Seurat/0000755000176200001440000000000013620617476011531 5ustar liggesusersSeurat/NAMESPACE0000644000176200001440000003560513617632030012746 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("$",JackStrawData) S3method("$",Seurat) S3method("$",SeuratCommand) S3method("$<-",Seurat) S3method("DefaultAssay<-",Assay) S3method("DefaultAssay<-",DimReduc) S3method("DefaultAssay<-",Graph) S3method("DefaultAssay<-",Seurat) S3method("Idents<-",Seurat) S3method("JS<-",DimReduc) S3method("JS<-",JackStrawData) S3method("Key<-",Assay) S3method("Key<-",DimReduc) S3method("Loadings<-",DimReduc) S3method("Misc<-",Assay) S3method("Misc<-",Seurat) S3method("Project<-",Seurat) S3method("Tool<-",Seurat) S3method("VariableFeatures<-",Assay) S3method("VariableFeatures<-",Seurat) S3method("[",Assay) S3method("[",DimReduc) S3method("[",Seurat) S3method("[",SeuratCommand) S3method("[[",Assay) S3method("[[",DimReduc) S3method("[[",Seurat) S3method("levels<-",Seurat) S3method(.DollarNames,JackStrawData) S3method(.DollarNames,Seurat) S3method(.DollarNames,SeuratCommand) S3method(AddMetaData,Assay) S3method(AddMetaData,Seurat) S3method(Cells,DimReduc) S3method(Cells,default) S3method(Command,Seurat) S3method(DefaultAssay,Assay) S3method(DefaultAssay,DimReduc) S3method(DefaultAssay,Graph) S3method(DefaultAssay,Seurat) S3method(DefaultAssay,SeuratCommand) S3method(Embeddings,DimReduc) S3method(Embeddings,Seurat) S3method(FindClusters,Seurat) S3method(FindClusters,default) S3method(FindMarkers,Seurat) S3method(FindMarkers,default) S3method(FindNeighbors,Assay) S3method(FindNeighbors,Seurat) S3method(FindNeighbors,default) S3method(FindNeighbors,dist) S3method(FindVariableFeatures,Assay) S3method(FindVariableFeatures,Seurat) S3method(FindVariableFeatures,default) S3method(GetAssay,Seurat) S3method(GetAssayData,Assay) S3method(GetAssayData,Seurat) S3method(HVFInfo,Assay) S3method(HVFInfo,Seurat) S3method(Idents,Seurat) S3method(IsGlobal,DimReduc) S3method(IsGlobal,default) S3method(JS,DimReduc) S3method(JS,JackStrawData) S3method(Key,Assay) S3method(Key,DimReduc) S3method(Key,Seurat) S3method(Loadings,DimReduc) S3method(Loadings,Seurat) S3method(Misc,Assay) S3method(Misc,Seurat) S3method(NormalizeData,Assay) S3method(NormalizeData,Seurat) S3method(NormalizeData,default) S3method(OldWhichCells,Assay) S3method(OldWhichCells,Seurat) S3method(Project,Seurat) S3method(ReadH5AD,H5File) S3method(ReadH5AD,character) S3method(RenameCells,Assay) S3method(RenameCells,DimReduc) S3method(RenameCells,Seurat) S3method(RenameIdents,Seurat) S3method(ReorderIdent,Seurat) S3method(RunALRA,Seurat) S3method(RunALRA,default) S3method(RunCCA,Seurat) S3method(RunCCA,default) S3method(RunICA,Assay) S3method(RunICA,Seurat) S3method(RunICA,default) S3method(RunLSI,Assay) S3method(RunLSI,Seurat) S3method(RunLSI,default) S3method(RunPCA,Assay) S3method(RunPCA,Seurat) S3method(RunPCA,default) S3method(RunTSNE,DimReduc) S3method(RunTSNE,Seurat) S3method(RunTSNE,dist) S3method(RunTSNE,matrix) S3method(RunUMAP,Graph) S3method(RunUMAP,Seurat) S3method(RunUMAP,default) S3method(ScaleData,Assay) S3method(ScaleData,Seurat) S3method(ScaleData,default) S3method(ScoreJackStraw,DimReduc) S3method(ScoreJackStraw,JackStrawData) S3method(ScoreJackStraw,Seurat) S3method(SetAssayData,Assay) S3method(SetAssayData,Seurat) S3method(SetIdent,Seurat) S3method(StashIdent,Seurat) S3method(Stdev,DimReduc) S3method(Stdev,Seurat) S3method(SubsetData,Assay) S3method(SubsetData,Seurat) S3method(Tool,Seurat) S3method(VariableFeatures,Assay) S3method(VariableFeatures,Seurat) S3method(WhichCells,Assay) S3method(WhichCells,Seurat) S3method(WriteH5AD,Seurat) S3method(as.CellDataSet,Seurat) S3method(as.Graph,Matrix) S3method(as.Graph,matrix) S3method(as.Seurat,CellDataSet) S3method(as.Seurat,SingleCellExperiment) S3method(as.Seurat,loom) S3method(as.SingleCellExperiment,Seurat) S3method(as.data.frame,Matrix) S3method(as.list,SeuratCommand) S3method(as.logical,JackStrawData) S3method(as.loom,Seurat) S3method(as.sparse,H5Group) S3method(as.sparse,Matrix) S3method(as.sparse,data.frame) S3method(as.sparse,matrix) S3method(dim,Assay) S3method(dim,DimReduc) S3method(dim,Seurat) S3method(dimnames,Assay) S3method(dimnames,DimReduc) S3method(dimnames,Seurat) S3method(droplevels,Seurat) S3method(length,DimReduc) S3method(levels,Seurat) S3method(merge,Assay) S3method(merge,Seurat) S3method(names,DimReduc) S3method(names,Seurat) S3method(print,DimReduc) S3method(subset,Assay) S3method(subset,DimReduc) S3method(subset,Seurat) export("DefaultAssay<-") export("Idents<-") export("JS<-") export("Key<-") export("Loadings<-") export("Misc<-") export("Project<-") export("Tool<-") export("VariableFeatures<-") export(ALRAChooseKPlot) export(AddMetaData) export(AddModuleScore) export(Assays) export(AugmentPlot) export(AverageExpression) export(BarcodeInflectionsPlot) export(BlackAndWhite) export(BlueAndRed) export(BoldTitle) export(BuildClusterTree) export(CalculateBarcodeInflections) export(CaseMatch) export(CellCycleScoring) export(CellScatter) export(CellSelector) export(Cells) export(CellsByIdentities) export(CollapseEmbeddingOutliers) export(CollapseSpeciesExpressionMatrix) export(ColorDimSplit) export(CombinePlots) export(Command) export(CreateAssayObject) export(CreateDimReducObject) export(CreateGeneActivityMatrix) export(CreateSeuratObject) export(CustomDistance) export(CustomPalette) export(DarkTheme) export(DefaultAssay) export(DietSeurat) export(DimHeatmap) export(DimPlot) export(DiscretePalette) export(DoHeatmap) export(DotPlot) export(ElbowPlot) export(Embeddings) export(ExpMean) export(ExpSD) export(ExpVar) export(ExportToCellbrowser) export(FeatureLocator) export(FeaturePlot) export(FeatureScatter) export(FetchData) export(FindAllMarkers) export(FindClusters) export(FindConservedMarkers) export(FindIntegrationAnchors) export(FindMarkers) export(FindNeighbors) export(FindTransferAnchors) export(FindVariableFeatures) export(FontSize) export(GeneSymbolThesarus) export(GetAssay) export(GetAssayData) export(GetIntegrationData) export(GetResidual) export(HTODemux) export(HTOHeatmap) export(HVFInfo) export(HoverLocator) export(Idents) export(IntegrateData) export(IsGlobal) export(JS) export(JackStraw) export(JackStrawPlot) export(Key) export(L2CCA) export(L2Dim) export(LabelClusters) export(LabelPoints) export(Loadings) export(LocalStruct) export(LogNormalize) export(LogSeuratCommand) export(LogVMR) export(MULTIseqDemux) export(MetaFeature) export(MinMax) export(Misc) export(MixingMetric) export(NoAxes) export(NoGrid) export(NoLegend) export(NormalizeData) export(OldWhichCells) export(PCAPlot) export(PCASigGenes) export(PCHeatmap) export(PercentageFeatureSet) export(PlotClusterTree) export(PolyDimPlot) export(PolyFeaturePlot) export(PrepSCTIntegration) export(Project) export(ProjectDim) export(PurpleAndYellow) export(Read10X) export(Read10X_h5) export(ReadAlevin) export(ReadAlevinCsv) export(ReadH5AD) export(Reductions) export(RegroupIdents) export(RelativeCounts) export(RenameAssays) export(RenameCells) export(RenameIdents) export(ReorderIdent) export(RestoreLegend) export(RidgePlot) export(RotatedAxis) export(RowMergeSparseMatrices) export(RunALRA) export(RunCCA) export(RunICA) export(RunLSI) export(RunPCA) export(RunTSNE) export(RunUMAP) export(SCTransform) export(SampleUMI) export(ScaleData) export(ScoreJackStraw) export(SelectIntegrationFeatures) export(SetAssayData) export(SetIdent) export(SetIntegrationData) export(SeuratAxes) export(SeuratTheme) export(SpatialTheme) export(SplitObject) export(StashIdent) export(Stdev) export(StopCellbrowser) export(SubsetByBarcodeInflections) export(SubsetData) export(TF.IDF) export(TSNEPlot) export(Tool) export(TopCells) export(TopFeatures) export(TransferData) export(UMAPPlot) export(UpdateSeuratObject) export(UpdateSymbolList) export(VariableFeaturePlot) export(VariableFeatures) export(VizDimLoadings) export(VlnPlot) export(WhichCells) export(WhiteBackground) export(as.CellDataSet) export(as.Graph) export(as.Seurat) export(as.SingleCellExperiment) export(as.loom) export(as.sparse) exportClasses(AnchorSet) exportClasses(Assay) exportClasses(DimReduc) exportClasses(Graph) exportClasses(IntegrationData) exportClasses(JackStrawData) exportClasses(Seurat) exportClasses(SeuratCommand) import(Matrix) importClassesFrom(Matrix,dgCMatrix) importFrom(KernSmooth,bkde) importFrom(MASS,glm.nb) importFrom(Matrix,Matrix) importFrom(Matrix,as.matrix) importFrom(Matrix,colMeans) importFrom(Matrix,colSums) importFrom(Matrix,readMM) importFrom(Matrix,rowMeans) importFrom(Matrix,rowSums) importFrom(Matrix,sparseMatrix) importFrom(RANN,nn2) importFrom(RColorBrewer,brewer.pal.info) importFrom(ROCR,performance) importFrom(ROCR,prediction) importFrom(Rcpp,evalCpp) importFrom(RcppAnnoy,AnnoyAngular) importFrom(RcppAnnoy,AnnoyEuclidean) importFrom(RcppAnnoy,AnnoyHamming) importFrom(RcppAnnoy,AnnoyManhattan) importFrom(Rtsne,Rtsne) importFrom(ape,as.phylo) importFrom(ape,drop.tip) importFrom(ape,nodelabels) importFrom(ape,plot.phylo) importFrom(cluster,clara) importFrom(cowplot,get_legend) importFrom(cowplot,plot_grid) importFrom(cowplot,theme_cowplot) importFrom(fitdistrplus,fitdist) importFrom(future,nbrOfWorkers) importFrom(future.apply,future_lapply) importFrom(future.apply,future_sapply) importFrom(ggplot2,GeomPolygon) importFrom(ggplot2,GeomViolin) importFrom(ggplot2,aes) importFrom(ggplot2,aes_string) importFrom(ggplot2,annotation_raster) importFrom(ggplot2,coord_cartesian) importFrom(ggplot2,coord_fixed) importFrom(ggplot2,coord_flip) importFrom(ggplot2,cut_number) importFrom(ggplot2,discrete_scale) importFrom(ggplot2,dup_axis) importFrom(ggplot2,element_blank) importFrom(ggplot2,element_line) importFrom(ggplot2,element_rect) importFrom(ggplot2,element_text) importFrom(ggplot2,facet_wrap) importFrom(ggplot2,geom_abline) importFrom(ggplot2,geom_blank) importFrom(ggplot2,geom_jitter) importFrom(ggplot2,geom_line) importFrom(ggplot2,geom_point) importFrom(ggplot2,geom_polygon) importFrom(ggplot2,geom_raster) importFrom(ggplot2,geom_smooth) importFrom(ggplot2,geom_text) importFrom(ggplot2,geom_tile) importFrom(ggplot2,geom_violin) importFrom(ggplot2,geom_vline) importFrom(ggplot2,ggplot) importFrom(ggplot2,ggplot_build) importFrom(ggplot2,ggproto) importFrom(ggplot2,ggsave) importFrom(ggplot2,ggtitle) importFrom(ggplot2,guide_colorbar) importFrom(ggplot2,guide_legend) importFrom(ggplot2,guides) importFrom(ggplot2,labs) importFrom(ggplot2,layer) importFrom(ggplot2,margin) importFrom(ggplot2,scale_color_brewer) importFrom(ggplot2,scale_color_distiller) importFrom(ggplot2,scale_color_gradient) importFrom(ggplot2,scale_color_gradientn) importFrom(ggplot2,scale_color_identity) importFrom(ggplot2,scale_color_manual) importFrom(ggplot2,scale_fill_continuous) importFrom(ggplot2,scale_fill_gradient) importFrom(ggplot2,scale_fill_gradientn) importFrom(ggplot2,scale_fill_manual) importFrom(ggplot2,scale_fill_viridis_c) importFrom(ggplot2,scale_radius) importFrom(ggplot2,scale_size) importFrom(ggplot2,scale_x_continuous) importFrom(ggplot2,scale_x_log10) importFrom(ggplot2,scale_y_continuous) importFrom(ggplot2,scale_y_discrete) importFrom(ggplot2,scale_y_log10) importFrom(ggplot2,stat_density2d) importFrom(ggplot2,stat_qq) importFrom(ggplot2,sym) importFrom(ggplot2,theme) importFrom(ggplot2,vars) importFrom(ggplot2,waiver) importFrom(ggplot2,xlab) importFrom(ggplot2,xlim) importFrom(ggplot2,ylab) importFrom(ggplot2,ylim) importFrom(ggrepel,geom_text_repel) importFrom(ggridges,geom_density_ridges) importFrom(ggridges,theme_ridges) importFrom(grDevices,col2rgb) importFrom(grDevices,colorRamp) importFrom(grDevices,colorRampPalette) importFrom(grDevices,rgb) importFrom(graphics,axis) importFrom(graphics,locator) importFrom(graphics,par) importFrom(graphics,plot) importFrom(graphics,plot.new) importFrom(graphics,smoothScatter) importFrom(grid,grobName) importFrom(grid,grobTree) importFrom(grid,unit) importFrom(httr,GET) importFrom(httr,accept_json) importFrom(httr,content) importFrom(httr,status_code) importFrom(httr,timeout) importFrom(ica,icafast) importFrom(ica,icaimax) importFrom(ica,icajade) importFrom(igraph,E) importFrom(igraph,graph.adjacency) importFrom(igraph,graph_from_adj_list) importFrom(igraph,graph_from_adjacency_matrix) importFrom(igraph,plot.igraph) importFrom(irlba,irlba) importFrom(leiden,leiden) importFrom(lmtest,lrtest) importFrom(metap,minimump) importFrom(methods,"slot<-") importFrom(methods,.hasSlot) importFrom(methods,as) importFrom(methods,is) importFrom(methods,new) importFrom(methods,setClass) importFrom(methods,setClassUnion) importFrom(methods,setMethod) importFrom(methods,setOldClass) importFrom(methods,signature) importFrom(methods,slot) importFrom(methods,slotNames) importFrom(pbapply,pbapply) importFrom(pbapply,pblapply) importFrom(pbapply,pbsapply) importFrom(plotly,layout) importFrom(plotly,plot_ly) importFrom(png,readPNG) importFrom(reticulate,dict) importFrom(reticulate,import) importFrom(reticulate,np_array) importFrom(reticulate,py_module_available) importFrom(reticulate,py_set_seed) importFrom(reticulate,tuple) importFrom(rlang,"!!") importFrom(rsvd,rsvd) importFrom(scales,hue_pal) importFrom(scales,zero_range) importFrom(sctransform,correct_counts) importFrom(sctransform,get_residual_var) importFrom(sctransform,get_residuals) importFrom(sctransform,vst) importFrom(stats,aggregate) importFrom(stats,anova) importFrom(stats,approxfun) importFrom(stats,as.dist) importFrom(stats,as.formula) importFrom(stats,ave) importFrom(stats,coef) importFrom(stats,cor) importFrom(stats,dist) importFrom(stats,dnorm) importFrom(stats,glm) importFrom(stats,hclust) importFrom(stats,kmeans) importFrom(stats,lm) importFrom(stats,loess) importFrom(stats,median) importFrom(stats,na.omit) importFrom(stats,p.adjust) importFrom(stats,pchisq) importFrom(stats,pnbinom) importFrom(stats,poisson) importFrom(stats,prcomp) importFrom(stats,prop.test) importFrom(stats,quantile) importFrom(stats,qunif) importFrom(stats,relevel) importFrom(stats,residuals) importFrom(stats,rnorm) importFrom(stats,runif) importFrom(stats,sd) importFrom(stats,setNames) importFrom(stats,t.test) importFrom(stats,var) importFrom(stats,wilcox.test) importFrom(tools,file_ext) importFrom(tools,file_path_sans_ext) importFrom(tsne,tsne) importFrom(utils,.DollarNames) importFrom(utils,argsAnywhere) importFrom(utils,browseURL) importFrom(utils,capture.output) importFrom(utils,file_test) importFrom(utils,globalVariables) importFrom(utils,isS3method) importFrom(utils,isS3stdGeneric) importFrom(utils,methods) importFrom(utils,packageVersion) importFrom(utils,read.csv) importFrom(utils,read.delim) importFrom(utils,read.table) importFrom(utils,setTxtProgressBar) importFrom(utils,txtProgressBar) importFrom(utils,write.table) importFrom(uwot,umap) useDynLib(Seurat) Seurat/LICENSE0000644000176200001440000010574713527073365012553 0ustar liggesusers GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. {one line to give the program's name and a brief idea of what it does.} Copyright (C) {year} {name of author} This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: {project} Copyright (C) {year} {fullname} This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . Seurat/README.md0000644000176200001440000000647513617623374013024 0ustar liggesusers[![Build Status](https://travis-ci.com/satijalab/seurat.svg)](https://travis-ci.com/satijalab/seurat) [![AppVeyor build status](https://ci.appveyor.com/api/projects/status/github/satijalab/seurat?svg=true)](https://ci.appveyor.com/project/satijalab/seurat) [![CRAN Version](https://www.r-pkg.org/badges/version/Seurat)](https://cran.r-project.org/package=Seurat) [![CRAN Downloads](https://cranlogs.r-pkg.org/badges/Seurat)](https://cran.r-project.org/package=Seurat) # Seurat v3.1.3 Seurat is an R toolkit for single cell genomics, developed and maintained by the Satija Lab at NYGC. Instructions, documentation, and tutorials can be found at: * https://satijalab.org/seurat Seurat is also hosted on GitHub, you can view and clone the repository at * https://github.com/satijalab/seurat Seurat has been successfully installed on Mac OS X, Linux, and Windows, using the devtools package to install directly from GitHub Improvements and new features will be added on a regular basis, please contact seuratpackage@gmail.com with any questions or if you would like to contribute Version History August 20, 2019 * Version 3.1 * Changes: * Support for SCTransform integration workflows * Integration speed ups: reference-based integration + reciprocal PCA April 12, 2019 * Version 3.0 * Changes: * Preprint published describing new methods for identifying anchors across single-cell datasets * Restructured Seurat object with native support for multimodal data * Parallelization support via future July 20, 2018 * Version 2.4 * Changes: * Java dependency removed and functionality rewritten in Rcpp March 22, 2018 * Version 2.3 * Changes: * New utility functions * Speed and efficiency improvments January 10, 2018 * Version 2.2 * Changes: * Support for multiple-dataset alignment with RunMultiCCA and AlignSubspace * New methods for evaluating alignment performance October 12, 2017 * Version 2.1 * Changes: * Support for using MAST and DESeq2 packages for differential expression testing in FindMarkers * Support for multi-modal single-cell data via \@assay slot July 26, 2017 * Version 2.0 * Changes: * Preprint released for integrated analysis of scRNA-seq across conditions, technologies and species * Significant restructuring of code to support clarity and dataset exploration * Methods for scoring gene expression and cell-cycle phase October 4, 2016 * Version 1.4 released * Changes: * Improved tools for cluster evaluation/visualizations * Methods for combining and adding to datasets August 22, 2016: * Version 1.3 released * Changes : * Improved clustering approach - see FAQ for details * All functions support sparse matrices * Methods for removing unwanted sources of variation * Consistent function names * Updated visualizations May 21, 2015: * Drop-Seq manuscript published. Version 1.2 released * Changes : * Added support for spectral t-SNE and density clustering * New visualizations - including pcHeatmap, dot.plot, and feature.plot * Expanded package documentation, reduced import package burden * Seurat code is now hosted on GitHub, enables easy install through devtools * Small bug fixes April 13, 2015: * Spatial mapping manuscript published. Version 1.1 released (initial release) Seurat/data/0000755000176200001440000000000013602476666012446 5ustar liggesusersSeurat/data/cc.genes.rda0000644000176200001440000000101013527073365014606 0ustar liggesusersBZh91AY&SYJM*H ?*@ݻ[ib&!OI1=!@jj&=Fh LM4@#! 4H4҃&i=Cd JHWI#'& kSmj'nKdVZИil1MT"Fy.D UF.7 L4P!hb@.UE]c`[[Q35\VdQp DYg9=XY*O>- zƀE߮!Pcvo.H'gI׸Jۺl|J i3 dh8IXcHfK$J/ YaU=9֥M |nR2,b_"iKF)B.$){-L5P"o?4rx&Xms)%I1,vǝ msY8/sgblv 9`ѯvE(_:CqUN)y!C?Ի,6 wə) A;{{GjIiDS4\AVEqK(82,zln)ʄ*Җ3DcK&*j#8b~L&lyf"Lk ^D Rɚo9 RAOL ˾hR!i͹kD24^/>} F߮b? 5..p!aSeurat/data/pbmc_small.rda0000644000176200001440000022042713527073365015251 0ustar liggesusersBZh91AY&SYd1> JIT] ކu}Lm7MCS`s =PZ5zgF)uW@(zv_@JPoi& ms}Tzep.ݙ VmL QAmmwp^=G{5zmTZ-d}{'&_yӽQ|񷍰 6γckZibųm ۤ];m ;5C8XZF6vk흍Rnp bovt=BE;wwn>at@P] |AHQk՘Z ;6 t#T֨UwWe˥+շ.ۗεv|woݺ]yy.w5:w[Z ɝO(EJe٩@T Υu۝J:Y,UT۸6#MJTahf+XF-M6;vkVl5k5ZM1i;n:T6ZͶ%FlE(+6{Ѧh4h 4hbh@@h iF`M2 CFddɈid "!`M L`10 &L@4ɐ&6CSiSzI)CMF5=0&&zh&zmISLSMOM506m$DBh4MOSLh lO ?DIf=d1hQCM4S2mL'LjzjliO&h4'M4i54O"zGI&4iɑL`i@)h 4 h("$01bOS؄ޕ?M4F4i6jjI(tcF}a! &U 9^3)XT.\4]@-Z@P`RZ9N,aCLxG,03o1XC(I]1癱1pp5r}냎4rE3cƖȽ,k'hgttf[e'8tlqg0n[_^M0j fiDYK*s1,ek3C»8DҡjUJT<*eLU5&8%Bp2cF.Pc|1n*W׍t/j;lL  ;* 4/ q˃JZz 6(JLj 9u˜3Fi[LӕZޯ<BziB`T6yq@ޡ N';I`0! "yML˥r+f6;;#Ѯfˁihr"h3rsAxɢc5l9e. vfbg2#"ZAi{"36t΂Ձ:C1 SBi 28 j5WU|ElBN$Ic\g #Eluts4Zχ\PM+R`{Wu% n=)f 5&:jfX EH881PE:;BSUA"5 s2oeՓktL䝭\ۦrߛ#vwz \gmnN[yH)kT)RG2eNdy!zׯ^zׯ^zׯ^wP`frR)/Yn[j{ѣ؈_b&ܡ7e^_[2SNTfԘ66;&`;333q70&Wݏv}(.08[(J&܂ťB;>RBK$hK8+[UlNjH,غ;1ٷSɴ)mrj0W./pK1Wan/m k~k]bedO St ]eN0eF)QEx))9Mŧ}{ȢKm+L\Kem0@ijDOSa*  yc'd)/;Q*JFZ3cT)<3!T^k>w -pF @R( {apxvqR.&`bMQ琅(j - n{|=+DE`O1#6sA]ШİX,a'[} XT-"%cAvi?qLk2crtxxNCWM}g;not=jQO>ÈVEK.Wپ-wf[6mAJ@_ TVk7C8Ynջxsnݽɧ_" e6ƞ3 ~kBO!&iB ~{N-?s=MMJ~uTU:]E x0qHKs[otȆdH)G 2st]UV#Mo Vʞ#-O, `(@~1`f̫\q?[j<џgrPuꔥ(oaټ{l~M6;L>߷۶AعjSM6;78)P??Ih }BtШ#}gdzx;u2.ixsミ ?: Ï@ENR"h6gWxx6Z6B* :(`B J匭ҭYE>TȡX 1+r?+jլLM6y?W"+##)嚚/s_q1+-`[:N5(8lnηͤ8_P,|\egXZ &'8B@1$%8lm ":7 K^㎓z_hW}Nh~rDm솱 zڵ ;҈vls~g|9Dΐ`6 HILa  2Gj2[{4tts%.ooozc ejuQQj6-f.暎OdF6pFL,<<;w#@_d (H0Xℯc8cŹ[1[.hpΟMK^4n^/p i>2PĤRn1rg9?Kk>;L:_B9NtMMm >S:GD0};n-07.chEYYREsnNPTk-G.]{6 . ֯_=$7MjԦjչ?kI џX8g ,$c!CCʺ;4,2PML2s{amlSʨrE2֡1:]3 2V>ļ{c(W:Kf-pKh #(4}x^]F> nNSٳ}|y7xqIذtDg , xM}b\nk00w0|/k9vE.W7u[ R.3 Y.nF>qǯ;B?/DcdIޒcwB a(+Jjb@j v23222!ɓW:I#xiJ`y,w9>/ @))ln;VSE5yg+vG*~CKHFfe(o\Nm<``<0cPZ Q,ٵ'}cqWnht@B aT +8(@i簒ռCc`vn8>.,#nvg\hLInkѢR˨99m/N#W5n Wt!xHb  Lf Mk}'Nn1Dbj!eKh{5_S0о{tQRR0ao2;slskY w C]/t5F(g0NbRԴ ӹxy y")ATn x?O#[B1~B :.: pz5?]`)Ie%9K R{[+[/;{#@ t)`ΦίA[2p4Bp9- F6_a]}.Ds(: TEVz倫wUuzw^zxޒCQRQJSN2Ԣ݃/JLls3}¸H!DsSB?%v5]GrjRRcXyx@` 0@F1)І?q-g|xN3]<^NH>k@nU.d9HKpA#Xh{k=`9994M=QF+{r @\W {u"WbBY"eBUDT R. [q<]=gmyܼ79;\y9Evv Z\ɨ(/f@9t1˳h@aܺIe+3 !SwN4hϼS Myo;KׯiD 𩾤浵ppjSږSS v~AuH3"6+6C" R&0X(atCpcQࠫ5Xí}J ``OnC.![~Mqp et  xqYy N7;Rֳ)sth:p`ch8( }Y.! [*}P'RN\;&mWUp/<--am )bEû po>?t9?@oG !AGǠQ vkƠuՆem;Ocj6{c? t9WR4h,l60 6N٭(QVp_S00D9 1)1'(c:*9j~ v.ZeL9=;'+8 aZ(L܍Q9TG)ASֳ.Yux#ty}v{2R)o,s Jv86^٭=]>}^zs9<.Ӑ[Żǔ}N2R)E)9*N?A++i}>sy׽?-^'()D>EHwYEB= %:唵-8uޫ'xY ھ{}s̊!T5J!#V\Ƞ3bc$ mY&qE)Pn[ RRZ)K;Ra'SאiV<w6WF.9S`ܸ=daCnKK` +CC`ETyivgH(ZHLC ,-ܷ`х9;mrMN9kǼ| =#n빟{v )1Kj)ZY`)>mOH7^϶;U^pV&ҍnIb{hpص(;I9mOledh<يK~{tl^Mm؟-$LH$@Kaanz_/_6֢n(ZsV㾷}U{ m h"A2Y )YIER-vjvlQFǮn+ko6550&n8qCkbRSڦTLbP?z2YkZ(Vj}N3]&kPأ4Q)Bo3 k!ԥ,ֵ}ʉਸ਼Von}&س 6)n..{Gg 0r1oyg4x-r|1DZoޮʑu5Ue +ak[-aɩjrRQNfQA8iR;=-/RmRJ7Դupp޿q&%ڦ2 h!F7QRѡڙ(XlS mѡKeXR5hRK9js14RFTK8 7h$E)4uNG5,KY[kS e0ooU|Z BYjSJ-kS 6;wk^ PRM*rXG+_ HpMl9L)RLש0cmWFզ5L)2 2jqmHNDACbLPAEQB"%% GXP,,[4pw5MO*{)AE R)J>eB((),DL ( LQVg)F-Kja0”-6qja7ZAL$D%$&z%" Yɕ)&V֥%(V+L !HT({?PHԥ0# 2O)jRn)q&ڔZᭇmL֥\f ژYI[{e|20÷ RTZ0+US e deKh0FT[ 0e ™up }ԦŖaMYkexMKeke4ZmOa&-n4mjx:4[Y6kSuޤp鼤l(4|-HY+]n׵0p0YZmS R IEMA+)5/C'%"8A_򾪒uNSk2ɢ깫en-bZakjS-KSqM&jyoJlz?R'ɺLj`ඞZ)E<&>9M[.CRߺ57k[9;^7[̑շakq?jhhao|T)htYe)C}adJRp_#kFZ}5Gqnl$h#R%ZhJsQo>q|u8Mť-o568mL.y6Rv6lS-j‘m✽=]5m9|)H([+um?%7ZaM [t&Tjr_mjl`unRJSe+[j}7[KSy,( ?@-BޓޯעE@N_ 탼w>ݿȆ}-a#.}a UUuYYW'/V ׀5^= pe"D'w|?Լ~sCCyp^V&!|g}9NwsCب;j.`uc{xaߢbɤ;*@bFEt%!#ב޹ yUvxHo1144])nPw.nFߑ\YMcN|eW58t*GejJ>yZ+k`ت==Tpy{a0_$XZyhڒ4dit^AG]]W""Z=yoP=U_V.iUo|JFFFO95767;9Yi:?Rx,m______Oීukt GYFƄ%'((dJGz|[_5/[KԋPÆ׹T]Jx()*t4#<+/*STbӘ:LǙj!p9(.EA& V1asӀ&Ez;`@}lyy&}byM5X@ -(1t{֥u|7m8Zfi9t"f2HgdHh> TQ@;o҆ki!x$agkmN\p] ܇W0 gnPJRRB+< ȓkj*>?7F||!dAe,dށ5.V5؈̦^k덄*(ZlKu4lII~3ƣS>d:&cc}RR +Gok۶$Sl-0 ICЉB%43pNdebmZ}m{hٙỲC8 98~h$J{&~ᢔ8|uǿ}*s G}3"pď~ag iDHO(e?ۿ:^ b L@ wPl7/hecQ"sR+J Ts1q3ȿ3jҪݙUWU^U~jf'}oz?7{z{{{{޽{ juGvǎ^F>bBgI|ǭZxo>7G'D=;<=t,p(G3?V7:FO"aB]s#4EDUU>y,"#CZz'_;߃®@<ᴗ"BpNP~"@:Y 9]ꂈiLQES $]ghi?.xȒ<0q:")F@0qVUgC*!;}g5!z/Rʁu蟍TQQCv&*#omېNï IQ'<j8tI/w~!(9 $JU DU ݤ $dHH@aA"RT*B B"!l&`*Q$tChb""'x5=D!N ~p Mjm?_ "#r" )" &)(U}DNI NPu.W;X[{jDNK" HҥP,T'Јsesčir(zu`Q4) ZjITGH,:sVI`\L0S$# GK@_͵MڻE0ns(Q"X"@ŜM<B{7EQ,Db #R(DX,BK%3Bm$;N d48g/T>=UMI @TKI[lk@hffgdkZdi4{eHϿDiQiچ״[V*_(id4]@ [;v[Ӄ]RB0 * dn2`.kk+qkWFm 6 ɪgmejFlayIg>N53Dnff[ZƓPZL6Z`Z湠kFX0h%p׍a3tai۟_ꬦ.C b2jClmM33Ldښa7hfdj5,%0ԓI04ЗQ*6M am[%5[ [\$Al5PCEbEv;᦯M5[ajUwb6 imM&-nuY۬&|$mPq NQ+OԨH/' +բPCa#H΃ѓVjY'Fiuφ;xnB*B0C:P3 0*!ba P.Db !p* !a x$WD8~B'eIg,R DOWV$"%Ǽz-D>M$$@E{laE`AK ?E.TೌB> M@}O)=HBL(D`aX E*'-C*4#'F|xQBD'OgOb(gܐ?=1Su'Ҥm}U,~^fu]HXk.BI'^!C1C+< @rd`A.O%")^q'=E@Tn0rQiȴ&WozHl2@}8mT{n8`Fo6)qOfKcT$nd= NV)IhID_x,%ڑa›D WC!ToJ!@}4k\k hvs=}0 D"kG  䣚9XPCǰr7@=!= ?ELmaHOP8!ؑP^;hOHI;D!ѤIB2H#"0ADT $YTAD`1B0I$P!V1BB(2 a$Hc $) EVB+ ! F0Y dQb#QAEDU X@F*$dY`Db #"* TXQ>L RER$3upƉlӽ?I>(,b'ly2􃣯P 6eJ!r^6ǣ`鐼@o1p"l*< rB_Ax3?0c"x}Rؒ));+$ qHu l42 Y_=N=7<΍߂V)D8ߺw?{/Rym'3QC =ty A'xAI M!!RNcqf{jDJj1.RH,}pnГyuϑZy5P5 r0;BHEf608,9۽I](@tta>I=+֧P h/MCyH!c y8lېg_eVj:Zt[K|'14jHIA׃WtCNFݐd!\Xrq, w3 88xV Ȍų.T"Gn1NXYB @:% ,IXS퓔CŇĞONnG^iY|E<3μLh¾$qo$];g|_'p>d*9yLum??^K<}/'u9T'H$R1I$hXyuJ_=gQOqw3\+P <{$=Ot2WsתtZG'o]8NJZwnQmys(VKʐZ2j/5asA,A@h[;]չ$!02RKx.I9GN !"b "1 `0,<2m)>w:{ :䱳 Q&?J-@'ʸ;oϺ0,`G-=Q1/j;ii>>AxzlM])JOvM_nTa fw(<9z@n&Ue%d̋;̜NS#b(OkBv:ܞ}JxV|]zPƍ#36 Y\ UDH!Wʾf 1qv dR"C7t|{kX*r 1 ljTJiz>@ .,cE :ܠm" e6yH %eH&G89/?J_,sPT\?%AB(:ёZa=Ez ;{/>wsUig(8V0 H0r1 ` mHP]B Q5CƧԯ3e)D/E+2&yѻ[d7zn:ze:O5:OIML Cǁig7-`|Z}DwHvPifM?l#dl+Ti^ H6z/wU}T!=\9Ѻ񴼈LD'EL'RI_wǣBO(~Yb:lݲR^ڐOf?V` 3tv S>7D&SM^y\F_t-Z*h@/#ņ]7#BD1𡐴_| ()Q]es}4Ȫ!VM״9<[(ԅs0ӫY|KLYa}.Nk94e_ {xZ^ɴ+=)#C3N鎪;.!UoKa0<>Pc;&ȋ[T/ &^ (Rאk 1,$ؿf *e7 PjMHwgv;Q?nAнCS-}tQ!C|sOal$8 f@x ,*[R-p0J"/}E>|F{9gNcM:jh3YрW;GФFbT8h%RN@ [=Gh`'Nhvmk`$ق0 g&15!sC2v! &j?\Dʚ)9 ZxKCWj!/j0mx2G9ccP:}f;U2~`裹e vq"^q1 BޕοkG}|܋/)@׷__Q<>=6F-(s?|<n>FC=su4!AM@;UWFJ\xL" 0qktQ bzS{Z_D%ID TOP6x=jR(' o#b dZb:Fl񭌭#eL$-c|Ψ]|`z.9&ھpBFnہ|^?AenAz8;z(e(hOe4IȨG^K|VLyhb,0*Op[DWGǥϊl STy~u5p Jp~$OQ`G[cR?nQl`O8lwLOj'z?\}k!'G?WlVݽoQN\٭eHt1x6L>q'$/7CBí΂n01_1O W73M swz E23 r8{^ҢCD5.b"e0liqo\ĸaəpph[k6S9b"X ׌ mnO"",Ề'(l 2GmD*xۛ 4ЂqocIV"ZJm^+,ex9 DJ.Nf T}Z~@The K)[{iYG6~m@ͦ(fbL3鵻k3Ty߶xEeJ DR_G{.)d3 XغDvCyo=K(<D~'Kg9 z8"(uW|.MD|G۬0JYbvҾAg/W.kn@&M( wMZY7 [uwGrTDZR8srU'[AZ2{.,CwD@0m \VtֺmvQ%#v_z` {I^`@!x{3GG`mE@"!fsTffeg |1COH'n`I)CCO_ב骁zL !_ ]!?)HdT9X]m4h~??_D@-s z4ݪ;ڧC HQAzFA0tmmS'%wL"jf˿t2@GXK۫u1-.=;&-nN' D8ږs+FX+,NG{L8pmêsMS!" Ƅ~X.#Y5ٴܽ_CUu@E {N˜i1\`O3l&*hӏXYN@ ^,YrWaW{i"=+!(72/naQk\&swWKG[i}`Ep}\ʝa=>'z.2X=#'QŒ"bG{HyOBہǞËĽ~ׇ`-bԇue0!nhhA KS6[^ɸmNSE#ꯨNy n~m0Q8\P)n} ȁ  >oU?2|M3ؑ Y(L+2 `GN#~qӶ #>=j0c5Ҽ%:\s-y@+F>wtt1HJgDmwꐦRA!Ts0b $jvB!8yD|vqUh'u'P—y+%6;rCAN .s65y̗sCynZ?eώȦ.wtTas>O"gqFmhsj;.o>`mޯv}śnyz_lZ2,0( QE^]QE^(&ET_*H|~_'rs9svO(uQA <I%E%BD _Q4\]6z IǾ"~3P?f#mD.&/ɒi5-YE(s~u@y^Ic29LꥧN?kmbT@Jy?fQ hzޡy=Y?{1Ph.!l}OXK,VjF8{LU-K*3OLQ*s?< J |L@0w\aT`^ۓz* x__r=?)e;(]RɒA3 C%9ox;[VϪo{s~w^X1/@p3^Z_o1UT_TғppEDKa.,oi@ @If@ada6Q8˝ŃO?')F'wĵcQ6p hmWA*:z&ٍĈu@LJĖGE}$N|%,PuE"X(XDN EPR) t!\PXSv+f͋|2ߴ#+wpYQJq*SJI >)'71#os,pQnnXH B/[Kq.Յotá.fC̙s< =8\}_ۆjƺь$j)3 n{[i*'hN p [px{YZ1/"D*ۯse}VoMuVT 96#_R2A & }ȝi}:m/+SdAkIHB݃aY[XLKi#%D9`Ic4`4 J%ȟ0@R~3pzdh4]4kv2n'I5;^4͑PӴkCLs\k ;RՍ&`w(lkUp.\F-sJkhn JQlFcgsi6֐nNefn $Mud w8ާ>*\Dt1FD2WM4)lpVv{;YWe%BKyˢ-g@O u[fri|4PХQ!+QBOP~ڼPC1 >i"""ͼ09wV0;tN-ĽK4cqOyU[7pܶ+g;ToAШt"^o10AhZVܛq.բ96 v5{pgog%_M>'!Hb :{51R^t^T"Y{xM >]EUew 0Z56?UU#̲@ ~[oLrl?wlz`@ MگIUl/9}eeÐuQ9loTۻri']R\1wcqp}Qxu (.34f;a1> EaFW&aݽ?`0W)ᝑP6Ja?)RH4i2oD mEyMxۄiKN ϓh3il5?m$p@I Qs.;݃[x~ͅao6)]{q-*;'aKX\Ɂ-}G):4Tr"&:U!;?՜e7w ϳcK5{/mR;ʞvႷވ%իVJ @!-̟KӦ>ٰ;wf}JG*%R[eV 08{;maD/%) R|,91d فؼ >+މ;?Δ?lz7:5%T4G:A'U/iwѾONJ"S)7'ŀPΜ N11~0"ID1XQĮF'!.sia߇OnzEЍ%[c~鄾 @* =N咘f-npOV[mwg@`t}߽}Ow[Kd)]JCˮć7ϻ>Fj]pP/3(УG| ;3Dt;xhg~,6+b%RQETeG<?(85DI7*Os]?szQ zf&ٴHBvqY@~&dq+ڱ͠hDK.?.$F"h7tl'q7ZzSW 8@uC?$LCqw :_1;;f֩󭻀*ߤ!哬Sʐo' MVw$]m\2?؏@Fh&6DM8_+ŷUBw' $@Y<|cNkVp͚36F^w.9g,S ٟR2a[8┭t^sI}˩ *6?(/*86mۜ;vqaXPlbXhGN/9;yμ#?s ~-?DܞgWkQY:ۼk^ˍ_W7/T9To蛫Vhj&x|>5;l2ZGΦ3됰q$&cqt,Ѩ/uRNrvRqy$7f4OПY.#%SgՖqT9ݒn7bX|pf?8lU[tnwpNG5Ay=# RbʃT"ry\m׋ޭq~31ZJ~<5'AH>=D46XD]kG59 ׹Ҳx^3{_!m]gy8_.mdg{#yˏ߻mh ̈Y|:C813䢒Dg>;H4d9"PA@!jU +!#j.79YPG )ŔkS#9~ͳ{q(7YZ3Wj٧;-ﺈC#Iwmߵ5bl&vWgc";ݙJj6e!%!F:S0*A)H12:UH0$frdvņ3mŤlM/6VJ|^` VTR##fMlcZy7ޓWm֛1XsGCX+2),b*+V~_3GƗZx>f&)/;͘pvX2'\}D>G1kZ%$ M4DP$ȈjQ1*B!fSW,k SKxI3:SNEnq˜,j(%1PIcN.]i2۸A0GDSSD+cA"<2R FhR<#(@o;H9j)A@xtM*M&YE䑓 "JVT4R6 LT-׆-TJeg%'&ѳ[}XX(+ݩ-_|*iaཱ. Z1@ *AA?I<@&j4 `Uit!8!hԉUHىF+VVd&{3 9 7 C|)8}vXw0kU-*ci2Ul6٥邍 ^v]U+snq89Wي[ٓ}'(By4bX3' z1f@f q[kLjN g%nf]h {`Pbd5P G/|1K~q{9w}A[o3<A;"E=@|ctĻp%f#P$'îtjSA6U.0p5+f6%4W|Zݹ0 /e3kv4.IAnV&YŮH*I3a'RX4MCaB3D;_Θ?Q;wM?.{+TyyEhD|0a(, ImJ(rrFʍo"G 40di=5A`Ζ:% O%F0XE*$ɃAPb@5* '8Uj@NU΂ E1nd粓>Ogo9 3P(f)3a)0A r P8ɪ)& WsoW L<1z\g9٧MFRCN_5jn[P6 uc@qaNm]xsBY>Pr3]'E@9h@&s(r)EŜ}'c0fGѶb{E4x)K)vT*4 ]b—SI#*b0 PQJ,1Zak#-z g6P: Ġtx7삭oۊqտ>^m׫=zٞc0}꾧[2?d=VqCv& _}豭V(tt:L_z֊ݦ۵EB9I#/s( $!8IR2T38W;msucs/mj֘0% iU`#K]`A jh'pX.UVQ \b.*-^$ҖrrJFljo@9slh.a%kwK1}XjL)k(:3Hp 'j> >n DE(Z חB( ʃ@qDA%-Ը3Î$3D VT?XZFoȷ=eVS`~\{]Rz$:_LG'&㻶V6B }HaDCDz&P ;qUCCe@[Nx|H%+#`QKR%I`4xM4kBpى/EPЉ\ :"=̱F  eZq O@H@$'LƆECLy݅5+ _?[?oʜ|;?x;;㗜^76xQ9ߺrX@79c(#$cV=$LY{+h޲ɚc4jm1Qc4XMpVͻ+T3v ܊$"XhF|ȵ?_tPYRլpr|p L&CPc5e9k*>w3XDT1 ;c@ݲE#1?GRh27g4;t:mn8+MI[p1yyu8wlĆf-h:BPOLHzד׷TL3;kJas,U@Y^"[5ܸ2.0&dG]yI٦ѓ`T"x3*Qvv2:VZ-gt #4U^l"iqFP=PotxOH .Ӌ|hM)3U0+ٖne'i|W9e'32Zl}&-s׸vՆ& xtg7ĉɂ3j)\ډ[]淲l^GEiEVk` qcYc?rQ5MYb5N=?!`n"6侈p}Ώnc>>p~3GM8+;[fY5~ rlG8 F9i]F8Bћ*Pky֬%%w:eDk;TCgdE)gr}8Ş4g4WMAD)^505#d %"x27Wf_>זal.>^y_V=ۺ~{o]DfEZxS=~݆ " _yz^F9OA]q}HD5mܼ))PV21--4-X,P%2J9D=+/cpnJ%/{%7 ::_Bq*ZaYD`Y"HdEPEEY")E$PQ`,YX((( dX,R ,H((X)UIX * PPd0"dY"5QdAU TAEX )dPP_N0(",%2(ER,)@REPP*L"ŐDA`"A@UőA`" E0PdF A`EdQ@ X`-2 (+ E X)1P@PDTH)* ŐPYTb`-0)"@XR$UQH(" TRJaH#,H,bŊ,X  bnd˸WI54;LJdYaVbb== OaU`t0Ȃ+4M#㊿yi޽^T%}DP~nt:r1|47KᶀXIe޸3j,\YT9W-:I.k|3C-^lZ/֏or dg@9NrTm;]A D*YӮO[_ﶿ[~EvAUIhKh1UIm2&vN<ãk]MTYeٻX0Jv3: j:!Gƻ"} XoRyn}[^Ğ)XI7Mqu!]᷿?0u=>'.ҶKI7y}rULs&K4eMٳT[5VB!ccW(hnp ,qJ7[又awIK?}=7vPY"),U,UP`dX( E")" ȱAEX(THjHUH"*b0Q`,,` RJVD`cQQHA`)` #AB") e(EY"Ilb"6<_jm:7ZuձU?y"im=?"kT2ÒV8^_]D͜V]_I;az(/{ي׏=Ru*Qtgb2@GP2Ls~WrH4YNb|E?hөa7*N=Pu -N6g=O׭߶y}DO&#R>qqw{TU_mļyts*c ߫W]ctųu^s/x׾_[ (J Hx41FpR4tv ^S æc8bH솱L̑19c y >gkvd>QE4i?3**^K$H"AAHXED XE @P(C3b?-t.G5wOdq5dX &$<"tgVfB 쟎$(X7L1 .U"cUT_֜|D!" ;f&~s eϨ]]Za%up:$h' b; o'}gWԎ1ߍ?[rfAz$/:#DCd]ѦzV8Q:ԫrv>;D?`a~|E`t'Ìp?2䣠<)wcp 1F7,oE%ϱ5^;n~#pcc"s @wlEnnygƓѮ)Ɵ!bC: ןF+I8Qmr3H`yI8Тn rhOZos9U`BiP>ax9Ju R0氡Mݓ7 1  l f:ɇ1̳ lo6 9h_L҂*ЇJɖ~̸Q9E8>=9ݺXr \7x04&cp̙39"l4s0  9f<\ZXe+szMP1`G54["1o{N8Xf k(]ᵗqPL9^X_Y~BΨ#^2Vn ̆^A q1rxŋw-Hw#0+DO*S`\U]l|n.>],FΪxLyh[\<5Oꏸ{> WV}W͕'Aba@UPD`G )"UU^S=Q{C#uYS6s7 b2#d çuw%r![6*ddȈGS, Yl/#3; aDUN!k ū2t\ ?)H+oxV~lsW7Vp3qc}6QYClhyɎ~Q>rVV&ۂͼfoIO!&@y`[\l9eOr7IsAKux039}>. jc"C4'$F#jVꐹfm46ZFG)EP% g*jt+~"5ce>{wpi.V1Jy}t1f8,s ,O@HZÉ?!6ji9I#|N8³O LG9fZDO،pN{d0֪w:s&>`N%ܣmTB^z)E&$fYA&5ih?./6 yXJ<;?eJk7,ܖ˜Sq`S7SN\Ob!"6nkաGEC|leq9u}{NB%hf!:>G-F`[N:lmzvh[+md8rܭqt"vscumڤ|>te7ЄUmAxen7b3H 4X'=(dлֻkߌ`}nAζ7o²>0zuO>FD*=^P< ΀5, )$XRD A1  w6gkŀ~TtW\ ]5SHbԅAOqPxԤ0/Pf|,`@nxaLK*_nf*6艮Οl0&1g}Gh41 + -YL:+7+ URum5M*lk;+33n vƹ⧇7\a3$$l;m?2jDk^vU {~Ht+[־V ؞:ֺ{ԪCGfC" ,; {MyRbxgGaop'-qY2YknB`T.-߄T5!,XNaANE/v=t8ʙ.űFұiРұc1<$nQrJĪumoӞLTņµlnn>":Iyϳ)qܗ/>n4[MMDcXCb8{gj;A4S 0_viqRvNQq>Y*rB) CD)Do[[8vܬ(hk=bȾ{/Mfȼ)9xlq J1@)}ndF1=-?;LJN$Hc>t]GO%35>Ss@~Y0/kBsx;A@1?̑<q 8X]ܲ3Jc}l~xt"0W0d+zssH6\T=w;OW>r9ӫMEDZ>U1^J&NStG > O`}z\^GQԝZTT{x^lI񰗘ld'eP≀mZj'0R`ӌ~Is), m^Gm*Ջ|u݃ !&MߎӭSn9CF@x+,t%FaͲx'*ձSgg%z bָWs^@tny=w+[a>wI=ĽڔE+%\*(9g`b1$ 4DTuG=ǭB+y Th-?wM]A#7ۺ}""Zr mF ffYUYؘY86-^q,̉އCl.B1"T0!2=K]d DF!&Q m)u6}#mAC}lU^PNN3i B0$LBR%p. !r&!\) Cȗ;yahjaZ !pf 塈fBP . \.!P}$i B CajȖB&lXp33 4uݩh Cl* PT* BhZb C\*¡pT* ¡P7aHlJ ¡p="lk֩Y_xߛH*ֵm {H\4C !P䡈T.!PT1 !e !. Q"\1 R&!p.ar&ab ¡pHT. C0=pgs<Oaihz AyP U=-T$vmjAYa_]jzͳMǥ0ES 7F]尞Bu?|7QvDaj! V@JEh)(9@K\(tP''x<SQGݶv`3߆0ajf xԷ"zVh$GQx5fD2IzR'H޻ \`pP: ,wDj#ML rP-nc}at=b1t:&0)1p'}ֶKocuʁƢR[s ذPCPT? !p\1 AqW3.BznBco*x$.(\Q2!L!P(fahT. !pZ !PT* afC0!1 C&$K!{bTdLbDi 1 !P1 !PZ BK!P3 ZBpT*\1 PT* ¡p\.!bB?4'sT8à aBP* dKafap0\*B~}ʹբgu*`tꚶ؛'8pPZXqaPa Bp- ș!hT*(\. \! $mX!ŮOWgEU/\7DH{Z5-\d@H9Dr}Ƕj=j*(`x{`n T6"{]IAt.N_jܟ"ğ&.Ǡsi1}^]u &#R"IpW:.SAH D@8!Ռ_ţy p9:ouAګ\7ސgh4f#=sVGTSk{KN77W^7sIRj [uI OP3{_wΎk A߿޺\tt@¢eL`!filV9Г#aoF]pT nͣ \}2MC2He?mb kHyT{#&f_viƷԌ* ^<՞66E6^gW'H&˃Ÿ'Ct.$y1l_H("e\.QhIh8ՑݐVgtj<.9~[#t7{͑T梳\)5?H-4'w4]JEE!NPtCԓwnClm4=l}J@?-'񂰫=ywӀm%Pt'zfÏ;;b5do^CVRK(4/OzO~6oO2ɫoF*x[Sz|pK=hY'nUzpHN3ܯ6p9#n3z@#AIRb7URq@W~6GӰf5T^T@E1w72rrݝ ~ F"vLer62 ;%BN/nf<\ӒEt3cx]" Xf*l0n ik-uׅg/Hu?;fm45Hq(4^1Ggx~l^P%==}rH.9hsfy;P~J Ej?AnJ]}=Px >xlΫ)4l7fY@*T<8d 68^6|5_ c 81 P G,`P+K@|=.9C~pysCV#m)O)T5`(2r ;;oҌBnˍoA#R !s̀NSxsYٽ75Xyq:&ͰS04<+Bvg7r*D7ּ̠ &239^EkGN0)~jڧLp1(o8W5JXղkL#g ;6Q÷5K|A]2tj91+>.AY +Q70F5Pj VH߯03]@ 3m,}-S#_|ʸ8vCO}x6wI5~OچeB;׊!'!!PuaY"? 5UY9=3^7Gjʮ{*C|qDVYlG!֟rXX !_πErI8x!,  y>Y( k/m>Sb}}Ɣ7s+r[&y[NvO]}e,ly,$b Dqx} κS#.|"R ]^5:]()llBS~D8ψaOҀfY?~Qzu:wbݝ*-Hn!}>ꓽ|U; @xflS^=?cʫwJ•jX+U}?N䝠 UB(ݽvTc5_YD\2;$+3+þMxkpk̀Mw/^R1K>lafz @b"!@y=y (7}7ygܺlc ;t-G'x˗'|<޹M,׷`;\;vcƹ6}ϱ;!>SKy=vN'l QxH _v zěL1y)ޞiC?l]_Ȱ!S6V`W `P$Bg9f.rx:~raňilg)m6z6פS W@ #/%ik#KH` D`@?J$֫ {G>F.屴"qf[>W ^5z|y䜪6>0—q gU"Y_R}F1ӾCmݘ =ѱ|臊F),vhIzBNv=kCR Sï` El*ui{Hi :YlJ Ƿ|/#hJdL(ӽx=Y_0lOGRqOFds9!a8vW1?gw[ O"_bC?C-̀`f ]_Cd0pkÂ]~a;^跩EP=BĹkpa 3*/{ØW,=7~TNe3N#@S{N"4G{}M픥|)R t6I>#cw˻-j!PdgdSJ5fz-We8@zw5鯹6*?>ŀ~.!?\kwC.z""!_^-Z+JwHc6:>:J^Z<䙴|0_dۭG57k!_^ߐvkl3FOЕxkA!p5C @b9Dg%gE1ČpSkeuVQN`gBq׃T- +dh, m{̚<_P1XԐo= Qz4iMB?sj†, =ݜzQ?N G69Cz#/uԪTy&)j'K$ @m6$7( T/Pp HIRqO# 8-Qe䛇'_52AYexb+ĵwNz=s}ZYS)EtLʈ@R.|7LҐ.|n CO5oY֐G9F1(Dp []~|nd]B mc00WW O7hMEĜjfc0?_[s>-++  ^HBl_7 ‹9aoYǖֳó$!|3/ "*G9d{F0244Ѣ_)ʩ o^npt.yMSn{C~FGn?30OOݥ-t>;~!g9%Qq" BYjxyv % o,8Jq{";]YE`‹3O=Df07>ԀYQΨv{6eK[a-tT}MqWiS>BA^0lsRG:ߐ"&j4C`-nc'f,^Y ![&lK@Ձ#YtXv~({-"T &d.*`Ȁ/+~L!yۿt 9 ٢}5^y-A۟}mԚF Z[mBН;Ug}ͧlDZkud,4?uFm:j3^2{%P`kn!s `&L@$ {Ҹy4ۺEem6T+K[:ƍcz^l|Ŧ/A`/_]2']ڿNv*ӜQOWY}06gJn?%{ob IgpPA߉5[b66};m2CtL@faƉ 8D42zH{mZ;-{%`?,>WHI98A'͐n=ۚ@`cG [YXyj_ssDD\6ggB+v.X`@!O"ppZÝ~m@004Txup揀CV P;4oyRQ%݅4N4. }-~2H6TbٽHh7P]H@ $x'Ozo?̡n]6all~}E˪/rgi@ 0wY|=3EPlq뷃&YLr˸ǿ%Jgԉ h/</ B~QG NY&A02Cl dN?H,^F/:iD g͟&/:#иqM[ ZW>'(4IHRTQHxۥ{3dhSvNie}<⾩6Ri!+l@)4\q*Wf٫b;lvɂsY)]=Fô泎]m.XKt잨E#d Ib5rOK/{Inڐ/K=n]M^0xym(âxGאbr o;4eߥ9Rr'I;\UU "@V |EeƚU8"P{]Ghxhe0hYS -_$n?u^0Epő 46 Y|E{[1 >NsVڍ!ntXm^ҧ}$M#<;z= n =ƸƫoGS//\7'txPϠ0ЬF^ONw~5UERH=Ɉ'$C.5N-xoi촿 ]YONo2zDZ^]x=a>D%'¤n}]3j=t+S.6D(;fƉ'|~~{'i#!f?74pʈ' u $C[HR,s$A0l歬s\O͊Ljq#op)uy~V@92"tHo@c@%)o:jtg)uwQa[*ӷ{=woo7a-zd9E4Zwq")HajչWXA..Џg=J,_CRuMu:O e' !TH:~+|/^n# q'H]]|ko[COYI$̤Yڣ) dX~KO-k]ԗǴ4;SWI ,,%e7 5m !vWi++q5U"~=IR6l~p9ޫ6} TXki$>HP > w' ḒnМ q=J*H(uiҨdLC:d _bmJÿm(_lU9qQ~kU)-Groν{8,Bﴲ/D:;~*9G>©У[NCR,ȰFfhkj+ᣤbq{N@QIrvo;cmF@DoQ=s#~T,T@.Ü3SϣC(eD0}ܿzt8P1m l*-BfNq~s2KuP"FM99vm/ "% s&k1͍"]Hm*H{-yܬ>f]Lʹ3ܯą'f{Ocwga8t;nG-Zw\bw-AZփ^ff`jW@6:7'ݪaC!!cZ~<'޻Ќ`,Xybp9z&}gTn=t{[b D1c L! #tt^/uV+7n(F]7r~+??6E cydɁnR:\/ı-r{yn(`4![4#4Lt~-L(HKOxp/UJ&g2ӂ_wm80"xɗvk<05zЧDv<€$pM=ˬ[u>W_T"@,qmKW/ET3m}G;VK\ט-}z(L|B;9į__?U4\Ujy0^A&=tM b5UyG_"Czh w:_fʍ) p7I\e`H1G(ďWl].='+SdFլ3?_IJ^[MBtD^@!/!dH;c&r~l eW;ko5ɍn;ǮpޥέٻᆯZCR)y"!򥻵*%թ>w1ݿ~7G7y[O8cUoZ>֢菌=Ĵu9퓣D3pu-.@yc]IĤ됵MҍyU/Οje[07 n.ucY!~=,EF@T@%_1ƥO^|z-c;# Ɯ 2$h V|d 8+b$mM+HA:ůH*]&Pb"<~22[䛇ӷ>*)v4Ġ62VȟQ3+>Uvu= c>48| '޽<6L |-@&Wdhd@Jm u%"wW} "aA;ܯl1[>[lz@nz2tv{= /Ox34O|nPB~g26?B꧉9v?s n g)?l^c =]FFOǭk>؍Dˍg$8ܥThDb tH4e~675G<7Ozsl?MhNq؄^K}b`{繙=◗(S[nr1Wl6{+.O\Fڱ%D9auDoYO,`w*"¿oc2 f/~:Oֹt-'іk_]/.հ>XyF"#_j}Z Alol1r0㊞bXF1YJ+a6%'K)ª+))Llj%Z퓺v8Ϧqa15;m [#m DDywߖxug(68~s鬀ؐe {z&e"\PgjE~GXtu].W~s%BSEYerˉD+ǧ2<TX^=_ ԦR]n.`1gL.)@D{C&xĻzUO:^W}ksv=^jv| Znn TA-"9<b_֩ +₊m򿞴jQ*F>ka:5Qj߯loF4d$ f!š_Q_g>\d\y>2c5UUds5Kjc_r\@" BdVZJ77Ϸ\Ys%WmU:!ƁA\χzw?_ذaVkS[EZHj %߷\}0@uEem{k ݵ"19hC[?]N(ڂ!z ?bIr,f 9_^J"zm/YGW s)!GΤ.q"Y_=O+ESwRz&`Éh @~r)k溤uO1ijXpvя.z69PWeځTQYKZb?ĘL@E)y0ެ0ZW} 96u#%z?RJ'Hk7̎" p˶w"~W3{ϑY~"/T&<|lk{ӯeĀ aa,F7]*M:+^yOȷLm )i^S/s>y`<E.~L%yyyEK9t`jk<5?wИc29W}s^a3W&oP{u3NhMj>;PN6?3½ἼܵMIy}|*"nD Aدx"kқ؝\!I׷b@l9}l8jt9Z91sUmR@ Yn?JI+vZ,FI k~RO1qig򍈭NN D$'QE9sx 1x!w_2mYvؽ~=N{2W #Y+ylJ ɢ@^wg/_KGq+UUԋp˕Ղ]w"qzwrB^[D[ DroX3`dq+H 5`3~ p^[ _>.PQnH"G=< '"*׻'&Gﵿ H{ύuhܲ`8DNUa)HS<SHPjx} :ZB9$ 'sv֍@\f9_:vڗِ\p@b\!ccF quqȈ. nw7UBOi?ZucGUAD,!`g;(FߜsIx,YS!}x>궬Hr ƂJ/Yui%Z)Ե-O[_lS5D2q@8@ T>c-i9'RFT! p_&p,DE&/@ oRQg(?9EbXȉM:{>OلZ>*ƐT!h4@Q@~6CTWچY}n* 'Hl_IaAqy]5ob}uLsؼ~6$ ?W G~jlF:x^"N2C$n7/(iMru?ml`}(5jؘU?LfPTpl1GZ KI<^cS:yl4 Q'{ڹ ѓ1[ة?|vM kK(#sCc[,Աk]jd ׅ~\/7{ ;lV[3GMW]g⥪1OyՍ]ݍYwW8~<:IʐAR$d HMP%Q46v0VD Pbf_`zJeHG#-ZUԭu`۬y0H*Υim?*xI#Wռu?P&ahd"()F!(@`R'ڮS|~ox?4#eZܚ$(T" wm[_N/ۅsLd(ȧH&8{Zwl28( vt)ܕUb/Yo m?y;`]Ş8r@00~ s==Z]jTxMN&QѧKqZwyOw74kA2D: " ȋB;u"N:7ϻ__W]t.p(E$$2z*gM. oHm?u<藮VUR®QhuWO&7IiQlUk Q5?Ӌ®P*`BTYvz(n7:бP==i*W:zˢ!]3T}g!×[xLlZ†{@A:^qIxGLGU#xhP$XE"/W&<{zjH/~)uy5J{>w,- ~6k֕I^NWw_5x2>mvSN3 L}<=/ᬈ*,˵b:-Ç} zV߾Pm,%oՂ))yF˒" 'x]u74˟"'tY`4ULo/Ua7`0vZi=eH@Q %~e#9 Hi}P{S8Iڝ`_HN$ MFؕUfPѮVt?KE|w.c33"..-@QHvAn~H4ZIZ%)wڅ>F(y)s1٧F)|E5Ehr@@yO_D3oINq[T3!D~+A LW5wEzC2t zֱ(Nq j@d'E gLt8|_z9Mtq$Ph- uBa{d˵@?U{:*UI5&dv#ܾ̒T3I$I ʍoʤ>u[:h8]*Tl祾|§xG۟4 )`sߎ+!", 0(~S3en @}cu2^៭~c& 59]Der޹ۊmW޹Yyz'&Rt{%qkb, q-Yt-=ky8UuÕp;lZoaӋ"9g}d< #g1 ? vsLyL]<Χ,[fƯ3 5g`'z Ujxu}7sZ}Gջc9;$^Z6_>ȴq5*[:kEs2Qk}/@}mk*@VL]ϧq2mUAMͥ4!EF9[ǜBb#ȀGV5 wnspqQN΀++̧](̰(葎ݨ#<>*}51M4e{η86 $   vSrkjZZܨw~w0~{KVА3OUc7b~&}»R) $ 'o`j;j|Кǧ@V]u4(W·I8r(d<ݝP>]N7/p/R=p?K F[ 줕KRQB/mcT&KP\Լk:3n.eҟ^ƫĻ !݀DeIS7H\LO dhXj>'"AFrHg]xXH@:N9Gc\öxpCڪ6&\EUo&2P$3E ""DaR$P" fA5 @x*͝+,5j@l׊N>fK۴:Q7U"XQBc "H45ڗU7i6_(u92 'VX)Pśfj&o?1 

wHcvQLWYc 9-v!J]t)Y 1uPg@dճJ̪҅,ʕv$2P&i]~~B6,2[Q.@X?d| N;[g@ 30.rm]k.`Um :o J&$_=\AE1iTꎷygpflzUZ" xFk$~ԁRjDT'Igs"RmUDTΚF8Ԁ)JGewKsw=uf{T`Oc`Zy`gY֏?ǒjHs- NLbts@m94U8Ƣ)b 4OYx~c*mX\hˡatXU ٔ譴bL$!ַ&l`0nj"ko\gzP({DpCW2OI/OW?MZ<5t(mɿ{"0X0uɯ5-盱 ]h0+jt]0$4hD1=bo3"&rcT_khb7Fq*YFOj{] ":K]m^9Da}f#0>cUy< g&Վ97 n{FU>6Su)}^3 m=,Ung-Z@d D+2/ؔ45;.ESu;{Db")Kz@5(oT_'w㰾e?L Yx}}M%uVi+.<(xj#C@qHCDN`v֙wliy9_eȎ QyEg҄ 6}3l!G? QF WOj#2K7~haCP|KҪ} S>_]8 R)(uٗR(ѿ&*r }G==LP{UtBfu!B8㾫g!cN>ɟ,;Wbv.~HE^K֙g菍ke>FtC~'1 (6 c ֢{qvv+FP@ bҩQ-ﵥnSW-s2pƨ=ȇ sb?{PMaQң5Ф@"7l;LqèwXR `CFc~7l.?X<ƣM+#W&;%}m`dJ$2(1ZL |t~D>y Ta2wݒ zUހD-_{MKN 6D9A&-[VY'Ga$onc0_|:ֳp7O5X ++b-^B[+9˓ԀDM֨v'~q`vv@˧Vw8j|)n1CTL;P?P?J>;})i'•^ZZ~oxش!db?> 'sB; EX 䡂QxPXY/G'}Nʙ"FO_F+1 0Cr*م=,>QA=ƣ7mڡ3)>v \'nZm6O( > oVm"z)C<4vHy8HMWMbĊ*o.huHs4*_Z"Y4 9Kܡji0OD{(/`@@:EzE8N*Mfq<~̦F& kr͉&&R™A>*fJ?$ǜx[RGڇ^a,:󈔙G :\HϺc{x.cߍ J0  Kf@3xuzrni}aLhޝ`8Ӫ,Lzl9Y MYÒnW=ykZDZRKnv vR _K'k=d=J%#W6MIm<wgO;z'#-Q@  D -sLpS}]gU5܈oR&sEl Op $#V;]e,dZ{lG*S;Mm$WiYv x"Ѯj|IģY߼X5\ް-WpowxfBiz+ն3moЦۊ8e{+;Χ W ڿ<9s=+/MӛzX1GңZpؖ] J~Y8sa9˗SnPJ|ޞ.ej2G:rE6kS\a>1܆w'{r|,-5K8 E5B;{>{gϏWiٿ8̇Egt >6ntoCM“'R}u%Rt(:d c`е<4庚T.w4YedQe7.72blz.u /#VsXLL[_ǭWuujm|nv%JY_trʸ^(Ⱥin'&%a3rf/{:̾հ`uyռ?u &W T g^ćǃ4,|Ml΢&=R=NY`Z3[/=kynZ~gޢՏ8G:abb1@X?{}@k!Czk-0 qX' tt 9H<锁FK8HۛBXy+^甥/9ڏ2@?$.6 d-E42/4+{\""0Yg{8`1yysQȊBcin}+x`@Fx]IR;VScw۸l% d72O-o[_ۣt֯R*1 RumWfG:l``EBb"ju/c>;7q䛤!Cž.Nl.C|W u}( /Nc s[~KG|8U*w67saza b(s-ҾG6%YG/>F8ѢOwKv1@D5†7MI8~QU谦 L`1q h~~F PJ`p=#[lu{Է2_E3/id|;Zew/ӡ!;Nܬg_b:dÍ%CiCo2GeYur57襘VN5{M΋H'fxju^vO5}\RI,SE+k0\ӟ/Qq\KQlImSwi~ir{ Ŏb}֨js\i?M[yjqԬFZm緍xRvh?L. <zƿ\'ؗ˻/O`| . _)j*+&x֬'Mr9yUHVDžb/I])/C3{0 ikZf2:z-m}ƅY?|&_ص\XP{di1=Qh2o0K^RKy\C| tL{c8?9jϮQ\gx.܀jΤ,R$"9JARZd<.<:Zb|)Ӕ =D98a8 ?ja/j#82WA*ڽ_mA [y"tw&2Vz|nu+"VsBԹTރw@])Nly'g#D`zkϸ㴣feؓ*q4B7QYT?Dϵ]MP{4s'G~ڨְ=]UkY(zTN6@[,Р[ql!Ȥ/ЀpTg^4@~T ľ,1Iw5eq30ڒYpJ^JL*S!Ǥ%:dD3aC$qSA$YV3g!xԩׯ'P.5cH>a xP̗͛fY$'d4Pq4+B}AbpbОHv֕:9[pR ')QD jی#jDSrf5o/"!5 8Рm:M1X3h;pLohKzi|m:Z#JP|IJhY4%lRFb+~xl\>eP ?sҦgۚԺ&cK4#mA+i3ț6^/5)uu%-Q :f^!O<>PiNԻ+q@<ʽ^ġw'Hw9>7 #]͗q~:9cC/*XN!Iu&,6(ӨyM`O$-|*eZ#tpѧe /넾ߨ-v@ɨUIWCPU"q?4@eͳX!mf <L?xFD  cn%GE.IL"t!>2eYH=[Hj6nC MD J=Dd^̚/dp1 0ORj@ ,@) Z9KϿt4$%3~vr4LPڴTB}gEZ?]xQo6Z4CUW&}tAt ^/<&_a-yH YuP+"W0iHwhpTeэձ}l:o`:lla$m/ dVi`{ 9˚gѣlghM]^M>+<̛kbR*fc2(}869;)m0Pp$?8g" M{*F_5iۙ$ʤAa=YTh#?Xs b.}[]p 2":9AW8B̈3f.+5,dlD& O\/LqaKGK|]ut^^,ʣʣ?<|Ra$XB)uh~"E,Oz,Q?EwIfd7"rN:nLi<OAh0jTg&sc6mp?{J{ H%QTH@ٳ-c9mUb^nEfl>YqW3 *%kd:1Jv.䈀 #oL@?+Im ~GExh)lz҇2B K\p?k_oiKa{F8o0Rs_ox\6 ,gR|U5fVp L|ڲJ@gج7w s`kMZ5eXC@'ϞVUȪ0YĜ-[j`鳯$ ETR%S@'c(}(t-`jqVxKb5 2zǶiA8 GT*L 2jj\ldA t#o7KÕT.i'9U6bkN.u9[  xvD'CwE_*PC'&bmOr((H6r7eR><1La~e z_qy[3Vīsg>gkez?D?׿=EqPrp7x*]D{(n#P%-k ^%[A<< S`/ಪt >'0&U`bıgs HO#pFZuW%H=7t{Ș.GMaeKe93H"z0"MṾ`ʢr {(\Rx)o1}ߗ3P C7[J3yj$7T݃V!J*ma@i3o@3K]vD b7𢦨[$HnY + wpGZR!A¨) >|9 R*6:a>[`t(ڱ6^7ԥ=?Nҩ! 8zBspDlU DK]R{zEsBfbh_5sN 'bZf>.}e.bޒN5ӈP0 d؅&F1tjAjCŔo|З %ќd),U5VDWҸyĩGwihz~eU'= |2υ\wܺ-؉pс(=/iiQ||l v0G p"KđPMDOdF1H_XC\v/;Snp*e!0o:W3h7l44T4.`#9NhY`eg}*cPu#8Zc{EO \8is-[-"( :8ǔe ~av':m۞KDT 7diإ(?#=F$$$9`"Ŧea<]qS4ws)Kx*"0!2ߕYo v(KAdedIXmPW% s{ď3j5=xqIdk-k/g֩^R=&%@,ݸR"Ҋ3jz`QJ׺x^Vur#  T3\@Aybئlbw=s I|R/[dp9j6_rs44&PnK)} ;O۱}809YeYfyœef%@1a[LzcV B;DCG_ y]fQI|\3s#Aa9Hq^$ kY3c^|7<o\FF=/=;@CI QN\c":fƣCY|\ldSF O?urdt 1@b"6SU~T@awD?Z=$ #Dp\,Q8mdHQ&t˸) ǵI(&ZV*rJ~ː"mRycID bw涮z(wT` ˼ !.$I{O!A)V#u(0HNGnya>nzf7ԆU:Bh$:J9?c)?/ cnmivU@K2 U&-=MwmʣǜUI?~׵%L$RY\ח<Lf><._ z߬)" nLV1E_ѿ9 ;:ztiJw!qv s@p 6Cbi)%U.(, (3sfާH ^EUB/39+%v߆.Ti8*[W M@ |a%?aӘckm*rGģjk4=]<c%g}-323=pD>V94ٳx/:}Ȯjm1+Kc b<&M0O= tDxDf+AyNd'B&0lSw| uRz?ԫL@PD)-υ78ٗDַx7itfT}sH_PjuzǨ*yvEP)$ʛ}cZaJe;~pADK]Rr%y=/Z/CդTGo (g-vzYRnե 4`D!? MIy.??yR!9M[LLp3M|$V@#oϦSbɖU0/8;>I'D9鲤7]+lAmryICչW$`6 V^ $߀))g?!%Xλy8'͇f^o2#ۿ{"(0MrާУZ=TBnt$I˄QN,_ #S/2پZnJ%ks `Kqat &%m'A겜}ot`|>R {QΊ>u5%Mgd*Fc52;Xj#b@ {^*WMcGJs(!4&!#BHPД uD| ^[dˬѤesXpr.";&8}IzFŮz %:9D y̘D!_{'9dFQ"KCs$"o:{*\RGI! Yi'A;zUFHj32+k#@7b7|,QUxC7T#2^W䠈'Å.!4mM:家qŚi\bH"'&N6"#{Ov2RH甔$0HXzGSFڨIaN7rG` ]{_k3u,=/.E&rIc DFMwNȷ C*wPY zbׅsW($]:?0's5/SVd܌<" Z?S F1-"`C AF c ^c*ϊV-8``n` Q+ CKvb@Z^ 4 Z$FQ|(d$Yͽ$Hz@"7-<7%2akU>/gG0FBXF7h=o~ &H3*ia<<"rϹ{S} 7|S9PK%oi %^7;R 7yRD ɻp!&`,!dAߝb}YCq=`Za2Pޕ5$5g! *^Zij Pq$2[F j`W eFa, q' f~Z>lerlGUHaR:^p< n9-^<|JZD~?Q1zn]3tgWHk%̆T|ǭY1{*X7} Vۧ rKJ@vNLQ 0W F HcP{'(o[&^!um~L.q%?Jb=V/f?f#+tRlo,/?*k]Қ~fFt|*7hjB  ZhLt 6y(W%\ ]ptA+ng ɶ&O26D@k)YS!ASt)ViqR4/bxf~4S{ஹI1#lJGހ {LtGۯp5* w;`wS6jMz+8baI cN8.J^=UFpgF{JjmuRO"hjhDtV*}lpD1:W0-sǒH'-@?s苔tx2)a3zP_* >^ ƧY:ê Lq,.Ix ̅eL,tg2`oedέ@`z=@ 4^@GL蒄L:Z1E yZpaG+*{dp9n<]ǣGԨy369+QX3^ y;MA{bܚE&n-Nbr_xU/%(Tk2ۡ֐+ mnDJ3 Pw5{ƚ'EUwN_*N<z;V PRk\&*1ٞD(v]n#7|0YbN<۞wH00~i;5V #=8\ Kq$@d6":ɍ93rO^ߏRTΫeئ  m#ɰAiE #P̝4I\e. *|G'-z{΍E1r*}%<$4fF_`uIJ,dZu_2fǰ)w ġ\g76{FJS҂Rf:5Cy1OcVsQI?& /JK֯*!铸0s ;t@Jӷ.1}xMZc |f1;r J]7b/l7ٗ7j:i nS0sE6o=) Sg\h؎9QgTS"@/e3f/?~|g57JH gXP42]7[ ZRhLs6%Sgp..9!Mej=" 6;GŦy3Q@7 7QsVZD І6GߴFE-چ M3? vH[u2]̀ H6w&44 b9T|tKq|8Fed;'{Q2g6h|WBHK:yNUA-|} $6 oxPE)d 6P~@YsDAS̘|J=- R5{+r٬ۚ fN8vc9Lvѿ]Sd6@wB>+u^)c5ߵPZP[ps`nړ5NE_ !2X@ ʄNS4k^͙ؓjг'2?凇*Hi>H|glwau `dE G<ʛ녋U=3#( oy FLQѐ3nX*,N݇!$֞1)\U>^VijثnEaP7T)eYC57oʍk;~G$0Ѐp Oߜ.JUݴ5@ 80jf{AAE@9I.!-(nv&ʇ^ۛQ% (= 3.0 with multiple data types data_dir <- 'path/to/data/directory' list.files(data_dir) # Should show barcodes.tsv.gz, features.tsv.gz, and matrix.mtx.gz data <- Read10X(data.dir = data_dir) seurat_object = CreateSeuratObject(counts = data$`Gene Expression`) seurat_object[['Protein']] = CreateAssayObject(counts = data$`Antibody Capture`) } } Seurat/man/CustomDistance.Rd0000644000176200001440000000146213617632030015510 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utilities.R \name{CustomDistance} \alias{CustomDistance} \title{Run a custom distance function on an input data matrix} \usage{ CustomDistance(my.mat, my.function, ...) } \arguments{ \item{my.mat}{A matrix to calculate distance on} \item{my.function}{A function to calculate distance} \item{...}{Extra parameters to my.function} } \value{ A distance matrix } \description{ Run a custom distance function on an input data matrix } \examples{ # Define custom distance matrix manhattan.distance <- function(x, y) return(sum(abs(x-y))) input.data <- GetAssayData(pbmc_small, assay.type = "RNA", slot = "scale.data") cell.manhattan.dist <- CustomDistance(input.data, manhattan.distance) } \author{ Jean Fan } Seurat/man/AverageExpression.Rd0000644000176200001440000000321113617632030016207 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utilities.R \name{AverageExpression} \alias{AverageExpression} \title{Averaged feature expression by identity class} \usage{ AverageExpression( object, assays = NULL, features = NULL, return.seurat = FALSE, add.ident = NULL, slot = "data", use.scale = FALSE, use.counts = FALSE, verbose = TRUE, ... ) } \arguments{ \item{object}{Seurat object} \item{assays}{Which assays to use. Default is all assays} \item{features}{Features to analyze. Default is all features in the assay} \item{return.seurat}{Whether to return the data as a Seurat object. Default is FALSE} \item{add.ident}{Place an additional label on each cell prior to averaging (very useful if you want to observe cluster averages, separated by replicate, for example)} \item{slot}{Slot to use; will be overriden by \code{use.scale} and \code{use.counts}} \item{use.scale}{Use scaled values for feature expression} \item{use.counts}{Use count values for feature expression} \item{verbose}{Print messages and show progress bar} \item{...}{Arguments to be passed to methods such as \code{\link{CreateSeuratObject}}} } \value{ Returns a matrix with genes as rows, identity classes as columns. If return.seurat is TRUE, returns an object of class \code{\link{Seurat}}. } \description{ Returns expression for an 'average' single cell in each identity class } \details{ Output is in log-space when \code{return.seurat = TRUE}, otherwise it's in non-log space. Averaging is done in non-log space. } \examples{ head(AverageExpression(object = pbmc_small)) } Seurat/man/TF.IDF.Rd0000644000176200001440000000126513617632030013476 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/preprocessing.R \name{TF.IDF} \alias{TF.IDF} \title{Term frequency-inverse document frequency} \usage{ TF.IDF(data, verbose = TRUE) } \arguments{ \item{data}{Matrix with the raw count data} \item{verbose}{Print progress} } \value{ Returns a matrix with the normalized data } \description{ Normalize binary data per cell using the term frequency-inverse document frequency normalization method (TF-IDF). This is suitable for the normalization of binary ATAC peak datasets. } \examples{ mat <- matrix(data = rbinom(n = 25, size = 5, prob = 0.2), nrow = 5) mat_norm <- TF.IDF(data = mat) } Seurat/man/RunUMAP.Rd0000644000176200001440000001660013617632030014012 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/dimensional_reduction.R \name{RunUMAP} \alias{RunUMAP} \alias{RunUMAP.default} \alias{RunUMAP.Graph} \alias{RunUMAP.Seurat} \title{Run UMAP} \usage{ RunUMAP(object, ...) \method{RunUMAP}{default}( object, assay = NULL, umap.method = "uwot", n.neighbors = 30L, n.components = 2L, metric = "cosine", n.epochs = NULL, learning.rate = 1, min.dist = 0.3, spread = 1, set.op.mix.ratio = 1, local.connectivity = 1L, repulsion.strength = 1, negative.sample.rate = 5, a = NULL, b = NULL, uwot.sgd = FALSE, seed.use = 42, metric.kwds = NULL, angular.rp.forest = FALSE, reduction.key = "UMAP_", verbose = TRUE, ... ) \method{RunUMAP}{Graph}( object, assay = NULL, umap.method = "umap-learn", n.components = 2L, metric = "correlation", n.epochs = 0L, learning.rate = 1, min.dist = 0.3, spread = 1, repulsion.strength = 1, negative.sample.rate = 5L, a = NULL, b = NULL, uwot.sgd = FALSE, seed.use = 42L, metric.kwds = NULL, verbose = TRUE, reduction.key = "UMAP_", ... ) \method{RunUMAP}{Seurat}( object, dims = NULL, reduction = "pca", features = NULL, graph = NULL, assay = "RNA", umap.method = "uwot", n.neighbors = 30L, n.components = 2L, metric = "cosine", n.epochs = NULL, learning.rate = 1, min.dist = 0.3, spread = 1, set.op.mix.ratio = 1, local.connectivity = 1L, repulsion.strength = 1, negative.sample.rate = 5L, a = NULL, b = NULL, uwot.sgd = FALSE, seed.use = 42L, metric.kwds = NULL, angular.rp.forest = FALSE, verbose = TRUE, reduction.name = "umap", reduction.key = "UMAP_", ... ) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods and UMAP} \item{assay}{Assay to pull data for when using \code{features}, or assay used to construct Graph if running UMAP on a Graph} \item{umap.method}{UMAP implementation to run. Can be \describe{ \item{\code{uwot}:}{Runs umap via the uwot R package} \item{\code{umap-learn}:}{Run the Seurat wrapper of the python umap-learn package} }} \item{n.neighbors}{This determines the number of neighboring points used in local approximations of manifold structure. Larger values will result in more global structure being preserved at the loss of detailed local structure. In general this parameter should often be in the range 5 to 50.} \item{n.components}{The dimension of the space to embed into.} \item{metric}{metric: This determines the choice of metric used to measure distance in the input space. A wide variety of metrics are already coded, and a user defined function can be passed as long as it has been JITd by numba.} \item{n.epochs}{he number of training epochs to be used in optimizing the low dimensional embedding. Larger values result in more accurate embeddings. If NULL is specified, a value will be selected based on the size of the input dataset (200 for large datasets, 500 for small).} \item{learning.rate}{The initial learning rate for the embedding optimization.} \item{min.dist}{This controls how tightly the embedding is allowed compress points together. Larger values ensure embedded points are moreevenly distributed, while smaller values allow the algorithm to optimise more accurately with regard to local structure. Sensible values are in the range 0.001 to 0.5.} \item{spread}{The effective scale of embedded points. In combination with min.dist this determines how clustered/clumped the embedded points are.} \item{set.op.mix.ratio}{Interpolate between (fuzzy) union and intersection as the set operation used to combine local fuzzy simplicial sets to obtain a global fuzzy simplicial sets. Both fuzzy set operations use the product t-norm. The value of this parameter should be between 0.0 and 1.0; a value of 1.0 will use a pure fuzzy union, while 0.0 will use a pure fuzzy intersection.} \item{local.connectivity}{The local connectivity required - i.e. the number of nearest neighbors that should be assumed to be connected at a local level. The higher this value the more connected the manifold becomes locally. In practice this should be not more than the local intrinsic dimension of the manifold.} \item{repulsion.strength}{Weighting applied to negative samples in low dimensional embedding optimization. Values higher than one will result in greater weight being given to negative samples.} \item{negative.sample.rate}{The number of negative samples to select per positive sample in the optimization process. Increasing this value will result in greater repulsive force being applied, greater optimization cost, but slightly more accuracy.} \item{a}{More specific parameters controlling the embedding. If NULL, these values are set automatically as determined by min. dist and spread. Parameter of differentiable approximation of right adjoint functor.} \item{b}{More specific parameters controlling the embedding. If NULL, these values are set automatically as determined by min. dist and spread. Parameter of differentiable approximation of right adjoint functor.} \item{uwot.sgd}{Set \code{uwot::umap(fast_sgd = TRUE)}; see \code{\link[uwot]{umap}} for more details} \item{seed.use}{Set a random seed. By default, sets the seed to 42. Setting NULL will not set a seed} \item{metric.kwds}{A dictionary of arguments to pass on to the metric, such as the p value for Minkowski distance. If NULL then no arguments are passed on.} \item{angular.rp.forest}{Whether to use an angular random projection forest to initialise the approximate nearest neighbor search. This can be faster, but is mostly on useful for metric that use an angular style distance such as cosine, correlation etc. In the case of those metrics angular forests will be chosen automatically.} \item{reduction.key}{dimensional reduction key, specifies the string before the number for the dimension names. UMAP by default} \item{verbose}{Controls verbosity} \item{dims}{Which dimensions to use as input features, used only if \code{features} is NULL} \item{reduction}{Which dimensional reduction (PCA or ICA) to use for the UMAP input. Default is PCA} \item{features}{If set, run UMAP on this subset of features (instead of running on a set of reduced dimensions). Not set (NULL) by default; \code{dims} must be NULL to run on features} \item{graph}{Name of graph on which to run UMAP} \item{reduction.name}{Name to store dimensional reduction under in the Seurat object} } \value{ Returns a Seurat object containing a UMAP representation } \description{ Runs the Uniform Manifold Approximation and Projection (UMAP) dimensional reduction technique. To run, you must first install the umap-learn python package (e.g. via \code{pip install umap-learn}). Details on this package can be found here: \url{https://github.com/lmcinnes/umap}. For a more in depth discussion of the mathematics underlying UMAP, see the ArXiv paper here: \url{https://arxiv.org/abs/1802.03426}. } \examples{ \dontrun{ pbmc_small # Run UMAP map on first 5 PCs pbmc_small <- RunUMAP(object = pbmc_small, dims = 1:5) # Plot results DimPlot(object = pbmc_small, reduction = 'umap') } } \references{ McInnes, L, Healy, J, UMAP: Uniform Manifold Approximation and Projection for Dimension Reduction, ArXiv e-prints 1802.03426, 2018 } Seurat/man/ExpSD.Rd0000644000176200001440000000067013617632030013546 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utilities.R \name{ExpSD} \alias{ExpSD} \title{Calculate the standard deviation of logged values} \usage{ ExpSD(x) } \arguments{ \item{x}{A vector of values} } \value{ Returns the standard deviation in log-space } \description{ Calculate SD of logged values in non-log space (return answer in log-space) } \examples{ ExpSD(x = c(1, 2, 3)) } Seurat/man/Tool.Rd0000644000176200001440000000271613617632030013503 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{Tool} \alias{Tool} \alias{Tools} \alias{Tool<-} \alias{Tool.Seurat} \alias{Tool<-.Seurat} \title{Get and set additional tool data} \usage{ Tool(object, ...) Tool(object, ...) <- value \method{Tool}{Seurat}(object, slot = NULL, ...) \method{Tool}{Seurat}(object, ...) <- value } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{value}{Information to be added to tool list} \item{slot}{Name of tool to pull} } \value{ If no additional arguments, returns the names of the tools in the object; otherwise returns the data placed by the tool requested } \description{ Use \code{Tool} to get tool data. If no additional arguments are provided, will return a vector with the names of tools in the object. } \note{ For developers: set tool data using \code{Tool<-}. \code{Tool<-} will automatically set the name of the tool to the function that called \code{Tool<-}, so each function gets one entry in the tools list and cannot overwrite another function's entry. The automatic naming will also remove any method identifiers (eg. RunPCA.Seurat will become RunPCA); please plan accordingly. } \examples{ Tool(object = pbmc_small) \dontrun{ sample.tool.output <- matrix(data = rnorm(n = 16), nrow = 4) # must be run from within a function Tool(object = pbmc_small) <- sample.tool.output } } Seurat/man/RunLSI.Rd0000644000176200001440000000352413617632030013700 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/dimensional_reduction.R \name{RunLSI} \alias{RunLSI} \alias{RunLSI.default} \alias{RunLSI.Assay} \alias{RunLSI.Seurat} \title{Run Latent Semantic Indexing on binary count matrix} \usage{ RunLSI(object, ...) \method{RunLSI}{default}( object, assay = NULL, n = 50, reduction.key = "LSI_", scale.max = NULL, seed.use = 42, verbose = TRUE, ... ) \method{RunLSI}{Assay}( object, assay = NULL, features = NULL, n = 50, reduction.key = "LSI_", scale.max = NULL, verbose = TRUE, ... ) \method{RunLSI}{Seurat}( object, assay = NULL, features = NULL, n = 50, reduction.key = "LSI_", reduction.name = "lsi", scale.max = NULL, verbose = TRUE, ... ) } \arguments{ \item{object}{Seurat object} \item{...}{Arguments passed to other methods} \item{assay}{Which assay to use. If NULL, use the default assay} \item{n}{Number of singular values to compute} \item{reduction.key}{Key for dimension reduction object} \item{scale.max}{Clipping value for cell embeddings. Default (NULL) is no clipping.} \item{seed.use}{Set a random seed. By default, sets the seed to 42. Setting NULL will not set a seed.} \item{verbose}{Print messages} \item{features}{Which features to use. If NULL, use variable features} \item{reduction.name}{Name for stored dimension reduction object. Default 'lsi'} } \description{ For details about stored LSI calculation parameters, see \code{PrintLSIParams}. } \note{ RunLSI is being moved to Signac. Equivalent functionality can be achieved via the Signac::RunTFIDF and Signac::RunSVD functions; for more information on Signac, please see \url{https://github.com/timoast/Signac} } \examples{ lsi <- RunLSI(object = pbmc_small, n = 5) } Seurat/man/Reductions.Rd0000644000176200001440000000122013617632030014672 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{Reductions} \alias{Reductions} \title{Pull DimReducs or DimReduc names} \usage{ Reductions(object, slot = NULL) } \arguments{ \item{object}{A Seurat object} \item{slot}{Name of DimReduc} } \value{ If \code{slot} is \code{NULL}, the names of all \code{DimReduc} objects in this Seurat object. Otherwise, the \code{DimReduc} object requested } \description{ Lists the names of \code{\link{DimReduc}} objects present in a Seurat object. If slot is provided, pulls specified DimReduc object. } \examples{ Reductions(object = pbmc_small) } Seurat/man/HoverLocator.Rd0000644000176200001440000000156013617632030015171 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{HoverLocator} \alias{HoverLocator} \title{Hover Locator} \usage{ HoverLocator(plot, information = NULL, dark.theme = FALSE, ...) } \arguments{ \item{plot}{A ggplot2 plot} \item{information}{An optional dataframe or matrix of extra information to be displayed on hover} \item{dark.theme}{Plot using a dark theme?} \item{...}{Extra parameters to be passed to \code{plotly::layout}} } \description{ Get quick information from a scatterplot by hovering over points } \examples{ \dontrun{ plot <- DimPlot(object = pbmc_small) HoverLocator(plot = plot, information = FetchData(object = pbmc_small, vars = 'percent.mito')) } } \seealso{ \code{\link[plotly]{layout}} \code{\link[ggplot2]{ggplot_build}} \code{\link{DimPlot}} \code{\link{FeaturePlot}} } Seurat/man/WhichCells.Rd0000644000176200001440000000337013617632030014610 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{WhichCells} \alias{WhichCells} \alias{WhichCells.Assay} \alias{WhichCells.Seurat} \title{Identify cells matching certain criteria} \usage{ WhichCells(object, ...) \method{WhichCells}{Assay}(object, cells = NULL, expression, invert = FALSE, ...) \method{WhichCells}{Seurat}( object, cells = NULL, idents = NULL, expression, slot = "data", invert = FALSE, downsample = Inf, seed = 1, ... ) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{cells}{Subset of cell names} \item{expression}{A predicate expression for feature/variable expression, can evalue anything that can be pulled by \code{FetchData}; please note, you may need to wrap feature names in backticks (\code{``}) if dashes between numbers are present in the feature name} \item{invert}{Invert the selection of cells} \item{idents}{A vector of identity classes to keep} \item{slot}{Slot to pull feature data for} \item{downsample}{Maximum number of cells per identity class, default is \code{Inf}; downsampling will happen after all other operations, including inverting the cell selection} \item{seed}{Random seed for downsampling. If NULL, does not set a seed} } \value{ A vector of cell names } \description{ Returns a list of cells that match a particular set of criteria such as identity class, high/low values for particular PCs, ect.. } \examples{ WhichCells(object = pbmc_small, idents = 2) WhichCells(object = pbmc_small, expression = MS4A1 > 3) levels(x = pbmc_small) WhichCells(object = pbmc_small, idents = c(1, 2), invert = TRUE) } \seealso{ \code{\link{FetchData}} } Seurat/man/SetAssayData.Rd0000644000176200001440000000244013617632030015106 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{SetAssayData} \alias{SetAssayData} \alias{SetAssayData.Assay} \alias{SetAssayData.Seurat} \title{Setter for multimodal data} \usage{ SetAssayData(object, ...) \method{SetAssayData}{Assay}(object, slot, new.data, ...) \method{SetAssayData}{Seurat}(object, slot = "data", new.data, assay = NULL, ...) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{slot}{Where to store the new data} \item{new.data}{New data to insert} \item{assay}{Name of assay whose data should be set} } \value{ object with the assay data set } \description{ Setter for multimodal data } \examples{ # Set an Assay slot directly count.data <- GetAssayData(object = pbmc_small[["RNA"]], slot = "counts") count.data <- as.matrix(x = count.data + 1) new.assay <- SetAssayData(object = pbmc_small[["RNA"]], slot = "counts", new.data = count.data) # Set an Assay slot through the Seurat object count.data <- GetAssayData(object = pbmc_small[["RNA"]], slot = "counts") count.data <- as.matrix(x = count.data + 1) new.seurat.object <- SetAssayData( object = pbmc_small, slot = "counts", new.data = count.data, assay = "RNA" ) } Seurat/man/RenameAssays.Rd0000644000176200001440000000077613617632030015165 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{RenameAssays} \alias{RenameAssays} \title{Rename assays in a \code{Seurat} object} \usage{ RenameAssays(object, ...) } \arguments{ \item{object}{A \code{Seurat} object} \item{...}{Named arguments as \code{old.assay = new.assay}} } \value{ \code{object} with assays renamed } \description{ Rename assays in a \code{Seurat} object } \examples{ RenameAssays(object = pbmc_small, RNA = 'rna') } Seurat/man/cc.genes.Rd0000644000176200001440000000075313617632030014252 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data.R \docType{data} \name{cc.genes} \alias{cc.genes} \title{Cell cycle genes} \format{A list of two vectors \describe{ \item{s.genes}{Genes associated with S-phase} \item{g2m.genes}{Genes associated with G2M-phase} }} \source{ \url{http://science.sciencemag.org/content/352/6282/189} } \usage{ cc.genes } \description{ A list of genes used in cell-cycle regression } \keyword{datasets} Seurat/man/SampleUMI.Rd0000644000176200001440000000144013617632030014353 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/preprocessing.R \name{SampleUMI} \alias{SampleUMI} \title{Sample UMI} \usage{ SampleUMI(data, max.umi = 1000, upsample = FALSE, verbose = FALSE) } \arguments{ \item{data}{Matrix with the raw count data} \item{max.umi}{Number of UMIs to sample to} \item{upsample}{Upsamples all cells with fewer than max.umi} \item{verbose}{Display the progress bar} } \value{ Matrix with downsampled data } \description{ Downsample each cell to a specified number of UMIs. Includes an option to upsample cells below specified UMI as well. } \examples{ counts = as.matrix(x = GetAssayData(object = pbmc_small, assay = "RNA", slot = "counts")) downsampled = SampleUMI(data = counts) head(x = downsampled) } Seurat/man/HTOHeatmap.Rd0000644000176200001440000000321713617632030014515 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{HTOHeatmap} \alias{HTOHeatmap} \title{Hashtag oligo heatmap} \usage{ HTOHeatmap( object, assay = "HTO", classification = paste0(assay, "_classification"), global.classification = paste0(assay, "_classification.global"), ncells = 5000, singlet.names = NULL, raster = TRUE ) } \arguments{ \item{object}{Seurat object. Assumes that the hash tag oligo (HTO) data has been added and normalized, and demultiplexing has been run with HTODemux().} \item{assay}{Hashtag assay name.} \item{classification}{The naming for metadata column with classification result from HTODemux().} \item{global.classification}{The slot for metadata column specifying a cell as singlet/doublet/negative.} \item{ncells}{Number of cells to plot. Default is to choose 5000 cells by random subsampling, to avoid having to draw exceptionally large heatmaps.} \item{singlet.names}{Namings for the singlets. Default is to use the same names as HTOs.} \item{raster}{If true, plot with geom_raster, else use geom_tile. geom_raster may look blurry on some viewing applications such as Preview due to how the raster is interpolated. Set this to FALSE if you are encountering that issue (note that plots may take longer to produce/render).} } \value{ Returns a ggplot2 plot object. } \description{ Draws a heatmap of hashtag oligo signals across singlets/doublets/negative cells. Allows for the visualization of HTO demultiplexing results. } \examples{ \dontrun{ object <- HTODemux(object) HTOHeatmap(object) } } \seealso{ \code{\link{HTODemux}} } Seurat/man/Assay-class.Rd0000644000176200001440000000211213617632030014737 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \docType{class} \name{Assay-class} \alias{Assay-class} \alias{Assay} \title{The Assay Class} \description{ The Assay object is the basic unit of Seurat; each Assay stores raw, normalized, and scaled data as well as cluster information, variable features, and any other assay-specific metadata. Assays should contain single cell expression data such as RNA-seq, protein, or imputed expression data. } \section{Slots}{ \describe{ \item{\code{counts}}{Unnormalized data such as raw counts or TPMs} \item{\code{data}}{Normalized expression data} \item{\code{scale.data}}{Scaled expression data} \item{\code{key}}{Key for the Assay} \item{\code{assay.orig}}{Original assay that this assay is based off of. Used to track assay provenence} \item{\code{var.features}}{Vector of features exhibiting high variance across single cells} \item{\code{meta.features}}{Feature-level metadata} \item{\code{misc}}{Utility slot for storing additional data associated with the assay} }} Seurat/man/IntegrationData-class.Rd0000644000176200001440000000167013617632030016744 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \docType{class} \name{IntegrationData-class} \alias{IntegrationData-class} \alias{IntegrationData} \title{The IntegrationData Class} \description{ The IntegrationData object is an intermediate storage container used internally throughout the integration procedure to hold bits of data that are useful downstream. } \section{Slots}{ \describe{ \item{\code{neighbors}}{List of neighborhood information for cells (outputs of \code{RANN::nn2})} \item{\code{weights}}{Anchor weight matrix} \item{\code{integration.matrix}}{Integration matrix} \item{\code{anchors}}{Anchor matrix} \item{\code{offsets}}{The offsets used to enable cell look up in downstream functions} \item{\code{objects.ncell}}{Number of cells in each object in the object.list} \item{\code{sample.tree}}{Sample tree used for ordering multi-dataset integration} }} Seurat/man/CreateSeuratObject.Rd0000644000176200001440000000442613617632030016304 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{CreateSeuratObject} \alias{CreateSeuratObject} \title{Create a Seurat object} \usage{ CreateSeuratObject( counts, project = "SeuratProject", assay = "RNA", min.cells = 0, min.features = 0, names.field = 1, names.delim = "_", meta.data = NULL ) } \arguments{ \item{counts}{Unnormalized data such as raw counts or TPMs} \item{project}{Sets the project name for the Seurat object.} \item{assay}{Name of the assay corresponding to the initial input data.} \item{min.cells}{Include features detected in at least this many cells. Will subset the counts matrix as well. To reintroduce excluded features, create a new object with a lower cutoff.} \item{min.features}{Include cells where at least this many features are detected.} \item{names.field}{For the initial identity class for each cell, choose this field from the cell's name. E.g. If your cells are named as BARCODE_CLUSTER_CELLTYPE in the input matrix, set names.field to 3 to set the initial identities to CELLTYPE.} \item{names.delim}{For the initial identity class for each cell, choose this delimiter from the cell's column name. E.g. If your cells are named as BARCODE-CLUSTER-CELLTYPE, set this to "-" to separate the cell name into its component parts for picking the relevant field.} \item{meta.data}{Additional cell-level metadata to add to the Seurat object. Should be a data frame where the rows are cell names and the columns are additional metadata fields.} } \description{ Create a Seurat object from a feature (e.g. gene) expression matrix. The expected format of the input matrix is features x cells. } \details{ Note: In previous versions (<3.0), this function also accepted a parameter to set the expression threshold for a 'detected' feature (gene). This functionality has been removed to simplify the initialization process/assumptions. If you would still like to impose this threshold for your particular dataset, simply filter the input expression matrix before calling this function. } \examples{ pbmc_raw <- read.table( file = system.file('extdata', 'pbmc_raw.txt', package = 'Seurat'), as.is = TRUE ) pbmc_small <- CreateSeuratObject(counts = pbmc_raw) pbmc_small } Seurat/man/CellsByIdentities.Rd0000644000176200001440000000130613617632030016137 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{CellsByIdentities} \alias{CellsByIdentities} \title{Get cell names grouped by identity class} \usage{ CellsByIdentities(object, idents = NULL, cells = NULL) } \arguments{ \item{object}{A Seurat object} \item{idents}{A vector of identity class levels to limit resulting list to; defaults to all identity class levels} \item{cells}{A vector of cells to grouping to} } \value{ A named list where names are identity classes and values are vectors of cells beloning to that class } \description{ Get cell names grouped by identity class } \examples{ CellsByIdentities(object = pbmc_small) } Seurat/man/Cells.Rd0000644000176200001440000000072213617632030013623 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{Cells} \alias{Cells} \alias{Cells.default} \alias{Cells.DimReduc} \title{Get cells present in an object} \usage{ Cells(x) \method{Cells}{default}(x) \method{Cells}{DimReduc}(x) } \arguments{ \item{x}{An object} } \value{ A vector of cell names } \description{ Get cells present in an object } \examples{ Cells(x = pbmc_small) } Seurat/man/ReadAlevin.Rd0000644000176200001440000000134513617632030014575 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/preprocessing.R \name{ReadAlevin} \alias{ReadAlevin} \title{Load in data from Alevin pipeline} \usage{ ReadAlevin(base.path) } \arguments{ \item{base.path}{Directory containing the alevin/quant_mat* files provided by Alevin.} } \value{ Returns a matrix with rows and columns labeled } \description{ Enables easy loading of binary format matrix provided by Alevin } \examples{ \dontrun{ data_dir <- 'path/to/output/directory' list.files(data_dir) # Should show alevin/quants_mat* files expression_matrix <- ReadAlevin(base.path = data_dir) seurat_object = CreateSeuratObject(counts = expression_matrix) } } \author{ Avi Srivastava } Seurat/man/LogSeuratCommand.Rd0000644000176200001440000000116713617632030015771 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{LogSeuratCommand} \alias{LogSeuratCommand} \title{Log a command} \usage{ LogSeuratCommand(object, return.command = FALSE) } \arguments{ \item{object}{Name of Seurat object} \item{return.command}{Return a \link{SeuratCommand} object instead} } \value{ If \code{return.command}, returns a SeuratCommand object. Otherwise, returns the Seurat object with command stored } \description{ Logs command run, storing the name, timestamp, and argument list. Stores in the Seurat object } \seealso{ \code{\link{Command}} } Seurat/man/Read10X_h5.Rd0000644000176200001440000000132513617632030014321 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/preprocessing.R \name{Read10X_h5} \alias{Read10X_h5} \title{Read 10X hdf5 file} \usage{ Read10X_h5(filename, use.names = TRUE, unique.features = TRUE) } \arguments{ \item{filename}{Path to h5 file} \item{use.names}{Label row names with feature names rather than ID numbers.} \item{unique.features}{Make feature names unique (default TRUE)} } \value{ Returns a sparse matrix with rows and columns labeled. If multiple genomes are present, returns a list of sparse matrices (one per genome). } \description{ Read count matrix from 10X CellRanger hdf5 file. This can be used to read both scATAC-seq and scRNA-seq matrices. } Seurat/man/subset.Seurat.Rd0000644000176200001440000000236113617632030015331 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{[.Seurat} \alias{[.Seurat} \alias{subset.Seurat} \alias{subset} \title{Subset a Seurat object} \usage{ \method{[}{Seurat}(x, i, j, ...) \method{subset}{Seurat}(x, subset, cells = NULL, features = NULL, idents = NULL, ...) } \arguments{ \item{x}{Seurat object to be subsetted} \item{i, features}{A vector of features to keep} \item{j, cells}{A vector of cells to keep} \item{...}{Extra parameters passed to \code{\link{WhichCells}}, such as \code{slot}, \code{invert}, or \code{downsample}} \item{subset}{Logical expression indicating features/variables to keep} \item{idents}{A vector of identity classes to keep} } \value{ A subsetted Seurat object } \description{ Subset a Seurat object } \examples{ pbmc_small[VariableFeatures(object = pbmc_small), ] pbmc_small[, 1:10] subset(x = pbmc_small, subset = MS4A1 > 4) subset(x = pbmc_small, subset = `DLGAP1-AS1` > 2) subset(x = pbmc_small, idents = '0', invert = TRUE) subset(x = pbmc_small, subset = MS4A1 > 3, slot = 'counts') subset(x = pbmc_small, features = VariableFeatures(object = pbmc_small)) } \seealso{ \code{\link[base]{subset}} \code{\link{WhichCells}} } Seurat/man/OldWhichCells.Rd0000644000176200001440000000370113617632030015245 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{OldWhichCells} \alias{OldWhichCells} \alias{OldWhichCells.Assay} \alias{OldWhichCells.Seurat} \title{Identify cells matching certain criteria} \usage{ OldWhichCells(object, ...) \method{OldWhichCells}{Assay}( object, cells, subset.name = NULL, low.threshold = -Inf, high.threshold = Inf, accept.value = NULL, ... ) \method{OldWhichCells}{Seurat}( object, cells = NULL, subset.name = NULL, low.threshold = -Inf, high.threshold = Inf, accept.value = NULL, ident.keep = NULL, ident.remove = NULL, max.cells.per.ident = Inf, random.seed = 1, assay = NULL, ... ) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods and \code{FetchData}} \item{cells}{Subset of cell names} \item{subset.name}{Parameter to subset on. Eg, the name of a gene, PC_1, a column name in object@meta.data, etc. Any argument that can be retreived using FetchData} \item{low.threshold}{Low cutoff for the parameter (default is -Inf)} \item{high.threshold}{High cutoff for the parameter (default is Inf)} \item{accept.value}{Returns all cells with the subset name equal to this value} \item{ident.keep}{Create a cell subset based on the provided identity classes} \item{ident.remove}{Subtract out cells from these identity classes (used for filtration)} \item{max.cells.per.ident}{Can be used to downsample the data to a certain max per cell ident. Default is INF.} \item{random.seed}{Random seed for downsampling} \item{assay}{Which assay to filter on} } \value{ A vector of cell names } \description{ Returns a list of cells that match a particular set of criteria such as identity class, high/low values for particular PCs, ect.. } \examples{ \dontrun{ OldWhichCells(object = pbmc_small, ident.keep = 2) } } \seealso{ \code{\link{FetchData}} } Seurat/man/GetAssayData.Rd0000644000176200001440000000220013617632030015064 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{GetAssayData} \alias{GetAssayData} \alias{GetAssayData.Assay} \alias{GetAssayData.Seurat} \title{General accessor function for the Assay class} \usage{ GetAssayData(object, ...) \method{GetAssayData}{Assay}(object, slot = "data", ...) \method{GetAssayData}{Seurat}(object, slot = "data", assay = NULL, ...) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{slot}{Specific information to pull (i.e. counts, data, scale.data, ...)} \item{assay}{Name of assay to pull data from} } \value{ Returns info from requested slot } \description{ This function can be used to pull information from any of the slots in the Assay class. For example, pull one of the data matrices("counts", "data", or "scale.data"). } \examples{ # Get the data directly from an Assay object GetAssayData(object = pbmc_small[["RNA"]], slot = "data")[1:5,1:5] # Get the data from a specific Assay in a Seurat object GetAssayData(object = pbmc_small, assay = "RNA", slot = "data")[1:5,1:5] } Seurat/man/SeuratTheme.Rd0000644000176200001440000000610213617632030015005 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{SeuratTheme} \alias{SeuratTheme} \alias{DarkTheme} \alias{FontSize} \alias{NoAxes} \alias{NoLegend} \alias{NoGrid} \alias{SeuratAxes} \alias{SpatialTheme} \alias{RestoreLegend} \alias{RotatedAxis} \alias{BoldTitle} \alias{WhiteBackground} \title{Seurat Themes} \usage{ SeuratTheme() DarkTheme(...) FontSize( x.text = NULL, y.text = NULL, x.title = NULL, y.title = NULL, main = NULL, ... ) NoAxes(..., keep.text = FALSE, keep.ticks = FALSE) NoLegend(...) NoGrid(...) SeuratAxes(...) SpatialTheme(...) RestoreLegend(..., position = "right") RotatedAxis(...) BoldTitle(...) WhiteBackground(...) } \arguments{ \item{...}{Extra parameters to be passed to \code{theme}} \item{x.text, y.text}{X and Y axis text sizes} \item{x.title, y.title}{X and Y axis title sizes} \item{main}{Plot title size} \item{keep.text}{Keep axis text} \item{keep.ticks}{Keep axis ticks} \item{position}{A position to restore the legend to} } \value{ A ggplot2 theme object } \description{ Various themes to be applied to ggplot2-based plots \describe{ \item{\code{SeuratTheme}}{The curated Seurat theme, consists of ...} \item{\code{DarkTheme}}{A dark theme, axes and text turn to white, the background becomes black} \item{\code{NoAxes}}{Removes axis lines, text, and ticks} \item{\code{NoLegend}}{Removes the legend} \item{\code{FontSize}}{Sets axis and title font sizes} \item{\code{NoGrid}}{Removes grid lines} \item{\code{SeuratAxes}}{Set Seurat-style axes} \item{\code{SpatialTheme}}{A theme designed for spatial visualizations (eg \code{\link{PolyFeaturePlot}}, \code{\link{PolyDimPlot}})} \item{\code{RestoreLegend}}{Restore a legend after removal} \item{\code{RotatedAxis}}{Rotate X axis text 45 degrees} \item{\code{BoldTitle}}{Enlarges and emphasizes the title} } } \examples{ # Generate a plot with a dark theme library(ggplot2) df <- data.frame(x = rnorm(n = 100, mean = 20, sd = 2), y = rbinom(n = 100, size = 100, prob = 0.2)) p <- ggplot(data = df, mapping = aes(x = x, y = y)) + geom_point(mapping = aes(color = 'red')) p + DarkTheme(legend.position = 'none') # Generate a plot with no axes library(ggplot2) df <- data.frame(x = rnorm(n = 100, mean = 20, sd = 2), y = rbinom(n = 100, size = 100, prob = 0.2)) p <- ggplot(data = df, mapping = aes(x = x, y = y)) + geom_point(mapping = aes(color = 'red')) p + NoAxes() # Generate a plot with no legend library(ggplot2) df <- data.frame(x = rnorm(n = 100, mean = 20, sd = 2), y = rbinom(n = 100, size = 100, prob = 0.2)) p <- ggplot(data = df, mapping = aes(x = x, y = y)) + geom_point(mapping = aes(color = 'red')) p + NoLegend() # Generate a plot with no grid lines library(ggplot2) df <- data.frame(x = rnorm(n = 100, mean = 20, sd = 2), y = rbinom(n = 100, size = 100, prob = 0.2)) p <- ggplot(data = df, mapping = aes(x = x, y = y)) + geom_point(mapping = aes(color = 'red')) p + NoGrid() } \seealso{ \code{\link[ggplot2]{theme}} } Seurat/man/FindNeighbors.Rd0000644000176200001440000000721713617632030015310 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/clustering.R \name{FindNeighbors} \alias{FindNeighbors} \alias{FindNeighbors.default} \alias{FindNeighbors.Assay} \alias{FindNeighbors.dist} \alias{FindNeighbors.Seurat} \title{SNN Graph Construction} \usage{ FindNeighbors(object, ...) \method{FindNeighbors}{default}( object, distance.matrix = FALSE, k.param = 20, compute.SNN = TRUE, prune.SNN = 1/15, nn.method = "rann", annoy.metric = "euclidean", nn.eps = 0, verbose = TRUE, force.recalc = FALSE, ... ) \method{FindNeighbors}{Assay}( object, features = NULL, k.param = 20, compute.SNN = TRUE, prune.SNN = 1/15, nn.method = "rann", annoy.metric = "euclidean", nn.eps = 0, verbose = TRUE, force.recalc = FALSE, ... ) \method{FindNeighbors}{dist}( object, k.param = 20, compute.SNN = TRUE, prune.SNN = 1/15, nn.method = "rann", annoy.metric = "euclidean", nn.eps = 0, verbose = TRUE, force.recalc = FALSE, ... ) \method{FindNeighbors}{Seurat}( object, reduction = "pca", dims = 1:10, assay = NULL, features = NULL, k.param = 20, compute.SNN = TRUE, prune.SNN = 1/15, nn.method = "rann", annoy.metric = "euclidean", nn.eps = 0, verbose = TRUE, force.recalc = FALSE, do.plot = FALSE, graph.name = NULL, ... ) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{distance.matrix}{Boolean value of whether the provided matrix is a distance matrix; note, for objects of class \code{dist}, this parameter will be set automatically} \item{k.param}{Defines k for the k-nearest neighbor algorithm} \item{compute.SNN}{also compute the shared nearest neighbor graph} \item{prune.SNN}{Sets the cutoff for acceptable Jaccard index when computing the neighborhood overlap for the SNN construction. Any edges with values less than or equal to this will be set to 0 and removed from the SNN graph. Essentially sets the strigency of pruning (0 --- no pruning, 1 --- prune everything).} \item{nn.method}{Method for nearest neighbor finding. Options include: rann, annoy} \item{annoy.metric}{Distance metric for annoy. Options include: euclidean, cosine, manhattan, and hamming} \item{nn.eps}{Error bound when performing nearest neighbor seach using RANN; default of 0.0 implies exact nearest neighbor search} \item{verbose}{Whether or not to print output to the console} \item{force.recalc}{Force recalculation of SNN.} \item{features}{Features to use as input for building the SNN} \item{reduction}{Reduction to use as input for building the SNN} \item{dims}{Dimensions of reduction to use as input} \item{assay}{Assay to use in construction of SNN} \item{do.plot}{Plot SNN graph on tSNE coordinates} \item{graph.name}{Optional naming parameter for stored SNN graph. Default is assay.name_snn.} } \value{ Returns the object with object@snn filled } \description{ Constructs a Shared Nearest Neighbor (SNN) Graph for a given dataset. We first determine the k-nearest neighbors of each cell. We use this knn graph to construct the SNN graph by calculating the neighborhood overlap (Jaccard index) between every cell and its k.param nearest neighbors. } \examples{ pbmc_small # Compute an SNN on the gene expression level pbmc_small <- FindNeighbors(pbmc_small, features = VariableFeatures(object = pbmc_small)) # More commonly, we build the SNN on a dimensionally reduced form of the data # such as the first 10 principle components. pbmc_small <- FindNeighbors(pbmc_small, reduction = "pca", dims = 1:10) } Seurat/man/StopCellbrowser.Rd0000644000176200001440000000046213617632030015713 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utilities.R \name{StopCellbrowser} \alias{StopCellbrowser} \title{Stop Cellbrowser web server} \usage{ StopCellbrowser() } \description{ Stop Cellbrowser web server } \examples{ \dontrun{ StopCellbrowser() } } Seurat/man/Seurat-class.Rd0000644000176200001440000000370113617632030015127 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \docType{class} \name{Seurat-class} \alias{Seurat-class} \alias{Seurat} \title{The Seurat Class} \description{ The Seurat object is a representation of single-cell expression data for R; each Seurat object revolves around a set of cells and consists of one or more \code{\link{Assay-class}} objects, or individual representations of expression data (eg. RNA-seq, ATAC-seq, etc). These assays can be reduced from their high-dimensional state to a lower-dimension state and stored as \code{\link{DimReduc-class}} objects. Seurat objects also store additional meta data, both at the cell and feature level (contained within individual assays). The object was designed to be as self-contained as possible, and easily extendible to new methods. } \section{Slots}{ \describe{ \item{\code{assays}}{A list of assays for this project} \item{\code{meta.data}}{Contains meta-information about each cell, starting with number of genes detected (nGene) and the original identity class (orig.ident); more information is added using \code{AddMetaData}} \item{\code{active.assay}}{Name of the active, or default, assay; settable using \code{\link{DefaultAssay}}} \item{\code{active.ident}}{The active cluster identity for this Seurat object; settable using \code{\link{Idents}}} \item{\code{graphs}}{A list of \code{\link{Graph-class}} objects} \item{\code{neighbors}}{...} \item{\code{reductions}}{A list of dimmensional reduction objects for this object} \item{\code{project.name}}{Name of the project} \item{\code{misc}}{A list of miscellaneous information} \item{\code{version}}{Version of Seurat this object was built under} \item{\code{commands}}{A list of logged commands run on this \code{Seurat} object} \item{\code{tools}}{A list of miscellaneous data generated by other tools, should be filled by developers only using \code{\link{Tool}<-}} }} Seurat/man/AddMetaData.Rd0000644000176200001440000000303413617632030014651 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{AddMetaData} \alias{AddMetaData} \alias{SeuratAccess} \alias{AddMetaData.Assay} \alias{AddMetaData.Seurat} \alias{[[<-,Assay-method} \alias{[[<-,Seurat-method} \title{Add in metadata associated with either cells or features.} \usage{ AddMetaData(object, metadata, col.name = NULL) \method{AddMetaData}{Assay}(object, metadata, col.name = NULL) \method{AddMetaData}{Seurat}(object, metadata, col.name = NULL) \S4method{[[}{Assay}(x, i, j, ...) <- value \S4method{[[}{Seurat}(x, i, j, ...) <- value } \arguments{ \item{x, object}{An object} \item{i, col.name}{Name to store metadata or object as} \item{j}{Ignored} \item{...}{Arguments passed to other methods} \item{value, metadata}{Metadata or object to add} } \value{ An object with metadata or and object added } \description{ Adds additional data to the object. Can be any piece of information associated with a cell (examples include read depth, alignment rate, experimental batch, or subpopulation identity) or feature (ENSG name, variance). To add cell level information, add to the Seurat object. If adding feature-level metadata, add to the Assay object (e.g. object[["RNA"]])) } \examples{ cluster_letters <- LETTERS[Idents(object = pbmc_small)] names(cluster_letters) <- colnames(x = pbmc_small) pbmc_small <- AddMetaData( object = pbmc_small, metadata = cluster_letters, col.name = 'letter.idents' ) head(x = pbmc_small[[]]) } Seurat/man/DoHeatmap.Rd0000644000176200001440000000451313617632030014425 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{DoHeatmap} \alias{DoHeatmap} \title{Feature expression heatmap} \usage{ DoHeatmap( object, features = NULL, cells = NULL, group.by = "ident", group.bar = TRUE, group.colors = NULL, disp.min = -2.5, disp.max = NULL, slot = "scale.data", assay = NULL, label = TRUE, size = 5.5, hjust = 0, angle = 45, raster = TRUE, draw.lines = TRUE, lines.width = NULL, group.bar.height = 0.02, combine = TRUE ) } \arguments{ \item{object}{Seurat object} \item{features}{A vector of features to plot, defaults to \code{VariableFeatures(object = object)}} \item{cells}{A vector of cells to plot} \item{group.by}{A vector of variables to group cells by; pass 'ident' to group by cell identity classes} \item{group.bar}{Add a color bar showing group status for cells} \item{group.colors}{Colors to use for the color bar} \item{disp.min}{Minimum display value (all values below are clipped)} \item{disp.max}{Maximum display value (all values above are clipped); defaults to 2.5 if \code{slot} is 'scale.data', 6 otherwise} \item{slot}{Data slot to use, choose from 'raw.data', 'data', or 'scale.data'} \item{assay}{Assay to pull from} \item{label}{Label the cell identies above the color bar} \item{size}{Size of text above color bar} \item{hjust}{Horizontal justification of text above color bar} \item{angle}{Angle of text above color bar} \item{raster}{If true, plot with geom_raster, else use geom_tile. geom_raster may look blurry on some viewing applications such as Preview due to how the raster is interpolated. Set this to FALSE if you are encountering that issue (note that plots may take longer to produce/render).} \item{draw.lines}{Include white lines to separate the groups} \item{lines.width}{Integer number to adjust the width of the separating white lines. Corresponds to the number of "cells" between each group.} \item{group.bar.height}{Scale the height of the color bar} \item{combine}{Combine plots into a single gg object; note that if TRUE; themeing will not work when plotting multiple dimensions} } \value{ A ggplot object } \description{ Draws a heatmap of single cell feature expression. } \examples{ DoHeatmap(object = pbmc_small) } Seurat/man/CalculateBarcodeInflections.Rd0000644000176200001440000000457713617632030020150 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/preprocessing.R \name{CalculateBarcodeInflections} \alias{CalculateBarcodeInflections} \title{Calculate the Barcode Distribution Inflection} \usage{ CalculateBarcodeInflections( object, barcode.column = "nCount_RNA", group.column = "orig.ident", threshold.low = NULL, threshold.high = NULL ) } \arguments{ \item{object}{Seurat object} \item{barcode.column}{Column to use as proxy for barcodes ("nCount_RNA" by default)} \item{group.column}{Column to group by ("orig.ident" by default)} \item{threshold.low}{Ignore barcodes of rank below this threshold in inflection calculation} \item{threshold.high}{Ignore barcodes of rank above thisf threshold in inflection calculation} } \value{ Returns Seurat object with a new list in the `tools` slot, `CalculateBarcodeInflections` with values: * `barcode_distribution` - contains the full barcode distribution across the entire dataset * `inflection_points` - the calculated inflection points within the thresholds * `threshold_values` - the provided (or default) threshold values to search within for inflections * `cells_pass` - the cells that pass the inflection point calculation } \description{ This function calculates an adaptive inflection point ("knee") of the barcode distribution for each sample group. This is useful for determining a threshold for removing low-quality samples. } \details{ The function operates by calculating the slope of the barcode number vs. rank distribution, and then finding the point at which the distribution changes most steeply (the "knee"). Of note, this calculation often must be restricted as to the range at which it performs, so `threshold` parameters are provided to restrict the range of the calculation based on the rank of the barcodes. [BarcodeInflectionsPlot()] is provided as a convenience function to visualize and test different thresholds and thus provide more sensical end results. See [BarcodeInflectionsPlot()] to visualize the calculated inflection points and [SubsetByBarcodeInflections()] to subsequently subset the Seurat object. } \examples{ CalculateBarcodeInflections(pbmc_small, group.column = 'groups') } \seealso{ \code{\link{BarcodeInflectionsPlot}} \code{\link{SubsetByBarcodeInflections}} } \author{ Robert A. Amezquita, \email{robert.amezquita@fredhutch.org} } Seurat/man/CollapseSpeciesExpressionMatrix.Rd0000644000176200001440000000300013617632030021074 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utilities.R \name{CollapseSpeciesExpressionMatrix} \alias{CollapseSpeciesExpressionMatrix} \title{Slim down a multi-species expression matrix, when only one species is primarily of interenst.} \usage{ CollapseSpeciesExpressionMatrix( object, prefix = "HUMAN_", controls = "MOUSE_", ncontrols = 100 ) } \arguments{ \item{object}{A UMI count matrix. Should contain rownames that start with the ensuing arguments prefix.1 or prefix.2} \item{prefix}{The prefix denoting rownames for the species of interest. Default is "HUMAN_". These rownames will have this prefix removed in the returned matrix.} \item{controls}{The prefix denoting rownames for the species of 'negative control' cells. Default is "MOUSE_".} \item{ncontrols}{How many of the most highly expressed (average) negative control features (by default, 100 mouse genes), should be kept? All other rownames starting with prefix.2 are discarded.} } \value{ A UMI count matrix. Rownames that started with \code{prefix} have this prefix discarded. For rownames starting with \code{controls}, only the \code{ncontrols} most highly expressed features are kept, and the prefix is kept. All other rows are retained. } \description{ Valuable for CITE-seq analyses, where we typically spike in rare populations of 'negative control' cells from a different species. } \examples{ \dontrun{ cbmc.rna.collapsed <- CollapseSpeciesExpressionMatrix(cbmc.rna) } } Seurat/man/PCASigGenes.Rd0000644000176200001440000000205213617632030014607 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dimensional_reduction.R \name{PCASigGenes} \alias{PCASigGenes} \title{Significant genes from a PCA} \usage{ PCASigGenes( object, pcs.use, pval.cut = 0.1, use.full = FALSE, max.per.pc = NULL ) } \arguments{ \item{object}{Seurat object} \item{pcs.use}{PCS to use.} \item{pval.cut}{P-value cutoff} \item{use.full}{Use the full list of genes (from the projected PCA). Assumes that \code{ProjectDim} has been run. Currently, must be set to FALSE.} \item{max.per.pc}{Maximum number of genes to return per PC. Used to avoid genes from one PC dominating the entire analysis.} } \value{ A vector of genes whose p-values are statistically significant for at least one of the given PCs. } \description{ Returns a set of genes, based on the JackStraw analysis, that have statistically significant associations with a set of PCs. } \examples{ PCASigGenes(pbmc_small, pcs.use = 1:2) } \seealso{ \code{\link{ProjectDim}} \code{\link{JackStraw}} } Seurat/man/RunCCA.Rd0000644000176200001440000000504013617632030013632 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/dimensional_reduction.R \name{RunCCA} \alias{RunCCA} \alias{RunCCA.default} \alias{RunCCA.Seurat} \title{Perform Canonical Correlation Analysis} \usage{ RunCCA(object1, object2, ...) \method{RunCCA}{default}( object1, object2, standardize = TRUE, num.cc = 20, seed.use = 42, verbose = FALSE, ... ) \method{RunCCA}{Seurat}( object1, object2, assay1 = NULL, assay2 = NULL, num.cc = 20, features = NULL, renormalize = FALSE, rescale = FALSE, compute.gene.loadings = TRUE, add.cell.id1 = NULL, add.cell.id2 = NULL, verbose = TRUE, ... ) } \arguments{ \item{object1}{First Seurat object} \item{object2}{Second Seurat object.} \item{...}{Extra parameters (passed onto MergeSeurat in case with two objects passed, passed onto ScaleData in case with single object and rescale.groups set to TRUE)} \item{standardize}{Standardize matrices - scales columns to have unit variance and mean 0} \item{num.cc}{Number of canonical vectors to calculate} \item{seed.use}{Random seed to set. If NULL, does not set a seed} \item{verbose}{Show progress messages} \item{assay1, assay2}{Assays to pull from in the first and second objects, respectively} \item{features}{Set of genes to use in CCA. Default is the union of both the variable features sets present in both objects.} \item{renormalize}{Renormalize raw data after merging the objects. If FALSE, merge the data matrices also.} \item{rescale}{Rescale the datasets prior to CCA. If FALSE, uses existing data in the scale data slots.} \item{compute.gene.loadings}{Also compute the gene loadings. NOTE - this will scale every gene in the dataset which may impose a high memory cost.} \item{add.cell.id1, add.cell.id2}{Add ...} } \value{ Returns a combined Seurat object with the CCA results stored. } \description{ Runs a canonical correlation analysis using a diagonal implementation of CCA. For details about stored CCA calculation parameters, see \code{PrintCCAParams}. } \examples{ pbmc_small # As CCA requires two datasets, we will split our test object into two just for this example pbmc1 <- subset(pbmc_small, cells = colnames(pbmc_small)[1:40]) pbmc2 <- subset(pbmc_small, cells = colnames(x = pbmc_small)[41:80]) pbmc1[["group"]] <- "group1" pbmc2[["group"]] <- "group2" pbmc_cca <- RunCCA(object1 = pbmc1, object2 = pbmc2) # Print results print(x = pbmc_cca[["cca"]]) } \seealso{ \code{\link{merge.Seurat}} } Seurat/man/ALRAChooseKPlot.Rd0000644000176200001440000000231613617632030015414 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{ALRAChooseKPlot} \alias{ALRAChooseKPlot} \title{ALRA Approximate Rank Selection Plot} \usage{ ALRAChooseKPlot(object, start = 0, combine = TRUE) } \arguments{ \item{object}{Seurat object} \item{start}{Index to start plotting singular value spacings from. The transition from "signal" to "noise" in the is hard to see because the first singular value spacings are so large. Nicer visualizations result from skipping the first few. If set to 0 (default) starts from k/2.} \item{combine}{Combine plots into a single gg object; note that if TRUE, themeing will not work when plotting multiple features} } \value{ A list of 3 ggplot objects splotting the singular values, the spacings of the singular values, and the p-values of the singular values. } \description{ Plots the results of the approximate rank selection process for ALRA. } \note{ ALRAChooseKPlot and associated functions are being moved to SeuratWrappers; for more information on SeuratWrappers, please see \url{https://github.com/satijalab/seurat-wrappers} } \seealso{ \code{\link{RunALRA}} } \author{ Jun Zhao, George Linderman } Seurat/man/oldseurat-class.Rd0000644000176200001440000000476113617632030015675 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \docType{class} \name{seurat-class} \alias{seurat-class} \alias{seurat} \title{The Seurat Class} \description{ The Seurat object is the center of each single cell analysis. It stores all information associated with the dataset, including data, annotations, analyes, etc. All that is needed to construct a Seurat object is an expression matrix (rows are genes, columns are cells), which should be log-scale } \details{ Each Seurat object has a number of slots which store information. Key slots to access are listed below. } \section{Slots}{ \describe{ \item{\code{raw.data}}{The raw project data} \item{\code{data}}{The normalized expression matrix (log-scale)} \item{\code{scale.data}}{scaled (default is z-scoring each gene) expression matrix; used for dimmensional reduction and heatmap visualization} \item{\code{var.genes}}{Vector of genes exhibiting high variance across single cells} \item{\code{is.expr}}{Expression threshold to determine if a gene is expressed (0 by default)} \item{\code{ident}}{THe 'identity class' for each cell} \item{\code{meta.data}}{Contains meta-information about each cell, starting with number of genes detected (nGene) and the original identity class (orig.ident); more information is added using \code{AddMetaData}} \item{\code{project.name}}{Name of the project (for record keeping)} \item{\code{dr}}{List of stored dimmensional reductions; named by technique} \item{\code{assay}}{List of additional assays for multimodal analysis; named by technique} \item{\code{hvg.info}}{The output of the mean/variability analysis for all genes} \item{\code{imputed}}{Matrix of imputed gene scores} \item{\code{cell.names}}{Names of all single cells (column names of the expression matrix)} \item{\code{cluster.tree}}{List where the first element is a phylo object containing the phylogenetic tree relating different identity classes} \item{\code{snn}}{Spare matrix object representation of the SNN graph} \item{\code{calc.params}}{Named list to store all calculation-related parameter choices} \item{\code{kmeans}}{Stores output of gene-based clustering from \code{DoKMeans}} \item{\code{spatial}}{Stores internal data and calculations for spatial mapping of single cells} \item{\code{misc}}{Miscellaneous spot to store any data alongisde the object (for example, gene lists)} \item{\code{version}}{Version of package used in object creation} }} Seurat/man/GetIntegrationData.Rd0000644000176200001440000000100113617632030016265 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{GetIntegrationData} \alias{GetIntegrationData} \title{Get integation data} \usage{ GetIntegrationData(object, integration.name, slot) } \arguments{ \item{object}{Seurat object} \item{integration.name}{Name of integration object} \item{slot}{Which slot in integration object to get} } \value{ Returns data from the requested slot within the integrated object } \description{ Get integation data } Seurat/man/SubsetData.Rd0000644000176200001440000000424313617632030014622 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{SubsetData} \alias{SubsetData} \alias{SubsetData.Assay} \alias{SubsetData.Seurat} \title{Return a subset of the Seurat object} \usage{ SubsetData(object, ...) \method{SubsetData}{Assay}( object, cells = NULL, subset.name = NULL, low.threshold = -Inf, high.threshold = Inf, accept.value = NULL, ... ) \method{SubsetData}{Seurat}( object, assay = NULL, cells = NULL, subset.name = NULL, ident.use = NULL, ident.remove = NULL, low.threshold = -Inf, high.threshold = Inf, accept.value = NULL, max.cells.per.ident = Inf, random.seed = 1, ... ) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{cells}{A vector of cell names to use as a subset. If NULL (default), then this list will be computed based on the next three arguments. Otherwise, will return an object consissting only of these cells} \item{subset.name}{Parameter to subset on. Eg, the name of a gene, PC_1, a column name in object@meta.data, etc. Any argument that can be retreived using FetchData} \item{low.threshold}{Low cutoff for the parameter (default is -Inf)} \item{high.threshold}{High cutoff for the parameter (default is Inf)} \item{accept.value}{Returns cells with the subset name equal to this value} \item{assay}{Assay to subset on} \item{ident.use}{Create a cell subset based on the provided identity classes} \item{ident.remove}{Subtract out cells from these identity classes (used for filtration)} \item{max.cells.per.ident}{Can be used to downsample the data to a certain max per cell ident. Default is INF.} \item{random.seed}{Random seed for downsampling} } \value{ Returns a Seurat object containing only the relevant subset of cells } \description{ Creates a Seurat object containing only a subset of the cells in the original object. Takes either a list of cells to use as a subset, or a parameter (for example, a gene), to subset on. } \examples{ \dontrun{ pbmc1 <- SubsetData(object = pbmc_small, cells = colnames(x = pbmc_small)[1:40]) pbmc1 } } Seurat/man/DiscretePalette.Rd0000644000176200001440000000177113617632030015647 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{DiscretePalette} \alias{DiscretePalette} \title{Discrete colour palettes from the pals package} \usage{ DiscretePalette(n, palette = NULL) } \arguments{ \item{n}{Number of colours to be generated.} \item{palette}{Options are "alphabet", "alphabet2", "glasbey", "polychrome", and "stepped". Can be omitted and the function will use the one based on the requested n.} } \value{ A vector of colors } \description{ These are included here because pals depends on a number of compiled packages, and this can lead to increases in run time for Travis, and generally should be avoided when possible. } \details{ These palettes are a much better default for data with many classes than the default ggplot2 palette. Many thanks to Kevin Wright for writing the pals package. Taken from the pals package (Licence: GPL-3). \url{https://cran.r-project.org/package=pals} Credit: Kevin Wright } Seurat/man/SetIntegrationData.Rd0000644000176200001440000000102613617632030016310 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{SetIntegrationData} \alias{SetIntegrationData} \title{Set integation data} \usage{ SetIntegrationData(object, integration.name, slot, new.data) } \arguments{ \item{object}{Seurat object} \item{integration.name}{Name of integration object} \item{slot}{Which slot in integration object to set} \item{new.data}{New data to insert} } \value{ Returns a \code{\link{Seurat}} object } \description{ Set integation data } Seurat/man/RelativeCounts.Rd0000644000176200001440000000144013617632030015526 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/preprocessing.R \name{RelativeCounts} \alias{RelativeCounts} \title{Normalize raw data to fractions} \usage{ RelativeCounts(data, scale.factor = 1, verbose = TRUE) } \arguments{ \item{data}{Matrix with the raw count data} \item{scale.factor}{Scale the result. Default is 1} \item{verbose}{Print progress} } \value{ Returns a matrix with the relative counts } \description{ Normalize count data to relative counts per cell by dividing by the total per cell. Optionally use a scale factor, e.g. for counts per million (CPM) use \code{scale.factor = 1e6}. } \examples{ mat <- matrix(data = rbinom(n = 25, size = 5, prob = 0.2), nrow = 5) mat mat_norm <- RelativeCounts(data = mat) mat_norm } Seurat/man/TopFeatures.Rd0000644000176200001440000000173213617632030015024 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{TopFeatures} \alias{TopFeatures} \title{Find features with highest scores for a given dimensional reduction technique} \usage{ TopFeatures( object, dim = 1, nfeatures = 20, projected = FALSE, balanced = FALSE, ... ) } \arguments{ \item{object}{DimReduc object} \item{dim}{Dimension to use} \item{nfeatures}{Number of features to return} \item{projected}{Use the projected feature loadings} \item{balanced}{Return an equal number of features with both + and - scores.} \item{...}{Extra parameters passed to \code{\link{Loadings}}} } \value{ Returns a vector of features } \description{ Return a list of features with the strongest contribution to a set of components } \examples{ pbmc_small TopFeatures(object = pbmc_small[["pca"]], dim = 1) # After projection: TopFeatures(object = pbmc_small[["pca"]], dim = 1, projected = TRUE) } Seurat/man/ExpVar.Rd0000644000176200001440000000065713617632030013775 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utilities.R \name{ExpVar} \alias{ExpVar} \title{Calculate the variance of logged values} \usage{ ExpVar(x) } \arguments{ \item{x}{A vector of values} } \value{ Returns the variance in log-space } \description{ Calculate variance of logged values in non-log space (return answer in log-space) } \examples{ ExpVar(x = c(1, 2, 3)) } Seurat/man/SelectIntegrationFeatures.Rd0000644000176200001440000000206113617632030017701 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/integration.R \name{SelectIntegrationFeatures} \alias{SelectIntegrationFeatures} \title{Select integration features} \usage{ SelectIntegrationFeatures( object.list, nfeatures = 2000, assay = NULL, verbose = TRUE, fvf.nfeatures = 2000, ... ) } \arguments{ \item{object.list}{List of seurat objects} \item{nfeatures}{Number of features to return} \item{assay}{Name of assay from which to pull the variable features.} \item{verbose}{Print messages} \item{fvf.nfeatures}{nfeatures for FindVariableFeatures. Used if VariableFeatures have not been set for any object in object.list.} \item{...}{Additional parameters to \code{\link{FindVariableFeatures}}} } \value{ A vector of selected features } \description{ Choose the features to use when integrating multiple datasets. This function ranks features by the number of datasets they appear in, breaking ties by the median rank across datasets. It returns the highest features by this ranking. } Seurat/man/CustomPalette.Rd0000644000176200001440000000226313617632030015354 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{BlackAndWhite} \alias{BlackAndWhite} \alias{BlueAndRed} \alias{CustomPalette} \alias{PurpleAndYellow} \title{Create a custom color palette} \usage{ BlackAndWhite(mid = NULL, k = 50) BlueAndRed(k = 50) CustomPalette(low = "white", high = "red", mid = NULL, k = 50) PurpleAndYellow(k = 50) } \arguments{ \item{mid}{middle color. Optional.} \item{k}{number of steps (colors levels) to include between low and high values} \item{low}{low color} \item{high}{high color} } \value{ A color palette for plotting } \description{ Creates a custom color palette based on low, middle, and high color values } \examples{ df <- data.frame(x = rnorm(n = 100, mean = 20, sd = 2), y = rbinom(n = 100, size = 100, prob = 0.2)) plot(df, col = BlackAndWhite()) df <- data.frame(x = rnorm(n = 100, mean = 20, sd = 2), y = rbinom(n = 100, size = 100, prob = 0.2)) plot(df, col = BlueAndRed()) myPalette <- CustomPalette() myPalette df <- data.frame(x = rnorm(n = 100, mean = 20, sd = 2), y = rbinom(n = 100, size = 100, prob = 0.2)) plot(df, col = PurpleAndYellow()) } Seurat/man/IsGlobal.Rd0000644000176200001440000000162613617632030014261 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{IsGlobal} \alias{IsGlobal} \alias{IsGlobal.default} \alias{IsGlobal.DimReduc} \title{Is an object global/persistent?} \usage{ IsGlobal(object, ...) \method{IsGlobal}{default}(object, ...) \method{IsGlobal}{DimReduc}(object, ...) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} } \value{ \code{TRUE} if the object is global/persistent otherwise \code{FALSE} } \description{ Typically, when removing \code{Assay} objects from an \code{Seurat} object, all associated objects (eg. \code{DimReduc}, \code{Graph}, and \code{SeuratCommand} objects) are removed as well. If an associated object is marked as global/persistent, the associated object will remain even if its original assay was deleted } \examples{ IsGlobal(pbmc_small[['pca']]) } Seurat/man/FindIntegrationAnchors.Rd0000644000176200001440000000600513617632030017163 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/integration.R \name{FindIntegrationAnchors} \alias{FindIntegrationAnchors} \title{Find integration anchors} \usage{ FindIntegrationAnchors( object.list = NULL, assay = NULL, reference = NULL, anchor.features = 2000, scale = TRUE, normalization.method = c("LogNormalize", "SCT"), sct.clip.range = NULL, reduction = c("cca", "rpca"), l2.norm = TRUE, dims = 1:30, k.anchor = 5, k.filter = 200, k.score = 30, max.features = 200, nn.method = "rann", eps = 0, verbose = TRUE ) } \arguments{ \item{object.list}{A list of objects between which to find anchors for downstream integration.} \item{assay}{A vector of assay names specifying which assay to use when constructing anchors. If NULL, the current default assay for each object is used.} \item{reference}{A vector specifying the object/s to be used as a reference during integration. If NULL (default), all pairwise anchors are found (no reference/s). If not NULL, the corresponding objects in \code{object.list} will be used as references. When using a set of specified references, anchors are first found between each query and each reference. The references are then integrated through pairwise integration. Each query is then mapped to the integrated reference.} \item{anchor.features}{Can be either: \itemize{ \item{A numeric value. This will call \code{\link{SelectIntegrationFeatures}} to select the provided number of features to be used in anchor finding} \item{A vector of features to be used as input to the anchor finding process} }} \item{scale}{Whether or not to scale the features provided. Only set to FALSE if you have previously scaled the features you want to use for each object in the object.list} \item{normalization.method}{Name of normalization method used: LogNormalize or SCT} \item{sct.clip.range}{Numeric of length two specifying the min and max values the Pearson residual will be clipped to} \item{reduction}{Dimensional reduction to perform when finding anchors. Can be one of: \itemize{ \item{cca: Canonical correlation analysis} \item{rpca: Reciprocal PCA} }} \item{l2.norm}{Perform L2 normalization on the CCA cell embeddings after dimensional reduction} \item{dims}{Which dimensions to use from the CCA to specify the neighbor search space} \item{k.anchor}{How many neighbors (k) to use when picking anchors} \item{k.filter}{How many neighbors (k) to use when filtering anchors} \item{k.score}{How many neighbors (k) to use when scoring anchors} \item{max.features}{The maximum number of features to use when specifying the neighborhood search space in the anchor filtering} \item{nn.method}{Method for nearest neighbor finding. Options include: rann, annoy} \item{eps}{Error bound on the neighbor finding algorithm (from RANN)} \item{verbose}{Print progress bars and output} } \value{ Returns an AnchorSet object } \description{ Finds the integration anchors } Seurat/man/CellScatter.Rd0000644000176200001440000000176013617632030014771 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{CellScatter} \alias{CellScatter} \alias{CellPlot} \title{Cell-cell scatter plot} \usage{ CellScatter( object, cell1, cell2, features = NULL, highlight = NULL, cols = NULL, pt.size = 1, smooth = FALSE ) } \arguments{ \item{object}{Seurat object} \item{cell1}{Cell 1 name} \item{cell2}{Cell 2 name} \item{features}{Features to plot (default, all features)} \item{highlight}{Features to highlight} \item{cols}{Colors to use for identity class plotting.} \item{pt.size}{Size of the points on the plot} \item{smooth}{Smooth the graph (similar to smoothScatter)} } \value{ A ggplot object } \description{ Creates a plot of scatter plot of features across two single cells. Pearson correlation between the two cells is displayed above the plot. } \examples{ CellScatter(object = pbmc_small, cell1 = 'ATAGGAGAAACAGA', cell2 = 'CATCAGGATGCACA') } Seurat/man/ReadAlevinCsv.Rd0000644000176200001440000000142113617632030015244 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/preprocessing.R \name{ReadAlevinCsv} \alias{ReadAlevinCsv} \title{Load in data from Alevin pipeline} \usage{ ReadAlevinCsv(base.path) } \arguments{ \item{base.path}{Directory containing the alevin/quant_mat* files provided by Alevin.} } \value{ Returns a matrix with rows and columns labeled } \description{ Enables easy loading of csv format matrix provided by Alevin ran with `--dumpCsvCounts` flags. } \examples{ \dontrun{ data_dir <- 'path/to/output/directory' list.files(data_dir) # Should show alevin/quants_mat* files expression_matrix <- ReadAlevinCsv(base.path = data_dir) seurat_object = CreateSeuratObject(counts = expression_matrix) } } \author{ Avi Srivastava } Seurat/man/as.Graph.Rd0000644000176200001440000000165613617632030014233 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{as.Graph} \alias{as.Graph} \alias{as.Graph.Matrix} \alias{as.Graph.matrix} \title{Convert a matrix (or Matrix) to the Graph class.} \usage{ as.Graph(x, ...) \method{as.Graph}{Matrix}(x, ...) \method{as.Graph}{matrix}(x, ...) } \arguments{ \item{x}{The matrix to convert} \item{...}{Arguments passed to other methods (ignored for now)} } \description{ Convert a matrix (or Matrix) to the Graph class. } \examples{ # converting sparse matrix mat <- Matrix::rsparsematrix(nrow = 10, ncol = 10, density = 0.1) rownames(x = mat) <- paste0("feature_", 1:10) colnames(x = mat) <- paste0("cell_", 1:10) g <- as.Graph(x = mat) # converting dense matrix mat <- matrix(data = 1:16, nrow = 4) rownames(x = mat) <- paste0("feature_", 1:4) colnames(x = mat) <- paste0("cell_", 1:4) g <- as.Graph(x = mat) } Seurat/man/LocalStruct.Rd0000644000176200001440000000245113617632030015021 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/integration.R \name{LocalStruct} \alias{LocalStruct} \title{Calculate the local structure preservation metric} \usage{ LocalStruct( object, grouping.var, idents = NULL, neighbors = 100, reduction = "pca", reduced.dims = 1:10, orig.dims = 1:10, verbose = TRUE ) } \arguments{ \item{object}{Seurat object} \item{grouping.var}{Grouping variable} \item{idents}{Optionally specify a set of idents to compute metric for} \item{neighbors}{Number of neighbors to compute in pca/corrected pca space} \item{reduction}{Dimensional reduction to use for corrected space} \item{reduced.dims}{Number of reduced dimensions to use} \item{orig.dims}{Number of PCs to use in original space} \item{verbose}{Display progress bar} } \value{ Returns the average preservation metric } \description{ Calculates a metric that describes how well the local structure of each group prior to integration is preserved after integration. This procedure works as follows: For each group, compute a PCA, compute the top num.neighbors in pca space, compute the top num.neighbors in corrected pca space, compute the size of the intersection of those two sets of neighbors. Return the average over all groups. } Seurat/man/GetResidual.Rd0000644000176200001440000000255613617632030015000 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/preprocessing.R \name{GetResidual} \alias{GetResidual} \title{Calculate pearson residuals of features not in the scale.data} \usage{ GetResidual( object, features, assay = "SCT", umi.assay = "RNA", clip.range = NULL, replace.value = FALSE, verbose = TRUE ) } \arguments{ \item{object}{A seurat object} \item{features}{Name of features to add into the scale.data} \item{assay}{Name of the assay of the seurat object generated by SCTransform} \item{umi.assay}{Name of the assay of the seurat object containing UMI matrix and the default is RNA} \item{clip.range}{Numeric of length two specifying the min and max values the Pearson residual will be clipped to} \item{replace.value}{Recalculate residuals for all features, even if they are already present. Useful if you want to change the clip.range.} \item{verbose}{Whether to print messages and progress bars} } \value{ Returns a Seurat object containing pearson residuals of added features in its scale.data } \description{ This function calls sctransform::get_residuals. } \examples{ pbmc_small <- SCTransform(object = pbmc_small, variable.features.n = 20) pbmc_small <- GetResidual(object = pbmc_small, features = c('MS4A1', 'TCL1A')) } \seealso{ \code{\link[sctransform]{get_residuals}} } Seurat/man/PrepSCTIntegration.Rd0000644000176200001440000000241713617632030016250 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/integration.R \name{PrepSCTIntegration} \alias{PrepSCTIntegration} \title{Prepare an object list that has been run through SCTransform for integration} \usage{ PrepSCTIntegration( object.list, assay = NULL, anchor.features = 2000, sct.clip.range = NULL, verbose = TRUE ) } \arguments{ \item{object.list}{A list of objects to prep for integration} \item{assay}{Name or vector of assay names (one for each object) that correspond to the assay that SCTransform has been run on. If NULL, the current default assay for each object is used.} \item{anchor.features}{Can be either: \itemize{ \item{A numeric value. This will call \code{\link{SelectIntegrationFeatures}} to select the provided number of features to be used in anchor finding} \item{A vector of features to be used as input to the anchor finding process} }} \item{sct.clip.range}{Numeric of length two specifying the min and max values the Pearson residual will be clipped to} \item{verbose}{Display output/messages} } \value{ An object list with the \code{scale.data} slots set to the anchor features } \description{ Prepare an object list that has been run through SCTransform for integration } Seurat/man/NormalizeData.Rd0000644000176200001440000000403013617632030015307 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/preprocessing.R \name{NormalizeData} \alias{NormalizeData} \alias{NormalizeData.default} \alias{NormalizeData.Assay} \alias{NormalizeData.Seurat} \title{Normalize Data} \usage{ NormalizeData(object, ...) \method{NormalizeData}{default}( object, normalization.method = "LogNormalize", scale.factor = 10000, margin = 1, block.size = NULL, verbose = TRUE, ... ) \method{NormalizeData}{Assay}( object, normalization.method = "LogNormalize", scale.factor = 10000, margin = 1, verbose = TRUE, ... ) \method{NormalizeData}{Seurat}( object, assay = NULL, normalization.method = "LogNormalize", scale.factor = 10000, margin = 1, verbose = TRUE, ... ) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{normalization.method}{Method for normalization. \itemize{ \item{LogNormalize: }{Feature counts for each cell are divided by the total counts for that cell and multiplied by the scale.factor. This is then natural-log transformed using log1p.} \item{CLR: }{Applies a centered log ratio transformation} \item{RC: }{Relative counts. Feature counts for each cell are divided by the total counts for that cell and multiplied by the scale.factor. No log-transformation is applied. For counts per million (CPM) set \code{scale.factor = 1e6}} }} \item{scale.factor}{Sets the scale factor for cell-level normalization} \item{margin}{If performing CLR normalization, normalize across features (1) or cells (2)} \item{block.size}{How many cells should be run in each chunk, will try to split evenly across threads} \item{verbose}{display progress bar for normalization procedure} \item{assay}{Name of assay to use} } \value{ Returns object after normalization } \description{ Normalize the count data present in a given assay. } \examples{ \dontrun{ pbmc_small pmbc_small <- NormalizeData(object = pbmc_small) } } Seurat/man/FindConservedMarkers.Rd0000644000176200001440000000362313617632030016642 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/differential_expression.R \name{FindConservedMarkers} \alias{FindConservedMarkers} \title{Finds markers that are conserved between the groups} \usage{ FindConservedMarkers( object, ident.1, ident.2 = NULL, grouping.var, assay = "RNA", slot = "data", meta.method = minimump, verbose = TRUE, ... ) } \arguments{ \item{object}{An object} \item{ident.1}{Identity class to define markers for} \item{ident.2}{A second identity class for comparison. If NULL (default) - use all other cells for comparison.} \item{grouping.var}{grouping variable} \item{assay}{of assay to fetch data for (default is RNA)} \item{slot}{Slot to pull data from; note that if \code{test.use} is "negbinom", "poisson", or "DESeq2", \code{slot} will be set to "counts"} \item{meta.method}{method for combining p-values. Should be a function from the metap package (NOTE: pass the function, not a string)} \item{verbose}{Print a progress bar once expression testing begins} \item{\dots}{parameters to pass to FindMarkers} } \value{ data.frame containing a ranked list of putative conserved markers, and associated statistics (p-values within each group and a combined p-value (such as Fishers combined p-value or others from the metap package), percentage of cells expressing the marker, average differences). Name of group is appended to each associated output column (e.g. CTRL_p_val). If only one group is tested in the grouping.var, max and combined p-values are not returned. } \description{ Finds markers that are conserved between the groups } \examples{ \dontrun{ pbmc_small # Create a simulated grouping variable pbmc_small[['groups']] <- sample(x = c('g1', 'g2'), size = ncol(x = pbmc_small), replace = TRUE) FindConservedMarkers(pbmc_small, ident.1 = 0, ident.2 = 1, grouping.var = "groups") } } Seurat/man/HVFInfo.Rd0000644000176200001440000000230513617632030014017 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{HVFInfo} \alias{HVFInfo} \alias{HVFInfo.Assay} \alias{HVFInfo.Seurat} \title{Get highly variable feature information} \usage{ HVFInfo(object, ...) \method{HVFInfo}{Assay}(object, selection.method, status = FALSE, ...) \method{HVFInfo}{Seurat}(object, selection.method = NULL, assay = NULL, status = FALSE, ...) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{selection.method}{Which method to pull; choose one from \code{c('sctransform', 'sct')} or \code{c('mean.var.plot', 'dispersion', 'mvp', 'disp')}} \item{status}{Add variable status to the resulting data.frame} \item{assay}{Name of assay to pull highly variable feature information for} } \value{ A dataframe with feature means, dispersion, and scaled dispersion } \description{ Get highly variable feature information } \examples{ # Get the HVF info directly from an Assay object HVFInfo(object = pbmc_small[["RNA"]], selection.method = 'vst')[1:5, ] # Get the HVF info from a specific Assay in a Seurat object HVFInfo(object = pbmc_small, assay = "RNA")[1:5, ] } Seurat/man/Misc.Rd0000644000176200001440000000200013617632030013443 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{Misc} \alias{Misc} \alias{Misc<-} \alias{Misc.Assay} \alias{Misc.Seurat} \alias{Misc<-.Assay} \alias{Misc<-.Seurat} \title{Access miscellaneous data} \usage{ Misc(object, ...) Misc(object, ...) <- value \method{Misc}{Assay}(object, slot = NULL, ...) \method{Misc}{Seurat}(object, slot = NULL, ...) \method{Misc}{Assay}(object, slot, ...) <- value \method{Misc}{Seurat}(object, slot, ...) <- value } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{value}{Data to add} \item{slot}{Name of specific bit of meta data to pull} } \value{ Miscellaneous data An object with miscellaneous data added } \description{ Access miscellaneous data Set miscellaneous data } \examples{ # Get the misc info Misc(object = pbmc_small, slot = "example") # Add misc info Misc(object = pbmc_small, slot = "example") <- "testing_misc" } Seurat/man/Idents.Rd0000644000176200001440000000721713617632030014015 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{Idents} \alias{Idents} \alias{Idents<-} \alias{RenameIdents} \alias{RenameIdent} \alias{ReorderIdent} \alias{SetIdent} \alias{StashIdent} \alias{Idents.Seurat} \alias{Idents<-.Seurat} \alias{ReorderIdent.Seurat} \alias{RenameIdents.Seurat} \alias{SetIdent.Seurat} \alias{StashIdent.Seurat} \alias{levels.Seurat} \alias{levels<-.Seurat} \title{Get, set, and manipulate an object's identity classes} \usage{ Idents(object, ...) Idents(object, ...) <- value RenameIdents(object, ...) ReorderIdent(object, var, ...) SetIdent(object, ...) StashIdent(object, save.name, ...) \method{Idents}{Seurat}(object, ...) \method{Idents}{Seurat}(object, cells = NULL, drop = FALSE, ...) <- value \method{ReorderIdent}{Seurat}( object, var, reverse = FALSE, afxn = mean, reorder.numeric = FALSE, ... ) \method{RenameIdents}{Seurat}(object, ...) \method{SetIdent}{Seurat}(object, cells = NULL, value, ...) \method{StashIdent}{Seurat}(object, save.name = "orig.ident", ...) \method{levels}{Seurat}(x) \method{levels}{Seurat}(x) <- value } \arguments{ \item{...}{Arguments passed to other methods; for \code{RenameIdents}: named arguments as \code{old.ident = new.ident}; for \code{ReorderIdent}: arguments passed on to \code{\link{FetchData}}} \item{value}{The name of the identites to pull from object metadata or the identities themselves} \item{var}{Feature or variable to order on} \item{save.name}{Store current identity information under this name} \item{cells}{Set cell identities for specific cells} \item{drop}{Drop unused levels} \item{reverse}{Reverse ordering} \item{afxn}{Function to evaluate each identity class based on; default is \code{\link[base]{mean}}} \item{reorder.numeric}{Rename all identity classes to be increasing numbers starting from 1 (default is FALSE)} \item{x, object}{An object} } \value{ \code{Idents}: The cell identies \code{Idents<-}: An object with the cell identites changed \code{RenameIdents}: An object with selected identity classes renamed \code{ReorderIdent}: An object with \code{SetIdent}: An object with new identity classes set \code{StashIdent}: An object with the identities stashed } \description{ Get, set, and manipulate an object's identity classes } \examples{ # Get cell identity classes Idents(object = pbmc_small) # Set cell identity classes # Can be used to set identities for specific cells to a new level Idents(object = pbmc_small, cells = 1:4) <- 'a' head(x = Idents(object = pbmc_small)) # Can also set idents from a value in object metadata colnames(x = pbmc_small[[]]) Idents(object = pbmc_small) <- 'RNA_snn_res.1' levels(x = pbmc_small) # Rename cell identity classes # Can provide an arbitrary amount of idents to rename levels(x = pbmc_small) pbmc_small <- RenameIdents(object = pbmc_small, '0' = 'A', '2' = 'C') levels(x = pbmc_small) \dontrun{ head(x = Idents(object = pbmc_small)) pbmc_small <- ReorderIdent(object = pbmc_small, var = 'PC_1') head(x = Idents(object = pbmc_small)) } # Set cell identity classes using SetIdent cells.use <- WhichCells(object = pbmc_small, idents = '1') pbmc_small <- SetIdent(object = pbmc_small, cells = cells.use, value = 'B') head(x = pbmc_small[[]]) pbmc_small <- StashIdent(object = pbmc_small, save.name = 'idents') head(x = pbmc_small[[]]) # Get the levels of identity classes of a Seurat object levels(x = pbmc_small) # Reorder identity classes levels(x = pbmc_small) levels(x = pbmc_small) <- c('C', 'A', 'B') levels(x = pbmc_small) } Seurat/man/AnchorSet-class.Rd0000644000176200001440000000251013617632030015547 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \docType{class} \name{AnchorSet-class} \alias{AnchorSet-class} \alias{AnchorSet} \title{The AnchorSet Class} \description{ The AnchorSet class is an intermediate data storage class that stores the anchors and other related information needed for performing downstream analyses - namely data integration (\code{\link{IntegrateData}}) and data transfer (\code{\link{TransferData}}). } \section{Slots}{ \describe{ \item{\code{object.list}}{List of objects used to create anchors} \item{\code{reference.cells}}{List of cell names in the reference dataset - needed when performing data transfer.} \item{\code{reference.objects}}{Position of reference object/s in object.list} \item{\code{query.cells}}{List of cell names in the query dataset - needed when performing data transfer} \item{\code{anchors}}{The anchor matrix. This contains the cell indices of both anchor pair cells, the anchor score, and the index of the original dataset in the object.list for cell1 and cell2 of the anchor.} \item{\code{offsets}}{The offsets used to enable cell look up in downstream functions} \item{\code{anchor.features}}{The features used when performing anchor finding.} \item{\code{command}}{Store log of parameters that were used} }} Seurat/man/UpdateSymbolList.Rd0000644000176200001440000000344713617632030016034 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utilities.R \name{UpdateSymbolList} \alias{UpdateSymbolList} \alias{GeneSymbolThesarus} \title{Get updated synonyms for gene symbols} \source{ \url{https://www.genenames.org/} \url{http://rest.genenames.org/} } \usage{ GeneSymbolThesarus( symbols, timeout = 10, several.ok = FALSE, verbose = TRUE, ... ) UpdateSymbolList( symbols, timeout = 10, several.ok = FALSE, verbose = TRUE, ... ) } \arguments{ \item{symbols}{A vector of gene symbols} \item{timeout}{Time to wait before cancelling query in seconds} \item{several.ok}{Allow several current gene sybmols for each provided symbol} \item{verbose}{Show a progress bar depicting search progress} \item{...}{Extra parameters passed to \code{\link[httr]{GET}}} } \value{ For \code{GeneSymbolThesarus}, if \code{several.ok}, a named list where each entry is the current symbol found for each symbol provided and the names are the provided symbols. Otherwise, a named vector with the same information. For \code{UpdateSymbolList}, \code{symbols} with updated symbols from HGNC's gene names database } \description{ Find current gene symbols based on old or alias symbols using the gene names database from the HUGO Gene Nomenclature Committee (HGNC) } \details{ For each symbol passed, we query the HGNC gene names database for current symbols that have the provided symbol as either an alias (\code{alias_symbol}) or old (\code{prev_symbol}) symbol. All other queries are \strong{not} supported. } \note{ This function requires internet access } \examples{ \dontrun{ GeneSybmolThesarus(symbols = c("FAM64A")) } \dontrun{ UpdateSymbolList(symbols = cc.genes$s.genes) } } \seealso{ \code{\link[httr]{GET}} } Seurat/man/LogVMR.Rd0000644000176200001440000000075513617632030013675 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utilities.R \name{LogVMR} \alias{LogVMR} \title{Calculate the variance to mean ratio of logged values} \usage{ LogVMR(x, ...) } \arguments{ \item{x}{A vector of values} \item{...}{Other arguments (not used)} } \value{ Returns the VMR in log-space } \description{ Calculate the variance to mean ratio (VMR) in non-logspace (return answer in log-space) } \examples{ LogVMR(x = c(1, 2, 3)) } Seurat/man/RidgePlot.Rd0000644000176200001440000000327113617632030014454 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{RidgePlot} \alias{RidgePlot} \title{Single cell ridge plot} \usage{ RidgePlot( object, features, cols = NULL, idents = NULL, sort = FALSE, assay = NULL, group.by = NULL, y.max = NULL, same.y.lims = FALSE, log = FALSE, ncol = NULL, combine = TRUE, slot = "data", ... ) } \arguments{ \item{object}{Seurat object} \item{features}{Features to plot (gene expression, metrics, PC scores, anything that can be retreived by FetchData)} \item{cols}{Colors to use for plotting} \item{idents}{Which classes to include in the plot (default is all)} \item{sort}{Sort identity classes (on the x-axis) by the average expression of the attribute being potted, can also pass 'increasing' or 'decreasing' to change sort direction} \item{assay}{Name of assay to use, defaults to the active assay} \item{group.by}{Group (color) cells in different ways (for example, orig.ident)} \item{y.max}{Maximum y axis value} \item{same.y.lims}{Set all the y-axis limits to the same values} \item{log}{plot the feature axis on log scale} \item{ncol}{Number of columns if multiple plots are displayed} \item{combine}{Combine plots into a single gg object; note that if TRUE; themeing will not work when plotting multiple features} \item{slot}{Use non-normalized counts data for plotting} \item{...}{Extra parameters passed on to \code{\link{CombinePlots}}} } \value{ A ggplot object } \description{ Draws a ridge plot of single cell data (gene expression, metrics, PC scores, etc.) } \examples{ RidgePlot(object = pbmc_small, features = 'PC_1') } Seurat/man/ExportToCellbrowser.Rd0000644000176200001440000000463513617632030016560 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utilities.R \name{ExportToCellbrowser} \alias{ExportToCellbrowser} \title{Export Seurat object for UCSC cell browser} \usage{ ExportToCellbrowser( object, dir, dataset.name = Project(object = object), reductions = "tsne", markers.file = NULL, cluster.field = "Cluster", cb.dir = NULL, port = NULL, skip.expr.matrix = FALSE, skip.metadata = FALSE, skip.reductions = FALSE, ... ) } \arguments{ \item{object}{Seurat object} \item{dir}{path to directory where to save exported files. These are: exprMatrix.tsv, tsne.coords.tsv, meta.tsv, markers.tsv and a default cellbrowser.conf} \item{dataset.name}{name of the dataset. Defaults to Seurat project name} \item{reductions}{vector of reduction names to export} \item{markers.file}{path to file with marker genes} \item{cluster.field}{name of the metadata field containing cell cluster} \item{cb.dir}{path to directory where to create UCSC cellbrowser static website content root, e.g. an index.html, .json files, etc. These files can be copied to any webserver. If this is specified, the cellbrowser package has to be accessible from R via reticulate.} \item{port}{on which port to run UCSC cellbrowser webserver after export} \item{skip.expr.matrix}{whether to skip exporting expression matrix} \item{skip.metadata}{whether to skip exporting metadata} \item{skip.reductions}{whether to skip exporting reductions} \item{...}{specifies the metadata fields to export. To supply field with human readable name, pass name as \code{field="name"} parameter.} } \value{ This function exports Seurat object as a set of tsv files to \code{dir} directory, copying the \code{markers.file} if it is passed. It also creates the default \code{cellbrowser.conf} in the directory. This directory could be read by \code{cbBuild} to create a static website viewer for the dataset. If \code{cb.dir} parameter is passed, the function runs \code{cbBuild} (if it is installed) to create this static website in \code{cb.dir} directory. If \code{port} parameter is passed, it also runs the webserver for that directory and opens a browser. } \description{ Export Seurat object for UCSC cell browser } \examples{ \dontrun{ ExportToCellbrowser(object = pbmc_small, dataset.name = "PBMC", dir = "out") } } \author{ Maximilian Haeussler, Nikolay Markov } Seurat/man/ElbowPlot.Rd0000644000176200001440000000142113617632030014465 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{ElbowPlot} \alias{ElbowPlot} \title{Quickly Pick Relevant Dimensions} \usage{ ElbowPlot(object, ndims = 20, reduction = "pca") } \arguments{ \item{object}{Seurat object} \item{ndims}{Number of dimensions to plot standard deviation for} \item{reduction}{Reduction technique to plot standard deviation for} } \value{ A ggplot object } \description{ Plots the standard deviations (or approximate singular values if running PCAFast) of the principle components for easy identification of an elbow in the graph. This elbow often corresponds well with the significant dims and is much faster to run than Jackstraw } \examples{ ElbowPlot(object = pbmc_small) } Seurat/man/RenameCells.Rd0000644000176200001440000000352313617632030014755 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{RenameCells} \alias{RenameCells} \alias{RenameCells.Assay} \alias{RenameCells.DimReduc} \alias{RenameCells.Seurat} \title{Rename cells} \usage{ RenameCells(object, ...) \method{RenameCells}{Assay}(object, new.names = NULL, ...) \method{RenameCells}{DimReduc}(object, new.names = NULL, ...) \method{RenameCells}{Seurat}( object, add.cell.id = NULL, new.names = NULL, for.merge = FALSE, ... ) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{new.names}{vector of new cell names} \item{add.cell.id}{prefix to add cell names} \item{for.merge}{Only rename slots needed for merging Seurat objects. Currently only renames the raw.data and meta.data slots.} } \value{ An object with new cell names } \description{ Change the cell names in all the different parts of an object. Can be useful before combining multiple objects. } \details{ If \code{add.cell.id} is set a prefix is added to existing cell names. If \code{new.names} is set these will be used to replace existing names. } \examples{ # Rename cells in an Assay head(x = colnames(x = pbmc_small[["RNA"]])) renamed.assay <- RenameCells( object = pbmc_small[["RNA"]], new.names = paste0("A_", colnames(x = pbmc_small[["RNA"]])) ) head(x = colnames(x = renamed.assay)) # Rename cells in a DimReduc head(x = Cells(x = pbmc_small[["pca"]])) renamed.dimreduc <- RenameCells( object = pbmc_small[["pca"]], new.names = paste0("A_", Cells(x = pbmc_small[["pca"]])) ) head(x = Cells(x = renamed.dimreduc)) # Rename cells in a Seurat object head(x = colnames(x = pbmc_small)) pbmc_small <- RenameCells(object = pbmc_small, add.cell.id = "A") head(x = colnames(x = pbmc_small)) } Seurat/man/as.list.SeuratCommand.Rd0000644000176200001440000000115113617632030016674 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{as.list.SeuratCommand} \alias{as.list.SeuratCommand} \title{Coerce a SeuratCommand to a list} \usage{ \method{as.list}{SeuratCommand}(x, complete = FALSE, ...) } \arguments{ \item{x}{object to be coerced or tested.} \item{complete}{Include slots besides just parameters (eg. call string, name, timestamp)} \item{...}{objects, possibly named.} } \value{ A list with the parameters and, if \code{complete = TRUE}, the call string, name, and timestamp } \description{ Coerce a SeuratCommand to a list } Seurat/man/SCTransform.Rd0000644000176200001440000000646213617632030014771 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/preprocessing.R \name{SCTransform} \alias{SCTransform} \title{Use regularized negative binomial regression to normalize UMI count data} \usage{ SCTransform( object, assay = "RNA", new.assay.name = "SCT", do.correct.umi = TRUE, ncells = NULL, variable.features.n = 3000, variable.features.rv.th = 1.3, vars.to.regress = NULL, do.scale = FALSE, do.center = TRUE, clip.range = c(-sqrt(x = ncol(x = object[[assay]])/30), sqrt(x = ncol(x = object[[assay]])/30)), conserve.memory = FALSE, return.only.var.genes = TRUE, seed.use = 1448145, verbose = TRUE, ... ) } \arguments{ \item{object}{A seurat object} \item{assay}{Name of assay to pull the count data from; default is 'RNA'} \item{new.assay.name}{Name for the new assay containing the normalized data} \item{do.correct.umi}{Place corrected UMI matrix in assay counts slot; default is TRUE} \item{ncells}{Number of subsampling cells used to build NB regression; default is NULL} \item{variable.features.n}{Use this many features as variable features after ranking by residual variance; default is 3000} \item{variable.features.rv.th}{Instead of setting a fixed number of variable features, use this residual variance cutoff; this is only used when \code{variable.features.n} is set to NULL; default is 1.3} \item{vars.to.regress}{Variables to regress out in a second non-regularized linear regression. For example, percent.mito. Default is NULL} \item{do.scale}{Whether to scale residuals to have unit variance; default is FALSE} \item{do.center}{Whether to center residuals to have mean zero; default is TRUE} \item{clip.range}{Range to clip the residuals to; default is \code{c(-sqrt(n/30), sqrt(n/30))}, where n is the number of cells} \item{conserve.memory}{If set to TRUE the residual matrix for all genes is never created in full; useful for large data sets, but will take longer to run; this will also set return.only.var.genes to TRUE; default is FALSE} \item{return.only.var.genes}{If set to TRUE the scale.data matrices in output assay are subset to contain only the variable genes; default is TRUE} \item{seed.use}{Set a random seed. By default, sets the seed to 1448145. Setting NULL will not set a seed.} \item{verbose}{Whether to print messages and progress bars} \item{...}{Additional parameters passed to \code{sctransform::vst}} } \value{ Returns a Seurat object with a new assay (named SCT by default) with counts being (corrected) counts, data being log1p(counts), scale.data being pearson residuals; sctransform::vst intermediate results are saved in misc slot of the new assay. } \description{ This function calls sctransform::vst. The sctransform package is available at https://github.com/ChristophH/sctransform. Use this function as an alternative to the NormalizeData, FindVariableFeatures, ScaleData workflow. Results are saved in a new assay (named SCT by default) with counts being (corrected) counts, data being log1p(counts), scale.data being pearson residuals; sctransform::vst intermediate results are saved in misc slot of new assay. } \examples{ SCTransform(object = pbmc_small) } \seealso{ \code{\link[sctransform]{correct_counts}} \code{\link[sctransform]{get_residuals}} } Seurat/man/VariableFeatures.Rd0000644000176200001440000000207013617632030016003 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{VariableFeatures} \alias{VariableFeatures} \alias{VariableFeatures<-} \alias{VariableFeatures.Assay} \alias{VariableFeatures.Seurat} \alias{VariableFeatures<-.Assay} \alias{VariableFeatures<-.Seurat} \title{Get and set variable feature information} \usage{ VariableFeatures(object, ...) VariableFeatures(object, ...) <- value \method{VariableFeatures}{Assay}(object, selection.method = NULL, ...) \method{VariableFeatures}{Seurat}(object, assay = NULL, selection.method = NULL, ...) \method{VariableFeatures}{Assay}(object, ...) <- value \method{VariableFeatures}{Seurat}(object, assay = NULL, ...) <- value } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{value}{A character vector of variable features} \item{selection.method}{Method used to set variable features} \item{assay}{Name of assay to pull variable features for} } \description{ Get and set variable feature information } Seurat/man/Stdev.Rd0000644000176200001440000000143413617632030013647 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{Stdev} \alias{Stdev} \alias{Stdev.DimReduc} \alias{Stdev.Seurat} \title{Get the standard deviations for an object} \usage{ Stdev(object, ...) \method{Stdev}{DimReduc}(object, ...) \method{Stdev}{Seurat}(object, reduction = "pca", ...) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{reduction}{Name of reduction to use} } \description{ Get the standard deviations for an object } \examples{ # Get the standard deviations for each PC from the DimReduc object Stdev(object = pbmc_small[["pca"]]) # Get the standard deviations for each PC from the Seurat object Stdev(object = pbmc_small, reduction = "pca") } Seurat/man/LogNormalize.Rd0000644000176200001440000000124513617632030015164 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/preprocessing.R \name{LogNormalize} \alias{LogNormalize} \title{Normalize raw data} \usage{ LogNormalize(data, scale.factor = 10000, verbose = TRUE) } \arguments{ \item{data}{Matrix with the raw count data} \item{scale.factor}{Scale the data. Default is 1e4} \item{verbose}{Print progress} } \value{ Returns a matrix with the normalize and log transformed data } \description{ Normalize count data per cell and transform to log scale } \examples{ mat <- matrix(data = rbinom(n = 25, size = 5, prob = 0.2), nrow = 5) mat mat_norm <- LogNormalize(data = mat) mat_norm } Seurat/man/Seurat-package.Rd0000644000176200001440000000203613617632030015415 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/zzz.R \docType{package} \name{Seurat-package} \alias{Seurat-package} \title{Tools for single-cell genomics} \description{ Tools for single-cell genomics } \section{Package options}{ Seurat uses the following [options()] to configure behaviour: \describe{ \item{\code{Seurat.memsafe}}{global option to call gc() after many operations. This can be helpful in cleaning up the memory status of the R session and prevent use of swap space. However, it does add to the computational overhead and setting to FALSE can speed things up if you're working in an environment where RAM availabiliy is not a concern.} \item{\code{Seurat.warn.umap.uwot}}{Show warning about the default backend for \code{\link{RunUMAP}} changing from Python UMAP via reticulate to UWOT} \item{\code{Seurat.checkdots}}{For functions that have ... as a parameter, this controls the behavior when an item isn't used. Can be one of warn, stop, or silent.} } } Seurat/man/ScoreJackStraw.Rd0000644000176200001440000000310113617632030015440 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/dimensional_reduction.R \name{ScoreJackStraw} \alias{ScoreJackStraw} \alias{ScoreJackStraw.JackStrawData} \alias{ScoreJackStraw.DimReduc} \alias{ScoreJackStraw.Seurat} \title{Compute Jackstraw scores significance.} \usage{ ScoreJackStraw(object, ...) \method{ScoreJackStraw}{JackStrawData}(object, dims = 1:5, score.thresh = 1e-05, ...) \method{ScoreJackStraw}{DimReduc}(object, dims = 1:5, score.thresh = 1e-05, ...) \method{ScoreJackStraw}{Seurat}( object, reduction = "pca", dims = 1:5, score.thresh = 1e-05, do.plot = FALSE, ... ) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{dims}{Which dimensions to examine} \item{score.thresh}{Threshold to use for the proportion test of PC significance (see Details)} \item{reduction}{Reduction associated with JackStraw to score} \item{do.plot}{Show plot. To return ggplot object, use \code{JackStrawPlot} after running ScoreJackStraw.} } \value{ Returns a Seurat object } \description{ Significant PCs should show a p-value distribution that is strongly skewed to the left compared to the null distribution. The p-value for each PC is based on a proportion test comparing the number of features with a p-value below a particular threshold (score.thresh), compared with the proportion of features expected under a uniform distribution of p-values. } \seealso{ \code{\link{JackStrawPlot}} \code{\link{JackStrawPlot}} } \author{ Omri Wurtzel } Seurat/man/SeuratCommand-class.Rd0000644000176200001440000000131013617632030016420 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \docType{class} \name{SeuratCommand-class} \alias{SeuratCommand-class} \alias{SeuratCommand} \title{The SeuratCommand Class} \description{ The SeuratCommand is used for logging commands that are run on a SeuratObject. It stores parameters and timestamps } \section{Slots}{ \describe{ \item{\code{name}}{Command name} \item{\code{time.stamp}}{Timestamp of when command was tun} \item{\code{assay.used}}{Optional name of assay used to generate \code{SeuratCommand} object} \item{\code{call.string}}{String of the command call} \item{\code{params}}{List of parameters used in the command call} }} Seurat/man/TransferData.Rd0000644000176200001440000000335413617632030015143 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/integration.R \name{TransferData} \alias{TransferData} \title{Transfer Labels} \usage{ TransferData( anchorset, refdata, weight.reduction = "pcaproject", l2.norm = FALSE, dims = 1:30, k.weight = 50, sd.weight = 1, eps = 0, do.cpp = TRUE, verbose = TRUE, slot = "data" ) } \arguments{ \item{anchorset}{Results from FindTransferAnchors} \item{refdata}{Data to transfer. Should be either a vector where the names correspond to reference cells, or a matrix, where the column names correspond to the reference cells.} \item{weight.reduction}{Dimensional reduction to use for the weighting. Options are: \itemize{ \item{pcaproject: Use the projected PCA used for anchor building} \item{pca: Use an internal PCA on the query only} \item{cca: Use the CCA used for anchor building} \item{custom DimReduc: User provided DimReduc object computed on the query cells} }} \item{l2.norm}{Perform L2 normalization on the cell embeddings after dimensional reduction} \item{dims}{Number of PCs to use in the weighting procedure} \item{k.weight}{Number of neighbors to consider when weighting} \item{sd.weight}{Controls the bandwidth of the Gaussian kernel for weighting} \item{eps}{Error bound on the neighbor finding algorithm (from RANN)} \item{do.cpp}{Run cpp code where applicable} \item{verbose}{Print progress bars and output} \item{slot}{Slot to store the imputed data} } \value{ If refdata is a vector, returns a dataframe with label predictions. If refdata is a matrix, returns an Assay object where the imputed data has been stored in the provided slot. } \description{ Transfers the labels } Seurat/man/AddModuleScore.Rd0000644000176200001440000000405713617632030015420 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utilities.R \name{AddModuleScore} \alias{AddModuleScore} \title{Calculate module scores for feature expression programs in single cells} \usage{ AddModuleScore( object, features, pool = NULL, nbin = 24, ctrl = 100, k = FALSE, assay = NULL, name = "Cluster", seed = 1, search = FALSE, ... ) } \arguments{ \item{object}{Seurat object} \item{features}{Feature expression programs in list} \item{pool}{List of features to check expression levels agains, defaults to \code{rownames(x = object)}} \item{nbin}{Number of bins of aggregate expression levels for all analyzed features} \item{ctrl}{Number of control features selected from the same bin per analyzed feature} \item{k}{Use feature clusters returned from DoKMeans} \item{assay}{Name of assay to use} \item{name}{Name for the expression programs} \item{seed}{Set a random seed. If NULL, seed is not set.} \item{search}{Search for symbol synonyms for features in \code{features} that don't match features in \code{object}? Searches the HGNC's gene names database; see \code{\link{UpdateSymbolList}} for more details} \item{...}{Extra parameters passed to \code{\link{UpdateSymbolList}}} } \value{ Returns a Seurat object with module scores added to object meta data } \description{ Calculate the average expression levels of each program (cluster) on single cell level, subtracted by the aggregated expression of control feature sets. All analyzed features are binned based on averaged expression, and the control features are randomly selected from each bin. } \examples{ \dontrun{ cd_features <- list(c( 'CD79B', 'CD79A', 'CD19', 'CD180', 'CD200', 'CD3D', 'CD2', 'CD3E', 'CD7', 'CD8A', 'CD14', 'CD1C', 'CD68', 'CD9', 'CD247' )) pbmc_small <- AddModuleScore( object = pbmc_small, features = cd_features, ctrl = 5, name = 'CD_Features' ) head(x = pbmc_small[]) } } \references{ Tirosh et al, Science (2016) } Seurat/man/Project.Rd0000644000176200001440000000123413617632030014166 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{Project} \alias{Project} \alias{Project<-} \alias{Project.Seurat} \alias{Project<-.Seurat} \title{Get and set project information} \usage{ Project(object, ...) Project(object, ...) <- value \method{Project}{Seurat}(object, ...) \method{Project}{Seurat}(object, ...) <- value } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{value}{Project information to set} } \value{ Project information An object with project information added } \description{ Get and set project information } Seurat/man/Graph-class.Rd0000644000176200001440000000073713617632030014733 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \docType{class} \name{Graph-class} \alias{Graph-class} \alias{Graph} \title{The Graph Class} \description{ The Graph class inherits from dgCMatrix. We do this to enable future expandability of graphs. } \section{Slots}{ \describe{ \item{\code{assay.used}}{Optional name of assay used to generate \code{Graph} object} }} \seealso{ \code{\link[Matrix]{dgCMatrix-class}} } Seurat/man/MixingMetric.Rd0000644000176200001440000000236413617632030015164 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/integration.R \name{MixingMetric} \alias{MixingMetric} \title{Calculates a mixing metric} \usage{ MixingMetric( object, grouping.var, reduction = "pca", dims = 1:2, k = 5, max.k = 300, eps = 0, verbose = TRUE ) } \arguments{ \item{object}{Seurat object} \item{grouping.var}{Grouping variable for dataset} \item{reduction}{Which dimensionally reduced space to use} \item{dims}{Dimensions to use} \item{k}{Neighbor number to examine per group} \item{max.k}{Maximum size of local neighborhood to compute} \item{eps}{Error bound on the neighbor finding algorithm (from RANN)} \item{verbose}{Displays progress bar} } \value{ Returns a vector of values representing the entropy metric from each bootstrapped iteration. } \description{ Here we compute a measure of how well mixed a composite dataset is. To compute, we first examine the local neighborhood for each cell (looking at max.k neighbors) and determine for each group (could be the dataset after integration) the k nearest neighbor and what rank that neighbor was in the overall neighborhood. We then take the median across all groups as the mixing metric per cell. } Seurat/man/FeatureScatter.Rd0000644000176200001440000000311413617632030015500 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{FeatureScatter} \alias{FeatureScatter} \alias{GenePlot} \title{Scatter plot of single cell data} \usage{ FeatureScatter( object, feature1, feature2, cells = NULL, group.by = NULL, cols = NULL, pt.size = 1, shape.by = NULL, span = NULL, smooth = FALSE, slot = "data" ) } \arguments{ \item{object}{Seurat object} \item{feature1}{First feature to plot. Typically feature expression but can also be metrics, PC scores, etc. - anything that can be retreived with FetchData} \item{feature2}{Second feature to plot.} \item{cells}{Cells to include on the scatter plot.} \item{group.by}{Name of one or more metadata columns to group (color) cells by (for example, orig.ident); pass 'ident' to group by identity class} \item{cols}{Colors to use for identity class plotting.} \item{pt.size}{Size of the points on the plot} \item{shape.by}{Ignored for now} \item{span}{Spline span in loess function call, if \code{NULL}, no spline added} \item{smooth}{Smooth the graph (similar to smoothScatter)} \item{slot}{Slot to pull data from, should be one of 'counts', 'data', or 'scale.data'} } \value{ A ggplot object } \description{ Creates a scatter plot of two features (typically feature expression), across a set of single cells. Cells are colored by their identity class. Pearson correlation between the two features is displayed above the plot. } \examples{ FeatureScatter(object = pbmc_small, feature1 = 'CD9', feature2 = 'CD3E') } Seurat/man/as.SingleCellExperiment.Rd0000644000176200001440000000114413617632030017244 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{as.SingleCellExperiment} \alias{as.SingleCellExperiment} \alias{as.SingleCellExperiment.Seurat} \title{Convert objects to SingleCellExperiment objects} \usage{ as.SingleCellExperiment(x, ...) \method{as.SingleCellExperiment}{Seurat}(x, assay = NULL, ...) } \arguments{ \item{x}{An object to convert to class \code{SingleCellExperiment}} \item{...}{Arguments passed to other methods} \item{assay}{Assay to convert} } \description{ Convert objects to SingleCellExperiment objects } Seurat/man/RunTSNE.Rd0000644000176200001440000000610313617632030014016 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/dimensional_reduction.R \name{RunTSNE} \alias{RunTSNE} \alias{RunTSNE.matrix} \alias{RunTSNE.DimReduc} \alias{RunTSNE.dist} \alias{RunTSNE.Seurat} \title{Run t-distributed Stochastic Neighbor Embedding} \usage{ RunTSNE(object, ...) \method{RunTSNE}{matrix}( object, assay = NULL, seed.use = 1, tsne.method = "Rtsne", add.iter = 0, dim.embed = 2, reduction.key = "tSNE_", ... ) \method{RunTSNE}{DimReduc}( object, cells = NULL, dims = 1:5, seed.use = 1, tsne.method = "Rtsne", add.iter = 0, dim.embed = 2, reduction.key = "tSNE_", ... ) \method{RunTSNE}{dist}( object, assay = NULL, seed.use = 1, tsne.method = "Rtsne", add.iter = 0, dim.embed = 2, reduction.key = "tSNE_", ... ) \method{RunTSNE}{Seurat}( object, reduction = "pca", cells = NULL, dims = 1:5, features = NULL, seed.use = 1, tsne.method = "Rtsne", add.iter = 0, dim.embed = 2, distance.matrix = NULL, reduction.name = "tsne", reduction.key = "tSNE_", ... ) } \arguments{ \item{object}{Seurat object} \item{...}{Arguments passed to other methods and to t-SNE call (most commonly used is perplexity)} \item{assay}{Name of assay that that t-SNE is being run on} \item{seed.use}{Random seed for the t-SNE. If NULL, does not set the seed} \item{tsne.method}{Select the method to use to compute the tSNE. Available methods are: \itemize{ \item{Rtsne: }{Use the Rtsne package Barnes-Hut implementation of tSNE (default)} \item{FIt-SNE: }{Use the FFT-accelerated Interpolation-based t-SNE. Based on Kluger Lab code found here: https://github.com/KlugerLab/FIt-SNE} }} \item{add.iter}{If an existing tSNE has already been computed, uses the current tSNE to seed the algorithm and then adds additional iterations on top of this} \item{dim.embed}{The dimensional space of the resulting tSNE embedding (default is 2). For example, set to 3 for a 3d tSNE} \item{reduction.key}{dimensional reduction key, specifies the string before the number for the dimension names. tSNE_ by default} \item{cells}{Which cells to analyze (default, all cells)} \item{dims}{Which dimensions to use as input features} \item{reduction}{Which dimensional reduction (e.g. PCA, ICA) to use for the tSNE. Default is PCA} \item{features}{If set, run the tSNE on this subset of features (instead of running on a set of reduced dimensions). Not set (NULL) by default; \code{dims} must be NULL to run on features} \item{distance.matrix}{If set, runs tSNE on the given distance matrix instead of data matrix (experimental)} \item{reduction.name}{dimensional reduction name, specifies the position in the object$dr list. tsne by default} } \description{ Run t-SNE dimensionality reduction on selected features. Has the option of running in a reduced dimensional space (i.e. spectral tSNE, recommended), or running based on a set of genes. For details about stored TSNE calculation parameters, see \code{PrintTSNEParams}. } Seurat/man/MetaFeature.Rd0000644000176200001440000000176513617632030014773 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utilities.R \name{MetaFeature} \alias{MetaFeature} \title{Aggregate expression of multiple features into a single feature} \usage{ MetaFeature( object, features, meta.name = "metafeature", cells = NULL, assay = NULL, slot = "data" ) } \arguments{ \item{object}{A Seurat object} \item{features}{List of features to aggregate} \item{meta.name}{Name of column in metadata to store metafeature} \item{cells}{List of cells to use (default all cells)} \item{assay}{Which assay to use} \item{slot}{Which slot to take data from (default data)} } \value{ Returns a \code{Seurat} object with metafeature stored in objct metadata } \description{ Calculates relative contribution of each feature to each cell for given set of features. } \examples{ pbmc_small <- MetaFeature( object = pbmc_small, features = c("LTB", "EAF2"), meta.name = 'var.aggregate' ) head(pbmc_small[[]]) } Seurat/man/VariableFeaturePlot.Rd0000644000176200001440000000172113617632030016461 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{VariableFeaturePlot} \alias{VariableFeaturePlot} \alias{VariableGenePlot} \alias{MeanVarPlot} \title{View variable features} \usage{ VariableFeaturePlot( object, cols = c("black", "red"), pt.size = 1, log = NULL, selection.method = NULL, assay = NULL ) } \arguments{ \item{object}{Seurat object} \item{cols}{Colors to specify non-variable/variable status} \item{pt.size}{Size of the points on the plot} \item{log}{Plot the x-axis in log scale} \item{selection.method}{Which method to pull; choose one from \code{c('sctransform', 'sct')} or \code{c('mean.var.plot', 'dispersion', 'mvp', 'disp')}} \item{assay}{Assay to pull variable features from} } \value{ A ggplot object } \description{ View variable features } \examples{ VariableFeaturePlot(object = pbmc_small) } \seealso{ \code{\link{FindVariableFeatures}} } Seurat/man/CombinePlots.Rd0000644000176200001440000000201413617632030015153 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{CombinePlots} \alias{CombinePlots} \title{Combine ggplot2-based plots into a single plot} \usage{ CombinePlots(plots, ncol = NULL, legend = NULL, ...) } \arguments{ \item{plots}{A list of gg objects} \item{ncol}{Number of columns} \item{legend}{Combine legends into a single legend choose from 'right' or 'bottom'; pass 'none' to remove legends, or \code{NULL} to leave legends as they are} \item{...}{Extra parameters passed to plot_grid} } \value{ A combined plot } \description{ Combine ggplot2-based plots into a single plot } \examples{ pbmc_small[['group']] <- sample( x = c('g1', 'g2'), size = ncol(x = pbmc_small), replace = TRUE ) plots <- FeaturePlot( object = pbmc_small, features = c('MS4A1', 'FCN1'), split.by = 'group', combine = FALSE ) CombinePlots( plots = plots, legend = 'none', nrow = length(x = unique(x = pbmc_small[['group', drop = TRUE]])) ) } Seurat/man/JS.Rd0000644000176200001440000000154513617632030013101 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{JS} \alias{JS} \alias{JS<-} \alias{JS.DimReduc} \alias{JS.JackStrawData} \alias{JS<-.DimReduc} \alias{JS<-.JackStrawData} \title{Get JackStraw information} \usage{ JS(object, ...) JS(object, ...) <- value \method{JS}{DimReduc}(object, slot = NULL, ...) \method{JS}{JackStrawData}(object, slot, ...) \method{JS}{DimReduc}(object, slot = NULL, ...) <- value \method{JS}{JackStrawData}(object, slot, ...) <- value } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{value}{JackStraw information} \item{slot}{Name of slot to store JackStraw scores to Can shorten to 'empirical', 'fake', 'full', or 'overall'} } \description{ Get JackStraw information Set JackStraw information } Seurat/man/LabelPoints.Rd0000644000176200001440000000245613617632030015003 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{LabelPoints} \alias{LabelPoints} \alias{Labeler} \title{Add text labels to a ggplot2 plot} \usage{ LabelPoints( plot, points, labels = NULL, repel = FALSE, xnudge = 0.3, ynudge = 0.05, ... ) } \arguments{ \item{plot}{A ggplot2 plot with a GeomPoint layer} \item{points}{A vector of points to label; if \code{NULL}, will use all points in the plot} \item{labels}{A vector of labels for the points; if \code{NULL}, will use rownames of the data provided to the plot at the points selected} \item{repel}{Use \code{geom_text_repel} to create a nicely-repelled labels; this is slow when a lot of points are being plotted. If using \code{repel}, set \code{xnudge} and \code{ynudge} to 0} \item{xnudge, ynudge}{Amount to nudge X and Y coordinates of labels by} \item{...}{Extra parameters passed to \code{geom_text}} } \value{ A ggplot object } \description{ Add text labels to a ggplot2 plot } \examples{ ff <- TopFeatures(object = pbmc_small[['pca']]) cc <- TopCells(object = pbmc_small[['pca']]) plot <- FeatureScatter(object = pbmc_small, feature1 = ff[1], feature2 = ff[2]) LabelPoints(plot = plot, points = cc) } \seealso{ \code{\link[ggplot2]{geom_text}} } Seurat/man/BarcodeInflectionsPlot.Rd0000644000176200001440000000202213617632030017150 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{BarcodeInflectionsPlot} \alias{BarcodeInflectionsPlot} \title{Plot the Barcode Distribution and Calculated Inflection Points} \usage{ BarcodeInflectionsPlot(object) } \arguments{ \item{object}{Seurat object} } \value{ Returns a `ggplot2` object showing the by-group inflection points and provided (or default) rank threshold values in grey. } \description{ This function plots the calculated inflection points derived from the barcode-rank distribution. } \details{ See [CalculateBarcodeInflections()] to calculate inflection points and [SubsetByBarcodeInflections()] to subsequently subset the Seurat object. } \examples{ pbmc_small <- CalculateBarcodeInflections(pbmc_small, group.column = 'groups') BarcodeInflectionsPlot(pbmc_small) } \seealso{ \code{\link{CalculateBarcodeInflections}} \code{\link{SubsetByBarcodeInflections}} } \author{ Robert A. Amezquita, \email{robert.amezquita@fredhutch.org} } Seurat/man/print.DimReduc.Rd0000644000176200001440000000131013617632030015402 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{print.DimReduc} \alias{print.DimReduc} \alias{print} \title{Print the results of a dimensional reduction analysis} \usage{ \method{print}{DimReduc}(x, dims = 1:5, nfeatures = 20, projected = FALSE, ...) } \arguments{ \item{x}{An object} \item{dims}{Number of dimensions to display} \item{nfeatures}{Number of genes to display} \item{projected}{Use projected slot} \item{...}{Arguments passed to other methods} } \value{ Set of features defining the components } \description{ Prints a set of features that most strongly define a set of components } \seealso{ \code{\link[base]{cat}} } Seurat/man/JackStraw.Rd0000644000176200001440000000331113617632030014447 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dimensional_reduction.R \name{JackStraw} \alias{JackStraw} \title{Determine statistical significance of PCA scores.} \usage{ JackStraw( object, reduction = "pca", assay = NULL, dims = 20, num.replicate = 100, prop.freq = 0.01, verbose = TRUE, maxit = 1000 ) } \arguments{ \item{object}{Seurat object} \item{reduction}{DimReduc to use. ONLY PCA CURRENTLY SUPPORTED.} \item{assay}{Assay used to calculate reduction.} \item{dims}{Number of PCs to compute significance for} \item{num.replicate}{Number of replicate samplings to perform} \item{prop.freq}{Proportion of the data to randomly permute for each replicate} \item{verbose}{Print progress bar showing the number of replicates that have been processed.} \item{maxit}{maximum number of iterations to be performed by the irlba function of RunPCA} } \value{ Returns a Seurat object where JS(object = object[['pca']], slot = 'empirical') represents p-values for each gene in the PCA analysis. If ProjectPCA is subsequently run, JS(object = object[['pca']], slot = 'full') then represents p-values for all genes. } \description{ Randomly permutes a subset of data, and calculates projected PCA scores for these 'random' genes. Then compares the PCA scores for the 'random' genes with the observed PCA scores to determine statistical signifance. End result is a p-value for each gene's association with each principal component. } \examples{ \dontrun{ pbmc_small = suppressWarnings(JackStraw(pbmc_small)) head(JS(object = pbmc_small[['pca']], slot = 'empirical')) } } \references{ Inspired by Chung et al, Bioinformatics (2014) } Seurat/man/SplitObject.Rd0000644000176200001440000000215213617632030015002 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{SplitObject} \alias{SplitObject} \title{Splits object into a list of subsetted objects.} \usage{ SplitObject(object, split.by = "ident") } \arguments{ \item{object}{Seurat object} \item{split.by}{Attribute for splitting. Default is "ident". Currently only supported for class-level (i.e. non-quantitative) attributes.} } \value{ A named list of Seurat objects, each containing a subset of cells from the original object. } \description{ Splits object based on a single attribute into a list of subsetted objects, one for each level of the attribute. For example, useful for taking an object that contains cells from many patients, and subdividing it into patient-specific objects. } \examples{ # Assign the test object a three level attribute groups <- sample(c("group1", "group2", "group3"), size = 80, replace = TRUE) names(groups) <- colnames(pbmc_small) pbmc_small <- AddMetaData(object = pbmc_small, metadata = groups, col.name = "group") obj.list <- SplitObject(pbmc_small, split.by = "group") } Seurat/man/LabelClusters.Rd0000644000176200001440000000223213617632030015323 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{LabelClusters} \alias{LabelClusters} \title{Label clusters on a ggplot2-based scatter plot} \usage{ LabelClusters( plot, id, clusters = NULL, labels = NULL, split.by = NULL, repel = TRUE, ... ) } \arguments{ \item{plot}{A ggplot2-based scatter plot} \item{id}{Name of variable used for coloring scatter plot} \item{clusters}{Vector of cluster ids to label} \item{labels}{Custom labels for the clusters} \item{split.by}{Split labels by some grouping label, useful when using \code{\link[ggplot2]{facet_wrap}} or \code{\link[ggplot2]{facet_grid}}} \item{repel}{Use \code{geom_text_repel} to create nicely-repelled labels} \item{...}{Extra parameters to \code{\link[ggrepel]{geom_text_repel}}, such as \code{size}} } \value{ A ggplot2-based scatter plot with cluster labels } \description{ Label clusters on a ggplot2-based scatter plot } \examples{ plot <- DimPlot(object = pbmc_small) LabelClusters(plot = plot, id = 'ident') } \seealso{ \code{\link[ggrepel]{geom_text_repel}} \code{\link[ggplot2]{geom_text}} } Seurat/man/FindClusters.Rd0000644000176200001440000000642013617632030015167 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/clustering.R \name{FindClusters} \alias{FindClusters} \alias{FindClusters.default} \alias{FindClusters.Seurat} \title{Cluster Determination} \usage{ FindClusters(object, ...) \method{FindClusters}{default}( object, modularity.fxn = 1, initial.membership = NULL, weights = NULL, node.sizes = NULL, resolution = 0.8, method = "matrix", algorithm = 1, n.start = 10, n.iter = 10, random.seed = 0, group.singletons = TRUE, temp.file.location = NULL, edge.file.name = NULL, verbose = TRUE, ... ) \method{FindClusters}{Seurat}( object, graph.name = NULL, modularity.fxn = 1, initial.membership = NULL, weights = NULL, node.sizes = NULL, resolution = 0.8, method = "matrix", algorithm = 1, n.start = 10, n.iter = 10, random.seed = 0, group.singletons = TRUE, temp.file.location = NULL, edge.file.name = NULL, verbose = TRUE, ... ) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{modularity.fxn}{Modularity function (1 = standard; 2 = alternative).} \item{initial.membership, weights, node.sizes}{Parameters to pass to the Python leidenalg function.} \item{resolution}{Value of the resolution parameter, use a value above (below) 1.0 if you want to obtain a larger (smaller) number of communities.} \item{method}{Method for running leiden (defaults to matrix which is fast for small datasets). Enable method = "igraph" to avoid casting large data to a dense matrix.} \item{algorithm}{Algorithm for modularity optimization (1 = original Louvain algorithm; 2 = Louvain algorithm with multilevel refinement; 3 = SLM algorithm; 4 = Leiden algorithm). Leiden requires the leidenalg python.} \item{n.start}{Number of random starts.} \item{n.iter}{Maximal number of iterations per random start.} \item{random.seed}{Seed of the random number generator.} \item{group.singletons}{Group singletons into nearest cluster. If FALSE, assign all singletons to a "singleton" group} \item{temp.file.location}{Directory where intermediate files will be written. Specify the ABSOLUTE path.} \item{edge.file.name}{Edge file to use as input for modularity optimizer jar.} \item{verbose}{Print output} \item{graph.name}{Name of graph to use for the clustering algorithm} } \value{ Returns a Seurat object where the idents have been updated with new cluster info; latest clustering results will be stored in object metadata under 'seurat_clusters'. Note that 'seurat_clusters' will be overwritten everytime FindClusters is run } \description{ Identify clusters of cells by a shared nearest neighbor (SNN) modularity optimization based clustering algorithm. First calculate k-nearest neighbors and construct the SNN graph. Then optimize the modularity function to determine clusters. For a full description of the algorithms, see Waltman and van Eck (2013) \emph{The European Physical Journal B}. Thanks to Nigel Delaney (evolvedmicrobe@github) for the rewrite of the Java modularity optimizer code in Rcpp! } \details{ To run Leiden algorithm, you must first install the leidenalg python package (e.g. via pip install leidenalg), see Traag et al (2018). } Seurat/man/RunICA.Rd0000644000176200001440000000436213617632030013646 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/dimensional_reduction.R \name{RunICA} \alias{RunICA} \alias{RunICA.default} \alias{RunICA.Assay} \alias{RunICA.Seurat} \title{Run Independent Component Analysis on gene expression} \usage{ RunICA(object, ...) \method{RunICA}{default}( object, assay = NULL, nics = 50, rev.ica = FALSE, ica.function = "icafast", verbose = TRUE, ndims.print = 1:5, nfeatures.print = 30, reduction.name = "ica", reduction.key = "ica_", seed.use = 42, ... ) \method{RunICA}{Assay}( object, assay = NULL, features = NULL, nics = 50, rev.ica = FALSE, ica.function = "icafast", verbose = TRUE, ndims.print = 1:5, nfeatures.print = 30, reduction.name = "ica", reduction.key = "ica_", seed.use = 42, ... ) \method{RunICA}{Seurat}( object, assay = NULL, features = NULL, nics = 50, rev.ica = FALSE, ica.function = "icafast", verbose = TRUE, ndims.print = 1:5, nfeatures.print = 30, reduction.name = "ica", reduction.key = "IC_", seed.use = 42, ... ) } \arguments{ \item{object}{Seurat object} \item{\dots}{Additional arguments to be passed to fastica} \item{assay}{Name of Assay ICA is being run on} \item{nics}{Number of ICs to compute} \item{rev.ica}{By default, computes the dimensional reduction on the cell x feature matrix. Setting to true will compute it on the transpose (feature x cell matrix).} \item{ica.function}{ICA function from ica package to run (options: icafast, icaimax, icajade)} \item{verbose}{Print the top genes associated with high/low loadings for the ICs} \item{ndims.print}{ICs to print genes for} \item{nfeatures.print}{Number of genes to print for each IC} \item{reduction.name}{dimensional reduction name} \item{reduction.key}{dimensional reduction key, specifies the string before the number for the dimension names.} \item{seed.use}{Set a random seed. Setting NULL will not set a seed.} \item{features}{Features to compute ICA on} } \description{ Run fastica algorithm from the ica package for ICA dimensionality reduction. For details about stored ICA calculation parameters, see \code{PrintICAParams}. } Seurat/man/DietSeurat.Rd0000644000176200001440000000207613617632030014636 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{DietSeurat} \alias{DietSeurat} \title{Slim down a Seurat object} \usage{ DietSeurat( object, counts = TRUE, data = TRUE, scale.data = FALSE, features = NULL, assays = NULL, dimreducs = NULL, graphs = NULL ) } \arguments{ \item{object}{Seurat object} \item{counts}{Preserve the count matrices for the assays specified} \item{data}{Preserve the data slot for the assays specified} \item{scale.data}{Preserve the scale.data slot for the assays specified} \item{features}{Only keep a subset of features, defaults to all features} \item{assays}{Only keep a subset of assays specified here} \item{dimreducs}{Only keep a subset of DimReducs specified here (if NULL, remove all DimReducs)} \item{graphs}{Only keep a subset of Graphs specified here (if NULL, remove all Graphs)} } \description{ Keep only certain aspects of the Seurat object. Can be useful in functions that utilize merge as it reduces the amount of data in the merge. } Seurat/man/UpdateSeuratObject.Rd0000644000176200001440000000123213617632030016313 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{UpdateSeuratObject} \alias{UpdateSeuratObject} \title{Update old Seurat object to accomodate new features} \usage{ UpdateSeuratObject(object) } \arguments{ \item{object}{Seurat object} } \value{ Returns a Seurat object compatible with latest changes } \description{ Updates Seurat objects to new structure for storing data/calculations. For Seurat v3 objects, will validate object structure ensuring all keys and feature names are formed properly. } \examples{ \dontrun{ updated_seurat_object = UpdateSeuratObject(object = old_seurat_object) } } Seurat/man/Loadings.Rd0000644000176200001440000000245313617632030014324 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{Loadings} \alias{Loadings} \alias{Loadings<-} \alias{Loadings.DimReduc} \alias{Loadings.Seurat} \alias{Loadings<-.DimReduc} \title{Get feature loadings} \usage{ Loadings(object, ...) Loadings(object, ...) <- value \method{Loadings}{DimReduc}(object, projected = FALSE, ...) \method{Loadings}{Seurat}(object, reduction = "pca", projected = FALSE, ...) \method{Loadings}{DimReduc}(object, projected = TRUE, ...) <- value } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{value}{Feature loadings to add} \item{projected}{Pull the projected feature loadings?} \item{reduction}{Name of reduction to pull feature loadings for} } \description{ Get feature loadings Add feature loadings } \examples{ # Get the feature loadings for a given DimReduc Loadings(object = pbmc_small[["pca"]])[1:5,1:5] # Get the feature loadings for a specified DimReduc in a Seurat object Loadings(object = pbmc_small, reduction = "pca")[1:5,1:5] # Set the feature loadings for a given DimReduc new.loadings <- Loadings(object = pbmc_small[["pca"]]) new.loadings <- new.loadings + 0.01 Loadings(object = pbmc_small[["pca"]]) <- new.loadings } Seurat/man/DefaultAssay.Rd0000644000176200001440000000256113617632030015151 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{DefaultAssay} \alias{DefaultAssay} \alias{DefaultAssay<-} \alias{DefaultAssay.Assay} \alias{DefaultAssay.DimReduc} \alias{DefaultAssay.Graph} \alias{DefaultAssay.Seurat} \alias{DefaultAssay.SeuratCommand} \alias{DefaultAssay<-.Seurat} \title{Get and set the default assay} \usage{ DefaultAssay(object, ...) DefaultAssay(object, ...) <- value \method{DefaultAssay}{Assay}(object, ...) \method{DefaultAssay}{DimReduc}(object, ...) \method{DefaultAssay}{Graph}(object, ...) \method{DefaultAssay}{Seurat}(object, ...) \method{DefaultAssay}{SeuratCommand}(object, ...) \method{DefaultAssay}{Seurat}(object, ...) <- value } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{value}{Name of assay to set as default} } \value{ The name of the default assay An object with the new default assay } \description{ Get and set the default assay } \examples{ # Get current default assay DefaultAssay(object = pbmc_small) # Create dummy new assay to demo switching default assays new.assay <- pbmc_small[["RNA"]] Key(object = new.assay) <- "RNA2_" pbmc_small[["RNA2"]] <- new.assay # switch default assay to RNA2 DefaultAssay(object = pbmc_small) <- "RNA2" DefaultAssay(object = pbmc_small) } Seurat/man/DotPlot.Rd0000644000176200001440000000433713617632030014154 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{DotPlot} \alias{DotPlot} \alias{SplitDotPlotGG} \title{Dot plot visualization} \usage{ DotPlot( object, assay = NULL, features, cols = c("lightgrey", "blue"), col.min = -2.5, col.max = 2.5, dot.min = 0, dot.scale = 6, group.by = NULL, split.by = NULL, scale.by = "radius", scale.min = NA, scale.max = NA ) } \arguments{ \item{object}{Seurat object} \item{assay}{Name of assay to use, defaults to the active assay} \item{features}{Input vector of features} \item{cols}{Colors to plot, can pass a single character giving the name of a palette from \code{RColorBrewer::brewer.pal.info}} \item{col.min}{Minimum scaled average expression threshold (everything smaller will be set to this)} \item{col.max}{Maximum scaled average expression threshold (everything larger will be set to this)} \item{dot.min}{The fraction of cells at which to draw the smallest dot (default is 0). All cell groups with less than this expressing the given gene will have no dot drawn.} \item{dot.scale}{Scale the size of the points, similar to cex} \item{group.by}{Factor to group the cells by} \item{split.by}{Factor to split the groups by (replicates the functionality of the old SplitDotPlotGG); see \code{\link{FetchData}} for more details} \item{scale.by}{Scale the size of the points by 'size' or by 'radius'} \item{scale.min}{Set lower limit for scaling, use NA for default} \item{scale.max}{Set upper limit for scaling, use NA for default} } \value{ A ggplot object } \description{ Intuitive way of visualizing how feature expression changes across different identity classes (clusters). The size of the dot encodes the percentage of cells within a class, while the color encodes the AverageExpression level across all cells within a class (blue is high). } \examples{ cd_genes <- c("CD247", "CD3E", "CD9") DotPlot(object = pbmc_small, features = cd_genes) pbmc_small[['groups']] <- sample(x = c('g1', 'g2'), size = ncol(x = pbmc_small), replace = TRUE) DotPlot(object = pbmc_small, features = cd_genes, split.by = 'groups') } \seealso{ \code{RColorBrewer::brewer.pal.info} } Seurat/man/PlotClusterTree.Rd0000644000176200001440000000112513617632030015657 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{PlotClusterTree} \alias{PlotClusterTree} \title{Plot clusters as a tree} \usage{ PlotClusterTree(object, ...) } \arguments{ \item{object}{Seurat object} \item{\dots}{Additional arguments to ape::plot.phylo} } \value{ Plots dendogram (must be precomputed using BuildClusterTree), returns no value } \description{ Plots previously computed tree (from BuildClusterTree) } \examples{ pbmc_small <- BuildClusterTree(object = pbmc_small) PlotClusterTree(object = pbmc_small) } Seurat/man/FindMarkers.Rd0000644000176200001440000002235013617632030014767 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/differential_expression.R \name{FindMarkers} \alias{FindMarkers} \alias{FindMarkersNode} \alias{FindMarkers.default} \alias{FindMarkers.Seurat} \title{Gene expression markers of identity classes} \usage{ FindMarkers(object, ...) \method{FindMarkers}{default}( object, slot = "data", counts = numeric(), cells.1 = NULL, cells.2 = NULL, features = NULL, reduction = NULL, logfc.threshold = 0.25, test.use = "wilcox", min.pct = 0.1, min.diff.pct = -Inf, verbose = TRUE, only.pos = FALSE, max.cells.per.ident = Inf, random.seed = 1, latent.vars = NULL, min.cells.feature = 3, min.cells.group = 3, pseudocount.use = 1, ... ) \method{FindMarkers}{Seurat}( object, ident.1 = NULL, ident.2 = NULL, group.by = NULL, subset.ident = NULL, assay = NULL, slot = "data", reduction = NULL, features = NULL, logfc.threshold = 0.25, test.use = "wilcox", min.pct = 0.1, min.diff.pct = -Inf, verbose = TRUE, only.pos = FALSE, max.cells.per.ident = Inf, random.seed = 1, latent.vars = NULL, min.cells.feature = 3, min.cells.group = 3, pseudocount.use = 1, ... ) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods and to specific DE methods} \item{slot}{Slot to pull data from; note that if \code{test.use} is "negbinom", "poisson", or "DESeq2", \code{slot} will be set to "counts"} \item{counts}{Count matrix if using scale.data for DE tests. This is used for computing pct.1 and pct.2 and for filtering features based on fraction expressing} \item{cells.1}{Vector of cell names belonging to group 1} \item{cells.2}{Vector of cell names belonging to group 2} \item{features}{Genes to test. Default is to use all genes} \item{reduction}{Reduction to use in differential expression testing - will test for DE on cell embeddings} \item{logfc.threshold}{Limit testing to genes which show, on average, at least X-fold difference (log-scale) between the two groups of cells. Default is 0.25 Increasing logfc.threshold speeds up the function, but can miss weaker signals.} \item{test.use}{Denotes which test to use. Available options are: \itemize{ \item{"wilcox"} : Identifies differentially expressed genes between two groups of cells using a Wilcoxon Rank Sum test (default) \item{"bimod"} : Likelihood-ratio test for single cell gene expression, (McDavid et al., Bioinformatics, 2013) \item{"roc"} : Identifies 'markers' of gene expression using ROC analysis. For each gene, evaluates (using AUC) a classifier built on that gene alone, to classify between two groups of cells. An AUC value of 1 means that expression values for this gene alone can perfectly classify the two groupings (i.e. Each of the cells in cells.1 exhibit a higher level than each of the cells in cells.2). An AUC value of 0 also means there is perfect classification, but in the other direction. A value of 0.5 implies that the gene has no predictive power to classify the two groups. Returns a 'predictive power' (abs(AUC-0.5) * 2) ranked matrix of putative differentially expressed genes. \item{"t"} : Identify differentially expressed genes between two groups of cells using the Student's t-test. \item{"negbinom"} : Identifies differentially expressed genes between two groups of cells using a negative binomial generalized linear model. Use only for UMI-based datasets \item{"poisson"} : Identifies differentially expressed genes between two groups of cells using a poisson generalized linear model. Use only for UMI-based datasets \item{"LR"} : Uses a logistic regression framework to determine differentially expressed genes. Constructs a logistic regression model predicting group membership based on each feature individually and compares this to a null model with a likelihood ratio test. \item{"MAST"} : Identifies differentially expressed genes between two groups of cells using a hurdle model tailored to scRNA-seq data. Utilizes the MAST package to run the DE testing. \item{"DESeq2"} : Identifies differentially expressed genes between two groups of cells based on a model using DESeq2 which uses a negative binomial distribution (Love et al, Genome Biology, 2014).This test does not support pre-filtering of genes based on average difference (or percent detection rate) between cell groups. However, genes may be pre-filtered based on their minimum detection rate (min.pct) across both cell groups. To use this method, please install DESeq2, using the instructions at https://bioconductor.org/packages/release/bioc/html/DESeq2.html }} \item{min.pct}{only test genes that are detected in a minimum fraction of min.pct cells in either of the two populations. Meant to speed up the function by not testing genes that are very infrequently expressed. Default is 0.1} \item{min.diff.pct}{only test genes that show a minimum difference in the fraction of detection between the two groups. Set to -Inf by default} \item{verbose}{Print a progress bar once expression testing begins} \item{only.pos}{Only return positive markers (FALSE by default)} \item{max.cells.per.ident}{Down sample each identity class to a max number. Default is no downsampling. Not activated by default (set to Inf)} \item{random.seed}{Random seed for downsampling} \item{latent.vars}{Variables to test, used only when \code{test.use} is one of 'LR', 'negbinom', 'poisson', or 'MAST'} \item{min.cells.feature}{Minimum number of cells expressing the feature in at least one of the two groups, currently only used for poisson and negative binomial tests} \item{min.cells.group}{Minimum number of cells in one of the groups} \item{pseudocount.use}{Pseudocount to add to averaged expression values when calculating logFC. 1 by default.} \item{ident.1}{Identity class to define markers for; pass an object of class \code{phylo} or 'clustertree' to find markers for a node in a cluster tree; passing 'clustertree' requires \code{\link{BuildClusterTree}} to have been run} \item{ident.2}{A second identity class for comparison; if \code{NULL}, use all other cells for comparison; if an object of class \code{phylo} or 'clustertree' is passed to \code{ident.1}, must pass a node to find markers for} \item{group.by}{Regroup cells into a different identity class prior to performing differential expression (see example)} \item{subset.ident}{Subset a particular identity class prior to regrouping. Only relevant if group.by is set (see example)} \item{assay}{Assay to use in differential expression testing} } \value{ data.frame with a ranked list of putative markers as rows, and associated statistics as columns (p-values, ROC score, etc., depending on the test used (\code{test.use})). The following columns are always present: \itemize{ \item \code{avg_logFC}: log fold-chage of the average expression between the two groups. Positive values indicate that the gene is more highly expressed in the first group \item \code{pct.1}: The percentage of cells where the gene is detected in the first group \item \code{pct.2}: The percentage of cells where the gene is detected in the second group \item \code{p_val_adj}: Adjusted p-value, based on bonferroni correction using all genes in the dataset } } \description{ Finds markers (differentially expressed genes) for identity classes } \details{ p-value adjustment is performed using bonferroni correction based on the total number of genes in the dataset. Other correction methods are not recommended, as Seurat pre-filters genes using the arguments above, reducing the number of tests performed. Lastly, as Aaron Lun has pointed out, p-values should be interpreted cautiously, as the genes used for clustering are the same genes tested for differential expression. } \examples{ # Find markers for cluster 2 markers <- FindMarkers(object = pbmc_small, ident.1 = 2) head(x = markers) # Take all cells in cluster 2, and find markers that separate cells in the 'g1' group (metadata # variable 'group') markers <- FindMarkers(pbmc_small, ident.1 = "g1", group.by = 'groups', subset.ident = "2") head(x = markers) # Pass 'clustertree' or an object of class phylo to ident.1 and # a node to ident.2 as a replacement for FindMarkersNode pbmc_small <- BuildClusterTree(object = pbmc_small) markers <- FindMarkers(object = pbmc_small, ident.1 = 'clustertree', ident.2 = 5) head(x = markers) } \references{ McDavid A, Finak G, Chattopadyay PK, et al. Data exploration, quality control and testing in single-cell qPCR-based gene expression experiments. Bioinformatics. 2013;29(4):461-467. doi:10.1093/bioinformatics/bts714 Trapnell C, et al. The dynamics and regulators of cell fate decisions are revealed by pseudotemporal ordering of single cells. Nature Biotechnology volume 32, pages 381-386 (2014) Andrew McDavid, Greg Finak and Masanao Yajima (2017). MAST: Model-based Analysis of Single Cell Transcriptomics. R package version 1.2.1. https://github.com/RGLab/MAST/ Love MI, Huber W and Anders S (2014). "Moderated estimation of fold change and dispersion for RNA-seq data with DESeq2." Genome Biology. https://bioconductor.org/packages/release/bioc/html/DESeq2.html } Seurat/man/CellSelector.Rd0000644000176200001440000000274213617632030015145 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{CellSelector} \alias{CellSelector} \alias{FeatureLocator} \title{Cell selector} \usage{ CellSelector(plot, object = NULL, ident = "SelectedCells", ...) FeatureLocator(plot, ...) } \arguments{ \item{plot}{A ggplot2 plot} \item{object}{An optional Seurat object; if passes, will return an object with the identities of selected cells set to \code{ident}} \item{ident}{An optional new identity class to assign the selected cells} \item{...}{Extra parameters, such as dark.theme, recolor, or smooth for using a dark theme, recoloring based on selected cells, or using a smooth scatterplot, respectively} } \value{ If \code{object} is \code{NULL}, the names of the points selected; otherwise, a Seurat object with the selected cells identity classes set to \code{ident} } \description{ Select points on a scatterplot and get information about them } \examples{ \dontrun{ plot <- DimPlot(object = pbmc_small) # Follow instructions in the terminal to select points cells.located <- CellSelector(plot = plot) cells.located # Automatically set the identity class of selected cells and return a new Seurat object pbmc_small <- CellSelector(plot = plot, object = pbmc_small, ident = 'SelectedCells') } } \seealso{ \code{\link[graphics]{locator}} \code{\link[ggplot2]{ggplot_build}} \code{\link[SDMTools]{pnt.in.poly}} \code{\link{DimPlot}} \code{\link{FeaturePlot}} } Seurat/man/PercentageFeatureSet.Rd0000644000176200001440000000323213617632030016625 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utilities.R \name{PercentageFeatureSet} \alias{PercentageFeatureSet} \title{Calculate the percentage of all counts that belong to a given set of features} \usage{ PercentageFeatureSet( object, pattern = NULL, features = NULL, col.name = NULL, assay = NULL ) } \arguments{ \item{object}{A Seurat object} \item{pattern}{A regex pattern to match features against} \item{features}{A defined feature set. If features provided, will ignore the pattern matching} \item{col.name}{Name in meta.data column to assign. If this is not null, returns a Seurat object with the proportion of the feature set stored in metadata.} \item{assay}{Assay to use} } \value{ Returns a vector with the proportion of the feature set or if md.name is set, returns a Seurat object with the proportion of the feature set stored in metadata. } \description{ This function enables you to easily calculate the percentage of all the counts belonging to a subset of the possible features for each cell. This is useful when trying to compute the percentage of transcripts that map to mitochondrial genes for example. The calculation here is simply the column sum of the matrix present in the counts slot for features belonging to the set divided by the column sum for all features times 100. } \examples{ # Calculate the proportion of transcripts mapping to mitochondrial genes # NOTE: The pattern provided works for human gene names. You may need to adjust depending on your # system of interest pbmc_small[["percent.mt"]] <- PercentageFeatureSet(object = pbmc_small, pattern = "^MT-") } Seurat/man/pbmc_small.Rd0000644000176200001440000000232713617632030014675 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data.R \docType{data} \name{pbmc_small} \alias{pbmc_small} \title{A small example version of the PBMC dataset} \format{A Seurat object with the following slots filled \describe{ \item{assays}{ \itemize{Currently only contains one assay ("RNA" - scRNA-seq expression data) \item{counts - Raw expression data} \item{data - Normalized expression data} \item{scale.data - Scaled expression data} \item{var.features - names of the current features selected as variable} \item{meta.features - Assay level metadata such as mean and variance} }} \item{meta.data}{Cell level metadata} \item{active.assay}{Current default assay} \item{active.ident}{Current default idents} \item{graphs}{Neighbor graphs computed, currently stores the SNN} \item{reductions}{Dimensional reductions: currently PCA and tSNE} \item{version}{Seurat version used to create the object} \item{commands}{Command history} }} \source{ \url{https://support.10xgenomics.com/single-cell-gene-expression/datasets/1.1.0/pbmc3k} } \usage{ pbmc_small } \description{ A subsetted version of 10X Genomics' 3k PBMC dataset } \keyword{datasets} Seurat/man/DimReduc-class.Rd0000644000176200001440000000244113617632030015360 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \docType{class} \name{DimReduc-class} \alias{DimReduc-class} \alias{DimReduc} \title{The Dimmensional Reduction Class} \description{ The DimReduc object stores a dimensionality reduction taken out in Seurat; each DimReduc consists of a cell embeddings matrix, a feature loadings matrix, and a projected feature loadings matrix. } \section{Slots}{ \describe{ \item{\code{cell.embeddings}}{Cell embeddings matrix (required)} \item{\code{feature.loadings}}{Feature loadings matrix (optional)} \item{\code{feature.loadings.projected}}{Projected feature loadings matrix (optional)} \item{\code{assay.used}}{Name of assay used to generate \code{DimReduc} object} \item{\code{global}}{Is this \code{DimReduc} global/persistent? If so, it will not be removed when removing its associated assay} \item{\code{stdev}}{A vector of standard deviations} \item{\code{key}}{Key for the \code{DimReduc}, must be alphanumerics followed by an underscore} \item{\code{jackstraw}}{A \code{\link{JackStrawData-class}} object associated with this \code{DimReduc}} \item{\code{misc}}{Utility slot for storing additional data associated with the \code{DimReduc} (e.g. the total variance of the PCA)} }} Seurat/man/PolyFeaturePlot.Rd0000644000176200001440000000310713617632030015657 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{PolyFeaturePlot} \alias{PolyFeaturePlot} \title{Polygon FeaturePlot} \usage{ PolyFeaturePlot( object, features, cells = NULL, poly.data = "spatial", ncol = ceiling(x = length(x = features)/2), min.cutoff = 0, max.cutoff = NA, common.scale = TRUE, flip.coords = FALSE ) } \arguments{ \item{object}{Seurat object} \item{features}{Vector of features to plot. Features can come from: \itemize{ \item An \code{Assay} feature (e.g. a gene name - "MS4A1") \item A column name from meta.data (e.g. mitochondrial percentage - "percent.mito") \item A column name from a \code{DimReduc} object corresponding to the cell embedding values (e.g. the PC 1 scores - "PC_1") }} \item{cells}{Vector of cells to plot (default is all cells)} \item{poly.data}{Name of the polygon dataframe in the misc slot} \item{ncol}{Number of columns to split the plot into} \item{min.cutoff}{Vector of minimum and maximum cutoff values for each feature, may specify quantile in the form of 'q##' where '##' is the quantile (eg, 'q1', 'q10')} \item{max.cutoff}{Vector of minimum and maximum cutoff values for each feature, may specify quantile in the form of 'q##' where '##' is the quantile (eg, 'q1', 'q10')} \item{common.scale}{...} \item{flip.coords}{Flip x and y coordinates} } \value{ Returns a ggplot object } \description{ Plot cells as polygons, rather than single points. Color cells by any value accessible by \code{\link{FetchData}}. } Seurat/man/CreateAssayObject.Rd0000644000176200001440000000216413617632030016116 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{CreateAssayObject} \alias{CreateAssayObject} \title{Create an Assay object} \usage{ CreateAssayObject(counts, data, min.cells = 0, min.features = 0) } \arguments{ \item{counts}{Unnormalized data such as raw counts or TPMs} \item{data}{Prenormalized data; if provided, do not pass \code{counts}} \item{min.cells}{Include features detected in at least this many cells. Will subset the counts matrix as well. To reintroduce excluded features, create a new object with a lower cutoff.} \item{min.features}{Include cells where at least this many features are detected.} } \description{ Create an Assay object from a feature (e.g. gene) expression matrix. The expected format of the input matrix is features x cells. } \details{ Non-unique cell or feature names are not allowed. Please make unique before calling this function. } \examples{ pbmc_raw <- read.table( file = system.file('extdata', 'pbmc_raw.txt', package = 'Seurat'), as.is = TRUE ) pbmc_rna <- CreateAssayObject(counts = pbmc_raw) pbmc_rna } Seurat/man/merge.Seurat.Rd0000644000176200001440000000360013617632030015120 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{merge.Assay} \alias{merge.Assay} \alias{merge.Seurat} \alias{merge} \alias{MergeSeurat} \alias{AddSamples} \title{Merge Seurat Objects} \usage{ \method{merge}{Assay}(x = NULL, y = NULL, add.cell.ids = NULL, merge.data = TRUE, ...) \method{merge}{Seurat}( x = NULL, y = NULL, add.cell.ids = NULL, merge.data = TRUE, project = "SeuratProject", ... ) } \arguments{ \item{x}{Object} \item{y}{Object (or a list of multiple objects)} \item{add.cell.ids}{A character vector of length(x = c(x, y)). Appends the corresponding values to the start of each objects' cell names.} \item{merge.data}{Merge the data slots instead of just merging the counts (which requires renormalization). This is recommended if the same normalization approach was applied to all objects.} \item{...}{Arguments passed to other methods} \item{project}{Sets the project name for the Seurat object.} } \value{ Merged object } \description{ Merge two or more objects. } \details{ When merging Seurat objects, the merge procedure will merge the Assay level counts and potentially the data slots (depending on the merge.data parameter). It will also merge the cell-level meta data that was stored with each object and preserve the cell identities that were active in the objects pre-merge. The merge will not preserve reductions, graphs, logged commands, or feature-level metadata that were present in the original objects. If add.cell.ids isn't specified and any cell names are duplicated, cell names will be appended with _X, where X is the numeric index of the object in c(x, y). } \examples{ # merge two objects merge(x = pbmc_small, y = pbmc_small) # to merge more than two objects, pass one to x and a list of objects to y merge(x = pbmc_small, y = c(pbmc_small, pbmc_small)) } Seurat/man/RegroupIdents.Rd0000644000176200001440000000111413617632030015347 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utilities.R \name{RegroupIdents} \alias{RegroupIdents} \title{Regroup idents based on meta.data info} \usage{ RegroupIdents(object, metadata) } \arguments{ \item{object}{Seurat object} \item{metadata}{Name of metadata column} } \value{ A Seurat object with the active idents regrouped } \description{ For cells in each ident, set a new identity based on the most common value of a specified metadata column. } \examples{ pbmc_small <- RegroupIdents(pbmc_small, metadata = "groups") } Seurat/man/Key.Rd0000644000176200001440000000215013617632030013306 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{Key} \alias{Key} \alias{Key<-} \alias{Key.Assay} \alias{Key.DimReduc} \alias{Key.Seurat} \alias{Key<-.Assay} \alias{Key<-.DimReduc} \title{Get a key} \usage{ Key(object, ...) Key(object, ...) <- value \method{Key}{Assay}(object, ...) \method{Key}{DimReduc}(object, ...) \method{Key}{Seurat}(object, ...) \method{Key}{Assay}(object, ...) <- value \method{Key}{DimReduc}(object, ...) <- value } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{value}{Key value} } \description{ Get a key Set a key } \examples{ # Get an Assay key Key(object = pbmc_small[["RNA"]]) # Get a DimReduc key Key(object = pbmc_small[["pca"]]) # Show all keys associated with a Seurat object Key(object = pbmc_small) # Set the key for an Assay Key(object = pbmc_small[["RNA"]]) <- "newkey_" Key(object = pbmc_small[["RNA"]]) # Set the key for DimReduc Key(object = pbmc_small[["pca"]]) <- "newkey2_" Key(object = pbmc_small[["pca"]]) } Seurat/man/VizDimLoadings.Rd0000644000176200001440000000231113617632030015440 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{VizDimLoadings} \alias{VizDimLoadings} \title{Visualize Dimensional Reduction genes} \usage{ VizDimLoadings( object, dims = 1:5, nfeatures = 30, col = "blue", reduction = "pca", projected = FALSE, balanced = FALSE, ncol = NULL, combine = TRUE ) } \arguments{ \item{object}{Seurat object} \item{dims}{Number of dimensions to display} \item{nfeatures}{Number of genes to display} \item{col}{Color of points to use} \item{reduction}{Reduction technique to visualize results for} \item{projected}{Use reduction values for full dataset (i.e. projected dimensional reduction values)} \item{balanced}{Return an equal number of genes with + and - scores. If FALSE (default), returns the top genes ranked by the scores absolute values} \item{ncol}{Number of columns to display} \item{combine}{Combine plots into a single gg object; note that if TRUE; themeing will not work when plotting multiple features} } \value{ A ggplot object } \description{ Visualize top genes associated with reduction components } \examples{ VizDimLoadings(object = pbmc_small) } Seurat/man/AugmentPlot.Rd0000644000176200001440000000150213617632030015015 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{AugmentPlot} \alias{AugmentPlot} \title{Augments ggplot2-based plot with a PNG image.} \usage{ AugmentPlot(plot, width = 10, height = 10, dpi = 100) } \arguments{ \item{plot}{A ggplot object} \item{width, height}{Width and height of PNG version of plot} \item{dpi}{Plot resolution} } \value{ A ggplot object } \description{ Creates "vector-friendly" plots. Does this by saving a copy of the plot as a PNG file, then adding the PNG image with \code{\link[ggplot2]{annotation_raster}} to a blank plot of the same dimensions as \code{plot}. Please note: original legends and axes will be lost during augmentation. } \examples{ \dontrun{ plot <- DimPlot(object = pbmc_small) AugmentPlot(plot = plot) } } Seurat/man/RowMergeSparseMatrices.Rd0000644000176200001440000000122313617632030017153 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utilities.R \name{RowMergeSparseMatrices} \alias{RowMergeSparseMatrices} \title{Merge two matrices by rowname} \usage{ RowMergeSparseMatrices(mat1, mat2) } \arguments{ \item{mat1}{First matrix} \item{mat2}{Second matrix} } \value{ A merged matrix Returns a sparse matrix } \description{ This function is for use on sparse matrices and should not be run on a Seurat object. } \details{ Shared matrix rows (with the same row name) will be merged, and unshared rows (with different names) will be filled with zeros in the matrix not containing the row. } Seurat/man/ScaleData.Rd0000644000176200001440000000733713617632030014413 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/preprocessing.R \name{ScaleData} \alias{ScaleData} \alias{ScaleData.default} \alias{ScaleData.Assay} \alias{ScaleData.Seurat} \title{Scale and center the data.} \usage{ ScaleData(object, ...) \method{ScaleData}{default}( object, features = NULL, vars.to.regress = NULL, latent.data = NULL, split.by = NULL, model.use = "linear", use.umi = FALSE, do.scale = TRUE, do.center = TRUE, scale.max = 10, block.size = 1000, min.cells.to.block = 3000, verbose = TRUE, ... ) \method{ScaleData}{Assay}( object, features = NULL, vars.to.regress = NULL, latent.data = NULL, split.by = NULL, model.use = "linear", use.umi = FALSE, do.scale = TRUE, do.center = TRUE, scale.max = 10, block.size = 1000, min.cells.to.block = 3000, verbose = TRUE, ... ) \method{ScaleData}{Seurat}( object, features = NULL, assay = NULL, vars.to.regress = NULL, split.by = NULL, model.use = "linear", use.umi = FALSE, do.scale = TRUE, do.center = TRUE, scale.max = 10, block.size = 1000, min.cells.to.block = 3000, verbose = TRUE, ... ) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{features}{Vector of features names to scale/center. Default is variable features.} \item{vars.to.regress}{Variables to regress out (previously latent.vars in RegressOut). For example, nUMI, or percent.mito.} \item{latent.data}{Extra data to regress out, should be cells x latent data} \item{split.by}{Name of variable in object metadata or a vector or factor defining grouping of cells. See argument \code{f} in \code{\link[base]{split}} for more details} \item{model.use}{Use a linear model or generalized linear model (poisson, negative binomial) for the regression. Options are 'linear' (default), 'poisson', and 'negbinom'} \item{use.umi}{Regress on UMI count data. Default is FALSE for linear modeling, but automatically set to TRUE if model.use is 'negbinom' or 'poisson'} \item{do.scale}{Whether to scale the data.} \item{do.center}{Whether to center the data.} \item{scale.max}{Max value to return for scaled data. The default is 10. Setting this can help reduce the effects of feautres that are only expressed in a very small number of cells. If regressing out latent variables and using a non-linear model, the default is 50.} \item{block.size}{Default size for number of feautres to scale at in a single computation. Increasing block.size may speed up calculations but at an additional memory cost.} \item{min.cells.to.block}{If object contains fewer than this number of cells, don't block for scaling calculations.} \item{verbose}{Displays a progress bar for scaling procedure} \item{assay}{Name of Assay to scale} } \description{ Scales and centers features in the dataset. If variables are provided in vars.to.regress, they are individually regressed against each feautre, and the resulting residuals are then scaled and centered. } \details{ ScaleData now incorporates the functionality of the function formerly known as RegressOut (which regressed out given the effects of provided variables and then scaled the residuals). To make use of the regression functionality, simply pass the variables you want to remove to the vars.to.regress parameter. Setting center to TRUE will center the expression for each feautre by subtracting the average expression for that feautre. Setting scale to TRUE will scale the expression level for each feautre by dividing the centered feautre expression levels by their standard deviations if center is TRUE and by their root mean square otherwise. } Seurat/man/h5ad.Rd0000644000176200001440000000704513617632030013407 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{ReadH5AD} \alias{ReadH5AD} \alias{WriteH5AD} \alias{ReadH5AD.character} \alias{ReadH5AD.H5File} \alias{WriteH5AD.Seurat} \title{Read from and write to h5ad files} \usage{ ReadH5AD(file, ...) WriteH5AD(object, ...) \method{ReadH5AD}{character}(file, assay = "RNA", layers = "data", verbose = TRUE, ...) \method{ReadH5AD}{H5File}(file, assay = "RNA", layers = "data", verbose = TRUE, ...) \method{WriteH5AD}{Seurat}( object, file, assay = NULL, graph = NULL, verbose = TRUE, overwrite = FALSE, ... ) } \arguments{ \item{file}{Name of h5ad file, or an H5File object for reading in} \item{...}{arguments passed to other methods} \item{object}{An object} \item{assay}{Name of assay to store} \item{layers}{Slot to store layers as; choose from 'counts' or 'data'; pass \code{FALSE} to not pull layers; may pass one value of 'counts' or 'data' for each layer in the H5AD file, must be in order} \item{verbose}{Show progress updates} \item{graph}{Name of graph to write out, defaults to \code{paste0(assay, '_snn')}} \item{overwrite}{Overwrite existing file} } \value{ \code{ReadH5AD}: A Seurat object with data from the h5ad file \code{WriteH5AD}: None, writes to disk } \description{ Utilize the Anndata h5ad file format for storing and sharing single-cell expression data. Provided are tools for writing objects to h5ad files, as well as reading h5ad files into a Seurat object } \details{ \code{ReadH5AD} and \code{WriteH5AD} will try to automatically fill slots based on data type and presence. For example, objects will be filled with scaled and normalized data if \code{adata.X} is a dense matrix and \code{raw} is present (when reading), or if the \code{scale.data} slot is filled (when writing). The following is a list of how objects will be filled \describe{ \item{\code{adata.X} is dense and \code{adata.raw} is filled; \code{ScaleData} is filled}{Objects will be filled with scaled and normalized data} \item{ \code{adata.X} is sparse and \code{adata.raw} is filled; \code{NormalizeData} has been run, \code{ScaleData} has not been run }{ Objects will be filled with normalized and raw data } \item{\code{adata.X} is sparse and \code{adata.raw} is not filled; \code{NormalizeData} has not been run}{Objects will be filled with raw data only} } In addition, dimensional reduction information and nearest-neighbor graphs will be searched for and added if and only if scaled data is being added. When reading: project name is \code{basename(file)}; identity classes will be set as the project name; all cell-level metadata from \code{adata.obs} will be taken; feature level metadata from \code{data.var} and \code{adata.raw.var} (if present) will be merged and stored in assay \code{meta.features}; highly variable features will be set if \code{highly_variable} is present in feature-level metadata; dimensional reduction objects will be given the assay name provided to the function call; graphs will be named \code{assay_method} if method is present, otherwise \code{assay_adata} When writing: only one assay will be written; all dimensional reductions and graphs associated with that assay will be stored, no other reductions or graphs will be written; active identity classes will be stored in \code{adata.obs} as \code{active_ident} } \note{ \code{WriteH5AD} is not currently functional, please use \code{\link{as.loom}} instead } \seealso{ \code{\link{as.loom}} } Seurat/man/BuildClusterTree.Rd0000644000176200001440000000361313617632030016004 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tree.R \name{BuildClusterTree} \alias{BuildClusterTree} \title{Phylogenetic Analysis of Identity Classes} \usage{ BuildClusterTree( object, assay = NULL, features = NULL, dims = NULL, graph = NULL, slot = "data", reorder = FALSE, reorder.numeric = FALSE, verbose = TRUE ) } \arguments{ \item{object}{Seurat object} \item{assay}{Assay to use for the analysis.} \item{features}{Genes to use for the analysis. Default is the set of variable genes (\code{VariableFeatures(object = object)})} \item{dims}{If set, tree is calculated in PCA space; overrides \code{features}} \item{graph}{If graph is passed, build tree based on graph connectivity between clusters; overrides \code{dims} and \code{features}} \item{slot}{Slot to use; will be overriden by \code{use.scale} and \code{use.counts}} \item{reorder}{Re-order identity classes (factor ordering), according to position on the tree. This groups similar classes together which can be helpful, for example, when drawing violin plots.} \item{reorder.numeric}{Re-order identity classes according to position on the tree, assigning a numeric value ('1' is the leftmost node)} \item{verbose}{Show progress updates} } \value{ A Seurat object where the cluster tree can be accessed with \code{\link{Tool}} } \description{ Constructs a phylogenetic tree relating the 'average' cell from each identity class. Tree is estimated based on a distance matrix constructed in either gene expression space or PCA space. } \details{ Note that the tree is calculated for an 'average' cell, so gene expression or PC scores are averaged across all cells in an identity class before the tree is constructed. } \examples{ pbmc_small pbmc_small <- BuildClusterTree(object = pbmc_small) Tool(object = pbmc_small, slot = 'BuildClusterTree') } Seurat/man/TopCells.Rd0000644000176200001440000000156513617632030014314 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{TopCells} \alias{TopCells} \title{Find cells with highest scores for a given dimensional reduction technique} \usage{ TopCells(object, dim = 1, ncells = 20, balanced = FALSE, ...) } \arguments{ \item{object}{DimReduc object} \item{dim}{Dimension to use} \item{ncells}{Number of cells to return} \item{balanced}{Return an equal number of cells with both + and - scores.} \item{...}{Extra parameters passed to \code{\link{Embeddings}}} } \value{ Returns a vector of cells } \description{ Return a list of genes with the strongest contribution to a set of components } \examples{ pbmc_small head(TopCells(object = pbmc_small[["pca"]])) # Can specify which dimension and how many cells to return TopCells(object = pbmc_small[["pca"]], dim = 2, ncells = 5) } Seurat/man/FindAllMarkers.Rd0000644000176200001440000001343113617632030015420 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/differential_expression.R \name{FindAllMarkers} \alias{FindAllMarkers} \alias{FindAllMarkersNode} \title{Gene expression markers for all identity classes} \usage{ FindAllMarkers( object, assay = NULL, features = NULL, logfc.threshold = 0.25, test.use = "wilcox", slot = "data", min.pct = 0.1, min.diff.pct = -Inf, node = NULL, verbose = TRUE, only.pos = FALSE, max.cells.per.ident = Inf, random.seed = 1, latent.vars = NULL, min.cells.feature = 3, min.cells.group = 3, pseudocount.use = 1, return.thresh = 0.01, ... ) } \arguments{ \item{object}{An object} \item{assay}{Assay to use in differential expression testing} \item{features}{Genes to test. Default is to use all genes} \item{logfc.threshold}{Limit testing to genes which show, on average, at least X-fold difference (log-scale) between the two groups of cells. Default is 0.25 Increasing logfc.threshold speeds up the function, but can miss weaker signals.} \item{test.use}{Denotes which test to use. Available options are: \itemize{ \item{"wilcox"} : Identifies differentially expressed genes between two groups of cells using a Wilcoxon Rank Sum test (default) \item{"bimod"} : Likelihood-ratio test for single cell gene expression, (McDavid et al., Bioinformatics, 2013) \item{"roc"} : Identifies 'markers' of gene expression using ROC analysis. For each gene, evaluates (using AUC) a classifier built on that gene alone, to classify between two groups of cells. An AUC value of 1 means that expression values for this gene alone can perfectly classify the two groupings (i.e. Each of the cells in cells.1 exhibit a higher level than each of the cells in cells.2). An AUC value of 0 also means there is perfect classification, but in the other direction. A value of 0.5 implies that the gene has no predictive power to classify the two groups. Returns a 'predictive power' (abs(AUC-0.5) * 2) ranked matrix of putative differentially expressed genes. \item{"t"} : Identify differentially expressed genes between two groups of cells using the Student's t-test. \item{"negbinom"} : Identifies differentially expressed genes between two groups of cells using a negative binomial generalized linear model. Use only for UMI-based datasets \item{"poisson"} : Identifies differentially expressed genes between two groups of cells using a poisson generalized linear model. Use only for UMI-based datasets \item{"LR"} : Uses a logistic regression framework to determine differentially expressed genes. Constructs a logistic regression model predicting group membership based on each feature individually and compares this to a null model with a likelihood ratio test. \item{"MAST"} : Identifies differentially expressed genes between two groups of cells using a hurdle model tailored to scRNA-seq data. Utilizes the MAST package to run the DE testing. \item{"DESeq2"} : Identifies differentially expressed genes between two groups of cells based on a model using DESeq2 which uses a negative binomial distribution (Love et al, Genome Biology, 2014).This test does not support pre-filtering of genes based on average difference (or percent detection rate) between cell groups. However, genes may be pre-filtered based on their minimum detection rate (min.pct) across both cell groups. To use this method, please install DESeq2, using the instructions at https://bioconductor.org/packages/release/bioc/html/DESeq2.html }} \item{slot}{Slot to pull data from; note that if \code{test.use} is "negbinom", "poisson", or "DESeq2", \code{slot} will be set to "counts"} \item{min.pct}{only test genes that are detected in a minimum fraction of min.pct cells in either of the two populations. Meant to speed up the function by not testing genes that are very infrequently expressed. Default is 0.1} \item{min.diff.pct}{only test genes that show a minimum difference in the fraction of detection between the two groups. Set to -Inf by default} \item{node}{A node to find markers for and all its children; requires \code{\link{BuildClusterTree}} to have been run previously; replaces \code{FindAllMarkersNode}} \item{verbose}{Print a progress bar once expression testing begins} \item{only.pos}{Only return positive markers (FALSE by default)} \item{max.cells.per.ident}{Down sample each identity class to a max number. Default is no downsampling. Not activated by default (set to Inf)} \item{random.seed}{Random seed for downsampling} \item{latent.vars}{Variables to test, used only when \code{test.use} is one of 'LR', 'negbinom', 'poisson', or 'MAST'} \item{min.cells.feature}{Minimum number of cells expressing the feature in at least one of the two groups, currently only used for poisson and negative binomial tests} \item{min.cells.group}{Minimum number of cells in one of the groups} \item{pseudocount.use}{Pseudocount to add to averaged expression values when calculating logFC. 1 by default.} \item{return.thresh}{Only return markers that have a p-value < return.thresh, or a power > return.thresh (if the test is ROC)} \item{...}{Arguments passed to other methods and to specific DE methods} } \value{ Matrix containing a ranked list of putative markers, and associated statistics (p-values, ROC score, etc.) } \description{ Finds markers (differentially expressed genes) for each of the identity classes in a dataset } \examples{ # Find markers for all clusters all.markers <- FindAllMarkers(object = pbmc_small) head(x = all.markers) \dontrun{ # Pass a value to node as a replacement for FindAllMarkersNode pbmc_small <- BuildClusterTree(object = pbmc_small) all.markers <- FindAllMarkers(object = pbmc_small, node = 4) head(x = all.markers) } } Seurat/man/as.CellDataSet.Rd0000644000176200001440000000116513617632030015312 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{as.CellDataSet} \alias{as.CellDataSet} \alias{as.CellDataSet.Seurat} \title{Convert objects to CellDataSet objects} \usage{ as.CellDataSet(x, ...) \method{as.CellDataSet}{Seurat}(x, assay = NULL, reduction = NULL, ...) } \arguments{ \item{x}{An object to convert to class \code{CellDataSet}} \item{...}{Arguments passed to other methods} \item{assay}{Assay to convert} \item{reduction}{Name of DimReduc to set to main reducedDim in cds} } \description{ Convert objects to CellDataSet objects } Seurat/man/FetchData.Rd0000644000176200001440000000147213617632030014407 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{FetchData} \alias{FetchData} \title{Access cellular data} \usage{ FetchData(object, vars, cells = NULL, slot = "data") } \arguments{ \item{object}{Seurat object} \item{vars}{List of all variables to fetch, use keyword 'ident' to pull identity classes} \item{cells}{Cells to collect data for (default is all cells)} \item{slot}{Slot to pull feature data for} } \value{ A data frame with cells as rows and cellular data as columns } \description{ Retreives data (feature expression, PCA scores, metrics, etc.) for a set of cells in a Seurat object } \examples{ pc1 <- FetchData(object = pbmc_small, vars = 'PC_1') head(x = pc1) head(x = FetchData(object = pbmc_small, vars = c('groups', 'ident'))) } Seurat/man/FindVariableFeatures.Rd0000644000176200001440000001111313617632030016602 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/preprocessing.R \name{FindVariableFeatures} \alias{FindVariableFeatures} \alias{FindVariableGenes} \alias{FindVariableFeatures.default} \alias{FindVariableFeatures.Assay} \alias{FindVariableFeatures.Seurat} \title{Find variable features} \usage{ FindVariableFeatures(object, ...) \method{FindVariableFeatures}{default}( object, selection.method = "vst", loess.span = 0.3, clip.max = "auto", mean.function = FastExpMean, dispersion.function = FastLogVMR, num.bin = 20, binning.method = "equal_width", verbose = TRUE, ... ) \method{FindVariableFeatures}{Assay}( object, selection.method = "vst", loess.span = 0.3, clip.max = "auto", mean.function = FastExpMean, dispersion.function = FastLogVMR, num.bin = 20, binning.method = "equal_width", nfeatures = 2000, mean.cutoff = c(0.1, 8), dispersion.cutoff = c(1, Inf), verbose = TRUE, ... ) \method{FindVariableFeatures}{Seurat}( object, assay = NULL, selection.method = "vst", loess.span = 0.3, clip.max = "auto", mean.function = FastExpMean, dispersion.function = FastLogVMR, num.bin = 20, binning.method = "equal_width", nfeatures = 2000, mean.cutoff = c(0.1, 8), dispersion.cutoff = c(1, Inf), verbose = TRUE, ... ) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{selection.method}{How to choose top variable features. Choose one of : \itemize{ \item{vst:}{ First, fits a line to the relationship of log(variance) and log(mean) using local polynomial regression (loess). Then standardizes the feature values using the observed mean and expected variance (given by the fitted line). Feature variance is then calculated on the standardized values after clipping to a maximum (see clip.max parameter).} \item{mean.var.plot (mvp):}{ First, uses a function to calculate average expression (mean.function) and dispersion (dispersion.function) for each feature. Next, divides features into num.bin (deafult 20) bins based on their average expression, and calculates z-scores for dispersion within each bin. The purpose of this is to identify variable features while controlling for the strong relationship between variability and average expression.} \item{dispersion (disp):}{ selects the genes with the highest dispersion values} }} \item{loess.span}{(vst method) Loess span parameter used when fitting the variance-mean relationship} \item{clip.max}{(vst method) After standardization values larger than clip.max will be set to clip.max; default is 'auto' which sets this value to the square root of the number of cells} \item{mean.function}{Function to compute x-axis value (average expression). Default is to take the mean of the detected (i.e. non-zero) values} \item{dispersion.function}{Function to compute y-axis value (dispersion). Default is to take the standard deviation of all values} \item{num.bin}{Total number of bins to use in the scaled analysis (default is 20)} \item{binning.method}{Specifies how the bins should be computed. Available methods are: \itemize{ \item{equal_width:}{ each bin is of equal width along the x-axis [default]} \item{equal_frequency:}{ each bin contains an equal number of features (can increase statistical power to detect overdispersed features at high expression values, at the cost of reduced resolution along the x-axis)} }} \item{verbose}{show progress bar for calculations} \item{nfeatures}{Number of features to select as top variable features; only used when \code{selection.method} is set to \code{'dispersion'} or \code{'vst'}} \item{mean.cutoff}{A two-length numeric vector with low- and high-cutoffs for feature means} \item{dispersion.cutoff}{A two-length numeric vector with low- and high-cutoffs for feature dispersions} \item{assay}{Assay to use} } \description{ Identifies features that are outliers on a 'mean variability plot'. } \details{ For the mean.var.plot method: Exact parameter settings may vary empirically from dataset to dataset, and based on visual inspection of the plot. Setting the y.cutoff parameter to 2 identifies features that are more than two standard deviations away from the average dispersion within a bin. The default X-axis function is the mean expression level, and for Y-axis it is the log(Variance/mean). All mean/variance calculations are not performed in log-space, but the results are reported in log-space - see relevant functions for exact details. } Seurat/man/L2CCA.Rd0000644000176200001440000000052113617632030013342 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dimensional_reduction.R \name{L2CCA} \alias{L2CCA} \title{L2-Normalize CCA} \usage{ L2CCA(object, ...) } \arguments{ \item{object}{Seurat object} \item{\dots}{Additional parameters to L2Dim.} } \description{ Perform l2 normalization on CCs } Seurat/man/CaseMatch.Rd0000644000176200001440000000111313617632030014404 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utilities.R \name{CaseMatch} \alias{CaseMatch} \title{Match the case of character vectors} \usage{ CaseMatch(search, match) } \arguments{ \item{search}{A vector of search terms} \item{match}{A vector of characters whose case should be matched} } \value{ Values from search present in match with the case of match } \description{ Match the case of character vectors } \examples{ cd_genes <- c('Cd79b', 'Cd19', 'Cd200') CaseMatch(search = cd_genes, match = rownames(x = pbmc_small)) } Seurat/man/CreateDimReducObject.Rd0000644000176200001440000000264713617632030016540 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{CreateDimReducObject} \alias{CreateDimReducObject} \alias{SetDimReduction} \title{Create a DimReduc object} \usage{ CreateDimReducObject( embeddings = new(Class = "matrix"), loadings = new(Class = "matrix"), projected = new(Class = "matrix"), assay = NULL, stdev = numeric(), key = NULL, global = FALSE, jackstraw = NULL, misc = list() ) } \arguments{ \item{embeddings}{A matrix with the cell embeddings} \item{loadings}{A matrix with the feature loadings} \item{projected}{A matrix with the projected feature loadings} \item{assay}{Assay used to calculate this dimensional reduction} \item{stdev}{Standard deviation (if applicable) for the dimensional reduction} \item{key}{A character string to facilitate looking up features from a specific DimReduc} \item{global}{Specify this as a global reduction (useful for visualizations)} \item{jackstraw}{Results from the JackStraw function} \item{misc}{list for the user to store any additional information associated with the dimensional reduction} } \description{ Create a DimReduc object } \examples{ data <- GetAssayData(pbmc_small[["RNA"]], slot = "scale.data") pcs <- prcomp(x = data) pca.dr <- CreateDimReducObject( embeddings = pcs$rotation, loadings = pcs$x, stdev = pcs$sdev, key = "PC", assay = "RNA" ) } Seurat/man/as.sparse.Rd0000644000176200001440000000323413617632030014461 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R, R/utilities.R \name{as.sparse} \alias{as.sparse} \alias{as.sparse.data.frame} \alias{as.sparse.H5Group} \alias{as.sparse.Matrix} \alias{as.sparse.matrix} \alias{as.data.frame.Matrix} \title{Convert between data frames and sparse matrices} \usage{ as.sparse(x, ...) \method{as.sparse}{data.frame}(x, ...) \method{as.sparse}{H5Group}(x, ...) \method{as.sparse}{Matrix}(x, ...) \method{as.sparse}{matrix}(x, ...) \method{as.data.frame}{Matrix}( x, row.names = NULL, optional = FALSE, ..., stringsAsFactors = default.stringsAsFactors() ) } \arguments{ \item{x}{An object} \item{...}{Arguments passed to other methods} \item{row.names}{\code{NULL} or a character vector giving the row names for the data frame. Missing values are not allowed.} \item{optional}{logical. If \code{TRUE}, setting row names and converting column names (to syntactic names: see \code{\link[base]{make.names}}) is optional. Note that all of \R's \pkg{base} package \code{as.data.frame()} methods use \code{optional} only for column names treatment, basically with the meaning of \code{\link[base]{data.frame}(*, check.names = !optional)}. See also the \code{make.names} argument of the \code{matrix} method.} \item{stringsAsFactors}{logical: should the character vector be converted to a factor?} } \value{ \code{as.sparse}: A sparse representation of the input data \code{as.data.frame.Matrix}: A data frame representation of the S4 Matrix } \description{ Convert between data frames and sparse matrices } Seurat/man/Command.Rd0000644000176200001440000000130413617632030014134 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{Command} \alias{Command} \alias{Command.Seurat} \title{Get SeuratCommands} \usage{ Command(object, ...) \method{Command}{Seurat}(object, command = NULL, value = NULL, ...) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{command}{Name of the command to pull, pass \code{NULL} to get the names of all commands run} \item{value}{Name of the parameter to pull the value for} } \value{ Either a SeuratCommand object or the requested paramter value } \description{ Pull information on previously run commands in the Seurat object. } Seurat/man/MinMax.Rd0000644000176200001440000000127113617632030013752 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utilities.R \name{MinMax} \alias{MinMax} \title{Apply a ceiling and floor to all values in a matrix} \usage{ MinMax(data, min, max) } \arguments{ \item{data}{Matrix or data frame} \item{min}{all values below this min value will be replaced with min} \item{max}{all values above this max value will be replaced with max} } \value{ Returns matrix after performing these floor and ceil operations } \description{ Apply a ceiling and floor to all values in a matrix } \examples{ mat <- matrix(data = rbinom(n = 25, size = 20, prob = 0.2 ), nrow = 5) mat MinMax(data = mat, min = 4, max = 5) } Seurat/man/MULTIseqDemux.Rd0000644000176200001440000000246513617632030015175 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/preprocessing.R \name{MULTIseqDemux} \alias{MULTIseqDemux} \title{Demultiplex samples based on classification method from MULTI-seq (McGinnis et al., bioRxiv 2018)} \usage{ MULTIseqDemux( object, assay = "HTO", quantile = 0.7, autoThresh = FALSE, maxiter = 5, qrange = seq(from = 0.1, to = 0.9, by = 0.05), verbose = TRUE ) } \arguments{ \item{object}{Seurat object. Assumes that the specified assay data has been added} \item{assay}{Name of the multiplexing assay (HTO by default)} \item{quantile}{The quantile to use for classification} \item{autoThresh}{Whether to perform automated threshold finding to define the best quantile. Default is FALSE} \item{maxiter}{Maximum number of iterations if autoThresh = TRUE. Default is 5} \item{qrange}{A range of possible quantile values to try if autoThresh = TRUE} \item{verbose}{Prints the output} } \value{ A Seurat object with demultiplexing results stored at \code{object$MULTI_ID} } \description{ Identify singlets, doublets and negative cells from multiplexing experiments. Annotate singlets by tags. } \examples{ \dontrun{ object <- MULTIseqDemux(object) } } \references{ \url{https://www.biorxiv.org/content/early/2018/08/08/387241} } Seurat/man/CollapseEmbeddingOutliers.Rd0000644000176200001440000000230613617632030017651 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{CollapseEmbeddingOutliers} \alias{CollapseEmbeddingOutliers} \title{Move outliers towards center on dimension reduction plot} \usage{ CollapseEmbeddingOutliers( object, reduction = "umap", dims = 1:2, group.by = "ident", outlier.sd = 2, reduction.key = "UMAP_" ) } \arguments{ \item{object}{Seurat object} \item{reduction}{Name of DimReduc to adjust} \item{dims}{Dimensions to visualize} \item{group.by}{Group (color) cells in different ways (for example, orig.ident)} \item{outlier.sd}{Controls the outlier distance} \item{reduction.key}{Key for DimReduc that is returned} } \value{ Returns a DimReduc object with the modified embeddings } \description{ Move outliers towards center on dimension reduction plot } \examples{ \dontrun{ pbmc_small <- FindClusters(pbmc_small, resolution = 1.1) pbmc_small <- RunUMAP(pbmc_small, dims = 1:5) DimPlot(pbmc_small, reduction = "umap") pbmc_small[["umap_new"]] <- CollapseEmbeddingOutliers(pbmc_small, reduction = "umap", reduction.key = 'umap_', outlier.sd = 0.5) DimPlot(pbmc_small, reduction = "umap_new") } } Seurat/man/L2Dim.Rd0000644000176200001440000000113113617632030013463 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dimensional_reduction.R \name{L2Dim} \alias{L2Dim} \title{L2-normalization} \usage{ L2Dim(object, reduction, new.dr = NULL, new.key = NULL) } \arguments{ \item{object}{Seurat object} \item{reduction}{Dimensional reduction to normalize} \item{new.dr}{name of new dimensional reduction to store (default is olddr.l2)} \item{new.key}{name of key for new dimensional reduction} } \value{ Returns a \code{\link{Seurat}} object } \description{ Perform l2 normalization on given dimensional reduction } Seurat/man/Embeddings.Rd0000644000176200001440000000147013617632030014623 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{Embeddings} \alias{Embeddings} \alias{Embeddings.DimReduc} \alias{Embeddings.Seurat} \title{Get cell embeddings} \usage{ Embeddings(object, ...) \method{Embeddings}{DimReduc}(object, ...) \method{Embeddings}{Seurat}(object, reduction = "pca", ...) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{reduction}{Name of reduction to pull cell embeddings for} } \description{ Get cell embeddings } \examples{ # Get the embeddings directly from a DimReduc object Embeddings(object = pbmc_small[["pca"]])[1:5, 1:5] # Get the embeddings from a specific DimReduc in a Seurat object Embeddings(object = pbmc_small, reduction = "pca")[1:5, 1:5] } Seurat/man/IntegrateData.Rd0000644000176200001440000000513113617632030015274 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/integration.R \name{IntegrateData} \alias{IntegrateData} \title{Integrate data} \usage{ IntegrateData( anchorset, new.assay.name = "integrated", normalization.method = c("LogNormalize", "SCT"), features = NULL, features.to.integrate = NULL, dims = 1:30, k.weight = 100, weight.reduction = NULL, sd.weight = 1, sample.tree = NULL, preserve.order = FALSE, do.cpp = TRUE, eps = 0, verbose = TRUE ) } \arguments{ \item{anchorset}{Results from FindIntegrationAnchors} \item{new.assay.name}{Name for the new assay containing the integrated data} \item{normalization.method}{Name of normalization method used: LogNormalize or SCT} \item{features}{Vector of features to use when computing the PCA to determine the weights. Only set if you want a different set from those used in the anchor finding process} \item{features.to.integrate}{Vector of features to integrate. By default, will use the features used in anchor finding.} \item{dims}{Number of PCs to use in the weighting procedure} \item{k.weight}{Number of neighbors to consider when weighting} \item{weight.reduction}{Dimension reduction to use when calculating anchor weights. This can be either: \itemize{ \item{A string, specifying the name of a dimension reduction present in all objects to be integrated} \item{A vector of strings, specifying the name of a dimension reduction to use for each object to be integrated} \item{A vector of Dimreduc objects, specifying the object to use for each object in the integration} \item{NULL, in which case a new PCA will be calculated and used to calculate anchor weights} } Note that, if specified, the requested dimension reduction will only be used for calculating anchor weights in the first merge between reference and query, as the merged object will subsequently contain more cells than was in query, and weights will need to be calculated for all cells in the object.} \item{sd.weight}{Controls the bandwidth of the Gaussian kernel for weighting} \item{sample.tree}{Specify the order of integration. If NULL, will compute automatically.} \item{preserve.order}{Do not reorder objects based on size for each pairwise integration.} \item{do.cpp}{Run cpp code where applicable} \item{eps}{Error bound on the neighbor finding algorithm (from \code{\link{RANN}})} \item{verbose}{Print progress bars and output} } \value{ Returns a Seurat object with a new integrated Assay } \description{ Perform dataset integration using a pre-computed anchorset } Seurat/man/CellCycleScoring.Rd0000644000176200001440000000227513617632030015752 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utilities.R \name{CellCycleScoring} \alias{CellCycleScoring} \title{Score cell cycle phases} \usage{ CellCycleScoring(object, s.features, g2m.features, set.ident = FALSE, ...) } \arguments{ \item{object}{A Seurat object} \item{s.features}{A vector of features associated with S phase} \item{g2m.features}{A vector of features associated with G2M phase} \item{set.ident}{If true, sets identity to phase assignments} \item{...}{Arguments to be passed to \code{\link{AddModuleScore}} Stashes old identities in 'old.ident'} } \value{ A Seurat object with the following columns added to object meta data: S.Score, G2M.Score, and Phase } \description{ Score cell cycle phases } \examples{ \dontrun{ # pbmc_small doesn't have any cell-cycle genes # To run CellCycleScoring, please use a dataset with cell-cycle genes # An example is available at http://satijalab.org/seurat/cell_cycle_vignette.html pbmc_small <- CellCycleScoring( object = pbmc_small, g2m.features = cc.genes$g2m.genes, s.features = cc.genes$s.genes ) head(x = pbmc_small@meta.data) } } \seealso{ \code{AddModuleScore} } Seurat/man/FindTransferAnchors.Rd0000644000176200001440000000501513617632030016464 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/integration.R \name{FindTransferAnchors} \alias{FindTransferAnchors} \title{Find transfer anchors} \usage{ FindTransferAnchors( reference, query, normalization.method = c("LogNormalize", "SCT"), reference.assay = NULL, query.assay = NULL, reduction = "pcaproject", project.query = FALSE, features = NULL, npcs = 30, l2.norm = TRUE, dims = 1:30, k.anchor = 5, k.filter = 200, k.score = 30, max.features = 200, nn.method = "rann", eps = 0, approx.pca = TRUE, verbose = TRUE ) } \arguments{ \item{reference}{Seurat object to use as the reference} \item{query}{Seurat object to use as the query} \item{normalization.method}{Name of normalization method used: LogNormalize or SCT} \item{reference.assay}{Assay to use from reference} \item{query.assay}{Assay to use from query} \item{reduction}{Dimensional reduction to perform when finding anchors. Options are: \itemize{ \item{pcaproject: Project the PCA from the reference onto the query. We recommend using PCA when reference and query datasets are from scRNA-seq} \item{cca: Run a CCA on the reference and query } }} \item{project.query}{Project the PCA from the query dataset onto the reference. Use only in rare cases where the query dataset has a much larger cell number, but the reference dataset has a unique assay for transfer.} \item{features}{Features to use for dimensional reduction} \item{npcs}{Number of PCs to compute on reference. If null, then use an existing PCA structure in the reference object} \item{l2.norm}{Perform L2 normalization on the cell embeddings after dimensional reduction} \item{dims}{Which dimensions to use from the reduction to specify the neighbor search space} \item{k.anchor}{How many neighbors (k) to use when picking anchors} \item{k.filter}{How many neighbors (k) to use when filtering anchors} \item{k.score}{How many neighbors (k) to use when scoring anchors} \item{max.features}{The maximum number of features to use when specifying the neighborhood search space in the anchor filtering} \item{nn.method}{Method for nearest neighbor finding. Options include: rann, annoy} \item{eps}{Error bound on the neighbor finding algorithm (from RANN)} \item{approx.pca}{Use truncated singular value decomposition to approximate PCA} \item{verbose}{Print progress bars and output} } \value{ Returns an AnchorSet object } \description{ Finds the transfer anchors } Seurat/man/DimPlot.Rd0000644000176200001440000000753413617632030014141 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R, R/convenience.R \name{DimPlot} \alias{DimPlot} \alias{TSNEPlot} \alias{PCAPlot} \alias{ICAPlot} \alias{UMAPPlot} \title{Dimensional reduction plot} \usage{ DimPlot( object, dims = c(1, 2), cells = NULL, cols = NULL, pt.size = NULL, reduction = NULL, group.by = NULL, split.by = NULL, shape.by = NULL, order = NULL, label = FALSE, label.size = 4, repel = FALSE, cells.highlight = NULL, cols.highlight = "#DE2D26", sizes.highlight = 1, na.value = "grey50", combine = TRUE, ncol = NULL, ... ) PCAPlot(object, ...) TSNEPlot(object, ...) UMAPPlot(object, ...) } \arguments{ \item{object}{Seurat object} \item{dims}{Dimensions to plot, must be a two-length numeric vector specifying x- and y-dimensions} \item{cells}{Vector of cells to plot (default is all cells)} \item{cols}{Vector of colors, each color corresponds to an identity class. This may also be a single character or numeric value corresponding to a palette as specified by \code{\link[RColorBrewer]{brewer.pal.info}}. By default, ggplot2 assigns colors. We also include a number of palettes from the pals package. See \code{\link{DiscretePalette}} for details.} \item{pt.size}{Adjust point size for plotting} \item{reduction}{Which dimensionality reduction to use. If not specified, first searches for umap, then tsne, then pca} \item{group.by}{Name of one or more metadata columns to group (color) cells by (for example, orig.ident); pass 'ident' to group by identity class} \item{split.by}{Name of a metadata column to split plot by; see \code{\link{FetchData}} for more details} \item{shape.by}{If NULL, all points are circles (default). You can specify any cell attribute (that can be pulled with FetchData) allowing for both different colors and different shapes on cells} \item{order}{Specify the order of plotting for the idents. This can be useful for crowded plots if points of interest are being buried. Provide either a full list of valid idents or a subset to be plotted last (on top)} \item{label}{Whether to label the clusters} \item{label.size}{Sets size of labels} \item{repel}{Repel labels} \item{cells.highlight}{A list of character or numeric vectors of cells to highlight. If only one group of cells desired, can simply pass a vector instead of a list. If set, colors selected cells to the color(s) in \code{cols.highlight} and other cells black (white if dark.theme = TRUE); will also resize to the size(s) passed to \code{sizes.highlight}} \item{cols.highlight}{A vector of colors to highlight the cells as; will repeat to the length groups in cells.highlight} \item{sizes.highlight}{Size of highlighted cells; will repeat to the length groups in cells.highlight} \item{na.value}{Color value for NA points when using custom scale} \item{combine}{Combine plots into a single gg object; note that if TRUE; themeing will not work when plotting multiple features} \item{ncol}{Number of columns for display when combining plots} \item{...}{Extra parameters passed on to \code{\link{CombinePlots}}} } \value{ A ggplot object } \description{ Graphs the output of a dimensional reduction technique on a 2D scatter plot where each point is a cell and it's positioned based on the cell embeddings determined by the reduction technique. By default, cells are colored by their identity class (can be changed with the group.by parameter). } \note{ For the old \code{do.hover} and \code{do.identify} functionality, please see \code{HoverLocator} and \code{CellSelector}, respectively. } \examples{ DimPlot(object = pbmc_small) DimPlot(object = pbmc_small, split.by = 'ident') } \seealso{ \code{\link{FeaturePlot}} \code{\link{HoverLocator}} \code{\link{CellSelector}} \code{link{FetchData}} } Seurat/man/JackStrawPlot.Rd0000644000176200001440000000250013617632030015305 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{JackStrawPlot} \alias{JackStrawPlot} \title{JackStraw Plot} \usage{ JackStrawPlot(object, dims = 1:5, reduction = "pca", xmax = 0.1, ymax = 0.3) } \arguments{ \item{object}{Seurat object} \item{dims}{Dims to plot} \item{reduction}{reduction to pull jackstraw info from} \item{xmax}{X-axis maximum on each QQ plot.} \item{ymax}{Y-axis maximum on each QQ plot.} } \value{ A ggplot object } \description{ Plots the results of the JackStraw analysis for PCA significance. For each PC, plots a QQ-plot comparing the distribution of p-values for all genes across each PC, compared with a uniform distribution. Also determines a p-value for the overall significance of each PC (see Details). } \details{ Significant PCs should show a p-value distribution (black curve) that is strongly skewed to the left compared to the null distribution (dashed line) The p-value for each PC is based on a proportion test comparing the number of genes with a p-value below a particular threshold (score.thresh), compared with the proportion of genes expected under a uniform distribution of p-values. } \examples{ JackStrawPlot(object = pbmc_small) } \seealso{ \code{\link{ScoreJackStraw}} } \author{ Omri Wurtzel } Seurat/man/VlnPlot.Rd0000644000176200001440000000423313617632030014160 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{VlnPlot} \alias{VlnPlot} \title{Single cell violin plot} \usage{ VlnPlot( object, features, cols = NULL, pt.size = 1, idents = NULL, sort = FALSE, assay = NULL, group.by = NULL, split.by = NULL, adjust = 1, y.max = NULL, same.y.lims = FALSE, log = FALSE, ncol = NULL, combine = TRUE, slot = "data", multi.group = FALSE, ... ) } \arguments{ \item{object}{Seurat object} \item{features}{Features to plot (gene expression, metrics, PC scores, anything that can be retreived by FetchData)} \item{cols}{Colors to use for plotting} \item{pt.size}{Point size for geom_violin} \item{idents}{Which classes to include in the plot (default is all)} \item{sort}{Sort identity classes (on the x-axis) by the average expression of the attribute being potted, can also pass 'increasing' or 'decreasing' to change sort direction} \item{assay}{Name of assay to use, defaults to the active assay} \item{group.by}{Group (color) cells in different ways (for example, orig.ident)} \item{split.by}{A variable to split the violin plots by,} \item{adjust}{Adjust parameter for geom_violin} \item{y.max}{Maximum y axis value} \item{same.y.lims}{Set all the y-axis limits to the same values} \item{log}{plot the feature axis on log scale} \item{ncol}{Number of columns if multiple plots are displayed} \item{combine}{Combine plots into a single gg object; note that if TRUE; themeing will not work when plotting multiple features} \item{slot}{Use non-normalized counts data for plotting} \item{multi.group}{plot each group of the split violin plots by multiple or single violin shapes see \code{\link{FetchData}} for more details} \item{...}{Extra parameters passed on to \code{\link{CombinePlots}}} } \value{ A ggplot object } \description{ Draws a violin plot of single cell data (gene expression, metrics, PC scores, etc.) } \examples{ VlnPlot(object = pbmc_small, features = 'PC_1') VlnPlot(object = pbmc_small, features = 'LYZ', split.by = 'groups') } \seealso{ \code{\link{FetchData}} } Seurat/man/Assays.Rd0000644000176200001440000000116513617632030014026 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/objects.R \name{Assays} \alias{Assays} \title{Pull Assays or assay names} \usage{ Assays(object, slot = NULL) } \arguments{ \item{object}{A Seurat object} \item{slot}{Name of Assay to return} } \value{ If \code{slot} is \code{NULL}, the names of all \code{Assay} objects in this Seurat object. Otherwise, the \code{Assay} object specified } \description{ Lists the names of \code{\link{Assay}} objects present in a Seurat object. If slot is provided, pulls specified Assay object. } \examples{ Assays(object = pbmc_small) } Seurat/man/FeaturePlot.Rd0000644000176200001440000001077013617632030015017 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{FeaturePlot} \alias{FeaturePlot} \alias{FeatureHeatmap} \title{Visualize 'features' on a dimensional reduction plot} \usage{ FeaturePlot( object, features, dims = c(1, 2), cells = NULL, cols = if (blend) { c("lightgrey", "#ff0000", "#00ff00") } else { c("lightgrey", "blue") }, pt.size = NULL, order = FALSE, min.cutoff = NA, max.cutoff = NA, reduction = NULL, split.by = NULL, shape.by = NULL, slot = "data", blend = FALSE, blend.threshold = 0.5, label = FALSE, label.size = 4, repel = FALSE, ncol = NULL, combine = TRUE, coord.fixed = FALSE, by.col = TRUE, sort.cell = FALSE ) } \arguments{ \item{object}{Seurat object} \item{features}{Vector of features to plot. Features can come from: \itemize{ \item An \code{Assay} feature (e.g. a gene name - "MS4A1") \item A column name from meta.data (e.g. mitochondrial percentage - "percent.mito") \item A column name from a \code{DimReduc} object corresponding to the cell embedding values (e.g. the PC 1 scores - "PC_1") }} \item{dims}{Dimensions to plot, must be a two-length numeric vector specifying x- and y-dimensions} \item{cells}{Vector of cells to plot (default is all cells)} \item{cols}{The two colors to form the gradient over. Provide as string vector with the first color corresponding to low values, the second to high. Also accepts a Brewer color scale or vector of colors. Note: this will bin the data into number of colors provided. When blend is \code{TRUE}, takes anywhere from 1-3 colors: \describe{ \item{1 color:}{Treated as color for double-negatives, will use default colors 2 and 3 for per-feature expression} \item{2 colors:}{Treated as colors for per-feature expression, will use default color 1 for double-negatives} \item{3+ colors:}{First color used for double-negatives, colors 2 and 3 used for per-feature expression, all others ignored} }} \item{pt.size}{Adjust point size for plotting} \item{order}{Boolean determining whether to plot cells in order of expression. Can be useful if cells expressing given feature are getting buried.} \item{min.cutoff, max.cutoff}{Vector of minimum and maximum cutoff values for each feature, may specify quantile in the form of 'q##' where '##' is the quantile (eg, 'q1', 'q10')} \item{reduction}{Which dimensionality reduction to use. If not specified, first searches for umap, then tsne, then pca} \item{split.by}{A factor in object metadata to split the feature plot by, pass 'ident' to split by cell identity'; similar to the old \code{FeatureHeatmap}} \item{shape.by}{If NULL, all points are circles (default). You can specify any cell attribute (that can be pulled with FetchData) allowing for both different colors and different shapes on cells} \item{slot}{Which slot to pull expression data from?} \item{blend}{Scale and blend expression values to visualize coexpression of two features} \item{blend.threshold}{The color cutoff from weak signal to strong signal; ranges from 0 to 1.} \item{label}{Whether to label the clusters} \item{label.size}{Sets size of labels} \item{repel}{Repel labels} \item{ncol}{Number of columns to combine multiple feature plots to, ignored if \code{split.by} is not \code{NULL}} \item{combine}{Combine plots into a single gg object; note that if \code{TRUE}; themeing will not work when plotting multiple features} \item{coord.fixed}{Plot cartesian coordinates with fixed aspect ratio} \item{by.col}{If splitting by a factor, plot the splits per column with the features as rows; ignored if \code{blend = TRUE}} \item{sort.cell}{If \code{TRUE}, the positive cells will overlap the negative cells} } \value{ Returns a ggplot object if only 1 feature is plotted. If >1 features are plotted and \code{combine=TRUE}, returns a combined ggplot object using \code{cowplot::plot_grid}. If >1 features are plotted and \code{combine=FALSE}, returns a list of ggplot objects. } \description{ Colors single cells on a dimensional reduction plot according to a 'feature' (i.e. gene expression, PC scores, number of genes detected, etc.) } \note{ For the old \code{do.hover} and \code{do.identify} functionality, please see \code{HoverLocator} and \code{CellSelector}, respectively. } \examples{ FeaturePlot(object = pbmc_small, features = 'PC_1') } \seealso{ \code{\link{DimPlot}} \code{\link{HoverLocator}} \code{\link{CellSelector}} } Seurat/man/RunALRA.Rd0000644000176200001440000000720513617632030013770 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/preprocessing.R \name{RunALRA} \alias{RunALRA} \alias{RunALRA.default} \alias{RunALRA.Seurat} \title{Run Adaptively-thresholded Low Rank Approximation (ALRA)} \usage{ RunALRA(object, ...) \method{RunALRA}{default}( object, k = NULL, q = 10, quantile.prob = 0.001, use.mkl = FALSE, mkl.seed = -1, ... ) \method{RunALRA}{Seurat}( object, k = NULL, q = 10, quantile.prob = 0.001, use.mkl = FALSE, mkl.seed = -1, assay = NULL, slot = "data", setDefaultAssay = TRUE, genes.use = NULL, K = NULL, thresh = 6, noise.start = NULL, q.k = 2, k.only = FALSE, ... ) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods} \item{k}{The rank of the rank-k approximation. Set to NULL for automated choice of k.} \item{q}{The number of additional power iterations in randomized SVD when computing rank k approximation. By default, q=10.} \item{quantile.prob}{The quantile probability to use when calculating threshold. By default, quantile.prob = 0.001.} \item{use.mkl}{Use the Intel MKL based implementation of SVD. Needs to be installed from https://github.com/KlugerLab/rpca-mkl. \strong{Note}: this requires the \href{https://github.com/satijalab/seurat-wrappers}{SeuratWrappers} implementation of \code{RunALRA}} \item{mkl.seed}{Only relevant if \code{use.mkl = TRUE}. Set the seed for the random generator for the Intel MKL implementation of SVD. Any number <0 will use the current timestamp. If \code{use.mkl = FALSE}, set the seed using \code{\link{set.seed}()} function as usual.} \item{assay}{Assay to use} \item{slot}{slot to use} \item{setDefaultAssay}{If TRUE, will set imputed results as default Assay} \item{genes.use}{genes to impute} \item{K}{Number of singular values to compute when choosing k. Must be less than the smallest dimension of the matrix. Default 100 or smallest dimension.} \item{thresh}{The threshold for ''significance'' when choosing k. Default 1e-10.} \item{noise.start}{Index for which all smaller singular values are considered noise. Default K - 20.} \item{q.k}{Number of additional power iterations when choosing k. Default 2.} \item{k.only}{If TRUE, only computes optimal k WITHOUT performing ALRA} } \description{ Runs ALRA, a method for imputation of dropped out values in scRNA-seq data. Computes the k-rank approximation to A_norm and adjusts it according to the error distribution learned from the negative values. Described in Linderman, G. C., Zhao, J., Kluger, Y. (2018). "Zero-preserving imputation of scRNA-seq data using low rank approximation." (bioRxiv:138677) } \note{ RunALRA and associated functions are being moved to SeuratWrappers; for more information on SeuratWrappers, please see \url{https://github.com/satijalab/seurat-wrappers} } \examples{ pbmc_small # Example 1: Simple usage, with automatic choice of k. pbmc_small_alra <- RunALRA(object = pbmc_small) \dontrun{ # Example 2: Visualize choice of k, then run ALRA # First, choose K pbmc_small_alra <- RunALRA(pbmc_small, k.only=TRUE) # Plot the spectrum, spacings, and p-values which are used to choose k ggouts <- ALRAChooseKPlot(pbmc_small_alra) do.call(gridExtra::grid.arrange, c(ggouts, nrow=1)) # Run ALRA with the chosen k pbmc_small_alra <- RunALRA(pbmc_small_alra) } } \references{ Linderman, G. C., Zhao, J., Kluger, Y. (2018). "Zero-preserving imputation of scRNA-seq data using low rank approximation." (bioRxiv:138677) } \seealso{ \code{\link{ALRAChooseKPlot}} } \author{ Jun Zhao, George Linderman } Seurat/man/RunPCA.Rd0000644000176200001440000000520713617632030013654 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/dimensional_reduction.R \name{RunPCA} \alias{RunPCA} \alias{RunPCA.default} \alias{RunPCA.Assay} \alias{RunPCA.Seurat} \title{Run Principal Component Analysis} \usage{ RunPCA(object, ...) \method{RunPCA}{default}( object, assay = NULL, npcs = 50, rev.pca = FALSE, weight.by.var = TRUE, verbose = TRUE, ndims.print = 1:5, nfeatures.print = 30, reduction.key = "PC_", seed.use = 42, approx = TRUE, ... ) \method{RunPCA}{Assay}( object, assay = NULL, features = NULL, npcs = 50, rev.pca = FALSE, weight.by.var = TRUE, verbose = TRUE, ndims.print = 1:5, nfeatures.print = 30, reduction.key = "PC_", seed.use = 42, ... ) \method{RunPCA}{Seurat}( object, assay = NULL, features = NULL, npcs = 50, rev.pca = FALSE, weight.by.var = TRUE, verbose = TRUE, ndims.print = 1:5, nfeatures.print = 30, reduction.name = "pca", reduction.key = "PC_", seed.use = 42, ... ) } \arguments{ \item{object}{An object} \item{...}{Arguments passed to other methods and IRLBA} \item{assay}{Name of Assay PCA is being run on} \item{npcs}{Total Number of PCs to compute and store (50 by default)} \item{rev.pca}{By default computes the PCA on the cell x gene matrix. Setting to true will compute it on gene x cell matrix.} \item{weight.by.var}{Weight the cell embeddings by the variance of each PC (weights the gene loadings if rev.pca is TRUE)} \item{verbose}{Print the top genes associated with high/low loadings for the PCs} \item{ndims.print}{PCs to print genes for} \item{nfeatures.print}{Number of genes to print for each PC} \item{reduction.key}{dimensional reduction key, specifies the string before the number for the dimension names. PC by default} \item{seed.use}{Set a random seed. By default, sets the seed to 42. Setting NULL will not set a seed.} \item{approx}{Use truncated singular value decomposition to approximate PCA} \item{features}{Features to compute PCA on. If features=NULL, PCA will be run using the variable features for the Assay. Note that the features must be present in the scaled data. Any requested features that are not scaled or have 0 variance will be dropped, and the PCA will be run using the remaining features.} \item{reduction.name}{dimensional reduction name, pca by default} } \value{ Returns Seurat object with the PCA calculation stored in the reductions slot } \description{ Run a PCA dimensionality reduction. For details about stored PCA calculation parameters, see \code{PrintPCAParams}. } Seurat/man/ColorDimSplit.Rd0000644000176200001440000000700513617632030015306 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/visualization.R \name{ColorDimSplit} \alias{ColorDimSplit} \title{Color dimensional reduction plot by tree split} \usage{ ColorDimSplit( object, node, left.color = "red", right.color = "blue", other.color = "grey50", ... ) } \arguments{ \item{object}{Seurat object} \item{node}{Node in cluster tree on which to base the split} \item{left.color}{Color for the left side of the split} \item{right.color}{Color for the right side of the split} \item{other.color}{Color for all other cells} \item{...}{ Arguments passed on to \code{\link[=DimPlot]{DimPlot}} \describe{ \item{\code{dims}}{Dimensions to plot, must be a two-length numeric vector specifying x- and y-dimensions} \item{\code{cells}}{Vector of cells to plot (default is all cells)} \item{\code{cols}}{Vector of colors, each color corresponds to an identity class. This may also be a single character or numeric value corresponding to a palette as specified by \code{\link[RColorBrewer]{brewer.pal.info}}. By default, ggplot2 assigns colors. We also include a number of palettes from the pals package. See \code{\link{DiscretePalette}} for details.} \item{\code{pt.size}}{Adjust point size for plotting} \item{\code{reduction}}{Which dimensionality reduction to use. If not specified, first searches for umap, then tsne, then pca} \item{\code{group.by}}{Name of one or more metadata columns to group (color) cells by (for example, orig.ident); pass 'ident' to group by identity class} \item{\code{split.by}}{Name of a metadata column to split plot by; see \code{\link{FetchData}} for more details} \item{\code{shape.by}}{If NULL, all points are circles (default). You can specify any cell attribute (that can be pulled with FetchData) allowing for both different colors and different shapes on cells} \item{\code{order}}{Specify the order of plotting for the idents. This can be useful for crowded plots if points of interest are being buried. Provide either a full list of valid idents or a subset to be plotted last (on top)} \item{\code{label}}{Whether to label the clusters} \item{\code{label.size}}{Sets size of labels} \item{\code{repel}}{Repel labels} \item{\code{cells.highlight}}{A list of character or numeric vectors of cells to highlight. If only one group of cells desired, can simply pass a vector instead of a list. If set, colors selected cells to the color(s) in \code{cols.highlight} and other cells black (white if dark.theme = TRUE); will also resize to the size(s) passed to \code{sizes.highlight}} \item{\code{cols.highlight}}{A vector of colors to highlight the cells as; will repeat to the length groups in cells.highlight} \item{\code{sizes.highlight}}{Size of highlighted cells; will repeat to the length groups in cells.highlight} \item{\code{na.value}}{Color value for NA points when using custom scale} \item{\code{combine}}{Combine plots into a single gg object; note that if TRUE; themeing will not work when plotting multiple features} \item{\code{ncol}}{Number of columns for display when combining plots} }} } \value{ Returns a DimPlot } \description{ Returns a DimPlot colored based on whether the cells fall in clusters to the left or to the right of a node split in the cluster tree. } \examples{ pbmc_small pbmc_small <- BuildClusterTree(object = pbmc_small, verbose = FALSE) PlotClusterTree(pbmc_small) ColorDimSplit(pbmc_small, node = 5) } Seurat/man/HTODemux.Rd0000644000176200001440000000412013617632030014212 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/preprocessing.R \name{HTODemux} \alias{HTODemux} \title{Demultiplex samples based on data from cell 'hashing'} \usage{ HTODemux( object, assay = "HTO", positive.quantile = 0.99, init = NULL, nstarts = 100, kfunc = "clara", nsamples = 100, seed = 42, verbose = TRUE ) } \arguments{ \item{object}{Seurat object. Assumes that the hash tag oligo (HTO) data has been added and normalized.} \item{assay}{Name of the Hashtag assay (HTO by default)} \item{positive.quantile}{The quantile of inferred 'negative' distribution for each hashtag - over which the cell is considered 'positive'. Default is 0.99} \item{init}{Initial number of clusters for hashtags. Default is the # of hashtag oligo names + 1 (to account for negatives)} \item{nstarts}{nstarts value for k-means clustering (for kfunc = "kmeans"). 100 by default} \item{kfunc}{Clustering function for initial hashtag grouping. Default is "clara" for fast k-medoids clustering on large applications, also support "kmeans" for kmeans clustering} \item{nsamples}{Number of samples to be drawn from the dataset used for clustering, for kfunc = "clara"} \item{seed}{Sets the random seed. If NULL, seed is not set} \item{verbose}{Prints the output} } \value{ The Seurat object with the following demultiplexed information stored in the meta data: \describe{ \item{hash.maxID}{Name of hashtag with the highest signal} \item{hash.secondID}{Name of hashtag with the second highest signal} \item{hash.margin}{The difference between signals for hash.maxID and hash.secondID} \item{classification}{Classification result, with doublets/multiplets named by the top two highest hashtags} \item{classification.global}{Global classification result (singlet, doublet or negative)} \item{hash.ID}{Classification result where doublet IDs are collapsed} } } \description{ Assign sample-of-origin for each cell, annotate doublets. } \examples{ \dontrun{ object <- HTODemux(object) } } \seealso{ \code{\link{HTOHeatmap}} } Seurat/man/as.Seurat.Rd0000644000176200001440000001070313617632030014426 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/generics.R, R/objects.R \name{as.Seurat} \alias{as.Seurat} \alias{as.Seurat.CellDataSet} \alias{as.Seurat.loom} \alias{as.Seurat.SingleCellExperiment} \title{Convert objects to Seurat objects} \usage{ as.Seurat(x, ...) \method{as.Seurat}{CellDataSet}(x, slot = "counts", assay = "RNA", verbose = TRUE, ...) \method{as.Seurat}{loom}( x, cells = "CellID", features = "Gene", normalized = NULL, scaled = NULL, assay = NULL, verbose = TRUE, ... ) \method{as.Seurat}{SingleCellExperiment}( x, counts = "counts", data = "logcounts", assay = "RNA", project = "SingleCellExperiment", ... ) } \arguments{ \item{x}{An object to convert to class \code{Seurat}} \item{...}{Arguments passed to other methods} \item{slot}{Slot to store expression data as} \item{assay}{Name to store expression matrices as} \item{verbose}{Display progress updates} \item{cells}{The name of the dataset within \code{col_attrs} containing cell names} \item{features}{The name of the dataset within \code{row_attrs} containing feature names} \item{normalized}{The name of the dataset within \code{layers} containing the normalized expression matrix; pass \code{/matrix} (with preceeding forward slash) to store \code{/matrix} as normalized data} \item{scaled}{The name of the dataset within \code{layers} containing the scaled expression matrix} \item{counts}{name of the SingleCellExperiment assay to store as \code{counts}; set to \code{NULL} if only normalized data are present} \item{data}{name of the SingleCellExperiment assay to slot as \code{data}. Set to NULL if only counts are present} \item{project}{Project name for new Seurat object} } \description{ Convert objects to Seurat objects } \details{ The \code{loom} method for \code{as.Seurat} will try to automatically fill in a Seurat object based on data presence. For example, if no normalized data is present, then scaled data, dimensional reduction informan, and neighbor graphs will not be pulled as these depend on normalized data. The following is a list of how the Seurat object will be constructed \itemize{ \item If no assay information is provided, will default to an assay name in a root-level HDF5 attribute called \code{assay}; if no attribute is present, will default to "RNA" \item Cell-level metadata will consist of all one-dimensional datasets in \code{col_attrs} \strong{except} datasets named "ClusterID", "ClusterName", and whatever is passed to \code{cells} \item Identity classes will be set if either \code{col_attrs/ClusterID} or \code{col_attrs/ClusterName} are present; if both are present, then the values in \code{col_attrs/ClusterID} will set the order (numeric value of a factor) for values in \code{col_attrs/ClusterName} (charater value of a factor) \item Feature-level metadata will consist of all one-dimensional datasets in \code{row_attrs} \strong{except} datasets named "Selected" and whatever is passed to \code{features}; any feature-level metadata named "variance_standardized", "variance_expected", or "dispersion_scaled" will have underscores "_" replaced with a period "." \item Variable features will be set if \code{row_attrs/Selected} exists and it is a numeric type \item If a dataset is passed to \code{normalized}, stored as a sparse matrix in \code{data}; if no dataset provided, \code{scaled} will be set to \code{NULL} \item If a dataset is passed to \code{scaled}, stored as a dense matrix in \code{scale.data}; all rows entirely consisting of \code{NA}s will be removed \item If a dataset is passed to \code{scaled}, dimensional reduction information will assembled from cell embedding information stored in \code{col_attrs}; cell embeddings will be pulled from two-dimensional datasets ending with "_cell_embeddings"; priority will be given to cell embeddings that have the name of \code{assay} in their name; feature loadings will be added from two-dimensional datasets in \code{row_attrs} that start with the name of the dimensional reduction and end with either "feature_loadings" or "feature_loadings_projected" (priority given to the latter) \item If a dataset is passed to \code{scaled}, neighbor graphs will be pulled from \code{col_graphs}, provided the name starts with the value of \code{assay} } } \examples{ \dontrun{ lfile <- as.loom(x = pbmc_small) pbmc <- as.Seurat(x = lfile) } } Seurat/man/CreateGeneActivityMatrix.Rd0000644000176200001440000000211513617632030017463 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/preprocessing.R \name{CreateGeneActivityMatrix} \alias{CreateGeneActivityMatrix} \title{Convert a peak matrix to a gene activity matrix} \usage{ CreateGeneActivityMatrix( peak.matrix, annotation.file, seq.levels = c(1:22, "X", "Y"), include.body = TRUE, upstream = 2000, downstream = 0, verbose = TRUE ) } \arguments{ \item{peak.matrix}{Matrix of peak counts} \item{annotation.file}{Path to GTF annotation file} \item{seq.levels}{Which seqlevels to keep (corresponds to chromosomes usually)} \item{include.body}{Include the gene body?} \item{upstream}{Number of bases upstream to consider} \item{downstream}{Number of bases downstream to consider} \item{verbose}{Print progress/messages} } \description{ This function will take in a peak matrix and an annotation file (gtf) and collapse the peak matrix to a gene activity matrix. It makes the simplifying assumption that all counts in the gene body plus X kb up and or downstream should be attributed to that gene. } Seurat/DESCRIPTION0000644000176200001440000000725613620617476013251 0ustar liggesusersPackage: Seurat Version: 3.1.3 Date: 2020-02-07 Title: Tools for Single Cell Genomics Description: A toolkit for quality control, analysis, and exploration of single cell RNA sequencing data. 'Seurat' aims to enable users to identify and interpret sources of heterogeneity from single cell transcriptomic measurements, and to integrate diverse types of single cell data. See Satija R, Farrell J, Gennert D, et al (2015) , Macosko E, Basu A, Satija R, et al (2015) , and Butler A and Satija R (2017) for more details. Authors@R: c( person(given = 'Rahul', family = 'Satija', email = 'rsatija@nygenome.org', role = 'aut', comment = c(ORCID = '0000-0001-9448-8833')), person(given = 'Andrew', family = 'Butler', email = 'abutler@nygenome.org', role = 'aut', comment = c(ORCID = '0000-0003-3608-0463')), person(given = 'Paul', family = 'Hoffman', email = 'nygcSatijalab@nygenome.org', role = c('aut', 'cre'), comment = c(ORCID = '0000-0002-7693-8957')), person(given = 'Tim', family = 'Stuart', email = 'tstuart@nygenome.org', role = 'aut', comment = c(ORCID = '0000-0002-3044-0897')), person(given = 'Jeff', family = 'Farrell', email = 'jfarrell@g.harvard.edu', role = 'ctb'), person(given = 'Shiwei', family = 'Zheng', email = 'szheng@nygenome.org', role = 'ctb', comment = c(ORCID = '0000-0001-6682-6743')), person(given = 'Christoph', family = 'Hafemeister', email = 'chafemeister@nygenome.org', role = 'ctb', comment = c(ORCID = '0000-0001-6365-8254')), person(given = 'Patrick', family = 'Roelli', email = 'proelli@nygenome.org', role = 'ctb'), person(given = "Yuhan", family = "Hao", email = 'yhao@nygenome.org', role = 'ctb', comment = c(ORCID = '0000-0002-1810-0822')) ) URL: http://www.satijalab.org/seurat, https://github.com/satijalab/seurat BugReports: https://github.com/satijalab/seurat/issues Additional_repositories: https://mojaveazure.github.io/loomR Depends: R (>= 3.4.0), methods, Imports: ape, cluster, cowplot, fitdistrplus, future, future.apply, ggplot2 (>= 3.0.0), ggrepel, ggridges, graphics, grDevices, grid, httr, ica, igraph, irlba, KernSmooth, leiden (>= 0.3.1), lmtest, MASS, Matrix (>= 1.2-14), metap, pbapply, plotly, png, RANN, RColorBrewer, Rcpp, RcppAnnoy, reticulate, rlang, ROCR, rsvd, Rtsne, scales, sctransform (>= 0.2.0), stats, tools, tsne, utils, uwot (>= 0.1.5) LinkingTo: Rcpp (>= 0.11.0), RcppEigen, RcppProgress License: GPL-3 | file LICENSE LazyData: true Collate: 'RcppExports.R' 'generics.R' 'clustering.R' 'visualization.R' 'convenience.R' 'data.R' 'differential_expression.R' 'dimensional_reduction.R' 'integration.R' 'objects.R' 'preprocessing.R' 'tree.R' 'utilities.R' 'zzz.R' RoxygenNote: 7.0.2 Encoding: UTF-8 biocViews: Suggests: loomR, SDMTools, testthat, hdf5r, S4Vectors, SummarizedExperiment, SingleCellExperiment, MAST, DESeq2, BiocGenerics, GenomicRanges, GenomeInfoDb, IRanges, rtracklayer, monocle, Biobase, VGAM NeedsCompilation: yes Packaged: 2020-02-10 02:12:30 UTC; mojav Author: Rahul Satija [aut] (), Andrew Butler [aut] (), Paul Hoffman [aut, cre] (), Tim Stuart [aut] (), Jeff Farrell [ctb], Shiwei Zheng [ctb] (), Christoph Hafemeister [ctb] (), Patrick Roelli [ctb], Yuhan Hao [ctb] () Maintainer: Paul Hoffman Repository: CRAN Date/Publication: 2020-02-11 21:40:14 UTC Seurat/tests/0000755000176200001440000000000013527073365012672 5ustar liggesusersSeurat/tests/testthat/0000755000176200001440000000000013620617476014533 5ustar liggesusersSeurat/tests/testthat/test_differential_expression.R0000644000176200001440000003261013620135602022614 0ustar liggesusers# Tests for functions in differential_expression.R suppressWarnings(RNGversion(vstr = "3.5.3")) set.seed(seed = 42) # Tests for FindMarkers default parameters # -------------------------------------------------------------------------------- context("FindMarkers") markers.0 <- suppressWarnings(FindMarkers(object = pbmc_small, ident.1 = 0, verbose = FALSE)) markers.01 <- suppressWarnings(FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = 1, verbose = FALSE)) test_that("Default settings work as expected", { expect_error(FindMarkers(object = pbmc_small)) expect_error(FindMarkers(object = pbmc_small, ident.1 = "test")) expect_error(FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = "test")) expect_equal(colnames(x = markers.0), c("p_val", "avg_logFC", "pct.1", "pct.2", "p_val_adj")) expect_equal(markers.0[1, "p_val"], 9.572778e-13) expect_equal(markers.0[1, "avg_logFC"], -4.034691, tolerance = 1e-6) expect_equal(markers.0[1, "pct.1"], 0.083) expect_equal(markers.0[1, "pct.2"], 0.909) expect_equal(markers.0[1, "p_val_adj"], 2.201739e-10) expect_equal(nrow(x = markers.0), 204) expect_equal(rownames(markers.0)[1], "HLA-DPB1") expect_equal(markers.01[1, "p_val"], 1.702818e-11) expect_equal(markers.01[1, "avg_logFC"], -2.539289, tolerance = 1e-6) expect_equal(markers.01[1, "pct.1"], 0.111) expect_equal(markers.01[1, "pct.2"], 1.00) expect_equal(markers.01[1, "p_val_adj"], 3.916481e-09) expect_equal(nrow(x = markers.01), 201) expect_equal(rownames(x = markers.01)[1], "TYMP") }) tymp.results <- suppressWarnings(FindMarkers(object = pbmc_small, ident.1 = 0, features = "TYMP", verbose = FALSE)) vargenes.results <- suppressWarnings(FindMarkers(object = pbmc_small, ident.1 = 0, features = VariableFeatures(object = pbmc_small), verbose = FALSE)) test_that("features parameter behaves correctly ", { expect_equal(nrow(x = tymp.results), 1) expect_equal(tymp.results[1, "p_val"], 3.227445e-07) expect_equal(tymp.results[1, "avg_logFC"], -2.093928, tolerance = 1e-6) expect_equal(tymp.results[1, "pct.1"], 0.111) expect_equal(tymp.results[1, "pct.2"], 0.682) expect_equal(tymp.results[1, "p_val_adj"], 7.423123e-05) expect_equal(rownames(x = tymp.results)[1], "TYMP") expect_equal(nrow(x = vargenes.results), 19) expect_equal(vargenes.results[19, "p_val"], 4.225151e-01, tolerance = 1e-6) expect_equal(vargenes.results[19, "avg_logFC"], 1.5976958, tolerance = 1e-6) expect_equal(vargenes.results[19, "pct.1"], 0.139) expect_equal(vargenes.results[19, "pct.2"], 0.091) expect_equal(vargenes.results[19, "p_val_adj"], 1.000000e+00) expect_equal(rownames(x = vargenes.results)[19], "PARVB") }) results <- suppressWarnings(FindMarkers(object = pbmc_small, ident.1 = Cells(x = pbmc_small)[1:40], ident.2 = Cells(x = pbmc_small)[41:80], verbose = FALSE)) test_that("passing cell names works", { expect_equal(nrow(x = results), 176) expect_equal(results[1, "p_val"], 0.0001690882) expect_equal(results[1, "avg_logFC"], -1.790824, tolerance = 1e-6) expect_equal(results[1, "pct.1"], 0.075) expect_equal(results[1, "pct.2"], 0.450) expect_equal(results[1, "p_val_adj"], 0.03889028) expect_equal(rownames(x = results)[1], "IFI30") }) results <- suppressWarnings(FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = 1, logfc.threshold = 2, verbose = FALSE)) test_that("logfc.threshold works", { expect_equal(nrow(x = results), 112) expect_gte(min(abs(x = results$avg_logFC)), 2) expect_error(FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = 1, logfc.threshold = 100, verbose = FALSE)) }) results <- suppressWarnings(FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = 1, min.pct = 0.5, verbose = FALSE)) test_that("min.pct works", { expect_equal(nrow(x = results), 63) expect_gte(min(apply(X = results, MARGIN = 1, FUN = function(x) max(x[3], x[4]))), 0.5) }) results <- suppressWarnings(FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = 1, min.diff.pct = 0.5, verbose = FALSE)) test_that("min.diff.pct works", { expect_equal(nrow(x = results), 43) expect_gte(min(apply(X = results, MARGIN = 1, FUN = function(x) abs(x[4] - x[3]))), 0.5) }) results <- suppressWarnings(FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = 1, only.pos = TRUE, verbose = FALSE)) test_that("only.pos works", { expect_equal(nrow(x = results), 116) expect_true(all(results$avg_logFC > 0)) }) results <- suppressWarnings(FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = 1, max.cells.per.ident = 20, verbose = FALSE)) test_that("max.cells.per.ident works", { expect_equal(nrow(x = results), 201) expect_equal(results[1, "p_val"], 3.428568e-08) expect_equal(results[1, "avg_logFC"], -2.539289, tolerance = 1e-6) expect_equal(results[1, "pct.1"], 0.111) expect_equal(results[1, "pct.2"], 1) expect_equal(results[1, "p_val_adj"], 7.885706e-06) expect_equal(rownames(x = results)[1], "TYMP") }) results <- suppressWarnings(FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = 1, latent.vars= "groups", verbose = FALSE, test.use = 'LR')) test_that("latent.vars works", { expect_error(FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = 1, latent.vars= "fake", verbose = FALSE)) expect_warning(FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = 1, latent.vars= "groups", verbose = FALSE)) expect_equal(nrow(x = results), 201) expect_equal(results[1, "p_val"], 2.130202e-16) expect_equal(results[1, "avg_logFC"], -3.082150, tolerance = 1e-6) expect_equal(results[1, "pct.1"], 0.417) expect_equal(results[1, "pct.2"], 1) expect_equal(results[1, "p_val_adj"], 4.899466e-14) expect_equal(rownames(x = results)[1], "LYZ") }) results <- suppressWarnings(FindMarkers(object = pbmc_small, ident.1 = "g1", ident.2 = "g2", group.by= "groups", verbose = FALSE)) t2 <- pbmc_small Idents(object = t2) <- "groups" results2 <- suppressWarnings(FindMarkers(object = t2, ident.1 = "g1", ident.2 = "g2", verbose = FALSE)) test_that("group.by works", { expect_equal(nrow(x = results), 136) expect_equal(results, results2) expect_equal(results[1, "p_val"], 0.02870319) expect_equal(results[1, "avg_logFC"], 0.8226720, tolerance = 1e-6) expect_equal(results[1, "pct.1"], 0.455) expect_equal(results[1, "pct.2"], 0.194) expect_equal(results[1, "p_val_adj"], 1) expect_equal(rownames(x = results)[1], "NOSIP") }) results <- suppressWarnings(FindMarkers(object = pbmc_small, ident.1 = "g1", ident.2 = "g2", group.by= "groups", subset.ident = 0, verbose = FALSE)) t2 <- subset(x = pbmc_small, idents = 0) Idents(object = t2) <- "groups" results2 <- suppressWarnings(FindMarkers(object = t2, ident.1 = "g1", ident.2 = "g2", verbose = FALSE)) test_that("subset.ident works", { expect_equal(nrow(x = results), 114) expect_equal(results, results2) expect_equal(results[1, "p_val"], 0.01293720) expect_equal(results[1, "avg_logFC"], 1.799280, tolerance = 1e-6) expect_equal(results[1, "pct.1"], 0.50) expect_equal(results[1, "pct.2"], 0.125) expect_equal(results[1, "p_val_adj"], 1) expect_equal(rownames(x = results)[1], "TSPO") }) results <- suppressWarnings(FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = 1, reduction = "pca", verbose = FALSE)) test_that("reduction works", { expect_equal(results[1, "p_val"], 1.664954e-10) expect_equal(results[1, "avg_diff"], -2.810453669, tolerance = 1e-6) expect_equal(results[1, "p_val_adj"], 3.163412e-09) expect_equal(rownames(x = results)[1], "PC_2") }) results <- FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = 1, test.use = "bimod", verbose = FALSE) test_that("bimod test works", { expect_equal(nrow(x = results), 201) expect_equal(results[1, "p_val"], 4.751376e-17) expect_equal(results[1, "avg_logFC"], -2.552769, tolerance = 1e-6) expect_equal(results[1, "pct.1"], 0.306) expect_equal(results[1, "pct.2"], 1.00) expect_equal(results[1, "p_val_adj"], 1.092816e-14) expect_equal(rownames(x = results)[1], "CST3") }) results <- FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = 1, test.use = "roc", verbose = FALSE) test_that("roc test works", { expect_equal(nrow(x = results), 201) expect_equal(colnames(x = results), c("myAUC", "avg_diff", "power", "pct.1", "pct.2")) expect_equal(results["CST3", "myAUC"], 0.018) expect_equal(results["CST3", "avg_diff"], -2.552769, tolerance = 1e-6) expect_equal(results["CST3", "power"], 0.964) expect_equal(results["CST3", "pct.1"], 0.306) expect_equal(results["CST3", "pct.2"], 1.00) expect_equal(rownames(x = results)[1], "LYZ") }) results <- FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = 1, test.use = "t", verbose = FALSE) test_that("bimod test works", { expect_equal(nrow(x = results), 201) expect_equal(results["CST3", "p_val"], 1.170112e-15) expect_equal(results["CST3", "avg_logFC"], -2.552769 , tolerance = 1e-6) expect_equal(results["CST3", "pct.1"], 0.306) expect_equal(results["CST3", "pct.2"], 1.00) expect_equal(results["CST3", "p_val_adj"], 2.691258e-13) expect_equal(rownames(x = results)[1], "TYMP") }) results <- suppressWarnings(FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = 1, test.use = "negbinom", verbose = FALSE)) test_that("negbinom test works", { expect_equal(nrow(x = results), 149) expect_equal(results["CST3", "p_val"], 1.354443e-17) expect_equal(results["CST3", "avg_logFC"], -2.353701, tolerance = 1e-6) expect_equal(results["CST3", "pct.1"], 0.306) expect_equal(results["CST3", "pct.2"], 1.00) expect_equal(results["CST3", "p_val_adj"], 3.115218e-15) expect_equal(rownames(x = results)[1], "LYZ") }) results <- suppressWarnings(FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = 1, test.use = "poisson", verbose = FALSE)) test_that("poisson test works", { expect_equal(nrow(x = results), 149) expect_equal(results["CST3", "p_val"], 3.792196e-78) expect_equal(results["CST3", "avg_logFC"], -2.353701, tolerance = 1e-6) expect_equal(results["CST3", "pct.1"], 0.306) expect_equal(results["CST3", "pct.2"], 1.00) expect_equal(results["CST3", "p_val_adj"], 8.722050e-76) expect_equal(rownames(x = results)[1], "LYZ") }) results <- suppressWarnings(FindMarkers(object = pbmc_small, ident.1 = 0, ident.2 = 1, test.use = "LR", verbose = FALSE)) test_that("LR test works", { expect_equal(nrow(x = results), 201) expect_equal(results["CST3", "p_val"], 3.990707e-16) expect_equal(results["CST3", "avg_logFC"], -2.552769, tolerance = 1e-6) expect_equal(results["CST3", "pct.1"], 0.306) expect_equal(results["CST3", "pct.2"], 1.00) expect_equal(results["CST3", "p_val_adj"], 9.178625e-14) expect_equal(rownames(x = results)[1], "LYZ") }) # Tests for FindConservedMarkers # -------------------------------------------------------------------------------- context("FindConservedMarkers") pbmc_small$groups markers <- suppressWarnings(FindConservedMarkers(object = pbmc_small, ident.1 = 0, grouping.var = "groups", verbose = FALSE)) standard.names <- c("p_val", "avg_logFC", "pct.1", "pct.2", "p_val_adj") test_that("FindConservedMarkers works", { expect_equal(colnames(x = markers), c(paste0("g2_", standard.names), paste0("g1_", standard.names), "max_pval", "minimump_p_val")) expect_equal(markers[1, "g2_p_val"], 4.983576e-05) expect_equal(markers[1, "g2_avg_logFC"], -4.125279, tolerance = 1e-6) # expect_equal(markers[1, "g2_pct.1"], 0.062) expect_equal(markers[1, "g2_pct.2"], 0.75) expect_equal(markers[1, "g2_p_val_adj"], 0.0114622238) expect_equal(markers[1, "g1_p_val"], 3.946643e-08) expect_equal(markers[1, "g1_avg_logFC"], -3.589384, tolerance = 1e-6) expect_equal(markers[1, "g1_pct.1"], 0.10) expect_equal(markers[1, "g1_pct.2"], 0.958) expect_equal(markers[1, "g1_p_val_adj"], 9.077279e-06) expect_equal(markers[1, "max_pval"], 4.983576e-05) expect_equal(markers[1, "minimump_p_val"], 7.893286e-08) expect_equal(nrow(markers), 162) expect_equal(rownames(markers)[1], "HLA-DRB1") expect_equal(markers[, "max_pval"], unname(obj = apply(X = markers, MARGIN = 1, FUN = function(x) max(x[c("g1_p_val", "g2_p_val")])))) }) test_that("FindConservedMarkers errors when expected", { expect_error(FindConservedMarkers(pbmc_small)) expect_error(FindConservedMarkers(pbmc_small, ident.1 = 0)) expect_error(FindConservedMarkers(pbmc_small, ident.1 = 0, grouping.var = "groups", meta.method = "minimump")) }) pbmc.test <- pbmc_small Idents(object = pbmc.test) <- "RNA_snn_res.1" pbmc.test$id.group <- paste0(pbmc.test$RNA_snn_res.1, "_", pbmc.test$groups) pbmc.test <- subset(x = pbmc.test, id.group == "0_g1", invert = TRUE) markers.missing <- suppressWarnings(FindConservedMarkers(object = pbmc.test, ident.1 = 0, grouping.var = "groups", test.use = "t", verbose = FALSE)) test_that("FindConservedMarkers handles missing idents in certain groups", { expect_warning(FindConservedMarkers(object = pbmc.test, ident.1 = 0, grouping.var = "groups", test.use = "t")) expect_equal(colnames(x = markers.missing), paste0("g2_", standard.names)) expect_equal(markers.missing[1, "g2_p_val"], 1.672911e-13) expect_equal(markers.missing[1, "g2_avg_logFC"], -4.527888, tolerance = 1e-6) # expect_equal(markers.missing[1, "g2_pct.1"], 0.062) expect_equal(markers.missing[1, "g2_pct.2"], 0.95) expect_equal(markers.missing[1, "g2_p_val_adj"], 3.847695e-11) expect_equal(nrow(markers.missing), 190) expect_equal(rownames(markers.missing)[1], "HLA-DPB1") }) Seurat/tests/testthat/test_data_manipulation.R0000644000176200001440000002262313527073365021412 0ustar liggesusers# Tests for functions in data_manipulation.cpp # change in random number generation in R3.6, this ensures tests will pass under older and newer Rs suppressWarnings(RNGversion(vstr = "3.5.3")) set.seed(42) library(Matrix) # Tests for row merging # -------------------------------------------------------------------------------- context("Row Merging") m1 <- rsparsematrix(10, 10, 0.1) m2 <- rsparsematrix(10, 10, 0.1) m1.names <- paste0("row", sample(1:10, size = 10)) m2.names <- paste0("row", sample(1:20, size = 10)) all.names <- union(m1.names, m2.names) rownames(m1) <- m1.names rownames(m2) <- m2.names m1 <- as(m1, "RsparseMatrix") m2 <- as(m2, "RsparseMatrix") test_that("Row merging done correctly", { m3 <- RowMergeMatrices(mat1 = m1, mat2 = m2, mat1_rownames = m1.names, mat2_rownames = m2.names, all_rownames = all.names) expect_equal(m3[1, 14], -0.17) expect_equal(m3[3, 2], -1.4) expect_equal(m3[14, 18], -0.43) expect_equal(length(m3), 280) }) # Tests for log normalization # -------------------------------------------------------------------------------- context("Log Normalization") mat <- as(matrix(1:16, ncol = 4, nrow = 4), "sparseMatrix") test_that("Log Normalization returns expected values", { mat.norm.r <- log1p(sweep(mat, 2, Matrix::colSums(mat), FUN = "/") * 1e4) mat.norm <- LogNorm(mat, 1e4, display_progress = F) expect_equal(mat.norm[1, ], mat.norm.r[1, ]) expect_equal(mat.norm[4, 4], mat.norm.r[4, 4]) }) # Tests for scaling data # -------------------------------------------------------------------------------- context("Fast Scale Data Functions") mat <- matrix(seq(0.001, 0.1, 0.001), nrow = 10, ncol = 10) # should be the equivalent of t(scale(t(mat))) test_that("Fast implementation of row scaling returns expected values", { expect_equal(t(scale(t(mat))[1:10, 1:10]), FastRowScale(mat, display_progress = FALSE)) expect_equal(t(scale(t(mat), center = FALSE))[1:10, 1:10], FastRowScale(mat, center = FALSE, display_progress = FALSE)) expect_equal(t(scale(t(mat), scale = FALSE))[1:10, 1:10], FastRowScale(mat, scale = FALSE, display_progress = FALSE)) expect_equal(t(scale(t(mat), scale = FALSE, center = F))[1:10, 1:10], FastRowScale(mat, scale = FALSE, center = F, display_progress = FALSE)) mat.clipped <- FastRowScale(mat, scale_max = 0.2, display_progress = F) expect_true(max(mat.clipped, na.rm = T) >= 0.2) }) # should be the equivalent of scale(mat, TRUE, apply(mat, 2, sd)) test_that("Standardize returns expected values", { expect_equal(Standardize(mat, display_progress = FALSE), scale(mat, TRUE, apply(mat, 2, sd)), check.attributes = FALSE) }) # should be the equivalent of t(scale(t(mat))) mat <- rsparsematrix(10, 15, 0.1) test_that("Fast implementation of row scaling returns expected values", { expect_equal(t(scale(t(as.matrix(mat))))[1:10, 1:15], FastSparseRowScale(mat, display_progress = FALSE), check.attributes = FALSE) expect_equal(t(scale(t(as.matrix(mat)), center = FALSE))[1:10, 1:15], FastSparseRowScale(mat, center = FALSE, display_progress = FALSE), check.attributes = FALSE) expect_equal(t(scale(t(as.matrix(mat)), scale = FALSE))[1:10, 1:15], FastSparseRowScale(mat, scale = FALSE, display_progress = FALSE), check.attributes = FALSE) expect_equal(t(scale(t(as.matrix(mat)), scale = FALSE, center = F))[1:10, 1:15], FastSparseRowScale(mat, scale = FALSE, center = F, display_progress = FALSE), check.attributes = FALSE) mat.clipped <- FastSparseRowScale(mat, scale_max = 0.2, display_progress = F) expect_true(max(mat.clipped, na.rm = T) >= 0.2) }) mat <- as(object = matrix(rnorm(1000), nrow = 10, ncol = 10), Class = "dgCMatrix") test_that("Row scaling with known stats works", { mat.rowmeans <- rowMeans(x = mat) mat.sd <- apply(X = mat, MARGIN = 1, FUN = sd) expect_equal( t(scale(t(as.matrix(mat)), center = mat.rowmeans, scale = mat.sd)), FastSparseRowScaleWithKnownStats(mat = mat, mu = mat.rowmeans, sigma = mat.sd, scale = TRUE, center = TRUE, scale_max = 10, display_progress = FALSE), check.attributes = FALSE ) expect_equal( t(scale(t(as.matrix(mat)), center = FALSE, scale = mat.sd)), FastSparseRowScaleWithKnownStats(mat = mat, mu = mat.rowmeans, sigma = mat.sd, scale = TRUE, center = FALSE, scale_max = 10, display_progress = FALSE), check.attributes = FALSE ) expect_equal( t(scale(t(as.matrix(mat)), center = mat.rowmeans, scale = FALSE)), FastSparseRowScaleWithKnownStats(mat = mat, mu = mat.rowmeans, sigma = mat.sd, scale = FALSE, center = TRUE, scale_max = 10, display_progress = FALSE), check.attributes = FALSE ) mat.clipped <- FastSparseRowScaleWithKnownStats(mat = mat, mu = mat.rowmeans, sigma = mat.sd, scale = FALSE, center = TRUE, scale_max = 0.2, display_progress = FALSE) expect_true(max(mat.clipped, na.rm = T) >= 0.2) }) # Tests for fast basic stats functions # -------------------------------------------------------------------------------- context("Fast Basic Stats Functions") set.seed(42) mat <- replicate(10, rchisq(10, 4)) fcv <- FastCov(mat) cv <- cov(mat) test_that("Fast implementation of covariance returns expected values", { expect_equal(fcv[1,1], 9.451051142) expect_equal(fcv[10,10], 5.6650068) expect_equal(fcv, cv) }) mat2 <- replicate(10, rchisq(10, 4)) fcv <- FastCovMats(mat1 = mat, mat2 = mat2) cv <- cov(mat, mat2) test_that("Fast implementation of covariance returns expected values for matrices", { expect_equal(fcv[1,1], 1.523417, tolerance = 1e-6) expect_equal(fcv[10,10], -0.6031694, tolerance = 1e-6) expect_equal(fcv, cv) }) merged.mat <- FastRBind(mat, fcv) test_that("Fast implementation of rbind returns expected values", { expect_equal(merged.mat, rbind(mat, fcv)) expect_equal(mat[1,1], merged.mat[1,1]) expect_equal(fcv[10,10], merged.mat[20,10]) }) mat <- as(mat, "dgCMatrix") test_that("Fast implementation of ExpMean returns expected values",{ expect_equal(ExpMean(mat[1,]), FastExpMean(mat, display_progress = F)[1]) expect_equal(ExpMean(mat[5,]), FastExpMean(mat, display_progress = F)[5]) expect_equal(ExpMean(mat[10,]), FastExpMean(mat, display_progress = F)[10]) expect_equal(length(FastExpMean(mat, display_progress = F)), nrow(mat)) expect_error(FastExpMean(mat[1, ], display_progress = F)) expect_equal(FastExpMean(mat[1, ,drop = F], display_progress = F), ExpMean(mat[1,])) expect_equal(FastExpMean(mat, display_progress = F)[1], 6.493418, tolerance = 1e-6) expect_equal(FastExpMean(mat, display_progress = F)[5], 6.255206, tolerance = 1e-6) expect_equal(FastExpMean(mat, display_progress = F)[10], 7.84965, tolerance = 1e-6) }) test_that("Fast implementation of LogVMR returns expected values", { expect_equal(LogVMR(mat[1,]), FastLogVMR(mat, display_progress = F)[1]) expect_equal(LogVMR(mat[5,]), FastLogVMR(mat, display_progress = F)[5]) expect_equal(LogVMR(mat[10,]), FastLogVMR(mat, display_progress = F)[10]) expect_equal(length(FastExpMean(mat, display_progress = F)), nrow(mat)) expect_error(FastLogVMR(mat[1, ], display_progress = F)) expect_equal(FastLogVMR(mat[1, ,drop = F], display_progress = F), LogVMR(mat[1,])) expect_equal(FastLogVMR(mat, display_progress = F)[1], 7.615384, tolerance = 1e-6) expect_equal(FastLogVMR(mat, display_progress = F)[5], 7.546768, tolerance = 1e-6) expect_equal(FastLogVMR(mat, display_progress = F)[10], 10.11755, tolerance = 1e-6) }) test_that("Row variance calculations for sparse matrices work", { expect_equal(apply(X = mat, MARGIN = 1, FUN = var), SparseRowVar(mat = mat, display_progress = FALSE), tolerance = 1e-6) expect_equal(apply(X = mat2, MARGIN = 1, FUN = var), SparseRowVar(mat = as(object = mat2, Class = "dgCMatrix"), display_progress = FALSE), tolerance = 1e-6) }) # Tests for data structure manipulations # -------------------------------------------------------------------------------- context("Data structure manipulations") mat <- rsparsematrix(nrow = 10, ncol = 100, density = 0.1) mat2 <- rsparsematrix(nrow = 10, ncol = 10, density = 0.1) cols.to.replace1 <- 1:10 cols.to.replace2 <- 10:1 cols.to.replace3 <- 91:100 cols.to.replace4 <- c(10, 15, 33, 2, 6, 99, 55, 30, 25, 42) ReplaceCols <- function(mat, cols, replace){ mat[, cols] <- replace return(mat) } test_that("Replacing columns works", { expect_equal(ReplaceColsC(mat = mat, col_idx = cols.to.replace1 - 1, replacement = mat2), ReplaceCols(mat = mat, cols = cols.to.replace1, replace = mat2)) expect_equal(ReplaceColsC(mat = mat, col_idx = cols.to.replace2 - 1, replacement = mat2), ReplaceCols(mat = mat, cols = cols.to.replace2, replace = mat2)) expect_equal(ReplaceColsC(mat = mat, col_idx = cols.to.replace3 - 1, replacement = mat2), ReplaceCols(mat = mat, cols = cols.to.replace3, replace = mat2)) expect_equal(ReplaceColsC(mat = mat, col_idx = cols.to.replace4 - 1, replacement = mat2), ReplaceCols(mat = mat, cols = cols.to.replace4, replace = mat2)) }) test_that("Cpp implementation of row variance is correct", { expect_equal(apply(X = mat, MARGIN = 1, FUN = var), RowVar(as.matrix(mat))) expect_equal(apply(X = merged.mat, MARGIN = 1, FUN = var), RowVar(as.matrix(merged.mat))) }) Seurat/tests/testthat/test_utilities.R0000644000176200001440000000173113602476667017737 0ustar liggesusersset.seed(42) pbmc.file <- system.file('extdata', 'pbmc_raw.txt', package = 'Seurat') pbmc.test <- as(as.matrix(read.table(pbmc.file, sep = "\t", row.names = 1)), "dgCMatrix") meta.data <- data.frame( a = rep(as.factor(c('a', 'b', 'c')), length.out = ncol(pbmc.test)), row.names = colnames(pbmc.test) ) object.filtered <- CreateSeuratObject( counts = pbmc.test, min.cells = 10, min.features = 30, meta.data = meta.data ) test_that("AverageExpression", { object <- SetIdent(object.filtered, value = 'a') average.expression <- AverageExpression(object, slot = 'data')$RNA expect_equivalent(average.expression['KHDRBS1', 1:3], c(a = 7.278237e-01, b = 1.658166e+14, c = 1.431902e-01), tolerance = 1e-6 ) expect_equivalent(average.expression['DNAJB1', 1:3] , c(a = 1.374079e+00, b = 5.100840e-01, c = 5.011655e-01), tolerance = 1e-6) }) Seurat/tests/testthat/test_objects.R0000644000176200001440000003077013527073365017354 0ustar liggesusers# Tests for functions in objects.R # Tests for interacting with the meta.data slot # ------------------------------------------------------------------------------ context("Metadata") cluster_letters <- LETTERS[Idents(object = pbmc_small)] names(cluster_letters) <- colnames(x = pbmc_small) cluster_letters_shuffled <- sample(x = cluster_letters) test_that("AddMetaData adds in cell-level vector properly ", { pbmc_small <- AddMetaData(object = pbmc_small, metadata = cluster_letters, col.name = 'letter.idents') expect_equal(pbmc_small$letter.idents, cluster_letters) pbmc_small <- AddMetaData(object = pbmc_small, metadata = cluster_letters_shuffled, col.name = 'letter.idents.shuffled') expect_equal(pbmc_small$letter.idents, pbmc_small$letter.idents.shuffled) }) cluster_letters_df <- data.frame(A = cluster_letters, B = cluster_letters_shuffled) test_that("AddMetaData adds in data frame properly for cell-level metadata", { pbmc_small <- AddMetaData(object = pbmc_small, metadata = cluster_letters_df) expect_equal(pbmc_small[[c("A", "B")]], cluster_letters_df) }) feature_letters <- sample(x = LETTERS, size = nrow(x = pbmc_small[["RNA"]]), replace = TRUE) names(feature_letters) <- rownames(x = pbmc_small[["RNA"]]) feature_letters_shuffled <- sample(x = feature_letters) test_that("AddMetaData adds feature level metadata", { pbmc_small[["RNA"]] <- AddMetaData(object = pbmc_small[["RNA"]], metadata = feature_letters, col.name = 'feature_letters') expect_equal(pbmc_small[["RNA"]][["feature_letters", drop = TRUE]], feature_letters) pbmc_small[["RNA"]] <- AddMetaData(object = pbmc_small[["RNA"]], metadata = feature_letters_shuffled, col.name = 'feature_letters_shuffled') expect_equal(pbmc_small[["RNA"]][["feature_letters", drop = TRUE]], pbmc_small[["RNA"]][["feature_letters_shuffled", drop = TRUE]]) }) feature_letters_df <- data.frame(A = feature_letters, B = feature_letters_shuffled) test_that("AddMetaData adds in data frame properly for Assays", { pbmc_small[["RNA"]] <- AddMetaData(object = pbmc_small[["RNA"]], metadata = feature_letters_df) expect_equal(pbmc_small[["RNA"]][[c("A", "B")]], feature_letters_df) }) test_that("AddMetaData errors", { expect_error(AddMetaData(object = pbmc_small, metadata = cluster_letters, col.name = "RNA")) expect_error(AddMetaData(object = pbmc_small, metadata = c(unname(cluster_letters), "A"), col.name = "letter.idents")) expect_error(AddMetaData(object = pbmc_small, metadata = feature_letters, col.name = "letter.idents")) expect_error(AddMetaData(object = pbmc_small[["RNA"]], metadata = cluster_letters, col.name = "letter.idents")) }) # Tests for creating an Assay object # ------------------------------------------------------------------------------ context("CreateAssayObject") pbmc.raw <- GetAssayData(object = pbmc_small[["RNA"]], slot = "counts") rna.assay <- CreateAssayObject(counts = pbmc.raw) rna.assay2 <- CreateAssayObject(data = pbmc.raw) test_that("CreateAssayObject works as expected", { expect_equal(dim(x = rna.assay), c(230, 80)) expect_equal(rownames(x = rna.assay), rownames(x = pbmc.raw)) expect_equal(colnames(x = rna.assay), colnames(x = pbmc.raw)) expect_equal(GetAssayData(object = rna.assay, slot = "counts"), pbmc.raw) expect_equal(GetAssayData(object = rna.assay, slot = "data"), pbmc.raw) expect_equal(GetAssayData(object = rna.assay, slot = "scale.data"), new(Class = "matrix")) expect_equal(dim(rna.assay[[]]), c(230, 0)) expect_equal(rownames(x = rna.assay[[]]), rownames(x = rna.assay)) expect_equal(VariableFeatures(object = rna.assay), vector()) expect_equal(rna.assay@misc, NULL) expect_equal(GetAssayData(object = rna.assay2, slot = "counts"), new(Class = "matrix")) }) rna.assay2 <- CreateAssayObject(counts = pbmc.raw, min.cells = 10, min.features = 30) test_that("CreateAssayObject filtering works", { expect_equal(dim(x = rna.assay2), c(163, 77)) expect_true(all(rowSums(GetAssayData(object = rna.assay2, slot = "counts")) >= 10)) expect_true(all(colSums(GetAssayData(object = rna.assay2, slot = "counts")) >= 30)) }) test_that("CreateAssayObject catches improper input", { expect_error(CreateAssayObject()) expect_error(CreateAssayObject(counts = pbmc.raw, data = pbmc.raw)) pbmc.raw2 <- cbind(pbmc.raw[, 1:10], pbmc.raw[, 1:10]) expect_warning(CreateAssayObject(counts = pbmc.raw2)) expect_warning(CreateAssayObject(data = pbmc.raw2)) pbmc.raw2 <- rbind(pbmc.raw[1:10, ], pbmc.raw[1:10, ]) expect_warning(CreateAssayObject(counts = pbmc.raw2)) expect_warning(CreateAssayObject(data = pbmc.raw2)) pbmc.raw2 <- pbmc.raw colnames(x = pbmc.raw2) <- c() expect_error(CreateAssayObject(counts = pbmc.raw2)) expect_error(CreateAssayObject(data = pbmc.raw2)) pbmc.raw2 <- pbmc.raw rownames(x = pbmc.raw2) <- c() expect_error(CreateAssayObject(counts = pbmc.raw2)) expect_error(CreateAssayObject(data = pbmc.raw2)) pbmc.raw.mat <- as.matrix(x = pbmc.raw) pbmc.raw.df <- as.data.frame(x = pbmc.raw.mat) rna.assay3 <- CreateAssayObject(counts = pbmc.raw.df) rna.assay4 <- CreateAssayObject(counts = pbmc.raw.mat) expect_is(object = GetAssayData(object = rna.assay3, slot = "counts"), class = "dgCMatrix") expect_is(object = GetAssayData(object = rna.assay4, slot = "counts"), class = "dgCMatrix") pbmc.raw.underscores <- pbmc.raw rownames(pbmc.raw.underscores) <- gsub(pattern = "-", replacement = "_", x = rownames(pbmc.raw.underscores)) expect_warning(CreateAssayObject(counts = pbmc.raw.underscores)) }) # Tests for creating an DimReduc object # ------------------------------------------------------------------------------ context("CreateDimReducObject") pca <- pbmc_small[["pca"]] Key(object = pca) <- 'PC_' test_that("CreateDimReducObject works", { pca.dr <- CreateDimReducObject( embeddings = Embeddings(object = pca), loadings = Loadings(object = pca), projected = Loadings(object = pca, projected = TRUE), assay = "RNA" ) expect_equal(Embeddings(object = pca.dr), Embeddings(object = pca)) expect_equal(Loadings(object = pca.dr), Loadings(object = pca)) expect_equal(Loadings(object = pca.dr, projected = TRUE), Loadings(object = pca, projected = TRUE)) expect_equal(Key(object = pca.dr), "PC_") expect_equal(pca.dr@assay.used, "RNA") }) test_that("CreateDimReducObject catches improper input", { bad.embeddings <- Embeddings(object = pca) colnames(x = bad.embeddings) <- paste0("PCA", 1:ncol(x = bad.embeddings)) expect_warning(CreateDimReducObject(embeddings = bad.embeddings, key = "PC")) colnames(x = bad.embeddings) <- paste0("PC", 1:ncol(x = bad.embeddings), "X") suppressWarnings(expect_error(CreateDimReducObject(embeddings = bad.embeddings, key = "PC"))) suppressWarnings(expect_error(CreateDimReducObject(embeddings = bad.embeddings))) }) # Tests for creating a Seurat object # ------------------------------------------------------------------------------ context("CreateSeuratObject") colnames(x = pbmc.raw) <- paste0(colnames(x = pbmc.raw), "-", pbmc_small$groups) metadata.test <- pbmc_small[[]][, 5:7] rownames(x = metadata.test) <- colnames(x = pbmc.raw) test_that("CreateSeuratObject works", { seurat.object <- CreateSeuratObject( counts = pbmc.raw, project = "TESTING", assay = "RNA.TEST", names.field = 2, names.delim = "-", meta.data = metadata.test ) expect_equal(seurat.object[[]][, 4:6], metadata.test) expect_equal(seurat.object@project.name, "TESTING") expect_equal(names(x = seurat.object), "RNA.TEST") expect_equal(as.vector(x = unname(obj = Idents(object = seurat.object))), unname(pbmc_small$groups)) }) test_that("CreateSeuratObject handles bad names.field/names.delim", { expect_warning(seurat.object <- CreateSeuratObject( counts = pbmc.raw[1:5,1:5], names.field = 3, names.delim = ":", meta.data = metadata.test )) }) # Tests for creating a Seurat object # ------------------------------------------------------------------------------ context("Merging") pbmc.assay <- pbmc_small[["RNA"]] x <- merge(x = pbmc.assay, y = pbmc.assay) test_that("Merging Assays works properly", { expect_equal(dim(GetAssayData(object = x, slot = "counts")), c(230, 160)) expect_equal(dim(GetAssayData(object = x, slot = "data")), c(230, 160)) expect_equal(GetAssayData(object = x, slot = "scale.data"), new(Class = "matrix")) expect_equal(Key(object = x), "rna_") expect_equal(VariableFeatures(object = x), vector()) expect_equal(x[[]], data.frame(row.names = rownames(x = pbmc.assay))) }) pbmc.assay2 <- pbmc.assay pbmc.assay2@counts <- new("dgCMatrix") test_that("Merging Assays handles case when counts not present", { y <- merge(x = pbmc.assay2, y = pbmc.assay) expect_equal(unname(colSums(x = GetAssayData(object = y, slot = "counts"))[1:80]), rep.int(x = 0, times = 80)) z <- merge(x = pbmc.assay2, pbmc.assay2) expect_equal(nnzero(x = GetAssayData(object = z, slot = "counts")), 0) }) pbmc.assay2 <- pbmc.assay pbmc.assay2@data <- new("dgCMatrix") test_that("Merging Assays handles case when data not present", { y <- merge(x = pbmc.assay2, y = pbmc.assay, merge.data = TRUE) expect_equal(unname(colSums(x = GetAssayData(object = y, slot = "data"))[1:80]), rep.int(x = 0, times = 80)) z <- merge(x = pbmc.assay2, y = pbmc.assay2, merge.data = TRUE) expect_equal(nnzero(x = GetAssayData(object = z, slot = "data")), 0) }) # Tests for FetchData # ------------------------------------------------------------------------------ context("FetchData") # Features to test: # able to pull cell embeddings, data, metadata # subset of cells test_that("Fetching a subset of cells works", { x <- FetchData(object = pbmc_small, cells = colnames(x = pbmc_small)[1:10], vars = rownames(x = pbmc_small)[1]) expect_equal(rownames(x = x), colnames(x = pbmc_small)[1:10]) random.cells <- sample(x = colnames(x = pbmc_small), size = 10) x <- FetchData(object = pbmc_small, cells = random.cells, vars = rownames(x = pbmc_small)[1]) expect_equal(rownames(x = x), random.cells) x <- FetchData(object = pbmc_small, cells = 1:10, vars = rownames(x = pbmc_small)[1]) expect_equal(rownames(x = x), colnames(x = pbmc_small)[1:10]) }) suppressWarnings(pbmc_small[["RNA2"]] <- pbmc_small[["RNA"]]) Key(pbmc_small[["RNA2"]]) <- "rna2_" test_that("Fetching keyed variables works", { x <- FetchData(object = pbmc_small, vars = c(paste0("rna_", rownames(x = pbmc_small)[1:5]), paste0("rna2_", rownames(x = pbmc_small)[1:5]))) expect_equal(colnames(x = x), c(paste0("rna_", rownames(x = pbmc_small)[1:5]), paste0("rna2_", rownames(x = pbmc_small)[1:5]))) x <- FetchData(object = pbmc_small, vars = c(paste0("rna_", rownames(x = pbmc_small)[1:5]), paste0("PC_", 1:5))) expect_equal(colnames(x = x), c(paste0("rna_", rownames(x = pbmc_small)[1:5]), paste0("PC_", 1:5))) }) test_that("Fetching embeddings/loadings not present returns warning or errors", { expect_warning(FetchData(object = pbmc_small, vars = c("PC_1", "PC_100"))) expect_error(FetchData(object = pbmc_small, vars = "PC_100")) }) bad.gene <- GetAssayData(object = pbmc_small[["RNA"]], slot = "data") rownames(x = bad.gene)[1] <- paste0("rna_", rownames(x = bad.gene)[1]) pbmc_small[["RNA"]]@data <- bad.gene # Tests for WhichCells # ------------------------------------------------------------------------------ test_that("Specifying cells works", { test.cells <- Cells(x = pbmc_small)[1:10] expect_equal(WhichCells(object = pbmc_small, cells = test.cells), test.cells) expect_equal(WhichCells(object = pbmc_small, cells = test.cells, invert = TRUE), setdiff(Cells(x = pbmc_small), test.cells)) }) test_that("Specifying idents works", { c12 <- WhichCells(object = pbmc_small, idents = c(1, 2)) expect_equal(length(x = c12), 44) expect_equal(c12[44], "CTTGATTGATCTTC") expect_equal(c12, WhichCells(object = pbmc_small, idents = 0, invert = TRUE)) }) test_that("downsample works", { expect_equal(length(x = WhichCells(object = pbmc_small, downsample = 5)), 15) expect_equal(length(x = WhichCells(object = pbmc_small, downsample = 100)), 80) }) test_that("passing an expression works", { lyz.pos <- WhichCells(object = pbmc_small, expression = LYZ > 1) expect_true(all(GetAssayData(object = pbmc_small, slot = "data")["LYZ", lyz.pos] > 1)) # multiple values in expression lyz.pos <- WhichCells(object = pbmc_small, expression = LYZ > 1 & groups == "g1") expect_equal(length(x = lyz.pos), 30) expect_equal(lyz.pos[30], "CTTGATTGATCTTC") }) Seurat/tests/testthat/test_preprocessing.R0000644000176200001440000004224413527073365020605 0ustar liggesusers# Tests for functions dependent on a seurat object set.seed(42) pbmc.file <- system.file('extdata', 'pbmc_raw.txt', package = 'Seurat') pbmc.test <- as(as.matrix(read.table(pbmc.file, sep = "\t", row.names = 1)), "dgCMatrix") # Tests for object creation (via CreateSeuratObject) # -------------------------------------------------------------------------------- context("Object creation") fake.meta.data <- data.frame(rep(1, ncol(pbmc.test))) rownames(fake.meta.data) <- colnames(pbmc.test) colnames(fake.meta.data) <- "FMD" object <- CreateSeuratObject(counts = pbmc.test, meta.data = fake.meta.data) test_that("object initialization actually creates seurat object", { expect_is(object, "Seurat") }) test_that("meta.data slot generated correctly", { expect_equal(dim(object[[]]), c(80, 4)) expect_equal(colnames(object[[]]), c("orig.ident", "nCount_RNA", "nFeature_RNA", "FMD")) expect_equal(rownames(object[[]]), colnames(object)) expect_equal(object[["nFeature_RNA"]][1:5, ], c(47, 52, 50, 56, 53)) expect_equal(object[["nCount_RNA"]][75:80, ], c(228, 527, 202, 157, 150, 233)) }) object.filtered <- CreateSeuratObject( counts = pbmc.test, min.cells = 10, min.features = 30 ) test_that("Filtering handled properly", { expect_equal(nrow(x = GetAssayData(object = object.filtered, slot = "counts")), 163) expect_equal(ncol(x = GetAssayData(object = object.filtered, slot = "counts")), 77) }) test_that("Metadata check errors correctly", { pbmc.md <- pbmc_small[[]] pbmc.md.norownames <- as.matrix(pbmc.md) rownames(pbmc.md.norownames) <- NULL expect_error(CreateSeuratObject(counts = pbmc.test, meta.data = pbmc.md.norownames), "Row names not set in metadata. Please ensure that rownames of metadata match column names of data matrix") }) # Tests for NormalizeData # -------------------------------------------------------------------------------- context("NormalizeData") test_that("NormalizeData error handling", { expect_error(NormalizeData(object = object, assay = "FAKE")) expect_equal( object = GetAssayData( object = NormalizeData( object = object, normalization.method = NULL, verbose = FALSE ), slot = "data" ), expected = GetAssayData(object = object, slot = "counts") ) }) object <- NormalizeData(object = object, verbose = FALSE, scale.factor = 1e6) test_that("NormalizeData scales properly", { expect_equal(GetAssayData(object = object, slot = "data")[2, 1], 9.567085, tolerance = 1e-6) expect_equal(GetAssayData(object = object, slot = "data")[161, 55], 8.415309, tolerance = 1e-6) expect_equal(Command(object = object, command = "NormalizeData.RNA", value = "scale.factor"), 1e6) expect_equal(Command(object = object, command = "NormalizeData.RNA", value = "normalization.method"), "LogNormalize") }) normalized.data <- LogNormalize(data = GetAssayData(object = object[["RNA"]], slot = "counts"), verbose = FALSE) test_that("LogNormalize normalizes properly", { expect_equal( LogNormalize(data = GetAssayData(object = object[["RNA"]], slot = "counts"), verbose = FALSE), LogNormalize(data = as.data.frame(as.matrix(GetAssayData(object = object[["RNA"]], slot = "counts"))), verbose = FALSE) ) }) clr.counts <- NormalizeData(object = pbmc.test, normalization.method = "CLR", verbose = FALSE) test_that("CLR normalization returns expected values", { expect_equal(dim(clr.counts), c(dim(pbmc.test))) expect_equal(clr.counts[2, 1], 0.5517828, tolerance = 1e-6) expect_equal(clr.counts[228, 76], 0.5971381, tolerance = 1e-6) expect_equal(clr.counts[230, 80], 0) }) rc.counts <- NormalizeData(object = pbmc.test, normalization.method = "RC", verbose = FALSE) test_that("Relative count normalization returns expected values", { expect_equal(rc.counts[2, 1], 142.8571, tolerance = 1e-6) expect_equal(rc.counts[228, 76], 18.97533, tolerance = 1e-6) expect_equal(rc.counts[230, 80], 0) rc.counts <- NormalizeData(object = pbmc.test, normalization.method = "RC", verbose = FALSE, scale.factor = 1e6) expect_equal(rc.counts[2, 1], 14285.71, tolerance = 1e-6) }) # Tests for ScaleData # -------------------------------------------------------------------------------- context("ScaleData") object <- ScaleData(object, verbose = FALSE) test_that("ScaleData returns expected values when input is a sparse matrix", { expect_equal(GetAssayData(object = object[["RNA"]], slot = "scale.data")[1, 1], -0.4148587, tolerance = 1e-6) expect_equal(GetAssayData(object = object[["RNA"]], slot = "scale.data")[75, 25], -0.2562305, tolerance = 1e-6) expect_equal(GetAssayData(object = object[["RNA"]], slot = "scale.data")[162, 59], -0.4363939, tolerance = 1e-6) }) new.data <- as.matrix(GetAssayData(object = object[["RNA"]], slot = "data")) new.data[1, ] <- rep(x = 0, times = ncol(x = new.data)) object2 <- object object2[["RNA"]] <- SetAssayData( object = object[["RNA"]], slot = "data", new.data = new.data ) object2 <- ScaleData(object = object2, verbose = FALSE) object <- ScaleData(object = object, verbose = FALSE) test_that("ScaleData returns expected values when input is not sparse", { expect_equal(GetAssayData(object = object[["RNA"]], slot = "scale.data")[75, 25], -0.2562305, tolerance = 1e-6) expect_equal(GetAssayData(object = object[["RNA"]], slot = "scale.data")[162, 59], -0.4363939, tolerance = 1e-6) }) test_that("ScaleData handles zero variance features properly", { expect_equal(GetAssayData(object = object2[["RNA"]], slot = "scale.data")[1, 1], 0) expect_equal(GetAssayData(object = object2[["RNA"]], slot = "scale.data")[1, 80], 0) }) ng1 <- rep(x = "g1", times = round(x = ncol(x = object) / 2)) object$group <- c(ng1, rep(x = "g2", times = ncol(x = object) - length(x = ng1))) g1 <- subset(x = object, group == "g1") g1 <- ScaleData(object = g1, features = rownames(x = g1), verbose = FALSE) g2 <- subset(x = object, group == "g2") g2 <- ScaleData(object = g2, features = rownames(x = g2), verbose = FALSE) object <- ScaleData(object = object, features = rownames(x = object), verbose = FALSE, split.by = "group") test_that("split.by option works", { expect_equal(GetAssayData(object = object, slot = "scale.data")[, Cells(x = g1)], GetAssayData(object = g1, slot = "scale.data")) expect_equal(GetAssayData(object = object, slot = "scale.data")[, Cells(x = g2)], GetAssayData(object = g2, slot = "scale.data")) }) g1 <- ScaleData(object = g1, features = rownames(x = g1), vars.to.regress = "nCount_RNA", verbose = FALSE) g2 <- ScaleData(object = g2, features = rownames(x = g2), vars.to.regress = "nCount_RNA", verbose = FALSE) object <- ScaleData(object = object, features = rownames(x = object), verbose = FALSE, split.by = "group", vars.to.regress = "nCount_RNA") test_that("split.by option works with regression", { expect_equal(GetAssayData(object = object, slot = "scale.data")[, Cells(x = g1)], GetAssayData(object = g1, slot = "scale.data")) expect_equal(GetAssayData(object = object, slot = "scale.data")[, Cells(x = g2)], GetAssayData(object = g2, slot = "scale.data")) }) # Tests for various regression techniques context("Regression") object <- ScaleData( object = object, vars.to.regress = "nCount_RNA", features = rownames(x = object)[1:10], verbose = FALSE, model.use = "linear") test_that("Linear regression works as expected", { expect_equal(dim(x = GetAssayData(object = object[["RNA"]], slot = "scale.data")), c(10, 80)) expect_equal(GetAssayData(object = object[["RNA"]], slot = "scale.data")[1, 1], -0.6436435, tolerance = 1e-6) expect_equal(GetAssayData(object = object[["RNA"]], slot = "scale.data")[5, 25], -0.09035383, tolerance = 1e-6) expect_equal(GetAssayData(object = object[["RNA"]], slot = "scale.data")[10, 80], -0.2723782, tolerance = 1e-6) }) object <- ScaleData( object, vars.to.regress = "nCount_RNA", features = rownames(x = object)[1:10], verbose = FALSE, model.use = "negbinom") test_that("Negative binomial regression works as expected", { expect_equal(dim(x = GetAssayData(object = object[["RNA"]], slot = "scale.data")), c(10, 80)) expect_equal(GetAssayData(object = object[["RNA"]], slot = "scale.data")[1, 1], -0.5888811, tolerance = 1e-6) expect_equal(GetAssayData(object = object[["RNA"]], slot = "scale.data")[5, 25], -0.2553394, tolerance = 1e-6) expect_equal(GetAssayData(object = object[["RNA"]], slot = "scale.data")[10, 80], -0.1921429, tolerance = 1e-6) }) test_that("Regression error handling checks out", { expect_error(ScaleData(object, vars.to.regress = "nCount_RNA", model.use = "not.a.model", verbose = FALSE)) }) object <- ScaleData( object, vars.to.regress = "nCount_RNA", features = rownames(x = object)[1:10], verbose = FALSE, model.use = "poisson") test_that("Poisson regression works as expected", { expect_equal(dim(x = GetAssayData(object = object[["RNA"]], slot = "scale.data")), c(10, 80)) expect_equal(GetAssayData(object = object[["RNA"]], slot = "scale.data")[1, 1], -1.011717, tolerance = 1e-6) expect_equal(GetAssayData(object = object[["RNA"]], slot = "scale.data")[5, 25], 0.05575307, tolerance = 1e-6) expect_equal(GetAssayData(object = object[["RNA"]], slot = "scale.data")[10, 80], -0.1662119, tolerance = 1e-6) }) #Tests for SampleUMI #-------------------------------------------------------------------------------- context("SampleUMI") downsampled.umis <- SampleUMI( data = GetAssayData(object = object, slot = "counts"), max.umi = 100, verbose = FALSE ) downsampled.umis.p.cell <- SampleUMI( data = GetAssayData(object = object, slot = "counts"), max.umi = seq(50, 840, 10), verbose = FALSE, upsample = TRUE ) test_that("SampleUMI gives reasonable downsampled/upsampled UMI counts", { expect_true(!any(colSums(x = downsampled.umis) < 30, colSums(x = downsampled.umis) > 120)) expect_error(SampleUMI(data = GetAssayData(object = object, slot = "raw.data"), max.umi = rep(1, 5))) expect_true(!is.unsorted(x = colSums(x = downsampled.umis.p.cell))) expect_error(SampleUMI( data = GetAssayData(object = object, slot = "counts"), max.umi = seq(50, 900, 10), verbose = FALSE, upsample = TRUE )) }) # Tests for FindVariableFeatures # -------------------------------------------------------------------------------- context("FindVariableFeatures") object <- FindVariableFeatures(object = object, selection.method = "mean.var.plot", verbose = FALSE) test_that("mean.var.plot selection option returns expected values", { expect_equal(VariableFeatures(object = object)[1:4], c("PTGDR", "SATB1", "ZNF330", "S100B")) expect_equal(length(x = VariableFeatures(object = object)), 20) expect_equal(HVFInfo(object = object[["RNA"]], selection.method = 'mvp')$mean[1:2], c(8.328927, 8.444462), tolerance = 1e6) expect_equal(HVFInfo(object = object[["RNA"]], selection.method = 'mvp')$dispersion[1:2], c(10.552507, 10.088223), tolerance = 1e6) expect_equal(as.numeric(HVFInfo(object = object[["RNA"]], selection.method = 'mvp')$dispersion.scaled[1:2]), c(0.1113214, -0.1113214), tolerance = 1e6) }) object <- FindVariableFeatures(object, selection.method = "dispersion", verbose = FALSE) test_that("dispersion selection option returns expected values", { expect_equal(VariableFeatures(object = object)[1:4], c("PCMT1", "PPBP", "LYAR", "VDAC3")) expect_equal(length(x = VariableFeatures(object = object)), 230) expect_equal(HVFInfo(object = object[["RNA"]], selection.method = 'mvp')$mean[1:2], c(8.328927, 8.444462), tolerance = 1e6) expect_equal(HVFInfo(object = object[["RNA"]], selection.method = 'mvp')$dispersion[1:2], c(10.552507, 10.088223), tolerance = 1e6) expect_equal(as.numeric(HVFInfo(object = object[["RNA"]], selection.method = 'mvp')$dispersion.scaled[1:2]), c(0.1113214, -0.1113214), tolerance = 1e6) expect_true(!is.unsorted(rev(HVFInfo(object = object[["RNA"]], selection.method = 'mvp')[VariableFeatures(object = object), "dispersion"]))) }) object <- FindVariableFeatures(object, selection.method = "vst", verbose = FALSE) test_that("vst selection option returns expected values", { expect_equal(VariableFeatures(object = object)[1:4], c("PPBP", "IGLL5", "VDAC3", "CD1C")) expect_equal(length(x = VariableFeatures(object = object)), 230) expect_equal(unname(object[["RNA"]][["vst.variance", drop = TRUE]][1:2]), c(1.0251582, 1.2810127), tolerance = 1e6) expect_equal(unname(object[["RNA"]][["vst.variance.expected", drop = TRUE]][1:2]), c(1.1411616, 2.7076228), tolerance = 1e6) expect_equal(unname(object[["RNA"]][["vst.variance.standardized", drop = TRUE]][1:2]), c(0.8983463, 0.4731134), tolerance = 1e6) expect_true(!is.unsorted(rev(object[["RNA"]][["vst.variance.standardized", drop = TRUE]][VariableFeatures(object = object)]))) }) # Tests for internal functions # ------------------------------------------------------------------------------ norm.fxn <- function(x) {x / mean(x)} test_that("CustomNormalize works as expected", { expect_equal( CustomNormalize(data = pbmc.test, custom_function = norm.fxn, margin = 2), apply(X = pbmc.test, MARGIN = 2, FUN = norm.fxn) ) expect_equal( CustomNormalize(data = as.matrix(pbmc.test), custom_function = norm.fxn, margin = 2), apply(X = pbmc.test, MARGIN = 2, FUN = norm.fxn) ) expect_equal( CustomNormalize(data = as.data.frame(as.matrix(pbmc.test)), custom_function = norm.fxn, margin = 2), apply(X = pbmc.test, MARGIN = 2, FUN = norm.fxn) ) expect_equal( CustomNormalize(data = pbmc.test, custom_function = norm.fxn, margin = 1), t(apply(X = pbmc.test, MARGIN = 1, FUN = norm.fxn)) ) expect_error(CustomNormalize(data = pbmc.test, custom_function = norm.fxn, margin = 10)) }) # Tests for SCTransform # ------------------------------------------------------------------------------ object <- suppressWarnings(SCTransform(object = object, verbose = FALSE)) test_that("SCTransform wrapper works as expected", { expect_true("SCT" %in% names(object)) expect_equal(as.numeric(colSums(GetAssayData(object = object[["SCT"]], slot = "scale.data"))[1]), 13.33038640) expect_equal(as.numeric(rowSums(GetAssayData(object = object[["SCT"]], slot = "scale.data"))[5]), 0) expect_equal(as.numeric(colSums(GetAssayData(object = object[["SCT"]], slot = "data"))[1]), 55.29678, tolerance = 1e6) expect_equal(as.numeric(rowSums(GetAssayData(object = object[["SCT"]], slot = "data"))[5]), 11.74404, tolerance = 1e6) expect_equal(as.numeric(colSums(GetAssayData(object = object[["SCT"]], slot = "counts"))[1]), 123) expect_equal(as.numeric(rowSums(GetAssayData(object = object[["SCT"]], slot = "counts"))[5]), 28) expect_equal(length(VariableFeatures(object[["SCT"]])), 220) expect_equal(object[["SCT"]][[]]["MS4A1", "sct.detection_rate"], 0.15) expect_equal(object[["SCT"]][[]]["MS4A1", "sct.gmean"], 0.2027364, tolerance = 1e6) expect_equal(object[["SCT"]][[]]["MS4A1", "sct.variance"], 1.025158, tolerance = 1e6) expect_equal(object[["SCT"]][[]]["MS4A1", "sct.residual_mean"], 0.2512783, tolerance = 1e6) expect_equal(object[["SCT"]][[]]["MS4A1", "sct.residual_variance"], 3.551259, tolerance = 1e6) }) object <- suppressWarnings(SCTransform(object = object, ncells = 40, verbose = FALSE)) test_that("SCTransform ncells param works", { expect_true("SCT" %in% names(object)) expect_equal(as.numeric(colSums(GetAssayData(object = object[["SCT"]], slot = "scale.data"))[1]), 11.834969847) expect_equal(as.numeric(rowSums(GetAssayData(object = object[["SCT"]], slot = "scale.data"))[5]), 0) expect_equal(as.numeric(colSums(GetAssayData(object = object[["SCT"]], slot = "data"))[1]), 55.29678, tolerance = 1e6) expect_equal(as.numeric(rowSums(GetAssayData(object = object[["SCT"]], slot = "data"))[5]), 11.74404, tolerance = 1e6) expect_equal(as.numeric(colSums(GetAssayData(object = object[["SCT"]], slot = "counts"))[1]), 121) expect_equal(as.numeric(rowSums(GetAssayData(object = object[["SCT"]], slot = "counts"))[5]), 25) expect_equal(length(VariableFeatures(object[["SCT"]])), 220) expect_equal(object[["SCT"]][[]]["MS4A1", "sct.detection_rate"], 0.15) expect_equal(object[["SCT"]][[]]["MS4A1", "sct.gmean"], 0.2027364, tolerance = 1e6) expect_equal(object[["SCT"]][[]]["MS4A1", "sct.variance"], 1.025158, tolerance = 1e6) expect_equal(object[["SCT"]][[]]["MS4A1", "sct.residual_mean"], 0.2512783, tolerance = 1e6) expect_equal(object[["SCT"]][[]]["MS4A1", "sct.residual_variance"], 3.551259, tolerance = 1e6) }) suppressWarnings(object[["SCT_SAVE"]] <- object[["SCT"]]) object[["SCT"]] <- SetAssayData(object = object[["SCT"]], slot = "scale.data", new.data = GetAssayData(object = object[["SCT"]], slot = "scale.data")[1:100, ]) object <- GetResidual(object = object, features = rownames(x = object), verbose = FALSE) test_that("GetResidual works", { expect_equal(dim(GetAssayData(object = object[["SCT"]], slot = "scale.data")), c(220, 80)) expect_equal( GetAssayData(object = object[["SCT"]], slot = "scale.data"), GetAssayData(object = object[["SCT_SAVE"]], slot = "scale.data") ) expect_warning(GetResidual(object, features = "asd")) }) Seurat/tests/testthat/test_visualization.R0000644000176200001440000000163013602476667020623 0ustar liggesusers# Tests for functions in visualization.R set.seed(42) # Tests for visualization utilities # ------------------------------------------------------------------------------ pbmc_small[["tsne_new"]] <- CollapseEmbeddingOutliers(pbmc_small, reduction = "tsne", reduction.key = 'tsne_', outlier.sd = 0.5) test_that("CollapseEmbeddingOutliers works", { expect_equal(Embeddings(pbmc_small[["tsne_new"]])[1, 1], -12.59713, tolerance = 1e-6) expect_equal(colSums(x = Embeddings(object = pbmc_small[["tsne_new"]])), c(-219.9218, 182.9215), check.attributes = FALSE, tolerance = 1e-5) }) test_that("DiscretePalette works", { isColors <- function(x) { all(grepl("#[0-9A-Fa-f]{6}", x)) } expect_true(isColors(DiscretePalette(26))) expect_true(isColors(DiscretePalette(32))) expect_true(isColors(DiscretePalette(36))) expect_warning(DiscretePalette(50), "Not enough colours") }) Seurat/tests/testthat/test_modularity_optimizer.R0000644000176200001440000001141713527073365022213 0ustar liggesusers# Tests to verify the RCpp version of ModularityOptimizer produces the same # results as the java version. # Equivalent java commands are given above. context("ModularityOptimizer") # The "karate club" network available from the ModularityOptimizer website at: # http://www.ludowaltman.nl/slm/ node1 <- c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 4, 4, 5, 5, 5, 6, 8, 8, 8, 9, 13, 14, 14, 15, 15, 18, 18, 19, 20, 20, 22, 22, 23, 23, 23, 23, 23, 24, 24, 24, 25, 26, 26, 27, 28, 28, 29, 29, 30, 30, 31, 31, 32) node2 <- c(1, 2, 3, 4, 5, 6, 7, 8, 10, 11, 12, 13, 17, 19, 21, 31, 2, 3, 7, 13, 17, 19, 21, 30, 3, 7, 8, 9, 13, 27, 28, 32, 7, 12, 13, 6, 10, 6, 10, 16, 16, 30, 32, 33, 33, 33, 32, 33, 32, 33, 32, 33, 33, 32, 33, 32, 33, 25, 27, 29, 32, 33, 25, 27, 31, 31, 29, 33, 33, 31, 33, 32, 33, 32, 33, 32, 33, 33) dim_s <- max(max(node1), max(node2)) + 1 # Note we want to represent network in the lower diagonal. connections <- sparseMatrix(i = node2 + 1, j = node1 + 1, x = 1.0) # Result from equivalent command to # java -jar ModularityOptimizer.jar karate_club_network.txt communities.txt 1 1.0 1 1 1 564 0 test_that("Algorithm 1", { expected <- c(1, 1, 1, 1, 2, 2, 2, 1, 0, 1, 2, 1, 1, 1, 0, 0, 2, 1, 0, 1, 0, 1, 0, 0, 3, 3, 0, 0, 3, 0, 0, 3, 0, 0) s <- Seurat:::RunModularityClusteringCpp( SNN = connections, modularityFunction = 1, resolution = 1.0, algorithm = 1, nRandomStarts = 1, nIterations = 1, randomSeed = 564, printOutput = 0, "" ) expect_equal(expected, s) }) #java -jar ModularityOptimizer.jar karate_club_network.txt communities.txt 1 1.0 2 1 1 2 0 test_that("Algorithm 2", { expected <- c(1, 1, 1, 1, 3, 3, 3, 1, 0, 0, 3, 1, 1, 1, 0, 0, 3, 1, 0, 1, 0, 1, 0, 2, 2, 2, 0, 2, 2, 0, 0, 2, 0, 0) s <- Seurat:::RunModularityClusteringCpp( SNN = connections, modularityFunction = 1, resolution = 1.0, algorithm = 2, nRandomStarts = 1, nIterations = 1, randomSeed = 2, printOutput = 0, "" ) expect_equal(expected, s) }) #java -jar ModularityOptimizer.jar karate_club_network.txt communities.txt 1 1.0 3 1 1 56464 0 test_that("Algorithm 3", { expected <- c(1, 1, 1, 1, 3, 3, 3, 1, 0, 0, 3, 1, 1, 1, 0, 0, 3, 1, 0, 1, 0, 1, 0, 2, 2, 2, 0, 2, 2, 0, 0, 2, 0, 0) s <- Seurat:::RunModularityClusteringCpp( SNN = connections, modularityFunction = 1, resolution = 1.0, algorithm = 3, nRandomStarts = 1, nIterations = 1, randomSeed = 56464, printOutput = 0, "") expect_equal(expected, s) }) test_that("Low Resolution", { e1 <- rep(0, 34) # java -jar ModularityOptimizer.jar karate_club_network.txt outjava.txt 1 0.05 3 1 10 10 0 s <- Seurat:::RunModularityClusteringCpp( SNN = connections, modularityFunction = 1, resolution = 0.05, algorithm = 3, nRandomStarts = 1, nIterations = 10, randomSeed = 10, printOutput = 0, "" ) expect_equal(s, e1) # java -jar ModularityOptimizer.jar karate_club_network.txt outjava.txt 2 0.05 3 1 10 10 0 s2 <- Seurat:::RunModularityClusteringCpp( SNN = connections, modularityFunction = 2, resolution=0.05, algorithm = 3, nRandomStarts = 1, nIterations = 10, randomSeed = 10, printOutput = 0, "" ) e2 = c(0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 1, 0, 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1) expect_equal(s2, e2) }) test_that("EdgeWeights", { # Make 1, 4, 5 and 20 a community by weighting them c2 <- connections c2[5, 4] <- 3.0 c2[5, 1] <- 5.0 c2[4, 1] <- 8.0 c2[20, 5] <- 8.0 c2[20, 4] <- 5.0 c2[20, 1] <- 5.0 # java -jar ModularityOptimizer.jar weighted_karate_club_network.txt outjava.txt 1 1.0 3 1 10 40 1 s2 <- Seurat:::RunModularityClusteringCpp( SNN = c2, modularityFunction = 1, resolution = 1.0, algorithm = 3, nRandomStarts = 1, nIterations = 10, randomSeed = 40, printOutput = 0, "" ) exp <- c(2, 1, 1, 2, 2, 3, 3, 1, 0, 1, 3, 2, 2, 1, 0, 0, 3, 1, 0, 2, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0) expect_equal(s2, exp) }) # test_that("pbmc_small network", { # observed <- as.numeric(FindClusters( # object = pbmc_small, # reduction.type = "pca", # dims.use = 1:10, # resolution = 1.1, # save.SNN = TRUE, # print.output = 0)@ident) # expected = c(1,1,1,1,1,1,1,1,1,1,6,1,6,1,2,2,1,6,2,1,2,2,2,2,2,2,2,2,2,6,3,5,3,3,3,3,3,3,3,3,5,1,1,1,1,1,3,1,3,1,2,1,2,2,6,2,3,2,1,3,5,2,5,5,2,2,2,2,5,3,4,4,4,4,4,4,4,4,4,4) # expect_equal(observed, expected) # }) Seurat/tests/testthat/test_load_10X.R0000644000176200001440000000203213527073365017260 0ustar liggesuserscontext("Read10X") # These tests were added to ensure Seurat was forwards and backwards compatible for 3.0 data dname = "../testdata/cr3.0" test.data <- Read10X(dname) test.data2 <- Read10X(c(dname, dname)) test_that("Cell Ranger 3.0 Data Parsing", { expect_is(test.data, "list") expect_equal(ncol(test.data$`Gene Expression`), .5 * ncol(test.data2$`Gene Expression`)) expect_equal(ncol(test.data$`Antibody Capture`), .5 * ncol(test.data2$`Antibody Capture`)) expect_equal(colnames(test.data2[[1]])[6], "2_AAAGTAGCACAGTCGC") expect_equal(test.data$`Gene Expression`[2,2], 1000) }) # Tests of Pre-3.0 Data test.data3 <- Read10X("../testdata/") test_that("Read10X creates sparse matrix", { expect_is(test.data3, "dgCMatrix") expect_equal(colnames(test.data3)[1], "ATGCCAGAACGACT") expect_equal(rownames(test.data3)[1], "MS4A1") }) test_that("Read10X handles missing files properly", { expect_error(Read10X(".")) expect_error(Read10X("./notadir/")) expect_error(Read10X(dname, gene.column = 10)) }) Seurat/tests/testthat/test_dimensional_reduction.R0000644000176200001440000000422013602476667022276 0ustar liggesuserscontext("test-dimensional_reduction") test_that("different ways of passing distance matrix", { # Generate dummy data exp matrix set.seed(1) dummyexpMat <- matrix(data = sample(x = c(1:50), size = 1e4, replace = TRUE), ncol = 100, nrow = 100) colnames(dummyexpMat) <- paste0("cell", seq(ncol(dummyexpMat))) row.names(dummyexpMat) <- paste0("gene", seq(nrow(dummyexpMat))) # Create Seurat object for testing obj <- CreateSeuratObject(counts = dummyexpMat) # Manually make a distance object to test distMat <- dist(t(dummyexpMat)) expect_equivalent( suppressWarnings(expr = RunTSNE(obj, distance.matrix = distMat)), suppressWarnings(expr = RunTSNE(obj, distance.matrix = as.matrix(distMat))) ) expect_equivalent( suppressWarnings(expr = RunTSNE(obj, distance.matrix = distMat)@reductions$tsne), suppressWarnings(expr = RunTSNE(distMat, assay = "RNA")) ) expect_equivalent( suppressWarnings(expr = RunTSNE(obj, distance.matrix = distMat)@reductions$tsne), suppressWarnings(expr = RunTSNE(as.matrix(distMat), assay = "RNA", is_distance = TRUE)) ) }) test_that("pca returns total variance (see #982)", { # Generate dummy data exp matrix set.seed(seed = 1) dummyexpMat <- matrix( data = sample(x = c(1:50), size = 1e4, replace = TRUE), ncol = 100, nrow = 100 ) colnames(x = dummyexpMat) <- paste0("cell", seq(ncol(x = dummyexpMat))) row.names(x = dummyexpMat) <- paste0("gene", seq(nrow(x = dummyexpMat))) # Create Seurat object for testing obj <- CreateSeuratObject(counts = dummyexpMat) # Scale and compute PCA, using RunPCA obj <- ScaleData(object = obj, verbose = FALSE) pca_result <- suppressWarnings(expr = RunPCA( object = obj, features = rownames(x = obj), verbose = FALSE )) # Using stats::prcomp scaled_data <- Seurat::GetAssayData(object = obj, slot = "scale.data") prcomp_result <- stats::prcomp(scaled_data, center = FALSE, scale. = FALSE) # Compare expect_equivalent(slot(object = pca_result[["pca"]], name = "misc")$total.variance, sum(prcomp_result$sdev^2)) }) Seurat/tests/testdata/0000755000176200001440000000000013527073365014503 5ustar liggesusersSeurat/tests/testdata/cr3.0/0000755000176200001440000000000013527073365015330 5ustar liggesusersSeurat/tests/testdata/cr3.0/barcodes.tsv.gz0000644000176200001440000000012713527073365020267 0ustar liggesusers?Fw[barcodes.tsv% ./Zx& DCB}{Ņo]+5j{P`ܡC0VPh3T:r|V{̤ҧ(.s>?5nY0'2K ?Seurat/tests/testdata/matrix.mtx0000644000176200001440000013230213527073365016542 0ustar liggesusers%%MatrixMarket matrix coordinate integer general 240 80 4814 2 1 1 6 1 1 9 1 3 12 1 1 23 1 1 31 1 4 33 1 3 35 1 1 36 1 5 38 1 1 40 1 1 44 1 3 45 1 3 47 1 1 48 1 3 50 1 1 51 1 1 52 1 1 53 1 1 54 1 2 56 1 1 57 1 2 58 1 1 59 1 2 60 1 1 65 1 1 78 1 4 80 1 1 84 1 1 93 1 1 95 1 1 100 1 1 104 1 1 109 1 1 120 1 1 126 1 1 133 1 1 141 1 1 149 1 2 152 1 2 159 1 1 163 1 2 166 1 3 167 1 1 177 1 1 194 1 1 198 1 1 208 1 1 222 1 1 233 1 1 236 1 1 238 1 1 4 2 1 9 2 7 22 2 1 23 2 1 25 2 2 27 2 1 31 2 4 32 2 3 33 2 7 34 2 1 36 2 2 38 2 1 39 2 1 40 2 1 41 2 5 42 2 2 43 2 2 44 2 2 45 2 3 48 2 1 49 2 2 52 2 2 56 2 3 57 2 2 58 2 1 67 2 1 69 2 3 72 2 2 74 2 2 77 2 1 78 2 4 80 2 2 92 2 1 93 2 1 95 2 1 100 2 1 111 2 1 115 2 1 116 2 1 117 2 1 126 2 1 128 2 1 141 2 1 147 2 1 156 2 1 159 2 1 177 2 1 191 2 1 193 2 1 197 2 1 198 2 2 219 2 1 223 2 1 228 2 1 231 2 1 232 2 1 239 2 1 9 3 11 12 3 1 24 3 1 31 3 4 32 3 2 33 3 11 35 3 2 36 3 1 37 3 1 39 3 1 42 3 1 44 3 1 47 3 1 48 3 2 49 3 1 51 3 2 54 3 1 55 3 1 56 3 2 57 3 2 58 3 1 65 3 9 67 3 1 69 3 2 72 3 2 78 3 4 80 3 2 89 3 1 92 3 1 93 3 1 98 3 1 104 3 1 107 3 1 124 3 1 126 3 1 140 3 1 141 3 1 144 3 1 149 3 1 152 3 1 153 3 2 155 3 2 157 3 1 160 3 1 163 3 1 164 3 1 166 3 3 172 3 4 175 3 1 179 3 1 181 3 1 222 3 1 232 3 1 9 4 13 12 4 1 23 4 6 31 4 5 32 4 2 33 4 13 34 4 1 35 4 2 36 4 2 39 4 1 40 4 1 42 4 1 43 4 2 44 4 6 45 4 4 46 4 2 48 4 5 49 4 4 54 4 1 55 4 2 56 4 3 57 4 3 58 4 1 59 4 2 60 4 1 65 4 8 67 4 1 70 4 2 72 4 4 76 4 1 78 4 5 81 4 1 88 4 1 90 4 1 96 4 2 98 4 1 104 4 2 112 4 1 130 4 1 141 4 1 142 4 3 149 4 2 151 4 3 154 4 1 155 4 1 157 4 1 163 4 2 166 4 3 169 4 1 172 4 2 173 4 1 176 4 1 180 4 1 182 4 1 210 4 1 214 4 1 222 4 1 236 4 3 4 5 1 9 5 3 31 5 4 32 5 3 33 5 3 36 5 2 39 5 36 41 5 2 43 5 1 44 5 5 45 5 2 48 5 2 49 5 3 51 5 2 52 5 1 54 5 54 56 5 2 57 5 2 64 5 1 65 5 1 67 5 3 68 5 1 69 5 1 72 5 1 75 5 1 78 5 4 89 5 1 90 5 2 99 5 1 100 5 1 101 5 1 104 5 1 128 5 1 131 5 1 137 5 1 140 5 1 141 5 2 144 5 1 146 5 1 149 5 3 151 5 2 153 5 3 154 5 1 159 5 1 161 5 1 163 5 1 166 5 1 172 5 1 176 5 1 180 5 1 182 5 1 183 5 1 198 5 2 211 5 1 217 5 1 222 5 2 223 5 1 232 5 2 233 5 1 4 6 1 9 6 4 14 6 1 23 6 2 24 6 1 31 6 4 32 6 1 33 6 4 34 6 1 35 6 1 37 6 2 42 6 2 43 6 2 44 6 3 45 6 1 46 6 1 47 6 1 48 6 4 49 6 1 50 6 1 54 6 2 55 6 1 57 6 1 60 6 1 66 6 1 69 6 1 72 6 1 78 6 4 80 6 1 81 6 1 93 6 1 100 6 2 101 6 1 126 6 1 128 6 1 135 6 1 144 6 1 146 6 1 149 6 2 151 6 1 153 6 2 155 6 1 156 6 1 159 6 2 166 6 3 172 6 2 182 6 1 194 6 1 200 6 1 223 6 1 231 6 1 232 6 1 236 6 1 9 7 6 23 7 4 31 7 3 32 7 1 33 7 6 34 7 1 36 7 1 37 7 3 38 7 1 41 7 1 42 7 1 44 7 4 45 7 1 48 7 3 49 7 3 50 7 1 54 7 1 55 7 2 59 7 2 60 7 1 65 7 3 69 7 2 70 7 1 78 7 3 96 7 1 101 7 1 113 7 1 125 7 1 127 7 1 132 7 1 149 7 2 152 7 2 156 7 1 166 7 3 179 7 1 210 7 1 213 7 1 236 7 1 238 7 1 4 8 1 9 8 4 23 8 1 24 8 1 31 8 2 32 8 3 33 8 4 35 8 1 36 8 12 37 8 2 38 8 1 40 8 1 41 8 1 43 8 2 45 8 2 46 8 1 47 8 1 48 8 2 49 8 4 50 8 1 53 8 1 54 8 1 55 8 2 58 8 1 59 8 1 65 8 3 71 8 1 74 8 1 78 8 2 81 8 1 85 8 1 92 8 1 100 8 1 120 8 1 128 8 1 141 8 1 149 8 1 152 8 1 154 8 1 156 8 1 159 8 1 161 8 1 163 8 1 166 8 1 172 8 1 182 8 1 183 8 1 222 8 1 233 8 1 9 9 2 31 9 2 32 9 2 33 9 2 35 9 2 37 9 3 38 9 1 42 9 1 43 9 3 44 9 1 45 9 1 47 9 1 48 9 3 49 9 2 51 9 1 54 9 1 56 9 1 57 9 3 58 9 2 59 9 1 78 9 2 80 9 2 81 9 2 83 9 1 89 9 1 93 9 1 95 9 1 96 9 1 100 9 1 112 9 1 126 9 1 142 9 1 148 9 1 156 9 1 159 9 1 163 9 1 172 9 1 179 9 1 191 9 1 236 9 1 2 10 1 9 10 21 12 10 1 23 10 4 25 10 1 31 10 2 32 10 1 33 10 21 34 10 1 35 10 1 36 10 9 38 10 1 40 10 1 41 10 1 43 10 1 44 10 6 45 10 1 47 10 1 53 10 1 54 10 3 55 10 1 59 10 1 65 10 3 69 10 2 72 10 6 74 10 2 78 10 2 80 10 1 98 10 4 100 10 1 101 10 1 115 10 1 141 10 2 146 10 1 149 10 3 150 10 1 154 10 1 156 10 2 159 10 1 166 10 3 172 10 3 182 10 1 210 10 1 231 10 1 1 11 2 2 11 2 4 11 14 5 11 3 6 11 1 7 11 3 9 11 2 13 11 1 15 11 3 20 11 1 21 11 1 22 11 1 23 11 2 24 11 2 26 11 2 28 11 1 29 11 1 30 11 1 33 11 2 43 11 1 54 11 1 86 11 1 90 11 1 93 11 1 95 11 1 100 11 1 121 11 3 126 11 1 128 11 14 129 11 4 132 11 1 133 11 1 134 11 2 143 11 1 159 11 1 233 11 1 1 12 2 2 12 4 3 12 5 4 12 28 6 12 6 7 12 1 8 12 4 9 12 9 10 12 2 11 12 1 12 12 3 14 12 1 16 12 3 17 12 1 18 12 1 25 12 1 26 12 2 27 12 4 33 12 9 43 12 1 44 12 1 45 12 1 48 12 2 54 12 2 55 12 1 57 12 1 68 12 1 72 12 1 75 12 2 81 12 2 84 12 1 89 12 1 90 12 1 93 12 4 98 12 1 101 12 1 107 12 1 112 12 1 121 12 8 124 12 1 126 12 4 128 12 28 129 12 10 130 12 4 132 12 4 133 12 6 134 12 10 138 12 2 141 12 1 143 12 1 146 12 1 155 12 1 156 12 1 161 12 1 163 12 1 165 12 1 166 12 1 169 12 2 172 12 2 180 12 1 181 12 1 182 12 1 210 12 29 217 12 1 222 12 1 236 12 2 1 13 4 2 13 3 3 13 2 4 13 18 5 13 2 6 13 2 8 13 1 9 13 2 11 13 1 12 13 2 13 13 1 15 13 1 21 13 1 23 13 4 25 13 1 26 13 1 28 13 15 33 13 2 37 13 1 45 13 1 48 13 1 66 13 1 81 13 1 82 13 1 98 13 1 100 13 1 108 13 1 121 13 2 128 13 18 129 13 4 130 13 4 132 13 3 133 13 2 134 13 6 142 13 1 146 13 1 149 13 1 154 13 2 155 13 1 159 13 1 166 13 2 182 13 1 215 13 1 230 13 1 231 13 1 1 14 4 2 14 3 3 14 2 4 14 7 5 14 4 6 14 2 8 14 1 9 14 4 10 14 1 14 14 1 16 14 1 17 14 2 21 14 1 23 14 1 29 14 1 33 14 4 48 14 1 54 14 1 64 14 2 93 14 1 121 14 2 126 14 1 128 14 7 129 14 4 130 14 1 133 14 2 134 14 1 143 14 1 178 14 1 180 14 1 211 14 2 1 15 2 2 15 2 3 15 5 4 15 15 6 15 2 7 15 2 8 15 2 9 15 4 10 15 1 12 15 1 15 15 1 18 15 1 22 15 2 24 15 2 25 15 2 27 15 1 33 15 4 36 15 1 47 15 1 48 15 5 56 15 1 61 15 1 72 15 1 81 15 1 84 15 1 98 15 1 121 15 5 128 15 15 129 15 8 132 15 4 133 15 2 134 15 5 138 15 1 142 15 2 144 15 1 152 15 1 153 15 2 154 15 1 155 15 1 156 15 2 166 15 1 182 15 1 194 15 1 196 15 1 198 15 1 222 15 1 231 15 1 236 15 1 1 16 3 2 16 3 3 16 8 4 16 28 6 16 8 8 16 2 10 16 1 12 16 2 14 16 3 15 16 1 17 16 1 19 16 1 20 16 1 25 16 3 27 16 1 30 16 1 32 16 2 37 16 1 47 16 1 56 16 1 61 16 1 71 16 1 72 16 1 79 16 1 101 16 1 121 16 9 124 16 4 128 16 28 129 16 23 130 16 8 132 16 8 133 16 8 134 16 16 140 16 3 141 16 2 146 16 1 149 16 2 156 16 5 158 16 1 164 16 1 172 16 1 176 16 1 194 16 1 198 16 2 228 16 1 233 16 2 1 17 3 2 17 1 3 17 1 4 17 7 5 17 3 6 17 2 7 17 2 8 17 1 9 17 3 11 17 1 12 17 2 13 17 1 19 17 2 20 17 1 23 17 4 26 17 1 30 17 1 33 17 3 44 17 2 45 17 1 58 17 1 67 17 2 100 17 1 101 17 1 107 17 1 124 17 1 128 17 7 129 17 7 130 17 1 132 17 1 133 17 2 134 17 5 138 17 1 149 17 4 159 17 1 182 17 1 233 17 1 1 18 4 2 18 2 3 18 5 4 18 26 5 18 3 6 18 2 7 18 1 8 18 2 9 18 6 11 18 1 13 18 2 16 18 1 18 18 1 19 18 1 20 18 1 22 18 2 23 18 2 25 18 1 27 18 1 28 18 23 29 18 1 33 18 6 45 18 3 48 18 1 49 18 1 61 18 1 64 18 1 66 18 1 72 18 1 81 18 1 93 18 1 100 18 2 121 18 5 124 18 1 126 18 1 128 18 26 130 18 5 132 18 2 133 18 2 134 18 11 138 18 1 140 18 1 143 18 2 154 18 1 159 18 2 172 18 1 175 18 1 183 18 1 190 18 1 211 18 1 229 18 1 1 19 2 2 19 2 3 19 5 4 19 10 5 19 3 6 19 1 7 19 1 9 19 5 10 19 1 12 19 1 13 19 2 14 19 1 17 19 1 21 19 1 22 19 1 23 19 6 24 19 1 26 19 1 33 19 5 36 19 1 44 19 1 45 19 1 47 19 1 49 19 1 56 19 1 62 19 1 63 19 1 90 19 1 93 19 1 98 19 1 102 19 1 121 19 1 126 19 1 128 19 10 129 19 4 132 19 2 133 19 1 134 19 5 135 19 1 143 19 1 151 19 1 154 19 1 166 19 2 180 19 1 221 19 1 228 19 1 231 19 1 233 19 1 1 20 3 2 20 5 3 20 12 4 20 16 5 20 2 6 20 2 7 20 2 8 20 1 9 20 7 11 20 1 16 20 2 18 20 3 19 20 1 23 20 2 24 20 1 25 20 1 26 20 1 30 20 1 33 20 7 37 20 1 41 20 1 45 20 1 49 20 1 56 20 1 75 20 1 80 20 2 81 20 1 98 20 1 100 20 2 121 20 5 124 20 1 128 20 16 129 20 6 130 20 1 132 20 4 133 20 2 134 20 8 135 20 1 143 20 1 144 20 1 149 20 1 152 20 1 159 20 2 166 20 3 196 20 1 4 21 7 7 21 1 9 21 1 23 21 3 33 21 1 36 21 1 44 21 1 49 21 1 50 21 1 64 21 2 68 21 1 81 21 1 90 21 2 91 21 18 92 21 30 93 21 50 94 21 1 95 21 10 96 21 14 97 21 3 98 21 3 99 21 4 100 21 15 101 21 1 104 21 2 105 21 1 107 21 1 108 21 1 109 21 2 110 21 1 111 21 3 112 21 5 113 21 12 115 21 2 119 21 1 120 21 5 125 21 12 126 21 50 128 21 7 130 21 1 134 21 2 135 21 13 136 21 4 140 21 2 146 21 1 147 21 4 151 21 3 152 21 5 153 21 6 154 21 1 156 21 4 157 21 3 158 21 6 159 21 15 160 21 1 161 21 1 163 21 2 164 21 6 166 21 6 170 21 1 172 21 6 173 21 1 177 21 2 178 21 1 182 21 4 186 21 1 198 21 1 211 21 2 212 21 1 217 21 1 218 21 1 222 21 1 4 22 22 6 22 3 8 22 1 32 22 2 44 22 2 54 22 2 64 22 1 70 22 1 74 22 1 76 22 1 82 22 1 91 22 5 92 22 12 93 22 29 94 22 2 95 22 6 96 22 13 97 22 2 98 22 13 99 22 7 100 22 9 101 22 2 103 22 1 104 22 14 105 22 1 106 22 1 107 22 3 108 22 1 109 22 27 110 22 1 111 22 4 112 22 1 113 22 6 116 22 4 118 22 1 120 22 3 121 22 13 124 22 4 125 22 6 126 22 29 128 22 22 129 22 18 130 22 5 131 22 1 132 22 8 133 22 3 134 22 12 135 22 28 138 22 2 140 22 3 144 22 1 146 22 3 147 22 1 148 22 7 151 22 6 152 22 7 153 22 5 155 22 1 156 22 15 158 22 4 159 22 9 160 22 5 161 22 1 163 22 10 164 22 3 165 22 1 166 22 4 167 22 2 170 22 1 171 22 1 172 22 15 173 22 1 174 22 2 176 22 1 177 22 1 180 22 1 182 22 5 198 22 1 211 22 1 231 22 2 3 23 1 7 23 1 12 23 1 13 23 1 74 23 1 75 23 1 91 23 25 92 23 51 93 23 25 94 23 2 95 23 5 96 23 3 98 23 5 99 23 1 100 23 1 101 23 6 102 23 1 104 23 10 105 23 1 107 23 1 111 23 2 113 23 2 114 23 1 118 23 1 121 23 2 124 23 1 125 23 2 126 23 25 129 23 1 132 23 1 134 23 1 135 23 15 137 23 1 140 23 1 141 23 1 147 23 1 148 23 1 151 23 1 152 23 6 153 23 1 155 23 1 156 23 8 159 23 1 163 23 4 164 23 4 172 23 2 174 23 4 177 23 1 180 23 1 182 23 3 198 23 2 4 24 10 8 24 1 9 24 1 24 24 1 33 24 1 44 24 2 74 24 1 91 24 5 92 24 22 93 24 49 94 24 4 95 24 9 96 24 10 99 24 6 100 24 5 103 24 4 104 24 8 107 24 2 108 24 1 109 24 1 110 24 2 111 24 1 113 24 1 114 24 1 115 24 1 116 24 4 121 24 1 124 24 1 125 24 1 126 24 49 128 24 10 129 24 2 132 24 1 134 24 5 135 24 11 140 24 6 142 24 1 146 24 3 148 24 1 151 24 4 152 24 5 153 24 5 154 24 1 156 24 5 158 24 2 159 24 5 163 24 2 164 24 6 172 24 4 177 24 1 182 24 5 195 24 3 198 24 3 237 24 1 1 25 1 4 25 6 9 25 1 13 25 1 31 25 1 32 25 1 33 25 1 42 25 1 44 25 1 45 25 3 48 25 1 54 25 1 56 25 1 58 25 1 61 25 1 66 25 1 72 25 3 74 25 1 78 25 1 81 25 1 91 25 25 92 25 85 93 25 98 94 25 1 95 25 7 96 25 16 97 25 1 98 25 11 99 25 5 100 25 7 101 25 36 102 25 2 103 25 1 104 25 11 105 25 1 106 25 1 108 25 1 109 25 1 110 25 1 111 25 1 112 25 1 113 25 6 114 25 2 115 25 14 116 25 4 117 25 1 119 25 1 120 25 3 125 25 6 126 25 98 128 25 6 131 25 2 134 25 1 135 25 13 140 25 5 141 25 2 142 25 2 143 25 2 146 25 1 147 25 1 148 25 1 151 25 8 152 25 4 153 25 3 154 25 2 156 25 4 157 25 3 159 25 7 163 25 2 164 25 1 165 25 1 166 25 1 168 25 1 169 25 2 172 25 7 177 25 1 181 25 1 182 25 12 183 25 1 198 25 5 210 25 1 212 25 1 239 25 1 36 26 1 91 26 6 92 26 3 93 26 11 95 26 1 96 26 4 99 26 1 100 26 3 101 26 1 102 26 1 103 26 1 104 26 4 105 26 1 107 26 1 108 26 1 109 26 1 112 26 1 114 26 2 115 26 1 116 26 1 117 26 1 119 26 1 121 26 1 126 26 11 129 26 3 135 26 7 136 26 1 140 26 1 146 26 1 151 26 3 152 26 3 153 26 2 156 26 2 159 26 3 160 26 2 163 26 2 164 26 2 166 26 1 172 26 3 177 26 1 182 26 1 191 26 1 198 26 1 237 26 1 4 27 4 6 27 1 23 27 1 38 27 1 44 27 1 48 27 1 58 27 1 64 27 1 72 27 1 82 27 1 91 27 24 92 27 54 93 27 59 94 27 1 95 27 1 96 27 13 97 27 1 98 27 2 99 27 6 100 27 4 101 27 5 102 27 4 103 27 7 104 27 6 105 27 1 106 27 1 110 27 1 114 27 1 115 27 2 116 27 3 117 27 3 119 27 1 120 27 1 126 27 59 128 27 4 133 27 1 134 27 3 135 27 37 140 27 3 142 27 1 146 27 1 147 27 5 148 27 2 151 27 5 152 27 1 153 27 1 156 27 8 157 27 1 158 27 1 159 27 4 160 27 4 163 27 1 164 27 4 171 27 1 172 27 6 174 27 3 177 27 1 180 27 1 182 27 15 183 27 1 198 27 2 206 27 1 211 27 1 215 27 1 225 27 1 228 27 1 236 27 1 3 28 1 4 28 3 24 28 1 48 28 1 56 28 1 58 28 1 91 28 40 92 28 55 93 28 28 94 28 1 95 28 2 96 28 12 98 28 3 99 28 4 100 28 4 102 28 1 103 28 1 104 28 7 105 28 1 106 28 2 107 28 1 111 28 2 114 28 3 117 28 2 118 28 2 120 28 5 126 28 28 128 28 3 129 28 1 131 28 1 135 28 5 140 28 1 141 28 1 142 28 1 147 28 1 152 28 2 153 28 1 154 28 1 156 28 2 157 28 1 159 28 4 160 28 1 163 28 6 164 28 4 166 28 1 168 28 2 170 28 1 178 28 1 182 28 2 193 28 1 228 28 1 231 28 1 233 28 1 4 29 7 6 29 1 8 29 2 39 29 1 43 29 1 59 29 1 61 29 1 72 29 1 79 29 1 80 29 1 91 29 16 92 29 35 93 29 34 94 29 3 95 29 8 96 29 19 97 29 1 98 29 5 99 29 5 100 29 11 101 29 3 102 29 1 103 29 1 104 29 22 107 29 1 108 29 2 109 29 1 110 29 2 111 29 15 112 29 2 113 29 5 115 29 1 116 29 2 117 29 1 121 29 7 124 29 1 125 29 5 126 29 34 128 29 7 129 29 7 131 29 1 132 29 4 133 29 1 134 29 5 135 29 20 136 29 2 137 29 1 140 29 4 141 29 2 142 29 1 143 29 1 146 29 2 148 29 2 149 29 3 151 29 7 152 29 10 153 29 6 154 29 2 155 29 2 156 29 11 157 29 1 158 29 3 159 29 11 160 29 2 162 29 1 163 29 5 164 29 9 166 29 3 167 29 1 170 29 1 171 29 3 172 29 4 174 29 1 175 29 2 182 29 3 191 29 1 193 29 1 198 29 3 225 29 1 227 29 1 228 29 1 2 30 1 4 30 13 9 30 1 13 30 1 25 30 1 33 30 1 36 30 1 37 30 1 45 30 1 48 30 1 51 30 1 54 30 3 64 30 1 70 30 1 81 30 1 84 30 1 88 30 1 91 30 11 92 30 17 93 30 16 95 30 7 96 30 12 98 30 10 99 30 1 100 30 7 101 30 5 103 30 2 104 30 37 106 30 1 107 30 3 108 30 1 109 30 1 110 30 1 111 30 2 112 30 1 113 30 2 114 30 1 115 30 2 118 30 5 120 30 4 121 30 6 124 30 2 125 30 2 126 30 16 128 30 13 129 30 7 130 30 1 132 30 1 134 30 3 135 30 18 136 30 3 140 30 2 141 30 1 146 30 3 147 30 2 148 30 1 149 30 3 151 30 13 152 30 12 153 30 4 156 30 18 157 30 1 158 30 3 159 30 7 160 30 7 161 30 1 163 30 6 164 30 8 166 30 6 168 30 2 172 30 20 174 30 3 175 30 1 176 30 1 177 30 2 180 30 1 182 30 1 186 30 2 187 30 1 198 30 2 203 30 1 206 30 1 210 30 1 211 30 1 232 30 1 237 30 2 2 31 1 9 31 1 22 31 1 32 31 1 33 31 1 36 31 2 39 31 1 47 31 1 48 31 2 54 31 1 57 31 3 61 31 1 62 31 1 64 31 35 68 31 4 80 31 1 84 31 1 91 31 1 96 31 3 101 31 1 104 31 3 129 31 2 135 31 1 140 31 1 141 31 3 146 31 1 149 31 1 152 31 1 154 31 2 155 31 1 156 31 3 161 31 6 163 31 6 164 31 8 166 31 8 176 31 2 183 31 2 193 31 1 201 31 1 211 31 35 212 31 27 213 31 2 214 31 35 215 31 5 216 31 7 217 31 4 218 31 5 219 31 14 221 31 1 222 31 1 225 31 4 226 31 2 227 31 1 228 31 1 229 31 1 230 31 3 231 31 2 232 31 3 233 31 3 235 31 4 236 31 7 237 31 1 239 31 3 4 32 1 24 32 1 31 32 7 35 32 2 48 32 2 49 32 1 62 32 3 64 32 14 65 32 2 68 32 4 69 32 1 70 32 2 72 32 2 78 32 7 80 32 1 84 32 1 87 32 1 98 32 1 104 32 4 121 32 1 128 32 1 129 32 4 132 32 1 134 32 2 140 32 2 145 32 1 149 32 4 153 32 1 157 32 1 161 32 2 166 32 2 172 32 1 174 32 1 177 32 2 182 32 1 183 32 1 211 32 14 212 32 2 213 32 5 215 32 3 217 32 4 218 32 3 219 32 1 220 32 3 221 32 3 222 32 1 223 32 4 224 32 1 226 32 1 228 32 1 231 32 2 232 32 1 234 32 1 235 32 1 236 32 3 239 32 5 2 33 2 26 33 1 32 33 1 54 33 1 57 33 1 62 33 2 64 33 12 68 33 2 70 33 5 74 33 1 77 33 1 82 33 1 84 33 1 87 33 1 93 33 1 96 33 4 100 33 1 104 33 9 126 33 1 141 33 1 142 33 1 149 33 5 153 33 2 154 33 1 155 33 1 159 33 1 161 33 2 164 33 3 166 33 3 172 33 1 177 33 1 179 33 1 211 33 12 212 33 1 213 33 3 214 33 15 215 33 9 216 33 1 217 33 2 218 33 1 219 33 4 220 33 5 221 33 2 222 33 2 223 33 2 224 33 1 226 33 1 227 33 1 228 33 1 230 33 4 231 33 1 232 33 1 233 33 2 234 33 3 236 33 2 237 33 58 238 33 1 239 33 1 9 34 1 24 34 1 32 34 1 33 34 1 44 34 2 48 34 2 49 34 1 54 34 15 55 34 1 56 34 1 57 34 1 59 34 1 62 34 3 64 34 30 65 34 5 68 34 7 69 34 2 70 34 14 71 34 1 74 34 1 80 34 1 87 34 1 90 34 2 92 34 1 96 34 3 98 34 1 99 34 2 104 34 6 107 34 1 121 34 2 134 34 1 140 34 1 142 34 1 146 34 4 149 34 1 154 34 1 161 34 1 164 34 1 166 34 5 173 34 1 176 34 1 211 34 30 212 34 10 213 34 4 214 34 3 215 34 2 216 34 1 217 34 7 219 34 9 220 34 7 221 34 3 222 34 2 223 34 1 224 34 1 225 34 3 226 34 1 227 34 1 228 34 1 231 34 1 232 34 3 233 34 1 234 34 2 235 34 1 238 34 2 239 34 3 4 35 1 12 35 1 26 35 1 39 35 1 44 35 2 57 35 1 62 35 2 64 35 20 65 35 4 68 35 2 69 35 1 72 35 1 80 35 1 83 35 2 90 35 2 92 35 1 93 35 2 96 35 6 104 35 1 120 35 1 124 35 1 126 35 2 128 35 1 140 35 2 141 35 3 142 35 1 146 35 1 148 35 1 149 35 1 153 35 1 164 35 2 166 35 2 173 35 1 211 35 20 212 35 8 213 35 10 214 35 29 215 35 6 217 35 2 218 35 3 219 35 7 220 35 1 221 35 2 222 35 4 223 35 1 228 35 1 229 35 2 230 35 1 231 35 1 233 35 1 236 35 1 238 35 1 240 35 10 12 36 1 14 36 1 23 36 1 42 36 1 51 36 1 57 36 3 62 36 4 64 36 27 67 36 2 68 36 4 69 36 1 70 36 29 74 36 2 75 36 1 81 36 1 90 36 1 91 36 1 96 36 7 98 36 1 104 36 3 116 36 1 151 36 1 154 36 1 161 36 1 164 36 5 166 36 1 176 36 1 186 36 1 211 36 27 212 36 5 213 36 8 214 36 11 215 36 3 216 36 1 217 36 4 218 36 1 219 36 10 221 36 4 222 36 1 223 36 2 225 36 1 227 36 1 229 36 1 230 36 2 231 36 1 232 36 2 233 36 3 236 36 3 237 36 1 238 36 3 4 37 1 31 37 1 44 37 1 51 37 1 56 37 1 57 37 4 59 37 2 61 37 1 62 37 8 64 37 28 68 37 3 69 37 1 70 37 1 72 37 1 78 37 1 81 37 1 88 37 2 90 37 1 92 37 1 96 37 3 100 37 1 101 37 1 103 37 1 104 37 14 120 37 1 121 37 1 128 37 1 135 37 1 140 37 1 142 37 1 146 37 4 149 37 1 153 37 1 156 37 1 158 37 1 159 37 1 161 37 2 163 37 1 164 37 6 165 37 1 166 37 5 172 37 1 176 37 3 179 37 1 182 37 2 183 37 1 210 37 2 211 37 28 212 37 10 213 37 12 214 37 22 215 37 6 216 37 5 217 37 3 218 37 1 219 37 10 220 37 3 221 37 8 223 37 3 224 37 1 225 37 7 226 37 1 227 37 2 228 37 1 229 37 1 230 37 3 231 37 3 232 37 2 233 37 1 235 37 4 236 37 3 238 37 2 239 37 1 4 38 1 25 38 1 32 38 2 38 38 1 48 38 1 55 38 1 57 38 2 61 38 1 62 38 6 64 38 10 68 38 3 69 38 2 70 38 7 74 38 1 80 38 1 81 38 1 83 38 3 90 38 1 93 38 1 95 38 1 96 38 4 101 38 1 104 38 2 109 38 1 120 38 1 126 38 1 128 38 1 135 38 1 140 38 2 141 38 1 142 38 1 146 38 1 153 38 1 154 38 1 161 38 1 163 38 1 164 38 6 166 38 1 176 38 1 183 38 1 193 38 1 211 38 10 212 38 7 213 38 10 214 38 15 215 38 8 216 38 4 217 38 3 218 38 2 219 38 2 220 38 1 221 38 6 222 38 2 223 38 2 225 38 4 227 38 2 229 38 1 233 38 2 235 38 2 236 38 5 237 38 2 238 38 1 239 38 2 240 38 1 14 39 1 23 39 4 31 39 1 48 39 3 49 39 1 57 39 1 61 39 1 62 39 1 64 39 25 67 39 1 68 39 2 69 39 1 70 39 5 72 39 1 74 39 1 78 39 1 81 39 2 90 39 1 96 39 5 101 39 1 104 39 1 120 39 2 134 39 1 142 39 1 155 39 1 156 39 1 161 39 2 164 39 1 165 39 1 166 39 3 176 39 1 182 39 1 183 39 1 211 39 25 212 39 4 213 39 3 214 39 18 215 39 2 216 39 1 217 39 2 218 39 1 219 39 4 221 39 1 222 39 1 223 39 2 224 39 1 226 39 1 227 39 1 228 39 1 230 39 1 231 39 3 232 39 1 233 39 1 234 39 1 235 39 1 237 39 1 238 39 2 26 40 1 35 40 2 47 40 1 48 40 1 54 40 1 55 40 1 57 40 1 62 40 11 64 40 27 65 40 7 67 40 1 68 40 5 70 40 25 72 40 2 74 40 1 75 40 1 80 40 1 81 40 1 83 40 2 84 40 2 89 40 1 96 40 15 99 40 1 100 40 4 104 40 4 137 40 1 140 40 1 141 40 3 142 40 1 146 40 1 154 40 2 155 40 1 156 40 1 159 40 4 161 40 6 164 40 6 166 40 2 176 40 2 179 40 3 196 40 1 198 40 2 210 40 1 211 40 27 212 40 11 213 40 13 214 40 18 215 40 5 216 40 1 217 40 5 218 40 1 219 40 7 220 40 2 221 40 11 222 40 3 223 40 6 224 40 51 225 40 3 226 40 1 228 40 25 229 40 3 231 40 1 232 40 1 233 40 2 234 40 2 235 40 2 236 40 1 238 40 1 239 40 2 240 40 1 23 41 7 32 41 1 44 41 2 45 41 2 48 41 1 49 41 1 50 41 1 54 41 2 57 41 2 62 41 1 63 41 1 64 41 31 65 41 8 68 41 2 69 41 1 71 41 1 72 41 1 73 41 1 74 41 1 75 41 1 76 41 1 81 41 1 84 41 1 85 41 1 87 41 1 90 41 2 96 41 2 98 41 5 100 41 1 101 41 1 104 41 1 122 41 1 140 41 2 141 41 1 145 41 1 153 41 3 155 41 1 157 41 1 159 41 1 161 41 2 163 41 1 164 41 3 166 41 7 172 41 1 198 41 1 210 41 1 211 41 31 212 41 3 213 41 1 214 41 10 215 41 4 217 41 2 218 41 3 219 41 6 220 41 6 221 41 1 222 41 1 223 41 2 225 41 1 226 41 1 227 41 1 228 41 1 232 41 2 239 41 3 9 42 1 23 42 1 31 42 2 33 42 1 36 42 1 44 42 1 45 42 2 54 42 1 57 42 1 59 42 1 61 42 1 62 42 4 64 42 22 65 42 5 66 42 1 67 42 1 68 42 3 69 42 1 70 42 14 72 42 2 75 42 2 78 42 2 79 42 1 80 42 1 81 42 2 82 42 1 83 42 1 84 42 1 85 42 1 88 42 1 90 42 1 93 42 1 98 42 1 100 42 1 101 42 1 104 42 3 111 42 1 126 42 1 129 42 4 130 42 1 138 42 1 141 42 1 144 42 1 153 42 1 154 42 1 155 42 1 156 42 1 159 42 1 166 42 4 172 42 2 179 42 1 193 42 1 206 42 1 211 42 22 213 42 8 215 42 1 217 42 3 219 42 13 221 42 4 223 42 1 231 42 1 232 42 1 233 42 2 234 42 1 235 42 1 236 42 2 237 42 1 238 42 1 9 43 1 23 43 3 31 43 3 33 43 1 36 43 3 44 43 4 49 43 2 54 43 3 55 43 1 56 43 1 57 43 4 61 43 1 62 43 1 63 43 2 64 43 7 65 43 5 67 43 1 68 43 1 69 43 2 70 43 27 71 43 1 72 43 1 74 43 2 77 43 3 78 43 3 80 43 3 81 43 1 85 43 1 86 43 1 89 43 1 90 43 2 93 43 1 96 43 1 98 43 1 107 43 1 113 43 1 125 43 1 126 43 1 137 43 1 146 43 1 154 43 1 156 43 3 157 43 1 166 43 2 211 43 7 213 43 2 217 43 1 221 43 1 227 43 1 231 43 2 236 43 1 9 44 1 22 44 1 33 44 1 36 44 1 45 44 1 48 44 1 54 44 1 61 44 1 62 44 2 63 44 1 64 44 2 67 44 2 68 44 1 70 44 3 72 44 1 74 44 1 75 44 1 81 44 1 82 44 1 84 44 1 86 44 1 88 44 1 89 44 1 96 44 1 149 44 2 166 44 2 180 44 1 182 44 1 193 44 1 211 44 2 213 44 1 214 44 3 217 44 1 221 44 2 236 44 1 238 44 1 9 45 7 12 45 1 23 45 6 24 45 1 25 45 1 31 45 3 33 45 7 36 45 1 42 45 1 44 45 4 46 45 1 48 45 2 49 45 1 57 45 2 62 45 1 63 45 2 64 45 4 65 45 7 67 45 47 69 45 1 70 45 13 72 45 1 73 45 1 75 45 1 76 45 1 77 45 1 78 45 3 80 45 1 81 45 1 84 45 1 86 45 1 87 45 2 88 45 1 89 45 2 90 45 2 100 45 1 101 45 2 121 45 1 129 45 1 152 45 2 153 45 1 155 45 1 159 45 1 163 45 1 166 45 5 167 45 1 172 45 5 182 45 1 211 45 4 221 45 1 223 45 1 224 45 1 4 46 1 9 46 1 23 46 1 26 46 3 31 46 15 33 46 1 36 46 1 43 46 1 44 46 4 49 46 2 54 46 1 58 46 2 62 46 2 64 46 14 65 46 1 68 46 2 69 46 2 70 46 17 71 46 1 72 46 2 75 46 1 77 46 3 78 46 15 82 46 1 84 46 1 86 46 2 87 46 1 90 46 1 121 46 3 128 46 1 129 46 2 132 46 1 134 46 3 149 46 1 154 46 1 155 46 1 163 46 1 166 46 1 172 46 1 177 46 1 211 46 14 215 46 2 217 46 2 221 46 2 231 46 1 236 46 2 4 47 1 31 47 1 32 47 1 35 47 2 43 47 1 48 47 2 54 47 1 61 47 1 62 47 2 64 47 16 65 47 6 66 47 1 67 47 1 68 47 8 69 47 1 70 47 7 72 47 4 74 47 1 76 47 1 77 47 3 78 47 1 81 47 1 83 47 1 84 47 1 95 47 1 98 47 1 101 47 1 104 47 1 128 47 1 141 47 2 146 47 1 154 47 2 157 47 1 161 47 1 166 47 1 176 47 1 177 47 1 182 47 1 211 47 16 212 47 6 214 47 4 215 47 9 217 47 8 219 47 6 220 47 10 221 47 2 222 47 1 223 47 3 232 47 1 236 47 2 237 47 1 238 47 1 239 47 3 4 48 1 9 48 1 14 48 1 23 48 1 31 48 3 33 48 1 36 48 2 37 48 1 42 48 1 45 48 1 48 48 3 49 48 1 54 48 1 62 48 1 63 48 2 64 48 4 65 48 7 66 48 1 67 48 1 68 48 4 69 48 1 70 48 3 71 48 1 72 48 1 74 48 1 75 48 1 78 48 3 79 48 1 80 48 7 81 48 2 82 48 1 83 48 4 87 48 1 88 48 1 90 48 1 93 48 1 107 48 1 116 48 1 126 48 1 128 48 1 135 48 1 141 48 1 144 48 1 146 48 1 149 48 1 153 48 1 154 48 2 163 48 1 166 48 4 176 48 1 182 48 2 211 48 4 213 48 3 214 48 1 217 48 4 221 48 1 222 48 1 223 48 2 229 48 1 233 48 1 238 48 2 239 48 1 9 49 5 31 49 6 33 49 5 39 49 2 49 49 5 61 49 39 62 49 5 64 49 29 65 49 6 66 49 1 67 49 1 68 49 5 69 49 1 70 49 16 71 49 1 72 49 2 73 49 1 74 49 17 75 49 1 78 49 6 79 49 1 82 49 1 83 49 1 84 49 1 88 49 1 90 49 2 98 49 1 103 49 1 104 49 1 120 49 1 121 49 1 140 49 1 141 49 1 149 49 3 153 49 2 154 49 1 155 49 1 156 49 2 166 49 1 172 49 2 179 49 1 198 49 1 210 49 1 211 49 29 212 49 2 213 49 3 214 49 3 215 49 3 217 49 5 219 49 5 220 49 9 221 49 5 227 49 1 232 49 1 234 49 1 236 49 1 239 49 3 9 50 3 23 50 1 31 50 4 32 50 1 33 50 3 36 50 2 37 50 1 44 50 2 48 50 1 49 50 2 54 50 1 55 50 3 57 50 1 59 50 1 60 50 1 62 50 1 63 50 3 64 50 8 65 50 1 66 50 1 67 50 1 68 50 2 69 50 1 70 50 12 72 50 4 73 50 1 78 50 4 79 50 2 80 50 1 81 50 2 83 50 1 85 50 13 89 50 1 95 50 2 141 50 1 146 50 2 153 50 1 154 50 1 156 50 1 166 50 2 167 50 1 211 50 8 213 50 2 217 50 2 219 50 3 221 50 1 223 50 1 235 50 1 236 50 1 238 50 1 2 51 1 4 51 10 9 51 1 15 51 1 24 51 1 33 51 1 38 51 1 42 51 1 45 51 1 50 51 1 56 51 1 59 51 1 64 51 5 70 51 3 72 51 2 75 51 1 91 51 2 92 51 20 93 51 41 95 51 13 96 51 11 98 51 2 99 51 6 100 51 8 101 51 2 102 51 1 103 51 4 104 51 5 109 51 1 111 51 4 113 51 3 115 51 3 116 51 2 118 51 1 119 51 1 121 51 12 124 51 1 125 51 3 126 51 41 128 51 10 129 51 8 132 51 4 134 51 8 135 51 16 140 51 4 141 51 3 142 51 1 146 51 9 147 51 2 148 51 2 149 51 3 151 51 15 152 51 7 153 51 8 154 51 2 156 51 21 157 51 2 158 51 2 159 51 8 160 51 5 162 51 1 163 51 17 164 51 12 166 51 5 168 51 3 170 51 2 171 51 1 172 51 9 173 51 2 174 51 6 176 51 1 177 51 2 178 51 1 182 51 5 183 51 2 193 51 1 194 51 1 198 51 1 211 51 5 225 51 1 228 51 2 4 52 10 6 52 1 9 52 2 23 52 1 32 52 2 33 52 2 40 52 1 45 52 1 48 52 2 51 52 1 54 52 1 58 52 1 59 52 1 64 52 3 67 52 2 70 52 1 72 52 1 81 52 1 87 52 1 90 52 1 91 52 2 92 52 6 93 52 4 95 52 7 96 52 21 98 52 2 99 52 5 100 52 8 101 52 4 104 52 12 109 52 1 110 52 1 111 52 5 115 52 2 116 52 2 120 52 2 121 52 4 126 52 4 128 52 10 129 52 3 130 52 2 132 52 5 133 52 1 134 52 4 135 52 32 140 52 1 141 52 3 142 52 1 146 52 3 148 52 1 149 52 1 151 52 17 152 52 12 153 52 8 154 52 2 155 52 1 156 52 25 157 52 3 158 52 1 159 52 8 160 52 3 161 52 5 162 52 1 163 52 13 164 52 12 165 52 2 166 52 10 167 52 2 168 52 3 169 52 5 170 52 4 171 52 2 172 52 20 173 52 3 174 52 4 175 52 5 176 52 6 177 52 2 179 52 26 182 52 3 193 52 1 196 52 1 198 52 2 210 52 1 211 52 3 212 52 1 230 52 1 237 52 1 238 52 1 2 53 1 4 53 4 6 53 1 38 53 1 44 53 1 59 53 1 74 53 1 92 53 1 93 53 3 95 53 5 96 53 2 98 53 2 99 53 1 100 53 7 103 53 1 104 53 4 109 53 1 110 53 1 111 53 2 114 53 1 121 53 2 126 53 3 128 53 4 129 53 5 133 53 1 135 53 7 140 53 2 146 53 1 147 53 1 148 53 3 151 53 8 152 53 7 153 53 6 154 53 1 156 53 6 157 53 16 158 53 1 159 53 7 160 53 4 161 53 1 162 53 3 163 53 1 164 53 2 165 53 1 166 53 1 167 53 2 169 53 1 170 53 2 172 53 9 174 53 1 178 53 1 180 53 1 191 53 1 228 53 1 2 54 1 4 54 1 8 54 1 23 54 1 45 54 1 91 54 4 93 54 3 95 54 1 96 54 5 99 54 1 100 54 3 101 54 1 104 54 2 115 54 1 120 54 1 121 54 1 126 54 3 128 54 1 129 54 2 131 54 1 135 54 9 141 54 1 142 54 1 147 54 1 151 54 11 152 54 6 153 54 2 156 54 10 158 54 1 159 54 3 160 54 1 161 54 2 163 54 2 164 54 4 166 54 4 167 54 1 168 54 1 170 54 1 171 54 1 172 54 3 176 54 1 177 54 2 180 54 1 215 54 1 225 54 1 2 55 2 4 55 6 6 55 2 8 55 1 9 55 1 12 55 1 15 55 1 22 55 1 33 55 1 37 55 1 45 55 1 48 55 2 72 55 2 74 55 1 91 55 3 92 55 10 93 55 14 95 55 4 96 55 21 98 55 2 99 55 6 100 55 10 101 55 2 103 55 1 104 55 16 105 55 2 106 55 1 107 55 2 109 55 3 110 55 1 112 55 1 115 55 3 116 55 4 117 55 2 118 55 1 120 55 1 121 55 5 126 55 14 128 55 6 129 55 3 132 55 3 133 55 2 134 55 7 135 55 11 140 55 1 141 55 2 146 55 4 147 55 2 151 55 18 152 55 32 153 55 9 154 55 50 155 55 3 156 55 26 157 55 1 158 55 3 159 55 10 160 55 11 161 55 14 163 55 9 164 55 35 165 55 3 166 55 17 167 55 1 168 55 2 169 55 2 170 55 1 172 55 6 173 55 6 174 55 4 175 55 4 176 55 1 177 55 2 178 55 1 179 55 2 180 55 2 182 55 1 193 55 1 226 55 1 233 55 1 236 55 2 237 55 2 2 56 2 4 56 28 7 56 1 9 56 1 22 56 1 32 56 1 33 56 1 43 56 2 44 56 2 47 56 2 54 56 1 56 56 1 87 56 1 90 56 2 92 56 4 93 56 17 94 56 1 95 56 3 96 56 13 98 56 1 99 56 4 100 56 15 101 56 3 104 56 10 107 56 2 109 56 6 110 56 2 111 56 5 115 56 1 116 56 2 118 56 1 120 56 3 121 56 5 124 56 4 126 56 17 128 56 28 129 56 7 130 56 1 132 56 3 134 56 7 135 56 17 140 56 5 141 56 2 144 56 1 146 56 2 147 56 3 148 56 1 149 56 1 151 56 13 152 56 33 153 56 9 154 56 1 155 56 3 156 56 26 157 56 11 158 56 4 159 56 15 160 56 9 161 56 4 162 56 1 163 56 12 164 56 16 165 56 4 166 56 8 168 56 1 169 56 4 170 56 3 171 56 3 172 56 9 174 56 3 176 56 2 177 56 1 178 56 6 179 56 2 180 56 25 182 56 1 198 56 2 206 56 1 228 56 3 4 57 10 9 57 1 12 57 1 22 57 1 32 57 1 33 57 1 39 57 1 43 57 3 48 57 1 51 57 1 59 57 1 61 57 1 64 57 5 65 57 1 66 57 1 67 57 2 69 57 1 72 57 3 74 57 1 81 57 1 90 57 1 91 57 1 92 57 8 93 57 7 95 57 1 96 57 16 98 57 1 99 57 3 100 57 18 101 57 6 103 57 3 104 57 6 105 57 1 107 57 5 108 57 1 109 57 1 110 57 1 111 57 2 115 57 1 117 57 1 120 57 1 121 57 7 126 57 7 128 57 10 129 57 6 130 57 1 131 57 1 132 57 6 134 57 13 135 57 33 137 57 2 138 57 1 146 57 3 148 57 1 151 57 36 152 57 12 153 57 10 154 57 1 155 57 1 156 57 16 157 57 3 158 57 5 159 57 18 160 57 2 161 57 18 162 57 1 163 57 14 164 57 24 165 57 1 166 57 33 167 57 3 168 57 6 169 57 3 171 57 1 172 57 91 175 57 5 176 57 7 178 57 4 179 57 1 191 57 1 194 57 1 198 57 2 211 57 5 214 57 1 228 57 2 237 57 1 4 58 13 6 58 1 8 58 1 9 58 1 13 58 1 22 58 1 24 58 1 33 58 1 44 58 1 50 58 1 54 58 3 65 58 1 72 58 1 81 58 1 90 58 1 91 58 1 92 58 6 93 58 6 95 58 1 96 58 9 98 58 1 99 58 2 100 58 19 101 58 4 104 58 2 107 58 1 109 58 2 110 58 1 111 58 3 112 58 1 116 58 2 117 58 2 120 58 3 121 58 14 126 58 6 128 58 13 129 58 5 130 58 2 131 58 1 132 58 3 133 58 1 134 58 6 135 58 10 137 58 1 138 58 2 141 58 1 142 58 2 143 58 2 146 58 2 147 58 1 151 58 17 152 58 19 153 58 8 154 58 1 155 58 27 156 58 15 157 58 5 158 58 5 159 58 19 160 58 5 161 58 9 163 58 8 164 58 9 165 58 2 166 58 8 167 58 1 168 58 1 169 58 1 170 58 1 171 58 2 172 58 11 173 58 3 174 58 4 175 58 2 176 58 2 177 58 6 178 58 1 180 58 1 182 58 1 198 58 2 228 58 1 2 59 3 4 59 5 6 59 1 7 59 1 9 59 2 23 59 1 33 59 2 39 59 1 48 59 2 54 59 1 67 59 1 72 59 3 74 59 2 84 59 2 91 59 2 93 59 9 95 59 2 96 59 16 98 59 2 99 59 4 100 59 4 101 59 2 104 59 12 105 59 2 107 59 2 109 59 2 111 59 2 112 59 3 115 59 1 116 59 1 118 59 1 121 59 5 126 59 9 128 59 5 129 59 9 131 59 2 132 59 6 133 59 1 134 59 6 135 59 15 136 59 1 140 59 1 141 59 2 142 59 3 147 59 1 148 59 3 149 59 1 151 59 12 152 59 18 153 59 5 154 59 3 155 59 1 156 59 11 157 59 4 158 59 3 159 59 4 160 59 7 161 59 5 162 59 1 163 59 7 164 59 9 165 59 1 166 59 14 167 59 1 168 59 5 171 59 3 172 59 18 174 59 2 175 59 1 176 59 6 177 59 3 182 59 1 198 59 1 213 59 1 219 59 1 225 59 1 4 60 8 8 60 1 9 60 1 23 60 2 25 60 1 33 60 1 43 60 1 44 60 1 45 60 1 47 60 1 48 60 1 56 60 1 59 60 1 61 60 2 66 60 1 72 60 1 81 60 1 89 60 1 90 60 1 93 60 6 96 60 17 98 60 9 99 60 5 100 60 17 101 60 5 103 60 2 104 60 16 105 60 1 106 60 1 109 60 4 111 60 3 112 60 1 115 60 1 118 60 2 120 60 2 121 60 11 126 60 6 128 60 8 129 60 4 131 60 2 132 60 2 134 60 4 135 60 25 140 60 1 146 60 6 147 60 3 148 60 2 149 60 1 151 60 27 152 60 29 153 60 10 154 60 1 155 60 1 156 60 22 157 60 6 158 60 6 159 60 17 160 60 10 161 60 11 162 60 1 163 60 13 164 60 30 165 60 1 166 60 19 167 60 2 168 60 6 169 60 2 171 60 5 172 60 18 173 60 3 174 60 8 175 60 4 176 60 3 177 60 6 178 60 2 179 60 1 182 60 2 183 60 1 191 60 2 193 60 2 198 60 2 210 60 2 214 60 1 225 60 1 238 60 3 4 61 108 6 61 21 8 61 3 12 61 1 15 61 1 22 61 2 23 61 12 26 61 1 32 61 1 36 61 1 39 61 1 42 61 1 44 61 2 46 61 1 48 61 4 49 61 1 61 61 3 71 61 2 74 61 1 75 61 1 82 61 1 84 61 1 85 61 1 88 61 1 89 61 1 90 61 1 93 61 76 96 61 2 98 61 2 99 61 1 100 61 5 101 61 1 103 61 1 104 61 8 107 61 1 109 61 2 112 61 2 113 61 3 114 61 4 115 61 3 121 61 75 122 61 16 124 61 6 125 61 3 126 61 76 127 61 3 128 61 108 129 61 102 130 61 25 131 61 2 132 61 11 133 61 21 134 61 50 135 61 61 136 61 1 138 61 7 139 61 2 140 61 9 141 61 1 142 61 4 143 61 2 145 61 2 146 61 5 147 61 6 148 61 4 149 61 3 151 61 12 152 61 6 153 61 1 154 61 5 156 61 10 157 61 8 158 61 1 159 61 5 163 61 5 164 61 8 166 61 4 168 61 6 172 61 18 176 61 2 177 61 1 182 61 6 183 61 1 191 61 1 196 61 1 198 61 1 210 61 1 222 61 1 223 61 1 228 61 1 235 61 1 237 61 2 239 61 1 4 62 93 6 62 21 8 62 2 9 62 1 23 62 3 25 62 2 32 62 1 33 62 1 36 62 1 50 62 1 54 62 2 56 62 1 58 62 1 59 62 2 64 62 1 70 62 1 72 62 2 91 62 2 93 62 20 96 62 8 98 62 2 99 62 3 100 62 3 103 62 1 104 62 13 109 62 2 112 62 1 113 62 10 114 62 1 115 62 1 116 62 5 120 62 4 121 62 52 122 62 1 123 62 5 124 62 6 125 62 10 126 62 20 127 62 3 128 62 93 129 62 78 130 62 39 131 62 2 132 62 26 133 62 21 134 62 53 135 62 31 136 62 8 137 62 1 138 62 9 139 62 5 140 62 4 142 62 3 146 62 1 147 62 1 149 62 1 150 62 4 151 62 7 152 62 7 153 62 2 156 62 5 157 62 1 158 62 1 159 62 3 160 62 12 163 62 4 164 62 8 166 62 7 171 62 1 172 62 2 178 62 1 182 62 7 191 62 1 211 62 1 236 62 1 239 62 1 4 63 41 6 63 3 8 63 1 23 63 1 25 63 1 26 63 1 36 63 1 43 63 1 54 63 1 56 63 1 62 63 1 72 63 3 80 63 1 81 63 1 84 63 1 92 63 1 93 63 24 95 63 3 96 63 6 99 63 2 100 63 1 104 63 21 107 63 1 108 63 1 109 63 2 112 63 1 113 63 1 116 63 1 117 63 1 118 63 2 121 63 11 122 63 2 123 63 2 124 63 5 125 63 1 126 63 24 127 63 1 128 63 41 129 63 23 130 63 5 132 63 5 133 63 3 134 63 10 135 63 25 137 63 1 138 63 1 140 63 5 141 63 1 143 63 3 146 63 5 148 63 2 150 63 1 151 63 7 152 63 1 153 63 1 156 63 5 157 63 1 159 63 1 160 63 2 163 63 5 164 63 3 166 63 4 168 63 3 169 63 1 172 63 9 173 63 1 176 63 1 178 63 1 182 63 2 184 63 1 214 63 1 219 63 1 221 63 1 228 63 1 2 64 4 3 64 8 4 64 42 5 64 4 6 64 5 8 64 4 9 64 5 12 64 3 16 64 1 21 64 1 23 64 3 25 64 1 26 64 1 30 64 2 33 64 5 43 64 1 44 64 5 45 64 2 48 64 4 54 64 1 59 64 2 61 64 2 66 64 1 74 64 1 75 64 1 81 64 1 91 64 2 92 64 10 93 64 79 94 64 2 95 64 1 96 64 9 97 64 1 98 64 1 99 64 5 100 64 5 101 64 4 103 64 2 104 64 9 109 64 2 113 64 2 114 64 7 115 64 2 117 64 1 120 64 2 121 64 19 122 64 4 123 64 4 124 64 4 125 64 2 126 64 79 127 64 3 128 64 42 129 64 25 130 64 2 131 64 1 132 64 2 133 64 5 134 64 9 135 64 14 136 64 3 137 64 33 140 64 7 141 64 2 142 64 1 143 64 2 144 64 1 146 64 1 147 64 2 149 64 2 151 64 4 152 64 3 153 64 6 156 64 16 158 64 3 159 64 5 160 64 1 163 64 3 164 64 3 166 64 3 168 64 1 170 64 1 172 64 11 173 64 1 177 64 1 179 64 1 182 64 6 193 64 2 198 64 1 222 64 1 225 64 1 228 64 1 2 65 1 4 65 138 6 65 11 8 65 5 12 65 1 15 65 1 26 65 1 35 65 2 36 65 1 39 65 1 43 65 1 44 65 2 45 65 3 48 65 2 54 65 3 55 65 1 56 65 4 62 65 1 64 65 1 65 65 1 68 65 1 70 65 1 71 65 1 72 65 1 74 65 1 75 65 2 84 65 1 87 65 1 90 65 1 91 65 1 93 65 53 94 65 2 95 65 2 96 65 11 98 65 1 99 65 14 101 65 2 104 65 20 108 65 2 111 65 1 112 65 3 113 65 3 114 65 7 115 65 2 116 65 6 118 65 1 120 65 6 121 65 54 122 65 8 123 65 2 124 65 6 125 65 3 126 65 53 128 65 138 129 65 69 130 65 16 131 65 1 132 65 31 133 65 11 134 65 68 135 65 58 136 65 1 138 65 6 139 65 3 140 65 2 141 65 1 143 65 3 144 65 1 146 65 22 147 65 5 148 65 1 149 65 64 150 65 1 151 65 8 152 65 11 153 65 6 154 65 2 156 65 2 160 65 3 163 65 11 164 65 13 166 65 2 168 65 1 171 65 1 172 65 12 174 65 1 176 65 2 177 65 2 179 65 1 182 65 24 183 65 1 191 65 1 194 65 2 198 65 3 211 65 1 217 65 1 221 65 1 225 65 3 228 65 1 231 65 1 233 65 1 236 65 2 237 65 4 4 66 77 6 66 11 8 66 2 22 66 1 23 66 1 32 66 1 35 66 1 43 66 1 44 66 2 45 66 1 48 66 4 51 66 1 59 66 1 64 66 3 66 66 1 67 66 1 68 66 1 70 66 1 72 66 3 75 66 2 82 66 1 90 66 4 91 66 9 92 66 41 93 66 53 94 66 1 95 66 4 96 66 14 97 66 1 98 66 6 99 66 11 100 66 3 101 66 5 103 66 2 104 66 10 105 66 2 108 66 1 111 66 2 112 66 1 113 66 4 115 66 3 116 66 2 117 66 1 120 66 2 121 66 23 122 66 5 123 66 3 124 66 5 125 66 4 126 66 53 127 66 1 128 66 77 129 66 24 130 66 6 131 66 1 132 66 21 133 66 11 134 66 36 135 66 112 136 66 2 138 66 1 139 66 3 140 66 5 142 66 1 143 66 1 146 66 10 147 66 4 148 66 39 149 66 2 151 66 10 152 66 7 153 66 4 154 66 5 156 66 3 158 66 1 159 66 3 160 66 4 163 66 9 164 66 8 165 66 1 166 66 2 167 66 2 168 66 3 171 66 1 172 66 11 173 66 1 174 66 1 177 66 1 179 66 1 182 66 16 183 66 2 186 66 2 198 66 1 211 66 3 217 66 1 225 66 2 228 66 2 231 66 1 233 66 1 236 66 1 237 66 2 4 67 76 6 67 10 8 67 1 15 67 1 23 67 2 39 67 1 48 67 1 54 67 1 56 67 2 61 67 1 72 67 2 81 67 2 82 67 1 89 67 1 91 67 1 92 67 11 93 67 87 94 67 1 95 67 6 96 67 10 98 67 1 99 67 3 100 67 6 101 67 10 103 67 2 104 67 23 105 67 1 107 67 1 109 67 3 112 67 1 113 67 4 114 67 2 115 67 3 116 67 7 120 67 5 121 67 45 122 67 8 123 67 6 124 67 6 125 67 4 126 67 87 127 67 3 128 67 76 129 67 43 130 67 11 131 67 6 132 67 21 133 67 10 134 67 49 135 67 37 136 67 3 138 67 4 140 67 12 141 67 1 142 67 38 143 67 2 144 67 21 146 67 9 147 67 8 148 67 1 149 67 3 151 67 4 152 67 9 153 67 4 154 67 4 155 67 2 156 67 16 157 67 1 159 67 6 160 67 4 161 67 1 163 67 9 164 67 7 167 67 1 168 67 3 172 67 7 178 67 1 179 67 1 182 67 28 183 67 1 193 67 1 194 67 1 198 67 3 222 67 2 228 67 4 235 67 1 236 67 1 237 67 1 238 67 1 1 68 1 4 68 15 6 68 1 8 68 1 32 68 1 36 68 1 43 68 1 44 68 1 54 68 5 64 68 1 74 68 1 90 68 1 91 68 23 92 68 32 93 68 76 94 68 1 95 68 1 96 68 10 98 68 3 99 68 4 100 68 2 101 68 6 103 68 1 104 68 5 108 68 1 109 68 1 110 68 1 112 68 1 113 68 1 114 68 1 115 68 1 116 68 2 117 68 1 120 68 1 121 68 10 122 68 4 123 68 4 124 68 5 125 68 1 126 68 76 128 68 15 129 68 8 130 68 3 131 68 3 132 68 2 133 68 1 134 68 3 135 68 18 136 68 6 138 68 1 140 68 7 141 68 1 145 68 1 146 68 1 147 68 2 148 68 3 149 68 1 150 68 1 151 68 2 152 68 4 153 68 2 155 68 2 156 68 3 157 68 1 159 68 2 163 68 4 164 68 5 166 68 1 172 68 5 173 68 1 177 68 1 178 68 1 182 68 3 198 68 1 202 68 1 211 68 1 228 68 1 239 68 1 3 69 1 4 69 19 6 69 2 8 69 1 9 69 1 26 69 1 27 69 1 33 69 1 44 69 2 54 69 13 59 69 1 62 69 1 72 69 4 91 69 4 92 69 17 93 69 42 96 69 6 97 69 1 98 69 2 99 69 8 101 69 4 104 69 28 112 69 1 113 69 3 114 69 2 115 69 4 116 69 2 121 69 23 122 69 7 123 69 2 124 69 3 125 69 3 126 69 42 127 69 1 128 69 19 129 69 10 130 69 4 131 69 5 132 69 3 133 69 2 134 69 9 135 69 29 136 69 1 137 69 1 140 69 10 141 69 3 143 69 1 144 69 1 145 69 32 146 69 3 147 69 4 148 69 5 149 69 1 151 69 6 152 69 1 153 69 2 154 69 1 155 69 1 156 69 4 157 69 1 161 69 1 163 69 5 164 69 8 166 69 6 167 69 1 168 69 1 169 69 1 171 69 1 172 69 4 173 69 1 179 69 1 180 69 1 182 69 6 183 69 1 198 69 1 221 69 1 225 69 1 233 69 1 237 69 3 4 70 104 6 70 11 8 70 5 9 70 4 12 70 1 23 70 2 31 70 1 32 70 1 33 70 4 39 70 2 48 70 1 49 70 1 54 70 2 57 70 1 63 70 1 64 70 1 68 70 1 72 70 2 77 70 1 78 70 1 80 70 2 90 70 2 93 70 114 96 70 7 97 70 1 98 70 4 99 70 4 100 70 3 101 70 2 104 70 13 109 70 2 112 70 1 113 70 6 115 70 3 121 70 37 123 70 1 124 70 5 125 70 6 126 70 114 127 70 2 128 70 104 129 70 50 130 70 9 131 70 1 132 70 10 133 70 11 134 70 26 135 70 125 137 70 3 138 70 5 139 70 1 140 70 18 141 70 43 142 70 1 143 70 8 146 70 3 147 70 5 148 70 1 149 70 1 151 70 6 152 70 4 153 70 7 154 70 3 155 70 2 156 70 5 157 70 2 158 70 1 159 70 3 160 70 1 163 70 2 164 70 3 165 70 2 166 70 4 168 70 4 169 70 1 171 70 4 172 70 25 173 70 1 174 70 1 177 70 1 178 70 2 182 70 3 183 70 1 185 70 1 193 70 1 198 70 2 211 70 1 214 70 1 215 70 1 217 70 1 231 70 1 237 70 1 4 71 1 44 71 1 70 71 8 92 71 3 93 71 3 100 71 1 126 71 3 128 71 1 129 71 1 135 71 5 143 71 1 156 71 3 159 71 1 172 71 1 181 71 43 182 71 18 183 71 4 184 71 14 185 71 11 186 71 1 187 71 8 188 71 6 189 71 14 190 71 5 191 71 8 192 71 1 193 71 2 194 71 3 195 71 6 196 71 3 197 71 4 198 71 2 199 71 3 200 71 4 201 71 4 202 71 3 203 71 5 204 71 4 206 71 5 207 71 2 208 71 1 70 72 5 91 72 1 93 72 1 126 72 1 135 72 1 147 72 1 156 72 4 172 72 2 181 72 41 182 72 8 183 72 4 184 72 11 185 72 3 186 72 5 187 72 3 188 72 5 189 72 5 190 72 3 191 72 2 192 72 3 193 72 5 195 72 4 196 72 3 197 72 3 200 72 1 201 72 1 202 72 1 203 72 1 206 72 4 210 72 41 9 73 1 33 73 1 67 73 1 70 73 4 84 73 1 93 73 1 126 73 1 136 73 1 142 73 1 153 73 1 156 73 2 181 73 36 182 73 12 183 73 2 184 73 14 185 73 13 186 73 3 187 73 2 188 73 9 189 73 8 190 73 5 192 73 3 193 73 4 194 73 1 195 73 4 196 73 2 197 73 5 198 73 1 199 73 2 200 73 2 202 73 4 203 73 4 204 73 3 205 73 3 206 73 1 207 73 4 208 73 1 209 73 6 236 73 1 70 74 10 88 74 1 153 74 1 156 74 6 164 74 1 172 74 3 181 74 55 182 74 18 183 74 2 184 74 18 185 74 8 186 74 3 187 74 2 188 74 10 189 74 11 190 74 5 191 74 12 192 74 2 193 74 4 194 74 2 195 74 3 196 74 3 197 74 2 198 74 2 199 74 7 201 74 4 202 74 1 203 74 2 204 74 4 205 74 1 206 74 4 209 74 1 235 74 2 4 75 2 70 75 11 93 75 1 103 75 1 104 75 1 126 75 1 128 75 2 135 75 5 140 75 1 152 75 1 153 75 1 156 75 3 166 75 1 174 75 1 181 75 58 182 75 18 183 75 2 184 75 23 185 75 8 186 75 2 187 75 3 188 75 7 189 75 15 190 75 2 191 75 8 192 75 3 193 75 1 194 75 1 195 75 4 196 75 2 197 75 14 198 75 1 199 75 4 200 75 2 201 75 2 202 75 3 203 75 4 204 75 8 205 75 1 210 75 2 219 75 1 4 76 1 25 76 1 27 76 1 36 76 1 44 76 1 70 76 30 91 76 1 101 76 2 108 76 1 116 76 1 128 76 1 135 76 1 142 76 2 156 76 17 166 76 1 172 76 2 181 76 54 182 76 28 183 76 15 184 76 62 185 76 29 186 76 7 187 76 9 188 76 23 189 76 6 190 76 42 191 76 7 192 76 11 193 76 6 194 76 14 195 76 3 196 76 9 197 76 32 198 76 10 200 76 3 201 76 6 202 76 8 203 76 1 204 76 1 205 76 2 207 76 20 208 76 25 209 76 26 210 76 1 224 76 1 228 76 1 236 76 1 238 76 1 4 77 1 70 77 8 128 77 1 135 77 3 156 77 3 172 77 3 181 77 66 182 77 11 183 77 2 184 77 9 185 77 3 186 77 3 187 77 3 188 77 12 189 77 4 190 77 2 191 77 3 192 77 6 194 77 2 195 77 4 197 77 2 198 77 37 199 77 1 200 77 1 201 77 2 203 77 4 204 77 2 205 77 1 206 77 1 207 77 2 209 77 1 45 78 1 70 78 5 156 78 6 164 78 1 174 78 1 176 78 1 181 78 34 182 78 13 183 78 1 184 78 14 185 78 6 186 78 1 187 78 3 188 78 6 189 78 3 190 78 1 191 78 2 192 78 5 193 78 4 195 78 20 199 78 3 200 78 2 201 78 2 202 78 13 203 78 1 205 78 2 207 78 2 208 78 3 210 78 1 4 79 2 49 79 1 70 79 9 128 79 2 156 79 4 172 79 4 174 79 1 181 79 30 182 79 16 183 79 3 184 79 6 185 79 5 186 79 1 187 79 4 188 79 11 189 79 5 190 79 2 191 79 6 192 79 3 194 79 4 195 79 5 196 79 1 197 79 8 198 79 2 199 79 5 200 79 4 202 79 2 205 79 3 207 79 1 208 79 1 210 79 1 4 80 7 6 80 1 13 80 1 26 80 1 43 80 1 44 80 1 45 80 1 60 80 1 65 80 1 70 80 2 91 80 2 92 80 7 93 80 22 96 80 14 98 80 6 99 80 2 100 80 3 101 80 3 103 80 1 104 80 10 111 80 3 112 80 1 113 80 3 114 80 1 115 80 2 116 80 1 117 80 1 120 80 4 121 80 5 123 80 1 124 80 1 125 80 3 126 80 22 128 80 7 129 80 5 132 80 1 133 80 1 134 80 4 135 80 16 136 80 5 140 80 4 141 80 3 142 80 2 146 80 4 148 80 1 151 80 7 152 80 5 153 80 1 154 80 1 155 80 1 156 80 3 158 80 2 159 80 3 160 80 1 163 80 1 164 80 4 166 80 1 168 80 1 171 80 1 172 80 7 174 80 1 178 80 1 179 80 1 181 80 6 182 80 9 183 80 2 185 80 2 186 80 2 187 80 2 188 80 1 189 80 2 190 80 1 193 80 1 194 80 1 198 80 3 199 80 2 204 80 1 208 80 1 209 80 1 210 80 1 231 80 1 Seurat/tests/testdata/barcodes.tsv0000644000176200001440000000264013527073365017025 0ustar liggesusersATGCCAGAACGACT-1 CATGGCCTGTGCAT-1 GAACCTGATGAACC-1 TGACTGGATTCTCA-1 AGTCAGACTGCACA-1 TCTGATACACGTGT-1 TGGTATCTAAACAG-1 GCAGCTCTGTTTCT-1 GATATAACACGCAT-1 AATGTTGACAGTCA-1 AGGTCATGAGTGTC-1 AGAGATGATCTCGC-1 GGGTAACTCTAGTG-1 CATGAGACACGGGA-1 TACGCCACTCCGAA-1 CTAAACCTGTGCAT-1 GTAAGCACTCATTC-1 TTGGTACTGAATCC-1 CATCATACGGAGCA-1 TACATCACGCTAAC-1 TTACCATGAATCGC-1 ATAGGAGAAACAGA-1 GCGCACGACTTTAC-1 ACTCGCACGAAAGT-1 ATTACCTGCCTTAT-1 CCCAACTGCAATCG-1 AAATTCGAATCACG-1 CCATCCGATTCGCC-1 TCCACTCTGAGCTT-1 CATCAGGATGCACA-1 CTAAACCTCTGACA-1 GATAGAGAAGGGTG-1 CTAACGGAACCGAT-1 AGATATACCCGTAA-1 TACTCTGAATCGAC-1 GCGCATCTTGCTCC-1 GTTGACGATATCGG-1 ACAGGTACTGGTGT-1 GGCATATGCTTATC-1 CATTACACCAACTG-1 TAGGGACTGAACTC-1 GCTCCATGAGAAGT-1 TACAATGATGCTAG-1 CTTCATGACCGAAT-1 CTGCCAACAGGAGC-1 TTGCATTGAGCTAC-1 AAGCAAGAGCTTAG-1 CGGCACGAACTCAG-1 GGTGGAGATTACTC-1 GGCCGATGTACTCT-1 CGTAGCCTGTATGC-1 TGAGCTGAATGCTG-1 CCTATAACGAGACG-1 ATAAGTTGGTACGT-1 AAGCGACTTTGACG-1 ACCAGTGAATACCG-1 ATTGCACTTGCTTT-1 CTAGGTGATGGTTG-1 GCACTAGACCTTTA-1 CATGCGCTAGTCAC-1 TTGAGGACTACGCA-1 ATACCACTCTAAGC-1 CATATAGACTAAGC-1 TTTAGCTGTACTCT-1 GACATTCTCCACCT-1 ACGTGATGCCATGA-1 ATTGTAGATTCCCG-1 GATAGAGATCACGA-1 AATGCGTGGACGGA-1 GCGTAAACACGGTT-1 ATTCAGCTCATTGG-1 GGCATATGGGGAGT-1 ATCATCTGACACCA-1 GTCATACTTCGCCT-1 TTACGTACGTTCAG-1 GAGTTGTGGTAGCT-1 GACGCTCTCTCTCG-1 AGTCTTACTTCGGA-1 GGAACACTTCAGAC-1 CTTGATTGATCTTC-1 Seurat/tests/testdata/nbt_small.Rdata0000644000176200001440000133013713527073365017443 0ustar liggesusersVŹ?K[Xzea"xTQJP@ v^b5&7hnM175h$&^b)]3Ϝyg̜s]IV9=e)2zf3WV-ZիUVZwټսV-tij5 Ac߮,lm)5lj^`Y=9ܺ'im|=e nsZ3n'& _Www+0dh|(g #~bb0fӎDP|ri>ޜjwxq gp>㟣MwAuo\ cyz^?_n{|}Fm1^~ׯ+kuy*8"kr/o}p!LsՏ׽5|] D_Ν^9ű_t~~Q"SyqW8Nlnu-X6U-+qopT}P3Ή_5n".-߻{Y?<Wv~Mז&gq:0~}n:>oyb>kVF~ngz[Z>b)2C]o?),uu>o+k yjhݼFk/W~@D~q|g 8SKEa %MK}wj#5uBK^oј~u"/jdBPW?Me }d`x__`~7G\o*zvL>yxPH;>?<{O&P6gN޹){<]r֯ nPeI wG]bXO YWdmŸD~i/lv<:(ާ&:FPu$-U ?ym*~ӊĺ!ZRk[Gfp@bg>a=I7CmvMw3O}gnZ1J:Xq<4~Qg@}/~̫c~5g|o >~S0N8^t?y)(84L GQB+"W$[=-jӂD3c/&/a|.u5nbhij/{ gOXQGU &xGsKq_ɰq1O[M~?Z?T'~\8N} ~՟ytKˈ~(ەlvsgk3?KLu6AC?~nmZo#R>d?gv!>ق} 9wAy<E eLW7; \I<Ƽ+h#E xduȡypP<~v?Ց∏h_0PtU7uO Vq1܂ o!폩ńOucbb:4Tgy/_Zt<1P'Oˤ9Oj]}h.Wdwvu7fӀ\/)>Zc/!-C vL/fx=ǰ籮B}_֝㗾P—" 뾫P&|yZ[IǽQ͓xy%ſTEIuEIqޑz<Ń(5pn8JO܅-OZ.3-|'OyMC`w݉#f9ڿXzA:zxU?+?W'߅5c}}]x]9\C*Ы/p'~ok#Ђ &7 MkpG}e=8dG_Yk1rpa?֟半mꏽ7_ +?p]p-¯vRwg^F<a:q-m[p?|77A?ҽn:WػWq܉[ S׼ % q s'd5fg\mΧ@_:/Aٶ:g$w6< ol2}s$^ux 'G?3-E~nGnWH[ͣ3AFD뺔Rq3])؅;\?bKXﯸ)o$&u68[Kg Wd/'SJxo* +h4:ZW ZQ|'Ӹ1w;:u|5eqbh! ?Q 7J||w5N_{9B=v/])4pǧSCpmC{ǩneg4/ӉC] [C/y웖%;N)|% 0Mo|38^>]{Ot>kZ'e0 pXd^7؎O_ |'{/~̏WS >ů2/TFo|& n6Zp[~ ;[xwG!&E[钧IN=ONNq{Jǐ ,Jw8ad/\lwr/y<~ހ UU$>87`&C+?އM>cZzI=X!Q>Bߛ.]OQo6>SL\WW>I |Vl~ꦣAG_<xiH?6D<ьZ0Tx,uK=9^ͣy.z]L$֙N? azY ;ߙu ?W]BquԤ߅˓`(Ƅ7_߳m2vPq!w:{~Pƈcjl'֧oKn8_9ɢ;(PG*⿹"x'{1}c @-ʟ.wRՅؿ g{zEw?/dHl6fuwZGn+nXޣϯ>y1O=t~ xQb?2ϺQFG=yiܳ][{"~-}DDp--q|3KUot[{$;:;Au܄cR>e1V J>,,TggE$hS]w˾ ȷ[PS6;+4o}91-t=&+ֺBGshFnLSi~k"]!Pa|35?:/D]]߲mt1y:̖gͩj=~cկ<_J0^qo^]\2=nӅG#ΡMsYFu' 9n+<;|2}>)'Πz[ #`ym?G')O ~#޳SXcnyUa0~,ԧYaNKO&[gڶ^%{n#PN,V K7[eٵ{ מT_:NEx2u>G{hRUc cC'=1޿h]\7#wWgok3zr *b ۬jd2a2oaw |ӹD^kAo-uoT 0; Pj+ S(0NS>mT>9t5Ϲ 2Χf2]nEsH˙7 \#ޓ>0?Fs'r\#3b7ǹlŜ樇қR}G-봝qv._qnnuBtfWG=W/$+Q3¥OeGtAqhj#N|pk̻( kMNZ/-h-ד$J2wu\bέn^O 5/M\'cZ&*&uOI?Oz>p(i[ûuREٺٙ?}M?>Ed׆OxMWǢ,}! .uո>[2X#;jeyjūƙ1?ui1;|ZזPVp({B!v~C9<~ g@h=~0i4\-0Z2\>]*Gb3N7~<_Tdi|6mr+Lxl+ŏ/6h<;ڨS1_8z8㺬hS_Ɛ VL_\_;"}D\'{;T<3-sAE~"aEd(V߃q0RG{cNR>Xh~`o3~? yVs~,>j9'统n5_P3NJ|.pV&p|^,<V7 JuqW 7VUцUIēu9tR|&8o;Iz47wf=ѢhϧF?nugnikJl*ׯYMsE|h<ΈI}foP뎖N>(0FM2$y~R n<{5WُSq4/E:uϔUtTᚯw K,R-yvz}/ ?%jq [ n}8~+G??7Cה'yz<{o]JyUB{%eq=%Um48=>Cz~Ǖ}%9WOqt9gl]FI㢹&!rqew?I։G?d֤S$;5ӎL>4ٮrbs9>[|h^ʓ+yXFkĕPW:2&p} p*k:ЯXXկ﮺?[ј7Ÿ>6<%+euZǘ.K|Ugٛa,lE [։y& } ({V-7" PݺE8(&'Ɓ`ӣ)Wt[s1O¸q%u EA p Eu:ܯg2[7D_5W bD7_O\C1!!##/f5LMϤO5I/mδ OD3O?=U M}UagtwD̈|_m^xA_QLݹ=s~k|{, uR(Y>.O%yy|юYK}1(Z/;ͳgu&̟-q9,KT~phxD"u%p?g o]3%^濄:駅!بskS޵7g2XEyM%ƤPцb=_\v9S;:FOˋs;"μKNC~qf?Ŭp]Y͡g7%WR5<#y`7><\ ;^PAǾxh0֙Z\zjx|/µE/u>ZO{EGh<$?d^ʒ%{yLpD'Ȓ^V=޹+[dW~ԧ]T8͛-|#obx/E_/WCC7?_ӯ|rc>1"<ƶЮh뿙.Y'~ׅ:L/lj~41۽T8|Ew-4|B6 =s/Ϋp'9sTG>SŞ8k4NGOO}0G&*&ݾyx,}/S~z}KeB%MKv3?웲pome&92ܰ*7QW=>O\yIvR<ƿGgꇅuOO ױ zy滉|0\GOQ%9>H㭇R]7q;Xqgق% !u-CB14<=ig:6;ui,y0_XVB2.֙<1 ƒO$5LkytXM~&561.0~rz{~9F~gֽz\߰:w<>xڧ¢?ׂ>GK}0KԵtԱq+}g۰[Z*Lm:i2]M)t¥qb$PϬKTsUxs:رN70귊b_dO>TF Nxyհtg~Rdf?O߷0iOy[S8^p3?W[fOwK q|+e:q$dӉY+`"kc=մ,9[^ C+,C׾G.GM0Ze8<oEݱ8 +6L:<.tbuↆ<Uyd=-=י|?e|ވ[Mf#8g &M2gq'u$ /ckcb."7]Ix5-׺~En+Kx,D(߸Kt^:f}V!]Lcniyl\wC]mӽ u_G)릾m%.h,Ckq݃,?!xz> g2\짆y"ṟgG2zyWW8Ekg~*ȱNY#f=٭o wd]bqR-0 G]#ÇC>EpvXvwKDyAYpڧ5av⿌\AZϰg{ncr;&Kbs&.^K@~Zmq{x= pL zj%q4Lr'{w],#F~(oF}q]V&2ߛEuLZJ8jXC??pQW}z疟̡>>^e<7d׸}?aU=f/ {Gn-5. B=\U|_̟P\ /ri!R7|ĽgF6,q9rK`Ԋ7]{Sלs65ǽ}V|7ءO 5#a!^,?@ٳ|_}ЖՉ['nz)z^&u#9a?wq!1<mKO!w9b7"üЂ,u翻.7p?~]B ->OK\ϟ~@7sÿfއlfp=F@{Sp;y~V6_YL: #FVqUVeUohjG\-ؓ]\vږZeUVeUVeUVeUVeUVeUVeUVeUVeUVeUVeUVeUVeUVeUVeUVeUVen.gGL{Ut4R /!>nw`-,.,зko:[/W^}vzḤ{ ]kOzMՑgUtx=3G>O'C ׺mKSӏ?oW՛ĠG|޽Cfz[Ï.ytW3ymB`SԫT=rq>_yO ~Qh^yڿAvu$0'^iqSOD7S >W?8cîx(W>(I>\,[(u/Xne">)> ao ,WT[~N]Q3D,KuۿWcXp3zu%銘t_8_mhS\7 7\sIsҋ@UkR*q_z]:/K6-.8u$('-a_Kp1y |II.{P~))Xw#ʶ:P?O}y0|q}rYD1"&鯇Ѽl_~3(oZ [ʯiuǝhz^mA^{&i\}ceUkŠy'싃Z W$s>5ӡv‚Fz-!E>($ݡz3%WTx:OxnB]1[ - F$2.0ZŒ?(_mDh/q)Y'cb>\31(^5EiSGHs\&e,P;Y#G[TK-g`qM)2L5]QW/:o|3}v]w>B7gyVUwbOUzNկN~bUMSy/4Hk0BaK'NRϋ-.y{yźp}5q_RZ8o.#2?|=Qn}YS79/#GMC_=+~? cgbbԏ?-uq_ļ~WMc-cпޠS~u=X[u^0OW/a}1q1x^Ħˎ _׏(vv&=K&Em}wq y5S~/"~km7w3K䩆uzJϊ(zէ"5zQa.+p`z?=F0m4/s:kt_q.-z?[TWG+jh>91o~ӠӉy|RWO-+}0W0DUK>Za3S{ҧE|kS 8eοub"}Vqӂ5EwXybL{*YT|@:ZP5 }^~NoG,٧%>2| |ކ SlnZ?=Oi./˸#2[yR_&Y :1=YF/0]=7-]c놁ROS*eغtwq ~ɂnbȷc ߆.jTGcv/?nMm(:-AJJ6zyt0c|-~6=^t/TYUYUY;Yp(;ʪ5ū@w!CA#{k(5e _Ko/~{TLN"ƒE3bսʐkgX΃C^᫂C,pKlS( >6^7_Qֵ%?!!RypDɐ6{=gI-8ffla7na׋lW:Ou]눬>M: e<Y0ng+jocQ} ))%j!™eC &Ak~%MK$ , /ӫߝ1AF^;ĺ."Iq2R/KD>"Y_;UB ؠ-C]v|z)"mwmO{Z?Ղ>z3x17<;};yGgGw7oRŪGos,Uq[zנ;9c1yg;q)=Capܚkv@}ޥ.OkqC؃OׁyBO/yOQ^<1ljn|?O\lI721IqͿ}4P~Dgwk::8Y꺲90]buNy{_ cvpX8 l.SU" sV}HOux2Hɧݘ?x O縦,q.jI83n]tˋ>`EkX CY^\- 7"ռX;~[扺xc6/^w>_ziG1 ;rŸ_;,.40zPWS3֨U7IW#SN ]Po?! n6MFKک;I+r uGwS GKU(w~"rp.vӢ6/Oh[~9O,֤go^; |yotefer9Mj(?g'#EnWt#h-< d yKn:-,/>GxV(K.2Jyq^ :\2?k_=7x ~zb^uG[JZFn}|y?ōLUE]F"6+~uULgܨ{` ,oPG~Ԧo>'=|vB2gIKz.x(:cp,!Yϟw((8蟳W&Qpj5r<x|n:m/0[ ^ׯ^Ա>qz V)"^FWCd{hA柂i] =[c}?c Z0u#, :|\ky%z]CWVwt6kuSuq= ,fx\qb`MKn~FqN>;&kDx*nelg g M%U~~^8N[0s{_ Zo܍O-\WQo1fq|2t; ]Œo|R=mx?ãʴ?ӽD aOE"Fa}c]A(43Ծ$w ^y~}8RX3T_.{٥b!(ֵ Zߺ=E|4`s1,:_qZ,eDcw/7+;zwj7Ps]} pmšW)TOj 'r~[G87WoSl+gwݦ{^q}7mסA#Iiqޥ>GzsPHk׈ijNܹ/%E(u6e<'6xway9hXNgy{^u>ՙ:395"a`{Ήοf'㺜,={D?`hm/3ެ̛UHNv&C#V:}?GM [G*'fz\+_}^}x`e^sQ!#*G\?naIgbq#Segv{Ac9:-|/:u[)i?Ao W(pe毘,czklj~zNhDÅ+_,-3ͣ|+2Ќɳ\x|9y8c9Z_8ًE pt[8x \K}xP=Bc-wau{@F@XR= nUpЛuiceN_>:9xЊt\˻uB-ɲy]]=G@6ꡮ)m_d>DW[66~~qD'mK2M^WYa>~5SlA^HVG}^U=)V 0Q?G,uӄ^!kAWco@0;}K_ߜ_赿N}9CU(8Ly!#t#z*ּۣCɞ ߺ5ԺT5[E|LY<{mqqGKW\_)M?ϩٚ>~=ZC}o[1˨?P ךɊNƨGXn^?{2OW'җz`̤ e}XzN U\ >-mp8M+q| qSq+n[FGq ֩zhU.1kٖ-?"pDžm:؊ ۯ](I OdtS|K=\Ȗ]:C5rTt=̦?gӯ+Ek|7={q< %+ίp 0@n0ě0/[r紾:3-Vם޳QW~/'Z#nLz#դNsM uyn/ԟU>/Z[OЌl\> O_)oO@e2e_\S_ʶࠁ?vb3}x_pğlZWc}[hboTľe{+"O8A;Y}/Ւ΢&ʼn7uyxqog#j_Q{U֗z^,<>̓GW4Wk)jcGC?7LkIjFKſ }qы͹"|#*2+k}u=Skİ>,)qk#F{/[T5z|sܵS]woґwl'ts?X~ jm>a`h_zS=/맬+k8c_]b Leu"7ϫˣn<|a8M2!<"&Mu:ăK+Q 34fŚԈ6pە\ڝ0]/>xdʦ9K^yZ }qKh?-e4Yc:HmHs/Fru&TOW㖊qJno^fY=Wx+?;kqPl%hAq*;wU=SJ1˸,:*=qb+ﯘe#Oq}FI%4uđ^'vhsSOR]Џ~ i hNx4ܯ;<%6_.vIdU'O9e]hUpP_b y6-}j} +_޽=Kktɯ'v#58#5 w_}K&ME/9kV ^\߿3|ߊpUgO~J:1։']K6L!ʔW|PÅLWK;3}5xmN'nv}+jp15SWx;E[[H+WKH~ -?"ο{>xh>Bo7=3.j<[z yl )Vﺻ_V7Ċ?l< -ܶ }]-D?>;ļ?k9]\C}~|/J<ߞYؔ#brwuH-5HzbSy܆BmOMjOZ`G 1BB]Co3)2,9WB*k.?`Ks1;O?-KGon~ގ' }d^o?~%G~⹟}}0c+/Cit\Tuom/X~z3 #ry wkKGԘ6~柠[>Yݭ#"}Hl=]\Q5zK'_e糲>^@}[zv)H٧ ŵxQt={.d%t$<lAz\7>?sX<'[*CE|!S`ЍGֿŬ~go.uc K?(S{5@:`ҟö'/J}=xՃ/c|knظNgaʷ㌷E<y uh,d<ՄD-w=?;}&YD}/n| oYDŽk- |tB$z]P}Y?N8w}v;D篱27{8IW 1|Jp4]Lq\ĝ`ζ;+NH̃-pЛ~z?uqyua;U:9s70l6 euh}`MXyݸ}j'=:&jt0l;XlI>.}zIS>d~1gZxp }X=^}R|ਏ,F(6CѺO8ʡ"`}ADk N.hR ]L\+Qٟ]֦:&õ³.Ym}^q X+'V7%ߌ~&?}~eDzzb#z7G%_b7Mx&; {sV t@l9g3 zXWwrH?4c>ٰ%?g?'_ͳ\w.ps]tq}_Qq;wߪ-zz}sǩm/1\G|<~"|+uЍp]7=Lj$O,e|l}bBz?>QǓɿ8nk6NkÐ':9~|Qc~A[OSpz2o:^P5Nu߷0XoCmag#zL;DYR?>|WwQ|/ɃN^.gVrIg=Md9y.3q$W/ɒ}$01; .9Bx8(Ͽxi=Euպf_}1v\Oد) eW e}{_t[+~9l_FKSӐjPCTyԽ> Uk13W|ɋ`_ptɓuou4VߩL dydzq~&ա {|.yU_⶛U^懓4F!flc7M/?q~P@qp;ЄG8:N \5.+#מ&_>q |JycP 7]a}Fo3elC1Нb|q4wBrm1zS=2_!# ÇRE0Q՟/:n~}>L T'juz2z}fgudyj~D'OE#ߦz17 Y+oEW{ 7YCꖆPߏ{y=j7DO&^:XZ. CЯ5VmMePw5?녿R=O#ȐCl8LW#XFù\l;)Lgq-}~Z3G&^)$Ps㚩lݯ婔dwokio ܃/w Qo~q N 2mӌN%>ץ' ߰P/V翤H3_w^s!Szz}\Ctrz2]=䧣l3׸SoH2p|~ LCL} .Λ=&],3WM?="?%ЎYnѵG {kκE޼Nϥ*,I'a/uCǖQ}%WPBޟZp(tcSYe_+}jIFЋp5OW f7u<,/A-8D~5f9&mvpqԛL$% _|JǙ} yӄw mN}8~1-y62oŝ|0spH^bf΋-Oi{nWBĹ P?р9_p;>2< 񷰳mz>x &XtʺDC{^W5ib>}Pp#_xx,oB'z7.I[E.xM}>Ӽ"R:=qk% y4d(f/k'먦6?k:I|{8F&z^=&>pw&ŕML-;:mb)~zga?uh*ˣf>> kӭkëe躽 !svfÎqy?Yf=^w==J>pUo<fFj̾4P.Z!ț᪟ߎxGuyd8 d uSG<`Ÿb]?O">7Oc:ip H5Ī"' вG8fY({'+ ^Cd~L\uLK6 úWNE+-y6~bG_ZZ^N5 u>s0S|uߌ 幄ǽxt}zzZ6HG7T-ߗm]wq uc1LoП;ֹ@N~q97MV(UYq=D5u캖8?ܓ~$rp6Ł\OSMgwΓv}TA>wTn)xhy| xN~6+:Ep=>CL8~u<ǥxyWlF ﰙFsak$8_nvc"mCES7-VF#ϟDȴ8 K(C]qHc1x4s[gqWa4ެs> ϴ:o< [ߩ I3% |_L2Vl[kЅNWH\qR7x#G~X']\'OkϑU/y]cӀG05+*ZQ#H{\\XiWʭIE?е<ų8j҇Ck{_|P{_qL7?N481c*oñ~1N|0.pw<}At|aܾAr~}}RO[zWmYJqMup[ϊ{+WÝRyOdKܭ8udžXd-V^Ϸ^\Sy =C@qpܒtp;O_S?7ϫ\=x>`ZE^: r>Ƌ-雡(_4yOnN:8ꟲ;U&лI"?,1*o')6|[az]WlE7&7nx,lOOo{ȼHXW=w[x:zd{^u>>R'[Ǭ]Ju,'w>'tcܚ yK|{ T/.I/pt (< u'<ozgmչX XѺv `{/z/Y}H7xvNy\MBupmNuV]Uw1:{~P TOjah08._ )ǦU߯xl\}ԑC/;&hv)YnZ=ytӪwQ*mW.XWoys ZG^&ߍu-oO׷_ߗ^궸` q>,-ky8d_]PqfVqc[nu|wbk1t>܌vVouκK>U?&QTCdjKR'}?yJyۣ󛋾*.%cq%xH=߆sōOnԱO>qbaz'Mi>cA\orvwW뚡grK,52c;֧CG5=wy~BۅAT=߭䶿a'qsO'ho?cF֗ߋ}nlg..{yaF5+/13xNGKSg%}^NAǀ, :јKy>]qwߢI:(HK )PoքuQ<QqTya2J3쓉8)R>węj\.u%0TI ??íӋ ^ǮI>\=S`H b֙&Soґ #OK}7t5:z1>ˣ--0C.MYMGr^ jG3%qG<|=к_^I#j{kpգKC=1x_)TWMu&cu .R}xegE~_صu#a(ct~-bez}{~^7.6ů}OUCKCJ}[$Et.ct K^C'lxpbx2䤣w=+Wo qϾDK[k2ae ._lĘ㌺+|4w_MJY ~;F y;4 |humM~#z]1CՃLb.q//SpBDs'[u ^ٌo}c :G3f2u*&~22퓌VV9GwCݛ Uݎ١p>T(tÅI]ph!גwa~:=?&>#b*CΎSTEh/*TGpƕxS3@d}_~B]φvJm&\}ǗAj|qoE6p>^oC(_}16uoA[ )Sk8dCߕ/6eXVꅾ\9^X+:Tϸ/{j/wXǮD֦=u2:x୓Ч.S.b:A}|fK2MwxK%Ol|-Orceb?81VU_XRvy*ry~D;A>^rMsn>2GsX+ɨo*Y uu<Ej>l7uK܏Gto?Tx<CI?GjA:$敓]W pxjċÆ<^=>7i;/56Gu~3|`R+z]Ɩ:"hwٯeW(i^ ?\.^ ۆ*^08LqQ}VhO=,v~W1gs.:Ox&1}}WSҡ#_Y#|xneY_zC5ԥҚT7 QK>jS|@Qd3\:~RooP_?GcIk>ܾ8>_s6amJ>F_psQYfxnsX:e\yg(y@_w~QsqJnQ,SU=Sф TB}Kxu:c3,yh4NyYq߫'Ed7Tgk-_J#Zou|?SqOMNQZ轆ģLV5 Q`#/3t'#xN:Ť J"wǣ_D̓wO `AOl'G~;W;o^BeŬU}1鵠 Zm2x"\}5WF>Ku}oSZ' ?Wq § E~:+KF/NtHI#G~IS6n-hݠַkKOBx+Cs("9㑢sȟr?ճ&NU9`B<0 V68?U M?<?&^%pYuj1Yp ;[U|< Bm;`_fl_'/NE< 8Kюcx&;TsGjdzglw.Λ#DAUMOQ讹Ґ;~WT7an>oijש{S̓ڈy>nlAzR/o  ԏ^oPx2: w:o3)a8t>!rNO|DG ~ dhX j᎞OyE W~  =e? _lͥp%|vBMg?a7"\ٺk<}k߿6Yo^hIWwihn^>?^`dpRMn0^OMJR x8)^wH|Y)e?z/F:Y"9ju;ݠuzM?W⭭ӌz\#lc~q'Qd5&=7aD ۖ7 A}$zJel}=Es|b_]TgM:vR k%Wt]n}>HO@wRs3D͟AYW?y~]m rkmy[1o./Vw;Mp2E[7T'}aW*:3alyv(]Hw`p#I-ķut9tǞ1)5ne |aUuRǻD} ==Dž#7?ecgO:]h@mslwDq͇;r%ܑ?D KӺ#(ӱ<#ނps1ut!b8JøA<W_~jU4A =N < >rO׫)ak2݂+ŀ%7~8N?. L5n<>_3M"l2'xj`Ly=j10O"|k߼g|?=K::aEC}qYBd>W^>MNgG6絣XDS߰r**|C_ 齌__ /cYKqBC_.-ngޟ>L8Nq?&i } M82=cvsf vuW/&uqmВ8^]Qvm_-}rHCa}=tdt򾢍]ShW7!/\η~#}S7cMCݦu=}?i~˗"8?nܕԜ# ~{of <oxźEg}PO]GЈt Z hPK^qb?ǭ,Q߀tm:g5ܢ&' eԲߜN~x mAG|dޔmC!{,M>p-Ga;uɑwteLڌkmoգy=t>U>n*ip8 MۯG׼(/+^mӭ/kbAԦg]׬\N6'ͩ hN'͢С}Q%(鿏D+ yq03Y\1R/";>yU[I] tHVs|WQ4$~i_9l:hs8hjֳ| # }ƺ$q >ָ2}n̸:5T7_WǵGg_Y;Ww䗠e}V1̓G?}cVL+: ﷇ'(::h>8ںx=&x/.>#QoŘY]Ǹ:,>TR9z(k`oܸnFu`~6:<`DZNzKϺ엓O'{u窻j7x%oZN /~L+AxMY] l1K.xJ[{:'zTٗϺTcɏK\8׿/w0u76LUYFRbg͛5w1ug4Hq3_(o Ѓ~' 4ݾWaG 5W ,ge't]uH#=cep/#c_}1ROh⎥/u㯾{j}kܾčG,T 7.Wׅx }/[`$֥Gzǭ᡿ |2Ѝ97_JZ]6XgNz_~X":AO^kyh}q >3_w5"zQx^{oa u D~yI5~=7aptzxuX{+vXKVE; zBá'7@W7QUe݊k1LhB:#΢NrњzF ޔDOOh 9wWl}DqJ}Mwp?}y a7fņ/#q딗ǒ|=LaN}imo~F׻Q**(CSC_.I]>*;9 =qUVeUVeUVeUVeUVeUVeUVeUVeUVeUVeUVeUVeUVeUVeUVeUVe'ͬwqί}ʓia>Y8/lҁgul\3aB$ѧfÔ ^_g}x}P`4˗zhKݒG,20֚*툷0Ae|ih﨓g[r|4_zv=̺{J70,z_0׻wԿO}Pk9鯓>Bl)3|ܐ(27=h3O6־/Wp> ~)8P~}NTӰFm㦃bzm}S Yu^饱tBЈ*1`_.<8*;;F s2‡[|('YTχ+ݮƬofpܱ/G?Z[xlh>AZ/^&~C*00W FM?^OŸqx^<IHpt9B-~bچnbuStajмr.y|DQ,r;)׊Cc97xӠ Sѡ?2±B3H5\l:!n\QByI+}9lo/keÐj~x鿋~V~nwk[?4ί54%=v?^ϳyI thdBoWѪgM2v>sԙ u9Zʼi>ȬiMئLAףkz=zQ"]Rq5żz>M }iOuX~v>}ռE Mֻ˶)ysmpTAa>e I}W5qg;J}=soL[͢#%:1鮯e~vsЅ;g~u l5Pێu=AQgkFu:hIMY2ηH=3z&J|ƻkzKZ>:&J.tCJzo>x<9Gc<ޯuܒ^%ƣCZ*# y|Y{Z&Bj)#^)j^xy_p4" 'lg~yOlɠcV>NP]U~r5u&`_},p#?UD—2GK$pcO ~NdMW1Mm\wnJ~QGY&݌e} >53p#YI|t^9E÷^/MqWnqsx5Iy<~Vԍ\]qi6%CڠbgMAL)pOm |tpoD}{st̴L~WBx?gP&xX~^O#~yۤKb>01oh/1o{euW|E?=?sM[P̀;6^p*VLX# Fc/|JkW=ԦN~sRLoW Ӎҽ_uAwԄQ|1j% qB'6lO R:u+Ktc~y/89?P`ؿtİ~]#+|\ͣ^X~rFfM[a=JduI*qJy.dN:@eF鄙L@] nQ]6u5 ~Ν.z}/"T3^珈?7/>1eY[zR,r!2%x3|1:ndߢ9Jc[ըc?a~kuzX%/Ϡ[a=韹bO{i}G6$~HM'16Y[<3Q] v3ɟ RHCӘxbחKp1qTާJ}6<1nc#؛.tǏnqu&x~y?ibS}x5HO:˯tlyJ_cwrӉK۰}Pt|00/ >4'&nfX֏'ݠr1ig_g<ٻc+P3=ŋYp?jUp jﻗNEVw.fwdWwQʀc3uz\NMJ-;`:ϸ^Ô|X. ]²Ŗ,w0s^W3cYR}6ߠB`W\xTEEwNI, qpqYcz]='WWu9Ey/OyPfo£Ab(fn]l?e_ng \#/gqM l .u8/A'7c~|g}Xo1h?~]F~}oȦ/ߍnFL?p]Ӿ+J8wƱwc~"}M俠~]6݈ mS֏דˤ;o%8:'[xNl= >~tvԅ04YT5ەzn0YGhQg`Kw;*Kl8KsGwH u p~+| &Mu5xU~"拹}>OQp+X2|yodp8x#T=>EsT]}d=_Ȍ?~XXb_6wRI)"-Sr2qm']|̑gO|Qo{xxY,|OqsZ:Z6-y.ۓ+q(N"nOt?hۓ:,$Z&~B b;m]wyO-;.c>ʿRs(<>;su;s?P\]E낻<3OĿ:]_ػO{QϷc|E(05jxP߿~?Tn<˹'b˖'Jky!>1i^FQT+S:.λBy^+h,$<Ɨn~/~,W1c O8'<3yg`}x"iϦuk >6 =,pyJՁu5>gd3wawwY}B8a#h9Fh` OI}dS?l(2t^;Qc_B˦ဇppg'<>\R^uX7C/-- {5YᎧ?ן'^2whЛ7/nR3 VfsG?/%= G}G ^ۤp.~<+} +SϟF] G(yȘ>gӢ-/Igc;8fJ *G瞛ijG(/r 1y53rt071|Nyobq8oJg_s>ŁX/Jp 1~C*W:A+0CKo] F*QBȏgJ_q8K=7⛚zN:9 Ɛ GV;Ӄz~a<._8t>O.qEy|vzD33qͦg2ɓJz|MIz]`vqد[,&s5eWny󈋯7:q~>q{ꪛ -}Gkog|9#;{=>j-ȯa ?y 5>Ŧ]z'O2ۆ^/(UW_)܏pa;OLP$t/ьn {^*;8l_p?Oyx__T\ڕ'bzXX_,\qd6\?9'ŕg3cg_+hJ[R\Ϻ)ŁotwG*Z6/_8jS?>T>gzlA7z_5SKm|v٩ɵJڃ vj܉9>goBם>CLR"Sł\Ws >Q;R4RG+-] 9%c5;9*****a/Yܽ7:.<' >݉0)xq*p;^n3M:2hsO|>CŜ'T2W}w#D_O&RS5FMɯgȻ:][ P^.r:2= G ]!\z[GwCPy A'"c_@U0J!7\R1E4_?z&폗GޯUԟd1^>WlKYV'tڶ 8ST_͎7]}ݟU-mp& lN$#g &Ő5j]{׿AuŸ~vao_Bݷ>[/3ю՝r)QXm-`AGC?~~ȋsA<Ꞹgg(4ȟ' :{Gx.#ibWuq뺦yنS€C ~#w2ORӬgq+/'f4<uϏ n뤁_s;βz]~ƗŕQ 7[~$CUlKe1}R?Tn8ts|j_󍟨x%E/\m=x_fXQ2VԉMc|/=cX8Rǣ #?E[qL;y|Yˠqj_]8|tIėV,?~ε^|l<u4cJد5mW O8>4AH,y(p[oQñ#~?I͕g! 9G^xAW9lo}.gJ}U} :ި&4z}G#?OL&ҿz[Ktby|z[e|naV$뿐C|Î 9ۍO ]|_7OLTg5oT d31u,&JͣLRH$xrEtݢy y%ozQԗU,q~7)x,τ;:kZ:9fMO [ޫEoq>߭ض>>{5+g郙tݯ/MIf_?gS_Ip>S/nS'[_Q`[4i立FLؒJ$*:]o=O;_YcqtM1>i+ts?V8^Ivʸh<ϧ6Hs5Yy]SP/:G|hWdmyE%mq~YcUM5'(^)x-ޏǻQỌ߸ZlΎqdOIU\#XL1H}Tg}o'~Uچf~Fgy?Iu54"e*.[^4~8_' ɎoKujYeO>l/nyI5g(4 |t3,O(/ sq0FCC߈yR?nɀg]qs}q}kBtg>FvozT=U&?ZNjMr[xyuoCv#ku+ѻaP4WX'+Ư/:_)J :hHDa{geq*iߺwG{#f0(=Ϲ4w(W:)횇fRQ&H-ҝdH y]4udm3[3:ZDS(`|vGTԗ'\-iEW㲮L߭(;9ݳOp zgqڬ:cT+n6nUG<&?dW]~G2A1 1!C8i|u+}ȼ)>-q^пǼ=~@b8ՙӺxW/u>"2_+qI,2+'%v?y>u7es<ݡ%~:JR>KI' ÍLӮs#?o<nHq3p-0m)[_x(?P897udhxLk]?݃EZc}3=M5 q&r{ǰA1ri᱙MPO?`_}yyZ1]_c]c?cɓົ-G\-T,ֆ[kascϋ 4rM~|Gg:p)F|]'xG <9n߭8&?o|Oz=a?zu*.ynnZ}.qWN\'1yڈ<;z:"~| JX]ebq }#uڠus6vɡ`}>ה÷D|ܞ܎ }X]P@&:)_)>Ԡߝ/Kv:OoϏ? DJ|Cl3;8$$Aȳazg(zDz9 =a.y8Kia}^-uǀRy(iRt?,@s2wH\D] 4^'#ﳣ?cA7Y~#l-[lO`rV~-r1MQv- ~D=?ED@)_c`isntS5&JUo ]]uĥF^,hF'}_7Nxda<։x럞oSuhC) %ėQ}n,-5#hS1y=_HN 7~@hcX_ɗCihѯ50x뉫qB^#ϚO!]{UW \(kxW]Փlqq]p_,Ԯ溼o20<6gleߺ\]wFOC-ük_r;_}W:8XS?,k}q5{+ȸL3lkܿp=p E],ujFWČߚUD_FMؗϖ<1 )?vnvu_ņCuR]WOyN{\ -Ca8#~%-7j5}p/-MC7{kse#҂⪇Vt1a+B7+1 ."\ߔX~8xhtU'e|%uȬ㖤N=$I?8(qÝq| *6/oy#;f{o]8Wly[U=}Jen5׺W su}1d::%׷C!+E^||}"W879q< ,y.Tu^!0YpWoΎ0oi6aޘ}:,.^G~Ч7Xoxnꈛ?(<iLyږ+':~F{>f6yݢ~&>#B?_"Ĥuti37ม~rkt35q2{JMq~gpQȠCTYfc pz}yql}|GQ%'65>#utmbꖶiv(կ_Y翯;~ȯWǝ]6>$\Cmwm\78U bZ1 ҭ_Zϋ!*C滹q"kup[t$N9x.߉џӉ/2H¬=v-4苣SYx g6տ\͵q&}~4HG/GC0}--)i:c'4R{);kҫIOf'Q˯>"Tg;Ͷ}vV>Ky|LNAn b/\գϋ*k<Jڿ9iCϛHVŦ} 8zԳ fIib~żn}Lޡ:1 d0\Ó߫_~ȑ?[&롶F:wәO1ۺx_Cvu{&͇y3y6I0hKx_[_o׾Gw쉩Ў[+o_|RM+s* 6D:-&mw)\-~ny +kq:_9I\ ӷ<߷+}̾MEZ?npߘ]\g1pvx:_ޝ7ofmO0g^/{ Sռ$<jU<&qO ǣ`ia9/{KRu{[_$ u{(< O.^0Uk8Q_AEOS/z\C~{z (ו+~(F|yP)mqKZU(Y 6WCfP΢KTrϷӯ#eUo\-Cj,L]CōY\odr::Nιi} >^e ڋZE/pf\3eY3Iz7Q|> ,Օ=]-ؓ:jw64('ܿ)&Bo^z7kǬכg[d}bD>XSDZ~ Jy]=t> ǹ~ճ1x/_!eb8 =cEj>WW2@f(D?jъO c ۺ[їٴBp >sV-K"v) p׃n3ZWhPH_KDc (ͫ& H=vQZ۳.\km=gnWT>~󨭞2Sbɗ*4^efůl8`/[+wѯ~ KvfX+Ⱦb@,<+>&:}AEWg)hcL q1Umַ[N$`]R^~"` ?S<]&w^eS;y3 ^8Θ^+L:(v[7_x/q>(Hg`Y[YS}_ƅSa[dGo6d}e^;I53Kp$ԪKxb> gǵNǭo s;$ Ow5Nׇ qV03%MJ^6`M _q3hnD\1/"_wC; ݢ[c<,o= =8Ӟ/a{I0?Obtx7gaCOVCtX̾P5y%n֌  W/vݣZD_!VsXׂ ozW}|X*MxkjZ[$_g_O 5 :ǝa+y-T'Ǽhz2wF?(EijzC=O (ޯmK-UAa> ޏ]^oy s:#0'X}U_2,Zͳu,1:N&7bOd79H:<2/M"'O ʴpxG"r-ulٗD<\;Zvf̳P7~^\uĠ]-:AEQ2{NnK7I~u;ܟ z҂OY3?jZ֝Wy02//Dx| ~{=ʹ4|i%~}\8V;9ǭ~%BlxHsd<Zy鷣_;6qgqt֏7o/>ƣq̏J?;}qzw?:M@8I|-e, 621|obx~VBZ#Vot:oBl`vuAZ>tys'O!&K2w>>R]R_u ћy 5g b7?"xǢSCxu;/ΌLJCy)r9{WL'8\9GX\;fNPZA˖ĻoXz^_~#{#컅z\(}6Gсpy T9 SIYլ3x}Тr5hzjՕ3?%ሳ7}]b}?86Q?V=!IM" R*Oo~l>Nf[M3K)PN_d G)xy eo{O?ԑ^xF:z$p~#̯^>ݱf,MQug kg|p{ˋoce-68;8Fu>O8{P+&>d?.&Pq^igs`tXN" VӮ<_Vm#,HϭlCNOZ8๓#z~,$_-OC_`Db{O7>: .i+Ӄp/yzuw,ƩL^6x5V~(ǧ>*/]8 =WF|J|un!`[uq^bΖX@qby/>UbIׁ0Nk5Mg['xE_K'iz`7W7b*ZZ}ˤۢ?[L|tUo"I[3#7ymk]Œh &}i|ר7 ~+cJmп;S:\~VWn˺]?yiU N)^`ZKdӤm&>Lx]1ycqkُ"GRe1K#lu[5 8Yz3WRVDߨG6LCkM>/o_qp.!뷈7^7?/Y& gЊ?T}E +t*?꣺x&V?E7U쇜PpDuIu0DyʶIϴyIN׷' Xw Xe qϭEoW~ƃA^(؟ Co(}9~Wؿ3hC^PJ}?p&o2X7~2SgޯDqSa_V|JYOOQq]:qW]ljY#zթ9NŤEhP=wsVC7TP[+WVӺy7F*{/z?}'{}_ϸf=Ãr'5ŽO]C=ߢE8`the+GlXK,6qQS͑$|v%6 ^67RG.y-]s[%n!w>`ʠJ-zUVeUVea72@g]>#ΊqzQtOJeMqu[yS[PG}Kp8X|69~A+> )^ `3m amX{Qb:6㷤& K\_~Xr^wEzu 8iڞ[ 'fCy8^ILf\{oAq;zȮ8 z#|xMD< ꈺ(ә@sKs u{'[t%x24qu%6?_nprZ2Y4:P'fN ̓륝 daz>]},}ͤ~Rt~_y_϶W< zǛoК B&{s bM{qnw4Xu},H}\/*zL/g} NSq-cXW5m嗻=7X}r]bjMz]C7'QFx::0=Jʿs]`E~t־哕y-8[C?&׸bMdz`Rw ET_nc=>f!oFͩ!fc/8n#iW pL=P'4?aYOK"81MOM [\ _ZuʦLg'`աknvPW͎[EA0-oguxU468N)}Íe#}Kƣwyf:gq ӋXlSبc.l=3u3TW'a_bdHKo7/ͳ~8P 2-xkkB#?G3sQ-;G>Ewo6seh8#zy[M_Gٳ#rcA3U_L䚕?\[mKoH5^yPVr%k~ly,$;g:G{ݎVwCX*BoNz,J;ˏF۳1 }O:$^m_usOG-xV>@;O]hϦg$uo~v+]jޡru2\ xDߑ=; Z%/-  <]^ONVeпhcYW=u3O0n<.nq o<#KŎϧ \Rآ{OA̋nMWԋ]pRSp>8ٸ Sߏ5䘟 7ShFG&#Ⱦu op< SNO:l>|Y۝6ip BY݆]KR .0{vΊ8.R5s frr|v'3B?UVeUVeq N'WmC[UYUYUYUYUYUYUYUYUYUYUYUYUYUYUYUٿɍW;k(n,߮*OgύO(Ra0;'|Fz]&~Fh1l%]~W\ O5Cc~k=Q̯*8m)n:)he??|V 5 ~t*4Wgln4WqǙϪ.&.%] ճG0e{vgNB.}|y*Pk !cR@wdxg&~f]X˔&& }> j鮚}9N NtWuǾM>/ނgwtǵSѵG+Kwm wc~Y3G<_/Y!O\g+uz\{n"ޅopq6{;! C*osMQeK_:8|vqc-Z>Zu̓1[E:Ij"u}Zb~Θn8􍶎֯/j蓖1N7g% -k,K!LQ_sݡ hΏo}@{>zttCQBzzK =ô>1}6_#.ngz_|(gޮqA]Wz}{/wӿ%˧a|gZ6}zn Aolz95oysuG"U>[ߍ{cŝu"tO^|x%z]I?}uXX{L}O8wtOg5׫}ns VfΝ_SLD<|>5/Qܭz䧓]rp7B~!s]G=Ү>!^e=&A>D(mOoѩw-';z?C"S+i6]Hl>/!з}Z7uςnE?%mzv~&)iSTw`T~m}+=o]ů+u~/dʵҩq&}O깧m&0n'4-C76nK8^MVOHs 1gxu_C'n|nدߎ ޤ-շox4wyD~6?Գ.Rw3h1'N=:Qՠjny{az+ez2[KZ / q(6V/7gۣ ^~ %5 ͣ){[BM~lݎmj^hX1TǪvϕ7a 7&GulJ gO5Q;ᗪ6SV[*;9?ReU+<,Wl*; ݣ6 >sTe7{?Gmqkچ} 7^,j'>ߘtP͇5.0+& g~zEd͂J aI. |ӏǰtoԏ_Y9~pi4^j/? ֤ris?O Lثhhخ!g]=7y{==}6/6m^Wޏs<]˓7+&wh>f݂'1A x|׃9;"lxp֎u$t&zYyrA_k'smϻhiX7 {P3vܥI:KL(q{΃pZq@<>5S\}?ytqո`Ӻ`[W*M[~/ބ}-yh׈|JwgNL_ nXr*x`_8ϕW`?U[kh[IL~+xIPGtOaߙ]Bva(=L}dzR3xLu{­c!tnv?,<_j~>u{]ɸ>3?I]mk~;zޭ~V8c*-]˲@@F.EĊ kl{5h̫5M+~ߝwg).~v9眙\uK߈v2^j~Q-On:p|vσ_'~_/~xjQ-Ih"Ք0 g|_srНx\wu,.PxsF%5ۺԻ>}Ȇx%e7l}>Bpy(ΟQ\G`rN|.0@~|M ѳ@ r^*\-ʫC1lq /O.q͘Lt՚gguw=Bqmd/bfy ]FCw5nI;NkM=טh}_ \= LVJ 8_w.1Sjx'koE߾2~ӻoh;r_"Ɠkyv KD ?[E'F|MX5j퓹8dG*ܮ?j?oe~N WG3˘ae~rSq$tZLwygot<Ւ]>p^$g8}YKAUj>dؾC wtd|[W@׋Gdzǚ_fЃ}ޣ.|㕯?ïQq#.cz$ ӑK\{87?aݏ`PV:gV&Z>,A, CpV,7e1S,z\/ҭfxuW]̆j"G;6? |W'pbqtXFEuLGhH&Sxm9T6}h 8Z}qsEֺ?ȲK5_3|^^uz3Fע;n]~jWp>S-|4)i\ϏQ3o_[CO>`\ޫ,qV{/ }yr,qwKɾ:^o`hZ/>>^%Wþ_ pL0+݆{o<ٓwKoußv <#,/VuR- ~}y<)?wc5%a}+x8M3eT{R8/^-~'|H/Ӡ&MxSGL5//ӵ^wKd\V^{\<Xi Z)Lyۨ>/I -9'@\I]o3ƴM>L{~5~ߠUt2;t>o[_ӚgƱW)޻x_ӥ\gX߶euup< Uz~-]3t.,l7nJ]ǵ5n}<~DrY:xh1v56Lg\%:lGG"D?n\vL/^g?-Vs;&2Q6,=! /0H9ǢżUu@u:r]k&׽^'&  re#m%&|w݄ux|*߳/0__ą4#Q2\J-t3;G0RwtM}Q-WvПHxZg7nǡ'z(mg8S w Uh:Cqvёxݽsoߪ+/?|pW0}t<^w}\D%h¿',tog~oj{dEY}~'?Pj{wzr>_ dϳ|xuGxoi*};";?OW`s3l|fvzlj{ŗECVyk) k4$m8HF IV9?'/~݇m8˪Yħ$[.ii īj:}4o[zqhZڑ;4zz><>A ^g fb1PHypAE1mh^_]2VcYwoqAO_F׍ 8"μ/Bo(j(Qq#x&/a)z}oJ/y;d-է+#Hg ?wC_fLqNa8 e"hc hO4("D?r97x &t߆G b!;xV?rAg.8vdPc8Oy =y^a8kQIR{D?Q UTC *x+pVxu6gQ ',stWS}p\Wɕcd\ǐ< N{-f?}y$/{ WuvkYWqY{~# .'1ZS: _xqݞg}Y< kp"7MaKۘ <_fhq= nr^@Pbj8\,> U ;X_9W׿/Fӕ\{IECwLG)ex'udfI8^\Z_^k4Vo0 Otwc \t w6a=?9yu+_n*n:}P[cѲxJso'O= ~yLj"}eu}ע?kZ?_W쾺?DuWogc /es9o @ xkx PB3~llz8:z~y,,u,[X<r74HPC YE8ض~p#l?o}Lxo x 5dXu:>+u>c ͔t]>.ߠ :}M&۲Dq.~W90|z_nc>옘f-; nǤ /7?| WZ^ O4.~F28j}s"ǎx0reS혞W}5 bS>?FԂ^Su]'/bz(g||p+>1YcW`G<>;o,\.8vq:>9~/RѰ(E&/?GnãL p޾z@WXyL)[ y?No}q9iu_*sm'}&=R4&qY3M_A^?7d'veuK~vXKY=>ӟ vۢ\m}Dv<]Ϲ2y_ $ov烜u' qe>ND>C|-{kטt-y0{pm\|iCo :7c'Z'Dą}o~|T=QS_i~߆WCE~hMtD &p#ޗ<_BxS8n2~@_5'cOZ8Ǐf|eG%{DvJ zV1POkk$q7Bw|ɾ,n?9yΊ ʩyof<"}do8LP?w>By Qq~#sX~coK{?OmއqH~xFd8Z y]?Z:;;Ba͖&< /;ܾvHv ~f~OKe8͍jr~Q1_RWTs޾98VHtgq^?GLzuNQ ^u]yS_7R},)ך~lk#tssJg6)N/.zO<sphG5nlխ3:=ߤj AS.tO3Wۘᛮ;q<0Mjh q|`VlՌ?'NJg5 *j۩0t=Q?]w6/Mr5eCoGmu?e@8ذ)'.ƒ/X}q6^[Bvr~58 O/*OzΡ1^D_q>=쮯{< uOuSǻ[t/RƩfϷN(ћw :b-un,OF W|]zuћ׫=hN9/d[ӾXOף×P(~4=; |r%ٯ0~upIN'.3bV u2ꆢR .- g)D'n_VԮ.Z3 NYכw4!zd}xlrxyP-9]TF%[EMpzxu>Lq6&zj^S3[vՎ}^]H<\5z_Ͻ1#z?Oc}l*u?_XX;ogLWxyix5$p5r"Mu,+ oS̼FL<'hhp kX/^;#>$6Z' =Nh/jLx ޽MlǾ1O3x[8\; z^C5w395+Q4y[ ?ծ)>6p\Vvrp}B{BkMOU8&<2 3_ckߚy6h۬+7kp8J Fa,˓cUI(P{܌Bb]FOJy\0 <~9 ~?9vQGM-Q\O.}0+~ӎjT9tO ރSl;}!;q>i\ r܉ƃvyݙ/yQzo$ C|5XYd W~03=ћ.)CGwCuBѠCےw/Rzr}՟jA\Mk0$\,p*W~;"]bl(fҩ`񸉗>c tI5?ߊY$cEB=z$mD>Aל~Ӓю߅vL*j:lGy2-P=I;4˺ 4zcly POW 4ZOiZ;;<\_2ѡaEpKaBG˜sZX|X}BMVOG4tUQMUU< }>S_>K^\[sztD}7 K{3%2,uF~ 縋'/yo};Z[/_ g8|)ՍObNፋy_X#Mk6bZ;ݼ;z#e_# /vߨ9>|RpGcqлhO'[ j }W~KrG>1w5?=V-gaS^m<86Y7/tj,?!)pbqH^?麆,MO?m]\=NHO 0Pqyq韂.ϘpWDQ^pܼOui5q@Ot^uet8J~]MߛS]&g#E/S38\3%n5wDu0`R<_aMYo_'Ԅ>Y~TKL|DZ% GF!{h"|n;Û<73QWxszpϋxD/xX9>cca,ao/OZd~<< nx]mS]rEUOV7' 3c= zO/ ;M|FKbj>޿]:<,}8e<nEX|PU9Om&K%݆:ո G_g)Hcúb ԸԸy4ʍקF>z3n?BkW\TFeQ)k7Jp1׾e!'`+,k(":b[N#m/0B~I2?`2tӅ(_o[u٤f%ch8< :8g@8\a7n-)oGxeʸ^u=7p}q4xkmM}++߯>K^ FV(0{!o 6ּ` _M밵e5%?{i4Zt 꼔wA{=6Jsd o*=cO5e-]D ck,F\wh]Eןw7身Лԍ 'm&"<~+?eAoF ['nx%Dke}3Rf=_c/e=K.^$ -b7үoѯ}/#ywű"pӻx:95uަqބWo |kD`]W,~MΕwǩ,#x=6qx4THlG|m/Y׫8g+۠w3$LWhnh,z#mV/BZW8^t6x|;S_1FxE7:Z,1oz`%ܡjSVj?7^.P?IbMW=a?beO@{->v}07,~aOz1o-,zQZ $ qr|ь76R}xfiSi'3 ][)a`M.N\~`fL6̻ 7 }鉏zhL0WK5xfnkp[c^98J5_7nWIK *ǢFd}oOD|\kCuQ~. Q(luBms"ѕ$}&~ o@x: ^9|~/=ZT-؋]GtVA.]Ѥwm獻Z81ʘٺ:>Wt2fooKo&ǣ=ے2Y!Du:YU9x⇳})yI?s%3ILjkN~Cz$M{8^|8} NLd^qkE r^1MboìNd'Ƽ.oB-quQ ~-D[~ay&$?Ըx{ꅸM{oGDE '`'  Oo$=Y?U1M#E_nnAn~܏?eyVjg!%{^cG7OpxG%_Q1_\{uaxϐ뿆g/zb'(q7 ej\Jw٥7`ۣz>լㅦ+3x G'τv\M-I}S?UׇDbpKoo_y 9X /KBfq+ 3"[i ?B8|guF-ՎFouCV׋wL::1jԼ6t}hBtWNg¨a?ĪvV#''~ kE=?\^ҕ5$_ك)~OЖu*˓cY DNwbiG$YBpVC3^ٙLQuhu=< &(Z R3-~C/y16;-n"D?nOp_+mgek&>%[1cyp]czC_lxS>a< ]x?^hIj>' Pwِ|{Z@j]\\v=J>עF2hѕ 3Ty/1 }x_GۡV2jqXwúьh U ܊:yd[:1 VrwuF|'sX_jKZr^ov=IP.(8, ֑k׊D`g}yrB]xxM?/u{nz(pEth8Fޭ}*5[tz ]q4]̾AyvPq]j?I4:dp[;:qp$mn|b]g;$754H11ߟr7?Z3DcuUQE∖8דG:Zyy=E_XM]&vq>kQ>4]x-Ϯ)LB*R_&t_8~쏢,9cR_>/ݽJ4'hAPƓW5w4^M=Ǎ}u1z`6X2L0Gh&[h G3^qLAlcĻiŧ dG3b_qc<)e;Є\Nγ<Nxӭ[Ny;OMT3 3 W<2g/`, >e4QNrML#7!My̷Rg:#^yO9-|ަC?X/[~p˫ѤN+=q%5d@xk qNÿ-c蠩8-<+Β3߉z5}5<&TmCgoC1}ƺї*;:̞uyɠ/D??#"Oӻ+V糗c↿zKK7ThloF]n}A~ˠ֞mo|?{fXJ~=^ 18u?o#G^>jbilye瑫'0աRix?:=970 |ͮ￙#f0~bOxq"t&'|RIlkJ?/%/x^myly@}hca =>k?=~uѸu=Z+1 d-SQycțr}p5ϚuΛd=12XUaޏ#;MVi}+/h~{U탿ϸLq~!_/3_yeܿn6ڧocܮAڠ#kG_yÍ#Ij!Y"ݮ?%~h]r. Z(ae^CӠ&)8O Sb|Kx>Q8.=u֌e~QUr5k.55Ohgws%,=]8Cu wt|q9=%`B) W-sod?pyIr&_QgS}pooi$>3r4D/&sXWu MoSg h)߷?1l=;/)t,Uy>ע3#7:K a¯v<&j/ {>)-5hfǐ|+wz : f;&oKzṂԿ&$^'?T;Zʓ:i/APz*>ܛã ޷ _Cg98|4V}Qb:~oD/aH2q(s'=you`xƳ |iY?cAOz}h>1Ẑ ^}P >WEwmקP8&}y:!оnaqd -ӭo Qz.)"ڪ^Нؕ=O[CBs7ysܯfJ5d#%~}1!\?JxWҞ#χ :lnj=Q t \%7L57q԰{*M#HT< 0=E|},HO o2 /?> 5vQThKp<\A:D;qZt:}o6կ8ή?eF/xyf{[գi֢u]抏w%!ïW㶾sdB>qA5j >[G3h?h~P˃j>?𳟭?#<.O#җ`ߟUq]"ũyO/%Ootwy1~7ڽO!1Y86p?EW?]&e~'UV}Zꄡ2J֗s߯d~&v}IIco.w{/&xNd>?b猏{Ν*)plX|:S]]1w],>!5S STA;ngBzqq+N ofI~{sÅb2)^^|D'͛w&un7^ϥ)ϵvyo[48Oys\ԒoID?u?")0+cyC.4#?XVX_,nt<ܧԄCpu oT!{(š'(~k;6sӎWcg=o ^V}y9̬de%sZ@~Qtws䥛K%i\v <{y=ƑgH<|F0rY65ۡ ЈbO kKguXRo. Lzp6"ypx$tIOW𽾜ː;_oUzs]ʕ?JoEG uywUL[ H>eXkS& ԪxXӏ;YoAǞ~SE|7#ԛ}HW'M9Qq᧝*'V'ke; M~5iqs5txpu=x)|CoOԗݤ~C%Fg-me,}Fdx״[LG3UxSt[%WS\z#uXpgEg0ԋ)]yԙ:P8 O$3duClq-/4&Nr}zꯕ ߽/4.7Oc>6c)X_)dE/a$OnH?65|[̯sܚtup)WV_ U`9{(g}_<=+O1Rsu+9u/(E7&Hgo4q=꾛_8mw%hxd' uXJ}ig4|ID|Twu']_%Ի!<5l_p\ϺPuБj#yjuUoE-_Oz&0<|UƩ-xӎi+_1i<5y]"aePؗExuZ^otXtuac}ƴ>{{qwW8qox4%UOw"~4wnQyM ܯqv{ڟ焗O~rޤi-վ@ Z|7| ^(z.ts.l}z]]YuM,FO9GuPQOOo̽DiPf\hg߽]<\yj5堊=%SOyTWTA繚uO 5ʗ\%' wpη獼DkSRa =sKA3E]<$U}ոo{ѿyPy(?9\J':29oex?'\{l/E>F몂{a K*BVȺ]L@P X>k*PiKז㪃ßGgCGL'G0Sԗxo/kK2 K/S3^TjeNY!%}ފ ]Fm]MP.yp_w7ƫwgqQWsqz7u$OW!tq7 x*/GuEɣ|r CtGjs.45-a~[%xWp.*ߘ 7+ZRaE}G G[5_qqU΄. pX{ X'p޻r9=Ii~y4Ӧ8ÍG{YAceuaC8R_n ~(t R}$н3ıocG`$n/ ϐew_mwQ2?^ۍ'rDz\Qd)z< =ޒy[Ar]űQ/ cD=hdпl3ҧh໡|5~jxx4gx!m2%\u?<N:y0W-z˸-?Ϊ훓8LQ( סВ_.jGW>4Qad4?Sy] FY+@vp#x"{5a' ,~zq 뎮,(SƱp=ZxvcI 4N!Xz~u9^@yے/E}`D'QU;Fufj7ȸC7@7uϭW C4Be&"Ob}j}M9s<oC >/ð0K_ Ap>{8:kMv7Σ:<7î#jR׳]ϽG~mؔi3/SCoܛ%_+/{PNoNΧ9W2ߌmXoFy˼-7΢sϫ{n}}hd|`)\Xk <%^ZzEyQ`TBO;17 GH +`Q٭;2uq@VGx-~;+o&h6Χ:v<Ƀ %렚Shx_V__𧥜^˄/s5<-u(O%Tۯlk)R[.OcS" /K%GTA{v/xt|S.m'[XvzNkczlPq" zfc_wëPy;6ǃ u+ƅkA 1RޯnēXzS C >ZyyM0'ѧ| OGtyW\__m_?ѾG}}MǾQ+:F{߽7xy@xpӥ1P3zDzuR]~oɬXZot~15" ;wPfs1; 1\ㅼ{p=8yO\q{;C)°>}x\eiכ !?_wQN#"MuϷHJ޺,.z?lHuIko9'.Fqb?vÈc;=[5Jƴ?xvq/qp_|N#tC7mwՎSguJ[{'ls`\1~O7d cx >Gۧ7Z#'叾U?6~o:ɶ!u#xCvK_$"RX~z5b=\c: 3yPAT}_8x+?2 z.Ge0s? dq#{c3:ϫe[y6) CYnנD³e_G|6]p]<)U[A~%\wʆiۿ G' s7ˏ'o}yƞZk1w@pp#do] h^=!q<5rDuJ-5wsa +VN5xs;~qnM˫`lE5mыgt5O ]ʟ 4IT ߺw<|~ۂ'1ޞ!08c/ ^b&o3y㥊~zOٓϫ?`x|u?vd?<-r5qޭ+vƚ}%SOCǧM}x?DH>C#D8~Dn}?SgR{pQ7^۶K8q$O g},/($joڇm yQ҃/AA&|} #}Dߧ/g_p ʼ>1ZxʭCx(yt:Mߴ㗇 LmGx7Mylo+'/7^; }^>'oF_*] LC?a*|"GC8zbC[~x+|e?0v3|_B렣𱾯<0éfQWqyxO`ֿ#i)?_ćpm1\ݿbM'zccj!a c".m ?y!'HY~T%x 3*[~.:qےVr}+{?,y_z)z1yX״ 2n(yk4B8;܀; ;y\;wW6w Qw$z{8Y}xcf:F z_W.'xvP/8 O3ps5Z}\\xՕze*:3`@SzHjx)h^E|~QKp {4]@;(2<$mS8(Ĝvy>|?\>ONO\{3\,pNۗ.C{EmJ&369{1Q@uGV -m1Y/,?ϹXy _lu1/ F^Z3?m)#I~xu|ܭg@ xԟkTÌO!o3Jċ>?vJu_x7#Z&ô/Dy٥:/K?Pgb}Wt_Mx\ru`>#qy<\|]<0Gmo${_4oM|quD~g|G3X_(z$^ @7k{</(gu(]~Gb5#uj|RބpOoǃN3$wDӫn<-e]Du}^Y}aWĵ?\NIfO}X~e `~- >pC%OҏT1k<^Shu)j4u&cGa?to?Ae8uׁ0Mv}uu'9Ow(C9jFœoR_ 1'J^onM~2LR}{P\vMsa!z}*GWvr}گB |&.eD bqcC{ޏM煷2\U[ǫS<}8Y*.%$q ַNlZ5!O~`N}eIu%05?8no7Ui5a)}:E[ 0q7OSNו9-?_)sMqXR)?r|42EٷEm^tsrX;| N}^>ˏ(Pʼ5Q,?bN߁Xq=l}KOg_~\6jֻ"o=mtX,u'-yxѧbQ'e^7AV]O:/~M% e8N+N9TO qevG*/:~Lʍ..=a=z! B:e!XB gG6??2{3^\WI_UUR舘ar&ΟG~,M:8:!FcG .~FtP|_v50Ӵ)4? I}ΐ k:~f. KW& '|K9+!}xkY;AKu  y,2Mo'p+8Q': 8Dw"1hꬶ>1ztխ}̈́ᅆ.,*^Ӥ۔_I|{:ƲanC nKzp݉/yaK8av' ?s7Ck}]z7mF=,o4EkIk]4??:ԎיW }qhC3y\PoMnq"6"َ ]7ge#HyѕOH}>6eR<7YOzm0{TmۤaD eS/&ch_f11nOAp\m㍿qT3oz=H>θƭr ÃRK>OJn#^.XT8Ko/E3I\01/iCjxS>lǣcģSVۍ ס~qcԴziy<0 .EQ+jQ#m6n>?o\Wכ$?cɛ3qʼ4r&4%$[Fԗst1u9y>0H\ǂ_X|sn0>~5m8<=\?w Tq-n?cnɰb ÕLWՍ)iqqfJN~^=+pRxM9vKG.q8K`J/8f/DS}[!nfGGC[7TƔW6]pIOSDB?HE&m<>8e>o쏓~ync3cS!qn:o<ƏQ?`UvuJ7 E y7 ]4uE\y :<r[8M<Fq| uٚ!PupL5_7sĉꮋuُ*y w§%IϳQ ~c?cD@\}BW"TM osrs1ᤐi+X4Cwf<.z#丗m8@ToLtDױ|dfLGWn~_ҕ!Rx!qȉv]L|Wy"jO\7u]d5y:S+ Ǧyn>6>P/yl'ٞǍM <]&e4c)g.!yr;&8?=qNAg坉Є=Pq9~v9kH>Q<^鼓JL=Nb:kxhHyBczj6=3ռ9jª>r4S/xۑey=y֟Ε{.psXp8fTb1ooL|w?)~F{F̟ IJ?VցɋPv`6tۆnhO6xH@ Mǻn$f>PצO6e^٬?Nbp[M`O;kVKx3w`I m ~:j Ƶ*"S';Mɒwx|Fbu^RA_ (!mt0L+g@𚝨ӈ~˰jY~A >D1 n (:1cFJ c3e+u<iGގ]KxKo*,u)ӀegҞOucze cV P}?>,Qr@a:djfqg&FKo{^dLChfߡ׹}pr%~XS|y ^PJ u5Njkr\ыyhL:]M$y9\'7c|uJ6FywxI8ܷ?k?"xC&|_r8Ɛ6͇?EDefݾr/^* -Vh^<ְG0u NWG]I6$ж7E:,uݼqxt\[nn[=xi|pB~3t>A(H=o[sG75W]Msz9OxbXp8I7 Jo}! LuђW.&>,m&m M|~;hlVW_I?[_s?x#wy0:q8skq IZ_Wo̸to9n(7lW6 '?Īqլ cB4,Si*IxpQ?9Oߘrϟ77kPaoWLY]̿.ɟ~˫YiGK9OۚLOMl@EzuF ԑOS'PkO7bf y ǃlqW^GhWVAfણ!|@ |-Esȸvg< MvCί_PǢgz0{LPNpD4I;˶EY)__O&ϻYpKnSjp'/QR[åqʛ~'&-ӵ̿ILz{]~Bi{ |'9~nU~cj.W|>_D%n-_஽rԙY1߳G<|Yn%.Cכqoq:mU2|VQ +TkD0r?A٤y!_hn'>^phT^C'[2~?9oUI/մ}cx-C PPK^ GbU+BZxo|_ryd3Ngg0/۞|g+)%֞?-υ||o^KglzNu8aGp~)WwNMu/Gүp`N ''U'JE=xď,S K^e:Btay:qNl7U^gG&ƕ![iABN}KX5\qF?'~xuhc@y0,QB覃p_^KtK|]UNKS"nb^Ǩ>(.C&H}=q kۧ*~yG(x߰/xS,{Q ^F,5N1QCW7yv8qtVQh?"x̿ 3(X,kieѮ2~/{_Q.a_\{OzFZfX>cD?OW@ xr> Ƈ$!lERJ.߿衩>\wp?ď"-y*g3ÕRש2|"B7E7;8ؠfqIǓh&q%_w:2C{D]UG_"CLgא88~_<пƼ>٠}iO !QJ⓼h ypRGd'Sc'~Qq}+ph>ZZE{ۚ'Ehy+?-or>l/юX^Ir?\/e,c pRӺ!0?hq]N'A"#@tԭP#<ߌM#A64xo;n#nWߘbX)n8Lc]SC%7e\mhi.z<"Nӡ!F'PlGh}_`XO[]'oWIuKLД}T|{u}.u8>!뻅gMLO},QոBT~>773B|%R|y':uI ] 8`Ϭt4WZuG4:JB?ns`e+p|*:{D_^GNv8HWDß%x3Mvn(7߁7>yoh0/QHsMhܺ)Yv+X>">[8,-q<&יz?HXxe><~~?o#w3.:xlPc5N'_6:CӖo?iv+Y4p~Y|: QH=4sqlCyq#}Cta`ǠOh8WBC y{\f̒/]W}F΄@f]:m5q^cү~I [sپgy\wgHpx;vw;("CEEv")9f7i5hL"5L $XwxY_!HO\߸h4?f_ .o> {?Gx*SNf[侚̓[Rk?N27^Gc_$D$f5W~tZYP 4jzsh-Ϻ`e8<ĔO, yч.-4Tzu]o*7 8L5y][yC~y0ˠ3\#Z&e^W]\#YC|+Fa<+Hgy6gLT'}x5nLWx$MW^!p8Jka sh6y8UJᠧ^ة>ȫq(\]]x^>pY\&;u6 ~~n ~_K|8yT<@})<hUk9B^z8/JlQII/ ~TmQv=aұ>S ve'ų5;w>S>q#seN ;~]]7a߲?ʿ>M?A( ~~'X'GB&v}e{{8 ybI.Q %(֕jμϿXg(MVkyd,cX2e,cX2e,cX2e,cX2e,c } k< qdqΙV}Y)zz"Oϕ8xS0O1ލOuxm }O+ ~_ܮМ4gdg" /G]W~%Vy2aG„yYP](ܿGۭ#FyohtUy8O=._r:4;tQÚ\~'t:E;ۙ }^/pO37稓Y}o '~ΎW`}R%QAfuB0]>~$ * 6RM1;ߨoSo\ NJb>n꠫>2w>+𱝟$>֭P+'Tk|R~;]_5~確j٬?k%]}u/.~[h0Mp&鯭lu;Ց =Fogs% Mϊ"5u'`8x}?[nuуvu] o ZWcy*θj>s8tZ䶞`| 4-x>%4sx_:K(w ??@—׆wt<\dk;Z<Ёk~i/HnK~M/BWlw5< qi S;XW-ޛί2sfAkq+ڍBo~Q⍋Eg2|yyӸ Si#*/#|z]8yl}+W2*_q_3Gq~XM W)qG=8_ %yگu '|}'[O k󑬿 Lމe_85$qc/z_ :T=vrsbsumgjIW3e,ckpzBmI3ﲡ*'cnJg8g.ZT{ɹrWսV8P׾.s5u^LĤS_r[;(ާ J8ٸMaEdf6?κ.~g|ṎPT\s.9s:3ջE!nMGɐoP7'^8M5D"%:zyo߿x7NZg\ONz䳘e)ߧ~g~Z W}ֿL1.u>_GdG+#g:ZU/*V|1[ =Nd6u,6;?[}1.RCzuw]͟÷$#M_?y/`ƠOs }'x%=K&r=5r??R>IӭBVaQ}ǞOr ;)_ 9nOi܍";.}%h=~ ] ނ8{fJ9yW'i*k7Wt8E6Kwwt<0,M>m€EL-<;A/~Z统rX!Y򗢀kg|/7ȶ>mhW4v~ʸă)?EMʋ)xK"c5,HTvW}"x_Gϣ;L}Q cQ VMf~aOgQW//jJ~k3|ꯗoOQ7M𜢱j{5*_['tq,׮ ">+ z7ԯ4ϿoR#0NQ >#CU߇ߟ@_qM<n) ׼OޭCu<txO;^xRxgn_~XL뫭Ɏ,u*U|+޺mHJq *|v6 <0~[/糶 <&hy9 ‘u@xC^˳`Pp755Lc Γ?_D]{=.'ٿ[e|"~Vӯ)H{U5_| [׆OCG> y*7bX1QL9@8Fw"3ײ>wyN.<@B}ƕ柳8^WԷQ!~2_p'~jwT%Ѻ&u4O:5ײx~ g0p5qo/1u=~ՌX3{/|Qyz]ְjJ0_Q?N=.&.vݠEz}] `&ޤjl7=Q/1׹mRYgr^Wm=WλbsЃ1pd(;ߟ;ght=ѕ_>L̓g`is¢_2bӦOjt%m& ԍ6_~O8&~Љ,YyK cMe2_ŠGY65΢.9FQ]_\^Y>ruׄ!kV&٨ɨ%]_`<|缹Gil/oo8B 'F%ϯ-Oˮce GpGK?LUE`.ƒ%2>b<ѦC1H]~U0X~W痍PŜTNɾVSBbH.L׳tA0-lN7A'wz僲w5O ~fY6O`C׃kWϳKԞ?u<ٱU5~#sY3 }MuC,o*#u>e>S? e|fmHVn_#b}Kh␺KۭRח\xݐL?!YOm:6XS~WKqk?R>\5޺ LqќDpU&C\Au<g6W6&?446[v\_ DžuW+αO9r>P"G㟣k|k߁%)C.>7˼M:Q9L8̔qAw:\93 rd? yHIgKp&t}2^y=Hd{x+pOAy+68Wֻ0Wek~ϻo?&^!,~5``{Q۶˄ǃOeS<Jf,cal02e,c˘Л 5ȍǏfu\ }}K}g%˗kT;{_j_v?'|M]\׭9)":x[C&.C8u*닪1a)pC+jъc9=nixVu[A8} [^s㺃p&h_>*^~q}Zs\o)sF8~5^|i^&Uy_?WޫHGDĄMWӗz4WxU ,$aͶ?9?d^,3 |=#CťagKhopck6+JB;7x֟pq Nsx4ׂ?!>pvq&= }{³4/5t5oOtO,VN;O ĬcּX=}1>*RoEnD}I·#xLBƗ18l4sq,r2N`Hu?YʣobgNZ޸2hu֭1=m W(i$kx]ⶫY}͐?^V! u>[:Ѷ<_8Z㽸^z[QH$ͺz9E:|&'mku:uy|{שZ~|tz]G\~)ˏ9ONx{ u5zg~}}cDZv8K-zVyBu]zQN#g8`]ks\?t)Y▢#t<}O{ F2/5: )_v_S] ׳1x%| )$|Pa?p"pd=%>"u/rlxAu54G@G9ѕu]9>EbqDAQ_oLI>B}R^vkEY7̖İ&5;/ݡvSh|K|<>QYu0p }VOaө3xusSso侽%R>]8ӥk2'hKP4 TDy'8_V }K6G{/˾k&q?sJ濌 pߞr܉):0.?>.og {Gk _B;u1Wo¯a)˃ K}-?vrcxNb}_d}Z7gF?ºԼUP=MC` npw?Pf)_Ss{[Po>h׍O÷J:e~SqEB7‹~v]m s3=0TF)cZՍ4X^+SqIU$aIO91k<#jԼ&k{`zq͠Cz< }P3"e :XOxtH 냯W(AنOu λpT7S{%ekR{~GƻuHp3p1&SO^w3B_BAO_ /J$>5_sa1joHx'{n:[4}MfN%_qPq#4[ 6wSz}=xrUꢡ/ޟW9ޝ yy}xnq!ռMv7dѽWuɸO#:Co`AGuKؗ#ʥs.oQA}gzMU>XpB0>bcQnz/'6!WW[:5y 7'1$jow'yR P.Dyߴ+Z'}jTP릸8ρ XO=[{2eshK7ng#Qܝώ"_/z<:ոCreɺ1Cou:ڢy:^ a8E<'O hoö~8QwE3=I@URpHnOn"yaMk 7|$Og{r~mx\:=H`H>cmNyf1zx_zsaU~Y' ,݉O:=ő9("9tE++%u&8v^~/~MOu2_gܐo%u4|HA8Cxєs?Ȓ' eWO9^l]1𫥜E kb|w穫9_GWh]y^#sou7j7~Eocf P|_)ݥ4xE}5>]OsN񌃉VZbypsVr=7^:OWq{Ĕ<\l~ޘ78<獈^(/}hDpw=38v՟Bs.m|.OnOy|,C#\t"Oyvk֓G6< 5A~;ZDt:ICkDӉW M67ћ.tu'TWJӷ}sf уǫ¾ G~yP=lIxń38?WŏhI\]Ecu Iġ<ΰ'E3 -qcl<]gueokȼG+>?QG4ϧ-?LXC;'km!O]w@_]<)ˣ% ׇ'P03kuS_Bi [K O $t]ql6L? g{aup8>:؀7~'돷e_!``_1Y(vCDTs nH1ЪՋ1ޣccBuet=IagvJ?\p[<+sEkٹա<W{^eL%~'lqg(/?B cu[Bu5${cwWωՍuθL֗?5tc<8_zV=ŝc{ИWt%w˄c"Ky 1~q yo\M0C;зuL}) 7M#gdAr5SCqN_O0-&- >I#EqY콦qmq=IzOpy'Q]/ʉeÀ}^qO+Z߀&C6:YqeݞYuǢquKם+cE_3r4<ټheT^~ҋ=.Wqjvp|r懩W%{_WYׅ5,k]{i8skM{z0^W^x6]ݷy'4 n0hgjyp]2c9S0k[kXŽ;2Y}Bq7v:K#8S?o8CHw.?\Kގ:%:= C nJϜi '9nhkx&jR.p`oL/߿XXωD\'xZ=T]pW>f׋? 5Cpqa]!}xx:ۚL=޾n(Q M5z.׸?ۣpMLb jLyi(`^dGs=/a8c@Sz"Qq78!qiP/}#݆v|mm,6okпҽ(,OuM)_R)gxo%~6OE 9m&zh8Gu4(Sy /drGԎQi׸="󙃈Aϕ+J]sLq?g\}S_?,Q-a ץjc4=3`&_sW3i9m'7XXZgụ/$W_KP{]'kU/Zn {84B3ӄK3$Y^gxRrڮu]*69רna퉍u7id\-IW}1t+;HIzGH7si+ý ËUUHy#0$~OE05OMg=Ag w]|6-T~O?ӯ>JhT}Mu!y!_O|"Hڄ{L5~}aL9ߠ#xm'Mu6J=tZ`̘ϕߧIgz6s:_?gZܰ:a gDQ)7XRM/: Do&/,$O'X`Ёryڇ~uqhXhio*Ȏ>8Q4՗0{LE 'q!+Ijd>O#}slc |_iQTK'>ORBkܒǵ:@E/ի./ qOl$)"kVy돻xxۇbU?gyu 0E2'~y/_[8Mj~L28vw]߆75qq,WM Y⳩}0tQe{$x )?N>2OaK7G[nx]w\r'Xgϭ n}Qwuo ĵ?0S۽7^@~.5"?A'IJzg/O{G_7&\i~]M2_}/v7d7('w<Ghy-l_  Q:ePKq1x\OD6OWͷ{9}޶ kޖxt(W1M6'}?&Cz~N8C?Å{&[_?M:q:MSr},<~(9D>h/^+~d0c-u7z 5kYoWքǒ+ixq'8N`@ ~ԷN K.&\ƀ8M<|yσw/]3w{'s2n¤ ?iQEL\[nLx>?pfG;nCh)JX/nC+Kt2Lf=nip`p<ݎvsB /mU#QLǢf~R:~7;Yߍ}@g8i=%ѺdlN |yGGC16@7nzM D&/Lhj(mϟ)7GBPBtM4-SLX[q=_W7{H}>;xp:^Cy{><+rF u$ ]LM4Cq|Cv*ߚym&;upEӃq|a,"8X LnϞۭdfxyLvMqrOX۴h3$95Ľ:kp׊*Rd{>]-nã:hx:^:܉l= U+>Ʋ_}2uZq]dxuu5I nO]?Z'BcRO+Bp?Ճ{>DQBNq BӔ@AxP0jE㪓WB78:=%2qe{mhGp[/Dݏpˣ5[t]h- OŸnG]xSz#8oJ⥉衄5g f)-R piG%By?'1}݄ofxce?Jau(6/p e]8/9t@#3'\_ ⮫ nwiqS0~6deCogZvq̸J~|)^-$~29GEvukF2$ ;)^ yƒ5x}o S}N8o~,9N)ް~|M ~I 8~[;| [ :}.=p5uÍo{['Ac|-&xϻce]'e^x~e{ Yoܡ$eDރō\w=cR_Y;Qj=O؝`2}N'YޏԱИn*q_ﻞݧ۾T6B3|.JWRmP%kIq[X?WCh?LG K+) ټ1riAQߍe4]3[cρǖz0<+(Aj-{if׮PtaMW0.Lj<2 cz][qОjX^- |bD5 UN aȼ 8njD>ˏí_z+^s7$V7n-86 }'uݟ!}w`G@M`z>}]jҿߒ&zF_^FHOp!q*? fLG#GWԺ-zi׶#< Xspk_Y[y{|>޳+s4~xx!uj|4nN\Ց'U<䥁ŝj0f ~">RW ǞVgyxgc]* ڮO ?u۬ѡ2d7X2:~)^h}Ɩ@כ˴i<?pbcL90\nb16<>Q,1 Vx3~hSnH`yy%~5&Ae2>U|ū+Lgn /v?N7 @ n<&m%5G9áQE&m82%oW;y{@Q:g蚞z0CчL0PƷq!d%=8z,>>\7X*P~P.*t#idqV˸_EUZ}~y_fk~apwFu AX=D Q_=K{o?kӾuN?ڱj#Ϡ<ݎ{#p蜐&CS-BBxo89kG$#Ovd>t$z 'mh7x[޸y_);Jy|xۡAhbEkE1G>vӒG7!r|:#=szwWpn5NLuoj?ZQ~q>QWԟI?ۺ-m@5O{[)p]pɯwswܲN3Ӂלar7ߏȼw㢜K.ZFu|Q*:+]FuhKs>  ^+`>Mk't>On&5lt3Z m$|ZVIۚ]< "ԗG\[G=^2*] pqZ׵SpN=הLCWė#hvquSP[dyiJ{+^#}o~R%*+P7޳ X?Nuo%!eY?G'Nf,cK~ 6ʳe,cX2e,cX2e,cX2e,cX2e, *YחaE{IRAә'Iu'jU"zqlj D7$Z:w9Sd\8ĥ3daY2^0ߙI~/nQ0vM׉.r0oOe2 "xm7x ֿ9:+TttmF~H`?\dO‘k|=>ZbWz/Ys#DB4Y,c?3;'\j8 "^0ѩaIzGcy| }ݟo{?f!Bط$z|uϯG:Y ߵ?aS}:nAv;tlh=K??e~] sEna8y B8;i3=na^OT/@7<2e,cڦX2VrP1Y֯dqnOOVƿN;=}7j Dq{BFC E C xC~ȓ;Am%a?6F3Ժ"l@ޟ-GpkGΏɸ+?ybZ_/n JV|NK 8z©eSM1ZkPmT S#:xVnz}&,UfSs,M @P B? ̷1nS&Bz3}} C8$z/tp/}'\ ~X;ϣ>Η{\I|@(+yy+SbŖ߀ 4C ^bz{_nCyr?SpGOfW~~RBw6@QNxX3ևp'r+&eh/(/%%ubx74MI7pWW [U п ?ۦ3hI0+T}CQ_t1sqhް[owĚ5?7ȣ?c^wOT>"BU(Nq9J3Vw̜x.bGS7YW& =xR{pO>/`7^%LPX'9wT,y=9V';+zkE3Ks2W?p~e3y4yG2] wvyކx-` o|5+pqkKwdAB?YL8X@cyrM:=)F@/[qS~^ >)_ | 1=QjnNy5'pÖ<)uS dki/#:\np=GjϟW1!}EZNP^8Qkɷw{/ЋW6y-}z0޶3n<7r nӛmRd?;O䔼g[F&?-dpX꒨7ą& ]{+:zy &6Qۯi)cZS߽y:<8?׍ފԸDFjxey89/n^ӫB, b 7f~W QߌmL}qFx}ékx{(=wÇţߥHza!%~JJ{½8DKRw}.[l%Cl=?oPrRA*d{m>kwM͕uav;dwuD=Zu7n=kGuyzjڪq 髞ߓ;|/j[/F_o{e{ P= s woN/ Cۻwr}Ys3vlmHì3hk~U{fGq+0A9F9gWDi$DAH&cqX0Y5I,cLN&HBI}TWVuUu3go=[v\k($=~ip|6ݥHZ⥤vӉqH̯tkpNvxis>o:QF- qQc?LZPQ g ͜>\+uVu>~Jԡe~3ԊSЌ鋞qS<5P.ŭUMG>gg_L?r_ڌ M͖a}O|ssZW1}DpǣytЈ;*HGlGjޱr.~L#L%)>>SMe oF~xKK(QGG[4ʐ~7Ե>=K|y3x!$[|k\ ?urmh>+O6_Xϫ@WLzqbb[ m ߧtM[‰o穷|DzPlBW]Nɢˈ/ܷsz=Hfҿ/kCd~ p 3qt˴u9q딏<= KCUO>39~ urC`Mg[uI l%n $=K vn p޺N]_Sx( KԽrrW9ͭXazC%]1icXGawu6:?SaVaVaVaVaecit^?QC1Zm}Xoܯ%Ky >޵]#g+0lO }隣t."txJ0X[=3)~}Wm'Sa ){Pݮ[^|5ɿ}TgY&o=o5T<'nP􃪤mRtW} }N-!Sq5WDa'ԌkfPq-R:8pFu9D9yb(1Q~.9?ab>ZûY6=tg8~ oD%|`WD-}9,8 g)yiPV" =zx8to1T :^_W;~k8 ljW:;;G1Nx4?FGi3ankgTXnNY2O"/| Mk>z z{?{[ >@\C'gR/Wꯇ}swòSƖ? N<ӿR@(Uwua>~M2'167u>k} Ea#8[yz6 Q^y?N^u$ h6Gg4bko9:?{>P89+Dxܸ$wS꨺ Ma=UQ۸_a:@_=5qCuK.,S/:WV뿡K}xP,ޤgϞlp|Ͼݱw7Uw 3$ӣn38&4֋SNDvCFE1G"?w94A~si!Sпhs};ue|= H|QP¢jA~W}v3CxU>bǣwcwx߆1gO֧Yh)k.cx_LG[/^|Nz:,8x4\:y֠KWNjMeL} Yɭnp֡U7qIn}OZO:B8)GMVC5y+xϳ.pzq x:=ļ,gu-,?yӌEMp>J1^z^~ }?V'%qMr߆Lt-|~WR=<?ɬ`ãW}_ZfWqY\}yˤɰ5??g,{2<cseLWth.%y}^_v<\߸;5WN^szn| qϿtʋJ1+U ѫT?gGxxز2[<>w#x ._h?A- km7-oEx-- gSn}"+~'uTd=w) _s+ׇm"ZBd~>fT{P[1#V ޴c$L%ȱߋ~<e .Uc}rB5 *?qJdw!_OIP\ yxT7'v}:"g0ς3%6} wdžT6-Wm=wo2/6z KO/Cp}GczNjP~ޫXnL<4Odm%Ieۜ7O>F_WXEb=A]3tZx8>ǻ'ov|?} <8$]tcq0!yy &cM7~.G7Cݡx?P7fO;;^QgTwGPRǂ/@:i>`>37TEce7p!HgcD( H{׵b-!|6ė߳m8]y] cc˵aQ`Yj)|nzQ "Mg¾I{\Vssƞ<6?כ}L(IǸxϯ G]aI]+t/.P!2go2MR_Ԕ=a x1+>=2N|;v>~)&2W2γIGo]" ߯C4w}9%K|~g>Qq_#Z%ϓ˱}'WB_v(ói+58,<'~~JH z/ϊGnZP|ğ63A0I$-hS'1O!ٲ-:y;AY-ywި;[OjCߵpf~aQN'= f|Oz6= lϮߌ|³O}08ۮѿsWMz>v_a:_κ jFavwݛ<|I,ɀñ8N'msʛ?E[cz ha|[X:XM?QrkanN|U!9 2멛j'a[p'i?6,p(|Sa15U­ y|^˲阐l&zJe[eʤ' ?ϋC-/2G hqa׳ۍHsMfg:J3)5bƓI #?uw`}>ÛǴ|LꪇoUq1b^۸lMN=Tb}-z~H׌~FqEmOvMy&Bz2cjbk{8?C36tZ|*z▼=ϴ #~hBQvu}Ё-&π^}(X/u`7S=ͦWWތ$_ywrjn<`Yth]XEo;+!\'!xI_7Wx{ޟÐ{}\c<7_-Zpm~tmu7w$^,^}鿲?1_ZWQZsgy[EţO+5O}|aҾ{q =$a΄_*[wDi>R0˓~Fn[J޿ 'ɾ+4 n6CGǃ8_|pT >gu;G\#q< v͊6&nSu'O3c~yC?S[?ŌC=VH%?7 bL<= dCys-󖿪y,Q)V-=/<4|їEߚ[ >ÏwwuT`5K8WX8a5,/~.)L$p3SߗsϿ8+kN+3o\Lsnz!|a-?~>\c§,}.2x+Ec(wXt9Uͦ3=c?mO:zM\w.=yx*ZkdTN6@f4G q[g!7I቎/)y7,\Qccr2=9x:Wj@񘅿z-j>_$;7VX2z2nB>֋w^BʓBJ]9sG'MSq"_SOo/Ǡg~Kķ[\~E3gE#3'Vї_{бzPᦳ\_uS|* (4u{SrՑ^eSYayvG[{]s@̢oQR/Cd~eG|KC,؛%Bӵ=WbNFp,;;W3fVducuL)Mqn_ק*q k j/x(6fqEG-8ȼQZ:?ύu모8~ ' 3ԝ!>wRJueJxRW{??[s߶y+;qA7 ac W7ny*]Տ~V%sT|r~]IWuFMv~$HOPx*= tWWČxaG\hcSK)N+m6R3) =|M@w?}Tu|xK8:W/#cO{:ΉTf| 4!ɐ{)9n]e>LwUm7LjeСGӮ~?Yj}$ڰݪ?߀Y͑}u(<ԗR+bɰxymwu*_M%tz0V26KpSoOG2Z5^GxĬDpXt.96?:D3ƹ_de3dž[wIYps|Z+xø#Y@~k4?a+h֓IʴP=wxv5 t G'Û%zO_  yS{rGUYޤە.נCU^ f$oY}2aT5ԑ琖I w޾7+nSInVaV-8΃~K#2 )_9o8!ׂ>U.ˇx~*C](^(7F(p5Dtx{߆aBx~OwV']ן\#c/Qy\h|5/_hk"nJ<:7p>G<մ<'|/U+o{׹2]}+oqoߍu$YEwܒkJɵH~Wt4\M:ui6|=/-G!Y:ސ_$᮱zݬ":=6=/pg3"=ncLʯ8YC kvǤf$-W\pڮ:(͜+ xP"|;ۙ ]2b `73wـϒF,8^'|-`seKLz4ZxqW\sAwߙ%|?"ֺb /;!&_+֧ >آU.&3A9pN5?6`K1\;2(sK_S I]یϿW5CtuqgU)W8Po"\9MqSȸ„O+qu zQW  s~02sj8NA0mj^yN}0/^S_o_CCMg2ۜ;8!7_^83CGGN{̣?p})Pű07ϦpaV7}^PCq)?/{|1S =o療w}}IАy7 abW ~U#nAez db*+Co6M}VO$4ɲ}gq2? HƑpmhV1?7eoT$CD?" cPn9* ec2S.xVqm:|].~u4RzS*ܿ[t>ȋߒ0אVӞZǤD)V}Lťanzn:T1y\778[_þWD-җXsya6o`󙡾n?+Q>i_q^'G:Xλ_%ܒwąbh+wg>6EjXtҲlqHæ_:g_x@3D{,u{~qm+y3"7+ H N4ihp[h^7Y\׮\} ywJ6oz)8n[0k f{7|bh^hc o8!-|,Ǿ~F6$1:Pp-Ը#q_[.2kr~t\b^ʖ~cy*V>_%OkM9":?uH4fswJPY[Gm9~ht:ī?_M:qa ?Keƶ7cz?H~hkxA U]q+vcYޏtTw17䟇"J)?'o&הhXP\ʴuR'}Zi6VW3 eg8lbRCtM0r[OM:R+cmyeGAz: `cs_xk #u=]yy }ڕ~+w5) soy g}IjΏCGW.e o4n]'g>h?xq*e~C%jޏ5 z}v|u[m.̷|UtBZ<<36K|h6_}ZyO/,urf!xO|}tN̟9/Mzjejf|͏yLЀToMIO|?._ j_֞Ԯ]ޗ%8 Nw_N_./ b}|k߱C~{j\L~Dpo3A|,~I;|q{&ux]Ħ'%Oyo4!>/Y%9dבG]nV 7"`{u|?N 7cyF qxdtC-^?鳣H.]{bK(sX(Vė&j|gz^7: HY|0?齨N>,u7H#\o#?NL2p<__%p)>7nx,gKQP|&,xϠ*\-^Φ8鼇rR7EsCA]CW geX3!:a~K|>?潨ǣS9U-tkk@BXŐiaؾA/ 9YaY7C+ۆ-x)Ztleqgv K}^An-cm*H;ת}W zT&ۤ&ȇSnv}Gy7ń-YW~7l&ܱߜgdπ4_/蟠 gz|юk[]u |MO\HGZ6pmy)Yo:ђ7ovȋ}"O<;yZkJ &Oi/V*4 .OhP>yX=Q= Ƅ &>Dpemܹu>I[pݣyf!C!{yD_)4d:1y.^w_@uv~8V}/4&]oGBsI_>)g40xS]L$!هniq݇$ʯ17w5_x{輊c6W`3ٸ2b{WS_O_7xMyqxLR cgܢRCGK߇6 %y"W_2Χ8p^d Et7#:>I./fko}V>Npj/Tύuo|,6~'稿W\6ϧ_g|>yYzs/#?wjf&>zbh5j`;X٢߃3> d+m ?*z|R5z)HXgjj|a\¸%DŽjW6(7d0ݺ;4鼥mK}<6]^/܏'AL!uѲl}P3~4el+ ҿ$BGpm^^ i~:qn𥘯L:HS,?O4 wUocv=Q߳O{.'uX!m#5ul-҉^:ܦe&t&~P@+u_KB<|K,J' ~?w|nGAdz0oԙBTЛ=0De\+;J6lap#ڐd}z.}vߘa?u r,2߸#_xq{\μ3E޺G_/KGc?6/JMg%W7mwpx W rmIw˗r/}+****************,;9Ӹz˪FUW" S੧h3; Χo;MOCY壣ނ z=Ѻ- $1,85j/u_tz_QՋJ,ڠ~vqahtv_p]]ul1+ R_KmeI_EET{0gtFe?gnȆJqx:C񎓂X1OSeq$"3|A+z:)&Uh?Ym^L3n\}l QzzZNt}[(25OD?|Ooh,to <7o?QY'>*$@.y<φPg0e]!aDzXXKD%aB+7^i^ m ~G|y'ʾ~iZon#>CN'ؾ+՘>'r>'j:R|Ԗ'k ;^jSq^~=T[Sٌ5>WϪj둫v|pq㽊1Doҗ& [I=$4shhXg.ݓ~Ǯx->Gi/ 3==딴/C;cܯs']+>Yq3S5-[H?_N؏ =-U m=u =~uQ?vp(tu\ʏ~~:/j__OtT?os_ɪak'.ioD͇un&Î{r>+yuTn<Oz#jcK_JE˽ꎧ[N S}[5ώ3AOAq߲aX3|u&^z+cXݳ:ťb; z~=T-nܢ֟!(r2nJ%>՞.tx!z\;x[4V#s O5~osPxW=x?M#{ՓGϓg{U/bN |e(aXujPM# O/Iy5ȯ:4fqEަ]EoT=uՋN$u;.קv;y/zy_B<'(49p}O+|%IܞǷLğN׉#}{hԼY L)DHlC숓ha?ӖxO7̽{Z@5KE'f3ok#U?a%ոi~gěe܇pԊ+ >WF뢇H04i8c1uG: xnzFyZKKq]X]'}:^~_z8MKf>(  _E3^ Θ{Pǹ/5{HGhȧJ ƟRg>9P~CjAm%tqN}PMw6?gN\-E}?;z?W zjaȻx((]GO]}e/s!ʛ!oWꗌQU͟"PRv{z HWͷ-oz?q ǻ)Eűh!sн#„tup<;yY'ulX.'o""U77Gnd_U}b;Dwx1{e h>]mҿu\WNYk ' 96{:zRRyX\}~z8 눟!8iY3'\V&8\)^?+?v."ʑ`/ʹK9?44:?bGjYV \`zȾ5_[W&}sϸ$h<.(xG5-ptd x_+pqqY=߇ݜpq8dc½#l0z= uvqwgu^Xev!`T1~:W2Տu"]Bp[Q?[iyinv{b7J Ǒ m *Ɇ}d̸>J=gOe2/U+3? ga6Jֈyj*Y y1y -`W_?i7}*|ַ~\1!%ԛq>O|1 u8M4o{4#=3!ͣwcO|յ:6-Y|V;A}:Z"x qZvZW}QɕF#C^:u WqVСFٯ4 בuN7_YVnPtu|uMy.=j3jtxly>uPtloՏ~\ /ւe|jyUqIZǬfLx~TaЏǹ/T-{,JsO.>  X}R񷆟_A℁q4ZwNȹFu DԅUd>z݉W)gVY͏?~MZqthA ETi>]׈'f!5:tOtL`x4/?8|FQuoQy\uÌKNUV"~~7g{JN]=Fᄀ9Mhn˭7Go|o]+ۆ&TF>qOozpsćW<*.uzNt1tCh=!焖YD=/zٛՕC#O`91h&n /cOrVqɿR#|_TACۏynjQُu+O\ɰY7\o}NzȿmיJ7.yV3Q= }! ډ мObG\&~qG\@C t:%{*VO?#?IbCC3⑧hV7P'3%qP| %˄d67Ût,~~+?=x׀s8 w|~~Yy1לIt=+#rpIVqR_WKv 9UP1)xCXckJ^G[F3{'U녠CJP 0`ǢE?X2]ݦ&-} )4gO~F̓5I錣=2f!IyRgģ7^tPwN ˞Π+ U<&ȩn~RjqONSEuIW7W/IZxmXT1=hƆG#TyOiFk2\eɘȼ#qz+B1)x2ƹ} zC2v< -qco8Lg㭲rynjg/PF2/&unR.#/YƤk޳Qy7_iBew!u :Nq=uK2#w,,^X|YTWYS4J_K\ONk R%Ro@o}~/8@uI}|Ju.<;"?]h4`A:[JT/{ݯ-U|ZRޘ!tB7!>/TeГiQ>_Xo|Z{ۭ#'`=M_;kveab:o㴠~AG诧:I\ss8˫azgs'f׏_>& úSqGǾ=UCfOy X5ZϘ_Kkk |7Y⥜͗r5ɋƃ>HymJ-"m[plQc'Q҂wb2CG~F񇲝Eq<`\6_n1v=g4R/'1Wtv 1'sh= 6yaV=%;(1v]ne3.g3{n뫉b|wYsW{ 3WrOn'MeVvx5:G\pֿGٍ;^RX}\x)A1 ^e}9"iyepV8_0z'_.&~Zb2CCˏ@#7cqopD"8e/ӌq{ 2׆Yo뼙\QˏWngG<7cIщSO q(ljm UUOL=zNNjׂOQ.C_L|Ztq>](?Wv -^8lh ꋸS,ϻŭw%^;Wϖ,C蝌'u$ï7$v7'>o?X__}Io":/G^q xE4c ḵj:yp3ZWRw2SmoF}Cz{҇WpɌIyO{%nm;ihkkLIO\]`38^D8Ov=! ~Ȁ7[S/:CSP^KRy1|w'!~y-]>AOA`AFC :̿J:0/N P>$k ѿ'+UW̧z]FUi"сyf|$Gibɠx%/u>F[# ȣmAW/Hy7-f{Vxsa/Z;9 s4d.gYt SG4?;q>yL~߸&qm |`c~7qA2?Xw9F5RlQʼ ߃3 0kWgm;f󣟈%UC<#_]9Tz}&y<}CDCa5bqgҷq8`zܤ?d'/y_O$$_5ήo_ Q{-:}mbSXuMGAE+~[U5yw5-=$'કj%7뷗8nJØ T' ՊϪtHIQ$%>NhkgK^d ap% 0>:5ql~gC?TMRts<^GQ/5#y1VgZGo/ =G<=GFA glk_bg,.Cg3(XQ,0 _Uo--"_dw.bzTZ_Sd8Wx1Np7=5޻>WpIY&z0lpu3":Eݦt>Hykt0d qֽШfY}vj_6d &|v,#VZn}`Sq>IoŜ5_rşLF]7,Y?</jdp}dS< >=0̟( _p7|miQkiJ>FRSEŃs݅K~.#\se0ݾZ}>k HOLu%S| fH={![6tqJtpqMmw>_W7tq6Ac_XgC3xǙStrjKSԑWQ %ω]]CxQCcE|N'}ޔ6J=YlZ' &~gRw- oSՀGqcZg}붧˟FW^IKms3gȃ^Hz<^C>Fq&C^3GiJśgZljlWnyYVEA>u[b3],K ?$c|؟a 8>R< '/I㊺~S K>59b_7!8$C^?2ΔT=MOof87VCh/@w~[7$xu/%źx=kKģk5 ~K*I~o=K勫 [݀۟>k[EnqK3u#yRbO:x+XH4'!q,tJ7*٩sb~=7]J\Gy.g#Z2Po<4ɯt.^ElM\q,x!>H> 5z-7I3\Zpjӕ~S+C%^U\wK^B]O0A+[}d&pO>nLaC$xq|E?Lz8NTaN5ߔ~_qKNI* y}Vuft\n9~E櫻"\$t2ӑMw&P50֯Tl/Э|7 {=XdD1OT'֕D~h/}c^n3J~~mNybm%(ougWY*#ڧ{mSKK=e Cx|\INOTdzO7]sux >:ήnd?{[*OQktS+fo#"ruTO#G CYhȷ>*.߲bsW'ȤeRC{)_ D訿:0Q3:V}5Iy̟ E8[7xϲou5t㛂<&ky5gKҲ@e_k>08TLzЂ ?_[g[+OM4YCK-c']Ǥ;6uo iע;a'u/EQAbw.|R}!~j S,HiyBEy:>}o V_%xGXs9IW;E|~ 5cՑBT~D|91=o(/_7u) UXS9ͣF`8OKQrM}d2s{߉;kߦؠ5x*z/H}!.aO7qCEOk/^>V?!3">NφFnR};9\,%7~~,ˎ?ISͻ>5NZLֱK0KM99^ԯMso9Y̹U?31~s2o\MO ˣu)8OPiҽ,xD|E|Rくu5c*>ϋa K~f喷w}f<~YAN;[nWyv]2~3O˜w y_\P||Ϋi<;P2Ƶ7QVPZ{26oѓ#+([/4gːGtD;nKτy/h<yZtM[D (OV3w{.Zd#E jGA :>W.PDEz T>1GM <C! -T_٩j^ffngcq?(&<䙕p(?xnc5_\Â٧z>]Ժu+e|W bvk91Gpdy.>̠ahfOL8F4֍SQdoGjU1Li[gD-.k^R'^^z=aR|!Jdy丆Z>tֵ7Te"ug G?_sz='W?:F|g_E,zGIǪg$~2P1/$OF\2KGa=.Wn8]o3xRy6z$?kb9.WO"*]:ҖyngjւFmzΪ_}d_OO~mFoWq&{Σk|:WPMQ=/r}Nƍes~tIOyb[]K{:-"{G.BH/+T^gm?U+Ʊx{(KMoҟƤ[@%KKoys.I;dRw{ze.nbVt㣍34t{Y@u]ƍ5ռQOֿŁ(p[_$Gb@:}|x_~Ӭ/as3ʳy:d-7d}mѯXq ^ֽ [3çu)QJ}>Ztx򧚡nv"Lx?p?lƌUnyƹ2Dwjp.7bwCiv5%KsMP 9ߎ*. FOj8νT|Ûe+?erS*Isϋ2T3['ocеkN~!u׍x?by(OuE?PL&0:XͣiGwx%ϻ=ؤm <3 5(>jx ؠϱz>'^yE%W#k#'. 7ty]Sī߯cgv/%W~'f5@?c1~~bXxW8|<<&0]ՉEx +yo,1p6 >.2lZ>ceЁ%Hߕ1&7e7hJg=Ԍ=O5)/gaSXD9ߑuǯF~s|o>OaaƩ5ME-7Tly2R-T#Iȼ7 tNy}qꌧ<;<%aH?k>#f#{\۔NڢÍ\M)/ћƫn/74U_K\ȃ}-ߘDQHl33U\/I'OCߓqnה1i*߇b> >CEL?o~P]Q iZ} 7:6t¡`OPo5~5^e_~?Y|U-$K'tTp:2l$x4*}FO{+R8aQ~E7H(uq^B3xeKD=ئ;x?ۖ;T<)vã_;H/T$PE?o6 =@׭s4n'|Ok]\CzPےOZX.h;ySM M<ΈaT.66Q ܠXypخ~c~5WmKuѺW7d} ,7=* BK&p9߸ _>zYOWx k fIH^[ߐ|ǥSŲ?)/:闥oPm콻=x[}[gmDkVcSHۊ յDz^D[T??&+;\G"mÖj_4Nx.R_7|- ^}m᫇1/ypYdq& *|F/K8}_Htkݧ{ ➩nNĄé1XWY߮p,<6㱧mӬYKz!NgچV^r1U]}e|LCntg̳R#ϛna2?V0} ^-*Vi48%:w '..ؗ|y XߕkMY9ˋ,Y!cߣJyēϐ_6Y>ЏuPT#f*^?dJyqM5t6YtN1|ÎT6FȏjHgqpˠQ+:nk}C K*}LUQ |sޟu|~~?cƼqy5^R:T2tL?+qi8ŋKtpm_s6xŇ~#O>v8߫%3&>z N!I=yGѷL`u;8Nd&av:(dndS}K=1*~iJy^|L:aXgvU-|"7~-^k?"Pxh7vk5w1F<Sr}|ےEGqDg?MxcLO#8wLb"?N1}>87n UϮ.;}^?8şaΟXD#T6XNs+~/Q+ދq.֯:''j=ļMu5,;7>vwOT`tR*;Lm]Z*9[p){-u km9ޒ["ڇzXx $tR񸣞Ey<$ ^1x( }7 8[x%^]wo(7Ul5m7Gv# ﹗CYίضMJnU8 ]~y8q`~ҜymiE_@m_?U?}3{[ r{Y!}n/E^+|C9K>sng<4WY7e"gk[egzǏ \5_ yV6=z>18xni /zW3Jgr1NhwqapClW8P܇N6ާPgfk(yWDчΈN{7|:+:GW?HߥNO~Cs?0/X';WiS,-<^n":q ܬO yVqW ZpV2~Oچdq*yKWI2؏:_z~]pSuV솃c;C!i_ ^rWLzEq)?L2ߺO;0 #7ݼ# _|>qI^&Wqp7\qH./m'Nj8?_O8;:[9]v*qK&x1qq6WX[ }eY;pRAged܀Rږ~Sj ,J<ִpTf!Pgq[0~&ۦ\Ĺz:8syqL9|Fu>5 X{)<篓+.myLYq<+LgoWkw 7*ݩfO"ީx=1f[7p݅BOuN ]/7\W 8l#]>@(P2['F ]_tq3p}L}R[s #sR1Gmq!⤉?r緌ǻOM/1_.$1ѢQvsWQw}`֊jXZ׿~4_>:+ ?y ~҈t.ϫ1FUةaY9gk7T6Wq wr?߸'u]҉J%u|hܸp9Y=9z?V?#֩mzQկDi"^,p㽓]4q-}т➺(N~G꘾<S`M~s;O+io$*97<O?*Ⳣu'W'ʤ"fK!c`ۊx9rq"gyESR;F &m7-:}:W:t wẊY~ccS=W 168]چz:<8ä_tWsSYy#p7d} sqHtmWE[X`'>n72lUS|q5OՁqOAbfu44p/PLmQSӒxjԇ<]p3ԧc(dm7u c~&)^/ 7'y_{8)Ƭ?_|o;|iӱ_N<4:\,p__:Λ,>TޢsVn,_V>E꣞秳-CnuԵ%ϵ:%шG旭`Qkz($f/y8-O.b=O-.Q>Zl={3[l}?kM]z^VQT'_Nqp|^|AhT&| O%7I|Le2+R88WK$6Mj6x\9'R}Аɭ' PO]++5N=;eo~6] syq U|WE^q&?G)S!rş;<fƸOcO˖ҩZz6C5~<ř8NR_'҇źYYw<<V~NPNޯ`_nzmq|4/o0կQQLv}yO'74r~DZxнRk/GYjzݘN8ֱ? z9Ad떭Lpjt ՟y^H)Upu@|./Ѻa> 㭛(<'@HԵ=i>!oŤw|^o>'[~^_qbo;j.lK.A~Zx6 ^ xab㰼Pӕ'߳H'x49jZ~w!#WVͤGdI}JxB?>]=nk_E_mcba^_l7+|1j"}\ Ϸ V ߟLRy4F4@'nb _< oqMphЏ]q~Q}_Wzw/sVa*z,&˦n(qs﫹qPwK [ʉ~EZ&u'Ό4Toh˕a4M^w| - ,u,몢%MbpM_кߑ- DIyhs%Q:aD:&ä##s?ĪB?nn Hϴ~} {y9з%ۆ"u yJii%k_`|_C_] IMx Oҷ*>@SYx?żo9S1g|/gQ+Az}BKS~dѕ72t{TC:Q\P37+Z VDCMW0ϟ;Q؆8_37bs>Y_:'c㬻Ro>h`h8֖ubXN|nDpĺz8?8p3S[dppt{Y#yOW&qi)3X_oGE㥘.6>)_n,8k>?9ӗfS'qڹMˣ7fǻn\5#.[,]qf~f~g?x'P 4-}{1QO̳Z4EN6i߼*L5V{%V+zXG*qAE:X&j.VWuO+ܼ^^q|oG ꢸz]o)ZM0Kz1qMq~O8zgnz8>IhN%t1 L{=ooxHwo2PV^:̤#K,;ȯGď\0Ez1GЎtxˌMu u7-9KNJu|ո5Sn{T>(nmzA[>_1Țnŷ>9@VaVkcےֳ+****************ٍl37Rp T/)UXHŽU=Ɏj_ZlzBſ`<4?w4-$87:o_NA-OOI>q;Ew3 7m'_7G:x&u9wC-`sпxϩk4GMЃ]⚞}Ny&p{7Bcy/-&?DPgxiI=1vqes5 sTw?KEBu[ܞq~HGAwuM&io"t4%ԋ_Sׅy ?q<> ] U?kXBjMI֑.CZ0BZ9lOV2e}ez.]uQwX^ICY@^r\.^Y;,xɯS]O:$X^``>]_AMOYsz-R`A.-yZ?AX[q.֧Knĭ‚ŊmHLx_?3gbm%saa{d/Uu<$Pt*bg~?q:ЖvtLSu/:nS6=szy=Q7P2-2hݾÆuY`Z}7mڏfAwW}I9^ACSvWsڷ-xꇵߣJyTx1uK3Yh@~|?幡 fu36>ܒ)h f7E>iSgo*ztP޼F伀NP8ߠJu}~E돆 2/%ߑq>n*EyK:k)։ՍnwSUK7h+JEmX=)/z>ׂ?[zW3$+**ۂG_aVa*u 6jgRC7NyJ !a}enRCmqx [k0AuǓ}K%R~託Vލj(</ Q6^kUϡ)j ވNCw a1gs]qߖ8'$lWMo2φDOޚxO ExO)לG7_\Ēnjk`CjU0ޫ~ck@n* z#/a7^pb7 N/Gyl?'/}ϥgS+}1}mQr_?a]+q?<'~ sԇxy۪ߊGhɡLy'>Csu ^qjבq|`~-=O1h_.> S떭~\<uxpVzZnۙ}NyѼ\L~i>{ñS.Y]O'+l{2@!E`e*D4~cmeLaS{_!/qǫ[WN R\?{W#zE_EpI3 +n }( jSy}ɯ4Q?V|/FS҆#m|O7 HgPDRG 礯[Ʃ7ÿaE"?4NMp9[ t?Pϟg1~Oj[Wcqp-CS$5?~)Ok2566%[/0P8sO!c>npȑR:x7Hn䍚փp>u1⥬q,?+ZgpM⸁9sy_Z?__҅x`_۠tWpЂtRpL/~Mz/o+i#t%?b jݎTΎ"X]>.pcƸe^|m~재i/ wQ]xR'7t6Ä(>+0pphb֜x)8N+c^< [Yvu2爓ʶa.^NN'|3|'*Sg,#%~XnEX~46ދT=~&rg=6X7~& #Xi?oׅ$-J07ud3SxTt.2Χ/MEĤIOGCO[tϳnRo:n[< z:t.٦ǹ/0jX0&e_յ@N%aKgK}V&ij&ŒskCxZZk=W?S+.R?R113׶*bkKY( _rT'=2FN8atK1v: ssN:bw<94uua~ɘr'?N;FO 80q|6կ?@Өd1ObX0St=gTgz$8d]wxD[4ˍo܇kD+[uP-zߘF@(ϯy맓3ꑶ?>|N{]}C_rì<1(`/^1jFo&#Wյ"IMz52/zP݂e}J$>&cj~q՟ m'~&j>iCkq=bu oO,,޿j|cv/'xWƧ [6p;Cd/a]^Ɖ뵲x1aciaA5•L]?r!RnUE xk]bq; 6h$so0+<%AnCYBq6d_ ߲ c}^x^Z.jGO,x+bvndz1K^մWupY=眧ף c6ORMWKC&z~c31F~e9_:)_'q[0 ZQкQ T?}|A8^{u+xNq¼躚447_(K_ yV2X!(kv '~M^}p6|>SNOt6/_s2n}m ,:(֑{E|YIneq=t+-sEVOċ4yf7zV=/s~`p&q76=\*P3^3RWE(n)wl {gVtr=8~C)[ QE繣L׸fa_RYѺLzR8Ĕ%zqiټnq{}/z[[&T[do%;H'B}m}T}.:Y-Ͳ۟ zx0]w]|&b^[ċ8zÚ"/Y՟[w>^.Ruh>["}fR'Nn\v^ސO0HT2tXnݣĵh9&ElA>ÑKt5\ϣ羆IkfOaw.^8l~zsp npZqY ~$XS<&uny!Uf_W{=u1PWCLux8̈́-Gp/U Au1ʫX}"t`/q~9[2'`A[*1^ӮsxM5Al{Gͣwֿ}h0ϓ3=~q Ebz5I`? .i>O7Td:s'v/5|LML/s><=p}v-))7QM;k;4 Q:_G{[5}ɚT=Q-!RM?uyàgN:R"﨟BQtYQدT5nWax4 |wGkz3bAsm.1Ku;1;$g{uES_aVaVaVaVaVgAcﯫ:+1s=_E|F5U ryIh'&mEW|R ̧Jިp5p2+4:Z{!>h{< IV= Gc)+>8h=9HԟgG%%,so4>ȩYSzϣi:-Ј 4x?WԦ<\\4C8<ipMOYDUe̯щN_QݠhNi>2YїkhF5ps,ztX>R$ܮ.">?Fp$'uw|FGsΏ?~K+x\L#ļ<֔!UK_L^Fuyncۖ}<(֯?K >բn:+Ǒ}tmm5Ncgʻ ׫xe~'h;˖applnxo{^p3CB}9~f6m 'piy2|9PW+E/֯(PWw}#xE&gma/Taݑ}eW&Hq'\D%~ GD@[}?q m=%Bɤ3/ ylYO<-S5:Fl/Ƣfٓ >['-~8S[cz 7AmQzwy s9䗘xߺ\-5G :&}("pX2RJVb<s/]G.Rd*} 1k㥿?=7Awx,725 8?SM;t3.ِ*?jLX;S*85)OG^Y_+{+7ˆWXFtpI(yNW OT֢}kѸ+}mq{Ulcx6 B X8V<R߼[ \cR/8WeuL8*{w]*R8L&upԺi<[ :xh熓ʫڳuV4բO~PQ>w̋ERo4w1x9<5uiϸY1[ \L=u>^O5|?\m}~98:b `be7Șy.3[1=B>6q?GJ#+c?Oz>W\ʗJ=:JҹAzd|[4kKգ~Gy.V,A-Ǹ `Y91?3nTق/Ϯ.&!}[.cwX}6gٺ-M x FFw׸(s]yyi4Jw@C'6l+ŔKDRdЕYW =}_p²yIm6膏OGڎp .{V=Vs<=1S-ӌ;N=X1sa7|Q?zECrl} q<ϓ$5c 7|HgS df(d_6-~]_tf P3L}y"oeI=xk ~,ǓK]tVʍo -qsZGyU?9^MKrJ7?;2NU(^Ýe>cjL~J:875[J8p}zQ-I+Շn\ 1΢7s%8+cEyʅ&Uy}  #YBM e=D]_)7_j*> g ׃Cgz%zMX [zFq˅8ytqoŷ_< bVo7ܹdy5gsY>/A?_d!@4 TYV%3.a0dxx<6Kx< +`1<#3<נ_e3깔4eZ\~q~,O~?VEߡ#=( 9}\nhM[AWyҸt`u5}}DC H/P/Fn׳soL ' BG yAJ~0J}i{t-RqnaL` 1on~_ #c&4M:;#udug,-۾G8KɤwwpcTƈ~,>D}ucQo궻M :oYj~\xy!e؟pLhv}lQsP/ yIy׆ bU hebBU^$s=n_ zVoS\sdQCp%[Qӝ)oAcOY:OtuQ䳺};GpEb^5B sx|;bj_r/oExqPW8 \*e<UA. ­?JAJz7LOogBd{i-¯cF4TŜ?~GEw?Iռ WC[!R_X{/v['u气¶/% e2emنKzum߮M[cl5z~|N:n8~;K_~x-4$܄CG->j}a%Su^ާԱG79Ⱦ?k޴bԺ' %]^;־|ӕ:͋n U]1{c}pאxy >5K|7+ 7bϭ7/WQ.Y_y$]=$qZڗ7Ȁ+M ^k @?;':XOL.c`|ǵ~cK3?Jn*j{Gcoǃ U~vZ!~,ǿ^|&_3ۦw6/X^m%"߷-x%gNyWlW<Է 9ܗŗkzKifwݰѹ_G ('j~d5tr1jL:,_׌j,yA8>Yy,={AQ'dt[ygh1y`񩿙k_0/wG< ?GOeIY Dv3nk+GY޵_^=.y\_q)~NExR w3!5|Y~=V_Xԉ5`Dy_3~71s73$KI/W&}oA# ^~JG+*3>͎ y(wW~~VsiL|n|WPi}gP/Acuz _,xig g^`\Ctxkxߎuw2TSty\_0X䓹.ջ0?T\ܧv>zOfa,DBVĥl$`[܁b}nS8VY}mFT]WE~w+GlEе/$`Obg:;1P)~ ˧y1)=7b~*~i8^u5+7sՙuyzL' l>]]Լf.׹ԌyA?x |Y]Cܐ~> PLͫ~!Ńi ~xaqK=~.֛| t;L/Q;]p)ǣۮt8:oԂyzǏ8﯉buWNآʉp6xlryXٟK/ [RqAlߴa>:H'~Q$/ck׿_z8 $W??OLZ7[{pLb_wk>}fYpXZ:2obxOOK^KTx`/ϛHku&}1$v/G]i1?5L>tPCFGW}1lR0{ fy-y5CF3 =ߞ >\OSMgr?7j>_]H[i柜d`S(\o /:_Uu ~]9Ksv5~YĻIJ|^`xЉ9P=|C݌"OԄp5 < /WU}_|[L.]ۢj-8)35K[#5>vJ?O/sat=կ)QVկo&oȃJz\X?mN4|N:r2hIk6SZSlgxpke1Og'qJ?=*? UdKvDc¿3ʙji8O?7')IkoޤS4L6&>{ )8tz5k:cb*W\wkxN{`kz))JG1 znb!s{<͔vg};jϏF/G6|sR. ]@5<N+Z:Ԏw_w=HEa̔T9#/"1iQ0Efe`gbHy.U H/R? u|uṖ!^+Wz+'Ϲf_L?!}a;1XGkz;c0ḗuu57:aڏ! \s87- 8 Mӈ˯_7>)7?"E&;|!6ZK2ckTϱ#$yϗO= WuyP\*ǰYRIAH<=|#v,~)wS/e0ݵ!wQEo~觩Pio0O];QW7Ou=KN \Z΀A*<ɳ}L<)4k+sLfy;3SSmT&\lj:Og8%%=VPd|ӮonXm!_7ӫ~s.|da@gz|T< ~D_tpyźLK07y͠`=|? (ܮ15В_Ĕzz#?Hj/_<~'>w,/J)k%`xMp}%ux-Yꎗyz}머Y!o6= ?%滱yj~%Ej5տP{N&~DZI0Zޱz^MXX\UNp^㰝k`T%^2I Ŕ/h`$q?c^ܗqKq {]E,bnrWԠH7pm&~s_rYW]G/|Up𻞏ӒGu@/+Xw|.Q]?C%[ Czr.-^ƨ$`/}TP~>,6^5ԧ<%uP3:5z1ܜ j~{q_,(8ht9LeK#֓EZ2磻'#oX>\ԋv PSE]C3r};u[#( u$un#<|smDVg>puFTƉ}ZrG yMt=Bߢnh}oy U5\:+j5N%>6l} Z?`oל۲5W!R~q~=Dd<gj' L0^*t.)?bLB=-/Mӿpjz_ t&j>שDc1Uiϯ+p{loDI38K}1mu&y2u>:o3o65P=m}%~aD>m_N`^E-3]ycskWpb}h1:(1!~oO2z|B8YRD-[z ,V 9s_+v:lGpl-' /} ۿw %[`s"A<=o7{l]d]۸ߤs l9;V`7mP#7X/l8h\.ګ<اƍ7$A[~hȎۖ ?q]?CW|>1|n3bՍ2 sWp~^}`T?׻u5BݬNJ~Go<9ԸDBi헽*u#5WyI176^;kRχö:[Ժ XX(_og8n+ߜ&)mG9.3K=<POOǬѕ_\X)rVd>iyfd: R}q͕I>WsSѕ@?6LGW0cqX:tDS~kwn6KYtEgY)[1"7G\p\`˻y_!N f4UynLχ^ON&EGߞuUXY޵_PHxu7 TXxJ|uvz}6'Pe[dz>>ׯ-,/V'[;E{4!OǸ͑V~~}gV3ǿrw )ä;aӏ1GOjANzrehB?CǍx u+z |$퓕+٬*:|z?[dx~G_^U9zF)QQloH~<}~yJzSMo2Z7#:s8fTw6q8o9MMfwSz nf{~yu$^ۄä;E#¢Cnw0%=Fka2Q4ߏ@D3xvչ5j K.W]G<{d祾nX㷮fٗHG*kj/?׋p哊?q˷J }!q˅6=.3f/<ꛉ]:7Mq)}G N5# REu.R/6JR=xcƩcѹ| S523!Ӊ.8 6ԈO~z}e1{t<6hGuQ\fTA(N*Qqn] y7px_^(3xUuPj"K}>+#=W4<+G>#'T27t/ۗ05H=p 8ߐx{b|G}=^Ke~_g:G.{~Wpm Y^tR(?f\ CXa?Q*ϒ?Džqfy 7g}5/C}*ҍ²~~z _5/W%s5yc}bsH̓Ay}ؠ Ć>T5Kw{a{K=x 1uu-vSY`Xxˢ?P_7^?q??3M*΢k~Q#_?wys~}Zҙ^3 }4mII=ujּS6~U r 8H\Wr{ϱ:Gigo{_G3dw|iʊzqM&kwq>W$nmy/T5Q6/_osݣļ_1*Wn%~ևJcj4kEױ3P˾uRj}LθC~z ob~O[z ?8Eߚ"Oşs;Nx<~] )R/P5=LfX[ 1Q集h)g{fK/͊N,8Lg_N/qp~i@UƳi,oj3,\7#yo-RѢ~ysR#ύeK]I p-[Tqg~mX< u,21Ts3_s|Bhޤ~֟a<#&?//P'KugGb~Fcpܠty>>訟0Utd:-D޷˯_'+ش -W LM'꘹z~*u9b/z|-K&ʯH=wW+Az;G/Md@?mvtX*>K/QӮs6cY޹=G4z/K|L}1a'(7Oz==wƂz\ywpTqk 4K27spy^vuf} Sbx^ո|q '|2ghS~jًo)~#Y5eRl#K7L}8~Yl}R?c#K"?nR')P0?! }:dQ"Qp,x!rd0kyC~{[ sicC?~vXqz4nk8?}u; Ǖ}I9'aWC{ޟwqtQϒ_VՓ@JYŔ4!]qZsvc-o!=x ^H8/kCJuwS*^'=wx~!L7q/ut;LKÅW˔tъYK2E#SxNW>V(c(cuޭG=,+;zE :q=/_:Gqvt2sM/+[3q} !>Ojht=qֿf<;Ett#]t\:U{MTGj>񺰴P5PZ}qN R]=ls]uT$\+cj4aS:ޜ#a}Mud F(m)0O uq,a-Ox:oGyfl7pL_ ,>nIDp%q]=t^>"Ρ>G8hz|[#?p,X`L٣7Vt]}Nqi24>nJ'/m#P .*ݧ~*)0b>r~=Ϲ6st=~cJb {L6Yo4ӛ5WT׾&iRo~+YPh?RKLPUX0(lr}/=^Vq-L^(/bb3CP*⟉*aP(~1BaatbI~j~[\TcYܛ4Z^,K4Fk$<#PO rm&Jod||aD-^3\cY1SS޿)N&+<u"o]-}9/*/*j ׏Eׯ6/f _t;,cц3pR%IYxw0+s70Ӓ7 2|v(i[pp ,߁fC q,e+K9ߔL~x_'wMu:$>.n?;c,QǩdOJG UinsXUҽp!M< }VKJSBC8^cGg}l-}yO\):Hq=*JV  t6]p*k2UaZ_v̳E7tN [np%pvhn^7΋}C_`TP|=74fqi:(); |Gj?a=9zK ӑm.OA{š;;~A:}:33MPV^=IP$S\A>;EtM`SqF_N-VQxN\bWNnXG-q~XO X~(y^p*I {y`s>oj9/5p! }IWC5oz;=x%\Ng/l_oVMb>]WjPu;W⎋KCm?'{;c T ah`Y̸bfZ2 1 :7u8r;v82#Y{OU=y]{gΜgݙ9sz |LhѸ]TCYsMz~/\?^4FߟG%]gꙉ=d$?;r|8x'klNmIG=q>/l2ovbѻ"x^Y[?j`'=(2Zsk͂`PǬAn\ߴվΌьp 7'qGECUݙyz53o{['_Cyuz {o%)b! p\T4*LZyկ&;ھE=~)ǥ<|uxXx,N2x 36S#OB;@ǟIZoWz m5u_`'~NìzV5WU-#8֭Sg ;~5?,<5U5/w b^]!tP0¿IgE騡%|:Z}h"s,a^ofsƊ6lqw_W*[ux\Z*jp(Ò^N* < ,}l=P8(+j?,H|?gGǣgoz^U+$q`Å U_ y٢ϕl;EɻR:[?ދUN"_#}XgByv5>xVX`V`iYTߗTV`f2W]++++++++++++++++K(38 夁f=R#JC#:w1jo wz?su|͏R_['x^'\>S识£DwP#Y='d収|T<.q9{ȏ<,.J|Kh O|y ?gzn_<[7]Z G(4f=yעEOu=/TyoMS렫Ǧkû0w5LKWwVیxn⁵A?릯ה_΅𶙏EEu^ȒYFʺSW#b_Kݖp,zo/[K9f]=uoZQ֥P#f+?ci l{/G1[Ǎ˘r`8!:u-Fщ1?ohFVft 5wٟPRVv%slά!늾2W#b6%epڵat>X?9޻if"^-#hX~'_#N6hH ^; 0>R:ͽ꯮E.uyU}MK?:%e+X/`~Iˈ)&C7JKҢ3߷4ft5}O: JŶMv":a}lqX@;(%u/[xzqK;%C׭M=҂+隯W1BpObk-x٬7; x}4}f<O_]IO?L-}Lovܵn5T:ˈ~K']M??8;NnڿaX9}P=XpW=/ՎunZMuUxzӯ7=^˷gJ1sDzV"X' C15yӨ1>6ޫqْ71MqAWOr]K͡Y4=7j1T:6Yr]x-׫|wy qӧJ7c=7};azwa(zyy.8k%ok7}OY 烟qb>滋#\[FuC7_\y]]NO>ޠ ]j">CǑM}9_7nc9Ϥi=y?ϻe+_/xƮ7:ss7T(P–~4>H_GX) u^a~G-VyM->Ƭׂ5 RƙB'@'䥌=R%GW94pOqߎ 4co31O4E& +yv?m| bx.8^_{o|~vWN@ﶿT1CqHXw4~)n3Vu:CsC&Q^O">Dq>XY!Oxׯ_[†nCQ,}_mHlu|@4idMݿߢ|pH}ǽY=pc6tIQӏٗV`V`հV`74ʻܷPmUf\H']Zxh8i$i郃=hsMPxbׯxqFqDyhdzoE뛔y |Z~ow //ʇWq2w@>ꭻ_~o1~y|Q?efqCt>ߗ)no7)'itڿu<NݒܣחP:?<}d+:qn{eh8$S̸26j?oyᴞΥ :7ϥ}9H`eߨTN__SW`];ok<>5DZlFo`}C?tn@1.ճ9m;P)7 w /~)/`oWu1ZR.y|yOהrou.EC1,yݑd~eҁhxޖ<@`^V]+܈Ⱦq2^dz?Ҷ:Ie}q`׏~W#@6&MW&^_WE !9(LS``C:_`n;_Xȼ=jQ˾u>oŒ/ĸJɿ.GǛ8tz P+(L8)†o0nW:[&uQ'$OTa]y\/$u/0g>Bb*8⟢_p =B֙ʏ1YWYD\zG+rqn/??$9e<iNgZpq}|,+fSg* E53Ьf"`'x#"],<}di{kC:O9;8)~*6/kOy][oCw֋\]uQ-hD|:7OӚ/ܕ_%_Wx |N|SV7}_7D?hA6-tӴބ鉅p&oK/?XRP)1P~D|Ft6Ztي2RfxTD7vOJ})NkHTTCm_Ly?~ ǵE3UWy˧V->BM7UnhhކApŷ)Ng{a;[W1֗FʸmBtlz3F|G_9τN҇e\бOǂO/E5ܰF_V^3m&WC7@擱&~NuM\E%z~!jV?Qnt$okOVB}hi_Sy[<=3i*OEqC[׍< .Db=[&p5C{ՅJEb~n#~xYg-\G5Id%oy溾0i"DWE*bY*cьH'K]]Oyoe"?dsx=ߏ~;nW0x[?ރu=]ɯK:QrVEʣ~Y6{80$H1=]ʉU2)ϵwO~#)YR"K3[c5#zh+/qdTG{PHJzbir]?ټn|ה뎠< _MwX#*zkB+ZJt`kXy=t"'zQ /f|hxn:k3-̠}\eqx"0@ w:g }yVg`Q3.}gGz7C(U >yGrCf*۸Zk+g8/utYH3+,hO_[Hs9OSwTޛy+/]csV {>2p,c~IW U Op?/ߓ՛,K>b5̦ͣ4W5ϯeaBo8O?rXW±`~C Y3d;²nL|!{e?(@mDC3zL.f޿/C)}lu^1Nı9._ ~I1G,S`r\o+ǭxo0s7Q󕪏ܞ63Y=C˅[—E{H=šzfZ[[`qŒ;#3]2:vnןoU7t)}> 7o3ƾUz^?vE {h7On3\?8/~o1O| ˆN~<@6%P Gyl:PoWEaW7]'3W{4%/jcpW>s9Fg N/76<ת) i,0Z7̤wʲn}rw5..8?pS:IKtoG~2tZQ[t?~;7,x^UB/wt @ϻ.}~Xy-.\mobr\S1PŒִ1:.|Zy6yWU˫K:<"ņƺڼw3b]$-JE)aA;}?N Xq#N޷Ӫ!)z:̗`:zu8!W*xOwl܃\g~UDImy^L$v~+P u%e~‘|8'jG~oNBWؑOtnБWWJuN\䜤/Cb@%aņq^ KZ6Oƞ'eVxa+筪g8爛+'b&^'*#Y+$9-u0S߿yڤWˏR<[UJ})JJ=z+⫽4~;5m\0/gzO9@o^w;|Q֗ ~H~&M-ϕS njH|'3 '0/<L(O뿯bui~Ub;UG;˟k˚SnxvS_Ci Y{OĿCfVgle~ZKs?t OD~p6SW}Q-zȅ盌㕮L8y7a)ך~I㳮zR }J\#gN`W_{U(^M = BYg|ڌ6}OsͰOqJCG1c'po(ahuae9=~EYq6T}}fi#!+fݤsaXX] XXav[ݿ_9׏ŃV8).DmJ=KڴCJP}@ ϊNwŚhz#Xpu#Ǐy5EBkd%k8p>5X/ դ.b2Q]գUB΋KG7_cm.pօ:Q_˄6Uǟ7-|?ts <!hH<}( z];E}U2pWux9Xg=J|6\&F ۼ}-+]UCu("c(wH;.d/wF䵡:A} _Iu|# Ws ?򟮥z&Q3\B̟ѧDu3,&n3OdYHs[x^Cm۶^:n8"/e^F[koNGu7Ctߎͼf\.`E]O?6\GxOv`0#ްx_gT1u~'}mU_SG{w[z%yEoжw>-B..mԈtTc/U'-f7 _h=o|gc^}o-#`oiOwmbk?z73/*2}[?^%\I1f}ZJoT`}U{r"2o1_`e{i8Gx$?_Yӕw5^w~]y5zN53"l&|d?&^u\>_u5f`ߏLe无#٦\]9-M-D}ct¥-0 /$W9~)wD6/G4/v[:}o~uY uu*?icdC!Oy01Rat}00SuE,"]|59OzD kYt_:G!31y7 __W; o1{XܝG2[Gg)C_wϤa]aGE>"ǣB -"b駖zz^ڿ^*[z=OZ/1?ֻn8r|؇4a麢zH\7> SU'7n45>j*}0t&\gh^Z"T3u=c$.'ÌoYoXI9~!pQMNffݷ7̭GT=Z7l?%"D?'cٟG{EYY=^űWFWzl} 4[qgBQQ7fF>z<<ߗ˳.YSx l(Gܷ|]]Kx_?:((rNj/?z`w0M>&[4^wR̿]w,DFlZǥtx?%O|iߏsOh>?/q@a"1 x kΛk'ϕ=Ge~"?\Z֓dg<3Z?%8hyBƼCיm3m%!Զe<Yp7Ao 79稫ռҋQo뛟 CuGMOb森{gn-WMmW҇[cN1 ׽$p5븡Xzuto,3kiy +$r#|_u?rSS\.㢱f7糊׭~z}c\0*%ƪnut:_5 '.<ԙ wZ6O_ͧ4J{ | z/Ni{:ќBeBt [QՇ1} ӆᄗ\s">θ.:yy ŗ]c{X5~K׽Iߺ{?\׍sW`66 )*pSjUy9xl}Ҍhү4d}7xוMד,ZV|-:]iUA% .4o;~Bt~oߋ5cﯩAɠ,XBx.oz1|?[OÁ\i$e54{1>h yC׉c@s~x_,:o']Eo1=?{ 7}5g؀yzQ|y:xøo(olc_9ʺ U-|}Wcgs^Ǽ/,^N.G~RfH~ۭi}}0*xcyos}}0d~ ƃUgx#x]:EʣGkLz}^P3O*~S=\(y%)o~cR\qkX90|}|?N8 +N8͢7'oz' 99q6柕{X/IsGyc7TXg$?N˚@Ks}ŐKPQ`gԫ=Co[/Ì&9sބp=BqU&Z~e3Oi43w]sh4|ߞ_!>89j}jOs]xH͖giEާ[}SP;BMXoӯ,_4_T߯4n7Iϳbeڏ}.bG> |;L{!?:J6w_W ^?iCzۧ'ChgXՆ$XGѭ%&t(*s=.Z~NX-u6GM^:5,af Ty(W=)+x藍_u*Vk_PS^;jp;</gckr)!>HUY缥> z4[H7ktG}(Ch?`@+x_Q4^P%_uV\+]| HfѹUQnzZqg!tu'Vdgzz]QaOa(wP׏^=UOߘEp}yY}i op]Fٴ? >~0˲D>}W|U,xߠ|m>\\6h;ͺP}L|\Ny50?-)pOQK0jOJ1xJ'Q SKD;gt1N_wP\޻nHkIBW#Odd , }s/ ٷz܍ߦ]'s{Oy@Rwէ\Ş߿5b%H Mi߾n;WT2LJ ֙}ҝzČ+zO45t7B;9K~3VNO^ewT"iL]/@Y"L?8E9VzI)Ws^ƅ̷`)ghNnҋ*|5J[cwLRuɒTv:ssTW}_Uj~`}OyQ>Ds%2/΄GS]g~y? fP axsa~?jO] n 摠P{e?3oJ)cѯsGp{tBji7BW݈?i7-L{QCOׁa__`SƙReE:Y?AUy7 YV-άp"#[7kx0NjKIg)?6%~ Ou<0=7Γop>v}xR0Wd8#ޤyj8Yt~+>G) }7l=uUFi}sLИt 8~`,<7x?ƚxl|=??=Wq_)c|2/.`CZ_^}KUKաR&c9+YX=t~6 èTpB77?YJ_42ν-nb4&̬jv8B ^wO!azS~ec>{12??opGڻFhHyczTB|u2c߃/V<8Kq2& Gj{&_X]bw`])ױ1R\J$g z)Uw׭TOsE5, /u\eeڄ}N袹>sf`D \٧qqQX%mLJ+R<=ܖͿkwyXIޯTN+2ϊ}9װ8ͣOIF[1xxS+q&7,xQ?ޭu2`sp$O F 0 GzH QzbXqۋ*Yub᫄ A`yZS&=~̿ɤ˺/2-qJQ 3)/^?HQDp];:J!]s}D54w?EiĦ҉M=u3++SfzX3U;&F- '=}S|=N4T>Wbwv+(u 3m 擪5J2sZXᗱVN`GI4JOw">-ӻ\m)][xW#4ەiN קO qsWu_Ld?K츗D4L7WBFx|ߤ1Dk.d&^ 3T_/Syh9`[[:>)5}UVkq=>xjh zQHO㯪~3(? EBBnj:mߤ}k\W]˅#YOBt zCײ䋭Vv;?Er! Ueqϧk1t3ϸkYn:xnT`_ubyǺ|LܲwJ;Ԛ|ﯘD+!"ь⧉$/f#K4%T!I+#+Z2Ռg@d)`?(b eƟW>ז<O81/F\G7)/tW~+1exÔ#Xaہ`އo 뷖r;ty]=P<|/YR *d?fϕs 2[MPC/?#Os[A_ƞb5JH]ے6,l~M1Mwd6f%zaŤ J0]=~ݿA+/hfY[i)Us˫H+U8iÊ> oTa}MǮmBtfyOqL Eפ 1+R!S抋?MG<)@=~~=D{Zm:ڬ4ba}󮢸pu ^(~A$fjm~ ճ/aG5OL:ny0տ*.2 Kϳu0)Z[]>y } @eE2/+-}w3v}}!e'#SAu\Nio3GcΣ/w+KGz/&g$#+'C"QC\CYӣPN)wO:_K6ߢ}]w݇SΛ5^5J3aT~mXiUE7 ',ε?'1>_`LC~^ZoD"MI}oI+ GH>F%溔2k/9mLz}N`+xatբad.__p6?G`?/CF[Oyttl'>njOP}]O\U_ge>1lekn I7U|?㫍G~FIgN,vXoOSt"uɒ_.˯ݮ(w>U}6\V~O+ҾpT^]H=כnZu~g]O^w1nsA>0:Q\K>^*phzE,cy4Da̗6Xs'{JZհPZcb3#w9|ѳSH(_p4(ӌº&5#| ֧=i:8X}W2BQO=YI߆wS?r[*9oO_u=)qڇjX׋ڲO3ZO0vL4>֫=FYt1r^ Ƀ'ma:uE~ļ1zΣs8|*p| Qv#/wBdYSWtS9n?g5o<' .&OO 7yXzNy?;{yP7DS1z/W {=P[OYDWfp}~:uʆeG|kIs';v|:.3j:=>x;RY_UKJ?:OZpljR 7|| SxsGbꁥ~qp>[kɬwGk|YtǤw3XP- ǯaeK=?>4w9VVޥQ,޼ˣs򎳎_xz>~^qd_g[)|40'>}“5d.dW1wZufۼB_ƒI]8?:VX‚[.jO~&}jo}X]}3/up4+睉g8z$:{/q(â<:OQIBV1Gzޭt<q~޻'̰G䵦W%z|׏16*"O-~Y)6|.&naHp#:#|(q+COY\cUnxX:ϮU.RY%p}?Y^#ďX30<.(L6Q❒•%Eh4?\n0Î#հ ލa9sKFcX0Nx\xM(X}:DWݷOǽ9pMe2VӔ;/q{&_k[14Dg2j?8T19n h}1G_/yxl;߹ʼnbK| GOw4]tyu_<&΢y"syhY5E;al?ԏU'OJd_u;fs^p| q7|oa[\) ̧ۘ~zwT_5f^_I  ֏^IO Ӝ[ќla֟W\{V%9g%\()mj(kOp ?ȡ742[g;huf]HG~0no8X7u>R~"w-r>c`[EGaan! !~aH]Ǫ3jƻ37=بqdtC=;i/aς|Z!yyO$}jxhBqX,ˤYxE`J k_'&mp%串ec2fu5lD6~QyYXxOXowTO7D Oߋ~qŽ+?Y_qW<=HwOpNJ|y?Qci~glxg|F)()W ߟ a 6/#=!e>P+3zFa}Q4>b)MK"C8Rmx`N蕁7KaI%P>.rwQ#DoS?t 6D%>B>ƼHRؒ65_Q>$_VB}W;S&-*$WrY\܂r^>1[y=\ O儿`0s KʨfSN#|,:z9:󩯲ew,_P-_3u]2WGs57l{MOdRw(_<=,G^' %/O|fE5ltY*l}Cs'-R!ܷ$^e.?IV/ $rh 8>RH^Ju9Lxovu"o0kM^طY!>|ްw}X˰.ԕftr ޔ7^$j~M'^}s<YqSƱ"%~HzAUߊw%I>gy>8/:{G\2ouaiKH'zt?Dw璨`E7㺋bo{e'ŭWsI2JnnT {&g",)}0=k̮,6iFcsy}F}Oa:XȬ[w1ں3.[)?:dt4~Z\q'y-}Kg$%Fw~nD%c?K>~/v9^QRVpHBՍ~4Q%~pۼΰ [Anhߨb݉xkȻaRυޏ /J a}5n|Y B^l_tq)8EzD5侖Vuq#O>Áǹ_{θ{o>Xu\oz;)w=Sy8 ?aS=V.;H#">s۾' +h3n#<[ʷH/Ϻs 4O~Ǖ(+tBx)u-/kgƜϣ|Ƥe3=OhFqSa- +wV[ ɆG*C+Rq#? sK$-έe|o"qQoe龳u ,a[(I͏rkF^D]qͮwi2ÿ* i=C)tM{ȿH@!om;v#8_O]@j8To5u5?(+w;moǮ~fi?Xn}xeu\Fw8A#;=t-j?aWC(UD̯?R]z+`zh+Y#^Rx\w?@ԕs.?~'w睵- -l*OQ _B}ྱiH_GUF䉠Cps=y'^O >(V #֋R1w XaD<-Y?3K\peǏ0˭K̕7Ic~[Xy A2DQ#Duz^ӫ(/(̼HTQ;"fsqH~ޛ}c?+x,Qz%_& ͣ#Q7WT3xK`L]W߉](22Q._kCSy1YxT񥒹>*ebo7[:8n'@{qXР7v}zˌߞ[K#S)xܶfh~9F,4 a7`s3(tSCRR߯ sїzݗ,-o gcmBz-xP2#Ot׭gr5R; O/_$mKۺyN|?z늺>Zdbzq=I3.6I/iMU YBY_3"_N]+$N$>^`v%O&<~qJ1>Qt-~[?!u1uO Wdj,J5t7 ; tqt8 Q2٧+"c܆sj{b,>"#cgɫM#=[~J<j\M2sݨzsԁc_O3oKowCt\=F<ߧoNluΣDA^J0 u/dߌ+e]T _XCຉw{s]ϑu CDc&z̆H9ޢk|>S{dk _(n*)ii^d^w *f'Q&OUT-},1~j P&3z$Iz캎RO8L_ps4=y[dzԩQ6|^+(U ')CKo/AK>BB:6}c\E5s^%?w’gdz餮u D#ꇢW~jsx's'uP ?r~8\U WHy?c!G{n= YE]}~68__ 3'Q;3z>^]q߇sBz?)߮P`xI{哕o(8Ox~*fWT߼uf 82/y\2Mdп G]J7j+ij0=tfqy ϐFPqԛ_ru_^=v:>#eFg)%To!Bo1$Of'OhRNn[ITUF;HGhOt~FCB&}v[QfOי#0.n{R.Q?t>?tƯ2D(܈B H(?y!x9l=ﭞ;Ze6?$uh0Aa_RO9%ZofҺ4ۘ3c?ΤLᮆ!}-ϰw!3y>[=*t*A}8^Tq:$'C~⅔gnꦿU1=;6/-:ƨ7yQ +gu@!Ɓ]j{i*o3+빶||Jk>zk~!Uq;COdҿF}˾yYLپ/pXE6gBCu >&k[`=ߢo3:D+gur.O?\~_\9ދ7CfOŪӨ|-Xw㥜G:ㆉ|=ǩ>cwxwEY JOoaZ Warg'7om.Θh:,?3.IgQ0BWi`!K^;ӘҖtc+ <#?Y(m΃n||UT<^Vu,rk$z!8 ?c _DOpa^7 WW07TrԻ\UZl:z(syV`V`S $>KS/X`V`V`V`V`V`V`V`V`V`V`V`V`V`V`V`V`S0nIeIqq5\.Ↄk.iK~W%A_}R&mE9X|$>E^ f,}J.;bgK?rNʮ3oqb_ k<:Btd QOWEZ}ư[^rǴ0<;j1_sIb/Q:9]^'ah|%շ9DUzyXʼJa]Z}1YDUf]Q}Y7a+&u ]ynV;z!+"]GcStV>mA_ @\r\QQ]4=/N4oj}i(ԯo0\Gޞ?b٪8+|2`4M]Tg淼,mNЎy0?'oSw4QZ@u9#2K{pЩtQ/:Bm}z7 \wxQ֧{B}w?buot끣`rܮxRCykq;}ܖ/C݈zI&H=Mh9h:e;J~M2j9mq!~ Lh.y*. =;tKZ7;)l_YozU,>pD}=K\sOi_\tu$*ڷ%~1~GoUfuW簎[|`뤛w =bsT|~e1^u"8#wtFJgWQ2z^RJH=b8EuA5-2U;i~~(=j럊®P>uV6Cu 5o:αx~-Aܟ2׃-'ףa06~Uh:_Z[҆/h?XXX};?XX_fc ›/zp}J@eǺUiL(_k3k\X"zw\fhqV{~ʌ?3Bsrul!y Bu4?cqG{:>HC/֫CwTykR"ه܃Ng$iy^};xikM;򏕡NbԈ* }ǂHQpըbnᗑz6VR $~]xwzxTxے) _)Jv`:6jy=="{`e&e KMG>? {Y*'qA?({IzIP='۷3Ӗ bt>%WHciXYLjMy%_+(O:oEwtĸj0_'m7*³ ׍ɣ>w#X2)=\ܒhVZC?2OΛ0=mobGccE51Wq,9_s)xo&zw:ڸu ޑͼ]7J[RgҽO`lW7<Ȩ.x:<Ў5yE-_n/V7Jfxw5TO:uB깠\b=ơXe7*Gmn$UMrM~=/nSC2iC[\r/k}:9=۷#[=CwR]~Wt ͻbΘ3?N4~Ơ:>,׷8_{%jJ#yH&ɣێKܨ]8E=f?\<3c#T/ ;m+;s?aײizS?c%D|du*魣 XQeR1D;2n`g>,G?0_*'OTw!Ŭg,3B#3 3o-6} 7Kw?Kl:^IK]=߽.ajKa˺N:yĢ/߇(=B%Ɖ=T7E/2Z\`QGcNP\o'[z"NQ^en̏?m/~ (NUo7=9s#i=\O1Z{~5](C.)%]=~սc֏9s!G?1=Hޱ\=F 9E ;>׃g<|R"w8^G'>0137ϯ9E/%7o:7\GcuWsWt䃟Wt=w~}L].7]04kkD(N[՗.rI0?e0C!y6\\C7ޛꟸ ~ w]ṭ~;9|~8z゚Uw=~&>D<8͓oÃyIJKb%xZHT;‘Ѽ/8_ӫ^>}3Oq7Dt/ou[hUǧmt\>6F/MNq_s]T cf~^HC|_*c7+L K_Q|؟YU:-oZ?cESS:Co(bU絡I_[wYwƱ-yf%ff|-)RiY.~ʈ/#QJUa/He{k`=!gq]u==Joռܾ^Ǫ|YTG=9O;~Ugc}W}Lp$׉ɯuA}AU@hσ]](UX\p }>ys߸`ݝ+$ռs޲ʣLR4?Mп_6oG>쾓♦+x'XCL_`ʹ#u6}gˈ~:f|W-cw$nqQ5qc~އGiL9uRƫb>XgVh9=d?%B7+W bX?ُIQU9phewc+k o֗7n]|WV%S[p| :?U ,whW2p}zcŭ(vZ=L]9G  37cX\! )+^c)_{eZ?=o,jh/@Ҫ:Q3 V^xuoKz<.Uqt S]Pٲ,N2E Of`Œ&եE[#x о s<\'QtϤNn4'~#!IB\C w 7SoџKIq]Ew 㹿,2:PȒGg ָλt(+++++=ww,0w3KNtp+kt1X';jѵeپk0~G<-Xzhz" ^l]}fu?:=V<.P#Bn?QcϭC(hŭ'K6O |28y6o-)u t㼩Ma|0^曉gs^1*b4rڢǜaV'jhL⁠H&*yg:J}9ӡ_f>ghPW`ɯ iE|{%0]A"x]>KIupY/h`e!Y}$-5dW$>1| +񣣟\ʫ_ֻE)Ư:pz8\us_jEIfhHT /󯚡U\;͸liu†T;T\Gn+jo Oxɋrz!Qߗ瞲>69tc~ >j^=0SM᝷\>nÚqyRVu[o(󵭇[_ls7x}R\tA{Y7BTà2{'mbЃz/LjɜXyk)~yc~j3Xzg-v?I^rw8?>Lbuǐ&mY]雥{8/SdO u7~췋ҜghxYWr],3yT<0y[=(Oz5su-8ǘ>[Z:|+q]9:er4mmHW0͡O ׭^W}_V;U^>,fh?e7z%K꽔2mT,Wb~_f tޮl,?%]} fU4mNzqgnCg]KX1~ =C.yՓp~_T^uf[8rߗr^h|:Atf-T\u'<].{_xqR;m/q3ipy gV3 0'a~V6|py;/j($rb眞JE;_mQSoGۼS" ^׉\qo>_a]+%}-~C~?0uv[YwH']GgV?$ qYtD0o*}N揾KTwތ\dx+,cs<#tz9=N#d~k)Kj oQ}yYw^{J)~#GoCI 1yy?A2exo&YC O"[#n,TXYTxJW^2n:7)-FKIՕO 疔~?;+Kӕ WgQGͿ/쨿+םex=Lc/=Bt,\gpˇ}?ǏN$uCu>CWC(rܞzDXyjL 5XW:y+e6ގ-cSx"-_׿7:abζ'?zW / 8@7KyiFKq5f~P _c*&p½#n8[G[kྜ6L7?O~"/pY7dkFfnfD1d@x}sZ`M%Ϻ6VWöS1];®xeXƧx3m<^ϕru}HOhow5-Ft=;J>>ןx^.M7OA~)F=m_ӯCۯ(YJ?9ł[m<:ַ!eɟ)݊”/x:f}3W ?u=qR8t 8;an>* Ewu8x[=+xG:n}.Cn/arq}z\*d#:䌏Oto״闊iۃ^#uUPU3q@}dcf}?>]f@t+4ͶBfgcػҵ9@ 7m9f\pq7īȯg;UӾ\oH_ ߥtGm.N,;G:6kBiհ q*>υf}7w??fi9xDwm1ސw/h2.X|I޹L~?lBK\2H#yOV}<+s;CQs #e gVO~? guo_мyu#~"!|{'!k;R4cc,j\?nfX4yWKﴥ~,tOY k]^(Te~V %! ?^a_73%k(3=GZ0bTtcS/ˇdf8M[*'CS#t ?[\U>0{/܇'tO(⅐~&Q|: ,It?'Ґ:QC]~\ThNOCK\[RxEqnwNFu }2?ַ?y~gMxSkTNy+!݋sڥUONF{e\) )BXOp_96`>>yybr!:(lG23|]c=f?-W]^wD}o7C K⮱O[i4{z1y-Ϩt Z_wӁ٥ Nωc=oTz<|ʱNGz Fʓy6LnC)ǵ8x% b[;u x>r<O9ޗEzuKNE\slH:Q-3!y#*A~^y0HC)_Y7KH9M*ebyyWMBG@⻌3-gM?tz<3e>%C!~Q>.9}/Rm7|'? ߣwK< ѩ/J4`l4y"#_|pUt\EU`=w%c~)`7ѯ߯n:Z's@4O>m3:|gJ}볪kAhXS'|I:d):&bRq]Σr{q8oTGK9} P|0}>t}p¸85߰{)p/{%ū#OngI}J4>AuaDuRn~'t  ӳ" ^yt?¼n-&Z3JO׬B!tB?=c)r/`э4T^qēnufz uA%n>pJ\u76wTo|=.X.x{i=zF1ž<\{7>9=.f;Z =.}BDq򃅎u]b^[M蛼W`YMOt:}fQ\r/*n2cڶ%fAe??ӓL擜Sy5sxp  8>j( n ̓u0!XWzA72i0q_~mnz /-U[埚1? c?*9Ŧg3B%ٍ).Q?W;3#0agwI}NIG}ybnu92u#c3ubm.̓" =d[nX_OYZ;n!AkDބX\ bU)~q#MG*϶쿅9g;Qby/5>Ha}Jly3y&yウa˔AG˯a3:~p'!}St>Gnzy>ytYwM|n6Uhs,ס1o0+8($4O5?AG/I* =O/;)/4CNvp1z?Ip>-ͿUḤv?IJ g}s*31?m1Liw0wກjכ7㽇)םۙ>WOhuaѯO9[~ϖGרuM)!z7y}5+Wcq!:>K?KDXȢ#~\z<}xX !HHy[/PS\7ʨzaj}6^䃗*A5a,Qz>S7rfe|Vqߞ}-)߄oqZ637iߝcScǏ$ `}_\ 敠P2+M$BB+ Zu#^aplxt7V`>P"_~r%ߟ׀WD~?]GFYxtK}DFwc)z\ zG#SgM|,ivU{E#+1ݴpPm~,FBuߊZ$3:Oa}O}Α{Ҍ{W|6v|?p3U^bpQ1@vyBiC7޿j[p/ǣ4ׇ/Чcf1{~oB ;t/#oggrZxՆ;F;,oop6R~/?M]]k(ާ_mM:hOLoU_=Ь ]NS,|>f\@c0Oύ8'NWŠc(_;P\R)dU㭯ؾY˛.t0W2|OSC}}zx43nE&6>1*%/wD?Z㙁'B?߁כqXKZ4-R&S[`~ܒ~oG5.6׫\Y3V>eBɟXxX[1.Ae\?,O)8Ū|fd_[Z +8;aǖ:R7!o(|EۏK̺rYimjG{q_O`SI1s[Z^ǝG4ub5πv yG檗t5\l vRgs4BӨ&jᾦnȏ>%U)".1U1*އR$e))} {[I>ڦz<3:؏u?yg0/f`'-d˷8Mu z=Z$5NR\W^?(c{yy/'B1js~s0=Y0@3zIk}tm䯶e|7tp!ŧ 7{ rmc㋈co)E_? /".6c[m }JF+\@G->XV~4յ EuopZt)4ˣwIz1NLqj=)~iR>8Ǻk)OxW鱭^Rb]s}R_۟ ~qws^Q6JSyB\<$Q)=''j_^WE}l&?U7~b'k3_?w1#>T蘌6Q"E?XGM 43s+"Dq 5"=w* jAZg7[Xw3/ʦ+,Χ Qטaη=t=۬ۃ]骾.lE3>Å߱k[iݯ.ķ}I:%z`vv>\ء7pm{9M߂`1D=tpk_ǾWPʂ/Mg xCiJ~aEs6-L`4`=IE];O<{hФ ouNaV_ݏnC:ZG[9UcHFD?+h|c Ԡ//*7qC/n}1O+l٧8ߍ`>N,u,l%Jz>/fa_qzY"dY̻6a57x^hxS"=$߸NJ 8)ϐ2~]77*|3^mo~~7=NtQ#{}WO-ۉ>~|JA7(eϵ%8Y)OWRG,n zMh+G>O6B|Q͒sDμ9.zk=xQ .S'=x'8W\7Wя{~W?gw~7h^06svqDv4=':'B&FѤd-J~;|Xȸ[0~_xiVN7_kYIMgُ4+i$w,}Pܥ^'o V ^҇*w8;C]/;z0cOh bOlc^]iKTu[5(=q?`>/0; +quwy>GO1^aߜa:erxhiKt%'ڱ>A)Λ0O y=ع30W8% yկ˼;ّ<|d1}ʢ__*nYT"y苦3_NpaYdun}jc 7˚zݹ_H<g҆i=*T>OⷣP,N9vj>`G)|#c )>1Y+,% +k`E=mb!8Q9Su~ol'utI>}wt%?tq~O`dX?[UiHh}Mpolg3MGzޚiݸv9f8sK NjSGu%Ze^Jgw a_Ϸ5x!z|tݣNa4:n>߫w,8T:ct-.;QjíWQ8-IvT_@N~y>+ #u޷bg,uEk5O72lXb_d=N[ښO,}iD) bDCԏ}ui~^^5T_+٧bU1ߦz <}y}PنO_Ke῏M7Ŀ;"oŕ5b-8[cX?q8_7S'xiKW??_ׂUMo~-Ow|ɼf[V|*>\0}E;y90DalMxތ7=8I wҲ=RN8H{z*y'Պtb|yC:Zm}\Ktz\ҠY`Y΢S0dy^yzyCtS`^[Kg[{IOyٜPR>m y'<d`Z;?QR-1.U Њ}qa*̃QDZ;[By3-?;ok3n]O:ٕV5ŘXׁ.u@ߣnH?zBߡX<|yG@Oq=f$q*_wX25]hz˶: rjf\\*,Qo) +t>~r3U |ܧg!wןtɵpےbzxT]xXW 70 P8jKG+<^~*~߇s^v'G}T뜟ÆO3p 7^gY#D'z$1zU};u U g-]OKwP?FեOūנX&5^) |{1Xo%\r)4ҧi^uclFgs% *u=[OM7Vǭ[C:J#Xff^d#v4EE;cKlHP~)/HX~ W44S΍UND?$ ?98-3ި[~ +)\]ӕ[踍;T}'W硅nʃ)|:?#7~vktֱ%[^6gNu;u:}_0`?R=?*~}|z+5:ja܂6,ui)SnQSGy ߉saRYFcJCM :aOşz1?sHwh6)j{3Qm} jGԋZ9Iҗ n:wqWӹUQzy7iD%swn x_ ۢ^X!NēsŕH%3d"W&~}vϴ^W|aБ,o-p>&q׷^/{Qw;J-ch{<˚&7Ƴw~Z RT1ǘ =U:.ߎԴĕWsh7cV !=#2/zgԒoU@ݖ Hqx\NY霬ԧFJܹߧm7{VFbQ\\Ryb|& )uvQs_yUOt$c9Rgi t~+Ւ&JϜGFGXWC^[כ5gIAMDz"*1MpiA0$Wg[[Fʫ_Ltf|S?_Vh}P>52Ϙu_WCu|nHcusb}Y`ֿS>}fQBz V~Y Wq֬?m۶Y1H]:> ЈRM+W(+R uB T>2ySm\q!Wt ΋"ooЄS=}b>:&Ǽ\.4z2Ǖ_ɿ?:>8`ӧSzV8u0/)6){UYKt(EK~p%7!MДu7Ua*Ҝy7=T:cnuZ,uȰ.H:.t-bR'DO_:TapЭ4>룱'Jޝ?`:=^}G9\'#FC )һp'*˔/׏@;afMB!nIp}ȆU7X~hP_Rs=li_Pe\Kʐ׊@uboՕU8Yr9fHZ~kvGl3U}>uļHPؿ5Z)vޑȾU5Bphϰ>\ׯlceC+U~"ue?/,}Zgj;Tx1 #SКq.9lH?_hr| p.R?BtM׫l~aiM EgK'ne7ʺ= hkԍ3֕tkFec؅^ԇKX?f_LwQ6^ovp\2ZtP6nA {8]x/ʭ9Ӌ$.`hDxR@Pш"3s7tHCxNWC<'KE g?wV$_pWﳝeZ8C԰ (>QAo~Ba{>v7};ƐfnuJ _("幬?Mgub!iϻ3q϶[*x{t+?m֗S3ȓp]=Q2Mx;O{33 3_Nqǻҧ?a4̻Y_HEㅧ}Ҭ3ugT] NGCa ﯮ*ta^vp/^^%}S} DH#)z}:_gg*2`R?ܖ)cnx1uBQM{[-Z X `j}[Ԃm=W+"6]{*ze,~xsƍ4ΟS~(:,>΃ ]m3_PZVwYYp^SŃ/UpU>ТrQx[z_?yB t< ̧y#fү@y7(O_T)ݽd>ף^MǘD:ZKK'eC<Ӗy_x\z3/>1sE'+3Tyf(8[> E?q>1tB|t1{E4ސӘN[/6b6Sqĺҽk!Аy'YZ,za7\q y}t`ӅNѓ>:bؿ_Q~쮠n6ю=NnWDk tSgѽÊT][>ݔF0^_G14 3\HkOEҝ9qy(}/P3ωY%}E=}Ye])*2#ΈpSFl<:3/:8ggP/=U_ Btg~˭mzо )TƠ61RPM8?SӞs'`+T}^XBoLqWLo s*z֌=_ŗFSUgm¼pXۙ}'}*7סy<%^#m=qs>2}@Tv˟I?\Ye<]5 6뤣7༔My?鰪z+ qyjnCq<&~gM6490Gc-0vZYU,ϗqBJOSꂠ;xE?)6u^ꚌOpG/sɯT:e~REu*/a%D5 yϹ~>@N%bU WOT:PAER}Sy!G0_m䚯BQ\9x,d^u#ǽuMdzal] Y<lo'k8.єΉXsCPܵN/iϟӼ.Tuw1bM!=O1~4'k6]U ,3>e/K?r֮MP7X_2L'L TCg >' ֛g1 ]6Ļ|T͈zws3t>}3Nз_{cS:+. Ez9vF!_3O#y1~H*=-?ghUO9_{f}V֓#q>s\oiz'-Ɗ'IE0b5x>UOOeFoJzN}D[e#9cfJ?4)jyJtۚ4≧/ } ?*u+pEGfz-ۂ ^Ϥ/~fߏy^>F)f8s588jqYpZ7˘gQ\_yh-#t^/[CyÃuXQ㷵sh=H`wɉG/"_CcVp$'ʉ~58>̳oHǶu'8x0-8ܱWsFe_{~Ѭ;yW8%wͻ>1ֽJ糎Kw tן{D>GO/릠yz:X'#~}+р~z~AsOq#?wu/ nݿKkq_^֑>Mw~¼Sl"WaJYlŪiYO 1G掿si>F < v^G_՗Gy٬[F6Oo?Ǫu9:]&GM:G=C-ݿuZ]o7tB}yTLbc4E-zzf{dBtxǼTELuk)O伀ԃŰ:ȻtE~.{U_/#3D=}~n}>߻kXMQWu]fw 8p$ a}@\ÌōmO;o/B֧1:rƮ} P۞(z3 )et>1?R"ϙ[Aߴ y#h>b?/OOD7e??똷9}(T;?Gc=Ƶkk }MH[X*!)I=Ģ oYO~5;2kw9nĜj~TWpgfHhei4u_quow?Z5R~AHoN;|B͐~͸Ϋh_2Ty׭z3k {ow*kcf.C>g8nxj|niCч,㍓<>> UoDwmy"uHxhlǝ9.g?g>{z\|<_{ `գ18Ru2B:;)'̧< |ni]Gg , ! ,=CcYwyza5D¹Jσj~vM77|/(E;1Oҷѻy"W: Vg|֏I^xbӚ{3)pa3Cy+zG{S֭vBGzļ σƬ0oι>RUE>=խ!UE¡ e]*IÇf|ħe(N;RҼˇc0׳,ċI{ ϵ|$Փ&Oq)ܧ|8P_j}[x\sX[6G?A|`90VxY7 y>*wZ4ʴ?M~uxnEtYucޗ2%|>r<u꣊݌"!'>"QMoTfVe W;sSZnz6ܭ.ᣢ{[': |=Y{ŢcW\S09`[C[V+̗&ZϙW1R4IC壃1F{׻JZa~#F3~ܤx6nw-u n~>3.ƒqU|(O|ոy7yG)ԯ[-a/YPC6/ W'mԊ7a=Gq3߂%q1V8~kUWI?z_+K~ gnTy_񂖾By1} E}1E+lgXG,]Mĵ={#;+e;.弅OӾ熞-߇ zсl1<"kQXTy\̓MDؾ48]}IǛ"u%[A" cБh:|_]t&gr>D!>8jYx|Q»@ *};y]碾7=K,WL[0C7azh~\o˦x)9"n837}/-)n5a/(u!;":u>SΫMDЍzwUh7wUsyϫ/R /('|7gzA~?}qYH)GJ;N_b=껨 u7̸>51eG0L*z ouy}' fR.򗧂;)~B8cC|qDǎ\xWǼpTFȫ:ɟA<8` PxRSn7?=aq"5*xROFvy3¢/qNk'~uHN3~7).Xޏvh>qG~ax98WChymoI~}EԺCaI]oy(Tw~bdXcc;0EU{DcM?\6CU}Y?ǩ^$eQw珿w6={{PRYw-83 _r֢WqsX/cҦNGӇo}w/1at"1t\/؞kqx)޾?'}tŭGXq޴0-D|ã{%eX;ގGxeI} ̇)Y{c^bcȂ_b\tǪ,xHAE)Y;_>S=۸8Σ4.xz(#Gx޳,kC+zqp=n?~{{!ީx%D~_sjA~ɢ h^Vw=OxZ=b O*2^VOM~?AcUU5axF e澿s){?}`ǥKK~KY}:񮱽]kqxI`>>׭sO[, {^=όˍtߦOҸFU6׹{P\)n^ފ'Q %^.Z}м8ep"ҾQ-_|194NI#*Kz]tafg*#b^E~ SnHz>}xd$u%n:%ޔOmX޿:%XDq99aЏłKaC5Y;K}}1tFǿ{a~h=-m{M,oGyOA/GU5g ;U>퓹g|[:Ou0_K-W 8qOx6}uF'c?Wo~_5`ο|Ҋ:âw\qxºISQz23oK.~f;x;Q6>Ǩ)pQK fq ~\ X7#q}҆u3M?on:؆}`ޞ!k+ˆƈ, :XnE$> Ŝ,ڏw eOϥ<=1?i!OuC:~/ם'OtZ<ۮf3: mvG>hg|ot r\1O->n^f|=<^.|-EXڕރ^<~֏dI-N|(˶=  ~aԱߍnx C3Ǟ)n\Eh~?To9#UuټS>ad+4ӯ7^?W/#ڞv%mx C G|ؓEgU9ҌZO?S~RgX?+$/n ~PeEՂoLGR>(x6&kUJ}t:3en(Cݞ/f)n1t-_u;]?fvf>('_ /Gl(Y"|z~ǛK٣%nXаSZ\_;pxDP!^ޘE~V-d0k6B3CxB/A}ZC+r՗gI׼h@VgEaWsi_WОpXPE[?ދ+P:ߑ׿*y]"pǂKPoje;Gv8uѩ$0\ ڿLy~4/j4y'z;8a3>um ΃i]7Vb}7Ĥ~FS_6Z0>uVGaz$@(PnB9QOڋIv5Q 1xV:鸎/mˑҘ굪/0`o;o[MD?G8@N1觛3 }iYUz gFg)Nby \Z+0..0W: ð<)yz$Fs~Y8jΟK]BL8F#>5*ĸǻy.7x1Ϻ=;M.x> ^EQ _+\qqm~(_"a:N>7Rx'K;q>X/>AuŹ):W4M-h+kؒN~CoBt>44S] E^("錻Xtsd,/Mϕq (~5 /z#J |Wt|x5:&PaYkhƢЧ{?g_\wz6c]ys6k8֛h![W/<] 4 sSQlBxn{?}&/rWuKc?kV}Өn6|ywwNNZ?jyђpRC:hz~+r)nXK'_K(t^Vf\g:kI>gFz,TW C^۝焗d']_zϡK#}JgC9̯*OD=M.D=[G >ύ uD?^fl} cۇU?| =CדERQ:dgHLJMKo׹K^=9ӵQ6}A7Wklqz~ݱSǫ>㵪[0Mg{n,,J/КB'ꟷy^䞥'K9Wa~WK2nzRg{>y_8ѣz{9yJ3nP!uÔ^z^>Ĭ}&WZ*1>_AN7^:8nz(7e+__ۍj>B;[~ۅ51alwM |1mMW >y"azR?#4MK+Ղalk{R ;HOsT}oӆcsۑrI(~ fڧW4;a[z1O缓w6=}b[2,}ZьXs[n ߗ̾pؓPQzg8_90NUU#~y|6*Bs/}jVLª_SGfߊ ՂquΣpwҏWgNDpdRGnxXp'{(҃Yĸtjlf{)b0eylC J~s)}t{Μ:\|[QWW4WEGf}0l"Ҝ~yokz?Kh`~)d à;^֏a:p(RK]1 [ʺ*|k+HN:>_Z+⨳w<ԁ 2v׿vԇޟb _bw_H`6,.EcQVGu0Xԏd G]tUz)26gjw}*Ss_X: Wu// 'TX|,#~eoO~E Մb>v#6IS4;Zq~^GWzB>?/ih1QRwFp~)eß?? Y?xXMGq9p'fT_2}9T,K|Wl#˾U=4/sB6=Lg7kt7lЀߟ,.Vʸ.!gf=#ْAe{7׽-aHG׳7zcsZ>c/j(}0>'I֑5TaHFFP~*O x1e7c7$Ƣ+5/^4|)!UǦ^y]yD,p'Cˎ?+!i߇үYS~!x/J'W3~ "yZՓ~8&p 8>G_  -)54~]`? b2W2@qe_wE~Ky;Cs(8oSłȟ8n(d?~MTu~ܒq|䃄.?ExKQ8qlDk})npb><,y=AmʔajuS_qU-:cBE`LeEOqD)iDu<%|Ü'a귡WO7lH}f;(n.N/$?т|) .DH'i}nV13-2^gR[GI[Tb\GEsI$:XY+F=Hx?'~⇪(ܣ׋AU{Ƽc:^N>T׀ 4̟w:Oڏ MRy٨xl/䐛N=Ot8V\y=Ro7NjR]Oi^wu28;mZ2yݛ$>䱞C+>}a ´U}80{-þh.z>rsG̤F|Wr]9S<6r)ї[H<XY3 Ʋ^ :o5շ/omRAx)Bjq|,Dc_NV(*M6b޶x2¿`q;FH1?7T=ʁ H,F  d kclc 1LRN=[nWuUw$v3ϼowun8\WeE<Nj 0Z"sOOfq\z9ō78s)O:O@ۨ4ˍ tkK4dGJW.. =C{êDvT&cp n~?Ӛyꐸ8oQ^Dݹ߬p^{4$QC=p ͝"Y#np|E[Wi_y7z!!<خODx7Ե{}2 "6jEYdxf#  j!5Y1ayPp :0)T`ST4;}uu[&|"⧙*~b \N s 1vuhCSPo)f~U'ڗ_ 14ÄT|I8eoF7AS YNr=nD^i-^s6ճV4W|GZwۿ^Kf1 -m0PGz)坆ꌡKd:3s= S#d5Bp~5Ogf~Aes]g8 7ipgq~(5i]M7p)qq+ۅ/-FywM:02njWfL CQP(|Xy: f~?=bsp%dz߈_v h^jAW{J+{{kQ\0/|3qڷy +S3O1v2=]ɠkX@|qLx"6 `.uBzmD#LjCS=xZr+g0+TdC/)<~+{M2=<Жg 6EtݫP^8/#:R|"~)_'2=w ,U7^N ~DΙs WIk&'$?-~G׻SE5Β6]hhX/_5:Z5)"=dž?gYǛG~;z?kGU|l}pmkL8+BM~/>oXiq8~qKԧ;a'BwQWD+g[p;U@o/^|^5ԽV/p[ `29%GJ4vIp|>:Gxyz]u5|lAN ƻ?cV齠]xJLBY.r@_~l:eiԉK?n|&ׄ?ݤ>#.&0޲uq&_iAyuC #om~@qE,e1T/EDIVa |nѓeL89?C+]x\Q!^8]Wȥhļ{c HGӅ2GwUWqQuɔǷum{Ť,Tݰy۱sO׍=.M|{y':e3d]>ؿB42ϣMfy=Q (8(z]i7@x~1܅? $ڪI߾SG[||náSᣊ |W%HD..͇wU9'r p+#N[jp}|sqꤿ|&GFQ?T4Xcͺu^|ԇճԢSqSA[4b~CgWw?*nxĞ\WC/^KD] 묡_u5}f*n?~0쬽: Y|9ţNZE F<Ɛ_Al? m>A+ <^hu?S5l]̺޵|BUeaCqu2N/u<걁GCc?)VWs2}^-Q\հN=<o=9>[kL']"8_-*O=Ø q1Yv3#;my+=sR=\t= *Rl,*.,U9} N&ǀw$^>qOdqV%|n3nun,<ޑtqw@~6H qqT\U:dO93ˣ5wq~rʱ֢T|ߍu6O[>P?`<<)@`_x'QP'׏a??Q1ܚtM|<Kh )]tS<]㖋1TpaJ(qdj^ǿո;ϔy67i?x,[EoG뇷տoO q}yTҼ3y\,nWquZhy]])}CZxsiJWxUQ#4cҋ^~g: Gӷ0jC-x?qݏ}iKï%]TFup|<:ןr$ܬNftRP2?՛')ɟk^i}B?/XD}EЭSAߐV6uPQl?^u串llmyߑo3ݫi "+?Ե$aOGz>+JB.R|/EtQ}dCw0FvVq)Jk=4L;YPV.xƬD>N8y:2e<.af^jܘRy3e(M8WM*_r< k -XҷQ EWd<~h1.S˸:9m@ܫ/A!}_pf:QqL<$t_b9pQMalut_,(%| oj'k:Dwm2miD}1|i; w<鹖T2eF̦/_hH{yRߣoTk7CIInb":+RDGPFW3šE?" =/ϐyD~ReRv<cJL_ĵܿ+S?FCU{!H:ݨO{w᧜fzƳq?Lu}8[/}`ܼڄm5D8 ;q #ߟ# B/U`ze77$拺dEoш̠ ~\O}BuS|^7'Nha J"n*`w1k#Q>q|R̒%U}mKmH&>/]wy3Nȸ9?qqn?(J=cus8fsƯL3qRfJ;kXW s{<Ϊ:zp1cOQ auRϘ5\O=rߠgo0>2KSbS< }hq48D>2\gc_|m+6U"q@~=pMXs:9n\qľzԃ_{sX>cÅ~~;m3<>/-B#u/ol[plJ {OmvsuaՏd\'p/w[e\:YqE8sYHg?EK#?@}M}ǫen.DŽxӉ_xf{.ݣ+竺g*7#߲B>6Ǵ՗"^dSn26^,?Rɰ]C^t>z42e\7}:}Ǘ} Չ6u _ Y O!Hy)uDC7 gÓ2O%l,ɿ2z>b: /f_Ϗ~ZO'%?'WgGe[YoVGKmU(1u bs۸8 /4Tƒb:_ey,i |.r]X"P}=8DQ?:'F^n'7D1Y_WW(٧5HW3IN38T*xN٠'?Xica2 .ꋇ&Pzhgz^M*%)86KAU} xG.|mQv?{D^pSVI5<-wtyH^n^kZ -<|K|#]{^(3y$!Ch/R'KމxJRsՒ?xf36~i']zWq](\E悇tрܴD/Mːgւxmֿs VՋF#Y4vAJIiR.d vu|V0Nx~lB:xT1eA^!{3}:zIRvsکu:/z,eӧ͇mp3xu7qäci d!a8zWiI}ۿ3u{N$Dp4KX|a,aLB%ZxGf>+ֿ X{wKx o&]TSߖ }ě).R *ﻼz_1E6U,lj+ܹH w^?D^L!Z>?Jy+{_sx'S;`e%ңl)[  HWZR.EZ0?tNoN%Bڏ}=H\B}3vs>)NN O6VA#}TyʔGSOdTl/t|{8hutSu4^a]+/ '??A|eovL*|چ%;?:Qk^{$>p~3Ծ"=ϖqQ+2ϛt x rx_AX(,b[qC8D6`>#QӒ|Hա>*%G>X,y1 _SLy2TF^2\]K7q7nʇߨ}M68>_o2.Vu%}U'c|ӗb]~/I濬eEVD?o>,EeGz j<.D߆-rzch꺚Q.ݺ};\w [k ΐ埰Mw6oZ$UcTL٤wy>42ϝT#bA5)!+%j2|]O$U3G,KG8ʄ7i{6|/ wOĵ-O6=`\ϏUćkQWyUҙ/pR&0~UfM 7-uxmk }Q7xWyx'~TSC{ `NyXp;r/>_yʃGk0?ů&{wvs ~lN*_@mg}JnyBt'Kj2~2xWX0IQk|G[Y0%Yf13Fch&疕ew}H6 ?jP016}?t86ly1%2ŧIVXxHP'a\as>w~}#Uc:@SzQDPLׯL{ Ga#JC>%\O*p1ŜgL2Lw&~|tY|^ue>,:~ǏuIƷs|xޯKl0| JcLC|ZΑ^ÌbY 0j{+ȥ=Նߋ[7.jwHyUQg9bD 3cDsLSj^%K~~%uY0X@dBw}Oǵ/\7)j!Rq<}}yBg~LWDk6J6>c!HF\C[׼)sH |V|oC:?c=!++n?q^~A7Q?~;>Ϝ0:3}l~X#Oqcxx0lҎS+]+Lj539 up?n ƿFhtl9Ioӡ}?МX^ԇ,:i|[o,x/Z;g>'2OO-p{ˉz,UWx"oc{n׀a"OX`B[Twmb/ڔN wg_iä"ޗ|Wìʡ,=7s9WXM_v(z63zqͤh2 BOg ?#%uEfp9xWnWzo{dVƯ֑iwcy ~\n!W8#{-[|WtsTqyLźWІɰ5s"vgYhT%75<%tWROt:?jޟ 7|B"K=-A!\W1ms"yzVV6dѩ:6^8_s ~f'2ժrKD>@; !JٖS7#*~_@Nf2+Ü|A?8M}"׼鋅ɻ>n._]N'M4}<*%ebfzI<)꺌oc^_ٱh}v}/G:;/ʃyMImד~2ngC`[Ș6 8}$?=Pp9boƏ ^JM~`3G48mԅJ m]uق?W38'CyR]yt ZJH1Dp< xհq^4<| fgEf5ᢈ^)3xN2NE&P/KU?VHLf෦:}Q΀[b(cQQGdJ;t-HFt zK"P+b7~Kt ѐwTy}n^*uO)O/ GV͏r|(u{.$ ̕Ga9ǜ:~~}zzP{<`KQ%a~Ԥ8~#/iwԢ `5ЄE 7gC3f86jVr9dK[u}%׍bN8qI%戅w%_Ӎ2E+2Z|2WNhЍ+:2Ugaw/5ٔJ ~OU?dqueպ029{nQ}{j_  E<`2}Y} ŽЇLƽ^w\:ƾ政edk3W6C[RoH[w m7[.q"cu}j3=ϔxm؟g>o͉]0Јˆ<ĥz_c}I!mUXU\$˷km|ΓsfD-iQwꎦW ;uh'& nڦٙխɢxÄ&R%#qQ>y#٧#SS *7u7RgEU?2E546_I<'LLg&=mvZPMӹϼ{N;DNN7_(<<4/"Ygj3)zgttǹdzoZ"~|7=S4߿w{umx2'_d6}Iy)Q-s&^p1-|cöKDJ*{,:mrm/S1σE4p/93N#t;ƛR;nm؟Kn<ϣ Qxs6:ohN~,^pFV&ܼ%<>tƫ;vF߰#Nz;#x7?Z [!ݼ ʱV::-hM:C"4d׊a7 }SЗ- q&}dhk^ d/yI\ =T}_,Q9n{<_f?O>9mwKQ7/I kE U 8; ߣýGwf39[ <-x->yȨ)׾GěZMOw;Muuˋ7OtTҲ@jG=TuNإ2چuDH@ަ7sTY j>7Y!l-dF"prٱ[r~ge&t dr,R{uo'5 7'[%Y -U=LjG|zXbSu)3\$~Ew"[IZC}+Ҽϒ/FwCUuW[B:qMϣw$_=?3z;LyfdtFVB|CQwDp< 78A0^$ l(~2p ߫J ~z<{ =Uʭ-^#_h?❴w#7j?uLǼXQ57c֣X|F,Hl;Jzx/ OrF |ȿB'Ͼn/ Sǫ<ƪSB_ۍǺs)7? k~nc>P!tqz &_秪#!uD| NnoW0?,~f%~ b^4؛ﲠ^U4<'ٔGb:zӉ/.<j/A3xu["ԗidfJ5>3Y8xKӇ-:>^] 9e<9p\ˌI~V~,4(QuT,_KF^zPeVfeysL_NpT˴>]}YYYYYYYYYYYYYYYYYfL36p_iR*<7xDѺh$^wa'Py~G8ci$束~rP t`Дtuq1< 3]t! AKO_8MQS[;UOD6x|'.?jm?# w3 B ǀt~ =U=Ml 91τ^&WuV{ =!?>^?ɤGީx+}TޛẚtPkfz|]|d+bQEMgzgJ2Zͷޑhωc?#K#;b\Dz"SU_L\ ?tZ}>'?0ocf:=: [GPձA=Qphn:~~ V~*P߮ˁp}뚆yqDb)Ηż{ncbj_kGasGVC''w+RS6}yՊ}xgg0};m_5ni_ cvi˔I|w/\ǏvN7ꗓw2^co;L/QoimeN8Js1j0p\<conCD=MWC[O*QI2V,\_ӇuM~#lFד[mq*z_~L,lo48nMjgi2㐮4VuKkhG=iyQ)K^-oLuPp#sbZ dtҡ|U$z=rm&}yQTۿqbaeZS߳:xqw_׊k\|^?jߊJ%:>s>Z#vRM ņ|8J>W\C0ho7tcP%GߦWIU-G 켽-}G9 /GY}6)\ʸAG\HC;($}׷|S]3~ωDg:SNx5u{^iC76"򷬿fsuH~=Oc^[uw.PAgNn*WL+T~_Fw#E"Ajp$$o{^7.. 5r?"42 |5 #xgvEg|E9/`po>ߑR?k*^&0ߥV:2+2+2+/y:28Qfee44,~"5^2X%j}<'˯4_Kkǫclo!򑫯=|T7; }Muֆ~;iCo~ҟ 2 #Rף6ǫJ|wp&xtPKjK⋼ߚ%17o=Y}%z)Z>dCdn *1]}jhӄ{lP]z]}, q<yK{IasuhǥqX޵5ǛG0?Sѝ Ϗ?#|g~2xnVM%CNV? _I<%u__߿yu&K^u .5tryu\ 7oUxzJpU?.p~Us>~UA㈺!vm[14š;K|O  ϑS>bfLw GIMbȳ،OhH;c~nxw 8Q̟=>O_ Λ.9.6w؍e)l2f3G*#֤baCX:S7}ƈq?WSAa9?"_OG%:5 _΃j:޷U@ץՉ[cK[l넪`wbI<|@ٔX~A* %Ǫ }n :|5^kssFC;5&0i X~w`?+ w < XncNG|.-_M*9w0"dž|wFgWAm8k7RZ_7ǟzq͆K5#VGA8o ~y֟¿hXdmLu}ַ穕yKhIG *K.KRIꏭUċ߳>oy7+\\=j;[–bpܸT2Y8OrՋ*6!Æc@O+'_7=-@<' fϷ'g'*a7Xݔ!E}ٯ1NԏRf1;|#? _Ϣ,t_y@?SX>UΆ2s7pL87ECzə3[W ku?b^3ri ;904qX].q}إƳXt6/ 3Ks*@E?5e7ګĺD|B4,4-~-%G/FhS8g] w)YU'zΏ^pρ,88󎼆DgXt_qf}jx/#'3D^׀4钠<G8DlqӏFz~W {xx fIߟy }FηUxt?.t:\ Me?ɐ<+99ReaTw&=vWOq&a~r7aiqxDORu>٭ppr^w"-O }^gX{Fp hdnb76|=EȶƯ̻v EjG`D\]+?{9C~x۪x/ō5R6=#Snx,Aq5O{^_7]=żמ/<+co7R>SٰI=5! _?%?Uuq.pwu;ծQ5o =w/ƒy"tȣ{>jLǝmY߭GP 5r];P;E:5&ľ-y{⾎ =sz])ķ~A}ЀxU .%A_aj#pKD:㋻+%K9ؼ|pP"q׋BJxh4zK*4Ud}#QC(뷜8ԡ;δasd{Ȃ .I} 3A'':-pn ׀e2W5ߒN9v+Z;f!uJ- }e6dD{2贍k0z{%nahs_;MgI]L >Lzh#t1oy;I,vƄC]y_j&h88?z kSU5>p*pIi:J Sk .<%ni";nS19|7Мʢxx69LzquTs4oa}ƂO)mU7pc-:p~`D{;~X?tp }E}GoC;\O\ϦWogǟ=͵|,7DLl?g/8=N؄DUb?QdAؑB Au\W*?QܜDq^t7ݯM=Gp8/VF}EV d㦼qŢWRuOq8¾UcFğ,g>| Y-XoA7K/?+(WC nɋe<bH3ƨxۗfEK?̘:\<_.Cao[=Tlp~bǿ%-G7·ce}E+l:Ts?-:G"o+uXw%,W?b]f)G1T\0e;y⮿>¯,GU}q@벬 ~߉T|!5WY}!-#1@S_Mue[$zl[7λеĮy>bgxwuo:g#>׻^ztLg:*5|7#-}b=n<߆}W0`bk?bX?x x2zil78@-zpq1b^FEޯ__OƢ~Y+I6]uֽ+C- }jY0$4gȋ߿}AϫGAg:_}Y}J:h>Xwׄ>TL\j6IYh.{]rT>W&hM}?dlߌ4~pI?t<}RT`z]wL/LK$sJtDaᥚK'>ofy'ihnklٲ QO]M~ ojCTѫ#˾4hhnV~/<ک/w'ŪwTZZߧyfRcMz' ׏7{~yReF[akFMHexvjOSoN56&E7ˇT'|3Z>uïճU{K$Iqb'sϊ4A>} awiغMMb)O#[/33ԃQ@<.=l:Ow$o33fR+Xϛe_*pk΅C4to>X=`<2?nU+֗M#?f8\1i*< SX_6\\= Ok~^8Ғ:#'ywRGiY@gFoE/$YÎF!{l_S_*S7Lr^qT:n痷Dy~jdPՒ['ǘ}vucPlwxJއ;0'4?#xOVy)u[*7\q¤C)Fw7HY\̎v!"-Njhgz3m-,<|5y1{\x$\=Go^B5uwYl7LJZG{)4o*癸såcu;xhWm )K0?}qr?-$ޚ$q̲>L Y{>1^_ؘ_*cOT? IG1M>[:zǀcjW: } eYe:yBTHG\Z n(z}Duz(ҵ7ċvǬmH~[1\ޭ^k[+WdMm>y* .Ħ(0\&h_t"zȸ oEzvU{9+/DU RfgQ;a>o5?Wty U՛8S4#;^Sߖ bx݄sG|xzp7T _ıl3<*>bGn9]}GE=]Lj7?ތ/k+XvsFX`5ϵHi|w:/F?=/2̍7s1|Zh&|QZ k= =gΜ/XCc~&Eu~&2άwhhWd~| u{Az/L˘!#4+ ~|m?^3bQt7)ɟCηnz]nQOn Mi.3|}mñ/dpk cG}/ʅw7)nOW_$ sKſgy{w"'W H։P0/VR/Q=#2/_=Nw/U|l\-L"=:6XZ֫lCu8?r)/ςŒzR7^WaژG _u^XHLњp 4p3Q9T-L,UeuӒ¶3ev~E7kC^|M@ߡN:}>!x1㻏7:<#bjbwdk4-o.$7bWL#1K y=nڈ<0D紦'-߄>gzjg${cQ7?ϒqShg,"w,ݿj9#yQHxj>[gF߃WĮz?J3>X'Oo,wgՄGgyQ;n\{;'-4h}<} oFd:iK<,$֙|7h42)hns'jx-?,!Td)' l+cx9H<&>Ɏuu|3,Qz?TB_w& 8AӼ\^x@~D\w6S_ɟED'}D䧈&!ZqQ}"ҿ0v K1E8\ ztҿφ]KiDusjOzl_g%نO,yr#=lzU'm=unKz )އkE=UnyWTާ|.j=q&b;4L<^'SHa~߄j%0:yhDх;YG22z~)hbyDRrk#ϩ^E:aėBy.6.ސKД9A-VWO(NdK?'y:M~fX҂i. z_qB|~Y鹳KΜ!].u[W+pZЕh=׃T"Vׁ#~{M}Lpn]_wxمnpCE7}CKYl:h_wǫ_y>n6"v^Qzi>?㸺`tYXc^ z~G|3x~-gfA=7 xO2$nD=e/GZ\]x~--u%L7]K8 T>x y>_x3EqDx-TS/"NQ"oߐs+q~coqch:Xy?֯8.p–Tn o otv$>[n!钯}ԷR깠V:B)*O|)_gx]zk{+gWq.q%~΄{RՏ@jg=>/g㍠z1ϣ!f~_z~G}տWG_/aW uϣ='Ky1~B``ZoEcONE2%{0w+X'(Q>Q@󑬗+ߛV] ݣcVc 5$tdxMoۈy y >c\2eXKR #(_"1W)o|_zHjԾE t(f}=NFS,[:Qq~Fӈ߈u?wi]k q,oq#P5|䥻G['5xVXOwد6Nzy_U'ָ͇/?{/z2`.b-: y#W,.{WUI)RpSobE*sjůƋxB_&,E57Wx8:Im;ރ}'+*pD2)Xog MNhYG^0Zu3Bx#q oҚp- }F*Ż^|~=VZ/ y2e(L݆Z]U^zץƙ6xySpZOl#yt˒X{8:^uWuU'ÿC}l0yޗC˅J3r、' BUSO`{wq.n̨ivQPݠh|uk1yoX1LHo8w8K\{Y[*Gn0Za#SQ7;ӆ+U x:,DR?`]OXslg~u:!}rcІ&OT <,X/75ކݛJѢ'>Naz]C6>>qٺ{ļJ:}Omf; Db[GbȗtQh(u7P>SOjYMOīz[M;qǾsbzP]30I`byq~P4u[yE RYKE"+zyu5tsԒ/S,VGN(u)Ȣ+Q0=jny{zghFĶjQo:N { Rq"Mc-rE_}_RkLJ m' t0u>bG8oYRm:[ǯ,F>zN`\donKSPDz]Wz~^}Wz-މast-aG~ߒ2E5zWèّ[a^.iɔwtF0>d[N GOsd%__==\;?z9yɎ#hLO[|>+>UDgu}X,& y#̧cΏyy7bʋ0Ncz0MSC#GT$~؇ N1uޫ}P}3#UR,nW#^Wb}m?wP+nj,p>@51dkHW1ԇVG#g=r4Ǽ6M.O2 <y5ޓqߏb~;4fyWD/ry'ȟ9bk~[>'Z$3My6J̫į@ W l΋:T_a%6zXGO1dS~yb5P,aJ׃}[ kxq=/ʧ<}4^x< V]&ut睡|pA/qC~6o9b.=Wz._,/{}e?-.@Ztf66?ޡgS7F FA4Ӆ]r+U6cE pӟY{yYLoQӉ/YQGpWb~Np 5ڥP υj:wWr2cQ 'Ч4~B}#>K3:郴 ;ԑhwGe=+5> _D{>1 ߑaI4އB7G$>s{mx~;*NU7뷈<:{ | 'n??)]g1 atzeӷ<0ju+D_hf}}]'c\'2đH45/%ZRe x IVŐW-~"o:,_.9~³-x2nC.uN5o2Vj~H'ȡCk$o8#zl{ὐqnmz~ ǃă<+ wn>g'>dgF=qmK }qSfVbM%Svzٸ&̲1Zu/O(W*U]~@qA7,pckѯUx]_Mf"fDGIYG>ޛ3TO,͟j~`?BS,x?-}tM} Fpz]3:bzGzz|OF,_ ph`3_1[3oe?~tOyXtsp𸳁%h8/B;E]bNUU}IK%0nhy@?!2A1TC?qԙ2tP#Gg&\O8~>`e6KI_Р'aڌG S֗jPKЗtp7N>l63IߊTHK<Oi?N~yEL5?oAm玩yս8/M'Qu -2=2jd1z:(esи.xA7;߶kWQ}P^7z\B/6zSxtsKXpFAm];Vlgk;]ؤbO߯xxYc0ט_oZg[w7$5_?=n'贠a4ܮi'du-;Butn+[tj QZXO}2zg6ߌcmiDhT>' Mơz ?׭hm>wgc dw4ejc;U7 z=7{5~+rXxƘM|u{ l7%GB󀍓g7~V /0 +D9HZkvբNȖDP}vC]}dzVOG[9Һ/q -kyʳ:%.Bj ؅h~w<>Ʌj&_~cC(`q:NP_~sSsoS`Uxul;B%>v ,q?eWM}[O-9@k p(ւc+V6~LqoQc-nuS?L;oa+c8p6sy X#uE"ć*[?.}H??0..csyMt/+O;Y[!}>s~,yq\3ˮo^:?6S|ϏNsZ&H1K~<7„2ߒ`JǪ[~}"ևt_ub+84.5(:>LPf_.*Я%cw_(gcOo] Լcr|~m'_&ލw?x25;j(ͯX=UܴΤt̤u'u[N~czy(T G-ZϦܟѐDwΣy2&[ǡ<8& xqWCɔ1+xi|Z4>G4p\jCOfOWwZQOϯat GGDסۧ:Q*ق9&^ɚ6 ;xdYx3n\GgFV8$_bp(V:umunU4)#y EOm8xt׃D5ndQZ^_)EOQ-ϣ)>S}Nծ /fK\yC:GLTŅ7%2Õok;2\1N^ Gu-mWS)4r}uϙި<%dQ݃_ƎFa} NU-xP\1y?V,_`|C-U?m˵t^;D[o@?͒疼kB'(p#߰`L`_=~_%6I:qj\}.I8  bp=WQacuЀwSsmP_Y@TvEOH~>ϯل[SQ !y1Ikf=yUEcf5I'񩎌AˬʬJ0gQVU ,vEڞ/]22!??CZ-Vkgq&CcdzqܾA#ݪA}0:nBwG r.WʎX5<^[ _5nG{Vzׅ;cqwʐCKxQCt~MmՂc1[;Y~)/ ޢ|x]_Ep]2l(5'qƇ/m YݓQ<`T`uB7ACL}g]w3CSߐΔusR[irf&ǥ0%%d;u*1IM\GQL˱Msk>PkXʆ:*EcҝF,I 3#+N&{O3C}5~_>>UMz֭}B#\9I_ߗ7ԙ uzǺѢk/t"ԣoA[7zEQgEZG{EpRZϫod+ :q↻t}Y3QUS?GZ;zSԱ)DŽOG <7&߫]mğEU85=顣Sq|/hޭ{Rҧ D WGӼ"aBx#.8{EuW`G ;j<^6ߞ?W63K}x.ڄ;c᥄Ģ.aAy {Wkm;tMz$6^U73_u/)Cc=?Mb[߿k4_'5?/8_bwN;jḐ!T El+ S|M׻yhcau&.i"Y^78D~E [|*$x24 ?SߍGū$cUqP}_+>6ɔ9oq=%$o647|N<èx=BV|܈p iGް>FXr Z=ĺ>>Z,^vh;ok_j1W粐gOR?xm 0_3m<4ٿ ]D)u#+hۓ>&|+\zt㿐Z\N?&C_/8[炩?!`k*Nk3i y@\x=Z̳VJw^_KhV:}0\`Wy y]uq3Wt6. P3Ft w(Z-y>z-Ubjׯ|0nk-׉utσ|b,Jķ'\..}.ZEgy+#Pt5Ru2?=HuyTI5e@(z Aql\tHw6_H3L)_zD}>/냦!q6_`#CT!36GQr"xVt{)aLQ+ ǫI^X>:SsGu [^_<[FI&K1Mv$C{}y,Xϣõ"\)-CtmRo=h. >Or;c~{:cq3^uL*E{>ѴN1891j\KqRJ2>=H\G'Sb|%;[vANVq4@_R'ݦ_hy7ׯjdPzy!@)MH׆A5')g}̬]>?{GN+[tyvJ^4Ǐ~Icolާhqb$;_#֏xszN|a-jaQJ$/麿 yI}<_knQR`u(5@5L(>qxGJ_a!7FxmAGKǬN*Znp_.L7+ױԢhCbн}j#th8\#ҕxǛ*vNpM/1*7 .h&u)/::H'7ʓNN?__V)vSSC» ,,0w䑾pM5~auoyiYao,[[oo3YYYYYYYYYYYYYYYYYY_NiaEEi<#p6~)7Wt\XPHw8C=S[It<ۿ_;/VUg +" "A<],yFUxD>eq}# Nwyu|uwz}ThEN^LsJӂwon&DQm w}6/%G/d{EtuC/AڻL,:V?5O^Z~>cX\^+e:ن>ha}eŒR_53@}yV>&%b p{ᠺ>?_Kï\+ }G&(iǾ+;)zvU&w)3W8~J!s͌Qh[_:ܤÎnzw~YLWzAwh21W=6}bSvwjбPk8[oCy?d޻"Z;p޹S{tyo:|Q=C2H'1Lߣ~qR7M<ʋy]!\D5lF)g /B}Q y1v8(_3=}7fY,o֔+'M?_&%zO 7Wd%t_^WFj?nXK}7awUpVտG>?,:n5;|?jwJ}]/ Ͽq۩cRw u^?1d\LNm@맢)ICCEGl׉|[!휐Y2}'4_GD]/`n2M}ug:WϲRw$ ;>}D%j4_` @ΎUXtj,U]@]Ww{^";b~c:/أ餳ẞ蕬 X?l޻%54q2~C"b`ϠKg<{3wW4tz8#)Uw_,*7:IO_}?n^x~>/= ]66u;.C!LeR'mx9KGCo|X4gu?iғkk>p q;K;@^x~,NH]Y­B w62m#4lVz7+Y"&o'e|Mu/#ygX]kV7>gxn;no?=}} 󗺿M#3y~ݪV8nzE?=GUIW uc}XϏ^{Z;zn<RZǵ;|l~N|]$&^A43~{Z|S*&;W{y/û ?o/:7yG~W^%~> t{чu>PŠ*oiy3oF;o 0am|`^y'-Y8X1SS:O^W^K+__bϞs‰^>~MMex[xФmCp %{,pRu=5{8[W/ö}':U7_n=digw>ަrSLy(Rull$>7-=Blw͑h{S| m\0N*uyǮ&\'L.rc~dM_Y-A uפK`c^\yׅ8^K!B|#ϑP8˧_ C>Ң}k (.| cCԡ!"_fu $);]obUT_% ϏqWEIdtwȠ#"L婑Eyҽ1=iď豱2mr0^Ww۱x8n|z=(yu5- ,]g|'AWN|VO7\[|!\6!W#{? 3 b;y;ujޫ:z9qw锌;~m1F{AxtǕݮə=%EQ{PzB[:Qc=nB{ ͯ7;>K^2S3,4t]@9_> ?z&Gdsu~3ӣc8PĦ7ߪ\N҃IJplJ~|Gw"Ⓖ<=Klxi8X?tD>P_zagb_i2̟݇|}zM9sx3:ߖaZG+/\?rKEM Z}jMu֑$Az>#LS-;Pvq%nx: <_)~ǹjH,D':Z'ӏq@) z끳8o 8w8_u;pX.3Y"T U6FoQІuy`L_:_=! z5w~W1qfz _P6ץܦb}IqMgo~Rkx*cK%e[p$.]7~A=FtD{GT(X\53K}lzϮ&xAf1Eudu{%.:ӆ3xܪ<7meq`xRLq:&.З4r+u,>)ܯOm|?ռ1QY#ς?-RWN\:]_\h|$|qE:)M="/к*[u_ZY7ѯϹqvyZJZw}_͟>?w`tWj[7.>dJ,0JC1S':ʿw;qt޻;yd;׸Oǡ:`]"nGqoOߊvUiiArTϙ() >JGEjQ՗ϽIN8'z5:w7bKE;9\ 4#W^c&qF%ϿG}}>ȿOL\o|WI:]5Lܟuq82ZJ“_TP[qP$!s% yt?9tG]`{穿oW3‼?a+ 74ċoEmh7V  |ud[ EcNrJ`8(^Ÿ PߛRLX^0P>t:5rj`$ B \ {۶xIxǍ}/>NԦӐl/y?c}C!'Wqx&}|'"ODz*n!~nǟB\Cg h­|I{;<>aRڈ8YyGἠdxU^| W ؂L1 'wLF⳱H n 9 ]N1γz<ѐeLlj>_+uhůPU8xo$u ,xס*au^vKyB[|)z,󿸢Wy cJOa嗆=V%I,~ .mS9f O Ypb~4̿BA4O`DE5~\AI,1H=5JRE1ϡ!݇:V!^X4t^@C\M8#$%s gn񸟳zGw_ih ?nxnV!xF\p?bZɦ )4'D?*K_&ɧcz=شgz 튣눝 ~l}Op82,%zqY~ *u&bȺjZq8l{ukx~~|8/9Od6"qW8}K},>b|؟x2! /CO:,sY͢m?RAQ>燋(}㮟CVL]\P$qtf-3=u&Lxn4kc}ziC8V_I8U1y' j#ZG:FV#zM-\5,#=ʬʬʬd WfzC9^3Rw:|`yfXE8[k_$.~\G|"YKO:M`7%\3<[0qY;炱;wO.@*;Ƈ6]{1>4} +#0:~,<~K[ulǡgWC~4_ޚE&P1%=9;q]X޹_'ӆ obrI"'.Cz@τS1PS x&\&z"\%sޟ*?0lo-w#U'- d|/ܯ.ݞ#G2{oPK\o/h/TuGs;B7x.(^RPPQW̻)QL(UD{6`s!AQ'w6f:s\ 5iVs<=8Zǡt5"ݹ3ߥӯ73=z_ݱ˝rC_p0 b|Gxx+4uN,?bn W>ϡ3Sq\;EEgs?~ce^78h.ϊ\Єxq;Z0}sO[늖Mh ^wۨ^#kX4@<^T=yEC6 O"\A7:[ W>.]]~^ϟօOҟ֤ckhDy yKDEc::A+F߮KۢQ͐["АcBx }BBT7J2ϯA7fmx㶡N(n#۱vKjo^BT{4WำZ:Vg[֙2fVIx)p>~ _l'yo;uJʧɴQGuEM)Q/3|CEOSR3kIM}ln; ]θ= x37G~iXs~R/Ms7\,@|q S[灉 N<_}Le9^o=!.LGvͳq}Gc_TiF} :~_Z\u_EZW{1\A9Vg^H YGGz0JOyrQ]Tz},ߜ۵c9äq>28^?^5;3c}C[n'{]K}3;{)|]bsQ~>:kpFcwT\*tOe<W1-_?ٗt<ax7~CRׄ<\WQź$p> Y-lnxw|%HYCw|5zxnZ,kcz=%|~1?c~>X#˜خ>OjuBOEAtI _ǛIWE:@:z$=q_OϒZ\gU,<T;\tO͛clE1ߴOxnR_nTnX;7݀չ"TI/s]7rN1>}q7Om~1lȷQWt$T:Q-SfN<7Xg3(&kf_lC)ߋق0F!/{sᅵW.-'Cnq_VT"Xn?HOʫn-lWB.@ͨq#N@]8_,j =y?yzm<`D<_g~?aZw/"h|GzCOEc?iϗ*^ %+|WxbĊTxQ TwM CjSi_sͿ W/~B_8_ ˀ E[7CŧPܼcJܵ#_Ӈ'[aȃᛸ!~!R1gb~3%g[ҍȢ38@8o4p|B>^gjDo10^ ;cʏ??tXaV>[cEnQC٨d68/SyLG._CuoԺ;gޡMhgT]>4fk:6Wq[5c,iyB&\ vqޮck=^[U;3_%n.p(KЇbRP>oG{Rk WG!1\5KmuԢbo8.o.-KW(ձ8?xN~!:Ψt =  ߤ.q>F;뫫ˮwc/D3~Png ao!t)z}#~/Nj&fDcbX/<ώ"U;ǹGBf$R%wЅ]jVG%7YxR:?;?Ʀy:3g %|?)Q`WC{MxC#AMkFu _QHT!᧚>"n|/U/bQGŔgr-DgAĈ ?TtApO>xn_[Qwoz4/7ݬ bI/Q`$zkxʤiۿlW5#+SYWQŻh>{&9{1u/^,3PS-!~жD|€kI n W }_w:>WCtF5G K_(,< ]~ 3Zk&>Q׳?ƕpNQ:Kx|QqIҚ<ۛd3YJM~06\X;l,_~[@=ĸ=YP[^bZQeYk\,L9sxi?+j8??8?G?ҁ)yH[te<+QłV%Hrf\g6f6^ zLp0ot*gKy|_KZ :uY^АAUkN: B뇕hi#М⳪ C|DQ[Ko-#9ROWF?l}JwϓpX|hhSo,i aۺw:K` {LtZ ׫r|m|[$v< %~{}}urh~ = <)2]ͧϯ+K\7{NJu(_ٔslN/ܗCտ~fW/f y}qwzW5;]|&&}zѼ\TSœc~oe?V C}P֙_9)Wn+ lo ̄ۓyr~^4awq,rGG鬠#uc}=R߁ʃp($C?Ks\mwiOWBQG6e|rDL&' qOߦXh8?٠}?\Z c]n.Y6~+g;0pWP޺]t6O;?U9~EE59t%_Ȼ4ML&^;n7߯A7]E:Tdk` 8>XyFRtіrV5 -oy] 'Ohl0]xx)s~9/Ĉ'{D=)-u/tu7̬|԰qvAҖW<{ӑYn!.u:ݬV7 {RbZt2ywבW?/>cz=i+9y}M_K3Kcpj}9Ow{:1u>T_zGͨYE/1Э^ļ墟Tf M, :< `ү>gG%*M2i^IZ,O3p7UtWSY9?~#C笻Ϻ)ሗ"cqE5)Hzo2^{/:Sh@㣖?NA~Ï=O&xYHNc<^aƏko;k[.zPw_/Ӻ#byO\tS}oj<˳wJ:_TWw5l[7S-}~ڮ*+9.LϷd}rpT!km?O|t#K>av-:b]¯3ֽxsG^&:<\-{{Mϯ9n&*sa/d M- 921RulV& ]$ɍ-z ?͗q|߅/,dG&ܲ>xo5J_ҩ`!7|N'jlp&>2Lm?3G8*FG[ċσIT^5Eѿ(dyΜ+ RHϓC"9/1_ >)櫓øwh}[f=MN}x]#_r Fc"OL 94ducⵥY"z9>?>q%>5if[ X|q$?CHPڷH~OKQ7Kh)sp 5(;@o4~BQ묘yQ<0Vq>&1XG.~钡U<^-__13.4ӿYh w*"vt"OoåtYKb:m wsV\Ϗ 𷻌rTٺ"occFx>d?8_9x9|^Cu]4 {#)e]=\t9Fs/h^NچL?J봎g{`ןtNE0Ts[p.?8^(gGF>u.TC= =&^tT/ Wr[~t/x|`'ѵln>D yK>{1OɳW6ezI4u_ἬKQ;Bp<6U|Tp6hH8z'W8{_*y83`*mȣqͣhQay1\:OXt?,/GgxO{ҁ@{r4wU>`b᩼4o'ov/BC~OCoǚO DyЅ|Rˉ6bP5_԰;"W8ʟ@?Q $-^5~1 ehXJy<}~~?tSuD'K?fus? E\>tL7 zdDŽ|@nyTW罣Is}QSE{~< ]O1crL_p>U?le_P?gꗅ*}l'yN#Jx}G=7 $(QU?fZTܴpq F#xٖzOYd#ؖ~퓌Gbwߨ!Z61/юg*t,zkB֑"G|4c0Jy-̂/z!YܟLři2eVg\T9iqľ)/~i޹ CL/Ϻ;F[!)@Q:4cApGd1R$Z]'T9b37'֪yb}w}NE¿^e6jq hnѽUϻz/:yy먆zQL =uˬt +Z$Zo Hj6%ϳ IWC;sݪO%o+kI>`S4L?=`ڑgʑ΋u/L?lS{:+{quwS۽ϓ_(ݬS#pstv㴏Wd/^6S 0]xʆ%˸/ f(@~F6Vftwwy ݸ_WXhAqcAx~\]m`Qcs8yT/&/Y?]#EvԹGz}UJ[_'ĵ|ҴLh\mx{7H3´3}T^`"Ψcඵ7IfY2C3GHĵϩwAFC6+ > :KjR/-}:w5q:w6Y]յnwtv^/OJqj].0GR}O$E#y݆ίE=!=Y9!zd4}αNhq<zgt#=6/ h§cQxXp~5?DW55P]\gѯhϨCc(?ʗbÁ yS oѪDI3?驡4?T_S߷ xM>/e='"?6%gL4op?YɑGg_G#uچBnqz@(Rgxy4I9X hNFy >[ڥ3?dPƒ7ݾVed^A^- wuUnAn4P-_4mj<^[* 񥟟_.E>!`yd}8ok?ubtf'W9\ *xQokB0غSgQ'?aqZbj x Nc1&=+*&:y>n$HI:G7B磪޳zJh\asE>OyCM; KL,y>}qp3V}}+ O,}OK} l:'2O}d^CW!&{~L>mxyی-q/Kn%w]XȻOzR{ C{;A[uW1qT*n&KDB_tI3?8^UGzLRG~=K>- |2{ӍcG]Tn d{giQFcV"Р7G+mhL'd~MQlߞczX$+T>3dT^;J>IyL|t^D #ݣ^fyeNՓ<}Azş)q%>|H`Sz'8^?>/tR jh9݇%ЎA>Z2],Q_׸Ӥ|1[{~%ˀrW1z8,5? QuTRx0UΌiOXׅtf|<;փ0l<7̤ DN8 Ls;WM{eS2aU 'e =c&|4yEyP ;-DCVX9烶n.MusսESKiC~CCX>jEuI{yϵ-U~bzvtnqz??s{E*|B3tv}zN J<㔧D +YVt[nHߥ=n8꩒g) ΘQ$[D<0U䱇 8o/=Ü~H%}e:2_I#:jFrx,YkCb~Kߐ)3 aѡxxޔtLY9zS;spb8r//H[gBE }o;=̎6_a8ᰙ ,ו|㛸6Q1hƮOuTa=YnޭZoE9|^L6߱_fG(3y=4*#W _:xESP?]>n{E>; NOwvvǿY7~S]Gm|QEǕ"[: ^El2# j{slb߀O2n!B}:vY7ۅgXpa%Y2wg$֎ Û4/[=z~4vig:tQߤv۴t,U ?zsu[z KO'>KEfgBg{ZG+qH+ח*zGqgC)q5}D}xz'Osb~LťO-l'&~jb:ɔ_ƍf0hxN>i~&[,>>"}6_3y=˼rvt}ٟ pކ'x/. yįA3%5T뫱 ۙ(~ƥ* r)z|tc_Q}UCɾ}C%?-Iw4z\l!!Q׭=dP~o 'wL bdEԳ ,J>.y:MYBȓv^-bz nշS9)ǩ~/H 'a ):ik3S볩m XWU φ| a3ےūgj3r5{v]WC=g߰Icc::!ާTd}///*W4{= M8N;pMAo)xSi̫0^_Oy ??H:QOS?߆z{dpw&.뺭n-x7^0K߮:Lrx\Ìt$Sgo}.7VׇAb+O _o+$̭ix>{G ȡ%y>??'׊[!wE0T-Q|f>=GzX(&$Ë귡";z 7mODOƫDh[8E^.DsMoW[=ҍ0:[h/ )+Iu.L:Hmَxn Ni[vyޛ߿ x>ʬ̾<_'0#1 W}Ҽy`c~Ml6gFGř?#=Pysߩ'}~GnPD)Mk<̔aXq/.PhGzܜqᔏܑO0h[:UKj%e!Y{̀gP4ssT>}pzǣp ' Z&q/c'^7MW7EF8v>nwp?=]'<' ooWSWz"خV[F{٭~YޤI5&C 8:}~OcGA~T\u\KC%ԍnH\5F>.T[t G7|ȿo2֗7'Zyt9/6oddYm}#rW%p~e`.G,!JGp^d\tH{'Ƒ: ;>LrwxӧPՕ1z&<*ƋP> 7ޫcm޴,3=ċ;nυ\wCuIN-Z?kW31߿+$#֝iMtkexfϯͷh byP#/^]#q5hA<,}Veh̿YWs<˅f{Cu_~oY|L3wf7], )֎s~؞`*ljjdݾV< G΋JY{3Ŝhޠg8#߾c|ypp&CGTi*ڪ_}ǫz8Iidkqm9' | O$ܯA_oDd:r6?Xw $UߋJ]5u%!4fD;& Ȉ+#3"TS`FBbHbB #K c<?sggg0]c1`d1#"c׊sj{_w[{ޱ;޸`{qG>o}mֺ#!W%yS.>$;4ǯܙwyo>9')WOs/xkjŏvj)~l獿KO|O];bN]g'8+vNxg}OxW?i ?>#y~%#~I6*$_;\vo};;.־u=9sSosNS`g~OuJ ۺuszesYo~tWߘ<>wa+[nݟ5u/Ww{Ys3#gkޓ v +~sw+?6[NpuQ}Oܕ{n!JϗګK.wn\]$ҟ6'>y{lmN~臶WfvbP:}~)޿t'=S/o'O3PZwۼ qo󶷷Ƀ?'K뫿}| a<<^m֗~1{oO/7J~Jb;+ ~rgrn7 _G|fiGg{k]ywo:MO>w_?ujrqx_Qߟ2>&?/`g;{ks޳'|^s?g=_pO=OޓÙx|ʋ߁xxyo 4ɍ?^d{{hی[p=ގ[/o^~vysZ,e:5/=׾w'ͽmUKϚ:ſw>;O?3WC'_zΧ}iw—흖߱u{{[?ߴ7_zzQ@Oҙk?wCqێ}Dww_g? /oC>#OG~|u[>:h1{H_\uGѝ|,I%9y.{Qzߣ~}sَ3?f.;Lサuzw~ޝ ~o}{\Frzj=w+7N^yWuo9Yߚ95O_u|7|Q7N>o?{9_Kq-l:~^|w~:~i9}}Ojznwxe}W\jΥK%/`?wGm~߱O__L:׺Jq΃>ᷟk"yQKǽOgΞ<]?qsv3|~[9y|{;y{^kEu{<÷wO^ﹿ9?ѿNlH+sd~'m;I=r<}|OCo~s絟l_qyǜr7︧;޾NM}۾m7oIO&vNUݿn/yoNru䞓糓6ͼiKe=#pɃi_y)s/)hw;K̗_y󾄯O5䃯y7q|zߧ%ϻ;j܃W?W|;{N^g|ϡ/>LY?xo9[8c]_Zgv_p;;kծ_fWosټ]Mk~L oAMng>|v}^g |ޡ{_sKp|CWuoK;;Mm[].~~Vv'}Xߝ%?|ܞ>=K>)|@3~)uv?&WvG׳O~/$KkϷ?0Mk}B=N~=g'8x-yWޕb_7EuSbXo{goGztSϜ/4d\Ɵ4Xκ}:iw/yۃ'Zo|w3t[weهyf{ݾ<K>8w_*e>w ˋ||7>ͼvÓ#I{ȫۧSͿh{?}7e=hO<;&om+I='3 y$κOH/;> 5H%o1 ⯝\~WJwk{Ol]lz}|w9~fe?=yvM~>O {>|uy}{37;9џJ.|AgR]E=ߺK ߣ{{;47=߾۵y]Nmvo: OXcǾk~;6^z]AqOsv{> ߛ-6 u;]N?ql'ϭ풷b]MO?N܇ySީs aǽ>Qa{ɓ/Z:Kݫ;g%1sirlX/If?]J]ȻFg;?z3<~M{|k/r?;%޵.߱c?_ŶgΜ=vfvG|T3~zX}s|-|yɷ~ss/{''7y!yizGm#L/6&%On 4#lSKoVɫ^];$spoc>_7y8w/?G=ռ~q]Ͻه=6ћ˓}\f;M]~6f]I5 Ifu܇zWC[s \~>=e+*P=Ϫz4枰jkm5m֑VO4t$zk?r=^z O k{o߇W~ߏ#~_ϩJZkw?cu_|styas/7$}i/ub>&yƎyi=_W͹5S~ϏWy~6e#rZ߭_]o_ϩuz=/9|?W|-SXU'G||w%amy]/F~)yxL#͹;_zXra;͸/f}~|>6O9ur?wOͼԳNy {䛟Zs/9y>oNs+~~6yxr{D~F{̇f>"y'kHr_*ϋܱp|QxW/N5}|OavI;q?8gܷca cs?G~zỹ9Ys$ut39~ݾ|rޓ<.I?I?luY}?8|s_J۱>:L3.y'y{_tr|_<ܝc:<.ϾA旼}' ګ>[ >]/mgɻ|Ζ}Z~?笒<>Y{qOcf[s{'9>аW|YZ#O=_j OByϾ|W࿝/W\c7IdܬߴO:_>kb~Gyw7ʇ8]Y{ܭ_2;Kjai>35mm~.|-^:S?c׺Dk^ahwuKdc}T3+G>O 91irk7]f_'wɢ'mi>Ykl&_?;T"/]Ͻ쇹u1}|sĮ{tz:s=8;.q{v))>l>ccNwx'$muNGg>㬿9M?c@|mϛ+kE9a'{n33Ss`3vu>߯ҜGͿ%~UfՅqϝ:wLLeGͿ߹Q5u{}tp%o?y?߫{wBo7*߲ݟ~3GvT73CzOG~}G~}ߟ_G:G%z>;]}}Ok湿ݷ\=Ϸoǹz_TbOz?-y앞g'7㱖?{}s{y$}R=U3xǷmȯ:/WqFs~}Yl=y;'o|џ7lO}ɺ[?yOzjto)F|Eb˛{Yو})࿬YVy{oK^w龰v|;>_.},~c`Yr~wzS>no?u߇m?F_'N]W~5BN9~{㇃5/&wdjO~S~ww6.&~䗚wM~ct峽+|RݽNܗܷ_;|'6X^nᆱG?~wߣooB:¼`ZIrgz6:S8zjÔ~<|>>Gށ߿\΃"I~P'AkNѽ1'o꧶?t?/ݝOos^j.m^cooܝ^Ͼ_z|*ߗmwԜ=c松K'CǷ{~+"g3+>@ nw'ӿ$o~R=O}u󝘃?j1xƝ9j]_lߋ&8䩢⾁/w|ٮ{dG=q)zH~Kζ/yPt}ɕ!y ާ|}ߧy9wY/IͽDgzVoo9|7}g=юFt,lǸ5-)ߩs|tڽ~]z:|LO=f_9澹OG7PM|Z>x0y9urkwƹ9MVRn~>߷{w{kR}8|W& g7.> ž}|7'yu3ȯ%=:_)8w+u=7-1"w)ɻDqN|;|H/H>li$5〃3xaO'_{}9yM<_/I^{g_n}z";}yv?yl?<}RXg}oii=X)Ib~'~Mm/oK^q_3N[{ߌ/m" CϾ3/s;uNٛScqi;X9O^N|7إnľ%wvˮ_Z>x[oOn=Mr?ެl~)׽m^ vԱ:^ jk:%g2O>ugy+vwoא#x|rξ[w}I/ѓ0{of7%/o~|+?}-}|o|5?>9;{G;^c~Əɟ;y8(q`bq'QO}s|mxO彆=#?Tms_'[ 9sQ~W&懪~_^r{%ϸ/JwtGޟ}~iI;ιl{&O:&</ܝ{qloQ|)-$=w]{)6}|Or%sO$UH,>~,'grno^6ۉU|y֝$ڭ63'Svh}~?uqhr;zϮW뷹%^K~=yr3zaw_Nl]'wz'{;՗=؜#zYs7]_/>1'W2|~>nWӚ~_אl+9(>Β㳤}u^ܾw~񔷷һޘ3ljqyTz)oKk=]\4烒/A|{u[Jnw^Ϋt:3wr &ך:<;E1~6b~;;qWmAIgG9M=}=~v0qv5,mj볉:e js {I?8Uq\~bS6'(|6{yݎtƍOec߫Y]]O5zZ5W_uS?ؿCCw?km%h_jϳcme~{^^ӯv~l_~>>i;Gފ_G |\9oo_kS1Kwf? Y|؏r1;o)|ן'4c3I{<1>{_xs>MVgr^^ѕJTRJAn^OJH~Wtބ2@+O :di.ByAF' `!1@FC'H[ =F5ABT+Jfώ=nfbF0>BI[P ԚB7iA:9!sӹLjmܻO@Au}ZVNPd:YAD1B0GXs+MR_}-0X5K!CX0>BRh2jR:o?O6 同a!0MV&CҘ.(7e1iWeK/k}8)F17 B"DG:}/ BjJԛF~̗Px2Ft ¾1f"sgAt|h^k}H55oXvT;( An[X}CBy9nP-0 €% SXץFszcrMmݰLg萏 Dh %bw7)5eH,mL^5Vm5N c}ܦ;h>,PsЀLj)F>Q(F#j 'tK 4fh#F#@"c0fT-W,{`-COx~F[s4}ǐcqD%IK}TH*h ,)F2m] r]`wKTE 4AhPuqL01:!D eǔW,R P >`L`NFV&>PC5 ! STԴXޠO>JR yF9?H/Y`0,>xam\LYxFϮE9!w,GF NQhIL*(%%,@\37\堦UCWr.))a b %ZF@죑jkPS:fRF4ͧ4|QFbT}h^x4A!B82ƞ`4`86nܦ1us ϩ>)F&Wk6v}Fh丠1LҎa;.o?^ ^sx]2(> G4'k4Wr|$[CdǠs{MXR'X0IIYcJj jJiOQ VQgKM)ژ{9hyjBp EL!i:v{%$3궴]IJ =F\O1Ҍ t  EB3^ͦ0=4 قZA3JG=>͘L1Ҍ :" br&!ː <Rֳ?h5r4"ϩ#gyv 6QkXpx7>PYdzFhNv}ǐH|#Ρj*RbF09:}|j j#Poʲ?Ԁt1R4#g0 A0rs r@ݼ|ykA\Xb}f}-3~:T-dѪVrPN)簌lJ 5>q99[۟ PSh)TD%|!  @Ok>EtQ-5FZRC ad\{54 NzsHPB(4fz--H[2-̹U(t5G#ͧU(8{P3@ ;qsWp*8<Cn:Gׯ4<(`1S̸mH i㎖7vDI:Jq ǀ!iF #1KH )o9g_󌣅|H;s v" O.34nOex fGr> [go|}bMeVˆl䎄0+V0Sn"~qVWNj,#PC$ ݶWki˵Q)рmXCG<:*#W91zA>:oBW;DwGBr#*W,!Ӫ#XLZ23Y}K:F(9Qg:+C Y(Zc*EG:e1Ԥ8`+/">->LNiBLYYEh]`;m6^p TQi(BF^_A5te˒F$E>5Nt8bއY,)aoW )nȫ~e*LHOx0)ؒѻ@MY -iCh4W2cm.7Y!@7CCB7V#X˵<_B?Ī Ch -3p>|v1G#.xR_aAB 4A!B##H326>?XӵqQWZAlO "Âg >iU`rЙvpms>x_P]^H NF6Y;%מAmw:d>!ɝr5\M@=uPH s%t 㸆pi捎Dٞ:=VZ\9Uj7 tRЂk2T J\S A#!@"5̀u&X!*(U̘Aȏ`v|1l[a.r5i'DTVEmjјb4)Ԓ y }œ7_Cp,,`|V #UP &15 \Cw٣zX]`we@y֐xiZCZa995Y E.##>u֧=Sn-ka 1zDEڪSРYnsץ(mccָg{~cxY`^B,@ASb!C}8C1[k)u(9Z~_v|Jmr D?c>c&=fa6#ܬV9>: [*Zb%A^Tc=|Pṙك{]`.- &SVƴCHiX`sb&$ap-]8@M׊5^`e92]K~^(8UV}rcYrqS4v@8?CLDEBz aŝpm"q0o`pJqcLsW1 C+++}Q4#Q g7VEӂ՚IKjMK(S(%v^ 0F #+(G ҨM9ءš*?pXBoQw0X1)5ktRzsJ]ߛ9If1YQuG){ PM T#0nMQMZj.VS= >l ]pl+{"H-3& #Q(d1! ]NH0lZ0 jxV9 >ǀc;NcYu+~_~voO5FW#]Z{UY fN\H֭ZZڀu!5P} -A" -DV } oԬi #~#C(tGp?ZO$Xu t-NL'1h9v^| vK.ʲkn)KB!@Yy<>`7ZTDa,Fm*[55V 谿}NhXI4A`‚BT ʚ:ھ5Um=sjp*m}LGp 8o]HNj6a'ahtH[k iFȄx5q u԰=]IW/0-3t|!D四jS_tt|;「KΪ9Ģ=gTQ,^̗mB}k%],Q5Gñ]Cl+JWc%YFit.wsq!`J5Z@C< R7aVEhn9HᄤS#gPQRcݒm;cw)Me%%%]}k)jGn*`eN:}K3-+HbLPct#ň #Sf,"MTdQ1͆N ȩSNѩ OKx+F34ZMEAnG{%d9jrp堜B[Yh2YBY@: ]^ nJF0]3*+ګp!m7 X%5ԫl0^1G}.j=F\/`2BB!xiF40tmNǨV֠6Gj.ͰQHQ 5#Hd L'B."Z9u !@SlԬ?^QlZ3{aT{_K17KA(p-F )(a@ɀH b!2tĢ5{|5ѳ1%l݆C9 =_D/6#^$">p/cJdϥ:i{#7pVB_ p¼4 %Xg"1g__p?@P7 _({o$܋{tO|HħͮMv"8N,%c *欕`_t96\ۈ3Ҿ/={_x }[ ? X*P">??SK4BER @H+JmT2a(2QO d@ItF#:,cFEq`8>VFh/jC1g|?9)*VThf}*|EM㋚b_H_D@ Ы0d:8f.c"u:H@Fős&8:VV+ EpCP'p?FH cX"cªI'J ) H b!dp/yȄH4 "O)O WJWR?,+Қ7d=>C҅~5r(Tw*vn7 "!7q7qbT̝j=u\rihiH7_AO 6\+Fj!ױ/P6JE<)PRFp Xxi}jǜ8c (rPŊkC3 X{PPmXx ?ypъ?k25SͿk>g%W,#1g-Z7¼5"|m|_h/ rҨET2QGU Xk*/})3b1c)Ѡh8##{ [h{߀;(<T0OO/'/[^js}= xbG0vcŬZ>jUDgOUU },iC\k¹@x5 ^UWWJ0*B x+ylAnpխքjaNߓRs 8 a i+j6ܰϣsm}kak)O{pր;p'Y= !w^"jOۣVܙU 2''⟧vr\Z=P ^[g3#^b"^b:OB7fp !G]x<" = bV_0G\s 8 Q;-܇EyVK":"0Y7އ=FlYbiB-5qv s>7sPļQgT Cnzw &'c%c<\: soFj855 9HIU{G5o4Gath6CBRFlFd}8SSMwÞJg1>BBK F6"ZlA/r7r YI"#ES 898scM8N9CEw.5o٪x-3ciFޘ3{cfoF!hvt¯ %{46U}vb`i<>Fz`%)}<[fKO0 BZX*ɜb1y95sN(G:y %T!|0`4F*J1{wNs{y`f ; )nlT!B +9@5$) e7b=F\O1Ҍ :4 BXVE_'`+h[,)F[mĚ icNM۷oԪT4k ,)UAQO,C-kA!h! w[Ūu tU!#RoCR$n wʲt3PРe U Gc1qbAQ8y<@B;x({ ,8jMlRIx4< D C(7˕9wSi7I$Ӕϣs>OP//\I cMˆ瀧P}d̓ ^[-'9UI !O'R)%اPO# j',#<#V7Y xX:Ū=cy3/|\Y|݌1X]  <6`3p, '3p,}tb>MHoRD,! nȂ˴"܈ydXF,Y#11,#V"^;qXXEgY4c͘E3fY7f!Y[I̬e31K,φZ ؑK!+49G}B! m7 b0 `hFahTks|0sA ~WF/T:)tay`42E2@+$=dkotc45FSPO ]9h@]`.]`2/FSk4޻ y[K>JX]Jp&Ҁ>B Y]bl:ra;ಌي]29 ~5o %d*[0]_G}nATrl@ *ʀ:e\93hP@23(a:u7K12(]:Pr>1G!F* H)e[&+! ě!zF.Z%ݣ'p*r<88Hs!=/5 !*:5$!A8t&MA0  逪@ 1 ,S5A jߴ!`!m|`ي)$q)z mrA2^QczbP7:gk+dݼV KmXnrs%'q ip ^Թ` 8s 5oܻp;E9>ǀcȑ!RZa0FEcaiA9Q p`H hGߐ>0 `-oW(#A!h#P4 gUz#p.φ8_2\YI'bƬ F)uB0GX , kT݂VG+k(B>M؂\~$x1tF轊t1"mGk!G[FB]SaD~Z1@CqxX#K w3JIC%ށA4B9#*R`@[:@c) ֧F}!Q3rl4QU<qDzvWG]awuDU֔3V Fm =;#}lk /d>))Ʃjj!Ǹ1|L5xqR D٤_fƀrzR9儞&lgwE=iF(`2^AL/Xw bPCbad[9 K\-*M ԐS\XqR9LsOad)4n2?7J:Vɾ ل*2}F)bzci2 3h#0+4NaB< nl ֐ɲi,ks>TX5^cRѭv෵DI9}_%4AUr٥zLS1Ҍ #h(d##_K1#iF(`!DflL1Y3G0+b a mfkŚ㴿\2~Z6MQ@AM2T\a!ENTAMsȡNl i4RB:҂Bȭ&9j!i)FLamoևu 9j̨N=WZ6_ϩjfG3xh/ʟmavEmv!9<:dMe24BX0P] ³QXpk"bdF!QcӌXP`%`!DbhR-&|y?ȡQ Lp 9FS톦c9H)7`#ifO3{VfhĈV*ly3F!#2mO,K>=4ALqJ{|rxMOCf  V]5,o_TrE P[0/|P@MMwXA/۽jtP"5x '#:(TSQ+n(5֯5Vh5&5q b@=h5q#?λ̡1'hga=oS.fYy1c@!  T]Ϗ4'+ȽE bP,,FT-,ƐFSŔV4zNs;Rq/@bȂB` :K8衖B̅]r ĥߢ(ۻ((@?/ iub^afF;5 s \۞˕ r+hW8Sm8?%5T-Re_/cHɩ%sTc']F%9]ñ!ZNl29ѓ Gc1x"VĂ EAhTh*MxR<"*bP4##hޫ5P(-a3 |=G(`&f2` k}F BW׎)=P|3b#g0 Eh&{ =| /aMwY@Sl Kb `@#"W`0(E- -Hlu2_ހԏ7~ o`}Y¥(r CIG) I10wn)@x| aRR+\Cxy9`y+``|!D E`byd0[r Xmrj ez)@Tr!s2" q;pOFEϭZڀ5aIZ*-r[dl1mA!h]"?b4T@go!)`M2`|!Dh_w1Ć}ަ7DA&6b5butA-ô @g1 8Rܤdq;9E*a@3.d0(ឱ(e@JL]gj%8% ˔]JXI(3% ڊAQ6e &X,#[#pdA-7pNN#rXǢ'.qYr 3Z8R"aa%MpfĭoeX[ŀJ f.4eF3` X!dB }UD@kܑai_j͌$M5Q%\"R¸<*Sh)F)e&Ii xaav< -1-Э=I{U\ZPWpŪ!sVhVCذ54KXug9 Wո/Tߑ*5y¯<ƃ|k}[\jAj1QiF͐`hj?h_oD,,b UN\Q A|] Փ-BօvF8 k`@:u1xCl?X`0XX$:hP[68+H1Ҍ #Q38 ]ŬrҌ #@(b#Ai Wrm5gD`3p|^̶aD amRYSJlNa7:} K0zYVMSbh=ҷ)F%SY7>_?)1xS^9a,}Zr3p )Ll; . jw{p]B{}u`~5#PA=55ft@YaF,zԷH^'+ . 1!_B`ӡ4t8}5ѷ8J0G9լ9l%)!i^*5}C8t3pKgpL1:fȋV&pґ [QP8R!%sBS4#(`w Gb' /UP0=tve%TO%r.Ы#a7[0Go` GG CC/Q!w > Nqý kL^_0way|\&w8w;Urh>?^@2[}݁fȑB*^4#ÈV;m#at€qzE؞;:M*UTq1+9wp!qSb jEA ujMlt\e*pNcƐAp ju0 #s(7*.\ EFqu dW=juߠfh3$׃5]d2K9TþyّbpU`50L㙛#L,s,rJ"mmi6U.BV x=a4h795+T/IҁNftAΓW`>>SS8l!(5꬙n'8#l v2./A>]lVDzmtҀY`r4V@h$5p8:"-| Ҡ6ׄvuR8H鴹SSRN[GiޖK5) mJlF܊$>Q#W1jگafN*65*4#s}+5ADb@9J >YyɌ9ܳ=}6:y95! r0VЎw"CP&֐TJ8 A#Ԛ* uT5GÑj] h[UOPas,&}*s@`A%YX2Z:TgT š*D>!ЧvJJ=8c S*C!R00 #4A900t;%BY1$9`PBp0pܹ샆)7>z7>ga|L EO& ګ0 b{UCClRt5US#W/VI`|+6r6B}_B?~(ۃcWj;,'+jT5Gp8 ǑKj5`( ͣy4+85=Gvhv٩Y 4=yF/ chaxNw]%PLJQ DQBJ^58 ۟!^G@ ۚ5q= @gS T3!@`D1d-`RjMtYrj8j%gLI4`2$՚,j%2x8{YU5Gp 9FyJ ]vdc˶5AV +Q{L}'=V㘙e5c5g2PÓO1+5咕`lc[!CZ[LP#EjX\e(0 xp*9uŜ,u^5]TQʈE1uE=SÞ[҅Fh{yh]eN GB 5K',֒jCR4^4˹EZU{ubx1X#?!JjiفBҩ* .:u(9!tɠ.c!#Ph_!w0\AQ۪[/ *1" J>mlZ wRs(kHMԬ/^(zpSEaDIt^@~+qGI<@΀msV@Am@M>c rL\&4U¢ 4uj+Jz*W+V[ցA"[%% IV$+h`Z[QjbT?Y5!1M=5ps胚 l?<`@ZàhݎÞԅwiw꣘,IJuxN%ZbF(9ឤኞ4A1#iF(`11(^QռL= ͮM[8.gt"4^tgp u]ÇG/nmGjM| vfWV[i3S+PjCPLM~ !om'wlBN59A"mGg. iCU[hma6@M͆rR5CyѪREY' DVB{5E=}UviBFҪJ Sp0Ӹܦ 87S4!] ԔEGhGa]۵p+RHtE& h2aSpSSXF謚;pE ( Ǘjqf.)FSfgք3^$dJ5Q&}$ Meh:Y`|Hс(ua Rׇy-QdP9hWk߆*1@9c9 *~%U%cBh ` /U@=!L a'^5ҫ&zdoք pBSJSEi1L!Xu )M;u19G82,` ,,Ga0F L!5\: a(+R0/T4Uio\ +4L U͘jN2ZA.PЦa9P'-&H3œC1c=|)v*B `{aѽ/NܝQ-$!: CP G&?>|diZkD32|F#&V iT@ӒUT|U0) 99w8\54@Am@:uԛho u0z!c+_ |4 ] 4so@iNԪ! ϡ,UӣzXI)nW. iro%oџzNjh%$1!McL}.&K1;bIUܴeR b ,-YP][\X@c4/ E{I L֤ Wv[Mjqg0 QI\SZ/I6 .U&cg@őZ ۑo̤ =WT3N h\NMBAc+=44A!q'ER'EЁ#t8wpf0gdZW-SO7Z% : k5Jȣ+کQTtEۑb0uDٰJZWT>K/U@jjp:!ԐW-gz:ݑ$qIؑtRTvS I")ѝН0˺L_ t|73x~e~NLNLA'Aǯrq'""|baӰ>qVܵՉE܉E,cuʲדN<wS޽Ny:nz$wTݱ)^.t£;)^zr=Sr=N9N,:%\SNNNA'^AǯW<@!h#PA& uffra^m4:)S8RQPn@ +H: JYƞ5A0Qrj`Ѐe bCㆲM!l75ꞕ7G#}o·6MAZ+^2@tspO+XZе E,P®7Q-ޑ;;r:VЋ^(*>=0V5ySiYo&!7ij7f֊oBpsJEͩ>-ޤ@,M<hjjf8y(ZGp G6T9HQ+D cC{.cfdF!3Gsxü#(GpC1,b ޢ=VM5ͭ͠s.*D<9fʹ-F}VIstkT~ [UGMOS95NujBv>p{0- C !DVMHF>՝>| 4L9*J)Q:'7sѫ5 =q]u\^pӆs]U5QCn9p*8k1  ݌!ONcw7qDϽ nS nu#_ioq.3Rܰ57a xR<P⩥xjP`xvQ13yм@iI@{nDVF4O-SK3O<Oӑ@n8.GC֎ 7_ +IʈydbVe8eyBtyB<}>ϥ>ϥ>ϥ>ϖ~rKue9)@Og܀'_/I$x< ϘϘOې珰ǒ/xCby1Kjm !Oggg^S/ nƂ; yj<5CO͈L7@kWWē3xrF<9@ 7( E,D12Q̳LԦXU xq ^e{#`e&I$y Z 7̓,I$yy m V}89f)}N`TNg&*H2aEܰ.y +4a$f.~a0,M|`IoX% 7遚) HÛJCMee6fY5,+So"kg#z^! 6u]`P@sBLrnrK^bJbOz;s!hHvT G\w)d=TOV,y?4iа~E췄>s>K>ǀc0eܣpw9dy*dy 5^ľ?0DRZVa_*\/c4`4d4b4f4Abe/b~Dڢ #zRr`C#ױ6Xy㖈%tL WlTn*1$Xq[cw1w1w1wq0O,mbVSZ0vqԧVRuљ%GCa#-^a}'|hbGHZ^Q.\-@c=Kph蓣kj jXBZ!q}O:|aRO1UrK9‚BBZX5JEQGԴt~iF(`2{jb<;*XPBk B\z=F#Q(dKؒEeIHkbNb(b^[j'<,pck_R~Zyάaa aA1, KKKKf'fa0>̀zA c`BG n" #hU5oVigh#SdF3fS`8}!ѐ$tȯ"Q&V! ]l nH1>.&j^[mֽRk5BWCI~iU+PkPPoS1˴c %oL;y*`: =[5xQ!BCoATb YF$+e$ujy#3nLMB VaEsŀphL}9|𶂱7E =gn!MҖN֠JjDWt4@kNۋ-P~JߌtUXbJO :1^@}iqDM!oOYHSӳY 7U #&ZjZXp稪޳f=޳ !B8GvGhdƊJlMcސa #c#˩YŖOw芃Cn{5Gk=PRR̼z! KmYa{Ʊ0>3=ʋ ccBa{|bq0Vgn}(3gë{,=t/bS{c@1<澵k,?X<ƁfbC13XZ7|az̾_}uc_?{|DǠjyxb:fps!7=/6Uq?)>Cf> z31buױfqgL_ctʯe-|ʟ1̛ݹyy{1ܼʣp~`+p9@pbVĽЧ`NZu jZ͗յ@-p^Nu |tjlQ~Z9 :9iu}V狜P ghƀeP> q٩YD-_bh/Pt=h}x9jQ'i':G)d|!Bq\f}]`.-4]aFkkf~ ,WO ~euڡ tIǔ*I0tFQsv}x3 10s@uqaLѯh:fhlO;G4@Ie KSRBKZ*У=* S2]Gt>RG4=PWތwkbVCV֬ -Jjʾ׃F%Mt@+bSL2U6MCwaTH>g>XQvAaS`To 1@^z{V0KY+Q--:5Mە4R[+X*RʠԬ2X6[AB[ud[,F5V h@3gkYCct)%Zz0Zd:+F W_+,(du#}zt9XfLY ԇ8dG*VpI ؇&78l=Lc<\P@:uLjQS{atDsGPiA \8CY瘊1r;^aJΪ{@Am@:u4ukܣJc0֐hN4 ~AN@Ava_[*4HlJ ڢgiݚ(VjM؍$ {fdK hn37̍cIV̍>>'!mm08Z+C9dI3C#cSY43Jek#!¦B7#eN!^Qq*bj*Z|5_P,U ]Qs4aH3&}FQ(f<9kn8H,(0&vkRSe_E?%34#UhoX촯b9X౒(a/!+RLj˫vΩq ^kJz yhM㥊T#|5Pd+L hM/{]ܦtUSRx}trZ &~u_ڀujD>Uoܼg܎E2t?SS`2]g iT:F+\(rLεkV=5?#330hdžgKlűAkQYBl[uA^;JZ3/<zor o8u`]VfPI= Mň<(`6.VI7dF!v&(NYɪcd4-T _hvf<@htJJGehNtU+PS^gkP`Ǻ>Ǻ>/!CU#~֏6:9 #]||h6YK nt f9|!2 m_9i=KȳB|8sqr`s;#UV#@VdnEe>JAMEj΋%hsA[iA!hLс):E|A6 XM.;5{,`%Fn~A5Ӡo94ۂzc[hhӤU:ub ]` s5$P~LjI|(4(0ޢO4se=&(ahA!j`m!TTc!F3aD3Wm)nj ~=a:"b'䁍xT"1#:#\[n*X)~*e>GbUK9hREז C9| 6˲q,+WHqa W,ǭJl/㴏˜z5m*cEu`fl/Qj#M)\*titqP[VMܪYm6DY (`1~\@RS/XQ@1Yנb:b| GAjxHfL85|,dU8"$:P)Fa3 A>-99EA375sS3W4s3f6F2,a 0 a6,܆% Ͼ<>0} Z,Spl ,p!K.di)b!X# :mC+!@Nrf zrs^ ]1r>gp kA@T`sR!Zg)#9B#t-ŒwT2Zn˸zJ2F)FaS EAt X:*P>A{d#(Ge>KjL9RB9T4# ro UX c1 ˔2C9pvgqw渜@.teF,(`ڞÕ G?+r:C3 03 Yvy(e1 if;c^lh9C5dԔKX)ah3UsZ5띖sc~BI}I:~iCXv!50%We%'eh>i"dO: px4y+\C[QEf nRX&nRX&Y j7:sLs`vpښY0p[7cf#0@tqDm1Y0[+9l8nWicXr)yku gnL*7jVX,`jv٩qLm#s>BJ`j-L>ێ$RgR@鰽j19'qFn;t-NR*KM;P)쀼T@-r!PhGi!@)pc&TФ\i q6jVmHMQ'YI5U@"p6 Otb=FT B!PО`^ha2hE}Gt#i TSʝ֫aՑb+0qSf6`kL7k5|!,m8>l[g2:UbDi1= t5U 7@5`[Es6i~.]nSLb>H}T;.^͊h8cG#rBY!Pi W(נ6AJ%k5 Y8<}YGtmMcpO$##pthgQ')-VH"mLTZ5unlI6Tu9-眨B4P^V 9'*;oӴ tT`fi;iQI&v[tE`:k@L!h* B]Nb}y2] ;8VRI@ R0L̤ M |F@ !3^*2z^:T7Me|STƷڶ,"h{=Z-rOǂ's6"|Fψ>#gD3"|Fo&xI:VGQ@)Y̤JI%,x/ėU*J($ R-ЈG'ӛC:R~XRnU\Y:* BN:SK$qXЋz5oмceix.p"PuW`0A@^4"ה'ƨ3 ᜚uc} fcxo"syP_LG.Aоdq f%1XZBhkAAa:g+ ')$1s @` )hfߍ6 X5aBa30 .F=J70}19n54YHF@íƈoj+}o:"M;01&]ZêQ33ͬ99!KCˇMt0aQ/ad9#h\BgۂBh_,9%ZeɊ`\aZ03 b@MܟZѵ@CmtX|!D!ct&h,T)*e:9J1TiA H.8Sca2 U0T$À X)`!P<a( 0 X{)=֤P.+ESm]⥸*X/^ 0pr ͗yXcHw=L5tHJQWk\_00@":h4јfSM4=={PJp܁BSz͖cJ5ܠ`Ça&\:9 FbdvWqGCNulj~X#Ev9g[5%Ҽqռˊh `jR] p*44XdЩ]dU! Ϊ)f1\ڀ' 4WZ E纘BDoS_Qk+K5]{RN10vQ7h*J|s!fHPﴽRU^ިMm5{(-VЧ`|f tZF #hv!BZf>$Mc)Zu]dCsu!Pq*:A:u{X` 3BE(o}>8sYz!XmMZG1MqN&VEndTnaʷ"ň>͍0)FAnRUR~8]X!hJ.Q?J5|Xab9XԠ6A:uj%87H  NY5#Q]a&^e0Xe1[-]K@.wjSEʡWAS7_-3ltS+j"WUVSJhv--M#XPװ٥# *Ԣ%GA#!B# 9&U@ei 3Qv@VaSq1N1ƴP8EjA!h#MV R*Li+ޚ0)BP\]U` Z3X]a4W29 eڿXy}Zg>L;CuH֤>UV̪1CuϬzN Z7ޘm'/^-;6X4tld>̽4^} B)ZLVPhթQAݮ ]o\N[N۷o/\?lGVz@Fzbև1CnrK A#ZZ3㊑pъᬿjAJ5M55Z**4>]B"D3Cxۨ"T2Ql/(QQGN;zCj'eT E]  ٠$1ͅΆ4[uaF!ƣG'@t9R{%Ke vqd6cNVI˳iya#fqn6Bp{!oñs]ػA%" jY{yh{}b^TpS<& Jfwy ~H9w1%dwb%eLqk,+b,1n6Ɯە+ι9=;7,X2wOy=\*-4/ܼ̇)ei<ruSĈ4{(reřZ[U@K,d'oxxDxܽ@$x <"z/ ZZڐirح(`|!?!\#:5rUK5bF>sݾ`0⺴Bcr b=F\O1Ҍ #Q(Bϙy犛d+b;EX:0'5 fA,(cA,(Et0>BОެ J.rXZgXfQ @aAAAᙡy(<3(<3(<3*X@u/(1K8[c%ځ ( \b #uƨCw ͳEF\&4Y"QA A#!@hЬhGVnWftFYBXJEeVfP9j r YY&4A YS#s$DgJ\@F,(>+ B]@uh11PY!Ñ{r=5ڦs)vB|RvM8ObnXh UAŖ>B! #)tMk ]hGv4!0耏 .t#rx&.NCP>XA#P`9/,IcY+g2?@ݪ F:`nO?\rjFQ3i@".V@m #x^3C'm X0G^+thWs0"BmtS)uGVkJG9 }t@Uhۃ(9\ t/ѥGpl;o53صˊffEk̛0eK5$1`R ӉgV֠6/H]AM "z!P9NLF(V #HPnn%܆aDб|-ՄpY5C1[uj*-vB>xD@VZ"0F#͈H)s3en͔27if0`j <Ȗjt>D4X1ML_|t.VhAW!DwA B0t7t i6:Vǽ^mI4Nȵ@ B!ƬF cBKt@ԓH DyAO dHh CBi"q e#i"!U()@DvVmʓ @LR Ҋ0[#Cɜ|iB~J%?_N76q#Fv2P~P&Q$ݐB2zECKoc!tϓ-F |) ̇ZZZZ?HoVIGtTf/Z:e\dVK_dҲiY鋑#NQY@Jt4?rF~9#ndFVKFij|FVKFVKF0F&- dC鋬lLK ،،FtF@1EFVFVFօlO}Ye>eetTfm_p6ٗ5/k_V |_]—mȠ }}}}q}q}OHTB_B_}-}D.e> d> d)@699@loٻ d^d5ȼQP ;l x1RIӽSV^!0+~1SP_ sP۫f-sLOcJ@ }OoUB-Zi ,Hy]tܩ)tft1U|tS\ڀ%L$ZP4u:_9 45)E]vj<(а2zn,F퓂ilBIYᅍ,0nVq/YЕuyA=o]7R[SFVAt㦷ô%juϗɶ3 ߈)a7,AMݸY#Y~DQ7~:~= sNĽnn>=EMXy] iNt5[D]?K nލ-io 3#@Ž@wvm1wx[ݸ[ެqkWGwe]ݑymCuu5+?+M@_V4vEw3Y d|G+S^Щ, |˰Sg[}%9ͣ.і4:ɺ~ĝrd]<wl+봍뙎9t-N^7nVIS[kfA֩4ٖN}ee[ka尿t:+CVCޖuNсVzA^؉uYyuZTNTJu˪Rp䮹PLpzQ'aVnQOֱNֵy|u'+xD#MӨ3^drCweݼa##ꖙh7~7^:#uFu{aeJw =b-qgM6^7/'G >qgP8Jّ}=mE:WP{2-2O[:de\X|7K+(+S2#b' --v9䧠Z/ˑ'3q)BwdΈ2s2Y/5'm+?Aɏ`e,N&+J֍-oLVHN&'*Gu-tLV N%9ݲn7xT-ved[Fdd[nIP6=-iEr`Sɶؕ>'JF,bWNVn-a|xK>L(Un-7AOvLv<*Y'nvE&J sЙr2dt*Y7,ltnt:ZfO6j}ON6VUؖu}ĉɁui}ecddޒ.d:"rm \Pt29@d]̖0-lI$Nm[ȉ +mmziˉh+LT:ٖt_(J'Jn +iߙ4p- *?ɶ|m s%]:ENt*R䤕A[%bb ;VuP+KΰuYNԖ4L~T '+b۾۾jKnŨ^gu +Y_ݭɶON֭l-ݒL[tۙl閷pKnG[=*@$Iv'B}$+ 9Rfnߢ;Vɶk.Uax/D]ٞzqLN&'L]+夋rnc1Id[s(դ2~qdc&n \q24cvyB=[AwW6;=!PɾJGB*Aľc+tO q/G.)nETh?H܊ GEDB 7xuR ^,L(O 4[l>1" ߈pÏ|)V%Λ_':A@X =Q\$A Ty! o;@i!yL(@!VRi񡌎x"r2 _|^F7YN D>5V@Zc%''DEHX&poa܈O"!P=0_f x%٪O0҄֗n"}m}?&DA@R .k?ʐX()&"bmJ+"1nDv (Iٜ^$Dpx1O@/P d t MQ 2 mk1V9+V;hVja}'ƬҶi`#Sw1';mc:hi%"f|2.HSQR t4 qb!ٰvXz3XV#x= 7/LH<06(⎚dSPe=!`a}KmFa0w.E1+Y "FWTeuY@"\z X8yJd|2DcD;%0q+0"」5V )[<=h܋xb R r dFZ_vU}] .N>6  =KJȀl%@D.2rA$Y1uXXXrLoc}@xJ bHF G' Vxdzʓᨎ&A7҄//xn܅SU "`xK-DH+D2 yX DHchV(io[N 𔈋,nLd W2)Osoc!&!XlDvz\+i]a J Lzv`Zd'` ;2Y dKӠR !P "&ie'1] >6ŵ-F-KZ4 @0,@/k< f;Mq{cku;V` H0ˀ]"u9@8HGC-p4ꉀE2 ch`BJ"tyl+Hih,E4!tD>UO <%" J+V~, [ @ ba%6=F "A$M=a")1G_.+"/܈E!71O( r{kQ'Z|OۺB[E+_:W|db!VpCutBeQ[~ cX6&o| YB['D<9D„B +u`@ N`Dt A($QXzIpzRK?8>j |-I% !J(m{R vEF2q(GJq{'_ +V0b 1„/K"=bjlVRJp4%=}>v@Ŝn-k,+Vۣǚ+x"Ns nB,<[ >6nGatQT TlhYfC6ӛ1+LL{+cXQϯbMkՔ&JO0]>k-=[| yU ܅<[`6XBuF>E޶t4A6EF'դiFh.a).(KRn.dpϣ\`%')*ᅸ_尠4%R-r`4A`‹V}8#@g:fXխs{c=ROy˪St|,°j ZY4F9uu~A)Kx&rjJakL^⪐ Eb B-zF"0yj9`*9 z,ܚT*t&=o[.7%2B|) gӂDžP۵}Vx认+-0 K,˰i؇4CLÂsɐ|>g,0kl5~R,d,!K1xyb  2"M  f{9C֢\0d9xEդiFOW}x<\s7uJ[kPwVUk5xϩ}PCn{5UUYQop"mz!_Sb7$OMٺ@FEFfV刔t:=l7ɷ,@148x&jWYoA,(@'8Jq0SFRi )ݎہU tqD$FB~q$5183tn?. F0>RԊ@+wmT}9`|j @֤iFT!B"- -kY0nM)/Z[W*`#[=m;B/IM+oV0nop bOoP8.DvV d}]0 v77(5SFc>Xc x؇pilZ熄TL}<Ԍ #Q(b3/bExƀ#s7eIYXS֔.1W2ʀ0mٽTՐY2#7aDEʈ^F}JWDC+hr!XN Rgaޟ|~$+o[9MYkb!96 BO8Wh=F )eze )fOL/0/)5D!b:+U<%|Â1qѹ '747 ][ĻP3ӌ x`6}FHϠVq(tGp?fdq{#Q .İ烋`e0X,)FlcfoPS4#è]hJG`֯FVд>kS C%_9P9)FTGTs;0cB!@C` "e6[Q`aU_fK̠[Xb(gPQ+X*oذԇǶy@KE F0kb544RT A#@ %DPf;H3N@I"Jjn#ň4[ݸ݂#{l/vDEth6  8IF7r(a: I%c 4/&yڠ7d)Y_P bk"'9yk72MnPlV Gț3q֣@ m[w1L/&#;[Kg8U,o>dؚ]#r 262mJHͬ6Q@?\X$qdvY, [hn}1n-ҷNy0/můhmvmؼ_Y~&Q<B$PGs QG 5pQO h$Kڢݶ% 2B١KQԾMpLlwo&Qc?]%yqn&m6[ ln&1PQ'ly{AXכrkS 5d#&C2Xi;߲ͫ|Rv4F?C5h<їDYZW QP,+Az9'>^G<~i5Ә8\ޱBA( i kVB7!Ԅΰ۠X8N4 |9KذeYFow Mm0,f4g݃jz  }(N4* a=rď'28ePej,(Z}7ςىqL;'ʞ;8=l'3;WV=3GAT$^r{wu_TƯ}IC튣Wf.Nl){O~?ta={9?GMm{CMWad139!k3>dBaؼBlt%ۋg}E.msLx_g,$cxbis Z5紿MF]3IɑP':;aY-xa^/k5 v^ mj:q-8Ww\)фay ?ĥE2NbPpWRՆNpsKvYEP5F?jCCC٭﨩UjąE7ZwT%IH #(U@`C*C*ʅ[})bբ_IB{GU*ճjN͂7]-X]NRVs_bQ*:O(WR3JiuDQujE\dV Phm*SVQҵ6lXÆ>l}|jVfOzUϵV-֪ZXkrU*5t -~l1+ŨX($W-Vja:T' t½RWJVTmj;MZmSTG:j8^t ۠1rPT>K)\."<-w EZBOЈKBP QB]O)4AiO ڧDv"A;HN$h'k5t?~tO~Pʹ# ڑHv$A{ c.}RjXi*V-$Ӯ"hWkUC;AX/(֊\oIV(8黹WE'Q24>j'kD1RݵhF"n9 r$YFI{st\.,< 4R@G'vQ}L>Jz<@mRaAtn~P,+EIBBB"VA EP FHO?*ڹZ]еkuX$v=v=tZYʞ] <ty.B$VŴo*o*o廄\Z_еk}ͧư(׋I] vLt%0?1j?Uh?rA.ʅBBg8p ککک:)uSj/Uj/U9LsYYKXRRRRRRv!v!K:)))u_ꤤfffffffffffffffff CRRRRRRRReT / /uvQj^j^dF z z z zYʐ,?UTjX/UYrUj^j^j^j^j^j^j^j^j^j^j^j^j^j^j^j^j^j^j^j^i^i^Um|%;ldJ͢[2A2]W\AZtA*ʋ戅¾v'u 8F`%Gsd-%zV\)rP'I{$,W!R!Q/$"ha\KEPJu+ :-GzaYh5"kv˺H '<9YBbT,+ VzR_>RJ r-(s((ߙFgEEEEC-%T)d]<~J y *! _V2*`UBu-[b%; Ok2*dhUЪ Il,|!g c҃$~~! 95_HM %Ůàvd*kJc Io lwAĿХSE!F$Ja{DK )Rv-KSHjԧRjB)+n[)VJOIR._)ϵՉ$*iu*i+i+IJRVֹJZJj-ëSSQkSFVZ&6j-mE+L$Ax  Rb 6[_$ʵL+͂ ͋K\N?T1+./͂ۅ"R-> ǁ]`X|ɝ# ?o%.~9b$|@O+ܟpދ]kc&?wfHk˷_efhOd&dD4Fp=OuHɿN+$^W^^B J: >A}2v Q< 1Q]%(E-F&Rb)A etLPmZn(tpjD7'9M iI^I—2;[tsCd0ǫuf u5BA(KGW di4 ЖK ˈ'tv[˗`%p㑋 {GӰp@25É#O|#gqKY a#kzEp!=FIFD=! ,]0o*#F#Wm-=q}:A>C*f*Hy_z{?/, .l+ca3ꎨPLWXAS 7hq" 8'A%KϖIIo=P`^{Z~Iۋ֥ } ݭDBIwߴ9l=M6P5טu8뽶yYx2:Zݒ |<\7sܽ+HBRm޷7!}![Ox@L#t _£AFwf0IL #;6(ؠ RУvt_Wei;' O ݯgi#?&%C%.+q&lb!-aGp<É4(F[_eגNJ:Yd26 c~E\k8u:C'CwW4"=lx?xc;a>N`kt:O.{Yؔy! Gk&^L*@H|M0/$s`<ۚH2i4NeGWs3ǝ/e'$(l/9&Bٟ^݇pg90#R~ٜlZ/s7\myrWFk 'rBșKy0[\C y  NYjLN-ݰ!f+'bgc d`@ 1wCDzW#GspoH7Tȷ\‚#Zv׶rsedw&G呋 ?$yl}sK~<`Dj|9s&C] bRJ%o#64,f^0m3W:# Ɇ %^#w{4l09B$L |zA/xA'1bOc7/|4Vp9ťnVG@PzD#S#QPHݛޟu /klK[nQY۝y _.sH>^l/Ɂe@WGˀfpO6}ٱ=+.LY9IFB֢N|(:ja8#L&N_$jɫZҩV$jIzMj$y=4c`UAnuu' &YIek#mm-㶱R 'Iش˶mWe>"ssۉK9Ï p2O` l`$`[2]r\AFtOnOT>/ +rU[-OO_WhZC}`_N脼P+f?:ŅBpnvoC߭l8ml+5fD&Od'Y'BVfv[K$7ͤf{kP(nfR䥞=~P- OD(nwJv<;<\vgV-oY}[?-?;=%ԣdR3/d%!;_.4m۱"=peH㣝 - ZK2 `Y]&5B̝Ų;k68"7d/+!5BQ/$k8[yyi)["CEc-ZtN\^ C$Pf^(EBy K 3kNK` '7o>Hf@hM!Og!5sB^cܔjtbM(%"x9[ymwyk*O鏃!e: #r 6sjߠ b\lY dպkc>xBv;!%K|[wM0t+ #r Ðz 8¾\͠V[~L  WTk l͵$ ֥bU:y5o hkWWz' !G1IfkMmoȈRn֚\ovnz뷘uu̅SAru5ՒyQ$HYdpn ;KG3uVLv;*{ӳ .@LP: l_&\0xNW 3Rkmt^:@66FՐmJbǼ葯=]OmP g౞؍wvh렺7wM|3#DBacIg436Eg@8"مb]MkS/=i`47m|lc{ߴUY~:t{ [TH5UƟ=Aom_m*ˍ h놁uז=zheu؝J"(̩p͹&ҟ_=" a'yGTL vX$`2REjv~5f>AzRY~wEe2m$ȓ]fp[hYAdoMV28'`; ;Z›~Ep(ku_2Iܛ8/]/u\):E 庵g)߳,$l5 6vQl&lh8mX9ZH6=B8Έ@ٮn} BQ7\& ^K{ yP%&$pAbGl _Bl7I7; 8 !6BHJA% 1 (c&MBˁo%I/%äv43HumIChim>1AlfK7\PўQzUx'Ѝ}E kmXzE0Y!sG.fQ^I{kp+jDNlNkU{RޱX⬆f͎tgzp$n_\m̜wL,0gzw.RGV&R3qZ"bJA (&̪5ӽ1ިofwZG@& Ff䄼PB2F,"Pg-:Ҋ(a,V $vVB @wTC^(E! a g0/qM~1}+PjJR-6kYGW[%s'f;1ۋ^̎bv~ BI:8NRI*9I'$%Vmݶ"ė)Bt/bElJ9I3wQw"ҋ; bQBA~Q1"(e|}JĆ=n$Xn$Hټj6ЄD)-,ENJc*lB,+[/"OQJA|%Mj=r9./b80؂F3{Dt!SUlkc#6UTa$W**WQjԮ8#ثa4@ŹZvzʢU k[3r뽘Y\ެY׿`QLlY6nt 毸9ra2h3s]x|j7?^-&#oybF'䅢P!T UBqC3'M԰Z}̀t`"gbIù7 v!v^teg~b}n ߠ%y##xxC,l+#gdO-M ,gդR+:IY!pSaֶ~f}7\̒{7ۭمx&pOlO液g&sQ yg!5sB^&a. j؉n6[6_}{G&G?|db/a$]D;4nLOhjLg6Ñad\ZyٴZ V]?yBkiOζGl.\dguG @77$}m6"4'H7CI]OZhg-Dkd"h@P*nLQJߢn%IFH>x"d G`\)O&R3'P:Mnên00oBM@Q,`dk7nD7'`~& 5<&lUt7k$tl[T XheC2Q#oƾH2['w2M t|,K}j+Mk|Tow]:(T UBk3$TI';8]gŅST$5 Bv:i"I$]3Q5~-ƫ^-LW QP,Gh'&V%jIZ$%jIZlo'yKsbT,KJQתFjԪFjԪƜvU'ƍzݨ|BtͶU>Җ u~{~' e6G6 r]qsLUpojV \Т^62KjpqEA!vrB^zj̙tjvM ^} !" 0atȲuNjLv~}J't&x iѪ})"*\[5OچޝZ|"ֵdFgr1 H5/@7&AL[h- m+_o%}hRd:m5! 2!Z% RYWl5dhP wɚcֱAbF{ۃ䄼Bh*[ fێuȶɫ!v`q"qhm@LoϭX+=2~S$T5m.#ȿnL-N [O5ٷN,Pa{: 8܇gيblk$`ack_w[qL4(- GLО ݻ 6_ #f_pqm[Wݮ#!"݋, ',v/'gȖ |0f]({6;ȲEe38B MG7`K Z j}!DX;ߨWX,=ߒ|uwt^ive&' e'{ EmNf7{#L24M:EhQ>lns!,:ɶߟdnptH,* tgt'כ!r0=ըB:W1MKdo=*B/f2Mmf3Oh809* `5Xcp \ؙd\+!K=.nu$א;{/3 +/=ߐoX p|"'dMKƿmkŽo'BОⶊ  DuǓMl +4el5ಏD/ttw0NqKP߱VleQ?, ?1z]{IQdc)8;ݼ|A2Nɿ 01x^SD{ <-#o\<R6r>OD='%'I(m/-9%jȲc.Nr ϗGͳ"K. Nu< ipV\X(eANN*nm>ыaP4 'h8Q*I'rbD#G`4j*kOJ*_upxZS' B }ÅWhmKk{sɁ&L ũIɤfN-e]9Byi@s'{7[:O0A1*G 񎝆\/Pit@WT4kǽ4ZةuV.u֮pǹeB/9;btĢى(OG%@@,ɘXsr O/i~hK]\ٲ\YБ0:}2z8q39!;ޝJw2eR3/H]-$ {^r繱9usd>om0^;ϵgTb-λ g"18c qF&'`/lf$fLeBA 5Q-1.'+0ɉ=P}[``3֔8XK$LAԾb%'1+~wB䄼PBP)d.m\tKk+nni9]kkyIN0aqa{ż/%u^h+ y=_nJAK[hz'6ስ =|ٖniNj( 3 _jFڒ'8ũ/;A(2ϼW E$t&y(z(z(=U{ K(:5ΫoO>~XZK/T 4_X-R>ړ"9RX0b]WtRΚkaIn.i՚LQq!ԄaO8P&_WX\_?J 'A^lz6Qy^F8ɒ[ ѧ(Gk?p~1|V)nbi:+֎#G7wuMcZVR/~&vօt,IO<{x55bc e_YkcJTI`YdR3/d}m pB3+߲| VqS#P$itl![O ;?ux3'BO&K3| jBKv=@B ΄ `ڡTB.wG'IƄX}pF/ 9, a\9.Džba^RR(.6LFhX(CX귏(y8x|*nw{$9J!M׵fytRV]C}qSӹlxF zΫw>4 Q}zTMjK y; ̈́ zF$8! "}(v]AB4)ߒvbF6Iv+U/xV~o;_Fl`o,z 5zK`*!n~aqłW ^B]P9ubT,KJq4ƌ);Hdr fj}c y   $T$[ 7t$`7C~{:bgB3$îg-vo\o83W{}?\q͞_ddǑM ?HEY#bV:LО_vO$3 Z ; kA8{׿`?pմ=ᖰ'G/Dk nt3=xe-|zX'|: 2]zlm秌i( BIV;ǎ)U+zkD==^^P/d]h {8ʥ+#æ-pS›jn3;, xjX]&fx(C| G;ێ Tr੫f<9!q2=x'EE1*a G_bfVMA'p/{|$},?m~1Ч1K9(G=P-DْlIm0#9 ۯ~n~L ߒ + ;yN'TТ9q =k{aBqP!T Ui'Q4$Pg$ $~F3ڱb `b Dۧ4=wkyrH2ai0`tuwN 82ܰ! C3`lgqA}\@.!W?n8 w^VdxaI $T 3< Q:ԡ5uCMja hh@qF|L:4ԡ-cJlە9!/Z2]ZFӏ?&x0&T˄jP[&ԖlŖZf/@4x>-;8<ɲ\F;1 i9nG2``8rkN#tyvl#Ov&XHn}ۛFgrB^DLV<}OM?0O{`IK ֯6+h83JJrezyy05?;0va䄐]ln>7mXMh/<1v~Y)9!/*z=oINt B$`=AMhml:-aG/3Cd%"0^[G#cԳjl\ta ‡q?ےB] #m_w_Wb@!+$S{7%,'oV},@=,6f}hwGټc(Po\dYĭbݬxz9A0K%Q7,i7h {{l-;>Ͻ:R~MzkhHg.6s.e>k暘ؗ\U<^"J/܌ 3zh`=P`FN?"cO?~CX#xB Pք 5VHQG}iL>! jH޼:o *D3Sr^[kk a>t|YNȋUBh 0poS|4fC@ ӭ;:v@;vyξj)zŏ2;jM?E:&dC@o³\Cޛ}eBmfجb NР6l烸1B>BÊrCΦ͂#[}l;5^1@8=8\X ԔM`dDasBꅂP*JJhm%ʼnP?_ɖ ~$67G,?vϜ  BIl(^ZMjpDN*K2|oj;I7v8Ͽ78/ 8;80T8,wbs:w/<f|]$C`9F"@@\@k $@- X7ڤ|_ah1=->q- mvB0g/Msw"ա< #qz,qNy -x?X4bbIac!5-ViM%-B=aPF7~EpXcڼ+_Ia1xd68!=-b)bOv$LUF^m|9I$ۍdY"ĥÀa-0X`-k،ɗ>[ŝ`dp?p-8^1(FnST"iBUpi1(5jQW\Wz5%9 B΢ eRyrL]G Wۈ6&뾝C$3T\+Vl45d,_l$>r_'?cRg6u>pIA.6 %9<ïio-^: 5ݺS5HV_f)._g:\`~`>~Z&i"O\ܕa G?5 ëukՏ-~۹wKIWX^HŪ݈gx ;vIw=J2.B̾{Gc;B)IjxW$$ n n0ܗ2Z#zrB dhvgT1&kn1ґy NIr#՛ip/{jwfw;nI>XH2LԉYfա@ƬE޾@ZZ*08dkۯ mmϯ sLԘӮ}).\ŨXPBt 2u0{4T 5$/6lDG4չ Z_$Ђ_1bY):-V)P88X%'x4b̽=P(N+;A\ogg'gWH= %ofa&Vh+ړ$ ! !Ag? 1+L+$A &kj4 6N:i߭qޓ6r H7d+vlUV[wfpg P[xw…W (-=KpՏ~^Ɇ[~.9,8.XprШ^\/u:KEKEEEE{?x'!킷K^][-7.L|y;j/K8\5i{Ծ G`:c:b,'B$P ϛf^ǛП EpoM@#:őXuQ ^IdRz; d[Z $ DNȃ65q&G=;- ZjBCh n( x?JfBBCc$XO.`yg6p*Er%`t6Cۛ:IFۑ$ʆ'L5ɉWjHAA+ vPAMc&'" }$S6%;dk/x,>yȜ }A=(sE6&R/&wsk |:0/;`EC|lp؃NFkDvvcp8L^(EBPĐI+ܫU$Y NTNĿSa>T?7)$c7#X/plܟ2>yKsw.; ?*bְJ⳽L񅲃l#$HJhey#WV2}g} 29Zl {#'20${a(C$bOpJx' G6x/8yXSdq[zu<2ޜ'z) $ch˜$Z=/xi\,\G@ BaP-rQ[X+5 DžbX)9ms9NVŅE-?x.w uB]P-u uB]P-u u~_~_ߜxn/ B?,KaT#+y~p9z CvnǞ'v^1PbST\(S*VRguڳ:YN{V=ig鴳t;:ziU?L-Apa儼Mb Rbng)gY:`:`:`:`:`Ryyy]Kt){)%VjVjQmմ][eVcUk~4-jիzW R 3m}^^['k++əWj)zŅQP,+E;kUsPsCn~Aw^qa9*bh˨ eؠsZSA[YAۖmKKAi my7L)y8c# 5o?g3^&HΦnz&SE@l_Vk m;WqJ5IO漇6#ۄdBr/j]Y5cX3:|d7@< jSԾ9ۻY LP2K^y(bqgxB X1 `%Ug(&^%'$!`P& o>{-Q4w S QP,+ŵ UFM*٨S+ډýwb de>WLjvtʓ,Ç-&.Ԛ Bj"=@k$J^/Z˵G8ѳ"cz͂o;|kոXX/KJq-4NSũ+ŨX(VNr 6j5^c5~Vc5"}Q/QE=Pɯ%RIHTHTXx4[4[fKTjUZE*VQUԔ͂5e0m$5BcXh a1,4ưX1,4 MY[> n.x݂ʫ͂-ZrnujhEVjBP&T U.JsvCVճjUiWA`ەxpɫTvEXp\8K傫2HDj2?|////ŧ_O9?/矊?>9>r>/?}9>s|,CS JLTb§O,uP\2? e(~.CsP\2? e(~.CsP\2? e(~*CsVů?9> >'|Ox9>aYW:?չOu.~sŧ:W|s:W|s:W|s:W|s:W|s:W|s:W|s:W|s:W|s:W|s:W|s\e\|*ŧQ|*ŧQ̥cбլ1bVa ^\\pn7 ^DP\^-\WЪF/Rk9(.LeLUVWZbTUVWZ]Ehue:n`.^K__ kb]^/vxKX%,+mиE\".!B*u^x(uAKɨ->o~D .H DbbfW\dW\Xi_`&.J}bJ*EmYVW)BVZ[ҥf.RPB A[.V%KUR +URmJV~`MJTJUT- Ph+{ku9'jXFzQO֚7kM}xCKb/r*?㞑mb)4[.x&K j[D p`$JT&E͖# v}e42RqO\z+}~wfk +7xu[=^YW+xeZaZ{Q1bd9B. G2,TgKVkC|Mvm^1V;ۑMAn䅂u]bX"Ȁ܄tǃě@=  xRgjymhLEIm tB[qS. t^1(Fįo`7'*{y"`BgObX)qaa>bTQ..BV ź+߯`=E P :;1Bygۦf"KGW=>T95kZNu V H)M @(<wmfR3T Poks7"ƚ= BM"'ðՑnrc-[)~ #Z؞okܓ޷Qd"N6&τ-Vd9۩foų>~o`kCONh z?[_ k@IQJkNХ%p(0g`px0\^x2O?xB Dn>BjL! BIHlQǕ2,M:$b&??ewJZ;ؓAwl/7 nQ![dƣGUJn,a  .d p} B \B%ٞLD.,?6~O&t^1(FE R0r/َKK-6qKNW|8!8pZ„N+ŨhMʸ#qqpGNF؜ܔa^a-V*Lk#DdAB% BP%FlFFmdfٗL5-D+Cz~4nco[2RoDU/d딣mGG#o<P(NfȞUiՖ%ŻP-Й ՉFkhd%2/$gLB3nO ׳s=c gsẂNuJulķJT*k7B5-<+P%/A W6 2rdOt^rcxcOG\qM4 NŪ:p{{G>O6|}JΆ@`(E25d&߶tp&u}acv{oD#Gro.0@Q ebIsvw;E~$sflx]PB.L{k/e,a䄼P0ʀO¿M?]Z? &p*?/s@]|Cg +wv +뿳֗O,# <: 'EBA(At>FHTI3#r !?,?J(}(ƍ1#xB$01qy{ 4=e:#@E{q:C/@7s%ܸW,`SjZ;eK#xB$l5!AJ%Rtgq zO]A% *kXW7{}oSM .NYy>ĥ@z]^"8@K= F#Tۥ!}[#}l 5_B$ê_ =+zŠX(J 'xb^1xǵJ)Ov{U㊇Q z\htJJf0Ln?sPfFnVṽsw<bPb55;@=rZW-jTKZM\+֢UiJyMw+~Lvi uNE fƺhj+$ɒlB7س|v%f%n^4Vkr>~/ X a }vPLUcYշI8뙛ye}Oч `K[]  R"DAԬεPB1 V*=Ⱥk< -[0kv2R)VBT],clY -hlK~]u$[d)fxVsaHpc``xOxFpCGo-F-FYH,zB$ eޙ5#x¼0n6,ۦ7M /Xݶ:·_l˸"8'h"C'-9'dv.?Դ/91V lN%Э~HGEu5`֓`%7#eČisC˰={y!蝳739BaJ U56GF+L_YqZjl p[6Epv[5d;,`v|E h2\ygoUΚ6u&c3:'ϣf@[ y qJdww=_7M{,( GdU쯶pL?v"b<`Dt] (VP>t1WaMkBj[;þn,MeG#=m8t{thy0dzăxB$.`G$CoXbzk`{~lrq<%+n~GE[N3#,`ؘу,[F)ɒ]rB)JF t>z~xcZ5D$t#TbA&&¶@fL[- COoa Ew,!. xǕrPH8`_[F,+ER];>_[ z1NɄ*cwM谅Z; !jڹbYLUq.5Of.{z͂o{^Sk<#h<&hp4ܠg7=P;h [\{|g~UGM 5g X\!yjZjr@Q+TBo)nETYY.jW]BjaZX׆&HWZ+ݳ@Y*,\^ƤUi-oZ;>[j \k \/JݿZ֚Et׋Vו^d JHYK_z~i?鞽bPbX)Jr;JX9}N>i;Z9J;Bs͂%mkP^Үikr59 =ӞiO崧rAҞiO傪 FթOQ}-$Q:x/4JjM&wXmծD;~sN|в7aQ}.8?KNDMO0L$RuuU?ݶꛨ#>2…okE):ERH,Dע:P:dAZL%TM%)REITR¬WB!iZ4_K[K% ֒kVa_:f K\tcY;_[G,=̫߳uBa>"el]ۏMƟ?ϙ~-/Jf*hO RY<8-QƚvMnI?rg g1֝n(jY~j˥1#[_RXe9bmgB w[>?OCs9tfCY.~X-X-pK~i۬CXpjo\+#RWɝR\qe;U{8(FEkZ3!5ю Jl\^eXgbX<T_l;c\49M2 6F:\j۪|0 Bv= -]nO^2uFW,'g&:XġPJEdv|Ij̽ډ j ^Z+k'hԤge?[![q5$I~(qDGutG+QIfWhr;4ݙ2:#ξ[%c!_Fc]n>,;5vZqҢ?&7ȐŚ51ڝnUC#/:LdOEy\i9$^Q6eQ槝 ^痾M`>VC/}s8՟ la,s<= H(63LR?2' M^]=qz\ď:{;>/xiԹScgS/A1o؁xp+5}{1yk'-?[7L4H;1 biȳ&痱RfbG쏵#XOG2PB6H( cULBwбDTEUUE/xQe^0L| le;Q-D ݞ~Ph N$20rhb|ܓىߨDg1BA( BP%krB9]~J1**:QY/ yζzX{OmxFQ9fG∫ ^qDibdO:_WQX0\ۃjedY#Ԃ식Y[ri] 6FcsQ ?`߃$Xcw&X[:b6^luUu /[k!__;([w;t ,݋@ڀΖhhz<`Pk7_TG&S&Ѽv3 eFnoy8׬Vtk }78J#펧dpm!{6]:(nϰ?l|lz1qOH([2=)zŠկbWXQ 5ҁtLtpbQwPhD 5`_@eAIqXTKS{ό TSyz| * T P@H"+RM+0{0w}_^kl1߈KET# rzⱣl\,~Vh=fﯾY[doQsGq %am.v؃m3oKd6 "j9rgv&,ã,snQ67hpco%Y< INrKPmOa^kU-.P8_9hbY?c&ɿwM0v=L>6ɖdzoivM<]왒o!oY[ ԌŔ,_h GmhKAu ӹnwv,#|ԏ d -<KML M< ذ8C D)+Nl&6AyS4!iE3 8dgN8οl0rA-g%mԫIE5Mlw5JKy;k;jgyyv>-Y`ۣٳ$~U6eeoۏQ{G?&jov fBP+43y<пp9Q6U/y/n*moގh&yg_o/q9B. +k7*Ouϒnݥ/)vK\BM!>B>Pv7_dV`0\=hT;f9_nMDx{\)ۍ->hN:O g dH(^I_A컷-qܽ۞a.t_`9Nvjfᦾ&l {0w;8D+,`?0ʿly˟͋ͣ*Wy蟺w9v0O'05PXP"19Bbq%|W_vB4W3ҾZ3q$a HA'HQ,bA6'R%6n؉lqiܡ/X+Z ?"Dt-Vl[ (4OC2yB tdTbEl;:?M94L+Ņe RJRF-R(TBݦGc~+Y3i@bT,KJq-JivUG:"2z!5BP)4!?Ȧ%?'=˜0wS3{nc|{Zz ϲt#\;؎kO(i/;8 zAk"p6vd+N+Ezhk Š@k ^&k4/]੹'c:3(H R傌+ Ԋ Jj)ݤ 5$H i$M&tAX5hX5 _$. (IWO ؔzC!YYC!(H2 R]A"T2 ւ zԽ u/H݋2ҍ2;ҋŸBdBZDQĸx;\-^(IXTmW(C((>J2< DT(U=JR(u6JRgOZx T%tQQFQFQ8?vNVVDi+tQXhx̜5&Dipb)I2@2@(VJIKee2l:l6lx*{xnBQNڱ(XEE6.J[3BZBXXLgSZBZBBB)4_ L i \2/dRHSVMٿgHBBBBF$҄҄҄҄2(A+ + +*dB_HUHUDN@s=6j#v$`i~ i~ s,   s3AirQ00000002*d_UCM/N -MBbn\zJ\x*]'^(Ui֊^|*JJ&e\(.-])m[)SRZRZIJ9Y{-y*y*zʜ/eU$V),KG]V)Q)C2nZ'^@6M)IY/X!#-Z"))5(5BږXrdWZRZRZRZR&e _JiQJiQJiQ9+-r$V"-f5*&؍B)dgJ]U؉GAZ,4V2Vp($SVK!&k%ʳŨ?WR+,HɩdR( jS W(6UdR`F5W)RS:JJnŪlY?SQH"p?;¶f~L`v> y!;DL 'F/xe*t+EG?vAv+Glu'WOJ>Hc>~q2K'#&zVmv b%^;1tS²W\ yFюO䄼PB5ysx]̭@!.} #include #include #include #include using namespace ModularityOptimizer; using namespace std::chrono; JavaRandom::JavaRandom(uint64_t seed) { setSeed(seed); } void JavaRandom::setSeed(uint64_t seed) { this->seed = (seed ^ uint64_t(0x5DEECE66D)) & ((uint64_t(1) << 48) - 1); } int JavaRandom::next(int bits) { // Only 31 bits ever used. seed = (seed * uint64_t(0x5DEECE66D) + uint64_t(0xB)) & ((uint64_t(1) << 48) - 1); return static_cast(seed >> (48 - bits)); } int JavaRandom::nextInt(int n) { if (n <= 0) throw std::out_of_range("n must be positive"); if ((n & -n) == n) // i.e., n is a power of 2 return static_cast((static_cast(n) * static_cast(next(31))) >> 31); int bits, val; do { bits = next(31); val = bits % n; } while (bits - val + (n - 1) < 0); return val; } IVector Arrays2::generateRandomPermutation(int nElements, JavaRandom& random) { IVector permutation(nElements, 0); for (int i = 0; i < nElements; i++) permutation[i] = i; for (int i = 0; i < nElements; i++) { int j = random.nextInt(nElements); int k = permutation[i]; permutation[i] = permutation[j]; permutation[j] = k; } return permutation; } Clustering::Clustering(int nNodes): nNodes(nNodes), nClusters(1), cluster(nNodes) {}; Clustering::Clustering(IVector cluster) : nNodes(cluster.size()), cluster(cluster.cbegin(), cluster.cend()) { nClusters = *std::max_element(cluster.cbegin(), cluster.cend()) + 1; } IVector Clustering::getNNodesPerCluster() const { IVector nNodesPerCluster(nClusters, 0); for(const int& clust: cluster) { nNodesPerCluster.at(clust)++; } return nNodesPerCluster; } std::vector Clustering::getNodesPerCluster() const { std::vector nodePerCluster(nClusters); IVector nNodesPerCluster = getNNodesPerCluster(); for(int i =0; i < nClusters; i++) { const int cnt = nNodesPerCluster.at(i); nodePerCluster.at(i).reserve(cnt); } for(int i=0; i< nNodes; i++) { nodePerCluster.at(cluster.at(i)).push_back(i); } return nodePerCluster; } void Clustering::setCluster(int node, int cluster) { this->cluster.at(node) = cluster; nClusters = std::max(nClusters, cluster+1); } void Clustering::initSingletonClusters() { for(int i=0; i < nNodes; i++) { cluster.at(i) = i; } nClusters = nNodes; } void Clustering::orderClustersByNNodes() { typedef std::pair ipair; // holds numNodes, cluster std::vector clusterNNodes; clusterNNodes.reserve(nClusters); IVector nNodesPerCluster = getNNodesPerCluster(); for(int i=0; i&a, const std::pair& b) { return b.first < a.first; }); //std::greater()); // now make a map from old to new names IVector newCluster(nClusters, 0); int i=0; do { newCluster[clusterNNodes[i].second] = i; i++; } while (i < nClusters && clusterNNodes[i].first > 0); nClusters = i; for(int i=0; icbegin(), edgeWeight->cend(), this->edgeWeight.begin()); if (nodeWeight != nullptr) { std::copy(nodeWeight->cbegin(), nodeWeight->cend(), this->nodeWeight.begin()); } else { this->nodeWeight = getTotalEdgeWeightPerNode(); } } Network::Network(int nNodes, DVector* nodeWeight, std::vector& edge, DVector* edgeWeight) : nNodes(nNodes), nEdges(0), nodeWeight(), firstNeighborIndex(nNodes + 1, 0), neighbor(), edgeWeight(), totalEdgeWeightSelfLinks(0) { if(edge.size() != 2 || edge[0].size() != edge[1].size()) { throw std::length_error("Edge was supposed to be an array with 2 columns of equal size."); } IVector neighbor(edge.at(0).size(), 0); DVector edgeWeight2(edge.at(0).size(), 0.0); int i = 1; for (size_t j = 0; j < edge[0].size(); j++) if (edge[0][j] != edge[1][j]) { if (edge[0][j] >= i) for (; i <= edge[0][j]; i++) firstNeighborIndex.at(i) = nEdges; neighbor[nEdges] = edge[1][j]; edgeWeight2[nEdges] = (edgeWeight != nullptr) ? (*edgeWeight)[j] : 1.0; nEdges++; } else totalEdgeWeightSelfLinks += (edgeWeight != nullptr) ? (*edgeWeight)[j] : 1; for (; i <= nNodes; i++) firstNeighborIndex.at(i) = nEdges; this->neighbor.resize(nEdges); std::copy(neighbor.begin(), neighbor.begin() + nEdges, this->neighbor.begin()); this->edgeWeight.resize(nEdges); std::copy(edgeWeight2.begin(), edgeWeight2.begin() + nEdges, this->edgeWeight.begin()); if(nodeWeight == nullptr) { this->nodeWeight = getTotalEdgeWeightPerNode(); } else { this->nodeWeight = *nodeWeight; } } double Network::getTotalNodeWeight() { return std::accumulate(nodeWeight.cbegin(), nodeWeight.cend(), 0.0); } DVector Network::getNodeWeights() { return nodeWeight; } IVector Network::getNEdgesPerNode() { IVector nEdgesPerNode(nNodes, 0); for(int i=0; i< nNodes; i++) { nEdgesPerNode.at(i) = firstNeighborIndex.at(i + 1) - firstNeighborIndex.at(i); } return nEdgesPerNode; } std::vector Network::getEdges() { std::vector edge(2); edge[0].resize(nEdges); for(int i=0; i < nNodes; i++) { std::fill(edge[0].begin() + firstNeighborIndex.at(i), edge[0].begin() + firstNeighborIndex.at(i + 1), i); } edge.at(1) = neighbor; return edge; } IVector Network::getEdges(int node) { return IVector(neighbor.begin() + firstNeighborIndex.at(node), neighbor.begin() + firstNeighborIndex.at(node + 1)); } std::vector Network::getEdgesPerNode() { std::vector edgePerNode(nNodes); for (int i = 0; i < nNodes; i++) { edgePerNode[i] = IVector(neighbor.begin() + firstNeighborIndex.at(i), neighbor.begin() + firstNeighborIndex.at(i + 1)); } return edgePerNode; } double Network::getTotalEdgeWeight() { return std::accumulate(edgeWeight.cbegin(), edgeWeight.cend(), 0.0) / 2.0; } double Network::getTotalEdgeWeight(int node) { return std::accumulate(edgeWeight.cbegin() + firstNeighborIndex.at(node), edgeWeight.cbegin() + firstNeighborIndex.at(node + 1), 0.0); } DVector Network::getTotalEdgeWeightPerNode() { DVector totalEdgeWeightPerNode(nNodes, 0.0); for (int i = 0; i < nNodes; i++) { totalEdgeWeightPerNode[i] = getTotalEdgeWeight(i); } return totalEdgeWeightPerNode; } DVector Network::getEdgeWeights(int node) { return DVector(edgeWeight.cbegin() + firstNeighborIndex.at(node), edgeWeight.cbegin() + firstNeighborIndex.at(node+1)); } std::vector Network::getEdgeWeightsPerNode() { std::vector edgeWeightPerNode(nNodes); for (int i = 0; i < nNodes; i++) edgeWeightPerNode[i] = getEdgeWeights(i); return edgeWeightPerNode; } // Skipping unused Network creators // Network createNetworkWithoutNodeWeights() // Network createNetworkWithoutEdgeWeights() // Network createNetworkWithoutNodeAndEdgeWeights() // Network createNormalizedNetwork1() // Network createNormalizedNetwork2() // Network createPrunedNetwork(int nEdges) // Network createPrunedNetwork(int nEdges, Random random) // Network createSubnetwork(int[] node) // Network createSubnetwork(boolean[] nodeInSubnetwork) // Network createSubnetwork(Clustering clustering, int cluster) std::vector Network::createSubnetworks(Clustering clustering) const { std::vector subnetwork(clustering.nClusters); auto nodePerCluster = clustering.getNodesPerCluster(); IVector subnetworkNode(nNodes); IVector subnetworkNeighbor(nEdges); DVector subnetworkEdgeWeight(nEdges); for (int i = 0; i < clustering.nClusters; i++) subnetwork[i] = createSubnetwork(clustering, i, nodePerCluster[i], subnetworkNode, subnetworkNeighbor, subnetworkEdgeWeight); return subnetwork; } // Network createSubnetworkLargestComponent() // Network createReducedNetwork(Clustering clustering) Network Network::createReducedNetwork(const Clustering& clustering) const { Network reducedNetwork; reducedNetwork.nNodes = clustering.nClusters; reducedNetwork.nEdges = 0; reducedNetwork.nodeWeight = DVector(clustering.nClusters); reducedNetwork.firstNeighborIndex = IVector(clustering.nClusters + 1); reducedNetwork.totalEdgeWeightSelfLinks = totalEdgeWeightSelfLinks; IVector reducedNetworkNeighbor1(nEdges); DVector reducedNetworkEdgeWeight1(nEdges); IVector reducedNetworkNeighbor2(clustering.nClusters - 1); DVector reducedNetworkEdgeWeight2(clustering.nClusters); std::vector nodePerCluster = clustering.getNodesPerCluster(); for (int i = 0; i < clustering.nClusters; i++) { int j = 0; for (size_t k = 0; k < nodePerCluster[i].size(); k++) { int l = nodePerCluster[i][k]; reducedNetwork.nodeWeight[i] += nodeWeight[l]; for (int m = firstNeighborIndex[l]; m < firstNeighborIndex[l + 1]; m++) { int n = clustering.cluster[neighbor[m]]; if (n != i) { if (reducedNetworkEdgeWeight2[n] == 0) { reducedNetworkNeighbor2[j] = n; j++; } reducedNetworkEdgeWeight2[n] += edgeWeight[m]; } else reducedNetwork.totalEdgeWeightSelfLinks += edgeWeight[m]; } } for (int k = 0; k < j; k++) { reducedNetworkNeighbor1[reducedNetwork.nEdges + k] = reducedNetworkNeighbor2[k]; reducedNetworkEdgeWeight1[reducedNetwork.nEdges + k] = reducedNetworkEdgeWeight2[reducedNetworkNeighbor2[k]]; reducedNetworkEdgeWeight2[reducedNetworkNeighbor2[k]] = 0; } reducedNetwork.nEdges += j; reducedNetwork.firstNeighborIndex[i + 1] = reducedNetwork.nEdges; } reducedNetwork.neighbor = IVector(reducedNetworkNeighbor1.cbegin(), reducedNetworkNeighbor1.cbegin() + reducedNetwork.nEdges); reducedNetwork.edgeWeight = DVector(reducedNetworkEdgeWeight1.cbegin(), reducedNetworkEdgeWeight1.cbegin() + reducedNetwork.nEdges); return reducedNetwork; } Clustering Network::identifyComponents() { std::vector nodeVisited(nNodes, false); IVector node(nNodes); Clustering clustering(nNodes); clustering.nClusters = 0; for (int i = 0; i < nNodes; i++) if (!nodeVisited[i]) { clustering.cluster[i] = clustering.nClusters; nodeVisited[i] = true; node[0] = i; int j = 1; int k = 0; do { for (int l = firstNeighborIndex[node[k]]; l < firstNeighborIndex[node[k] + 1]; l++) if (!nodeVisited[neighbor[l]]) { clustering.cluster[neighbor[l]] = clustering.nClusters; nodeVisited[neighbor[l]] = true; node[j] = neighbor[l]; j++; } k++; } while (k < j); clustering.nClusters++; } clustering.orderClustersByNNodes(); return clustering; } // private: // double generateRandomNumber(int node1, int node2, const IVector& nodePermutation); Network Network::createSubnetwork(const Clustering& clustering, int cluster, IVector& node, IVector& subnetworkNode, IVector& subnetworkNeighbor, DVector& subnetworkEdgeWeight) const { Network subnetwork; subnetwork.nNodes = node.size(); if (subnetwork.nNodes == 1) { subnetwork.nEdges = 0; subnetwork.nodeWeight = DVector(1, nodeWeight[node[0]]); subnetwork.firstNeighborIndex = IVector(2); subnetwork.neighbor = IVector(0); subnetwork.edgeWeight = DVector(0); } else { for (size_t i = 0; i < node.size(); i++) subnetworkNode[node[i]] = i; subnetwork.nEdges = 0; subnetwork.nodeWeight = DVector(subnetwork.nNodes, 0); subnetwork.firstNeighborIndex = IVector(subnetwork.nNodes + 1); for (int i = 0; i < subnetwork.nNodes; i++) { int j = node[i]; subnetwork.nodeWeight[i] = nodeWeight[j]; for (int k = firstNeighborIndex[j]; k < firstNeighborIndex[j + 1]; k++) if (clustering.cluster[neighbor[k]] == cluster) { subnetworkNeighbor[subnetwork.nEdges] = subnetworkNode[neighbor[k]]; subnetworkEdgeWeight[subnetwork.nEdges] = edgeWeight[k]; subnetwork.nEdges++; } subnetwork.firstNeighborIndex[i + 1] = subnetwork.nEdges; } subnetwork.neighbor = IVector(subnetworkNeighbor.cbegin(), subnetworkNeighbor.cbegin() + subnetwork.nEdges); subnetwork.edgeWeight = DVector(subnetworkEdgeWeight.cbegin(), subnetworkEdgeWeight.cbegin() + subnetwork.nEdges); } subnetwork.totalEdgeWeightSelfLinks = 0; return subnetwork; } VOSClusteringTechnique::VOSClusteringTechnique(std::shared_ptr network, double resolution) : network(network), resolution(resolution) { clustering = std::make_shared(network->getNNodes()); clustering->initSingletonClusters(); }; VOSClusteringTechnique::VOSClusteringTechnique(std::shared_ptr network, std::shared_ptr clustering, double resolution) : network(network), clustering(clustering), resolution(resolution){}; double VOSClusteringTechnique::calcQualityFunction() { double qualityFunction = 0.0; for (int i = 0; i < network->getNNodes(); i++) { int j = clustering->cluster[i]; for (int k = network->getFirstNeighborIndexValue(i); k < network->getFirstNeighborIndexValue(i + 1); k++) if (clustering->cluster[network->getNeighborValue(k)] == j) qualityFunction += network->edgeWeight[k]; } qualityFunction += network->totalEdgeWeightSelfLinks; DVector clusterWeight(clustering->nClusters); for (int i = 0; i < network->nNodes; i++) clusterWeight[clustering->cluster[i]] += network->nodeWeight[i]; for (int i = 0; i < clustering->nClusters; i++) qualityFunction -= clusterWeight[i] * clusterWeight[i] * resolution; qualityFunction /= 2 * network->getTotalEdgeWeight() + network->totalEdgeWeightSelfLinks; return qualityFunction; } bool VOSClusteringTechnique::runLocalMovingAlgorithm(JavaRandom& random){ bool update = false; double maxQualityFunction, qualityFunction; DVector clusterWeight(network->getNNodes(), 0); IVector nNodesPerCluster(network->getNNodes(), 0); int bestCluster, j, k, l, nNeighboringClusters, nStableNodes; if (network->getNNodes() == 1) return false; for (int i = 0; i < network->getNNodes(); i++) { clusterWeight[clustering->cluster[i]] += network->nodeWeight[i]; nNodesPerCluster[clustering->cluster[i]]++; } int nUnusedClusters = 0; IVector unusedCluster(network->getNNodes(), 0); for (int i = 0; i < network->getNNodes(); i++) { if (nNodesPerCluster[i] == 0) { unusedCluster[nUnusedClusters] = i; nUnusedClusters++; } } IVector nodePermutation = Arrays2::generateRandomPermutation(network->nNodes, random); DVector edgeWeightPerCluster(network->getNNodes(), 0.0); IVector neighboringCluster(network->getNNodes() - 1, 0); nStableNodes = 0; int i = 0; do { j = nodePermutation[i]; nNeighboringClusters = 0; for (k = network->firstNeighborIndex.at(j); k < network->firstNeighborIndex.at(j + 1); k++) { l = clustering->cluster[network->neighbor[k]]; if (edgeWeightPerCluster[l] == 0) { neighboringCluster[nNeighboringClusters] = l; nNeighboringClusters++; } edgeWeightPerCluster[l] += network->edgeWeight[k]; } clusterWeight[clustering->cluster[j]] -= network->nodeWeight[j]; nNodesPerCluster[clustering->cluster[j]]--; if (nNodesPerCluster[clustering->cluster[j]] == 0) { unusedCluster[nUnusedClusters] = clustering->cluster[j]; nUnusedClusters++; } bestCluster = -1; maxQualityFunction = 0; for (k = 0; k < nNeighboringClusters; k++) { l = neighboringCluster[k]; qualityFunction = edgeWeightPerCluster[l] - network->nodeWeight[j] * clusterWeight[l] * resolution; if ((qualityFunction > maxQualityFunction) || ((qualityFunction == maxQualityFunction) && (l < bestCluster))) { bestCluster = l; maxQualityFunction = qualityFunction; } edgeWeightPerCluster[l] = 0; } if (maxQualityFunction == 0) { bestCluster = unusedCluster[nUnusedClusters - 1]; nUnusedClusters--; } clusterWeight[bestCluster] += network->nodeWeight[j]; nNodesPerCluster[bestCluster]++; if (bestCluster == clustering->cluster[j]) nStableNodes++; else { clustering->cluster[j] = bestCluster; nStableNodes = 1; update = true; } i = (i < network->nNodes - 1) ? (i + 1) : 0; } while (nStableNodes < network->nNodes); IVector newCluster(network->getNNodes()); clustering->nClusters = 0; for (i = 0; i < network->nNodes; i++) if (nNodesPerCluster[i] > 0) { newCluster[i] = clustering->nClusters; clustering->nClusters++; } for (i = 0; i < network->nNodes; i++) clustering->cluster[i] = newCluster[clustering->cluster[i]]; return update; } bool VOSClusteringTechnique::runLouvainAlgorithm(JavaRandom& random) { if (network->nNodes == 1) return false; bool update = runLocalMovingAlgorithm(random); if (clustering->nClusters < network->nNodes) { VOSClusteringTechnique vosClusteringTechnique(std::make_shared(network->createReducedNetwork(*clustering)), resolution); bool update2 = vosClusteringTechnique.runLouvainAlgorithm(random); if (update2) { update = true; clustering->mergeClusters(*vosClusteringTechnique.clustering); } } return update; } bool VOSClusteringTechnique::runIteratedLouvainAlgorithm(int maxNIterations, JavaRandom& random) { bool update; int i = 0; do { update = runLouvainAlgorithm(random); i++; } while ((i < maxNIterations) && update); return ((i > 1) || update); } bool VOSClusteringTechnique::runLouvainAlgorithmWithMultilevelRefinement(JavaRandom& random) { if (network->nNodes == 1) return false; bool update = runLocalMovingAlgorithm(random); if (clustering->nClusters < network->nNodes) { VOSClusteringTechnique vosClusteringTechnique(std::make_shared(network->createReducedNetwork(*clustering)), resolution); bool update2 = vosClusteringTechnique.runLouvainAlgorithmWithMultilevelRefinement(random); if (update2) { update = true; clustering->mergeClusters(*vosClusteringTechnique.clustering); runLocalMovingAlgorithm(random); } } return update;} bool VOSClusteringTechnique::runIteratedLouvainAlgorithmWithMultilevelRefinement(int maxNIterations, JavaRandom& random) { bool update; int i = 0; do { update = runLouvainAlgorithmWithMultilevelRefinement(random); i++; } while ((i < maxNIterations) && update); return ((i > 1) || update); } bool VOSClusteringTechnique::runSmartLocalMovingAlgorithm(JavaRandom& random) { if (network->nNodes == 1) return false; bool update = runLocalMovingAlgorithm(random); if (clustering->nClusters < network->nNodes) { std::vector subnetwork = network->createSubnetworks(*clustering); auto nodePerCluster = clustering->getNodesPerCluster(); clustering->nClusters = 0; IVector nNodesPerClusterReducedNetwork(subnetwork.size()); for (size_t i = 0; i < subnetwork.size(); i++) { VOSClusteringTechnique vosClusteringTechnique(std::make_shared(subnetwork[i]), resolution); vosClusteringTechnique.runLocalMovingAlgorithm(random); for (int j = 0; j < subnetwork[i].nNodes; j++) clustering->cluster[nodePerCluster[i][j]] = clustering->nClusters + vosClusteringTechnique.clustering->cluster[j]; clustering->nClusters += vosClusteringTechnique.clustering->nClusters; nNodesPerClusterReducedNetwork[i] = vosClusteringTechnique.clustering->nClusters; } VOSClusteringTechnique vosClusteringTechnique2(std::make_shared(network->createReducedNetwork(*clustering)), resolution); int i = 0; for (size_t j = 0; j < nNodesPerClusterReducedNetwork.size(); j++) { for (int k = 0; k < nNodesPerClusterReducedNetwork[j]; k++) { vosClusteringTechnique2.clustering->cluster[i] = static_cast(j); i++; } } vosClusteringTechnique2.clustering->nClusters = nNodesPerClusterReducedNetwork.size(); update |= vosClusteringTechnique2.runSmartLocalMovingAlgorithm(random); clustering->mergeClusters(*vosClusteringTechnique2.clustering); } return update; } bool VOSClusteringTechnique::runIteratedSmartLocalMovingAlgorithm(int nIterations, JavaRandom& random) { bool update = false; for (int i = 0; i < nIterations; i++) update |= runSmartLocalMovingAlgorithm(random); return update; } int VOSClusteringTechnique::removeCluster(int cluster) { DVector clusterWeight(clustering->nClusters); DVector totalEdgeWeightPerCluster(clustering->nClusters); for (int i = 0; i < network->nNodes; i++) { clusterWeight[clustering->cluster[i]] += network->nodeWeight[i]; if (clustering->cluster[i] == cluster) for (int j = network->firstNeighborIndex[i]; j < network->firstNeighborIndex[i + 1]; j++) totalEdgeWeightPerCluster[clustering->cluster[network->neighbor[j]]] += network->edgeWeight[j]; } int i = -1; double maxQualityFunction = 0; for (int j = 0; j < clustering->nClusters; j++) if ((j != cluster) && (clusterWeight[j] > 0)) { double qualityFunction = totalEdgeWeightPerCluster[j] / clusterWeight[j]; if (qualityFunction > maxQualityFunction) { i = j; maxQualityFunction = qualityFunction; } } if (i >= 0) { for (int j = 0; j < network->nNodes; j++) if (clustering->cluster[j] == cluster) clustering->cluster[j] = i; if (cluster == clustering->nClusters - 1) clustering->nClusters = *std::max_element(clustering->cluster.cbegin(), clustering->cluster.cend()) + 1; } return i; } void VOSClusteringTechnique::removeSmallClusters(int minNNodesPerCluster) { VOSClusteringTechnique vosClusteringTechnique(std::make_shared(network->createReducedNetwork(*clustering)), resolution); auto nNodesPerCluster = clustering->getNNodesPerCluster(); int i; do { i = -1; int j = minNNodesPerCluster; for (int k = 0; k < vosClusteringTechnique.clustering->nClusters; k++) if ((nNodesPerCluster[k] > 0) && (nNodesPerCluster[k] < j)) { i = k; j = nNodesPerCluster[k]; } if (i >= 0) { j = vosClusteringTechnique.removeCluster(i); if (j >= 0) nNodesPerCluster[j] += nNodesPerCluster[i]; nNodesPerCluster[i] = 0; } } while (i >= 0); clustering->mergeClusters(*vosClusteringTechnique.clustering); } std::shared_ptr ModularityOptimizer::matrixToNetwork(IVector& node1, IVector& node2, DVector& edgeWeight1, int modularityFunction) { int n1_max = *std::max_element(node1.cbegin(), node1.cend()); int n2_max = *std::max_element(node2.cbegin(), node2.cend()); int nNodes = std::max(n1_max, n2_max) + 1; IVector nNeighbors(nNodes); for (size_t i = 0; i < node1.size(); i++) if (node1[i] < node2[i]) { nNeighbors[node1[i]]++; nNeighbors[node2[i]]++; } IVector firstNeighborIndex(nNodes + 1); int nEdges = 0; for (int i = 0; i < nNodes; i++) { firstNeighborIndex[i] = nEdges; nEdges += nNeighbors[i]; } firstNeighborIndex[nNodes] = nEdges; IVector neighbor(nEdges); DVector edgeWeight2(nEdges); std::fill(nNeighbors.begin(), nNeighbors.end(), 0); for (size_t i = 0; i < node1.size(); i++) if (node1[i] < node2[i]) { int j = firstNeighborIndex[node1[i]] + nNeighbors[node1[i]]; neighbor[j] = node2[i]; edgeWeight2[j] = edgeWeight1[i]; nNeighbors[node1[i]]++; j = firstNeighborIndex[node2[i]] + nNeighbors[node2[i]]; neighbor[j] = node1[i]; edgeWeight2[j] = edgeWeight1[i]; nNeighbors[node2[i]]++; } if (modularityFunction == 1) return std::make_shared(nNodes, firstNeighborIndex, neighbor, &edgeWeight2); else { DVector nodeWeight(nNodes, 1.0); return std::make_shared(nNodes, &nodeWeight, firstNeighborIndex, neighbor, &edgeWeight2); } } std::shared_ptr ModularityOptimizer::readInputFile(std::string fname, int modularityFunction) { std::ifstream f; f.open(fname, std::ios::in); if(!f) { throw std::runtime_error("File could not be opened."); } std::string line; int nLines = 0; while(std::getline(f, line)) { nLines++; } f.clear(); f.seekg(0, std::ios::beg); IVector node1(nLines); IVector node2(nLines); DVector edgeWeight1(nLines, 1.0); for (int j = 0; j < nLines; j++) { std::getline(f, line); auto splittedLine = split(line, '\t'); node1[j] =std::stoi(splittedLine[0]); node2[j] = std::stoi(splittedLine[1]); if(splittedLine.size() > 2) { edgeWeight1[j] = std::stod(splittedLine[2]); } } return matrixToNetwork(node1, node2, edgeWeight1, modularityFunction); } std::vector ModularityOptimizer::split(const std::string& s, char delimiter) { std::vector tokens; std::string token; std::istringstream tokenStream(s); while (std::getline(tokenStream, token, delimiter)) { tokens.push_back(token); } return tokens; } #ifdef STANDALONE void writeOutputFile(std::string fname, Clustering& clustering) { int nNodes = clustering.getNNodes(); clustering.orderClustersByNNodes(); std::ofstream f(fname, std::ios::out); for(int i=0; i < nNodes; i++) f << clustering.getCluster(i) << std::endl; f.close(); } template void input(std::string msg, T& value) { std::cout << msg << std::endl << std::endl; std::cin >> value; } int main(int argc, char* argv[]) { std::string msg = "Modularity Optimizer version 1.3.0 by Ludo Waltman and Nees Jan van Eck"; std::vector args; std::string inputFileName, outputFileName; bool printOutput, update; double modularity, maxModularity, resolution, resolution2; int algorithm, i, j, modularityFunction, nIterations, nRandomStarts; unsigned long long int randomSeed; for(int i=0; i 0); if (printOutput) { std::cout << msg << std::endl << std::endl; } } else { std::cout << msg << std::endl << std::endl; input("Input file name: ", inputFileName); input("Output file name: ", outputFileName); input("Modularity function (1 = standard; 2 = alternative): ", modularityFunction); input("Resolution parameter (e.g., 1.0): ", resolution); input("Algorithm (1 = Louvain; 2 = Louvain with multilevel refinement; 3 = smart local moving): ", algorithm); input("Number of random starts (e.g., 10): ", nRandomStarts); input("Number of iterations (e.g., 10): ",nIterations); input("Random seed (e.g., 0): ", randomSeed); int tmp; input("Print output (0 = no; 1 = yes): ",tmp); printOutput = tmp > 0; std::cout << std::endl; } if (printOutput) { std::cout << "Reading input file..." << std::endl << std::endl; } std::shared_ptr network = readInputFile(inputFileName, modularityFunction); if (printOutput) { std::printf("Number of nodes: %d\n", network->getNNodes()); std::printf("Number of edges: %d\n", network->getNEdges()); std::cout << std::endl; std::cout << "Running " << ((algorithm == 1) ? "Louvain algorithm" : ((algorithm == 2) ? "Louvain algorithm with multilevel refinement" : "smart local moving algorithm")) << "..."; std::cout << std::endl; } resolution2 = ((modularityFunction == 1) ? (resolution / (2 * network->getTotalEdgeWeight() + network->getTotalEdgeWeightSelfLinks())) : resolution); auto beginTime = duration_cast(system_clock::now().time_since_epoch()); std::shared_ptr clustering; maxModularity = -std::numeric_limits::infinity(); JavaRandom random(randomSeed); for (i = 0; i < nRandomStarts; i++) { if (printOutput && (nRandomStarts > 1)) std::printf("Random start: %d\n", i + 1); VOSClusteringTechnique vosClusteringTechnique(network, resolution2); j = 0; update = true; do { if (printOutput && (nIterations > 1)) std::printf("Iteration: %d\n", j + 1); if (algorithm == 1) update = vosClusteringTechnique.runLouvainAlgorithm(random); else if (algorithm == 2) update = vosClusteringTechnique.runLouvainAlgorithmWithMultilevelRefinement(random); else if (algorithm == 3) vosClusteringTechnique.runSmartLocalMovingAlgorithm(random); j++; modularity = vosClusteringTechnique.calcQualityFunction(); if (printOutput && (nIterations > 1)) std::printf("Modularity: %.4f\n", modularity); } while ((j < nIterations) && update); if (modularity > maxModularity) { clustering = vosClusteringTechnique.getClustering(); maxModularity = modularity; } if (printOutput && (nRandomStarts > 1)) { if (nIterations == 1) std::printf("Modularity: %.4f\n", modularity); std::cout << std::endl; } } auto endTime = duration_cast(system_clock::now().time_since_epoch()); if (printOutput) { if (nRandomStarts == 1) { if (nIterations > 1) std::cout << std::endl; std::printf("Modularity: %.4f\n", maxModularity); } else std::printf("Maximum modularity in %d random starts: %.4f\n", nRandomStarts, maxModularity); std::printf("Number of communities: %d\n", clustering->getNClusters()); std::printf("Elapsed time: %d seconds\n", static_cast((endTime - beginTime).count() / 1000.0)); std::cout << std::endl << "Writing output file..." << std::endl; } writeOutputFile(outputFileName, *clustering); } catch (std::exception a) { std::cout << a.what() << std::endl; } return 0; }; #endif Seurat/src/Makevars0000644000176200001440000000002013527073365014003 0ustar liggesusersCXX_STD = CXX11 Seurat/src/data_manipulation.h0000644000176200001440000000545213527073365016167 0ustar liggesusers#ifndef DATA_MANIPULATION #define DATA_MANIPULATION #include #include #include #include #include #include using namespace Rcpp; //---------------------------------------------------- Eigen::SparseMatrix RunUMISampling(Eigen::SparseMatrix data, int sample_val, bool upsample, bool display_progress); Eigen::SparseMatrix RunUMISamplingPerCell(Eigen::SparseMatrix data, NumericVector sample_val, bool upsample, bool display_progress); Eigen::SparseMatrix RowMergeMatrices(Eigen::SparseMatrix mat1, Eigen::SparseMatrix mat2, std::vector< std::string > mat1_rownames, std::vector< std::string > mat2_rownames, std::vector< std::string > all_rownames); Eigen::SparseMatrix LogNorm(Eigen::SparseMatrix data, int scale_factor, bool display_progress ); Eigen::MatrixXd FastRowScale(Eigen::MatrixXd mat, bool scale, bool center, double scale_max, bool display_progress); NumericMatrix Standardize(const Eigen::Map mat, bool display_progress); Eigen::MatrixXd FastSparseRowScale(Eigen::SparseMatrix mat, bool scale, bool center, double scale_max, bool display_progress); Eigen::MatrixXd FastCov(Eigen::MatrixXd mat, bool center); Eigen::MatrixXd FastCovMats(Eigen::MatrixXd mat1, Eigen::MatrixXd mat2, bool center); Eigen::MatrixXd FastRBind(Eigen::MatrixXd mat1, Eigen::MatrixXd mat2); Eigen::VectorXd FastExpMean(Eigen::MatrixXd mat, bool display_progress); Eigen::VectorXd FastRowMean(Eigen::MatrixXd mat, bool display_progress); Eigen::VectorXd FastLogVMR(Eigen::SparseMatrix mat, bool display_progress); Eigen::VectorXd FastExpVar(Eigen::SparseMatrix mat, bool display_progress); Eigen::VectorXd SparseRowVar(Eigen::SparseMatrix mat, bool display_progress); NumericVector SparseRowVar2(Eigen::SparseMatrix mat, NumericVector mu, bool display_progress); NumericVector SparseRowVarStd(Eigen::SparseMatrix mat, NumericVector mu, NumericVector sd, double vmax, bool display_progress); NumericVector RowVar(Eigen::Map x); //---------------------------------------------------- #endif//DATA_MANIPULATION Seurat/src/integration.h0000644000176200001440000000166013527073365015016 0ustar liggesusers#ifndef CORRECT_EXPRESSION #define CORRECT_EXPRESSION #include #include using namespace Rcpp; //---------------------------------------------------- Eigen::SparseMatrix FindWeightsC( Eigen::SparseMatrix integration_matrix, NumericVector cells2, Eigen::MatrixXd distances, std::vector anchor_cells2, std::vector integration_matrix_rownames, Eigen::MatrixXd cell_index, Eigen::VectorXd anchor_score, double min_dist, double sd, bool display_progress ); Eigen::SparseMatrix IntegrateDataC( Eigen::SparseMatrix integration_matrix, Eigen::SparseMatrix weights, Eigen::SparseMatrix expression_cells2 ); Eigen::SparseMatrix SNNAnchor( Eigen::SparseMatrix k_matrix, Eigen::SparseMatrix anchor_only ); //---------------------------------------------------- #endif//CORRECT_EXPRESSION Seurat/src/ModularityOptimizer.h0000644000176200001440000001322113527073365016523 0ustar liggesusers#pragma once #include #include #include #include #include #include #include #include typedef std::vector IVector; typedef std::vector DVector; namespace ModularityOptimizer { class JavaRandom { private: uint64_t seed; int next(int bits); public: JavaRandom(uint64_t seed); int nextInt(int n); void setSeed(uint64_t seed); }; namespace Arrays2 { IVector generateRandomPermutation(int nElements); IVector generateRandomPermutation(int nElements, JavaRandom& random); } class Clustering { private: int nNodes; public: // Note: These two variables were "protected" in java, which means it is accessible to the whole package/public. // Although we could have used friend classes, this allows for better mirroring of the original code. int nClusters; IVector cluster; Clustering(int nNodes); Clustering(IVector cluster); int getNNodes() const {return nNodes;}; int getNClusters() const {return nClusters;}; IVector getClusters() const {return cluster;}; int getCluster(int node) const {return cluster[node];}; IVector getNNodesPerCluster() const; std::vector getNodesPerCluster() const; void setCluster(int node, int cluster); void initSingletonClusters(); void orderClustersByNNodes(); void mergeClusters(const Clustering& clustering); }; class Network { friend class VOSClusteringTechnique; protected: int nNodes; int nEdges; DVector nodeWeight; IVector firstNeighborIndex; IVector neighbor; DVector edgeWeight; double totalEdgeWeightSelfLinks; public: Network(); Network(int nNodes, DVector* nodeWeight, std::vector& edge, DVector* edgeWeight); Network(int nNodes, std::vector& edge) : Network(nNodes, nullptr, edge, nullptr) { }; Network(int nNodes, DVector* nodeWeight, std::vector edge) : Network(nNodes, nodeWeight, edge, nullptr) {}; Network(int nNodes, std::vector& edge, DVector* edgeWeight) : Network(nNodes, nullptr, edge, edgeWeight) {}; Network(int nNodes, DVector* nodeWeight, IVector& firstNeighborIndex, IVector& neighbor, DVector* edgeWeight); Network(int nNodes, IVector& firstNeighborIndex, IVector& neighbor) : Network(nNodes, nullptr, firstNeighborIndex, neighbor, nullptr) {}; Network(int nNodes, DVector* nodeWeight, IVector& firstNeighborIndex, IVector& neighbor) : Network(nNodes, nodeWeight, firstNeighborIndex, neighbor, nullptr){}; Network(int nNodes, IVector& firstNeighborIndex, IVector& neighbor, DVector* edgeWeight) : Network(nNodes, nullptr, firstNeighborIndex, neighbor, edgeWeight) {}; int getNNodes() {return nNodes;}; double getTotalNodeWeight(); DVector getNodeWeights(); double getNodeWeight(int node) { return nodeWeight.at(node);}; int getNEdges() {return nEdges / 2;}; int getNEdges(int node) {return firstNeighborIndex.at(node + 1) - firstNeighborIndex.at(node);}; IVector getNEdgesPerNode(); std::vector getEdges(); IVector getEdges(int node); std::vector getEdgesPerNode(); double getTotalEdgeWeight(); double getTotalEdgeWeight(int node); DVector getTotalEdgeWeightPerNode(); DVector getEdgeWeights() {return edgeWeight;}; DVector getEdgeWeights(int node); std::vector getEdgeWeightsPerNode(); double getTotalEdgeWeightSelfLinks() { return totalEdgeWeightSelfLinks; }; // Added these to avoid making these values public int getFirstNeighborIndexValue(int i) const { return firstNeighborIndex.at(i); }; int getNeighborValue(int index) const { return neighbor.at(index); } std::vector createSubnetworks(Clustering clustering) const; Network createReducedNetwork(const Clustering& clustering) const; Clustering identifyComponents(); private: double generateRandomNumber(int node1, int node2, const IVector& nodePermutation); Network createSubnetwork(const Clustering& clustering, int cluster, IVector& node, IVector& subnetworkNode, IVector& subnetworkNeighbor, DVector& subnetworkEdgeWeight) const; }; class VOSClusteringTechnique { private: std::shared_ptr network; std::shared_ptr clustering; double resolution; public: VOSClusteringTechnique(std::shared_ptr network, double resolution); VOSClusteringTechnique(std::shared_ptr network, std::shared_ptr clustering, double resolution); std::shared_ptr getNetwork() { return network;} std::shared_ptr getClustering() { return clustering; } double getResolution() {return resolution; } void setNetwork(std::shared_ptr network) {this->network = network;} void setClustering(std::shared_ptr clustering) {this->clustering = clustering;} void setResolution(double resolution) {this->resolution = resolution;} double calcQualityFunction(); bool runLocalMovingAlgorithm(JavaRandom& random); bool runLouvainAlgorithm(JavaRandom& random); bool runIteratedLouvainAlgorithm(int maxNIterations, JavaRandom& random); bool runLouvainAlgorithmWithMultilevelRefinement(JavaRandom& random); bool runIteratedLouvainAlgorithmWithMultilevelRefinement(int maxNIterations, JavaRandom& random); bool runSmartLocalMovingAlgorithm(JavaRandom& random); bool runIteratedSmartLocalMovingAlgorithm(int nIterations, JavaRandom& random); int removeCluster(int cluster); void removeSmallClusters(int minNNodesPerCluster); }; std::shared_ptr matrixToNetwork(IVector& node1, IVector& node2, DVector& edgeWeight1, int modularityFunction); std::shared_ptr readInputFile(std::string fname, int modularityFunction); std::vector split(const std::string& s, char delimiter); }; Seurat/src/integration.cpp0000644000176200001440000000766113527073365015360 0ustar liggesusers#include #include #include using namespace Rcpp; // [[Rcpp::depends(RcppEigen)]] // [[Rcpp::depends(RcppProgress)]] typedef Eigen::Triplet T; // [[Rcpp::export]] Eigen::SparseMatrix FindWeightsC( Eigen::SparseMatrix integration_matrix, NumericVector cells2, Eigen::MatrixXd distances, std::vector anchor_cells2, std::vector integration_matrix_rownames, Eigen::MatrixXd cell_index, Eigen::VectorXd anchor_score, double min_dist, double sd, bool display_progress ) { std::vector tripletList; tripletList.reserve(anchor_cells2.size() * 10); std::unordered_map> cell_map; Progress p(anchor_cells2.size() + cells2.size() , display_progress); // build map from anchor_cells2 to integration_matrix rows for(int i=0; i matches; std::vector::iterator iter = integration_matrix_rownames.begin(); while ((iter = std::find(iter, integration_matrix_rownames.end(), anchor_cells2[i])) != integration_matrix_rownames.end()) { int idx = std::distance(integration_matrix_rownames.begin(), iter); matches.push_back(idx); iter++; } cell_map[i] = matches; p.increment(); } // Construct dist_weights matrix for(auto const &cell : cells2){ Eigen::VectorXd dist = distances.row(cell); Eigen::VectorXd indices = cell_index.row(cell); for(int i=0; i mnn_idx = cell_map[indices[i]-1]; for(int j=0; j return_mat; if(min_dist == 0){ Eigen::SparseMatrix dist_weights(integration_matrix.rows(), cells2.size()); dist_weights.setFromTriplets(tripletList.begin(), tripletList.end(), [] (const double&, const double &b) { return b; }); Eigen::VectorXd colSums = dist_weights.transpose() * Eigen::VectorXd::Ones(dist_weights.rows()); for (int k=0; k < dist_weights.outerSize(); ++k){ for (Eigen::SparseMatrix::InnerIterator it(dist_weights, k); it; ++it){ it.valueRef() = it.value()/colSums[k]; } } return_mat = dist_weights; } else { Eigen::MatrixXd dist_weights = Eigen::MatrixXd::Constant(integration_matrix.rows(), cells2.size(), min_dist); for(int i = 0; i < dist_weights.cols(); ++i){ for(int j = 0; j < dist_weights.rows(); ++j){ dist_weights(j, i) = 1 - exp(-1 * dist_weights(j, i) * anchor_score[j]/2 * pow(1/sd, 2)); } } for(auto const &weight : tripletList){ dist_weights(weight.row(), weight.col()) = weight.value(); } Eigen::VectorXd colSums = dist_weights.colwise().sum(); for(int i = 0; i < dist_weights.cols(); ++i){ for(int j = 0; j < dist_weights.rows(); ++j){ dist_weights(j, i) = dist_weights(j, i) / colSums[i]; } } return_mat = dist_weights.sparseView(); } return(return_mat); } // [[Rcpp::export]] Eigen::SparseMatrix IntegrateDataC( Eigen::SparseMatrix integration_matrix, Eigen::SparseMatrix weights, Eigen::SparseMatrix expression_cells2 ) { Eigen::SparseMatrix corrected = expression_cells2 - weights.transpose() * integration_matrix; return(corrected); } //[[Rcpp::export]] Eigen::SparseMatrix SNNAnchor( Eigen::SparseMatrix k_matrix, Eigen::SparseMatrix anchor_only ) { typedef Eigen::SparseMatrix SpMat; SpMat mat2 = k_matrix; SpMat mat3 = mat2 * mat2.transpose(); for (int k=0; k::InnerIterator it(anchor_only,k); it; ++it){ it.valueRef() = mat3.coeff(it.row(), it.col()); } } return(anchor_only); } Seurat/src/data_manipulation.cpp0000644000176200001440000003445313527073365016525 0ustar liggesusers#include #include #include #include #include #include using namespace Rcpp; // [[Rcpp::depends(RcppEigen)]] // [[Rcpp::depends(RcppProgress)]] // [[Rcpp::export]] Eigen::SparseMatrix RunUMISampling(Eigen::SparseMatrix data, int sample_val, bool upsample = false, bool display_progress=true){ Progress p(data.outerSize(), display_progress); Eigen::VectorXd colSums = data.transpose() * Eigen::VectorXd::Ones(data.rows()); for (int k=0; k < data.outerSize(); ++k){ p.increment(); for (Eigen::SparseMatrix::InnerIterator it(data, k); it; ++it){ double entry = it.value(); if( (upsample) || (colSums[k] > sample_val)){ entry = entry * double(sample_val) / colSums[k]; if (fmod(entry, 1) != 0){ double rn = R::runif(0,1); if(fmod(entry, 1) <= rn){ it.valueRef() = floor(entry); } else{ it.valueRef() = ceil(entry); } } else{ it.valueRef() = entry; } } } } return(data); } // [[Rcpp::export]] Eigen::SparseMatrix RunUMISamplingPerCell(Eigen::SparseMatrix data, NumericVector sample_val, bool upsample = false, bool display_progress=true){ Progress p(data.outerSize(), display_progress); Eigen::VectorXd colSums = data.transpose() * Eigen::VectorXd::Ones(data.rows()); for (int k=0; k < data.outerSize(); ++k){ p.increment(); for (Eigen::SparseMatrix::InnerIterator it(data, k); it; ++it){ double entry = it.value(); if( (upsample) || (colSums[k] > sample_val[k])){ entry = entry * double(sample_val[k]) / colSums[k]; if (fmod(entry, 1) != 0){ double rn = R::runif(0,1); if(fmod(entry, 1) <= rn){ it.valueRef() = floor(entry); } else{ it.valueRef() = ceil(entry); } } else{ it.valueRef() = entry; } } } } return(data); } typedef Eigen::Triplet T; // [[Rcpp::export]] Eigen::SparseMatrix RowMergeMatrices(Eigen::SparseMatrix mat1, Eigen::SparseMatrix mat2, std::vector< std::string > mat1_rownames, std::vector< std::string > mat2_rownames, std::vector< std::string > all_rownames){ // Set up hash maps for rowname based lookup std::unordered_map mat1_map; for(int i = 0; i < mat1_rownames.size(); i++){ mat1_map[mat1_rownames[i]] = i; } std::unordered_map mat2_map; for(int i = 0; i < mat2_rownames.size(); i++){ mat2_map[mat2_rownames[i]] = i; } // set up tripletList for new matrix creation std::vector tripletList; int num_rows = all_rownames.size(); int num_col1 = mat1.cols(); int num_col2 = mat2.cols(); tripletList.reserve(mat1.nonZeros() + mat2.nonZeros()); for(int i = 0; i < num_rows; i++){ std::string key = all_rownames[i]; if (mat1_map.count(key)){ for(Eigen::SparseMatrix::InnerIterator it1(mat1, mat1_map[key]); it1; ++it1){ tripletList.push_back(T(i, it1.col(), it1.value())); } } if (mat2_map.count(key)){ for(Eigen::SparseMatrix::InnerIterator it2(mat2, mat2_map[key]); it2; ++it2){ tripletList.push_back(T(i, num_col1 + it2.col(), it2.value())); } } } Eigen::SparseMatrix combined_mat(num_rows, num_col1 + num_col2); combined_mat.setFromTriplets(tripletList.begin(), tripletList.end()); return combined_mat; } // [[Rcpp::export]] Eigen::SparseMatrix LogNorm(Eigen::SparseMatrix data, int scale_factor, bool display_progress = true){ Progress p(data.outerSize(), display_progress); Eigen::VectorXd colSums = data.transpose() * Eigen::VectorXd::Ones(data.rows()); for (int k=0; k < data.outerSize(); ++k){ p.increment(); for (Eigen::SparseMatrix::InnerIterator it(data, k); it; ++it){ it.valueRef() = log1p(double(it.value()) / colSums[k] * scale_factor); } } return data; } /* Performs row scaling and/or centering. Equivalent to using t(scale(t(mat))) in R. Note: Doesn't handle NA/NaNs in the same way the R implementation does, */ // [[Rcpp::export]] Eigen::MatrixXd FastRowScale(Eigen::MatrixXd mat, bool scale = true, bool center = true, double scale_max = 10, bool display_progress = true){ Progress p(mat.rows(), display_progress); Eigen::MatrixXd scaled_mat(mat.rows(), mat.cols()); for(int i=0; i < mat.rows(); ++i){ p.increment(); Eigen::ArrayXd r = mat.row(i).array(); double rowMean = r.mean(); double rowSdev = 1; if(scale == true){ if(center == true){ rowSdev = sqrt((r - rowMean).square().sum() / (mat.cols() - 1)); } else{ rowSdev = sqrt(r.square().sum() / (mat.cols() - 1)); } } if(center == false){ rowMean = 0; } scaled_mat.row(i) = (r - rowMean) / rowSdev; for(int s=0; s scale_max){ scaled_mat(i, s) = scale_max; } } } return scaled_mat; } /* Performs column scaling and/or centering. Equivalent to using scale(mat, TRUE, apply(x,2,sd)) in R. Note: Doesn't handle NA/NaNs in the same way the R implementation does, */ // [[Rcpp::export]] NumericMatrix Standardize(Eigen::Map mat, bool display_progress = true){ Progress p(mat.cols(), display_progress); NumericMatrix std_mat(mat.rows(), mat.cols()); for(int i=0; i < mat.cols(); ++i){ p.increment(); Eigen::ArrayXd r = mat.col(i).array(); double colMean = r.mean(); double colSdev = sqrt((r - colMean).square().sum() / (mat.rows() - 1)); NumericMatrix::Column new_col = std_mat(_, i); for(int j=0; j < new_col.size(); j++) { new_col[j] = (r[j] - colMean) / colSdev; } } return std_mat; } // [[Rcpp::export]] Eigen::MatrixXd FastSparseRowScale(Eigen::SparseMatrix mat, bool scale = true, bool center = true, double scale_max = 10, bool display_progress = true){ mat = mat.transpose(); Progress p(mat.outerSize(), display_progress); Eigen::MatrixXd scaled_mat(mat.rows(), mat.cols()); for (int k=0; k::InnerIterator it(mat,k); it; ++it) { colMean += it.value(); } colMean = colMean / mat.rows(); if (scale == true){ int nnZero = 0; if(center == true){ for (Eigen::SparseMatrix::InnerIterator it(mat,k); it; ++it) { nnZero += 1; colSdev += pow((it.value() - colMean), 2); } colSdev += pow(colMean, 2) * (mat.rows() - nnZero); } else{ for (Eigen::SparseMatrix::InnerIterator it(mat,k); it; ++it) { colSdev += pow(it.value(), 2); } } colSdev = sqrt(colSdev / (mat.rows() - 1)); } else{ colSdev = 1; } if(center == false){ colMean = 0; } Eigen::VectorXd col = Eigen::VectorXd(mat.col(k)); scaled_mat.col(k) = (col.array() - colMean) / colSdev; for(int s=0; s scale_max){ scaled_mat(s,k) = scale_max; } } } return scaled_mat.transpose(); } // [[Rcpp::export]] Eigen::MatrixXd FastSparseRowScaleWithKnownStats(Eigen::SparseMatrix mat, NumericVector mu, NumericVector sigma, bool scale = true, bool center = true, double scale_max = 10, bool display_progress = true){ mat = mat.transpose(); Progress p(mat.outerSize(), display_progress); Eigen::MatrixXd scaled_mat(mat.rows(), mat.cols()); for (int k=0; k scale_max){ scaled_mat(s,k) = scale_max; } } } return scaled_mat.transpose(); } /* Note: May not handle NA/NaNs in the same way the R implementation does, */ // [[Rcpp::export]] Eigen::MatrixXd FastCov(Eigen::MatrixXd mat, bool center = true){ if (center) { mat = mat.rowwise() - mat.colwise().mean(); } Eigen::MatrixXd cov = (mat.adjoint() * mat) / double(mat.rows() - 1); return(cov); } // [[Rcpp::export]] Eigen::MatrixXd FastCovMats(Eigen::MatrixXd mat1, Eigen::MatrixXd mat2, bool center = true){ if(center){ mat1 = mat1.rowwise() - mat1.colwise().mean(); mat2 = mat2.rowwise() - mat2.colwise().mean(); } Eigen::MatrixXd cov = (mat1.adjoint() * mat2) / double(mat1.rows() - 1); return(cov); } /* Note: Faster than the R implementation but is not in-place */ //[[Rcpp::export]] Eigen::MatrixXd FastRBind(Eigen::MatrixXd mat1, Eigen::MatrixXd mat2){ Eigen::MatrixXd mat3(mat1.rows() + mat2.rows(), mat1.cols()); mat3 << mat1, mat2; return(mat3); } /* Calculates the row means of the logged values in non-log space */ //[[Rcpp::export]] Eigen::VectorXd FastExpMean(Eigen::SparseMatrix mat, bool display_progress){ int ncols = mat.cols(); Eigen::VectorXd rowmeans(mat.rows()); mat = mat.transpose(); if(display_progress == true){ Rcpp::Rcerr << "Calculating gene means" << std::endl; } Progress p(mat.outerSize(), display_progress); for (int k=0; k::InnerIterator it(mat,k); it; ++it){ rm += expm1(it.value()); } rm = rm / ncols; rowmeans[k] = log1p(rm); } return(rowmeans); } /* use this if you know the row means */ //[[Rcpp::export]] NumericVector SparseRowVar2(Eigen::SparseMatrix mat, NumericVector mu, bool display_progress){ mat = mat.transpose(); if(display_progress == true){ Rcpp::Rcerr << "Calculating gene variances" << std::endl; } Progress p(mat.outerSize(), display_progress); NumericVector allVars = no_init(mat.cols()); for (int k=0; k::InnerIterator it(mat,k); it; ++it) { nZero -= 1; colSum += pow(it.value() - mu[k], 2); } colSum += pow(mu[k], 2) * nZero; allVars[k] = colSum / (mat.rows() - 1); } return(allVars); } /* standardize matrix rows using given mean and standard deviation, clip values larger than vmax to vmax, then return variance for each row */ //[[Rcpp::export]] NumericVector SparseRowVarStd(Eigen::SparseMatrix mat, NumericVector mu, NumericVector sd, double vmax, bool display_progress){ if(display_progress == true){ Rcpp::Rcerr << "Calculating feature variances of standardized and clipped values" << std::endl; } mat = mat.transpose(); NumericVector allVars(mat.cols()); Progress p(mat.outerSize(), display_progress); for (int k=0; k::InnerIterator it(mat,k); it; ++it) { nZero -= 1; colSum += pow(std::min(vmax, (it.value() - mu[k]) / sd[k]), 2); } colSum += pow((0 - mu[k]) / sd[k], 2) * nZero; allVars[k] = colSum / (mat.rows() - 1); } return(allVars); } /* Calculate the variance to mean ratio (VMR) in non-logspace (return answer in log-space) */ //[[Rcpp::export]] Eigen::VectorXd FastLogVMR(Eigen::SparseMatrix mat, bool display_progress){ int ncols = mat.cols(); Eigen::VectorXd rowdisp(mat.rows()); mat = mat.transpose(); if(display_progress == true){ Rcpp::Rcerr << "Calculating gene variance to mean ratios" << std::endl; } Progress p(mat.outerSize(), display_progress); for (int k=0; k::InnerIterator it(mat,k); it; ++it){ rm += expm1(it.value()); } rm = rm / ncols; for (Eigen::SparseMatrix::InnerIterator it(mat,k); it; ++it){ v += pow(expm1(it.value()) - rm, 2); nnZero += 1; } v = (v + (ncols - nnZero) * pow(rm, 2)) / (ncols - 1); rowdisp[k] = log(v/rm); } return(rowdisp); } /* Calculates the variance of rows of a matrix */ //[[Rcpp::export]] NumericVector RowVar(Eigen::Map x){ NumericVector out(x.rows()); for(int i=0; i < x.rows(); ++i){ Eigen::ArrayXd r = x.row(i).array(); double rowMean = r.mean(); out[i] = (r - rowMean).square().sum() / (x.cols() - 1); } return out; } /* Calculate the variance in non-logspace (return answer in non-logspace) */ //[[Rcpp::export]] Eigen::VectorXd SparseRowVar(Eigen::SparseMatrix mat, bool display_progress){ int ncols = mat.cols(); Eigen::VectorXd rowdisp(mat.rows()); mat = mat.transpose(); if(display_progress == true){ Rcpp::Rcerr << "Calculating gene variances" << std::endl; } Progress p(mat.outerSize(), display_progress); for (int k=0; k::InnerIterator it(mat,k); it; ++it){ rm += (it.value()); } rm = rm / ncols; for (Eigen::SparseMatrix::InnerIterator it(mat,k); it; ++it){ v += pow((it.value()) - rm, 2); nnZero += 1; } v = (v + (ncols - nnZero) * pow(rm, 2)) / (ncols - 1); rowdisp[k] = v; } return(rowdisp); } //cols_idx should be 0-indexed //[[Rcpp::export]] Eigen::SparseMatrix ReplaceColsC(Eigen::SparseMatrix mat, NumericVector col_idx, Eigen::SparseMatrix replacement){ int rep_idx = 0; for(auto const &ci : col_idx){ mat.col(ci) = replacement.col(rep_idx); rep_idx += 1; } return(mat); } Seurat/src/snn.cpp0000644000176200001440000000434113527073365013623 0ustar liggesusers#include #include "data_manipulation.h" #include #include #include #include #include #include using namespace Rcpp; // [[Rcpp::depends(RcppEigen)]] // [[Rcpp::depends(RcppProgress)]] typedef Eigen::Triplet T; //[[Rcpp::export]] Eigen::SparseMatrix ComputeSNN(Eigen::MatrixXd nn_ranked, double prune) { std::vector tripletList; int k = nn_ranked.cols(); tripletList.reserve(nn_ranked.rows() * nn_ranked.cols()); for(int j=0; j SNN(nn_ranked.rows(), nn_ranked.rows()); SNN.setFromTriplets(tripletList.begin(), tripletList.end()); SNN = SNN * (SNN.transpose()); for (int i=0; i < SNN.outerSize(); ++i){ for (Eigen::SparseMatrix::InnerIterator it(SNN, i); it; ++it){ it.valueRef() = it.value()/(k + (k - it.value())); if(it.value() < prune){ it.valueRef() = 0; } } } SNN.prune(0.0); // actually remove pruned values return SNN; } //[[Rcpp::export]] void WriteEdgeFile(Eigen::SparseMatrix snn, String filename, bool display_progress){ if (display_progress == true) { Rcpp::Rcerr << "Writing SNN as edge file" << std::endl; } // Write out lower triangle std::ofstream output; output.open(filename); Progress p(snn.outerSize(), display_progress); for (int k=0; k < snn.outerSize(); ++k){ p.increment(); for (Eigen::SparseMatrix::InnerIterator it(snn, k); it; ++it){ if(it.col() >= it.row()){ continue; } output << std::setprecision(15) << it.col() << "\t" << it.row() << "\t" << it.value() << "\n"; } } output.close(); } // Wrapper function so that we don't have to go back into R before writing to file //[[Rcpp::export]] Eigen::SparseMatrix DirectSNNToFile(Eigen::MatrixXd nn_ranked, double prune, bool display_progress, String filename) { Eigen::SparseMatrix SNN = ComputeSNN(nn_ranked, prune); WriteEdgeFile(SNN, filename, display_progress); return SNN; } Seurat/src/RcppExports.cpp0000644000176200001440000005222613617631656015326 0ustar liggesusers// Generated by using Rcpp::compileAttributes() -> do not edit by hand // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 #include #include using namespace Rcpp; // RunModularityClusteringCpp IntegerVector RunModularityClusteringCpp(Eigen::SparseMatrix SNN, int modularityFunction, double resolution, int algorithm, int nRandomStarts, int nIterations, int randomSeed, bool printOutput, std::string edgefilename); RcppExport SEXP _Seurat_RunModularityClusteringCpp(SEXP SNNSEXP, SEXP modularityFunctionSEXP, SEXP resolutionSEXP, SEXP algorithmSEXP, SEXP nRandomStartsSEXP, SEXP nIterationsSEXP, SEXP randomSeedSEXP, SEXP printOutputSEXP, SEXP edgefilenameSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type SNN(SNNSEXP); Rcpp::traits::input_parameter< int >::type modularityFunction(modularityFunctionSEXP); Rcpp::traits::input_parameter< double >::type resolution(resolutionSEXP); Rcpp::traits::input_parameter< int >::type algorithm(algorithmSEXP); Rcpp::traits::input_parameter< int >::type nRandomStarts(nRandomStartsSEXP); Rcpp::traits::input_parameter< int >::type nIterations(nIterationsSEXP); Rcpp::traits::input_parameter< int >::type randomSeed(randomSeedSEXP); Rcpp::traits::input_parameter< bool >::type printOutput(printOutputSEXP); Rcpp::traits::input_parameter< std::string >::type edgefilename(edgefilenameSEXP); rcpp_result_gen = Rcpp::wrap(RunModularityClusteringCpp(SNN, modularityFunction, resolution, algorithm, nRandomStarts, nIterations, randomSeed, printOutput, edgefilename)); return rcpp_result_gen; END_RCPP } // RunUMISampling Eigen::SparseMatrix RunUMISampling(Eigen::SparseMatrix data, int sample_val, bool upsample, bool display_progress); RcppExport SEXP _Seurat_RunUMISampling(SEXP dataSEXP, SEXP sample_valSEXP, SEXP upsampleSEXP, SEXP display_progressSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type data(dataSEXP); Rcpp::traits::input_parameter< int >::type sample_val(sample_valSEXP); Rcpp::traits::input_parameter< bool >::type upsample(upsampleSEXP); Rcpp::traits::input_parameter< bool >::type display_progress(display_progressSEXP); rcpp_result_gen = Rcpp::wrap(RunUMISampling(data, sample_val, upsample, display_progress)); return rcpp_result_gen; END_RCPP } // RunUMISamplingPerCell Eigen::SparseMatrix RunUMISamplingPerCell(Eigen::SparseMatrix data, NumericVector sample_val, bool upsample, bool display_progress); RcppExport SEXP _Seurat_RunUMISamplingPerCell(SEXP dataSEXP, SEXP sample_valSEXP, SEXP upsampleSEXP, SEXP display_progressSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type data(dataSEXP); Rcpp::traits::input_parameter< NumericVector >::type sample_val(sample_valSEXP); Rcpp::traits::input_parameter< bool >::type upsample(upsampleSEXP); Rcpp::traits::input_parameter< bool >::type display_progress(display_progressSEXP); rcpp_result_gen = Rcpp::wrap(RunUMISamplingPerCell(data, sample_val, upsample, display_progress)); return rcpp_result_gen; END_RCPP } // RowMergeMatrices Eigen::SparseMatrix RowMergeMatrices(Eigen::SparseMatrix mat1, Eigen::SparseMatrix mat2, std::vector< std::string > mat1_rownames, std::vector< std::string > mat2_rownames, std::vector< std::string > all_rownames); RcppExport SEXP _Seurat_RowMergeMatrices(SEXP mat1SEXP, SEXP mat2SEXP, SEXP mat1_rownamesSEXP, SEXP mat2_rownamesSEXP, SEXP all_rownamesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type mat1(mat1SEXP); Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type mat2(mat2SEXP); Rcpp::traits::input_parameter< std::vector< std::string > >::type mat1_rownames(mat1_rownamesSEXP); Rcpp::traits::input_parameter< std::vector< std::string > >::type mat2_rownames(mat2_rownamesSEXP); Rcpp::traits::input_parameter< std::vector< std::string > >::type all_rownames(all_rownamesSEXP); rcpp_result_gen = Rcpp::wrap(RowMergeMatrices(mat1, mat2, mat1_rownames, mat2_rownames, all_rownames)); return rcpp_result_gen; END_RCPP } // LogNorm Eigen::SparseMatrix LogNorm(Eigen::SparseMatrix data, int scale_factor, bool display_progress); RcppExport SEXP _Seurat_LogNorm(SEXP dataSEXP, SEXP scale_factorSEXP, SEXP display_progressSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type data(dataSEXP); Rcpp::traits::input_parameter< int >::type scale_factor(scale_factorSEXP); Rcpp::traits::input_parameter< bool >::type display_progress(display_progressSEXP); rcpp_result_gen = Rcpp::wrap(LogNorm(data, scale_factor, display_progress)); return rcpp_result_gen; END_RCPP } // FastRowScale Eigen::MatrixXd FastRowScale(Eigen::MatrixXd mat, bool scale, bool center, double scale_max, bool display_progress); RcppExport SEXP _Seurat_FastRowScale(SEXP matSEXP, SEXP scaleSEXP, SEXP centerSEXP, SEXP scale_maxSEXP, SEXP display_progressSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::MatrixXd >::type mat(matSEXP); Rcpp::traits::input_parameter< bool >::type scale(scaleSEXP); Rcpp::traits::input_parameter< bool >::type center(centerSEXP); Rcpp::traits::input_parameter< double >::type scale_max(scale_maxSEXP); Rcpp::traits::input_parameter< bool >::type display_progress(display_progressSEXP); rcpp_result_gen = Rcpp::wrap(FastRowScale(mat, scale, center, scale_max, display_progress)); return rcpp_result_gen; END_RCPP } // Standardize NumericMatrix Standardize(Eigen::Map mat, bool display_progress); RcppExport SEXP _Seurat_Standardize(SEXP matSEXP, SEXP display_progressSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::Map >::type mat(matSEXP); Rcpp::traits::input_parameter< bool >::type display_progress(display_progressSEXP); rcpp_result_gen = Rcpp::wrap(Standardize(mat, display_progress)); return rcpp_result_gen; END_RCPP } // FastSparseRowScale Eigen::MatrixXd FastSparseRowScale(Eigen::SparseMatrix mat, bool scale, bool center, double scale_max, bool display_progress); RcppExport SEXP _Seurat_FastSparseRowScale(SEXP matSEXP, SEXP scaleSEXP, SEXP centerSEXP, SEXP scale_maxSEXP, SEXP display_progressSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type mat(matSEXP); Rcpp::traits::input_parameter< bool >::type scale(scaleSEXP); Rcpp::traits::input_parameter< bool >::type center(centerSEXP); Rcpp::traits::input_parameter< double >::type scale_max(scale_maxSEXP); Rcpp::traits::input_parameter< bool >::type display_progress(display_progressSEXP); rcpp_result_gen = Rcpp::wrap(FastSparseRowScale(mat, scale, center, scale_max, display_progress)); return rcpp_result_gen; END_RCPP } // FastSparseRowScaleWithKnownStats Eigen::MatrixXd FastSparseRowScaleWithKnownStats(Eigen::SparseMatrix mat, NumericVector mu, NumericVector sigma, bool scale, bool center, double scale_max, bool display_progress); RcppExport SEXP _Seurat_FastSparseRowScaleWithKnownStats(SEXP matSEXP, SEXP muSEXP, SEXP sigmaSEXP, SEXP scaleSEXP, SEXP centerSEXP, SEXP scale_maxSEXP, SEXP display_progressSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type mat(matSEXP); Rcpp::traits::input_parameter< NumericVector >::type mu(muSEXP); Rcpp::traits::input_parameter< NumericVector >::type sigma(sigmaSEXP); Rcpp::traits::input_parameter< bool >::type scale(scaleSEXP); Rcpp::traits::input_parameter< bool >::type center(centerSEXP); Rcpp::traits::input_parameter< double >::type scale_max(scale_maxSEXP); Rcpp::traits::input_parameter< bool >::type display_progress(display_progressSEXP); rcpp_result_gen = Rcpp::wrap(FastSparseRowScaleWithKnownStats(mat, mu, sigma, scale, center, scale_max, display_progress)); return rcpp_result_gen; END_RCPP } // FastCov Eigen::MatrixXd FastCov(Eigen::MatrixXd mat, bool center); RcppExport SEXP _Seurat_FastCov(SEXP matSEXP, SEXP centerSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::MatrixXd >::type mat(matSEXP); Rcpp::traits::input_parameter< bool >::type center(centerSEXP); rcpp_result_gen = Rcpp::wrap(FastCov(mat, center)); return rcpp_result_gen; END_RCPP } // FastCovMats Eigen::MatrixXd FastCovMats(Eigen::MatrixXd mat1, Eigen::MatrixXd mat2, bool center); RcppExport SEXP _Seurat_FastCovMats(SEXP mat1SEXP, SEXP mat2SEXP, SEXP centerSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::MatrixXd >::type mat1(mat1SEXP); Rcpp::traits::input_parameter< Eigen::MatrixXd >::type mat2(mat2SEXP); Rcpp::traits::input_parameter< bool >::type center(centerSEXP); rcpp_result_gen = Rcpp::wrap(FastCovMats(mat1, mat2, center)); return rcpp_result_gen; END_RCPP } // FastRBind Eigen::MatrixXd FastRBind(Eigen::MatrixXd mat1, Eigen::MatrixXd mat2); RcppExport SEXP _Seurat_FastRBind(SEXP mat1SEXP, SEXP mat2SEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::MatrixXd >::type mat1(mat1SEXP); Rcpp::traits::input_parameter< Eigen::MatrixXd >::type mat2(mat2SEXP); rcpp_result_gen = Rcpp::wrap(FastRBind(mat1, mat2)); return rcpp_result_gen; END_RCPP } // FastExpMean Eigen::VectorXd FastExpMean(Eigen::SparseMatrix mat, bool display_progress); RcppExport SEXP _Seurat_FastExpMean(SEXP matSEXP, SEXP display_progressSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type mat(matSEXP); Rcpp::traits::input_parameter< bool >::type display_progress(display_progressSEXP); rcpp_result_gen = Rcpp::wrap(FastExpMean(mat, display_progress)); return rcpp_result_gen; END_RCPP } // SparseRowVar2 NumericVector SparseRowVar2(Eigen::SparseMatrix mat, NumericVector mu, bool display_progress); RcppExport SEXP _Seurat_SparseRowVar2(SEXP matSEXP, SEXP muSEXP, SEXP display_progressSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type mat(matSEXP); Rcpp::traits::input_parameter< NumericVector >::type mu(muSEXP); Rcpp::traits::input_parameter< bool >::type display_progress(display_progressSEXP); rcpp_result_gen = Rcpp::wrap(SparseRowVar2(mat, mu, display_progress)); return rcpp_result_gen; END_RCPP } // SparseRowVarStd NumericVector SparseRowVarStd(Eigen::SparseMatrix mat, NumericVector mu, NumericVector sd, double vmax, bool display_progress); RcppExport SEXP _Seurat_SparseRowVarStd(SEXP matSEXP, SEXP muSEXP, SEXP sdSEXP, SEXP vmaxSEXP, SEXP display_progressSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type mat(matSEXP); Rcpp::traits::input_parameter< NumericVector >::type mu(muSEXP); Rcpp::traits::input_parameter< NumericVector >::type sd(sdSEXP); Rcpp::traits::input_parameter< double >::type vmax(vmaxSEXP); Rcpp::traits::input_parameter< bool >::type display_progress(display_progressSEXP); rcpp_result_gen = Rcpp::wrap(SparseRowVarStd(mat, mu, sd, vmax, display_progress)); return rcpp_result_gen; END_RCPP } // FastLogVMR Eigen::VectorXd FastLogVMR(Eigen::SparseMatrix mat, bool display_progress); RcppExport SEXP _Seurat_FastLogVMR(SEXP matSEXP, SEXP display_progressSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type mat(matSEXP); Rcpp::traits::input_parameter< bool >::type display_progress(display_progressSEXP); rcpp_result_gen = Rcpp::wrap(FastLogVMR(mat, display_progress)); return rcpp_result_gen; END_RCPP } // RowVar NumericVector RowVar(Eigen::Map x); RcppExport SEXP _Seurat_RowVar(SEXP xSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::Map >::type x(xSEXP); rcpp_result_gen = Rcpp::wrap(RowVar(x)); return rcpp_result_gen; END_RCPP } // SparseRowVar Eigen::VectorXd SparseRowVar(Eigen::SparseMatrix mat, bool display_progress); RcppExport SEXP _Seurat_SparseRowVar(SEXP matSEXP, SEXP display_progressSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type mat(matSEXP); Rcpp::traits::input_parameter< bool >::type display_progress(display_progressSEXP); rcpp_result_gen = Rcpp::wrap(SparseRowVar(mat, display_progress)); return rcpp_result_gen; END_RCPP } // ReplaceColsC Eigen::SparseMatrix ReplaceColsC(Eigen::SparseMatrix mat, NumericVector col_idx, Eigen::SparseMatrix replacement); RcppExport SEXP _Seurat_ReplaceColsC(SEXP matSEXP, SEXP col_idxSEXP, SEXP replacementSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type mat(matSEXP); Rcpp::traits::input_parameter< NumericVector >::type col_idx(col_idxSEXP); Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type replacement(replacementSEXP); rcpp_result_gen = Rcpp::wrap(ReplaceColsC(mat, col_idx, replacement)); return rcpp_result_gen; END_RCPP } // FindWeightsC Eigen::SparseMatrix FindWeightsC(Eigen::SparseMatrix integration_matrix, NumericVector cells2, Eigen::MatrixXd distances, std::vector anchor_cells2, std::vector integration_matrix_rownames, Eigen::MatrixXd cell_index, Eigen::VectorXd anchor_score, double min_dist, double sd, bool display_progress); RcppExport SEXP _Seurat_FindWeightsC(SEXP integration_matrixSEXP, SEXP cells2SEXP, SEXP distancesSEXP, SEXP anchor_cells2SEXP, SEXP integration_matrix_rownamesSEXP, SEXP cell_indexSEXP, SEXP anchor_scoreSEXP, SEXP min_distSEXP, SEXP sdSEXP, SEXP display_progressSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type integration_matrix(integration_matrixSEXP); Rcpp::traits::input_parameter< NumericVector >::type cells2(cells2SEXP); Rcpp::traits::input_parameter< Eigen::MatrixXd >::type distances(distancesSEXP); Rcpp::traits::input_parameter< std::vector >::type anchor_cells2(anchor_cells2SEXP); Rcpp::traits::input_parameter< std::vector >::type integration_matrix_rownames(integration_matrix_rownamesSEXP); Rcpp::traits::input_parameter< Eigen::MatrixXd >::type cell_index(cell_indexSEXP); Rcpp::traits::input_parameter< Eigen::VectorXd >::type anchor_score(anchor_scoreSEXP); Rcpp::traits::input_parameter< double >::type min_dist(min_distSEXP); Rcpp::traits::input_parameter< double >::type sd(sdSEXP); Rcpp::traits::input_parameter< bool >::type display_progress(display_progressSEXP); rcpp_result_gen = Rcpp::wrap(FindWeightsC(integration_matrix, cells2, distances, anchor_cells2, integration_matrix_rownames, cell_index, anchor_score, min_dist, sd, display_progress)); return rcpp_result_gen; END_RCPP } // IntegrateDataC Eigen::SparseMatrix IntegrateDataC(Eigen::SparseMatrix integration_matrix, Eigen::SparseMatrix weights, Eigen::SparseMatrix expression_cells2); RcppExport SEXP _Seurat_IntegrateDataC(SEXP integration_matrixSEXP, SEXP weightsSEXP, SEXP expression_cells2SEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type integration_matrix(integration_matrixSEXP); Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type weights(weightsSEXP); Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type expression_cells2(expression_cells2SEXP); rcpp_result_gen = Rcpp::wrap(IntegrateDataC(integration_matrix, weights, expression_cells2)); return rcpp_result_gen; END_RCPP } // SNNAnchor Eigen::SparseMatrix SNNAnchor(Eigen::SparseMatrix k_matrix, Eigen::SparseMatrix anchor_only); RcppExport SEXP _Seurat_SNNAnchor(SEXP k_matrixSEXP, SEXP anchor_onlySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type k_matrix(k_matrixSEXP); Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type anchor_only(anchor_onlySEXP); rcpp_result_gen = Rcpp::wrap(SNNAnchor(k_matrix, anchor_only)); return rcpp_result_gen; END_RCPP } // ComputeSNN Eigen::SparseMatrix ComputeSNN(Eigen::MatrixXd nn_ranked, double prune); RcppExport SEXP _Seurat_ComputeSNN(SEXP nn_rankedSEXP, SEXP pruneSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::MatrixXd >::type nn_ranked(nn_rankedSEXP); Rcpp::traits::input_parameter< double >::type prune(pruneSEXP); rcpp_result_gen = Rcpp::wrap(ComputeSNN(nn_ranked, prune)); return rcpp_result_gen; END_RCPP } // WriteEdgeFile void WriteEdgeFile(Eigen::SparseMatrix snn, String filename, bool display_progress); RcppExport SEXP _Seurat_WriteEdgeFile(SEXP snnSEXP, SEXP filenameSEXP, SEXP display_progressSEXP) { BEGIN_RCPP Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::SparseMatrix >::type snn(snnSEXP); Rcpp::traits::input_parameter< String >::type filename(filenameSEXP); Rcpp::traits::input_parameter< bool >::type display_progress(display_progressSEXP); WriteEdgeFile(snn, filename, display_progress); return R_NilValue; END_RCPP } // DirectSNNToFile Eigen::SparseMatrix DirectSNNToFile(Eigen::MatrixXd nn_ranked, double prune, bool display_progress, String filename); RcppExport SEXP _Seurat_DirectSNNToFile(SEXP nn_rankedSEXP, SEXP pruneSEXP, SEXP display_progressSEXP, SEXP filenameSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Eigen::MatrixXd >::type nn_ranked(nn_rankedSEXP); Rcpp::traits::input_parameter< double >::type prune(pruneSEXP); Rcpp::traits::input_parameter< bool >::type display_progress(display_progressSEXP); Rcpp::traits::input_parameter< String >::type filename(filenameSEXP); rcpp_result_gen = Rcpp::wrap(DirectSNNToFile(nn_ranked, prune, display_progress, filename)); return rcpp_result_gen; END_RCPP } static const R_CallMethodDef CallEntries[] = { {"_Seurat_RunModularityClusteringCpp", (DL_FUNC) &_Seurat_RunModularityClusteringCpp, 9}, {"_Seurat_RunUMISampling", (DL_FUNC) &_Seurat_RunUMISampling, 4}, {"_Seurat_RunUMISamplingPerCell", (DL_FUNC) &_Seurat_RunUMISamplingPerCell, 4}, {"_Seurat_RowMergeMatrices", (DL_FUNC) &_Seurat_RowMergeMatrices, 5}, {"_Seurat_LogNorm", (DL_FUNC) &_Seurat_LogNorm, 3}, {"_Seurat_FastRowScale", (DL_FUNC) &_Seurat_FastRowScale, 5}, {"_Seurat_Standardize", (DL_FUNC) &_Seurat_Standardize, 2}, {"_Seurat_FastSparseRowScale", (DL_FUNC) &_Seurat_FastSparseRowScale, 5}, {"_Seurat_FastSparseRowScaleWithKnownStats", (DL_FUNC) &_Seurat_FastSparseRowScaleWithKnownStats, 7}, {"_Seurat_FastCov", (DL_FUNC) &_Seurat_FastCov, 2}, {"_Seurat_FastCovMats", (DL_FUNC) &_Seurat_FastCovMats, 3}, {"_Seurat_FastRBind", (DL_FUNC) &_Seurat_FastRBind, 2}, {"_Seurat_FastExpMean", (DL_FUNC) &_Seurat_FastExpMean, 2}, {"_Seurat_SparseRowVar2", (DL_FUNC) &_Seurat_SparseRowVar2, 3}, {"_Seurat_SparseRowVarStd", (DL_FUNC) &_Seurat_SparseRowVarStd, 5}, {"_Seurat_FastLogVMR", (DL_FUNC) &_Seurat_FastLogVMR, 2}, {"_Seurat_RowVar", (DL_FUNC) &_Seurat_RowVar, 1}, {"_Seurat_SparseRowVar", (DL_FUNC) &_Seurat_SparseRowVar, 2}, {"_Seurat_ReplaceColsC", (DL_FUNC) &_Seurat_ReplaceColsC, 3}, {"_Seurat_FindWeightsC", (DL_FUNC) &_Seurat_FindWeightsC, 10}, {"_Seurat_IntegrateDataC", (DL_FUNC) &_Seurat_IntegrateDataC, 3}, {"_Seurat_SNNAnchor", (DL_FUNC) &_Seurat_SNNAnchor, 2}, {"_Seurat_ComputeSNN", (DL_FUNC) &_Seurat_ComputeSNN, 2}, {"_Seurat_WriteEdgeFile", (DL_FUNC) &_Seurat_WriteEdgeFile, 3}, {"_Seurat_DirectSNNToFile", (DL_FUNC) &_Seurat_DirectSNNToFile, 4}, {NULL, NULL, 0} }; RcppExport void R_init_Seurat(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } Seurat/src/RModularityOptimizer.cpp0000644000176200001440000001262713527073365017211 0ustar liggesusers#include #include #include #include #include #include #include #include #include #include #include "ModularityOptimizer.h" using namespace ModularityOptimizer; using namespace std::chrono; using namespace Rcpp; // [[Rcpp::depends(RcppEigen)]] // [[Rcpp::depends(RcppProgress)]] // [[Rcpp::export]] IntegerVector RunModularityClusteringCpp(Eigen::SparseMatrix SNN, int modularityFunction, double resolution, int algorithm, int nRandomStarts, int nIterations, int randomSeed, bool printOutput, std::string edgefilename) { // validate arguments if(modularityFunction != 1 && modularityFunction != 2) stop("Modularity parameter must be equal to 1 or 2."); if(algorithm != 1 && algorithm !=2 && algorithm !=3 && algorithm !=4) stop("Algorithm for modularity optimization must be 1, 2, 3, or 4"); if(nRandomStarts < 1) stop("Have to have at least one start"); if(nIterations < 1) stop("Need at least one interation"); if (modularityFunction == 2 && resolution > 1.0) stop("error: resolution<1 for alternative modularity"); try { bool update; double modularity, maxModularity, resolution2; int i, j; std::string msg = "Modularity Optimizer version 1.3.0 by Ludo Waltman and Nees Jan van Eck"; if (printOutput) Rcout << msg << std::endl << std::endl; // Load netwrok std::shared_ptr network; if(edgefilename != "") { if (printOutput) Rcout << "Reading input file..." << std::endl << std::endl; try{ network = readInputFile(edgefilename, modularityFunction); } catch(...) { stop("Could not parse edge file."); } } else { // Load lower triangle int network_size = (SNN.nonZeros() / 2) + 3; IVector node1; IVector node2; DVector edgeweights; node1.reserve(network_size); node2.reserve(network_size); edgeweights.reserve(network_size); for (int k=0; k < SNN.outerSize(); ++k){ for (Eigen::SparseMatrix::InnerIterator it(SNN, k); it; ++it){ if(it.col() >= it.row()){ continue; } node1.emplace_back(it.col()); node2.emplace_back(it.row()); edgeweights.emplace_back(it.value()); } } if(node1.size() == 0) { stop("Matrix contained no network data. Check format."); } network = matrixToNetwork(node1, node2, edgeweights, modularityFunction); Rcpp::checkUserInterrupt(); } if (printOutput) { Rprintf("Number of nodes: %d\n", network->getNNodes()); Rprintf("Number of edges: %d\n", network->getNEdges()); Rcout << std::endl; Rcout << "Running " << ((algorithm == 1) ? "Louvain algorithm" : ((algorithm == 2) ? "Louvain algorithm with multilevel refinement" : "smart local moving algorithm")) << "..."; Rcout << std::endl; } resolution2 = ((modularityFunction == 1) ? (resolution / (2 * network->getTotalEdgeWeight() + network->getTotalEdgeWeightSelfLinks())) : resolution); auto beginTime = duration_cast(system_clock::now().time_since_epoch()); std::shared_ptr clustering; maxModularity = -std::numeric_limits::infinity(); JavaRandom random(randomSeed); Progress p(nRandomStarts, printOutput); for (i = 0; i < nRandomStarts; i++) { //if (printOutput && (nRandomStarts > 1)) //Rprintf("Random start: %d\n", i + 1); VOSClusteringTechnique vosClusteringTechnique(network, resolution2); j = 0; update = true; do { /*if (printOutput && (nIterations > 1)) Rprintf("Iteration: %d\n", j + 1); */ if (algorithm == 1) update = vosClusteringTechnique.runLouvainAlgorithm(random); else if (algorithm == 2) update = vosClusteringTechnique.runLouvainAlgorithmWithMultilevelRefinement(random); else if (algorithm == 3) vosClusteringTechnique.runSmartLocalMovingAlgorithm(random); j++; modularity = vosClusteringTechnique.calcQualityFunction(); //if (printOutput && (nIterations > 1)) // Rprintf("Modularity: %.4f\n", modularity); Rcpp::checkUserInterrupt(); } while ((j < nIterations) && update); if (modularity > maxModularity) { clustering = vosClusteringTechnique.getClustering(); maxModularity = modularity; } /*if (printOutput && (nRandomStarts > 1)) { if (nIterations == 1) Rprintf("Modularity: %.4f\n", modularity); Rcout << std::endl; }*/ p.increment(); } auto endTime = duration_cast(system_clock::now().time_since_epoch()); if(clustering == nullptr) { stop("Clustering step failed."); } if (printOutput) { if (nRandomStarts == 1) { if (nIterations > 1) Rcout << std::endl; Rprintf("Modularity: %.4f\n", maxModularity); } else Rprintf("Maximum modularity in %d random starts: %.4f\n", nRandomStarts, maxModularity); Rprintf("Number of communities: %d\n", clustering->getNClusters()); Rprintf("Elapsed time: %d seconds\n", static_cast((endTime - beginTime).count() / 1000.0)); } // Return results clustering->orderClustersByNNodes(); IntegerVector iv(clustering->cluster.cbegin(), clustering->cluster.cend()); return iv; } catch(std::exception &ex) { forward_exception_to_r(ex); } catch(...) { ::Rf_error("c++ exception (unknown reason)"); } return IntegerVector(1); } Seurat/src/snn.h0000644000176200001440000000117213527073365013267 0ustar liggesusers#ifndef SNN #define SNN #include #include "data_manipulation.h" #include #include #include #include #include #include using namespace Rcpp; //---------------------------------------------------- Eigen::SparseMatrix ComputeSNN(Eigen::MatrixXd nn_ranked); void WriteEdgeFile(Eigen::SparseMatrix snn, String filename, bool display_progress); Eigen::SparseMatrix DirectSNNToFile(Eigen::MatrixXd nn_ranked, double prune, bool display_progress, String filename); //---------------------------------------------------- #endif//SNN Seurat/R/0000755000176200001440000000000013620136016011714 5ustar liggesusersSeurat/R/objects.R0000644000176200001440000070736213617623374013525 0ustar liggesusers#' @include generics.R #' @importFrom Rcpp evalCpp #' @importFrom Matrix colSums rowSums colMeans rowMeans #' @importFrom methods setClass setOldClass setClassUnion slot #' slot<- setMethod new signature slotNames is #' @importClassesFrom Matrix dgCMatrix #' @useDynLib Seurat #' NULL #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Class definitions #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% setOldClass(Classes = 'package_version') setClassUnion(name = 'AnyMatrix', members = c("matrix", "dgCMatrix")) setClassUnion(name = 'OptionalCharacter', members = c('NULL', 'character')) #' The AnchorSet Class #' #' The AnchorSet class is an intermediate data storage class that stores the anchors and other #' related information needed for performing downstream analyses - namely data integration #' (\code{\link{IntegrateData}}) and data transfer (\code{\link{TransferData}}). #' #' @slot object.list List of objects used to create anchors #' @slot reference.cells List of cell names in the reference dataset - needed when performing data #' transfer. #' @slot reference.objects Position of reference object/s in object.list #' @slot query.cells List of cell names in the query dataset - needed when performing data transfer #' @slot anchors The anchor matrix. This contains the cell indices of both anchor pair cells, the #' anchor score, and the index of the original dataset in the object.list for cell1 and cell2 of #' the anchor. #' @slot offsets The offsets used to enable cell look up in downstream functions #' @slot anchor.features The features used when performing anchor finding. #' @slot command Store log of parameters that were used #' #' @name AnchorSet-class #' @rdname AnchorSet-class #' @exportClass AnchorSet #' AnchorSet <- setClass( Class = "AnchorSet", slots = list( object.list = "list", reference.cells = "vector", reference.objects = "vector", query.cells = "vector", anchors = "ANY", offsets = "ANY", anchor.features = "ANY", command = "ANY" ) ) #' The Assay Class #' #' The Assay object is the basic unit of Seurat; each Assay stores raw, normalized, and scaled data #' as well as cluster information, variable features, and any other assay-specific metadata. #' Assays should contain single cell expression data such as RNA-seq, protein, or imputed expression #' data. #' #' @slot counts Unnormalized data such as raw counts or TPMs #' @slot data Normalized expression data #' @slot scale.data Scaled expression data #' @slot key Key for the Assay #' @slot assay.orig Original assay that this assay is based off of. Used to track #' assay provenence #' @slot var.features Vector of features exhibiting high variance across single cells #' @slot meta.features Feature-level metadata #' @slot misc Utility slot for storing additional data associated with the assay #' #' @name Assay-class #' @rdname Assay-class #' @exportClass Assay #' Assay <- setClass( Class = 'Assay', slots = c( counts = 'AnyMatrix', data = 'AnyMatrix', scale.data = 'matrix', key = 'character', assay.orig = 'OptionalCharacter', var.features = 'vector', meta.features = 'data.frame', misc = 'ANY' ) ) #' The JackStrawData Class #' #' The JackStrawData is used to store the results of a JackStraw computation. #' #' @slot empirical.p.values Empirical p-values #' @slot fake.reduction.scores Fake reduction scores #' @slot empirical.p.values.full Empirical p-values on full #' @slot overall.p.values Overall p-values from ScoreJackStraw #' #' @name JackStrawData-class #' @rdname JackStrawData-class #' @exportClass JackStrawData #' JackStrawData <- setClass( Class = "JackStrawData", slots = list( empirical.p.values = "matrix", fake.reduction.scores = "matrix", empirical.p.values.full = "matrix", overall.p.values = "matrix" ) ) #' The Dimmensional Reduction Class #' #' The DimReduc object stores a dimensionality reduction taken out in Seurat; each DimReduc #' consists of a cell embeddings matrix, a feature loadings matrix, and a projected feature #' loadings matrix. #' #' @slot cell.embeddings Cell embeddings matrix (required) #' @slot feature.loadings Feature loadings matrix (optional) #' @slot feature.loadings.projected Projected feature loadings matrix (optional) #' @slot assay.used Name of assay used to generate \code{DimReduc} object #' @slot global Is this \code{DimReduc} global/persistent? If so, it will not be #' removed when removing its associated assay #' @slot stdev A vector of standard deviations #' @slot key Key for the \code{DimReduc}, must be alphanumerics followed by an underscore #' @slot jackstraw A \code{\link{JackStrawData-class}} object associated with #' this \code{DimReduc} #' @slot misc Utility slot for storing additional data associated with the #' \code{DimReduc} (e.g. the total variance of the PCA) #' #' @name DimReduc-class #' @rdname DimReduc-class #' @exportClass DimReduc #' DimReduc <- setClass( Class = 'DimReduc', slots = c( cell.embeddings = 'matrix', feature.loadings = 'matrix', feature.loadings.projected = 'matrix', assay.used = 'character', global = 'logical', stdev = 'numeric', key = 'character', jackstraw = 'JackStrawData', misc = 'list' ) ) #' The Graph Class #' #' The Graph class inherits from dgCMatrix. We do this to enable future expandability of graphs. #' #' @slot assay.used Optional name of assay used to generate \code{Graph} object #' #' @name Graph-class #' @rdname Graph-class #' @exportClass Graph #' #' @seealso \code{\link[Matrix]{dgCMatrix-class}} #' Graph <- setClass( Class = 'Graph', contains = "dgCMatrix", slots = list( assay.used = 'OptionalCharacter' ) ) #' The IntegrationData Class #' #' The IntegrationData object is an intermediate storage container used internally throughout the #' integration procedure to hold bits of data that are useful downstream. #' #' @slot neighbors List of neighborhood information for cells (outputs of \code{RANN::nn2}) #' @slot weights Anchor weight matrix #' @slot integration.matrix Integration matrix #' @slot anchors Anchor matrix #' @slot offsets The offsets used to enable cell look up in downstream functions #' @slot objects.ncell Number of cells in each object in the object.list #' @slot sample.tree Sample tree used for ordering multi-dataset integration #' #' @name IntegrationData-class #' @rdname IntegrationData-class #' @exportClass IntegrationData #' IntegrationData <- setClass( Class = "IntegrationData", slots = list( neighbors = "ANY", weights = "ANY", integration.matrix = "ANY", anchors = "ANY", offsets = "ANY", objects.ncell = "ANY", sample.tree = "ANY" ) ) #' The SeuratCommand Class #' #' The SeuratCommand is used for logging commands that are run on a SeuratObject. It stores parameters and timestamps #' #' @slot name Command name #' @slot time.stamp Timestamp of when command was tun #' @slot assay.used Optional name of assay used to generate \code{SeuratCommand} object #' @slot call.string String of the command call #' @slot params List of parameters used in the command call #' #' @name SeuratCommand-class #' @rdname SeuratCommand-class #' @exportClass SeuratCommand #' SeuratCommand <- setClass( Class = 'SeuratCommand', slots = c( name = 'character', time.stamp = 'POSIXct', assay.used = 'OptionalCharacter', call.string = 'character', params = 'ANY' ) ) #' The Seurat Class #' #' The Seurat object is a representation of single-cell expression data for R; each Seurat #' object revolves around a set of cells and consists of one or more \code{\link{Assay-class}} #' objects, or individual representations of expression data (eg. RNA-seq, ATAC-seq, etc). #' These assays can be reduced from their high-dimensional state to a lower-dimension state #' and stored as \code{\link{DimReduc-class}} objects. Seurat objects also store additional #' meta data, both at the cell and feature level (contained within individual assays). The #' object was designed to be as self-contained as possible, and easily extendible to new methods. #' #' @slot assays A list of assays for this project #' @slot meta.data Contains meta-information about each cell, starting with number of genes detected (nGene) #' and the original identity class (orig.ident); more information is added using \code{AddMetaData} #' @slot active.assay Name of the active, or default, assay; settable using \code{\link{DefaultAssay}} #' @slot active.ident The active cluster identity for this Seurat object; settable using \code{\link{Idents}} #' @slot graphs A list of \code{\link{Graph-class}} objects #' @slot neighbors ... #' @slot reductions A list of dimmensional reduction objects for this object #' @slot project.name Name of the project #' @slot misc A list of miscellaneous information #' @slot version Version of Seurat this object was built under #' @slot commands A list of logged commands run on this \code{Seurat} object #' @slot tools A list of miscellaneous data generated by other tools, should be filled by developers only using \code{\link{Tool}<-} #' #' @name Seurat-class #' @rdname Seurat-class #' @exportClass Seurat #' Seurat <- setClass( Class = 'Seurat', slots = c( assays = 'list', meta.data = 'data.frame', active.assay = 'character', active.ident = 'factor', graphs = 'list', neighbors = 'list', reductions = 'list', project.name = 'character', misc = 'list', version = 'package_version', commands = 'list', tools = 'list' ) ) #' The Seurat Class #' #' The Seurat object is the center of each single cell analysis. It stores all information #' associated with the dataset, including data, annotations, analyes, etc. All that is needed #' to construct a Seurat object is an expression matrix (rows are genes, columns are cells), which #' should be log-scale #' #' Each Seurat object has a number of slots which store information. Key slots to access #' are listed below. #' #' @slot raw.data The raw project data #' @slot data The normalized expression matrix (log-scale) #' @slot scale.data scaled (default is z-scoring each gene) expression matrix; used for dimmensional reduction and heatmap visualization #' @slot var.genes Vector of genes exhibiting high variance across single cells #' @slot is.expr Expression threshold to determine if a gene is expressed (0 by default) #' @slot ident THe 'identity class' for each cell #' @slot meta.data Contains meta-information about each cell, starting with number of genes detected (nGene) #' and the original identity class (orig.ident); more information is added using \code{AddMetaData} #' @slot project.name Name of the project (for record keeping) #' @slot dr List of stored dimmensional reductions; named by technique #' @slot assay List of additional assays for multimodal analysis; named by technique #' @slot hvg.info The output of the mean/variability analysis for all genes #' @slot imputed Matrix of imputed gene scores #' @slot cell.names Names of all single cells (column names of the expression matrix) #' @slot cluster.tree List where the first element is a phylo object containing the phylogenetic tree relating different identity classes #' @slot snn Spare matrix object representation of the SNN graph #' @slot calc.params Named list to store all calculation-related parameter choices #' @slot kmeans Stores output of gene-based clustering from \code{DoKMeans} #' @slot spatial Stores internal data and calculations for spatial mapping of single cells #' @slot misc Miscellaneous spot to store any data alongisde the object (for example, gene lists) #' @slot version Version of package used in object creation #' #' @name seurat-class #' @rdname oldseurat-class #' @aliases seurat-class #' seurat <- setClass( Class = "seurat", slots = c( raw.data = "ANY", data = "ANY", scale.data = "ANY", var.genes = "vector", is.expr = "numeric", ident = "factor", meta.data = "data.frame", project.name = "character", dr = "list", assay = "list", hvg.info = "data.frame", imputed = "data.frame", cell.names = "vector", cluster.tree = "list", snn = "dgCMatrix", calc.params = "list", kmeans = "ANY", spatial = "ANY", misc = "ANY", version = "ANY" ) ) #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Functions #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' Pull Assays or assay names #' #' Lists the names of \code{\link{Assay}} objects present in #' a Seurat object. If slot is provided, pulls specified Assay object. #' #' @param object A Seurat object #' @param slot Name of Assay to return #' #' @return If \code{slot} is \code{NULL}, the names of all \code{Assay} objects #' in this Seurat object. Otherwise, the \code{Assay} object specified #' #' @export #' #' @examples #' Assays(object = pbmc_small) #' Assays <- function(object, slot = NULL) { assays <- FilterObjects(object = object, classes.keep = 'Assay') if (is.null(x = slot)) { return(assays) } if (!slot %in% assays) { warning( "Cannot find an assay of name ", slot, " in this Seurat object", call. = FALSE, immediate. = TRUE ) } return(slot(object = object, name = 'assays')[[slot]]) } #' Get cell names grouped by identity class #' #' @param object A Seurat object #' @param idents A vector of identity class levels to limit resulting list to; #' defaults to all identity class levels #' @param cells A vector of cells to grouping to #' #' @return A named list where names are identity classes and values are vectors #' of cells beloning to that class #' #' @export #' #' @examples #' CellsByIdentities(object = pbmc_small) #' CellsByIdentities <- function(object, idents = NULL, cells = NULL) { cells <- cells %||% colnames(x = object) cells <- intersect(x = cells, y = colnames(x = object)) if (length(x = cells) == 0) { stop("Cannot find cells provided") } idents <- idents %||% levels(x = object) idents <- intersect(x = idents, y = levels(x = object)) if (length(x = idents) == 0) { stop("None of the provided identity class levels were found", call. = FALSE) } cells.idents <- sapply( X = idents, FUN = function(i) { return(cells[as.vector(x = Idents(object = object)[cells]) == i]) }, simplify = FALSE, USE.NAMES = TRUE ) if (any(is.na(x = Idents(object = object)[cells]))) { cells.idents["NA"] <- names(x = which(x = is.na(x = Idents(object = object)[cells]))) } return(cells.idents) } #' Create an Assay object #' #' Create an Assay object from a feature (e.g. gene) expression matrix. The #' expected format of the input matrix is features x cells. #' #' Non-unique cell or feature names are not allowed. Please make unique before #' calling this function. #' #' @param counts Unnormalized data such as raw counts or TPMs #' @param data Prenormalized data; if provided, do not pass \code{counts} #' @param min.cells Include features detected in at least this many cells. Will #' subset the counts matrix as well. To reintroduce excluded features, create a #' new object with a lower cutoff. #' @param min.features Include cells where at least this many features are #' detected. #' #' @importFrom methods as #' @importFrom Matrix colSums rowSums #' #' @export #' #' @examples #' pbmc_raw <- read.table( #' file = system.file('extdata', 'pbmc_raw.txt', package = 'Seurat'), #' as.is = TRUE #' ) #' pbmc_rna <- CreateAssayObject(counts = pbmc_raw) #' pbmc_rna #' CreateAssayObject <- function( counts, data, min.cells = 0, min.features = 0 ) { if (missing(x = counts) && missing(x = data)) { stop("Must provide either 'counts' or 'data'") } else if (!missing(x = counts) && !missing(x = data)) { stop("Either 'counts' or 'data' must be missing; both cannot be provided") } else if (!missing(x = counts)) { # check that dimnames of input counts are unique if (anyDuplicated(rownames(x = counts))) { warning( "Non-unique features (rownames) present in the input matrix, making unique", call. = FALSE, immediate. = TRUE ) rownames(x = counts) <- make.unique(names = rownames(x = counts)) } if (anyDuplicated(colnames(x = counts))) { warning( "Non-unique cell names (colnames) present in the input matrix, making unique", call. = FALSE, immediate. = TRUE ) colnames(x = counts) <- make.unique(names = colnames(x = counts)) } if (is.null(x = colnames(x = counts))) { stop("No cell names (colnames) names present in the input matrix") } if (any(rownames(x = counts) == '')) { stop("Feature names of counts matrix cannot be empty", call. = FALSE) } if (nrow(x = counts) > 0 && is.null(x = rownames(x = counts))) { stop("No feature names (rownames) names present in the input matrix") } if (!inherits(x = counts, what = 'dgCMatrix')) { counts <- as(object = as.matrix(x = counts), Class = 'dgCMatrix') } # Filter based on min.features if (min.features > 0) { nfeatures <- Matrix::colSums(x = counts > 0) counts <- counts[, which(x = nfeatures >= min.features)] } # filter genes on the number of cells expressing if (min.cells > 0) { num.cells <- Matrix::rowSums(x = counts > 0) counts <- counts[which(x = num.cells >= min.cells), ] } data <- counts } else if (!missing(x = data)) { # check that dimnames of input data are unique if (anyDuplicated(rownames(x = data))) { warning( "Non-unique features (rownames) present in the input matrix, making unique", call. = FALSE, immediate. = TRUE ) rownames(x = data) <- make.unique(names = rownames(x = data)) } if (anyDuplicated(colnames(x = data))) { warning( "Non-unique cell names (colnames) present in the input matrix, making unique", call. = FALSE, immediate. = TRUE ) colnames(x = data) <- make.unique(names = colnames(x = data)) } if (is.null(x = colnames(x = data))) { stop("No cell names (colnames) names present in the input matrix") } if (any(rownames(x = data) == '')) { stop("Feature names of data matrix cannot be empty", call. = FALSE) } if (nrow(x = data) > 0 && is.null(x = rownames(x = data))) { stop("No feature names (rownames) names present in the input matrix") } if (min.cells != 0 | min.features != 0) { warning( "No filtering performed if passing to data rather than counts", call. = FALSE, immediate. = TRUE ) } counts <- new(Class = 'matrix') } # Ensure row- and column-names are vectors, not arrays if (!is.vector(x = rownames(x = counts))) { rownames(x = counts) <- as.vector(x = rownames(x = counts)) } if (!is.vector(x = colnames(x = counts))) { colnames(x = counts) <- as.vector(x = colnames(x = counts)) } if (!is.vector(x = rownames(x = data))) { rownames(x = data) <- as.vector(x = rownames(x = data)) } if (!is.vector(x = colnames(x = data))) { colnames(x = data) <- as.vector(x = colnames(x = data)) } if (any(grepl(pattern = '_', x = rownames(x = counts))) || any(grepl(pattern = '_', x = rownames(x = data)))) { warning( "Feature names cannot have underscores ('_'), replacing with dashes ('-')", call. = FALSE, immediate. = TRUE ) rownames(x = counts) <- gsub( pattern = '_', replacement = '-', x = rownames(x = counts) ) rownames(x = data) <- gsub( pattern = '_', replacement = '-', x = rownames(x = data) ) } if (any(grepl(pattern = '|', x = rownames(x = counts), fixed = TRUE)) || any(grepl(pattern = '|', x = rownames(x = data), fixed = TRUE))) { warning( "Feature names cannot have pipe characters ('|'), replacing with dashes ('-')", call. = FALSE, immediate. = TRUE ) rownames(x = counts) <- gsub( pattern = '|', replacement = '-', x = rownames(x = counts), fixed = TRUE ) rownames(x = data) <- gsub( pattern = '|', replacement = '-', x = rownames(x = data), fixed = TRUE ) } # Initialize meta.features init.meta.features <- data.frame(row.names = rownames(x = data)) assay <- new( Class = 'Assay', counts = counts, data = data, scale.data = new(Class = 'matrix'), meta.features = init.meta.features ) return(assay) } #' Create a DimReduc object #' #' @param embeddings A matrix with the cell embeddings #' @param loadings A matrix with the feature loadings #' @param projected A matrix with the projected feature loadings #' @param assay Assay used to calculate this dimensional reduction #' @param stdev Standard deviation (if applicable) for the dimensional reduction #' @param key A character string to facilitate looking up features from a #' specific DimReduc #' @param global Specify this as a global reduction (useful for visualizations) #' @param jackstraw Results from the JackStraw function #' @param misc list for the user to store any additional information associated #' with the dimensional reduction #' #' @aliases SetDimReduction #' #' @export #' #' @examples #' data <- GetAssayData(pbmc_small[["RNA"]], slot = "scale.data") #' pcs <- prcomp(x = data) #' pca.dr <- CreateDimReducObject( #' embeddings = pcs$rotation, #' loadings = pcs$x, #' stdev = pcs$sdev, #' key = "PC", #' assay = "RNA" #' ) #' CreateDimReducObject <- function( embeddings = new(Class = 'matrix'), loadings = new(Class = 'matrix'), projected = new(Class = 'matrix'), assay = NULL, stdev = numeric(), key = NULL, global = FALSE, jackstraw = NULL, misc = list() ) { if (is.null(x = assay)) { warning( "No assay specified, setting assay as RNA by default.", call. = FALSE, immediate. = TRUE ) assay <- "RNA" } # Try to infer key from column names if (is.null(x = key) && is.null(x = colnames(x = embeddings))) { stop("Please specify a key for the DimReduc object") } else if (is.null(x = key)) { key <- regmatches( x = colnames(x = embeddings), m = regexec(pattern = '^[[:alnum:]]+_', text = colnames(x = embeddings)) ) key <- unique(x = unlist(x = key, use.names = FALSE)) } if (length(x = key) != 1) { stop("Please specify a key for the DimReduc object") } else if (!grepl(pattern = '^[[:alnum:]]+_$', x = key)) { old.key <- key key <- UpdateKey(key = old.key) colnames(x = embeddings) <- gsub( x = colnames(x = embeddings), pattern = old.key, replacement = key ) warning( "All keys should be one or more alphanumeric characters followed by an underscore '_', setting key to ", key, call. = FALSE, immediate. = TRUE ) } # ensure colnames of the embeddings are the key followed by a numeric if (is.null(x = colnames(x = embeddings))) { warning( "No columnames present in cell embeddings, setting to '", key, "1:", ncol(x = embeddings), "'", call. = FALSE, immediate. = TRUE ) colnames(x = embeddings) <- paste0(key, 1:ncol(x = embeddings)) } else if (!all(grepl(pattern = paste0('^', key, "[[:digit:]]+$"), x = colnames(x = embeddings)))) { digits <- unlist(x = regmatches( x = colnames(x = embeddings), m = regexec(pattern = '[[:digit:]]+$', text = colnames(x = embeddings)) )) if (length(x = digits) != ncol(x = embeddings)) { stop("Please ensure all column names in the embeddings matrix are the key plus a digit representing a dimension number") } colnames(x = embeddings) <- paste0(key, digits) } if (!IsMatrixEmpty(x = loadings)) { if (any(rownames(x = loadings) == '')) { stop("Feature names of loadings matrix cannot be empty", call. = FALSE) } colnames(x = loadings) <- colnames(x = embeddings) } if (!IsMatrixEmpty(x = projected)) { if (any(rownames(x = loadings) == '')) { stop("Feature names of projected loadings matrix cannot be empty", call. = FALSE) } colnames(x = projected) <- colnames(x = embeddings) } jackstraw <- jackstraw %||% new(Class = 'JackStrawData') dim.reduc <- new( Class = 'DimReduc', cell.embeddings = embeddings, feature.loadings = loadings, feature.loadings.projected = projected, assay.used = assay, global = global, stdev = stdev, key = key, jackstraw = jackstraw, misc = misc ) return(dim.reduc) } #' Create a Seurat object #' #' Create a Seurat object from a feature (e.g. gene) expression matrix. The expected format of the #' input matrix is features x cells. #' #' #' Note: In previous versions (<3.0), this function also accepted a parameter to set the expression #' threshold for a 'detected' feature (gene). This functionality has been removed to simplify the #' initialization process/assumptions. If you would still like to impose this threshold for your #' particular dataset, simply filter the input expression matrix before calling this function. #' #' @inheritParams CreateAssayObject #' @param project Sets the project name for the Seurat object. #' @param assay Name of the assay corresponding to the initial input data. #' @param names.field For the initial identity class for each cell, choose this field from the #' cell's name. E.g. If your cells are named as BARCODE_CLUSTER_CELLTYPE in the input matrix, set #' names.field to 3 to set the initial identities to CELLTYPE. #' @param names.delim For the initial identity class for each cell, choose this delimiter from the #' cell's column name. E.g. If your cells are named as BARCODE-CLUSTER-CELLTYPE, set this to "-" to #' separate the cell name into its component parts for picking the relevant field. #' @param meta.data Additional cell-level metadata to add to the Seurat object. Should be a data #' frame where the rows are cell names and the columns are additional metadata fields. #' #' @importFrom utils packageVersion #' @importFrom Matrix colSums #' @export #' #' @examples #' pbmc_raw <- read.table( #' file = system.file('extdata', 'pbmc_raw.txt', package = 'Seurat'), #' as.is = TRUE #' ) #' pbmc_small <- CreateSeuratObject(counts = pbmc_raw) #' pbmc_small #' CreateSeuratObject <- function( counts, project = 'SeuratProject', assay = 'RNA', min.cells = 0, min.features = 0, names.field = 1, names.delim = "_", meta.data = NULL ) { if (!is.null(x = meta.data)) { if (is.null(x = rownames(x = meta.data))) { stop("Row names not set in metadata. Please ensure that rownames of metadata match column names of data matrix") } if (length(x = setdiff(x = rownames(x = meta.data), y = colnames(x = counts)))) { warning("Some cells in meta.data not present in provided counts matrix.") meta.data <- meta.data[intersect(x = rownames(x = meta.data), y = colnames(x = counts)), ] } if (is.data.frame(x = meta.data)) { new.meta.data <- data.frame(row.names = colnames(x = counts)) for (ii in 1:ncol(x = meta.data)) { new.meta.data[rownames(x = meta.data), colnames(x = meta.data)[ii]] <- meta.data[, ii, drop = FALSE] } meta.data <- new.meta.data } } assay.data <- CreateAssayObject( counts = counts, min.cells = min.cells, min.features = min.features ) Key(object = assay.data) <- paste0(tolower(x = assay), '_') assay.list <- list(assay.data) names(x = assay.list) <- assay init.meta.data <- data.frame(row.names = colnames(x = assay.list[[assay]])) # Set idents idents <- factor(x = unlist(x = lapply( X = colnames(x = assay.data), FUN = ExtractField, field = names.field, delim = names.delim ))) if (any(is.na(x = idents))) { warning("Input parameters result in NA values for initial cell identities. Setting all initial idents to the project name") } # if there are more than 100 idents, set all idents to ... name ident.levels <- length(x = unique(x = idents)) if (ident.levels > 100 || ident.levels == 0 || ident.levels == length(x = idents)) { idents <- rep.int(x = factor(x = project), times = ncol(x = assay.data)) } names(x = idents) <- colnames(x = assay.data) object <- new( Class = 'Seurat', assays = assay.list, meta.data = init.meta.data, active.assay = assay, active.ident = idents, project.name = project, version = packageVersion(pkg = 'Seurat') ) object[['orig.ident']] <- idents # Calculate nCount and nFeature n.calc <- CalcN(object = assay.data) if (!is.null(x = n.calc)) { names(x = n.calc) <- paste(names(x = n.calc), assay, sep = '_') object[[names(x = n.calc)]] <- n.calc } if (!is.null(x = meta.data)) { object <- AddMetaData(object = object, metadata = meta.data) } return(object) } #' Slim down a Seurat object #' #' Keep only certain aspects of the Seurat object. Can be useful in functions that utilize merge as #' it reduces the amount of data in the merge. #' #' @param object Seurat object #' @param counts Preserve the count matrices for the assays specified #' @param data Preserve the data slot for the assays specified #' @param scale.data Preserve the scale.data slot for the assays specified #' @param features Only keep a subset of features, defaults to all features #' @param assays Only keep a subset of assays specified here #' @param dimreducs Only keep a subset of DimReducs specified here (if NULL, #' remove all DimReducs) #' @param graphs Only keep a subset of Graphs specified here (if NULL, remove #' all Graphs) #' #' @export #' DietSeurat <- function( object, counts = TRUE, data = TRUE, scale.data = FALSE, features = NULL, assays = NULL, dimreducs = NULL, graphs = NULL ) { assays <- assays %||% FilterObjects(object = object, classes.keep = "Assay") assays <- assays[assays %in% FilterObjects(object = object, classes.keep = 'Assay')] if (length(x = assays) == 0) { stop("No assays provided were found in the Seurat object") } if (!DefaultAssay(object = object) %in% assays) { stop("The default assay is slated to be removed, please change the default assay") } if (!counts && !data) { stop("Either one or both of 'counts' and 'data' must be kept") } for (assay in FilterObjects(object = object, classes.keep = 'Assay')) { if (!(assay %in% assays)) { object[[assay]] <- NULL } else { features.assay <- features %||% rownames(x = object[[assay]]) features.assay <- intersect(x = features.assay, y = rownames(x = object[[assay]])) if (length(x = features.assay) == 0) { if (assay == DefaultAssay(object = object)) { stop("The default assay is slated to be removed, please change the default assay") } else { warning("No features found in assay '", assay, "', removing...") object[[assay]] <- NULL } } else { if (counts) { if (!is.null(x = features)) { slot(object = object[[assay]], name = 'counts') <- slot(object = object[[assay]], name = 'counts')[features.assay, ] } } else { slot(object = object[[assay]], name = 'counts') <- new(Class = 'matrix') } if (data) { if (!is.null(x = features)) { slot(object = object[[assay]], name = 'data') <- slot(object = object[[assay]], name = 'data')[features.assay, ] } } else { stop('data = FALSE currently not supported') slot(object = object[[assay]], name = 'data') <- new(Class = 'matrix') } features.scaled <- features.assay[features.assay %in% rownames(x = slot(object = object[[assay]], name = 'scale.data'))] if (scale.data && length(x = features.scaled) > 0) { if (! all(rownames(x = slot(object = object[[assay]], name = 'scale.data')) %in% features.scaled)) { slot(object = object[[assay]], name = 'scale.data') <- slot(object = object[[assay]], name = 'scale.data')[features.scaled, ] } } else { slot(object = object[[assay]], name = 'scale.data') <- new(Class = 'matrix') } } } } # remove unspecified DimReducs and Graphs all.objects <- FilterObjects(object = object, classes.keep = c('DimReduc', 'Graph')) objects.to.remove <- all.objects[!all.objects %in% c(dimreducs, graphs)] for (ob in objects.to.remove) { object[[ob]] <- NULL } return(object) } #' Access cellular data #' #' Retreives data (feature expression, PCA scores, metrics, etc.) for a set #' of cells in a Seurat object #' #' @param object Seurat object #' @param vars List of all variables to fetch, use keyword 'ident' to pull identity classes #' @param cells Cells to collect data for (default is all cells) #' @param slot Slot to pull feature data for #' #' @return A data frame with cells as rows and cellular data as columns #' #' @export #' #' @examples #' pc1 <- FetchData(object = pbmc_small, vars = 'PC_1') #' head(x = pc1) #' head(x = FetchData(object = pbmc_small, vars = c('groups', 'ident'))) #' FetchData <- function(object, vars, cells = NULL, slot = 'data') { cells <- cells %||% colnames(x = object) if (is.numeric(x = cells)) { cells <- colnames(x = object)[cells] } # Get a list of all objects to search through and their keys objects.use <- FilterObjects(object = object) object.keys <- sapply(X = objects.use, FUN = function(i) {return(Key(object[[i]]))}) # Find all vars that are keyed keyed.vars <- lapply( X = object.keys, FUN = function(key) { if (length(x = key) == 0) { return(integer(length = 0L)) } return(grep(pattern = paste0('^', key), x = vars)) } ) keyed.vars <- Filter(f = length, x = keyed.vars) data.fetched <- lapply( X = names(x = keyed.vars), FUN = function(x) { vars.use <- vars[keyed.vars[[x]]] key.use <- object.keys[x] data.return <- if (inherits(x = object[[x]], what = 'DimReduc')) { vars.use <- grep( pattern = paste0('^', key.use, '[[:digit:]]+$'), x = vars.use, value = TRUE ) if (length(x = vars.use) > 0) { tryCatch( expr = object[[x]][[cells, vars.use, drop = FALSE]], error = function(...) { return(NULL) } ) } else { NULL } } else if (inherits(x = object[[x]], what = 'Assay')) { vars.use <- gsub(pattern = paste0('^', key.use), replacement = '', x = vars.use) data.assay <- GetAssayData( object = object, slot = slot, assay = x ) vars.use <- vars.use[vars.use %in% rownames(x = data.assay)] data.vars <- t(x = as.matrix(data.assay[vars.use, cells, drop = FALSE])) if (ncol(data.vars) > 0) { colnames(x = data.vars) <- paste0(key.use, vars.use) } data.vars } data.return <- as.list(x = as.data.frame(x = data.return)) return(data.return) } ) data.fetched <- unlist(x = data.fetched, recursive = FALSE) # Pull vars from object metadata meta.vars <- vars[vars %in% colnames(x = object[[]]) & ! vars %in% names(x = data.fetched)] data.fetched <- c(data.fetched, object[[meta.vars]][cells, , drop = FALSE]) # Pull vars from the default assay default.vars <- vars[vars %in% rownames(x = GetAssayData(object = object, slot = slot)) & ! vars %in% names(x = data.fetched)] data.fetched <- c( data.fetched, tryCatch( expr = as.data.frame(x = t(x = as.matrix(x = GetAssayData( object = object, slot = slot )[default.vars, cells, drop = FALSE]))), error = function(...) { return(NULL) } ) ) # Pull identities if ('ident' %in% vars && !'ident' %in% colnames(x = object[[]])) { data.fetched[['ident']] <- Idents(object = object)[cells] } # Try to find ambiguous vars fetched <- names(x = data.fetched) vars.missing <- setdiff(x = vars, y = fetched) if (length(x = vars.missing) > 0) { # Search for vars in alternative assays vars.alt <- vector(mode = 'list', length = length(x = vars.missing)) names(x = vars.alt) <- vars.missing for (assay in FilterObjects(object = object, classes.keep = 'Assay')) { vars.assay <- Filter( f = function(x) { features.assay <- rownames(x = GetAssayData( object = object, assay = assay, slot = slot )) return(x %in% features.assay) }, x = vars.missing ) for (var in vars.assay) { vars.alt[[var]] <- append(x = vars.alt[[var]], values = assay) } } # Vars found in multiple alternative assays are truly ambiguous, will not pull vars.many <- names(x = Filter( f = function(x) { return(length(x = x) > 1) }, x = vars.alt )) if (length(x = vars.many) > 0) { warning( "Found the following features in more than one assay, excluding the default. We will not include these in the final dataframe: ", paste(vars.many, collapse = ', '), call. = FALSE, immediate. = TRUE ) } vars.missing <- names(x = Filter( f = function(x) { return(length(x = x) != 1) }, x = vars.alt )) # Pull vars found in only one alternative assay # Key this var to highlight that it was found in an alternate assay vars.alt <- Filter( f = function(x) { return(length(x = x) == 1) }, x = vars.alt ) for (var in names(x = vars.alt)) { assay <- vars.alt[[var]] warning( 'Could not find ', var, ' in the default search locations, found in ', assay, ' assay instead', immediate. = TRUE, call. = FALSE ) keyed.var <- paste0(Key(object = object[[assay]]), var) data.fetched[[keyed.var]] <- as.vector( x = GetAssayData(object = object, assay = assay, slot = slot)[var, cells] ) vars <- sub( pattern = paste0('^', var, '$'), replacement = keyed.var, x = vars ) } fetched <- names(x = data.fetched) } # Name the vars not found in a warning (or error if no vars found) m2 <- if (length(x = vars.missing) > 10) { paste0(' (10 out of ', length(x = vars.missing), ' shown)') } else { '' } if (length(x = vars.missing) == length(x = vars)) { stop( "None of the requested variables were found", m2, ': ', paste(head(x = vars.missing, n = 10L), collapse = ', ') ) } else if (length(x = vars.missing) > 0) { warning( "The following requested variables were not found", m2, ': ', paste(head(x = vars.missing, n = 10L), collapse = ', ') ) } # Assembled fetched vars in a dataframe data.fetched <- as.data.frame( x = data.fetched, row.names = cells, stringsAsFactors = FALSE ) data.order <- na.omit(object = pmatch( x = vars, table = fetched )) if (length(x = data.order) > 1) { data.fetched <- data.fetched[, data.order] } colnames(x = data.fetched) <- vars[vars %in% fetched] return(data.fetched) } #' Get integation data #' #' @param object Seurat object #' @param integration.name Name of integration object #' @param slot Which slot in integration object to get #' #' @return Returns data from the requested slot within the integrated object #' #' @export #' GetIntegrationData <- function(object, integration.name, slot) { tools <- slot(object = object, name = 'tools') if (!(integration.name %in% names(tools))) { stop('Requested integration key does not exist') } int.data <- tools[[integration.name]] return(slot(object = int.data, name = slot)) } #' Log a command #' #' Logs command run, storing the name, timestamp, and argument list. Stores in #' the Seurat object #' #' @param object Name of Seurat object #' @param return.command Return a \link{SeuratCommand} object instead #' #' @return If \code{return.command}, returns a SeuratCommand object. Otherwise, #' returns the Seurat object with command stored #' #' @export #' #' @seealso \code{\link{Command}} #' LogSeuratCommand <- function(object, return.command = FALSE) { time.stamp <- Sys.time() #capture function name which.frame <- sys.nframe() - 1 if (which.frame < 1) { stop("'LogSeuratCommand' cannot be called at the top level", call. = FALSE) } command.name <- as.character(x = deparse(expr = sys.calls()[[which.frame]])) command.name <- gsub(pattern = "\\.Seurat", replacement = "", x = command.name) call.string <- command.name command.name <- ExtractField(string = command.name, field = 1, delim = "\\(") #capture function arguments argnames <- names(x = formals(fun = sys.function(which = sys.parent(n = 1)))) argnames <- grep(pattern = "object", x = argnames, invert = TRUE, value = TRUE) argnames <- grep(pattern = "anchorset", x = argnames, invert = TRUE, value = TRUE) argnames <- grep(pattern = "\\.\\.\\.", x = argnames, invert = TRUE, value = TRUE) params <- list() p.env <- parent.frame(n = 1) argnames <- intersect(x = argnames, y = ls(name = p.env)) # fill in params list for (arg in argnames) { param_value <- get(x = arg, envir = p.env) if (inherits(x = param_value, what = 'Seurat')) { next } #TODO Institute some check of object size? params[[arg]] <- param_value } # check if function works on the Assay and/or the DimReduc Level assay <- params[["assay"]] reduction <- params[["reduction"]] # Get assay used for command cmd.assay <- assay %||% (reduction %iff% if (inherits(x = reduction, what = 'DimReduc')) { DefaultAssay(object = reduction) } else if (reduction %in% Reductions(object = object)) { DefaultAssay(object = object[[reduction]]) }) if (inherits(x = reduction, what = 'DimReduc')) { reduction <- 'DimReduc' } # rename function name to include Assay/DimReduc info if (length(x = assay) == 1) { command.name <- paste(command.name, assay, reduction, sep = '.') } command.name <- sub(pattern = "[\\.]+$", replacement = "", x = command.name, perl = TRUE) command.name <- sub(pattern = "\\.\\.", replacement = "\\.", x = command.name, perl = TRUE) # store results seurat.command <- new( Class = 'SeuratCommand', name = command.name, params = params, time.stamp = time.stamp, call.string = call.string, assay.used = cmd.assay ) if (return.command) { return(seurat.command) } object[[command.name]] <- seurat.command return(object) } #' Pull DimReducs or DimReduc names #' #' Lists the names of \code{\link{DimReduc}} objects present in #' a Seurat object. If slot is provided, pulls specified DimReduc object. #' #' @param object A Seurat object #' @param slot Name of DimReduc #' #' @return If \code{slot} is \code{NULL}, the names of all \code{DimReduc} objects #' in this Seurat object. Otherwise, the \code{DimReduc} object requested #' #' @export #' #' @examples #' Reductions(object = pbmc_small) #' Reductions <- function(object, slot = NULL) { reductions <- FilterObjects(object = object, classes.keep = 'DimReduc') if (is.null(x = slot)) { return(reductions) } if (!slot %in% reductions) { warning( "Cannot find a DimReduc of name ", slot, " in this Seurat object", call. = FALSE, immediate. = TRUE ) } return(slot(object = object, name = 'reductions')[[slot]]) } #' Rename assays in a \code{Seurat} object #' #' @param object A \code{Seurat} object #' @param ... Named arguments as \code{old.assay = new.assay} #' #' @return \code{object} with assays renamed #' #' @export #' @examples #' RenameAssays(object = pbmc_small, RNA = 'rna') #' RenameAssays <- function(object, ...) { assay.pairs <- tryCatch( expr = as.list(x = ...), error = function(e) { return(list(...)) } ) old.assays <- names(x = assay.pairs) # Handle missing assays missing.assays <- setdiff(x = old.assays, y = Assays(object = object)) if (length(x = missing.assays) == length(x = old.assays)) { stop("None of the assays provided are present in this object", call. = FALSE) } else if (length(x = missing.assays)) { warning( "The following assays could not be found: ", paste(missing.assays, collapse = ', '), call. = FALSE, immediate. = TRUE ) } old.assays <- setdiff(x = old.assays, missing.assays) assay.pairs <- assay.pairs[old.assays] # Check to see that all old assays are named if (is.null(x = names(x = assay.pairs)) || any(sapply(X = old.assays, FUN = nchar) < 1)) { stop("All arguments must be named with the old assay name", call. = FALSE) } # Ensure each old assay is going to one new assay if (!all(sapply(X = assay.pairs, FUN = length) == 1) || length(x = old.assays) != length(x = unique(x = old.assays))) { stop("Can only rename assays to one new name", call. = FALSE) } # Ensure each new assay is coming from one old assay if (length(x = assay.pairs) != length(x = unique(x = assay.pairs))) { stop( "One or more assays are set to be lost due to duplicate new assay names", call. = FALSE ) } # Rename assays for (old in names(x = assay.pairs)) { new <- assay.pairs[[old]] # If we aren't actually renaming any if (old == new) { next } old.key <- Key(object = object[[old]]) suppressWarnings(expr = object[[new]] <- object[[old]]) if (old == DefaultAssay(object = object)) { message("Renaming default assay from ", old, " to ", new) DefaultAssay(object = object) <- new } Key(object = object[[new]]) <- old.key object[[old]] <- NULL } return(object) } #' Set integation data #' #' @param object Seurat object #' @param integration.name Name of integration object #' @param slot Which slot in integration object to set #' @param new.data New data to insert #' #' @return Returns a \code{\link{Seurat}} object #' #' @export #' SetIntegrationData <- function(object, integration.name, slot, new.data) { tools <- slot(object = object, name = 'tools') if (!(integration.name %in% names(tools))) { new.integrated <- new(Class = 'IntegrationData') slot(object = new.integrated, name = slot) <- new.data tools[[integration.name]] <- new.integrated slot(object = object, name = 'tools') <- tools return(object) } int.data <- tools[[integration.name]] slot(object = int.data, name = slot) <- new.data tools[[integration.name]] <- int.data slot(object = object, name = 'tools') <- tools return(object) } #' Splits object into a list of subsetted objects. #' #' Splits object based on a single attribute into a list of subsetted objects, #' one for each level of the attribute. For example, useful for taking an object #' that contains cells from many patients, and subdividing it into #' patient-specific objects. #' #' @param object Seurat object #' @param split.by Attribute for splitting. Default is "ident". Currently #' only supported for class-level (i.e. non-quantitative) attributes. #' #' @return A named list of Seurat objects, each containing a subset of cells #' from the original object. #' #' @export #' #' @examples #' # Assign the test object a three level attribute #' groups <- sample(c("group1", "group2", "group3"), size = 80, replace = TRUE) #' names(groups) <- colnames(pbmc_small) #' pbmc_small <- AddMetaData(object = pbmc_small, metadata = groups, col.name = "group") #' obj.list <- SplitObject(pbmc_small, split.by = "group") #' SplitObject <- function(object, split.by = "ident") { if (split.by == 'ident') { groupings <- Idents(object = object) } else { groupings <- FetchData(object = object, vars = split.by)[, 1] } groupings <- unique(x = as.character(x = groupings)) obj.list <- list() for (i in groupings) { if (split.by == "ident") { obj.list[[i]] <- subset(x = object, idents = i) } else { cells <- which(x = object[[split.by, drop = TRUE]] == i) cells <- colnames(x = object)[cells] obj.list[[i]] <- subset(x = object, cells = cells) } } return(obj.list) } #' Find features with highest scores for a given dimensional reduction technique #' #' Return a list of features with the strongest contribution to a set of components #' #' @param object DimReduc object #' @param dim Dimension to use #' @param nfeatures Number of features to return #' @param projected Use the projected feature loadings #' @param balanced Return an equal number of features with both + and - scores. #' @param ... Extra parameters passed to \code{\link{Loadings}} #' #' @return Returns a vector of features #' #' @export #' #' @examples #' pbmc_small #' TopFeatures(object = pbmc_small[["pca"]], dim = 1) #' # After projection: #' TopFeatures(object = pbmc_small[["pca"]], dim = 1, projected = TRUE) #' TopFeatures <- function( object, dim = 1, nfeatures = 20, projected = FALSE, balanced = FALSE, ... ) { loadings <- Loadings(object = object, projected = projected, ...)[, dim, drop = FALSE] return(Top( data = loadings, num = nfeatures, balanced = balanced )) } #' Find cells with highest scores for a given dimensional reduction technique #' #' Return a list of genes with the strongest contribution to a set of components #' #' @param object DimReduc object #' @param dim Dimension to use #' @param ncells Number of cells to return #' @param balanced Return an equal number of cells with both + and - scores. #' @param ... Extra parameters passed to \code{\link{Embeddings}} #' #' @return Returns a vector of cells #' #' @export #' #' @examples #' pbmc_small #' head(TopCells(object = pbmc_small[["pca"]])) #' # Can specify which dimension and how many cells to return #' TopCells(object = pbmc_small[["pca"]], dim = 2, ncells = 5) #' TopCells <- function(object, dim = 1, ncells = 20, balanced = FALSE, ...) { embeddings <- Embeddings(object = object, ...)[, dim, drop = FALSE] return(Top( data = embeddings, num = ncells, balanced = balanced )) } #' Update old Seurat object to accomodate new features #' #' Updates Seurat objects to new structure for storing data/calculations. #' For Seurat v3 objects, will validate object structure ensuring all keys and feature #' names are formed properly. #' #' @param object Seurat object #' #' @return Returns a Seurat object compatible with latest changes #' #' @importFrom utils packageVersion #' @importFrom methods .hasSlot new slotNames as #' #' @export #' #' @examples #' \dontrun{ #' updated_seurat_object = UpdateSeuratObject(object = old_seurat_object) #' } #' UpdateSeuratObject <- function(object) { if (.hasSlot(object, "version")) { if (slot(object = object, name = 'version') >= package_version(x = "2.0.0") && slot(object = object, name = 'version') < package_version(x = '3.0.0')) { # Run update message("Updating from v2.X to v3.X") seurat.version <- packageVersion(pkg = "Seurat") new.assay <- UpdateAssay(old.assay = object, assay = "RNA") assay.list <- list(new.assay) names(x = assay.list) <- "RNA" for (i in names(x = object@assay)) { assay.list[[i]] <- UpdateAssay(old.assay = object@assay[[i]], assay = i) } new.dr <- UpdateDimReduction(old.dr = object@dr, assay = "RNA") object <- new( Class = "Seurat", version = seurat.version, assays = assay.list, active.assay = "RNA", project.name = object@project.name, misc = object@misc %||% list(), active.ident = object@ident, reductions = new.dr, meta.data = object@meta.data, tools = list() ) # Run CalcN for (assay in Assays(object = object)) { n.calc <- CalcN(object = object[[assay]]) if (!is.null(x = n.calc)) { names(x = n.calc) <- paste(names(x = n.calc), assay, sep = '_') object[[names(x = n.calc)]] <- n.calc } to.remove <- c("nGene", "nUMI") for (i in to.remove) { if (i %in% colnames(x = object[[]])) { object[[i]] <- NULL } } } } if (package_version(x = slot(object = object, name = 'version')) >= package_version(x = "3.0.0")) { # Run validation message("Validating object structure") # Update object slots message("Updating object slots") object <- UpdateSlots(object = object) # Rename assays assays <- make.names(names = Assays(object = object)) names(x = assays) <- Assays(object = object) object <- do.call(what = RenameAssays, args = c('object' = object, assays)) for (obj in FilterObjects(object = object, classes.keep = c('Assay', 'DimReduc', 'Graph'))) { suppressWarnings(expr = object[[obj]] <- UpdateSlots(object = object[[obj]])) } for (cmd in Command(object = object)) { slot(object = object, name = 'commands')[[cmd]] <- UpdateSlots( object = Command(object = object, command = cmd) ) } # Validate object keys message("Ensuring keys are in the proper strucutre") for (ko in FilterObjects(object = object)) { Key(object = object[[ko]]) <- UpdateKey(key = Key(object = object[[ko]])) } # Check feature names message("Ensuring feature names don't have underscores or pipes") for (assay.name in FilterObjects(object = object, classes.keep = 'Assay')) { assay <- object[[assay.name]] for (slot in c('counts', 'data', 'scale.data')) { if (!IsMatrixEmpty(x = slot(object = assay, name = slot))) { rownames(x = slot(object = assay, name = slot)) <- gsub( pattern = '_', replacement = '-', x = rownames(x = slot(object = assay, name = slot)) ) rownames(x = slot(object = assay, name = slot)) <- gsub( pattern = '|', replacement = '-', x = rownames(x = slot(object = assay, name = slot)), fixed = TRUE ) } } VariableFeatures(object = assay) <- gsub( pattern = '_', replacement = '-', x = VariableFeatures(object = assay) ) VariableFeatures(object = assay) <- gsub( pattern = '|', replacement = '-', x = VariableFeatures(object = assay), fixed = TRUE ) rownames(x = slot(object = assay, name = "meta.features")) <- gsub( pattern = '_', replacement = '-', x = rownames(x = assay[[]]) ) rownames(x = slot(object = assay, name = "meta.features")) <- gsub( pattern = '|', replacement = '-', x = rownames(x = assay[[]]), fixed = TRUE ) object[[assay.name]] <- assay } for (reduc.name in FilterObjects(object = object, classes.keep = 'DimReduc')) { reduc <- object[[reduc.name]] for (slot in c('feature.loadings', 'feature.loadings.projected')) { if (!IsMatrixEmpty(x = slot(object = reduc, name = slot))) { rownames(x = slot(object = reduc, name = slot)) <- gsub( pattern = '_', replacement = '-', x = rownames(x = slot(object = reduc, name = slot)) ) rownames(x = slot(object = reduc, name = slot)) <- gsub( pattern = '_', replacement = '-', x = rownames(x = slot(object = reduc, name = slot)), fixed = TRUE ) } } object[[reduc.name]] <- reduc } } if (package_version(x = slot(object = object, name = 'version')) <= package_version(x = '3.1.1')) { # Update Assays, DimReducs, and Graphs for (x in names(x = object)) { message("Updating slots in ", x) xobj <- object[[x]] xobj <- UpdateSlots(object = xobj) if (inherits(x = xobj, what = 'DimReduc')) { if (any(sapply(X = c('tsne', 'umap'), FUN = grepl, x = tolower(x = x)))) { message("Setting ", x, " DimReduc to global") slot(object = xobj, name = 'global') <- TRUE } } else if (inherits(x = xobj, what = 'Graph')) { graph.assay <- unlist(x = strsplit(x = x, split = '_'))[1] if (graph.assay %in% Assays(object = object)) { message("Setting default assay of ", x, " to ", graph.assay) DefaultAssay(object = xobj) <- graph.assay } } object[[x]] <- xobj } # Update SeuratCommands for (cmd in Command(object = object)) { cobj <- Command(object = object, command = cmd) cobj <- UpdateSlots(object = cobj) cmd.assay <- unlist(x = strsplit(x = cmd, split = '\\.')) cmd.assay <- cmd.assay[length(x = cmd.assay)] cmd.assay <- if (cmd.assay %in% Assays(object = object)) { cmd.assay } else if (cmd.assay %in% Reductions(object = object)) { DefaultAssay(object = object[[cmd.assay]]) } else { NULL } if (is.null(x = cmd.assay)) { message("No assay information could be found for ", cmd) } else { message("Setting assay used for ", cmd, " to ", cmd.assay) } slot(object = cobj, name = 'assay.used') <- cmd.assay object[[cmd]] <- cobj } # Update object version slot(object = object, name = 'version') <- packageVersion(pkg = 'Seurat') } message("Object representation is consistent with the most current Seurat version") return(object) } stop( "We are unable to convert Seurat objects less than version 2.X to version 3.X\n", 'Please use devtools::install_version to install Seurat v2.3.4 and update your object to a 2.X object', call. = FALSE ) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Methods for Seurat-defined generics #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' @rdname AddMetaData #' @export #' @method AddMetaData Assay #' AddMetaData.Assay <- function(object, metadata, col.name = NULL) { return(.AddMetaData(object = object, metadata = metadata, col.name = col.name)) } #' @rdname AddMetaData #' @export #' @method AddMetaData Seurat #' AddMetaData.Seurat <- function(object, metadata, col.name = NULL) { return(.AddMetaData(object = object, metadata = metadata, col.name = col.name)) } #' @param assay Assay to convert #' @param reduction Name of DimReduc to set to main reducedDim in cds #' #' @rdname as.CellDataSet #' @export #' @method as.CellDataSet Seurat #' as.CellDataSet.Seurat <- function(x, assay = NULL, reduction = NULL, ...) { CheckDots(...) if (!PackageCheck('monocle', error = FALSE)) { stop("Please install monocle from Bioconductor before converting to a CellDataSet object") } else if (packageVersion(pkg = 'monocle') >= package_version(x = '2.99.0')) { stop("Seurat can only convert to/from Monocle v2.X objects") } assay <- assay %||% DefaultAssay(object = x) # make variables, then run `newCellDataSet` # create cellData counts counts <- GetAssayData(object = x, assay = assay, slot = "counts") # metadata cell.metadata <- x[[]] feature.metadata <- x[[assay]][[]] if (!"gene_short_name" %in% colnames(x = feature.metadata)) { feature.metadata$gene_short_name <- rownames(x = feature.metadata) } pd <- new(Class = "AnnotatedDataFrame", data = cell.metadata) fd <- new(Class = "AnnotatedDataFrame", data = feature.metadata) # Now, determine the expressionFamily if ("monocle" %in% names(x = Misc(object = x))) { expressionFamily <- Misc(object = x, slot = "monocle")[["expressionFamily"]] } else { if (all(counts == floor(x = counts))) { expressionFamily <- VGAM::negbinomial.size() } else if (any(counts < 0)) { expressionFamily <- VGAM::uninormal() } else { expressionFamily <- VGAM::tobit() } } cds <- monocle::newCellDataSet( cellData = counts, phenoData = pd, featureData = fd, expressionFamily = expressionFamily ) if ("monocle" %in% names(x = Misc(object = x))) { monocle::cellPairwiseDistances(cds = cds) <- Misc(object = x, slot = "monocle")[["cellPairwiseDistances"]] monocle::minSpanningTree(cds = cds) <- Misc(object = x, slot = "monocle")[["minSpanningTree"]] Biobase::experimentData(cds = cds) <- Misc(object = x, slot = "monocle")[["experimentData"]] Biobase::protocolData(cds = cds) <- Misc(object = x, slot = "monocle")[["protocolData"]] Biobase::classVersion(cds = cds) <- Misc(object = x, slot = "monocle")[["classVersion"]] # no setter methods found for following slots slot(object = cds, name = "lowerDetectionLimit") <- Misc(object = x, slot = "monocle")[["lowerDetectionLimit"]] slot(object = cds, name = "dispFitInfo") <- Misc(object = x, slot = "monocle")[["dispFitInfo"]] slot(object = cds, name = "auxOrderingData") <- Misc(object = x, slot = "monocle")[["auxOrderingData"]] slot(object = cds, name = "auxClusteringData") <- Misc(object = x, slot = "monocle")[["auxClusteringData"]] } # adding dimensionality reduction data to the CDS dr.slots <- c("reducedDimS", "reducedDimK", "reducedDimW", "reducedDimA") reduction <- reduction %||% DefaultDimReduc(object = x, assay = assay) if (!is.null(x = reduction)) { if (grepl(pattern = 'tsne', x = tolower(x = reduction))) { slot(object = cds, name = "dim_reduce_type") <- "tSNE" monocle::reducedDimA(cds = cds) <- t(x = Embeddings(object = x[[reduction]])) } else { slot(object = cds, name = "dim_reduce_type") <- reduction monocle::reducedDimA(cds = cds) <- Loadings(object = x[[reduction]]) slot(object = cds, name = "reducedDimS") <- Embeddings(object = x[[reduction]]) } for (ii in dr.slots) { if (ii %in% names(x = slot(object = x[[reduction]], name = "misc"))) { slot(object = cds, name = ii) <- slot(object = x[[reduction]], name = "misc")[[ii]] } } } return(cds) } #' @rdname as.Graph #' @export #' @method as.Graph Matrix #' #' @examples #' # converting sparse matrix #' mat <- Matrix::rsparsematrix(nrow = 10, ncol = 10, density = 0.1) #' rownames(x = mat) <- paste0("feature_", 1:10) #' colnames(x = mat) <- paste0("cell_", 1:10) #' g <- as.Graph(x = mat) #' as.Graph.Matrix <- function(x, ...) { CheckDots(...) x <- as.sparse(x = x) if (is.null(x = rownames(x = x))) { stop("Please provide rownames to the matrix before converting to a Graph.") } if (is.null(x = colnames(x = x))) { stop("Please provide colnames to the matrix before converting to a Graph.") } return(as(object = x, Class = "Graph")) } #' @rdname as.Graph #' @export #' @method as.Graph matrix #' #' @examples #' # converting dense matrix #' mat <- matrix(data = 1:16, nrow = 4) #' rownames(x = mat) <- paste0("feature_", 1:4) #' colnames(x = mat) <- paste0("cell_", 1:4) #' g <- as.Graph(x = mat) #' as.Graph.matrix <- function(x, ...) { CheckDots(...) return(as.Graph.Matrix(x = as(object = x, Class = 'Matrix'))) } #' @details #' The Seurat method for \code{as.loom} will try to automatically fill in datasets based on data presence. #' For example, if an assay's scaled data slot isn't filled, then dimensional reduction and graph information #' will not be filled, since those depend on scaled data. The following is a list of how datasets will be filled #' \itemize{ #' \item \code{counts} will be stored in \code{matrix} #' \item Cell names will be stored in \code{col_attrs/CellID}; feature names will be stored in \code{row_attrs/Gene} #' \item \code{data} will be stored in \code{layers/norm_data} #' \item \code{scale.data} will be stored in \code{layers/scale_data} #' \item Cell-level metadata will be stored in \code{col_attrs}; all periods '.' in metadata will be replaced with underscores '_' #' \item Clustering information from \code{Idents(object = x)} will be stored in \code{col_attrs/ClusterID} and \code{col_attrs/ClusterName} #' for the numeric and string representation of the factor, respectively #' \item Feature-level metadata will be stored in \code{Feature_attrs}; all periods '.' in metadata will be replaced with underscores '_' #' \item Variable features, if set, will be stored in \code{row_attrs/Selected}; features declared as variable will be stored as '1', #' others will be stored as '0' #' \item Dimensional reduction information for the assay provided will be stored in \code{col_attrs} for cell embeddings and \code{row_attrs} #' for feature loadings; datasets will be named as \code{name_type} where \code{name} is the name within the Seurat object #' and \code{type} is \code{cell_embeddings} or \code{feature_loadings}; if feature loadings have been projected for all features, #' then projected loadings will be stored instead and \code{type} will be \code{feature_loadings_projected} #' \item Nearest-neighbor graphs that start with the name of the assay will be stored in \code{col_graphs} #' \item Assay information will be stored as an HDF5 attribute called \code{assay} at the root level #' } #' #' @inheritParams loomR::create #' @param assay Assay to store in loom file #' #' @rdname as.loom #' @export #' @method as.loom Seurat #' #' @examples #' \dontrun{ #' lfile <- as.loom(x = pbmc_small) #' } #' as.loom.Seurat <- function( x, assay = NULL, filename = file.path(getwd(), paste0(Project(object = x), '.loom')), max.size = '400mb', chunk.dims = NULL, chunk.size = NULL, overwrite = FALSE, verbose = TRUE, ... ) { if (!PackageCheck('loomR', error = FALSE)) { stop("Please install loomR from GitHub before converting to a loom object") } CheckDots(..., fxns = 'loomR::create') # Set the default assay to make life easy assay <- assay %||% DefaultAssay(object = x) DefaultAssay(object = x) <- assay # Pull ordering information cell.order <- colnames(x = x) feature.order <- rownames(x = x) # Get cell- and feature-level metadata meta.data <- x[[]][cell.order, ] colnames(x = meta.data) <- gsub( pattern = '\\.', replacement = '_', x = colnames(x = meta.data) ) meta.data$ClusterID <- as.integer(x = Idents(object = x)[rownames(x = meta.data)]) meta.data$ClusterName <- as.character(x = Idents(object = x)[rownames(x = meta.data)]) meta.feature <- x[[assay]][[]][feature.order, ] colnames(x = meta.feature) <- gsub( pattern = '\\.', replacement = '_', x = colnames(x = meta.feature) ) if (length(x = VariableFeatures(object = x)) > 0) { meta.feature[VariableFeatures(object = x), 'Selected'] <- 1 meta.feature[is.na(x = meta.feature$Selected), 'Selected'] <- 0 } if (IsMatrixEmpty(x = GetAssayData(object = x, slot = 'counts'))) { data <- GetAssayData(object = x, slot = 'data') layers <- NULL } else { data <- GetAssayData(object = x, slot = 'counts') # Raw counts matrix layers = list('norm_data' = GetAssayData(object = x, slot = 'data')) # Add data slot as norm_data } # Make the initial loom object lfile <- loomR::create( filename = filename, data = data[feature.order, cell.order], feature.attrs = as.list(x = meta.feature), # Feature-level metadata cell.attrs = as.list(x = meta.data), # Cell-level metadata layers = layers, transpose = TRUE, calc.count = FALSE, max.size = max.size, chunk.size = chunk.size, chunk.dims = chunk.dims, overwrite = overwrite, verbose = verbose, ... ) # Add scale.data if (!IsMatrixEmpty(x = GetAssayData(object = x, slot = 'scale.data'))) { if (verbose) { message("Adding scaled data matrix to /layers/scale_data") } lfile$add.layer( layers = list( 'scale_data' = as.matrix( x = t( x = as.data.frame( x = GetAssayData(object = x, slot = 'scale.data') )[feature.order, cell.order] ) ) ), verbose = verbose ) dim.reducs <- FilterObjects(object = x, classes.keep = 'DimReduc') dim.reducs <- Filter( f = function(d) { return(DefaultAssay(object = x[[d]]) == assay) }, x = dim.reducs ) # Add dimensional reduction information for (dr in dim.reducs) { if (verbose) { message("Adding dimensional reduction information for ", dr) } embeddings <- Embeddings(object = x, reduction = dr)[cell.order, ] embeddings <- list(embeddings) names(x = embeddings) <- paste0(dr, '_cell_embeddings') if (verbose) { message("Adding cell embedding information for ", dr) } lfile$add.col.attribute(attributes = embeddings) loadings <- Loadings( object = x, reduction = dr, projected = Projected(object = x[[dr]]) ) # Add feature loading information if (!IsMatrixEmpty(x = loadings)) { if (verbose) { message("Adding feature loading information for ", dr) } loadings <- as.matrix(x = as.data.frame(x = loadings)[feature.order, ]) loadings <- list(loadings) names(x = loadings) <- paste0(dr, '_feature_loadings') if (Projected(object = x[[dr]])) { names(x = loadings) <- paste0(names(x = loadings), '_projected') } lfile$add.row.attribute(attributes = loadings) } else if (verbose) { message("No feature loading information for ", dr) } } # Add graph information graphs <- FilterObjects(object = x, classes.keep = 'Graph') graphs <- grep(pattern = paste0('^', assay), x = graphs, value = TRUE) for (gr in graphs) { if (verbose) { message("Adding graph ", gr) } lfile$add.graph.matrix(mat = x[[gr]], name = gr, MARGIN = 2) } } else if (verbose) { message("No scaled data present, not adding scaled data, dimensional reduction information, or neighbor graphs") } # Store assay hdf5r::h5attr(x = lfile, which = 'assay') <- assay return(lfile) } #' @param slot Slot to store expression data as #' #' @importFrom utils packageVersion #' #' @rdname as.Seurat #' @export #' @method as.Seurat CellDataSet #' as.Seurat.CellDataSet <- function( x, slot = 'counts', assay = 'RNA', verbose = TRUE, ... ) { CheckDots(...) if (!PackageCheck('monocle', error = FALSE)) { stop("Please install monocle from Bioconductor before converting to a CellDataSet object") } else if (packageVersion(pkg = 'monocle') >= package_version(x = '2.99.0')) { stop("Seurat can only convert to/from Monocle v2.X objects") } slot <- match.arg(arg = slot, choices = c('counts', 'data')) if (verbose) { message("Pulling expression data") } expr <- Biobase::exprs(object = x) if (IsMatrixEmpty(x = expr)) { stop("No data provided in this CellDataSet object", call. = FALSE) } meta.data <- as.data.frame(x = Biobase::pData(object = x)) # if cell names are NULL, fill with cell_X if (is.null(x = colnames(x = expr))) { warning( "The column names of the 'counts' and 'data' matrices are NULL. Setting cell names to cell_columnidx (e.g 'cell_1').", call. = FALSE, immediate. = TRUE ) rownames(x = meta.data) <- colnames(x = expr) <- paste0("cell_", 1:ncol(x = expr)) } # Creating the object if (verbose) { message("Building Seurat object") } if (slot == 'data') { assays <- list(CreateAssayObject(data = expr)) names(x = assays) <- assay Key(object = assays[[assay]]) <- suppressWarnings(expr = UpdateKey(key = assay)) object <- new( Class = 'Seurat', assays = assays, meta.data = meta.data, version = packageVersion(pkg = 'Seurat'), project.name = 'SeuratProject' ) DefaultAssay(object = object) <- assay } else { object <- CreateSeuratObject( counts = expr, meta.data = meta.data, assay = assay ) } # feature metadata if (verbose) { message("Adding feature-level metadata") } feature.metadata <- Biobase::fData(object = x) object[[assay]][[names(x = feature.metadata)]] <- feature.metadata # mean/dispersion values disp.table <- tryCatch( expr = suppressWarnings(expr = monocle::dispersionTable(cds = x)), error = function(...) { return(NULL) } ) if (!is.null(x = disp.table)) { if (verbose) { message("Adding dispersion information") } rownames(x = disp.table) <- disp.table[, 1] disp.table[, 1] <- NULL colnames(x = disp.table) <- paste0('monocle_', colnames(x = disp.table)) object[[assay]][[names(x = disp.table)]] <- disp.table } else if (verbose) { message("No dispersion information in CellDataSet object") } # variable features if ("use_for_ordering" %in% colnames(x = feature.metadata)) { if (verbose) { message("Setting variable features") } VariableFeatures(object = object, assay = assay) <- rownames(x = feature.metadata)[which(x = feature.metadata[, "use_for_ordering"])] } else if (verbose) { message("No variable features present") } # add dim reduction dr.name <- slot(object = x, name = "dim_reduce_type") if (length(x = dr.name) > 0) { if (verbose) { message("Adding ", dr.name, " dimensional reduction") } reduced.A <- t(x = slot(object = x, name = 'reducedDimA')) reduced.S <- t(x = slot(object = x, name = 'reducedDimS')) if (IsMatrixEmpty(x = reduced.S)) { embeddings <- reduced.A loadings <- new(Class = 'matrix') } else { embeddings <- reduced.S loadings <- t(x = reduced.A) } rownames(x = embeddings) <- colnames(x = object) misc.dr <- list( reducedDimS = slot(object = x, name = "reducedDimS"), reducedDimK = slot(object = x, name = "reducedDimK"), reducedDimW = slot(object = x, name = "reducedDimW"), reducedDimA = slot(object = x, name = "reducedDimA") ) dr <- suppressWarnings(expr = CreateDimReducObject( embeddings = embeddings, loadings = loadings, assay = assay, key = UpdateKey(key = tolower(x = dr.name)), misc = misc.dr )) object[[dr.name]] <- dr } else if (verbose) { message("No dimensional reduction information found") } monocle.specific.info <- list( expressionFamily = slot(object = x, name = "expressionFamily"), lowerDetectionLimit = slot(object = x, name = "lowerDetectionLimit"), dispFitInfo = slot(object = x, name = "dispFitInfo"), cellPairwiseDistances = slot(object = x, name = "cellPairwiseDistances"), minSpanningTree = slot(object = x, name = "minSpanningTree"), auxOrderingData = slot(object = x, name = "auxOrderingData"), auxClusteringData = slot(object = x, name = "auxClusteringData"), experimentData = slot(object = x, name = "experimentData"), protocolData = slot(object = x, name = "protocolData"), classVersion = slot(object = x, name = ".__classVersion__") ) Misc(object = object, slot = "monocle") <- monocle.specific.info return(object) } #' @details #' The \code{loom} method for \code{as.Seurat} will try to automatically fill in a Seurat object based on data presence. #' For example, if no normalized data is present, then scaled data, dimensional reduction informan, and neighbor graphs #' will not be pulled as these depend on normalized data. The following is a list of how the Seurat object will be constructed #' \itemize{ #' \item If no assay information is provided, will default to an assay name in a root-level HDF5 attribute called \code{assay}; #' if no attribute is present, will default to "RNA" #' \item Cell-level metadata will consist of all one-dimensional datasets in \code{col_attrs} \strong{except} datasets named "ClusterID", "ClusterName", #' and whatever is passed to \code{cells} #' \item Identity classes will be set if either \code{col_attrs/ClusterID} or \code{col_attrs/ClusterName} are present; if both are present, then #' the values in \code{col_attrs/ClusterID} will set the order (numeric value of a factor) for values in \code{col_attrs/ClusterName} #' (charater value of a factor) #' \item Feature-level metadata will consist of all one-dimensional datasets in \code{row_attrs} \strong{except} datasets named "Selected" and whatever #' is passed to \code{features}; any feature-level metadata named "variance_standardized", "variance_expected", or "dispersion_scaled" will have #' underscores "_" replaced with a period "." #' \item Variable features will be set if \code{row_attrs/Selected} exists and it is a numeric type #' \item If a dataset is passed to \code{normalized}, stored as a sparse matrix in \code{data}; #' if no dataset provided, \code{scaled} will be set to \code{NULL} #' \item If a dataset is passed to \code{scaled}, stored as a dense matrix in \code{scale.data}; all rows entirely consisting of \code{NA}s #' will be removed #' \item If a dataset is passed to \code{scaled}, dimensional reduction information will assembled from cell embedding information #' stored in \code{col_attrs}; cell embeddings will be pulled from two-dimensional datasets ending with "_cell_embeddings"; priority will #' be given to cell embeddings that have the name of \code{assay} in their name; feature loadings will be added from two-dimensional #' datasets in \code{row_attrs} that start with the name of the dimensional reduction and end with either "feature_loadings" or #' "feature_loadings_projected" (priority given to the latter) #' \item If a dataset is passed to \code{scaled}, neighbor graphs will be pulled from \code{col_graphs}, provided the name starts #' with the value of \code{assay} #' } #' #' @param cells The name of the dataset within \code{col_attrs} containing cell names #' @param features The name of the dataset within \code{row_attrs} containing feature names #' @param normalized The name of the dataset within \code{layers} containing the #' normalized expression matrix; pass \code{/matrix} (with preceeding forward slash) to store #' \code{/matrix} as normalized data #' @param scaled The name of the dataset within \code{layers} containing the scaled expression matrix #' @param verbose Display progress updates #' #' @importFrom Matrix sparseMatrix #' #' @rdname as.Seurat #' @export #' @method as.Seurat loom #' #' @examples #' \dontrun{ #' lfile <- as.loom(x = pbmc_small) #' pbmc <- as.Seurat(x = lfile) #' } #' as.Seurat.loom <- function( x, cells = 'CellID', features = 'Gene', normalized = NULL, scaled = NULL, assay = NULL, verbose = TRUE, ... ) { CheckDots(...) # Shouldn't be necessary if (!PackageCheck('loomR', error = FALSE)) { stop("Please install loomR") } # Check prerequisite datasets if (!x[['col_attrs']]$exists(name = cells)) { stop("Cannot find provided cell name attribute in the loom file") } if (!x[['row_attrs']]$exists(name = features)) { stop("Cannot find provided feature name attribute in the loom file") } assay <- assay %||% hdf5r::h5attributes(x = x)$assay %||% 'RNA' # Read in the counts matrix if (verbose) { message( "Pulling ", ifelse( test = !is.null(x = normalized) && normalized == '/matrix', yes = 'normalized data', no = 'counts' ) ," matrix" ) } counts <- x$get.sparse( dataset = 'matrix', feature.names = features, cell.names = cells, verbose = verbose ) if (!is.null(x = normalized) && normalized == '/matrix') { assays <- list(CreateAssayObject(data = counts)) names(x = assays) <- assay object <- new( Class = 'Seurat', assays = assays, meta.data = data.frame(row.names = colnames(x = assays[[assay]])), version = packageVersion(pkg = 'Seurat'), project.name = 'SeuratProject' ) DefaultAssay(object = object) <- assay } else { object <- CreateSeuratObject( counts = counts, assay = assay ) } # Read in normalized and scaled data if (!is.null(x = normalized) && normalized != '/matrix') { normalized <- basename(path = normalized) if (!x[['layers']]$exists(name = normalized)) { warning( "Cannot find provided normalized data in the loom file", call. = FALSE, immediate. = TRUE ) scaled <- NULL } else { if (verbose) { message("Adding normalized data") } norm.data <- x$get.sparse( dataset = paste0('layers/', normalized), feature.names = features, cell.names = cells ) object <- SetAssayData(object = object, slot = 'data', new.data = norm.data) } } else if (is.null(x = normalized) || normalized != '/matrix') { if (verbose) { message("No normalized data provided, not adding scaled data") } scaled <- NULL } if (!is.null(x = scaled)) { scaled <- basename(path = scaled) if (!x[['layers']]$exists(name = scaled)) { warning( "Cannot find provided scaled data in the loom file", call. = FALSE, immediate. = TRUE ) scaled <- NULL } else { if (verbose) { message("Adding scaled data") } scale.data <- t(x = x[['layers']][[scaled]][, ]) rownames(x = scale.data) <- x[['row_attrs']][[features]][] colnames(x = scale.data) <- x[['col_attrs']][[cells]][] row.drop <- apply( X = scale.data, MARGIN = 1, FUN = function(row) { return(all(is.na(x = row))) } ) scale.data <- scale.data[!row.drop, , drop = FALSE] object <- SetAssayData( object = object, slot = 'scale.data', new.data = scale.data ) } } else if (verbose) { message("No scaled data provided") } # Read in cell-level metadata meta.data <- hdf5r::list.datasets( object = x, path = 'col_attrs', full.names = FALSE, recursive = FALSE ) meta.data <- meta.data[-which(x = meta.data %in% c(cells, 'ClusterID', 'ClusterName'))] meta.data <- Filter( f = function(m) { return(length(x = x[['col_attrs']][[m]]$dims) == 1) }, x = meta.data ) if (length(x = meta.data) > 0) { meta.data <- sapply( X = meta.data, FUN = function(m) { return(x[['col_attrs']][[m]][]) }, simplify = FALSE, USE.NAMES = TRUE ) meta.data <- as.data.frame(x = meta.data) rownames(x = meta.data) <- make.unique(names = x[['col_attrs']][[cells]][]) colnames(x = meta.data) <- gsub( pattern = 'orig_ident', replacement = 'orig.ident', x = colnames(x = meta.data) ) object[[colnames(x = meta.data)]] <- meta.data } # Set clustering information idents <- if (x[['col_attrs']]$exists(name = 'ClusterID')) { if (length(x = x[['col_attrs/ClusterID']]$dims) == 1) { x[['col_attrs/ClusterID']][] } else { NULL } } else { NULL } if (x[['col_attrs']]$exists(name = 'ClusterName')) { if (length(x = x[['col_attrs/ClusterName']]$dims) == 1) { ident.order <- idents idents <- x[['col_attrs/ClusterName']][] } else { ident.order <- NULL } } else { ident.order <- NULL } if (!is.null(x = idents)) { if (verbose) { message("Setting cluster IDs") } names(x = idents) <- x[['col_attrs']][[cells]][] levels <- if (is.null(x = ident.order)) { idents } else { idents[order(ident.order)] } levels <- unique(x = levels) idents <- factor(x = idents, levels = levels) Idents(object = object) <- idents } else if (verbose) { message("No clustering information present") } # Read in feature-level metadata meta.features <- hdf5r::list.datasets( object = x, path = 'row_attrs', full.names = FALSE, recursive = FALSE ) meta.features <- meta.features[-which(x = meta.features %in% c(features, 'Selected'))] meta.features <- Filter( f = function(m) { return(length(x = x[['row_attrs']][[m]]$dims) == 1) }, x = meta.features ) if (length(x = meta.features) > 0) { meta.features <- sapply( X = meta.features, FUN = function(m) { return(x[['row_attrs']][[m]][]) }, simplify = FALSE, USE.NAMES = TRUE ) meta.features <- as.data.frame(x = meta.features) rownames(x = meta.features) <- make.unique(names = x[['row_attrs']][[features]][]) colnames(x = meta.features) <- gsub( pattern = 'variance_standardized', replacement = 'variance.standardized', x = colnames(x = meta.features) ) colnames(x = meta.features) <- gsub( pattern = 'variance_expected', replacement = 'variance.expected', x = colnames(x = meta.features) ) colnames(x = meta.features) <- gsub( pattern = 'dispersion_scaled', replacement = 'dispersion.scaled', x = colnames(x = meta.features) ) object[[assay]][[colnames(x = meta.features)]] <- meta.features } # Look for variable features if (x[['row_attrs']]$exists(name = 'Selected')) { if (inherits(x = x[['row_attrs/Selected']]$get_type(), what = c('H5T_FLOAT', 'H5T_INTEGER'))) { var.features <- which(x = x[['row_attrs/Selected']][] == 1) VariableFeatures(object = object) <- x[['row_attrs']][[features]][var.features] } else if (verbose) { message("'Selected' must be a dataset of floats or integers, with '1' signifiying variable") } } # If scaled, look for dimensional reduction information if (!is.null(x = scaled)) { reductions <- hdf5r::list.datasets( object = x, path = 'col_attrs', full.names = FALSE, recursive = FALSE ) reductions <- grep( pattern = '_cell_embeddings$', x = reductions, value = TRUE ) reductions <- Filter( f = function(r) { return(length(x = x[['col_attrs']][[r]]$dims) == 2) }, x = reductions ) reduc.names <- sapply( X = strsplit(x = reductions, split = '_'), FUN = '[', 1 ) reductions <- sapply( X = reduc.names, FUN = function(r) { reducs <- grep(pattern = paste0('^', r), x = reductions, value = TRUE) if (sum(grepl(pattern = assay, x = reducs)) == 1) { return(grep(pattern = assay, x = reducs, value = TRUE)) } return(reducs[which.min(x = nchar(x = reducs))]) }, USE.NAMES = FALSE ) all.loadings <- grep( pattern = '_feature_loadings[_projected]', x = names(x = x[['row_attrs']]), value = TRUE, perl = TRUE ) for (reduc in reductions) { dim.name <- gsub(pattern = '_cell_embeddings', replacement = '', x = reduc) if (verbose) { message("Adding ", dim.name, " dimensional reduction information") } key <- switch( EXPR = dim.name, 'pca' = 'PC', 'tsne' = 'tSNE', toupper(x = dim.name) ) key <- paste0(key, '_') embeddings <- t(x = x[['col_attrs']][[reduc]][, ]) rownames(x = embeddings) <- x[['col_attrs']][[cells]][] dr <- CreateDimReducObject( embeddings = embeddings, assay = assay, key = key ) loadings <- grep(pattern = dim.name, x = all.loadings, value = TRUE) if (length(x = loadings) == 1) { if (verbose) { message("Pulling feature loadings for ", dim.name) } projected <- grepl(pattern = '_projected$', x = loadings) loadings <- t(x = x[['row_attrs']][[loadings]][, ]) rownames(x = loadings) <- if (projected) { x[['row_attrs']][[features]][] } else { rownames(x = GetAssayData(object = object, slot = 'scale.data')) } Loadings(object = dr, projected = projected) <- loadings } else if (verbose) { message("No loadings present for ", dim.name) } object[[dim.name]] <- dr } } else if (verbose) { message("No scaled data, not searching for dimensional reduction information") } # If scaled, look for graphs if (!is.null(x = scaled)) { for (gname in names(x = x[['col_graphs']])) { if (!grepl(pattern = paste0('^', assay), x = gname)) { next } if (verbose) { message("Loading graph ", gname) } graph <- sparseMatrix( i = x[['col_graphs']][[gname]][['a']][] + 1, j = x[['col_graphs']][[gname]][['b']][], x = x[['col_graphs']][[gname]][['w']][] ) rownames(x = graph) <- colnames(x = graph) <- x[['col_attrs']][[cells]][] object[[gname]] <- as.Graph(x = graph) } } else if (verbose) { message("No scaled data, not searching for nearest neighbor graphs") } return(object) } #' @param counts name of the SingleCellExperiment assay to store as \code{counts}; #' set to \code{NULL} if only normalized data are present #' @param data name of the SingleCellExperiment assay to slot as \code{data}. #' Set to NULL if only counts are present #' @param assay Name to store expression matrices as #' @param project Project name for new Seurat object #' #' @rdname as.Seurat #' @export #' @method as.Seurat SingleCellExperiment #' as.Seurat.SingleCellExperiment <- function( x, counts = 'counts', data = 'logcounts', assay = 'RNA', project = 'SingleCellExperiment', ... ) { CheckDots(...) if (!PackageCheck('SingleCellExperiment', error = FALSE)) { stop( "Please install SingleCellExperiment from Bioconductor before converting to a SingeCellExperiment object", call. = FALSE ) } meta.data <- as.data.frame(x = SummarizedExperiment::colData(x = x)) # Pull expression matrices mats <- list(counts = counts, data = data) mats <- Filter(f = Negate(f = is.null), x = mats) if (length(x = mats) == 0) { stop("Cannot pass 'NULL' to both 'counts' and 'data'") } for (m in 1:length(x = mats)) { # if (is.null(x = mats[[m]])) next mats[[m]] <- tryCatch( expr = SummarizedExperiment::assay(x = x, i = mats[[m]]), error = function(e) { stop("No data in provided assay - ", mats[[m]], call. = FALSE) } ) # if cell names are NULL, fill with cell_X if (is.null(x = colnames(x = mats[[m]]))) { warning( "The column names of the", names(x = mats)[m], " matrix is NULL. Setting cell names to cell_columnidx (e.g 'cell_1').", call. = FALSE, immediate. = TRUE ) cell.names <- paste0("cell_", 1:ncol(x = mats[[m]])) colnames(x = mats[[m]]) <- cell.names rownames(x = meta.data) <- cell.names } } assays <- if (is.null(x = mats$counts)) { list(CreateAssayObject(data = mats$data)) } else if (is.null(x = mats$data)) { list(CreateAssayObject(counts = mats$counts)) } else { a <- CreateAssayObject(counts = mats$counts) a <- SetAssayData(object = a, slot = 'data', new.data = mats$data) list(a) } names(x = assays) <- assay Key(object = assays[[assay]]) <- paste0(tolower(x = assay), '_') # Create the Seurat object object <- new( Class = 'Seurat', assays = assays, meta.data = meta.data, version = packageVersion(pkg = 'Seurat'), project.name = project ) DefaultAssay(object = object) <- assay Idents(object = object) <- project # Get DimReduc information if (length(x = SingleCellExperiment::reducedDimNames(x = x)) > 0) { for (dr in SingleCellExperiment::reducedDimNames(x = x)) { embeddings <- SingleCellExperiment::reducedDim(x = x, type = dr) if (is.null(x = rownames(x = embeddings))) { rownames(x = embeddings) <- cell.names } key <- gsub( pattern = "[[:digit:]]", replacement = "_", x = colnames(x = SingleCellExperiment::reducedDim(x = x, type = dr))[1] ) if (length(x = key) == 0) { key <- paste0(dr, "_") } colnames(x = embeddings) <- paste0(key, 1:ncol(x = embeddings)) object[[dr]] <- CreateDimReducObject( embeddings = embeddings, key = key, assay = DefaultAssay(object = object) ) } } return(object) } #' @param assay Assay to convert #' #' @rdname as.SingleCellExperiment #' @export #' @method as.SingleCellExperiment Seurat #' as.SingleCellExperiment.Seurat <- function(x, assay = NULL, ...) { CheckDots(...) if (!PackageCheck('SingleCellExperiment', error = FALSE)) { stop("Please install SingleCellExperiment from Bioconductor before converting to a SingeCellExperiment object") } assay <- assay %||% DefaultAssay(object = x) assays = list( counts = GetAssayData(object = x, assay = assay, slot = "counts"), logcounts = GetAssayData(object = x, assay = assay, slot = "data") ) assays <- assays[sapply(X = assays, FUN = nrow) != 0] sce <- SingleCellExperiment::SingleCellExperiment(assays = assays) metadata <- x[[]] metadata$ident <- Idents(object = x) SummarizedExperiment::colData(sce) <- S4Vectors::DataFrame(metadata) SummarizedExperiment::rowData(sce) <- S4Vectors::DataFrame(x[[assay]][[]]) for (dr in FilterObjects(object = x, classes.keep = "DimReduc")) { SingleCellExperiment::reducedDim(sce, toupper(x = dr)) <- Embeddings(object = x[[dr]]) } return(sce) } #' @importFrom methods as #' @importClassesFrom Matrix dgCMatrix #' #' @rdname as.sparse #' @export #' @method as.sparse data.frame #' as.sparse.data.frame <- function(x, ...) { CheckDots(...) return(as(object = as.matrix(x = x), Class = 'dgCMatrix')) } #' @importFrom methods is #' @importFrom Matrix sparseMatrix #' #' @rdname as.sparse #' @export #' @method as.sparse H5Group #' as.sparse.H5Group <- function(x, ...) { CheckDots(...) for (i in c('data', 'indices', 'indptr')) { if (!x$exists(name = i) || !is(object = x[[i]], class2 = 'H5D')) { stop("Invalid H5Group specification for a sparse matrix, missing dataset ", i) } } if ('h5sparse_shape' %in% hdf5r::h5attr_names(x = x)) { return(sparseMatrix( i = x[['indices']][] + 1, p = x[['indptr']][], x = x[['data']][], dims = rev(x = hdf5r::h5attr(x = x, which = 'h5sparse_shape')) )) } return(sparseMatrix( i = x[['indices']][] + 1, p = x[['indptr']][], x = x[['data']][] )) } #' @importFrom methods as #' @importClassesFrom Matrix dgCMatrix #' #' @rdname as.sparse #' @export #' @method as.sparse Matrix #' as.sparse.Matrix <- function(x, ...) { CheckDots(...) return(as(object = x, Class = 'dgCMatrix')) } #' @rdname as.sparse #' @export #' @method as.sparse matrix #' as.sparse.matrix <- function(x, ...) { return(as.sparse.Matrix(x = x, ...)) } #' @rdname Cells #' @export #' Cells.default <- function(x) { return(colnames(x = x)) } #' @rdname Cells #' @export #' @method Cells DimReduc #' Cells.DimReduc <- function(x) { return(rownames(x = x)) } #' @param command Name of the command to pull, pass \code{NULL} to get the names of all commands run #' @param value Name of the parameter to pull the value for #' #' @rdname Command #' @export #' @method Command Seurat #' Command.Seurat <- function(object, command = NULL, value = NULL, ...) { CheckDots(...) commands <- slot(object = object, name = "commands") if (is.null(x = command)) { return(names(x = commands)) } if (is.null(x = commands[[command]])) { stop(command, " has not been run or is not a valid command.") } command <- commands[[command]] if (is.null(x = value)) { return(command) } params <- slot(object = command, name = "params") if (!value %in% names(x = params)) { stop(value, " is not a valid parameter for ", slot(object = command, name = "name")) } return(params[[value]]) } #' @rdname DefaultAssay #' @export #' @method DefaultAssay Assay #' DefaultAssay.Assay <- function(object, ...) { object <- UpdateSlots(object = object) return(slot(object = object, name = 'assay.orig')) } #' @rdname DefaultAssay #' @export #' @method DefaultAssay DimReduc #' DefaultAssay.DimReduc <- function(object, ...) { CheckDots(...) return(slot(object = object, name = 'assay.used')) } #' @rdname DefaultAssay #' @export #' @method DefaultAssay Graph #' DefaultAssay.Graph <- function(object, ...) { object <- UpdateSlots(object = object) return(slot(object = object, name = 'assay.used')) } #' @rdname DefaultAssay #' @export #' @method DefaultAssay Seurat #' #' @examples #' # Get current default assay #' DefaultAssay(object = pbmc_small) #' DefaultAssay.Seurat <- function(object, ...) { CheckDots(...) return(slot(object = object, name = 'active.assay')) } #' @rdname DefaultAssay #' @export #' @method DefaultAssay SeuratCommand #' DefaultAssay.SeuratCommand <- function(object, ...) { object <- UpdateSlots(object = object) return(slot(object = object, name = 'assay.used')) } #' @export #' @method DefaultAssay<- Assay #' "DefaultAssay<-.Assay" <- function(object, ..., value) { object <- UpdateSlots(object = object) return(slot(object = object, name = 'assay.used')) object <- UpdateSlots(object = object) slot(object = object, name = 'assay.orig') <- value return(object) } #' @export #' @method DefaultAssay<- DimReduc #' "DefaultAssay<-.DimReduc" <- function(object, ..., value) { CheckDots(...) slot(object = object, name = 'assay.used') <- value return(object) } #' @export #' @method DefaultAssay<- Graph #' "DefaultAssay<-.Graph" <- function(object, ..., value) { object <- UpdateSlots(object = object) slot(object = object, name = 'assay.used') <- value return(object) } #' @rdname DefaultAssay #' @export #' @method DefaultAssay<- Seurat #' #' @examples #' # Create dummy new assay to demo switching default assays #' new.assay <- pbmc_small[["RNA"]] #' Key(object = new.assay) <- "RNA2_" #' pbmc_small[["RNA2"]] <- new.assay #' # switch default assay to RNA2 #' DefaultAssay(object = pbmc_small) <- "RNA2" #' DefaultAssay(object = pbmc_small) #' "DefaultAssay<-.Seurat" <- function(object, ..., value) { CheckDots(...) if (!value %in% names(x = slot(object = object, name = 'assays'))) { stop("Cannot find assay ", value) } slot(object = object, name = 'active.assay') <- value return(object) } #' @rdname Embeddings #' @export #' @method Embeddings DimReduc #' #' @examples #' # Get the embeddings directly from a DimReduc object #' Embeddings(object = pbmc_small[["pca"]])[1:5, 1:5] #' Embeddings.DimReduc <- function(object, ...) { CheckDots(...) return(slot(object = object, name = 'cell.embeddings')) } #' @param reduction Name of reduction to pull cell embeddings for #' #' @rdname Embeddings #' @export #' @method Embeddings Seurat #' #' @examples #' # Get the embeddings from a specific DimReduc in a Seurat object #' Embeddings(object = pbmc_small, reduction = "pca")[1:5, 1:5] #' Embeddings.Seurat <- function(object, reduction = 'pca', ...) { return(Embeddings(object = object[[reduction]], ...)) } #' @param assay Assay to get #' #' @rdname GetAssay #' @export #' @method GetAssay Seurat #' #' @examples #' GetAssay(object = pbmc_small, assay = "RNA") #' GetAssay.Seurat <- function(object, assay = NULL, ...) { CheckDots(...) assay <- assay %||% DefaultAssay(object = object) object.assays <- FilterObjects(object = object, classes.keep = 'Assay') if (!assay %in% object.assays) { stop(paste0( assay, " is not an assay present in the given object. Available assays are: ", paste(object.assays, collapse = ", ") )) } return(slot(object = object, name = 'assays')[[assay]]) } #' @param slot Specific information to pull (i.e. counts, data, scale.data, ...) #' #' @rdname GetAssayData #' @export #' @method GetAssayData Assay #' #' @examples #' # Get the data directly from an Assay object #' GetAssayData(object = pbmc_small[["RNA"]], slot = "data")[1:5,1:5] #' GetAssayData.Assay <- function(object, slot = 'data', ...) { CheckDots(...) return(slot(object = object, name = slot)) } #' @param assay Name of assay to pull data from #' #' @rdname GetAssayData #' @export #' @method GetAssayData Seurat #' #' @examples #' # Get the data from a specific Assay in a Seurat object #' GetAssayData(object = pbmc_small, assay = "RNA", slot = "data")[1:5,1:5] #' GetAssayData.Seurat <- function(object, slot = 'data', assay = NULL, ...) { CheckDots(...) assay <- assay %||% DefaultAssay(object = object) return(GetAssayData( object = GetAssay(object = object, assay = assay), slot = slot )) } #' @param selection.method Which method to pull; choose one from \code{c('sctransform', 'sct')} #' or \code{c('mean.var.plot', 'dispersion', 'mvp', 'disp')} #' @param status Add variable status to the resulting data.frame #' #' @rdname HVFInfo #' @export #' @method HVFInfo Assay #' #' @examples #' # Get the HVF info directly from an Assay object #' HVFInfo(object = pbmc_small[["RNA"]], selection.method = 'vst')[1:5, ] #' HVFInfo.Assay <- function(object, selection.method, status = FALSE, ...) { CheckDots(...) disp.methods <- c('mean.var.plot', 'dispersion', 'disp') if (tolower(x = selection.method) %in% disp.methods) { selection.method <- 'mvp' } selection.method <- switch( EXPR = tolower(x = selection.method), 'sctransform' = 'sct', selection.method ) vars <- switch( EXPR = selection.method, 'vst' = c('mean', 'variance', 'variance.standardized'), 'mvp' = c('mean', 'dispersion', 'dispersion.scaled'), 'sct' = c('gmean', 'variance', 'residual_variance'), stop("Unknown method: '", selection.method, "'", call. = FALSE) ) tryCatch( expr = hvf.info <- object[[paste(selection.method, vars, sep = '.')]], error = function(e) { stop( "Unable to find highly variable feature information for method '", selection.method, "'", call. = FALSE ) } ) colnames(x = hvf.info) <- vars if (status) { hvf.info$variable <- object[[paste0(selection.method, '.variable')]] } return(hvf.info) } #' @param assay Name of assay to pull highly variable feature information for #' #' @importFrom tools file_path_sans_ext #' #' @rdname HVFInfo #' @export #' @method HVFInfo Seurat #' #' @examples #' # Get the HVF info from a specific Assay in a Seurat object #' HVFInfo(object = pbmc_small, assay = "RNA")[1:5, ] #' HVFInfo.Seurat <- function( object, selection.method = NULL, assay = NULL, status = FALSE, ... ) { CheckDots(...) assay <- assay %||% DefaultAssay(object = object) if (is.null(x = selection.method)) { cmds <- apply( X = expand.grid( c('FindVariableFeatures', 'SCTransform'), FilterObjects(object = object, classes.keep = 'Assay') ), MARGIN = 1, FUN = paste, collapse = '.' ) find.command <- Command(object = object)[Command(object = object) %in% cmds] if (length(x = find.command) < 1) { stop( "Please run either 'FindVariableFeatures' or 'SCTransform'", call. = FALSE ) } find.command <- find.command[length(x = find.command)] test.command <- paste(file_path_sans_ext(x = find.command), assay, sep = '.') find.command <- ifelse( test = test.command %in% Command(object = object), yes = test.command, no = find.command ) selection.method <- switch( EXPR = file_path_sans_ext(x = find.command), 'FindVariableFeatures' = Command( object = object, command = find.command, value = 'selection.method' ), 'SCTransform' = 'sct', stop("Unknown command for finding variable features: '", find.command, "'", call. = FALSE) ) } return(HVFInfo( object = GetAssay(object = object, assay = assay), selection.method = selection.method, status = status )) } #' @rdname Idents #' @export #' @method Idents Seurat #' Idents.Seurat <- function(object, ...) { CheckDots(...) return(slot(object = object, name = 'active.ident')) } #' @param cells Set cell identities for specific cells #' @param drop Drop unused levels #' #' @rdname Idents #' @export #' @method Idents<- Seurat #' "Idents<-.Seurat" <- function(object, cells = NULL, drop = FALSE, ..., value) { CheckDots(...) cells <- cells %||% colnames(x = object) if (is.numeric(x = cells)) { cells <- colnames(x = object)[cells] } cells <- intersect(x = cells, y = colnames(x = object)) cells <- match(x = cells, table = colnames(x = object)) if (length(x = cells) == 0) { warning("Cannot find cells provided") return(object) } idents.new <- if (length(x = value) == 1 && value %in% colnames(x = object[[]])) { unlist(x = object[[value]], use.names = FALSE)[cells] } else { if (is.list(x = value)) { value <- unlist(x = value, use.names = FALSE) } rep_len(x = value, length.out = length(x = cells)) } new.levels <- if (is.factor(x = idents.new)) { levels(x = idents.new) } else { unique(x = idents.new) } old.levels <- levels(x = object) levels <- c(new.levels, old.levels) idents.new <- as.vector(x = idents.new) idents <- as.vector(x = Idents(object = object)) idents[cells] <- idents.new idents[is.na(x = idents)] <- 'NA' levels <- intersect(x = levels, y = unique(x = idents)) names(x = idents) <- colnames(x = object) missing.cells <- which(x = is.na(x = names(x = idents))) if (length(x = missing.cells) > 0) { idents <- idents[-missing.cells] } idents <- factor(x = idents, levels = levels) slot(object = object, name = 'active.ident') <- idents if (drop) { object <- droplevels(x = object) } return(object) } #' @rdname IsGlobal #' @export #' @method IsGlobal default #' IsGlobal.default <- function(object, ...) { return(FALSE) } #' @rdname IsGlobal #' @export #' @method IsGlobal DimReduc #' IsGlobal.DimReduc <- function(object, ...) { object <- UpdateSlots(object = object) return(slot(object = object, name = 'global')) } #' @param slot Name of slot to store JackStraw scores to #' Can shorten to 'empirical', 'fake', 'full', or 'overall' #' #' @rdname JS #' @export #' @method JS DimReduc #' JS.DimReduc <- function(object, slot = NULL, ...) { CheckDots(...) jackstraw <- slot(object = object, name = 'jackstraw') if (!is.null(x = slot)) { jackstraw <- JS(object = jackstraw, slot = slot) } return(jackstraw) } #' @rdname JS #' @export #' @method JS JackStrawData #' JS.JackStrawData <- function(object, slot, ...) { CheckDots(...) slot <- switch( EXPR = slot, 'empirical' = 'empirical.p.values', 'fake' = 'fake.reduction.scores', 'full' = 'empirical.p.values.full', 'overall' = 'overall.p.values', slot ) return(slot(object = object, name = slot)) } #' @rdname JS #' @export #' @method JS<- DimReduc #' "JS<-.DimReduc" <- function(object, slot = NULL, ..., value) { CheckDots(...) if (inherits(x = value, what = 'JackStrawData')) { slot(object = object, name = 'jackstraw') <- value } else if (is.null(x = NULL)) { stop("A slot must be specified") } else { JS(object = JS(object = object), slot = slot) <- value } return(object) } #' @rdname JS #' @export #' @method JS<- JackStrawData #' "JS<-.JackStrawData" <- function(object, slot, ..., value) { CheckDots(...) slot <- switch( EXPR = slot, 'empirical' = 'empirical.p.values', 'fake' = 'fake.reduction.scores', 'full' = 'empirical.p.values.full', 'overall' = 'overall.p.values', slot ) slot(object = object, name = slot) <- value return(object) } #' @rdname Key #' @export #' @method Key Assay #' #' @examples #' # Get an Assay key #' Key(object = pbmc_small[["RNA"]]) #' Key.Assay <- function(object, ...) { CheckDots(...) return(slot(object = object, name = 'key')) } #' @rdname Key #' @export #' @method Key DimReduc #' #' @examples #' # Get a DimReduc key #' Key(object = pbmc_small[["pca"]]) #' Key.DimReduc <- function(object, ...) { CheckDots(...) return(slot(object = object, name = 'key')) } #' @rdname Key #' @export #' @method Key Seurat #' #' @examples #' # Show all keys associated with a Seurat object #' Key(object = pbmc_small) #' Key.Seurat <- function(object, ...) { CheckDots(...) keyed.objects <- FilterObjects(object = object) return(sapply( X = keyed.objects, FUN = function(x) { return(Key(object = object[[x]])) } )) } #' @rdname Key #' @export #' @method Key<- Assay #' #' @examples #' # Set the key for an Assay #' Key(object = pbmc_small[["RNA"]]) <- "newkey_" #' Key(object = pbmc_small[["RNA"]]) #' "Key<-.Assay" <- function(object, ..., value) { CheckDots(...) slot(object = object, name = 'key') <- value return(object) } #' @rdname Key #' @export #' @method Key<- DimReduc #' #' @examples #' # Set the key for DimReduc #' Key(object = pbmc_small[["pca"]]) <- "newkey2_" #' Key(object = pbmc_small[["pca"]]) #' "Key<-.DimReduc" <- function(object, ..., value) { CheckDots(...) object <- UpdateSlots(object = object) old.key <- Key(object = object) slots <- Filter( f = function(x) { return(class(x = slot(object = object, name = x)) == 'matrix') }, x = slotNames(x = object) ) for (s in slots) { mat <- slot(object = object, name = s) if (!IsMatrixEmpty(x = mat)) { colnames(x = mat) <- sub( pattern = paste0('^', old.key), replacement = value, x = colnames(x = mat) ) } slot(object = object, name = s) <- mat } slot(object = object, name = 'key') <- value return(object) } #' @param projected Pull the projected feature loadings? #' #' @rdname Loadings #' @export #' @method Loadings DimReduc #' #' @examples #' # Get the feature loadings for a given DimReduc #' Loadings(object = pbmc_small[["pca"]])[1:5,1:5] #' Loadings.DimReduc <- function(object, projected = FALSE, ...) { CheckDots(...) projected <- projected %||% Projected(object = object) slot <- ifelse( test = projected, yes = 'feature.loadings.projected', no = 'feature.loadings' ) return(slot(object = object, name = slot)) } #' @param reduction Name of reduction to pull feature loadings for #' #' @rdname Loadings #' @export #' @method Loadings Seurat #' #' @examples #' # Get the feature loadings for a specified DimReduc in a Seurat object #' Loadings(object = pbmc_small, reduction = "pca")[1:5,1:5] #' Loadings.Seurat <- function(object, reduction = 'pca', projected = FALSE, ...) { return(Loadings(object = object[[reduction]], projected = projected, ...)) } #' @rdname Loadings #' @export #' @method Loadings<- DimReduc #' #' @examples #' # Set the feature loadings for a given DimReduc #' new.loadings <- Loadings(object = pbmc_small[["pca"]]) #' new.loadings <- new.loadings + 0.01 #' Loadings(object = pbmc_small[["pca"]]) <- new.loadings #' "Loadings<-.DimReduc" <- function(object, projected = TRUE, ..., value) { CheckDots(...) slot.use <- ifelse( test = projected, yes = 'feature.loadings.projected', no = 'feature.loadings' ) if (ncol(x = value) != length(x = object)) { stop("New feature loadings must have the dimensions as currently calculated") } slot(object = object, name = slot.use) <- value return(object) } #' @param slot Name of specific bit of meta data to pull #' #' @rdname Misc #' @export #' @method Misc Assay #' Misc.Assay <- function(object, slot = NULL, ...) { CheckDots(...) if (is.null(x = slot)) { return(slot(object = object, name = 'misc')) } return(slot(object = object, name = 'misc')[[slot]]) } #' @rdname Misc #' @export #' @method Misc Seurat #' #' @examples #' # Get the misc info #' Misc(object = pbmc_small, slot = "example") #' Misc.Seurat <- function(object, slot = NULL, ...) { CheckDots(...) if (is.null(x = slot)) { return(slot(object = object, name = 'misc')) } return(slot(object = object, name = 'misc')[[slot]]) } #' @rdname Misc #' @export #' @method Misc<- Assay #' "Misc<-.Assay" <- function(object, slot, ..., value) { CheckDots(...) if (slot %in% names(x = Misc(object = object))) { warning("Overwriting miscellanous data for ", slot) } if (is.list(x = value)) { slot(object = object, name = 'misc')[[slot]] <- c(value) } else { slot(object = object, name = 'misc')[[slot]] <- value } return(object) } #' @rdname Misc #' @export #' @method Misc<- Seurat #' #' @examples #'# Add misc info #' Misc(object = pbmc_small, slot = "example") <- "testing_misc" #' "Misc<-.Seurat" <- function(object, slot, ..., value) { CheckDots(...) if (slot %in% names(x = Misc(object = object))) { warning("Overwriting miscellanous data for ", slot) } if (is.list(x = value)) { slot(object = object, name = 'misc')[[slot]] <- c(value) } else { slot(object = object, name = 'misc')[[slot]] <- value } return(object) } #' @param cells Subset of cell names #' @param subset.name Parameter to subset on. Eg, the name of a gene, PC_1, a #' column name in object@@meta.data, etc. Any argument that can be retreived #' using FetchData #' @param low.threshold Low cutoff for the parameter (default is -Inf) #' @param high.threshold High cutoff for the parameter (default is Inf) #' @param accept.value Returns all cells with the subset name equal to this value #' #' @rdname OldWhichCells #' @export #' @method OldWhichCells Assay #' OldWhichCells.Assay <- function( object, cells, subset.name = NULL, low.threshold = -Inf, high.threshold = Inf, accept.value = NULL, ... ) { cells <- cells %||% colnames(x = object) # input checking if (length(x = subset.name) > 1) { stop("subset.name must be a single parameter") } if (length(x = low.threshold) > 1 | length(x = high.threshold) > 1) { stop("Multiple values passed to low.threshold or high.threshold") } if (low.threshold >= high.threshold) { stop("low.threshold is greater than or equal to high.threshold") } if (!is.null(x = subset.name)) { subset.name <- as.character(x = subset.name) data.use <- GetAssayData( object = object, ... = ... ) data.use <- t(x = data.use[subset.name, cells, drop = FALSE]) if (!is.null(x = accept.value)) { if (!all(accept.value %in% unique(x = data.use[, 1]))) { bad.vals <- accept.value[!(accept.value %in% unique(x = data.use[, 1]))] stop("Identity: ", bad.vals, " not found.") } pass.inds <- which(x = apply(data.use, MARGIN = 1, function(x) x %in% accept.value)) } else { pass.inds <- which(x = (data.use > low.threshold) & (data.use < high.threshold)) } cells <- rownames(x = data.use)[pass.inds] } return(cells) } #' @param ident.keep Create a cell subset based on the provided identity classes #' @param ident.remove Subtract out cells from these identity classes (used for #' filtration) #' @param max.cells.per.ident Can be used to downsample the data to a certain #' max per cell ident. Default is INF. #' @param random.seed Random seed for downsampling #' @param assay Which assay to filter on #' #' @seealso \code{\link{FetchData}} #' #' @rdname OldWhichCells #' @export #' @method OldWhichCells Seurat #' OldWhichCells.Seurat <- function( object, cells = NULL, subset.name = NULL, low.threshold = -Inf, high.threshold = Inf, accept.value = NULL, ident.keep = NULL, ident.remove = NULL, max.cells.per.ident = Inf, random.seed = 1, assay = NULL, ... ) { # input checking .Deprecated(new = "WhichCells", old = "OldWhichCells") if (length(x = subset.name) > 1) { stop("subset.name must be a single parameter") } if (length(x = low.threshold) > 1 | length(x = high.threshold) > 1) { stop("Multiple values passed to low.threshold or high.threshold") } if (low.threshold >= high.threshold) { stop("low.threshold is greater than or equal to high.threshold") } if (!is.na(x = random.seed)) { set.seed(seed = random.seed) } expression <- character(length = 0L) if (!is.null(x = subset.name)) { sub <- gsub( pattern = '"', replacement = '', x = deparse(expr = substitute(expr = subset.name)) ) if (!is.infinite(x = low.threshold)) { expression <- c( expression, paste(sub, '>', deparse(expr = substitute(expr = low.threshold))) ) } if (!is.infinite(x = high.threshold)) { expression <- c( expression, paste(sub, '<', deparse(expr = substitute(expr = high.threshold))) ) } if (!is.null(x = accept.value)) { expression <- c( expression, paste(sub, '==', deparse(expr = substitute(expr = accept.value))) ) } } #message( # 'With Seurat 3.X, identifying cells can now be done with:\n', # 'WhichCells(object = ', # deparse(expr = substitute(expr = object)), # if (length(x = expression) > 0) { # paste0(', subset = ', paste(expression, collapse = ' & ')) # }, # if (!is.null(x = cells)) { # paste(', cells =', deparse(expr = substitute(expr = cells))) # }, # if (!is.null(x = ident.keep)) { # paste(', idents =', deparse(expr = substitute(expr = ident.keep))) # }, # if (!is.infinite(x = max.cells.per.ident)) { # paste0(', downsample = ', max.cells.per.ident, ', seed = ', random.seed) # }, # ')' #) cells <- cells %||% colnames(x = object) assay <- assay %||% DefaultAssay(object = object) ident.keep <- ident.keep %||% unique(x = Idents(object = object)) bad.remove.idents <- ident.remove[!ident.remove %in% unique(x = Idents(object = object))] if (length(bad.remove.idents) > 0) { stop(paste("Identity :", bad.remove.idents, "not found. ")) } ident.keep <- setdiff(x = ident.keep, y = ident.remove) if (!all(ident.keep %in% unique(Idents(object = object)))) { bad.idents <- ident.keep[!(ident.keep %in% unique(x = Idents(object = object)))] stop("Identity: ", bad.idents, " not found.") } cells.to.use <- character() for (id in ident.keep) { cells.in.ident <- Idents(object = object)[cells] cells.in.ident <- names(x = cells.in.ident[cells.in.ident == id]) cells.in.ident <- cells.in.ident[!is.na(x = cells.in.ident)] if (length(x = cells.in.ident) > max.cells.per.ident) { cells.in.ident <- sample(x = cells.in.ident, size = max.cells.per.ident) } cells.to.use <- c(cells.to.use, cells.in.ident) } cells <- cells.to.use if (!is.null(x = subset.name)) { subset.name <- as.character(subset.name) data.use <- FetchData( object = object, vars = subset.name, cells = cells, ... ) if (!is.null(x = accept.value)) { if (!all(accept.value %in% unique(x = data.use[, 1]))) { bad.vals <- accept.value[!accept.value %in% unique(x = data.use[, 1])] stop("Identity: ", bad.vals, " not found.") } pass.inds <- which(x = apply(X = data.use, MARGIN = 1, FUN = function(x) x %in% accept.value)) } else { pass.inds <- which(x = (data.use > low.threshold) & (data.use < high.threshold)) } cells <- rownames(x = data.use)[pass.inds] } return(cells) } #' @rdname Project #' @export #' @method Project Seurat #' Project.Seurat <- function(object, ...) { CheckDots(...) return(slot(object = object, name = 'project.name')) } #' @rdname Project #' @export #' @method Project<- Seurat #' "Project<-.Seurat" <- function(object, ..., value) { CheckDots(...) slot(object = object, name = 'project.name') <- as.character(x = value) return(object) } #' @param assay Name of assay to store #' @param layers Slot to store layers as; choose from 'counts' or 'data'; pass #' \code{FALSE} to not pull layers; may pass one value of 'counts' or 'data' for #' each layer in the H5AD file, must be in order #' @param verbose Show progress updates #' #' @rdname h5ad #' @export #' @method ReadH5AD character #' ReadH5AD.character <- function( file, assay = 'RNA', layers = 'data', verbose = TRUE, ... ) { CheckDots(...) if (!PackageCheck('hdf5r', error = FALSE)) { stop("Please install hdf5r' for h5ad capabilities") } if (!file.exists(file)) { stop("Unable to find input H5AD file ", file) } hfile <- hdf5r::h5file(filename = file, mode = 'r') object <- ReadH5AD( file = hfile, assay = assay, layers = layers, verbose = verbose, ... ) hfile$close_all() return(object) } #' @importFrom methods is #' @importFrom Matrix sparseMatrix #' @importFrom utils packageVersion #' #' @rdname h5ad #' @export #' @method ReadH5AD H5File #' ReadH5AD.H5File <- function( file, assay = 'RNA', layers = 'data', verbose = TRUE, ... ) { CheckDots(...) # Pull assay data # If X is an H5D, assume scaled # Otherwise, if file$exists(name = 'raw'), assume X is normalized # Otherwise, assume file[['X']] is raw counts if (verbose) { message("Pulling expression matrices and metadata") } if (is(object = file[['X']], class2 = 'H5Group')) { x <- as.sparse(x = file[['X']]) } else { x <- file[['X']][, ] } # x will be an S3 matrix if X was scaled, otherwise will be a dgCMatrix scaled <- is.matrix(x = x) if (verbose) { message("Data is ", ifelse(test = scaled, yes = 'scaled', no = 'unscaled')) } # Pull cell- and feature-level metadata obs <- file[['obs']][] x.var <- file[['var']][] rownames(x = x) <- rownames(x = x.var) <- x.var$index colnames(x = x) <- rownames(x = obs) <- obs$index # Pull raw expression matrix and feature-level metadata if (file$exists(name = 'raw.X')) { raw <- as.sparse(x = file[['raw.X']]) raw.var <- file[['raw.var']][] slot(object = raw, name = 'Dim') <- c(nrow(x = raw.var), nrow(x = obs)) rownames(x = raw) <- rownames(x = raw.var) <- raw.var$index colnames(x = raw) <- obs$index raw.var <- raw.var[, -which(x = colnames(x = raw.var) == 'index'), drop = FALSE] x.slot <- ifelse(test = scaled, yes = 'scale.data', no = 'data') } else { # If X is scaled, we required normalized data present in raw if (scaled) { stop("Seurat requires normalized data present in the raw slot when X is scaled") } else { x.slot <- 'raw' } } obs <- obs[, -which(x = colnames(x = obs) == 'index'), drop = FALSE] x.var <- x.var[, -which(x = colnames(x = x.var) == 'index'), drop = FALSE] # Merge raw.var and x.var # Only happens when we have a raw.X and raw.var in the h5ad file if (x.slot != 'raw') { if (verbose) { message("Merging feature-level metadata dataframes") } x.var <- x.var[, -which(x = colnames(x = x.var) %in% colnames(x = raw.var))] meta.features <- merge(x = raw.var, y = x.var, by = 0, all = TRUE) rownames(x = meta.features) <- meta.features$Row.names meta.features <- meta.features[, -which(x = colnames(x = meta.features) == 'Row.names'), drop = FALSE] rm(raw.var) } else { meta.features <- x.var } # Fix meta feature colnames colnames(x = meta.features) <- gsub( pattern = 'dispersions_norm', replacement = 'mvp.dispersion.scaled', x = colnames(x = meta.features) ) colnames(x = meta.features) <- gsub( pattern = 'dispersions', replacement = 'mvp.dispersion', x = colnames(x = meta.features) ) colnames(x = meta.features) <- gsub( pattern = 'means', replacement = 'mvp.mean', x = colnames(x = meta.features) ) colnames(x = meta.features) <- gsub( pattern = '_', replacement = '.', x = colnames(x = meta.features) ) if ('highly.variable' %in% colnames(x = meta.features)) { meta.features$highly.variable[is.na(x = meta.features$highly.variable)] <- FALSE } rm(x.var) CheckGC() # Fix metadata colnames colnames(x = obs) <- gsub( pattern = '_', replacement = '.', x = colnames(x = obs) ) colnames(x = obs) <- gsub( pattern = 'n.genes', replacement = paste0('nFeatures_', assay), x = colnames(x = obs) ) colnames(x = obs) <- gsub( pattern = 'n.counts', replacement = paste0('nCount_', assay), x = colnames(x = obs) ) # Assemble assay object if (verbose) { message("Creating assay object") message( "Storing X as ", x.slot, ifelse( test = x.slot != 'counts', yes = paste(" and raw as", ifelse(test = scaled, yes = 'data', no = 'counts')), no = '' ) ) } if (scaled) { assays <- list(CreateAssayObject(data = raw)) assays[[1]] <- SetAssayData( object = assays[[1]], slot = 'scale.data', new.data = x ) rm(raw) } else if (x.slot == 'data') { assays <- list(CreateAssayObject(counts = raw)) assays[[1]] <- SetAssayData( object = assays[[1]], slot = 'data', new.data = x ) rm(raw) } else { assays <- list(CreateAssayObject(counts = x)) } names(x = assays) <- assay # Add meta feature information if (ncol(x = meta.features) > 0) { assays[[assay]][[names(x = meta.features)]] <- meta.features } # Add highly variable feature information if ('highly.variable' %in% colnames(x = assays[[assay]][[]])) { if (verbose) { message("Setting highly variable features") } hvf.info <- HVFInfo(object = assays[[assay]], selection.method = 'mvp') hvf.info <- hvf.info[order(hvf.info$dispersion, decreasing = TRUE), , drop = FALSE] means.use <- (hvf.info$mean > 0.1) & (hvf.info$mean < 8) dispersions.use <- (hvf.info$dispersion.scaled > 1) & (hvf.info$dispersion.scaled < Inf) top.features <- rownames(x = hvf.info)[which(x = means.use & dispersions.use)] VariableFeatures(object = assays[[assay]]) <- top.features } else if (verbose) { message("No variable feature expression found in h5ad file") } Key(object = assays[[assay]]) <- paste0(tolower(x = assay), '_') rm(x) CheckGC() # Get dimensional reduction information # If data isn't scaled, don't bother if (scaled && file$exists(name = 'obsm')) { if (verbose) { message("Pulling dimensional reduction information") message("Pulling cell embeddings") } # Pull cell embeddings if (inherits(x = file[['obsm']], what = 'H5Group')) { embed.reduc <- names(x = file[['obsm']]) embeddings <- sapply( X = embed.reduc, FUN = function(x) { return(t(x = file[['obsm']][[x]][, ])) }, simplify = FALSE, USE.NAMES = TRUE ) } else { embed.reduc <- file[['obsm']]$get_type()$get_cpd_labels() embed.n <- sapply( X = file[['obsm']]$get_type()$describe()$cpd_types, FUN = '[[', 'array_dims' ) names(x = embed.n) <- embed.reduc ncells <- file[['obsm']]$dims embeddings <- lapply( X = embed.reduc, FUN = function(r) { return(t(x = vapply( X = 1:ncells, FUN = function(i) { return(file[['obsm']][i][[r]]) }, FUN.VALUE = numeric(length = embed.n[[r]]) ))) } ) names(x = embeddings) <- embed.reduc } # Set cell names for embeddings matrices for (i in 1:length(x = embeddings)) { rownames(x = embeddings[[i]]) <- colnames(x = assays[[assay]]) } # Pull feature loadings if (file$exists(name = 'varm')) { if (verbose) { message("Pulling feature loadings") } if (inherits(x = file[['varm']], what = 'H5Group')) { load.reduc <- names(x = file[['varm']]) loadings <- sapply( X = load.reduc, FUN = function(x) { return(t(x = file[['varm']][[x]][, ])) }, simplify = FALSE, USE.NAMES = TRUE ) } else { load.reduc <- file[['varm']]$get_type()$get_cpd_labels() load.n <- sapply( X = file[['varm']]$get_type()$describe()$cpd_types, FUN = '[[', 'array_dims' ) names(x = load.n) <- load.reduc nfeatures <- file[['varm']]$dims loadings <- lapply( X = load.reduc, FUN = function(r) { return(t(x = vapply( X = 1:nfeatures, FUN = function(i) { return(file[['varm']][i][[r]]) }, FUN.VALUE = numeric(length = load.n[[load.reduc]]) ))) } ) } match.ind <- lapply( X = gsub(pattern = 's$', replacement = '', x = tolower(x = load.reduc)), FUN = grep, x = embed.reduc ) no.match <- which(x = sapply(X = match.ind, FUN = length) != 1) if (length(x = no.match) >= 1) { warning( "Unable to determine where the following feature loadings belong: ", paste(load.reduc[no.match], collapse = ', '), call. = FALSE, immediate. = TRUE ) loadings <- loadings[-no.match] load.reduc <- load.reduc[-no.match] match.ind <- match.ind[-no.match] } names(x = loadings) <- embed.reduc[unlist(x = match.ind)] for (i in 1:length(x = loadings)) { rownames(x = loadings[[i]]) <- rownames(x = GetAssayData( object = assays[[assay]], slot = 'scale.data' )) } } else { if (verbose) { message("No feature loadings found") } loadings <- list() } # Create DimReduc objects dim.reducs <- vector(mode = 'list', length = length(x = embed.reduc)) for (i in 1:length(x = embed.reduc)) { r <- embed.reduc[i] key <- tolower(x = gsub(pattern = 'X_', replacement = '', x = r)) key <- switch( EXPR = key, 'pca' = 'PC', 'tsne' = 'tSNE', toupper(x = key) ) key <- paste0(key, '_') stdev <- if (r == 'X_pca' && file$exists(name = 'uns') && file$exists(name = 'uns/pca/variance')) { sqrt(x = file[['uns/pca/variance']][]) } else { numeric(length = 0L) } dim.reducs[[i]] <- CreateDimReducObject( embeddings = embeddings[[r]], loadings = loadings[[r]] %||% new(Class = 'matrix'), assay = assay, stdev = stdev, key = key ) } # Properly name dimensional reductions names(x = dim.reducs) <- gsub( pattern = 'X_', replacement = '', x = embed.reduc ) # Clean up rm(embeddings, loadings) CheckGC() } else { if (verbose) { message("No dimensional reduction information found") } dim.reducs <- list() } # Create the Seurat object if (verbose) { message("Assembling Seurat object") } # Create a project name, will be used as identity classes project <- gsub( pattern = '\\.h5ad', replacement = '', x = basename(path = file$filename) ) object <- new( Class = 'Seurat', assays = assays, meta.data = obs, version = packageVersion(pkg = 'Seurat'), project.name = project ) # Set default assay and identity information DefaultAssay(object = object) <- assay Idents(object = object) <- project # Add dimensional reduction infrom if (scaled && length(x = dim.reducs) >= 1) { for (r in names(x = dim.reducs)) { object[[r]] <- dim.reducs[[r]] } } # Get graph information if (scaled && file$exists(name = 'uns') && file$exists(name = 'uns/neighbors')) { if (verbose) { message("Finding nearest neighbor graph") } graph <- as.sparse(x = file[['uns/neighbors/distances']]) colnames(x = graph) <- rownames(x = graph) <- colnames(x = object) method <- ifelse( test = file[['uns/neighbors/params']]$exists(name = 'method'), yes = file[['uns/neighbors/params/method']][], no = 'adata' ) object[[paste(assay, method, sep = '_')]] <- as.Graph(x = graph) } else if (verbose) { message("No nearest-neighbor graph") } # Add layers if (isFALSE(x = layers)) { if (verbose) { message("Not pulling layers") } } else if (file$exists(name = 'layers')) { file.layers <- names(x = file[['layers']]) layers <- rep_len( x = tolower(x = layers), length.out = length(x = file.layers) ) if (!all(layers %in% c('counts', 'data'))) { stop("'layers' must be either 'counts' or 'data'", call. = FALSE) } names(x = layers) <- file.layers for (layer in file.layers) { layer.dest <- layers[[layer]] if (verbose) { message( "Reading ", layer, " into new assay, putting data into ", layer.dest ) } layer.data <- if (inherits(x = file[['layers']][[layer]], what = 'H5Group')) { as.sparse(x = file[['layers']][[layer]]) } else { file[['layers']][[layer]][, ] } dimnames(x = layer.data) <- dimnames(x = object) layer.assay <- switch( EXPR = layer.dest, 'counts' = CreateAssayObject( counts = layer.data, min.cells = -1, min.features = -1 ), 'data' = CreateAssayObject(data = layer.data), stop("Unknown layer destination: ", layer.data, call. = FALSE) ) object[[layer]] <- layer.assay } } else if (verbose) { message("No additional layers found") } return(object) } #' @param reverse Reverse ordering #' @param afxn Function to evaluate each identity class based on; default is #' \code{\link[base]{mean}} #' @param reorder.numeric Rename all identity classes to be increasing numbers #' starting from 1 (default is FALSE) #' #' @rdname Idents #' @export #' @method ReorderIdent Seurat #' ReorderIdent.Seurat <- function( object, var, reverse = FALSE, afxn = mean, reorder.numeric = FALSE, ... ) { data.use <- FetchData(object = object, vars = var, ...)[, 1] rfxn <- ifelse( test = reverse, yes = function(x) { return(max(x) + 1 - x) }, no = Same ) new.levels <- names(x = rfxn(x = sort(x = tapply( X = data.use, INDEX = Idents(object = object), FUN = afxn )))) new.idents <- factor( x = Idents(object = object), levels = new.levels, ordered = TRUE ) if (reorder.numeric) { new.idents <- rfxn(x = rank(x = tapply( X = data.use, INDEX = as.numeric(x = new.idents), FUN = mean )))[as.numeric(x = new.idents)] new.idents <- factor( x = new.idents, levels = 1:length(x = new.idents), ordered = TRUE ) } Idents(object = object) <- new.idents return(object) } #' @param new.names vector of new cell names #' #' @rdname RenameCells #' @export #' @method RenameCells Assay #' #' @examples #' # Rename cells in an Assay #' head(x = colnames(x = pbmc_small[["RNA"]])) #' renamed.assay <- RenameCells( #' object = pbmc_small[["RNA"]], #' new.names = paste0("A_", colnames(x = pbmc_small[["RNA"]])) #' ) #' head(x = colnames(x = renamed.assay)) #' RenameCells.Assay <- function(object, new.names = NULL, ...) { CheckDots(...) if (IsSCT(assay = object)) { if (is.null(x = Misc(object = object, slot = 'vst.set'))) { suppressWarnings(Misc(object = object, slot = "vst.out")$cells_step1 <- new.names) suppressWarnings(rownames(x = Misc(object = object, slot = "vst.out")$cell_attr) <- new.names) } else{ suppressWarnings( Misc(object, slot = "vst.set") <- lapply( X = Misc(object = object, slot = "vst.set"), FUN = function(x) { new.names.vst <- new.names[which(x = x$cells_step1 %in% Cells(x = object))] x$cells_step1 <- new.names.vst rownames(x = x$cell_attr) <- new.names.vst return(x) } ) ) } } for (data.slot in c("counts", "data", "scale.data")) { old.data <- GetAssayData(object = object, slot = data.slot) if (ncol(x = old.data) <= 1) { next } colnames(x = slot(object = object, name = data.slot)) <- new.names } return(object) } #' @rdname RenameCells #' @export #' @method RenameCells DimReduc #' #' @examples #' # Rename cells in a DimReduc #' head(x = Cells(x = pbmc_small[["pca"]])) #' renamed.dimreduc <- RenameCells( #' object = pbmc_small[["pca"]], #' new.names = paste0("A_", Cells(x = pbmc_small[["pca"]])) #' ) #' head(x = Cells(x = renamed.dimreduc)) #' RenameCells.DimReduc <- function(object, new.names = NULL, ...) { CheckDots(...) old.data <- Embeddings(object = object) rownames(x = old.data) <- new.names slot(object = object, name = "cell.embeddings") <- old.data return(object) } #' @param for.merge Only rename slots needed for merging Seurat objects. #' Currently only renames the raw.data and meta.data slots. #' @param add.cell.id prefix to add cell names #' #' @details #' If \code{add.cell.id} is set a prefix is added to existing cell names. If #' \code{new.names} is set these will be used to replace existing names. #' #' @rdname RenameCells #' @export #' @method RenameCells Seurat #' #' @examples #' # Rename cells in a Seurat object #' head(x = colnames(x = pbmc_small)) #' pbmc_small <- RenameCells(object = pbmc_small, add.cell.id = "A") #' head(x = colnames(x = pbmc_small)) #' RenameCells.Seurat <- function( object, add.cell.id = NULL, new.names = NULL, for.merge = FALSE, ... ) { CheckDots(...) if (missing(x = add.cell.id) && missing(x = new.names)) { stop("One of 'add.cell.id' and 'new.names' must be set") } if (!missing(x = add.cell.id) && !missing(x = new.names)) { stop("Only one of 'add.cell.id' and 'new.names' may be set") } if (!missing(x = add.cell.id)) { new.cell.names <- paste(add.cell.id, colnames(x = object), sep = "_") } else { if (length(x = new.names) == ncol(x = object)) { new.cell.names <- new.names } else { stop( "the length of 'new.names' (", length(x = new.names), ") must be the same as the number of cells (", ncol(x = object), ")" ) } } # rename in the assay objects assays <- FilterObjects(object = object, classes.keep = 'Assay') for (assay in assays) { slot(object = object, name = "assays")[[assay]] <- RenameCells( object = object[[assay]], new.names = new.cell.names ) } # rename in the DimReduc objects dimreducs <- FilterObjects(object = object, classes.keep = 'DimReduc') for (dr in dimreducs) { object[[dr]] <- RenameCells( object = object[[dr]], new.names = new.cell.names ) } # rename the active.idents old.ids <- Idents(object = object) names(x = old.ids) <- new.cell.names Idents(object = object) <- old.ids # rename the cell-level metadata old.meta.data <- object[[]] rownames(x = old.meta.data) <- new.cell.names slot(object = object, name = "meta.data") <- old.meta.data # rename the graphs graphs <- FilterObjects(object = object, classes.keep = "Graph") for (g in graphs) { rownames(x = object[[g]]) <- colnames(x = object[[g]]) <- new.cell.names } return(object) } #' @rdname Idents #' @export #' @method RenameIdents Seurat #' RenameIdents.Seurat <- function(object, ...) { ident.pairs <- tryCatch( expr = as.list(x = ...), error = function(e) { return(list(...)) } ) if (is.null(x = names(x = ident.pairs))) { stop("All arguments must be named with the old identity class") } if (!all(sapply(X = ident.pairs, FUN = length) == 1)) { stop("Can only rename identity classes to one value") } if (!any(names(x = ident.pairs) %in% levels(x = object))) { stop("Cannot find any of the provided identities") } cells.idents <- CellsByIdentities(object = object) for (i in rev(x = names(x = ident.pairs))) { if (!i %in% names(x = cells.idents)) { warning("Cannot find identity ", i, call. = FALSE, immediate. = TRUE) next } Idents(object = object, cells = cells.idents[[i]]) <- ident.pairs[[i]] } return(object) } #' @param slot Where to store the new data #' @param new.data New data to insert #' #' #' @importFrom stats na.omit #' #' @rdname SetAssayData #' @export #' @method SetAssayData Assay #' #' @examples #' # Set an Assay slot directly #' count.data <- GetAssayData(object = pbmc_small[["RNA"]], slot = "counts") #' count.data <- as.matrix(x = count.data + 1) #' new.assay <- SetAssayData(object = pbmc_small[["RNA"]], slot = "counts", new.data = count.data) #' SetAssayData.Assay <- function(object, slot, new.data, ...) { CheckDots(...) slots.use <- c('counts', 'data', 'scale.data') if (!slot %in% slots.use) { stop( "'slot' must be one of ", paste(slots.use, collapse = ', '), call. = FALSE ) } if (!IsMatrixEmpty(x = new.data)) { if (any(grepl(pattern = '_', x = rownames(x = new.data)))) { warning( "Feature names cannot have underscores ('_'), replacing with dashes ('-')", call. = FALSE, immediate. = TRUE ) rownames(x = new.data) <- gsub( pattern = '_', replacement = '-', x = rownames(x = new.data) ) } if (ncol(x = new.data) != ncol(x = object)) { stop( "The new data doesn't have the same number of cells as the current data", call. = FALSE ) } num.counts <- nrow(x = object) counts.names <- rownames(x = object) if (slot == 'scale.data' && nrow(x = new.data) > num.counts) { warning( "Adding more features than present in current data", call. = FALSE, immediate. = TRUE ) } else if (slot %in% c('counts', 'data') && nrow(x = new.data) != num.counts) { warning( "The new data doesn't have the same number of features as the current data", call. = FALSE, immediate. = TRUE ) } if (!all(rownames(x = new.data) %in% counts.names)) { warning( "Adding features not currently present in the object", call. = FALSE, immediate. = TRUE ) } new.features <- na.omit(object = match( x = counts.names, table = rownames(x = new.data) )) new.cells <- colnames(x = new.data) if (!all(new.cells %in% colnames(x = object))) { stop( "All cell names must match current cell names", call. = FALSE ) } new.data <- new.data[new.features, colnames(x = object), drop = FALSE] if (slot %in% c('counts', 'data') && !all(dim(x = new.data) == dim(x = object))) { stop( "Attempting to add a different number of cells and/or features", call. = FALSE ) } } if (!is.vector(x = rownames(x = new.data))) { rownames(x = new.data) <- as.vector(x = rownames(x = new.data)) } if (!is.vector(x = colnames(x = new.data))) { colnames(x = new.data) <- as.vector(x = colnames(x = new.data)) } slot(object = object, name = slot) <- new.data return(object) } #' @param assay Name of assay whose data should be set #' #' @rdname SetAssayData #' @export #' @method SetAssayData Seurat #' #' @examples #' # Set an Assay slot through the Seurat object #' count.data <- GetAssayData(object = pbmc_small[["RNA"]], slot = "counts") #' count.data <- as.matrix(x = count.data + 1) #' new.seurat.object <- SetAssayData( #' object = pbmc_small, #' slot = "counts", #' new.data = count.data, #' assay = "RNA" #' ) #' SetAssayData.Seurat <- function( object, slot = 'data', new.data, assay = NULL, ... ) { CheckDots(...) assay <- assay %||% DefaultAssay(object = object) object[[assay]] <- SetAssayData(object = object[[assay]], slot = slot, new.data = new.data, ...) return(object) } #' @inheritParams Idents #' #' @rdname Idents #' @export #' @method SetIdent Seurat #' SetIdent.Seurat <- function(object, cells = NULL, value, ...) { #message( # 'With Seurat 3.X, setting identity classes can be done as follows:\n', # 'Idents(object = ', # deparse(expr = substitute(expr = object)), # if (!is.null(x = cells)) { # paste0(', cells = ', deparse(expr = substitute(expr = cells))) # }, # ') <- ', # deparse(expr = substitute(expr = value)) #) CheckDots(...) Idents(object = object, cells = cells) <- value return(object) } #' @inheritParams Idents #' @param save.name Store current identity information under this name #' #' @rdname Idents #' @export #' @method StashIdent Seurat #' StashIdent.Seurat <- function(object, save.name = 'orig.ident', ...) { message( 'With Seurat 3.X, stashing identity classes can be accomplished with the following:\n', deparse(expr = substitute(expr = object)), '[[', deparse(expr = substitute(expr = save.name)), ']] <- Idents(object = ', deparse(expr = substitute(expr = object)), ')' ) CheckDots(...) object[[save.name]] <- Idents(object = object) return(object) } #' @rdname Stdev #' @export #' @method Stdev DimReduc #' #' @examples #' # Get the standard deviations for each PC from the DimReduc object #' Stdev(object = pbmc_small[["pca"]]) #' Stdev.DimReduc <- function(object, ...) { CheckDots(...) return(slot(object = object, name = 'stdev')) } #' @param reduction Name of reduction to use #' #' @rdname Stdev #' @export #' @method Stdev Seurat #' #' @examples #' # Get the standard deviations for each PC from the Seurat object #' Stdev(object = pbmc_small, reduction = "pca") #' Stdev.Seurat <- function(object, reduction = 'pca', ...) { CheckDots(...) return(Stdev(object = object[[reduction]])) } #' @param cells A vector of cell names to use as a subset. If NULL #' (default), then this list will be computed based on the next three #' arguments. Otherwise, will return an object consissting only of these cells #' @param subset.name Parameter to subset on. Eg, the name of a gene, PC_1, a #' column name in object@@meta.data, etc. Any argument that can be retreived #' using FetchData #' @param low.threshold Low cutoff for the parameter (default is -Inf) #' @param high.threshold High cutoff for the parameter (default is Inf) #' @param accept.value Returns cells with the subset name equal to this value #' #' @rdname SubsetData #' @export #' @method SubsetData Assay #' SubsetData.Assay <- function( object, cells = NULL, subset.name = NULL, low.threshold = -Inf, high.threshold = Inf, accept.value = NULL, ... ) { cells <- cells %||% colnames(x = object) cells <- OldWhichCells( object = object, cells = cells, subset.name = subset.name, low.threshold = low.threshold, high.threshold = high.threshold, accept.value = accept.value, ... ) if (ncol(x = GetAssayData(object = object, slot = 'counts')) == ncol(x = object)) { slot(object = object, name = "counts") <- GetAssayData(object = object, slot = "counts")[, cells] } slot(object = object, name = "data") <- GetAssayData(object = object, slot = "data")[, cells] cells.scaled <- colnames(x = GetAssayData(object = object, slot = "scale.data")) cells.scaled <- cells.scaled[cells.scaled %in% cells] if (length(x = cells.scaled) > 0) { slot(object = object, name = "scale.data") <- GetAssayData(object = object, slot = "scale.data")[, cells] } return(object) } #' @param assay Assay to subset on #' @param ident.use Create a cell subset based on the provided identity classes #' @param ident.remove Subtract out cells from these identity classes (used for #' filtration) #' @param max.cells.per.ident Can be used to downsample the data to a certain #' max per cell ident. Default is INF. #' @param random.seed Random seed for downsampling #' #' @rdname SubsetData #' @export #' @method SubsetData Seurat #' SubsetData.Seurat <- function( object, assay = NULL, cells = NULL, subset.name = NULL, ident.use = NULL, ident.remove = NULL, low.threshold = -Inf, high.threshold = Inf, accept.value = NULL, max.cells.per.ident = Inf, random.seed = 1, ... ) { .Deprecated(old = "SubsetData", new = "subset") expression <- character(length = 0L) if (!is.null(x = subset.name)) { sub <- gsub( pattern = '"', replacement = '', x = deparse(expr = substitute(expr = subset.name)) ) if (!is.infinite(x = low.threshold)) { expression <- c( expression, paste(sub, '>', deparse(expr = substitute(expr = low.threshold))) ) } if (!is.infinite(x = high.threshold)) { expression <- c( expression, paste(sub, '<', deparse(expr = substitute(expr = high.threshold))) ) } if (!is.null(x = accept.value)) { expression <- c( expression, paste(sub, '==', deparse(expr = substitute(expr = accept.value))) ) } } #message( # 'With Seurat 3.X, subsetting Seurat objects can now be done with:\n', # 'subset(x = ', # deparse(expr = substitute(expr = object)), # if (length(x = expression) > 0) { # paste0(', subset = ', paste(expression, collapse = ' & ')) # }, # if (length(x = c(cells, ident.use) > 0)) { # paste0(', select = c("', paste0(c(cells, ident.use), collapse = '", '), '")') # }, # if (!is.infinite(x = max.cells.per.ident)) { # paste0(', downsample = ', max.cells.per.ident, ', seed = ', random.seed) # }, # ')' #) assay <- assay %||% DefaultAssay(object = object) cells <- OldWhichCells( object = object, assay = assay, ident = ident.use, ident.remove = ident.remove, subset.name = subset.name, cells = cells, max.cells.per.ident = max.cells.per.ident, random.seed = random.seed, low.threshold = low.threshold, high.threshold = high.threshold, accept.value = accept.value, ... ) # Subset all the Assays assays <- FilterObjects(object = object, classes.keep = 'Assay') for (assay in assays) { slot(object = object, name = "assays")[[assay]] <- SubsetData( object = object[[assay]], cells = cells ) } # Subset all the DimReducs drs <- FilterObjects(object = object, classes.keep = 'DimReduc') for (dr in drs) { object[[dr]] <- CreateDimReducObject( embeddings = Embeddings(object = object[[dr]])[cells, ], loadings = Loadings(object = object[[dr]], projected = FALSE), projected = Loadings(object = object[[dr]], projected = TRUE), assay = DefaultAssay(object = object[[dr]]), stdev = Stdev(object = object[[dr]]), key = Key(object = object[[dr]]), jackstraw = slot(object = object[[dr]], name = "jackstraw"), misc = slot(object[[dr]], name = "misc") ) } slot(object = object, name = "active.ident") <- Idents(object = object)[cells] slot(object = object, name = "meta.data") <- slot(object = object, name = "meta.data")[cells, ] return(object) } #' @param slot Name of tool to pull #' #' @rdname Tool #' @export #' @method Tool Seurat #' #' @examples #' Tool(object = pbmc_small) #' Tool.Seurat <- function(object, slot = NULL, ...) { CheckDots(...) if (is.null(x = slot)) { return(names(x = slot(object = object, name = 'tools'))) } return(slot(object = object, name = 'tools')[[slot]]) } #' @rdname Tool #' @export #' @method Tool<- Seurat #' #' @examples #' \dontrun{ #' sample.tool.output <- matrix(data = rnorm(n = 16), nrow = 4) #' # must be run from within a function #' Tool(object = pbmc_small) <- sample.tool.output #' } "Tool<-.Seurat" <- function(object, ..., value) { CheckDots(...) calls <- as.character(x = sys.calls()) calls <- lapply( X = strsplit(x = calls, split = '(', fixed = TRUE), FUN = '[', 1 ) tool.call <- min(grep(pattern = 'Tool<-', x = calls)) if (tool.call <= 1) { stop("'Tool<-' cannot be called at the top level", call. = FALSE) } tool.call <- calls[[tool.call - 1]] class.call <- unlist(x = strsplit( x = as.character(x = sys.call())[1], split = '.', fixed = TRUE )) class.call <- class.call[length(x = class.call)] tool.call <- sub( pattern = paste0('\\.', class.call, '$'), replacement = '', x = tool.call, perl = TRUE ) slot(object = object, name = 'tools')[[tool.call]] <- value return(object) } #' @rdname VariableFeatures #' @export #' @method VariableFeatures Assay #' VariableFeatures.Assay <- function(object, selection.method = NULL, ...) { CheckDots(...) if (!is.null(x = selection.method)) { vf <- HVFInfo(object = object, selection.method = selection.method, status = TRUE) return(rownames(x = vf)[which(x = vf[, "variable"][, 1])]) } return(slot(object = object, name = 'var.features')) } #' @param assay Name of assay to pull variable features for #' #' @rdname VariableFeatures #' @export #' @method VariableFeatures Seurat #' VariableFeatures.Seurat <- function(object, assay = NULL, selection.method = NULL, ...) { CheckDots(...) assay <- assay %||% DefaultAssay(object = object) return(VariableFeatures(object = object[[assay]], selection.method = selection.method)) } #' @rdname VariableFeatures #' @export #' @method VariableFeatures<- Assay #' "VariableFeatures<-.Assay" <- function(object, ..., value) { CheckDots(...) if (length(x = value) == 0) { slot(object = object, name = 'var.features') <- character(length = 0) return(object) } if (any(grepl(pattern = '_', x = value))) { warning( "Feature names cannot have underscores '_', replacing with dashes '-'", call. = FALSE, immediate = TRUE ) value <- gsub(pattern = '_', replacement = '-', x = value) } value <- split(x = value, f = value %in% rownames(x = object)) if (length(x = value[['FALSE']]) > 0) { if (length(x = value[['TRUE']]) == 0) { stop("None of the features provided are in this Assay object", call. = FALSE) } else { warning( "Not all features provided are in this Assay object, removing the following feature(s): ", paste(value[['FALSE']], collapse = ', '), call. = FALSE, immediate. = TRUE ) } } slot(object = object, name = 'var.features') <- value[['TRUE']] return(object) } #' @inheritParams VariableFeatures.Seurat #' #' @rdname VariableFeatures #' @export #' @method VariableFeatures<- Seurat #' "VariableFeatures<-.Seurat" <- function(object, assay = NULL, ..., value) { CheckDots(...) assay <- assay %||% DefaultAssay(object = object) VariableFeatures(object = object[[assay]]) <- value return(object) } #' @param cells Subset of cell names #' @param expression A predicate expression for feature/variable expression, can #' evalue anything that can be pulled by \code{FetchData}; please note, you may #' need to wrap feature names in backticks (\code{``}) if dashes between numbers #' are present in the feature name #' @param invert Invert the selection of cells #' #' @importFrom stats na.omit #' #' @rdname WhichCells #' @export #' @method WhichCells Assay #' WhichCells.Assay <- function( object, cells = NULL, expression, invert = FALSE, ... ) { CheckDots(...) cells <- cells %||% colnames(x = object) if (!missing(x = expression) && !is.null(x = substitute(expr = expression))) { key.pattern <- paste0('^', Key(object = object)) expr <- if (is.call(x = substitute(expr = expression))) { substitute(expr = expression) } else { parse(text = expression) } expr.char <- as.character(x = expr) expr.char <- unlist(x = lapply(X = expr.char, FUN = strsplit, split = ' ')) expr.char <- gsub( pattern = key.pattern, replacement = '', x = expr.char, perl = TRUE ) expr.char <- gsub( pattern = '(', replacement = '', x = expr.char, fixed = TRUE ) expr.char <- gsub( pattern = '`', replacement = '', x = expr.char ) vars.use <- which(x = expr.char %in% rownames(x = object)) expr.char <- expr.char[vars.use] data.subset <- as.data.frame(x = t(x = as.matrix(x = object[expr.char, ]))) colnames(x = data.subset) <- expr.char data.subset <- subset.data.frame(x = data.subset, subset = eval(expr = expr)) cells <- rownames(x = data.subset) } if (invert) { cells <- colnames(x = object)[!colnames(x = object) %in% cells] } cells <- na.omit(object = unlist(x = cells, use.names = FALSE)) return(as.character(x = cells)) } #' @param idents A vector of identity classes to keep #' @param slot Slot to pull feature data for #' @param downsample Maximum number of cells per identity class, default is \code{Inf}; #' downsampling will happen after all other operations, including inverting the #' cell selection #' @param seed Random seed for downsampling. If NULL, does not set a seed #' #' @importFrom stats na.omit #' #' @rdname WhichCells #' @export #' @method WhichCells Seurat #' WhichCells.Seurat <- function( object, cells = NULL, idents = NULL, expression, slot = 'data', invert = FALSE, downsample = Inf, seed = 1, ... ) { CheckDots(...) cells <- cells %||% colnames(x = object) if (is.numeric(x = cells)) { cells <- colnames(x = object)[cells] } cell.order <- cells if (!is.null(x = idents)) { if (!is.null(x = seed)) { set.seed(seed = seed) } if (any(!idents %in% levels(x = Idents(object = object)))) { stop( "Cannot find the following identities in the object: ", paste( idents[!idents %in% levels(x = Idents(object = object))], sep = ', ' ) ) } cells.idents <- unlist(x = lapply( X = idents, FUN = function(i) { cells.use <- which(x = as.vector(x = Idents(object = object)) == i) cells.use <- names(x = Idents(object = object)[cells.use]) return(cells.use) } )) cells <- intersect(x = cells, y = cells.idents) } if (!missing(x = expression)) { objects.use <- FilterObjects(object = object) object.keys <- sapply( X = objects.use, FUN = function(i) { return(Key(object = object[[i]])) } ) key.pattern <- paste0('^', object.keys, collapse = '|') expr <- if (is.call(x = substitute(expr = expression))) { substitute(expr = expression) } else { parse(text = expression) } expr.char <- as.character(x = expr) expr.char <- unlist(x = lapply(X = expr.char, FUN = strsplit, split = ' ')) expr.char <- gsub( pattern = '(', replacement = '', x = expr.char, fixed = TRUE ) expr.char <- gsub( pattern = '`', replacement = '', x = expr.char ) vars.use <- which( x = expr.char %in% rownames(x = object) | expr.char %in% colnames(x = object[[]]) | grepl(pattern = key.pattern, x = expr.char, perl = TRUE) ) data.subset <- FetchData( object = object, vars = expr.char[vars.use], cells = cells, slot = slot ) data.subset <- subset.data.frame(x = data.subset, subset = eval(expr = expr)) cells <- rownames(x = data.subset) } if (invert) { cell.order <- colnames(x = object) cells <- colnames(x = object)[!colnames(x = object) %in% cells] } cells <- CellsByIdentities(object = object, cells = cells) cells <- lapply( X = cells, FUN = function(x) { if (length(x = x) > downsample) { x <- sample(x = x, size = downsample, replace = FALSE) } return(x) } ) cells <- as.character(x = na.omit(object = unlist(x = cells, use.names = FALSE))) cells <- cells[na.omit(object = match(x = cell.order, table = cells))] return(cells) } #' @note #' \code{WriteH5AD} is not currently functional, please use \code{\link{as.loom}} instead #' #' @seealso \code{\link{as.loom}} #' #' @param graph Name of graph to write out, defaults to \code{paste0(assay, '_snn')} #' @param overwrite Overwrite existing file #' #' @importFrom methods slot #' @importFrom reticulate py_module_available import tuple np_array dict #' #' @rdname h5ad #' @export #' @method WriteH5AD Seurat #' WriteH5AD.Seurat <- function( object, file, assay = NULL, graph = NULL, verbose = TRUE, overwrite = FALSE, ... ) { message("WriteH5AD is not currently operational, please use as.loom") .NotYetImplemented() if (!PackageCheck('hdf5r', error = FALSE)) { stop("Please install hdf5r to enable h5ad functionality") } CheckDots(...) if (file.exists(file) && !overwrite) { stop("Output file exists, not overwriting") } assay <- assay %||% DefaultAssay(object = object) graph <- graph %||% paste0(assay, '_snn') DefaultAssay(object = object) <- assay object[['active_assay']] <- Idents(object = object) # Figure out which slot to store as X x.slot <- if (!IsMatrixEmpty(x = GetAssayData(object = object, slot = 'scale.data'))) { 'scale.data' } else if (identical(x = GetAssayData(object = object, slot = 'counts'), y = GetAssayData(object = object, slot = 'data'))) { 'counts' } else { 'data' } if (verbose) { message("Storing '", x.slot, "' into 'X'") } # Figure out which slot to store as raw raw.slot <- switch( EXPR = x.slot, 'scale.data' = 'data', 'data' = 'counts', NULL ) if (verbose) { message("Storing '", raw.slot, "' into 'raw.X'") } # Handle cases where we have data but no counts if (x.slot == 'counts' && IsMatrixEmpty(x = GetAssayData(object = object, slot = x.slot))) { if (verbose) { warning("Counts slot empty, storing data slot into 'X', not storing a raw.X") } x.slot <- 'data' raw.slot <- NULL } # Fix meta feature column names meta.features <- object[[assay]][[]] colnames(x = meta.features) <- gsub( pattern = 'dispersion.scaled', replacement = 'dispersions_norm', x = colnames(x = meta.features) ) colnames(x = meta.features) <- gsub( pattern = 'dispersion', replacement = 'dispersions', x = colnames(x = meta.features) ) colnames(x = meta.features) <- gsub( pattern = 'mean', replacement = 'means', x = colnames(x = meta.features) ) colnames(x = meta.features) <- gsub( pattern = '\\.', replacement = '_', x = colnames(x = meta.features) ) # Add variable feature information meta.features$highly_variable <- FALSE meta.features[VariableFeatures(object = object), 'highly_variable'] <- TRUE # Reorder feature-level metadata meta.features$index <- rownames(x = meta.features) mf.order <- c( 'index', grep( pattern = 'index', x = colnames(x = meta.features), invert = TRUE, value = TRUE ) ) meta.features <- meta.features[, mf.order, drop = FALSE] # Fix metadata column names meta.data <- object[[]] assays.remove <- grep( pattern = assay, x = FilterObjects(object = object, classes.keep = 'Assay'), invert = TRUE, value = TRUE ) if (length(x = assays.remove)) { assays.remove <- grep( pattern = assays.remove, x = colnames(x = meta.data) ) meta.data <- meta.data[, -assays.remove, drop = FALSE] } colnames(x = meta.data) <- gsub( pattern = paste0('nCount_', assay), replacement = 'n_counts', x = colnames(x = meta.data) ) colnames(x = meta.data) <- gsub( pattern = paste0('nFeatures_', assay), replacement = 'n_umis', x = colnames(x = meta.data) ) colnames(x = meta.data) <- gsub( pattern = '\\.', replacement = '_', x = colnames(x = meta.data) ) # Reorder cell-level metadata meta.data$index <- rownames(x = meta.data) md.order <- c( 'index', grep( pattern = 'index', x = colnames(x = meta.data), invert = TRUE, value = TRUE ) ) meta.data <- meta.data[, md.order, drop = FALSE] # Write X hfile <- hdf5r::h5file(filename = file, mode = 'w') if (verbose) { message("Writing 'X' matrix") } x.data <- GetAssayData(object = object, slot = x.slot, assay = assay) switch( EXPR = x.slot, 'scale.data' = hfile[['X']] <- x.data, { x.data <- as.sparse(x = x.data) hfile[['X/indices']] <- slot(object = x.data, 'i') - 1 hfile[['X/indptr']] <- slot(object = x.data, 'p') hfile[['X/data']] <- slot(object = x.data, 'x') } ) # Write var (feature-level metadata) # var only has the features that are present in X if (verbose) { message("Writing 'var' metadata") } hfile[['var']] <- meta.features[rownames(x = x.data), , drop = FALSE] # Write raw.X and raw.var if (!is.null(x = raw.slot)) { if (verbose) { message("Writing 'raw.X' sparse matrix") } # Write raw.X raw.data <- GetAssayData(object = object, slot = raw.slot, assay = assay) hfile[['raw.X/indices']] <- slot(object = raw.data, 'i') - 1 hfile[['raw.X/indptr']] <- slot(object = raw.data, 'p') hfile[['raw.X/data']] <- slot(object = raw.data, 'x') # Write raw.var if (verbose) { message("Writing 'raw.var' metadata") } hfile[['raw.var']] <- meta.features } # Write obs (cell-level metadata) if (verbose) { message("Writing 'obs' metadata") } hfile[['obs']] <- meta.data # Write out dimensional reduction information if (x.slot == 'scale.data') { # Find dimensional reduction objects for this assay dim.reducs <- FilterObjects(object = object, classes.keep = 'DimReduc') dim.reducs <- Filter( f = function(x) { return(DefaultAssay(object = object[[x]]) == assay) }, x = dim.reducs ) # If we have any dimensional reduction objects, write them out if (length(x = dim.reducs) >= 1) { embedding.names <- paste0('X_', dim.reducs) names(x = embedding.names) <- dim.reducs loading.names <- gsub( pattern = '_$', replacement = 's', x = vapply( X = dim.reducs, FUN = function(x) { return(Key(object[[x]])) }, FUN.VALUE = character(length = 1L) ) ) # TODO: Write obsm (cell embeddings) embeddings <- sapply( X = dim.reducs, FUN = function(x) { return(t(x = Embeddings(object = object, reduction = x))) }, USE.NAMES = TRUE, simplify = FALSE ) names(x = embeddings) <- embedding.names[names(x = embeddings)] hfile[['obsm']] <- embeddings # TODO: Write varm (feature loadings) # TODO: Write Stdev information to uns } else if (verbose) { warning("No dimensional reduction objects for assay '", assay, "' found") } } else if (verbose) { warning("Intial object unscaled, not storing dimensional reduction information") } # TODO: Write neighbors if (x.slot == 'scale.data') { # Find a Graph with the name provided graphs <- FilterObjects(object = object, classes.keep = 'Graph') graphs <- grep(pattern = graph, x = graphs, value = TRUE) # If we have a grpah, write it out if (length(x = graphs) == 1) { '' } else if (verbose) { warning("Could not find a graph named '", graph, "'") } } else if (verbose) { warning("Initial object unscaled, not storing graph information") } # Flush our h5ad file and return it invisibly hfile$flush() invisible(x = hfile) # adata <- anndata$AnnData() # if (!is.null(x = raw.slot)) { # raw <- GetAssayData(object = object, slot = raw.slot) # raw.mf <- object[[assay]][[]] # raw.mf <- raw.mf[rownames(x = raw), , drop = FALSE] # adata$X <- as.scipy(x = raw) # adata$var <- raw.mf # adata$raw <- adata # } # if (inherits(x = raw, what = c('matrix', 'Matrix'))) { # raw <- as(object = raw, Class = "dgCMatrix") # } else { # raw <- as(object = as.matrix(x = raw), Class = "dgCMatrix") # } # sp_sparse_csc <- scipy$csc_matrix # raw.rownames <- rownames(x = raw) # raw <- sp_sparse_csc( # tuple(np_array(raw@x), np_array(raw@i), np_array(raw@p)), # shape = tuple(raw@Dim[1], raw@Dim[2]) # ) # if (inherits(x = raw, what = c('matrix', 'Matrix', 'data.frame'))) { # raw <- r_to_py(x = raw) # } # raw <- raw$T # raw <- dict(X = raw, var = dict(var_names = raw.rownames)) # if (anndata.X == 'data') { # X <- sp_sparse_csc( # tuple(np_array(X@x), np_array(X@i), np_array(X@p)), # shape = tuple(X@Dim[1], X@Dim[2]) # ) # X <- X$T # } else { # X <- np_array(t(x = X)) # } # obsm <- list() # for (dr in names(object@dr)) { # obsm[[paste0("X_",dr)]] <- np_array(Embeddings(object = object[[dr]])) # } # obsm <- if (!identical(obsm, list())) dict(obsm) else NULL # meta_data <- object@meta.data # if ("nUMI" %in% colnames(x = meta_data)) { # colnames(x = meta_data) <- gsub( # pattern = "nUMI", # replacement = "n_counts", # x = colnames(x = meta_data) # ) # } # if ("nGene" %in% colnames(x = meta_data)) { # colnames(x = meta_data) <- gsub( # pattern = "nGene", # replacement = "n_genes", # x = colnames(x = meta_data) # ) # } # colnames(x = meta_data) <- gsub( # pattern = "\\.", # replacement = "_", # x = colnames(x = meta_data) # ) # anndata.object <- ad$AnnData( # raw = raw, # X = X, # obs = meta_data, # var = object@hvg.info, # obsm = obsm # ) # anndata.object$var_names <- gene_names # anndata.object$obs_names <- cell_names # if (!missing(x = file)) { # anndata.object$write(file) # } # invisible(x = NULL) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Methods for R-defined generics #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' @importFrom utils .DollarNames #' @export #' @method .DollarNames JackStrawData #' ".DollarNames.JackStrawData" <- function(x, pattern = '') { slotnames <- as.list(x = slotNames(x = x)) names(x = slotnames) <- unlist(x = slotnames) return(.DollarNames(x = slotnames, pattern = pattern)) } #' @importFrom utils .DollarNames #' @export #' @method .DollarNames Seurat #' ".DollarNames.Seurat" <- function(x, pattern = '') { meta.data <- as.list(x = colnames(x = x[[]])) names(x = meta.data) <- unlist(x = meta.data) return(.DollarNames(x = meta.data, pattern = pattern)) } #' @importFrom utils .DollarNames #' @export #' @method .DollarNames SeuratCommand #' ".DollarNames.SeuratCommand" <- function(x, pattern = '') { return(.DollarNames(x = slot(object = x, name = "params"), pattern = pattern)) } #' @export #' "$.JackStrawData" <- function(x, i, ...) { return(slot(object = x, name = i)) } #' @export #' "$.Seurat" <- function(x, i, ...) { return(x[[i, drop = TRUE]]) } #' @export #' "$.SeuratCommand" <- function(x, i, ...) { params <- slot(object = x, name = "params") return(params[[i]]) } #' @export #' "$<-.Seurat" <- function(x, i, ..., value) { x[[i]] <- value return(x) } #' @export #' @method [ Assay #' "[.Assay" <- function(x, i, j, ...) { if (missing(x = i)) { i <- 1:nrow(x = x) } if (missing(x = j)) { j <- 1:ncol(x = x) } return(GetAssayData(object = x)[i, j, ..., drop = FALSE]) } #' @export #' @method [ DimReduc #' "[.DimReduc" <- function(x, i, j, drop = FALSE, ...) { loadings <- Loadings(object = x) if (missing(x = i)) { i <- 1:nrow(x = loadings) } if (missing(x = j)) { j <- names(x = x) } else if (is.numeric(x = j)) { j <- names(x = x)[j] } bad.j <- j[!j %in% colnames(x = loadings)] j <- j[!j %in% bad.j] if (length(x = j) == 0) { stop("None of the requested loadings are present.") } if (length(x = bad.j) > 0) { warning(paste0("The following loadings are not present: ", paste(bad.j, collapse = ", "))) } return(Loadings(object = x)[i, j, drop = drop, ...]) } #' @inheritParams subset.Seurat #' #' @rdname subset.Seurat #' @export #' @method [ Seurat #' #' @examples #' pbmc_small[VariableFeatures(object = pbmc_small), ] #' pbmc_small[, 1:10] #' "[.Seurat" <- function(x, i, j, ...) { if (missing(x = i) && missing(x = j)) { return(x) } if (missing(x = i)) { i <- NULL } else if (missing(x = j)) { j <- colnames(x = x) } if (is.logical(x = i)) { if (length(i) != nrow(x = x)) { stop("Incorrect number of logical values provided to subset features") } i <- rownames(x = x)[i] } if (is.logical(x = j)) { if (length(j) != ncol(x = x)) { stop("Incorrect number of logical values provided to subset cells") } j <- colnames(x = x)[j] } if (is.numeric(x = i)) { i <- rownames(x = x)[i] } if (is.numeric(x = j)) { j <- colnames(x = x)[j] } return(subset.Seurat(x = x, features = i, cells = j, ...)) } #' @export #' @method [ SeuratCommand #' "[.SeuratCommand" <- function(x, i, ...) { slot.use <- c("name", "timestamp", "call_string", "params") if (!i %in% slot.use) { stop("Invalid slot") } return(slot(object = x, name = i)) } #' @export #' @method [[ Assay #' "[[.Assay" <- function(x, i, ..., drop = FALSE) { if (missing(x = i)) { i <- colnames(x = slot(object = x, name = 'meta.features')) } data.return <- slot(object = x, name = 'meta.features')[, i, drop = FALSE, ...] if (drop) { data.return <- unlist(x = data.return, use.names = FALSE) names(x = data.return) <- rep.int(x = rownames(x = x), times = length(x = i)) } return(data.return) } #' @export #' @method [[ DimReduc #' "[[.DimReduc" <- function(x, i, j, drop = FALSE, ...) { if (missing(x = i)) { i <- 1:nrow(x = x) } if (missing(x = j)) { j <- names(x = x) } else if (is.numeric(x = j)) { j <- names(x = x)[j] } embeddings <- Embeddings(object = x) bad.j <- j[!j %in% colnames(x = embeddings)] j <- j[!j %in% bad.j] if (length(x = j) == 0) { stop("None of the requested embeddings are present.") } if (length(x = bad.j) > 0) { warning(paste0("The following embeddings are not present: ", paste(bad.j, collapse = ", "))) } return(embeddings[i, j, drop = drop, ...]) } #' @export #' @method [[ Seurat #' "[[.Seurat" <- function(x, i, ..., drop = FALSE) { if (missing(x = i)) { i <- colnames(x = slot(object = x, name = 'meta.data')) } if (length(x = i) == 0) { return(data.frame(row.names = colnames(x = x))) } else if (length(x = i) > 1 || any(i %in% colnames(x = slot(object = x, name = 'meta.data')))) { if (any(!i %in% colnames(x = slot(object = x, name = 'meta.data')))) { warning( "Cannot find the following bits of meta data: ", paste0( i[!i %in% colnames(x = slot(object = x, name = 'meta.data'))], collapse = ', ' ) ) } i <- i[i %in% colnames(x = slot(object = x, name = 'meta.data'))] data.return <- slot(object = x, name = 'meta.data')[, i, drop = FALSE, ...] if (drop) { data.return <- unlist(x = data.return, use.names = FALSE) names(x = data.return) <- rep.int(x = colnames(x = x), times = length(x = i)) } } else { slot.use <- unlist(x = lapply( X = c('assays', 'reductions', 'graphs', 'neighbors', 'commands'), FUN = function(s) { if (any(i %in% names(x = slot(object = x, name = s)))) { return(s) } return(NULL) } )) if (is.null(x = slot.use)) { stop("Cannot find '", i, "' in this Seurat object") } data.return <- slot(object = x, name = slot.use)[[i]] } return(data.return) } #' Coerce a SeuratCommand to a list #' #' @inheritParams base::as.list #' @param complete Include slots besides just parameters (eg. call string, name, timestamp) #' #' @return A list with the parameters and, if \code{complete = TRUE}, the call string, name, and timestamp #' #' @export #' @method as.list SeuratCommand #' as.list.SeuratCommand <- function(x, complete = FALSE, ...) { CheckDots(...) cmd <- slot(object = x, name = 'params') if (complete) { cmd <- append( x = cmd, values = sapply( X = grep( pattern = 'params', x = slotNames(x = x), invert = TRUE, value = TRUE ), FUN = slot, object = x, simplify = FALSE, USE.NAMES = TRUE ), after = 0 ) } for (i in 1:length(x = cmd)) { if (is.character(x = cmd[[i]])) { cmd[[i]] <- paste(trimws(x = cmd[[i]]), collapse = ' ') } } return(cmd) } #' @export #' @method as.logical JackStrawData #' as.logical.JackStrawData <- function(x, ...) { CheckDots(...) empP <- JS(object = x, slot = 'empirical') return(!(all(dim(x = empP) == 0) || all(is.na(x = empP)))) } #' @export #' @method dim Assay #' dim.Assay <- function(x) { return(dim(x = GetAssayData(object = x))) } #' @export #' @method dim DimReduc #' dim.DimReduc <- function(x) { return(dim(x = Embeddings(object = x))) } #' @export #' @method dim Seurat #' dim.Seurat <- function(x) { return(dim(x = GetAssay(object = x))) } #' @export #' @method dimnames Assay #' dimnames.Assay <- function(x) { return(dimnames(x = GetAssayData(object = x))) } #' @export #' @method dimnames DimReduc #' dimnames.DimReduc <- function(x) { return(dimnames(x = Embeddings(object = x))) } #' @export #' @method dimnames Seurat #' dimnames.Seurat <- function(x) { return(dimnames(x = GetAssay(object = x))) } #' @export #' @method droplevels Seurat #' droplevels.Seurat <- function(x, ...) { slot(object = x, name = 'active.ident') <- droplevels(x = Idents(object = x), ...) return(x) } #' @export #' @method length DimReduc #' length.DimReduc <- function(x) { return(ncol(x = Embeddings(object = x))) } #' @rdname Idents #' @export #' @method levels Seurat #' #' @examples #' # Get the levels of identity classes of a Seurat object #' levels(x = pbmc_small) #' levels.Seurat <- function(x) { return(levels(x = Idents(object = x))) } #' @rdname Idents #' @export #' @method levels<- Seurat #' #' @examples #' # Reorder identity classes #' levels(x = pbmc_small) #' levels(x = pbmc_small) <- c('C', 'A', 'B') #' levels(x = pbmc_small) #' "levels<-.Seurat" <- function(x, value) { idents <- Idents(object = x) if (!all(levels(x = idents) %in% value)) { stop("NA's generated by missing levels", call. = FALSE) } idents <- factor(x = idents, levels = value) Idents(object = x) <- idents return(x) } #' @rdname merge.Seurat #' @export #' @method merge Assay #' merge.Assay <- function( x = NULL, y = NULL, add.cell.ids = NULL, merge.data = TRUE, ... ) { CheckDots(...) assays <- c(x, y) if (!is.null(x = add.cell.ids)) { for (i in 1:length(assays)) { assays[[i]] <- RenameCells(object = assays[[i]], new.names = add.cell.ids[i]) } } # Merge the counts (if present) merged.counts <- ValidateDataForMerge(assay = assays[[1]], slot = "counts") keys <- Key(object = assays[[1]]) for (i in 2:length(x = assays)) { merged.counts <- RowMergeSparseMatrices( mat1 = merged.counts, mat2 = ValidateDataForMerge(assay = assays[[i]], slot = "counts") ) if (length(Key(object = assays[[i]]) > 0)) { keys[i] <- Key(object = assays[[i]]) } } combined.assay <- CreateAssayObject( counts = merged.counts, min.cells = -1, min.features = -1 ) if (length(x = unique(x = keys)) == 1) { Key(object = combined.assay) <- keys[1] } if (merge.data) { merged.data <- ValidateDataForMerge(assay = assays[[1]], slot = "data") for (i in 2:length(x = assays)) { merged.data <- RowMergeSparseMatrices( mat1 = merged.data, mat2 = ValidateDataForMerge(assay = assays[[i]], slot = "data") ) } # only keep cells that made it through counts filtering params merged.data <- merged.data[, colnames(x = combined.assay)] combined.assay <- SetAssayData( object = combined.assay, slot = "data", new.data = merged.data ) } # merge SCT assay misc vst info and scale.data if (all(IsSCT(assay = assays))) { vst.set.new <- list() idx <- 1 for (i in 1:length(x = assays)) { vst.set.old <- Misc(object = assays[[i]], slot = "vst.set") if (!is.null(x = vst.set.old)) { for (j in 1:length(x = vst.set.old)) { vst.set.new[[idx]] <- vst.set.old[[j]] idx <- idx + 1 } } else if (!is.null(x = Misc(object = assays[[i]], slot = "vst.out"))) { vst.set.new[[idx]] <- Misc(object = assays[[i]], slot = "vst.out") idx <- idx + 1 } } Misc(object = combined.assay, slot = "vst.set") <- vst.set.new scale.data <- do.call( what = cbind, args = lapply(X = assays, FUN = function(x) GetAssayData(object = x, slot = "scale.data")) ) combined.assay <- SetAssayData( object = combined.assay, slot = "scale.data", new.data = scale.data ) } return(combined.assay) } #' Merge Seurat Objects #' #' Merge two or more objects. #' #' When merging Seurat objects, the merge procedure will merge the Assay level #' counts and potentially the data slots (depending on the merge.data parameter). #' It will also merge the cell-level meta data that was stored with each object #' and preserve the cell identities that were active in the objects pre-merge. #' The merge will not preserve reductions, graphs, logged commands, or feature-level metadata #' that were present in the original objects. If add.cell.ids isn't specified #' and any cell names are duplicated, cell names will be appended with _X, where #' X is the numeric index of the object in c(x, y). #' #' @inheritParams CreateSeuratObject #' @param x Object #' @param y Object (or a list of multiple objects) #' @param add.cell.ids A character vector of length(x = c(x, y)). Appends the #' corresponding values to the start of each objects' cell names. #' @param merge.data Merge the data slots instead of just merging the counts #' (which requires renormalization). This is recommended if the same normalization #' approach was applied to all objects. #' @param ... Arguments passed to other methods #' #' @return Merged object #' #' @rdname merge.Seurat #' @aliases merge MergeSeurat AddSamples #' #' @export #' @method merge Seurat #' #' @examples #' # merge two objects #' merge(x = pbmc_small, y = pbmc_small) #' # to merge more than two objects, pass one to x and a list of objects to y #' merge(x = pbmc_small, y = c(pbmc_small, pbmc_small)) #' merge.Seurat <- function( x = NULL, y = NULL, add.cell.ids = NULL, merge.data = TRUE, project = "SeuratProject", ... ) { CheckDots(...) objects <- c(x, y) if (!is.null(x = add.cell.ids)) { if (length(x = add.cell.ids) != length(x = objects)) { stop("Please provide a cell identifier for each object provided to merge") } for (i in 1:length(x = objects)) { objects[[i]] <- RenameCells(object = objects[[i]], add.cell.id = add.cell.ids[i]) } } # ensure unique cell names objects <- CheckDuplicateCellNames(object.list = objects) assays <- lapply( X = objects, FUN = FilterObjects, classes.keep = 'Assay' ) fake.feature <- RandomName(length = 17) assays <- unique(x = unlist(x = assays, use.names = FALSE)) combined.assays <- vector(mode = 'list', length = length(x = assays)) names(x = combined.assays) <- assays for (assay in assays) { assays.merge <- lapply( X = objects, FUN = function(object) { return(tryCatch( expr = object[[assay]], error = function(e) { return(CreateAssayObject(counts = Matrix( data = 0, ncol = ncol(x = object), dimnames = list(fake.feature, colnames(x = object)), sparse = TRUE ))) } )) } ) if (all(IsSCT(assay = assays.merge))) { scaled.features <- unique(x = unlist(x = lapply( X = assays.merge, FUN = function(x) rownames(x = GetAssayData(object = x, slot = "scale.data"))) )) for (ob in 1:length(x = objects)) { if (assay %in% FilterObjects(object = objects[[ob]], classes.keep = "Assay")) { objects[[ob]] <- suppressWarnings(GetResidual(object = objects[[ob]], features = scaled.features, assay = assay, verbose = FALSE)) assays.merge[[ob]] <- objects[[ob]][[assay]] } } # handle case where some features aren't in counts and can't be retrieved with # GetResidual - take intersection scaled.features <- names(x = which(x = table(x = unlist(x = lapply( X = assays.merge, FUN = function(x) rownames(x = GetAssayData(object = x, slot = "scale.data"))) )) == length(x = assays.merge))) for (a in 1:length(x = assays.merge)) { assays.merge[[a]] <- SetAssayData( object = assays.merge[[a]], slot = "scale.data", new.data = GetAssayData(object = assays.merge[[a]], slot = "scale.data")[scaled.features, ]) } } merged.assay <- merge( x = assays.merge[[1]], y = assays.merge[2:length(x = assays.merge)], merge.data = merge.data ) merged.assay <- subset( x = merged.assay, features = rownames(x = merged.assay)[rownames(x = merged.assay) != fake.feature] ) if (length(x = Key(object = merged.assay)) == 0) { Key(object = merged.assay) <- paste0(assay, '_') } combined.assays[[assay]] <- merged.assay } # Merge the meta.data combined.meta.data <- data.frame(row.names = colnames(x = combined.assays[[1]])) new.idents <- c() for (object in objects) { old.meta.data <- object[[]] if (any(!colnames(x = old.meta.data) %in% colnames(x = combined.meta.data))) { cols.to.add <- colnames(x = old.meta.data)[!colnames(x = old.meta.data) %in% colnames(x = combined.meta.data)] combined.meta.data[, cols.to.add] <- NA } # unfactorize any factor columns i <- sapply(X = old.meta.data, FUN = is.factor) old.meta.data[i] <- lapply(X = old.meta.data[i], FUN = as.vector) combined.meta.data[rownames(x = old.meta.data), colnames(x = old.meta.data)] <- old.meta.data new.idents <- c(new.idents, as.vector(Idents(object = object))) } names(x = new.idents) <- rownames(x = combined.meta.data) new.idents <- factor(x = new.idents) if (DefaultAssay(object = x) %in% assays) { new.default.assay <- DefaultAssay(object = x) } else if (DefaultAssay(object = y) %in% assays) { new.default.assay <- DefaultAssay(object = y) } else { new.default.assay <- assays[1] } merged.object <- new( Class = 'Seurat', assays = combined.assays, meta.data = combined.meta.data, active.assay = new.default.assay, active.ident = new.idents, project.name = project, version = packageVersion(pkg = 'Seurat') ) return(merged.object) } #' @export #' @method names DimReduc #' names.DimReduc <- function(x) { return(colnames(x = Embeddings(object = x))) } #' @export #' @method names Seurat #' names.Seurat <- function(x) { return(FilterObjects(object = x, classes.keep = c('Assay', 'DimReduc', 'Graph'))) } #' Print the results of a dimensional reduction analysis #' #' Prints a set of features that most strongly define a set of components #' #' @param x An object #' @param dims Number of dimensions to display #' @param nfeatures Number of genes to display #' @param projected Use projected slot #' @param ... Arguments passed to other methods #' #' @return Set of features defining the components #' #' @aliases print #' @seealso \code{\link[base]{cat}} #' #' @export #' @method print DimReduc #' print.DimReduc <- function(x, dims = 1:5, nfeatures = 20, projected = FALSE, ...) { CheckDots(...) loadings <- Loadings(object = x, projected = projected) nfeatures <- min(nfeatures, nrow(x = loadings)) if (ncol(x = loadings) == 0) { warning("Dimensions have not been projected. Setting projected = FALSE") projected <- FALSE loadings <- Loadings(object = x, projected = projected) } if (min(dims) > ncol(x = loadings)) { stop("Cannot print dimensions greater than computed") } if (max(dims) > ncol(x = loadings)) { warning(paste0("Only ", ncol(x = loadings), " dimensions have been computed.")) dims <- min(dims):ncol(x = loadings) } for (dim in dims) { features <- TopFeatures( object = x, dim = dim, nfeatures = nfeatures * 2, projected = projected, balanced = TRUE ) cat(Key(object = x), dim, '\n') pos.features <- split(x = features$positive, f = ceiling(x = seq_along(along.with = features$positive) / 10)) cat("Positive: ", paste(pos.features[[1]], collapse = ", "), '\n') pos.features[[1]] <- NULL if (length(x = pos.features) > 0) { for (i in pos.features) { cat("\t ", paste(i, collapse = ", "), '\n') } } neg.features <- split(x = features$negative, f = ceiling(x = seq_along(along.with = features$negative) / 10)) cat("Negative: ", paste(neg.features[[1]], collapse = ", "), '\n') neg.features[[1]] <- NULL if (length(x = neg.features) > 0) { for (i in neg.features) { cat("\t ", paste(i, collapse = ", "), '\n') } } } } #' @importFrom stats na.omit #' #' @export #' @method subset Assay #' subset.Assay <- function(x, cells = NULL, features = NULL, ...) { CheckDots(...) cells <- cells %||% colnames(x = x) if (all(is.na(x = cells))) { cells <- colnames(x = x) } else if (any(is.na(x = cells))) { warning("NAs passed in cells vector, removing NAs") cells <- na.omit(object = cells) } features <- features %||% rownames(x = x) if (all(is.na(x = features))) { features <- rownames(x = x) } else if (any(is.na(x = features))) { warning("NAs passed in the features vector, removing NAs") features <- na.omit(object = features) } if (all(sapply(X = list(features, cells), FUN = length) == dim(x = x))) { return(x) } if (is.numeric(x = features)) { features <- rownames(x = x)[features] } features <- gsub( pattern = paste0('^', Key(object = x)), replacement = '', x = features ) features <- intersect(x = rownames(x = x), y = features) if (length(x = features) == 0) { stop("Cannot find features provided") } if (ncol(x = GetAssayData(object = x, slot = 'counts')) == ncol(x = x)) { slot(object = x, name = "counts") <- GetAssayData(object = x, slot = "counts")[features, cells, drop = FALSE] } slot(object = x, name = "data") <- GetAssayData(object = x, slot = "data")[features, cells, drop = FALSE] cells.scaled <- colnames(x = GetAssayData(object = x, slot = "scale.data")) cells.scaled <- cells.scaled[cells.scaled %in% cells] cells.scaled <- cells.scaled[na.omit(object = match(x = colnames(x = x), table = cells.scaled))] features.scaled <- rownames(x = GetAssayData(object = x, slot = 'scale.data')) features.scaled <- features.scaled[features.scaled %in% features] slot(object = x, name = "scale.data") <- if (length(x = cells.scaled) > 0 && length(x = features.scaled) > 0) { GetAssayData(object = x, slot = "scale.data")[features.scaled, cells.scaled, drop = FALSE] } else { new(Class = 'matrix') } VariableFeatures(object = x) <- VariableFeatures(object = x)[VariableFeatures(object = x) %in% features] slot(object = x, name = 'meta.features') <- x[[]][features, , drop = FALSE] return(x) } #' @export #' @method subset DimReduc #' subset.DimReduc <- function(x, cells = NULL, features = NULL, ...) { CheckDots(...) cells <- Cells(x = x) %iff% cells %||% Cells(x = x) if (all(is.na(x = cells))) { cells <- Cells(x = x) } else if (any(is.na(x = cells))) { warning("NAs passed in cells vector, removing NAs") cells <- na.omit(object = cells) } # features <- rownames(x = x) %iff% features %||% rownames(x = x) features <- rownames(x = Loadings(object = x)) %iff% features %||% rownames(x = Loadings(object = x)) if (all(sapply(X = list(features, cells), FUN = length) == dim(x = x))) { return(x) } slot(object = x, name = 'cell.embeddings') <- if (is.null(x = cells)) { new(Class = 'matrix') } else { if (is.numeric(x = cells)) { cells <- Cells(x = x)[cells] } cells <- intersect(x = cells, y = Cells(x = x)) if (length(x = cells) == 0) { stop("Cannot find cell provided", call. = FALSE) } x[[cells, , drop = FALSE]] } slot(object = x, name = 'feature.loadings') <- if (is.null(x = features)) { new(Class = 'matrix') } else { if (is.numeric(x = features)) { features <- rownames(x = x)[features] } features.loadings <- intersect( x = rownames(x = Loadings(object = x, projected = FALSE)), y = features ) if (length(x = features.loadings) == 0) { stop("Cannot find features provided", call. = FALSE) } Loadings(object = x, projected = FALSE)[features.loadings, , drop = FALSE] } slot(object = x, name = 'feature.loadings.projected') <- if (is.null(x = features) || !Projected(object = x)) { new(Class = 'matrix') } else { features.projected <- intersect( x = rownames(x = Loadings(object = x, projected = TRUE)), y = features ) if (length(x = features.projected) == 0) { stop("Cannot find features provided", call. = FALSE) } Loadings(object = x, projected = TRUE)[features.projected, , drop = FALSE] } slot(object = x, name = 'jackstraw') <- new(Class = 'JackStrawData') return(x) } #' Subset a Seurat object #' #' @param x Seurat object to be subsetted #' @param subset Logical expression indicating features/variables to keep #' @param i,features A vector of features to keep #' @param j,cells A vector of cells to keep #' @param idents A vector of identity classes to keep #' @param ... Extra parameters passed to \code{\link{WhichCells}}, #' such as \code{slot}, \code{invert}, or \code{downsample} #' #' @return A subsetted Seurat object #' #' @rdname subset.Seurat #' @aliases subset #' @seealso \code{\link[base]{subset}} \code{\link{WhichCells}} #' #' @export #' @method subset Seurat #' #' @examples #' subset(x = pbmc_small, subset = MS4A1 > 4) #' subset(x = pbmc_small, subset = `DLGAP1-AS1` > 2) #' subset(x = pbmc_small, idents = '0', invert = TRUE) #' subset(x = pbmc_small, subset = MS4A1 > 3, slot = 'counts') #' subset(x = pbmc_small, features = VariableFeatures(object = pbmc_small)) #' subset.Seurat <- function(x, subset, cells = NULL, features = NULL, idents = NULL, ...) { if (!missing(x = subset)) { subset <- deparse(expr = substitute(expr = subset)) } cells <- WhichCells( object = x, cells = cells, idents = idents, expression = subset, ... ) if (length(x = cells) == 0) { stop("No cells found", call. = FALSE) } if (all(cells %in% Cells(x = x)) && length(x = cells) == length(x = Cells(x = x)) && is.null(x = features)) { return(x) } assays <- FilterObjects(object = x, classes.keep = 'Assay') # Filter Assay objects for (assay in assays) { assay.features <- features %||% rownames(x = x[[assay]]) slot(object = x, name = 'assays')[[assay]] <- tryCatch( expr = subset.Assay(x = x[[assay]], cells = cells, features = assay.features), error = function(e) { return(NULL) } ) } slot(object = x, name = 'assays') <- Filter( f = Negate(f = is.null), x = slot(object = x, name = 'assays') ) if (length(x = FilterObjects(object = x, classes.keep = 'Assay')) == 0 || is.null(x = x[[DefaultAssay(object = x)]])) { stop("Under current subsetting parameters, the default assay will be removed. Please adjust subsetting parameters or change default assay.", call. = FALSE) } # Filter DimReduc objects for (dimreduc in FilterObjects(object = x, classes.keep = 'DimReduc')) { x[[dimreduc]] <- tryCatch( expr = subset.DimReduc(x = x[[dimreduc]], cells = cells, features = features), error = function(e) { return(NULL) } ) } # Remove metadata for cells not present slot(object = x, name = 'meta.data') <- slot(object = x, name = 'meta.data')[cells, , drop = FALSE] # Recalculate nCount and nFeature for (assay in FilterObjects(object = x, classes.keep = 'Assay')) { n.calc <- CalcN(object = x[[assay]]) if (!is.null(x = n.calc)) { names(x = n.calc) <- paste(names(x = n.calc), assay, sep = '_') x[[names(x = n.calc)]] <- n.calc } } slot(object = x, name = 'graphs') <- list() Idents(object = x, drop = TRUE) <- Idents(object = x)[cells] return(x) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # S4 methods #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' @rdname AddMetaData #' setMethod( f = '[[<-', signature = c('x' = 'Assay'), definition = function(x, i, ..., value) { meta.data <- x[[]] feature.names <- rownames(x = meta.data) if (is.data.frame(x = value)) { value <- lapply( X = 1:ncol(x = value), FUN = function(index) { v <- value[[index]] names(x = v) <- rownames(x = value) return(v) } ) } err.msg <- "Cannot add more or fewer meta.features information without values being named with feature names" if (length(x = i) > 1) { # Add multiple bits of feature-level metadata value <- rep_len(x = value, length.out = length(x = i)) for (index in 1:length(x = i)) { names.intersect <- intersect(x = names(x = value[[index]]), feature.names) if (length(x = names.intersect) > 0) { meta.data[names.intersect, i[index]] <- value[[index]][names.intersect] } else if (length(x = value) %in% c(nrow(x = meta.data), 1) %||% is.null(x = value)) { meta.data[i[index]] <- value[index] } else { stop(err.msg, call. = FALSE) } } } else { # Add a single column to feature-level metadata value <- unlist(x = value) if (length(x = intersect(x = names(x = value), y = feature.names)) > 0) { meta.data[, i] <- value[feature.names] } else if (length(x = value) %in% c(nrow(x = meta.data), 1) || is.null(x = value)) { meta.data[, i] <- value } else { stop(err.msg, call. = FALSE) } } slot(object = x, name = 'meta.features') <- meta.data return(x) } ) #' @rdname AddMetaData #' setMethod( # because R doesn't allow S3-style [[<- for S4 classes f = '[[<-', signature = c('x' = 'Seurat'), definition = function(x, i, ..., value) { # Require names, no index setting if (!is.character(x = i)) { stop("'i' must be a character", call. = FALSE) } # Allow removing of other object if (is.null(x = value)) { slot.use <- if (i %in% colnames(x = x[[]])) { 'meta.data' } else { FindObject(object = x, name = i) } if (is.null(x = slot.use)) { stop("Cannot find object ", i, call. = FALSE) } if (i == DefaultAssay(object = x)) { stop("Cannot delete the default assay", call. = FALSE) } } # remove disallowed characters from object name newi <- if (is.null(x = value)) { i } else { make.names(names = i) } if (any(i != newi)) { warning( "Invalid name supplied, making object name syntactically valid. New object name is ", newi, "; see ?make.names for more details on syntax validity", call. = FALSE, immediate. = TRUE ) i <- newi } # Figure out where to store data slot.use <- if (inherits(x = value, what = 'Assay')) { # Ensure we have the same number of cells if (ncol(x = value) != ncol(x = x)) { stop( "Cannot add a different number of cells than already present", call. = FALSE ) } # Ensure cell order stays the same if (all(Cells(x = value) %in% Cells(x = x)) && !all(Cells(x = value) == Cells(x = x))) { for (slot in c('counts', 'data', 'scale.data')) { assay.data <- GetAssayData(object = value, slot = slot) if (!IsMatrixEmpty(x = assay.data)) { assay.data <- assay.data[, Cells(x = x), drop = FALSE] } # Use slot because SetAssayData is being weird slot(object = value, name = slot) <- assay.data } } 'assays' } else if (inherits(x = value, what = 'Graph')) { # Ensure Assay that Graph is associated with is present in the Seurat object if (is.null(x = DefaultAssay(object = value))) { warning( "Adding a Graph without an assay associated with it", call. = FALSE, immediate. = TRUE ) } else if (!any(DefaultAssay(object = value) %in% Assays(object = x))) { stop("Cannot find assay '", DefaultAssay(object = value), "' in this Seurat object", call. = FALSE) } # Ensure Graph object is in order if (all(Cells(x = value) %in% Cells(x = x)) && !all(Cells(x = value) == Cells(x = x))) { value <- value[Cells(x = x), Cells(x = x)] } 'graphs' } else if (inherits(x = value, what = 'DimReduc')) { # All DimReducs must be associated with an Assay if (is.null(x = DefaultAssay(object = value))) { stop("Cannot add a DimReduc without an assay associated with it", call. = FALSE) } # Ensure Assay that DimReduc is associated with is present in the Seurat object if (!IsGlobal(object = value) && !any(DefaultAssay(object = value) %in% Assays(object = x))) { stop("Cannot find assay '", DefaultAssay(object = value), "' in this Seurat object", call. = FALSE) } # Ensure DimReduc object is in order if (all(Cells(x = value) %in% Cells(x = x)) && !all(Cells(x = value) == Cells(x = x))) { slot(object = value, name = 'cell.embeddings') <- value[[Cells(x = x), ]] } 'reductions' } else if (inherits(x = value, what = 'SeuratCommand')) { # Ensure Assay that SeuratCommand is associated with is present in the Seurat object if (is.null(x = DefaultAssay(object = value))) { warning( "Adding a command log without an assay associated with it", call. = FALSE, immediate. = TRUE ) } else if (!any(DefaultAssay(object = value) %in% Assays(object = x))) { stop("Cannot find assay '", DefaultAssay(object = value), "' in this Seurat object", call. = FALSE) } 'commands' } else if (is.null(x = value)) { slot.use } else { 'meta.data' } if (slot.use == 'meta.data') { # Add data to object metadata meta.data <- x[[]] cell.names <- rownames(x = meta.data) # If we have metadata with names, ensure they match our order if (is.data.frame(x = value) && !is.null(x = rownames(x = value))) { meta.order <- match(x = rownames(x = meta.data), table = rownames(x = value)) value <- value[meta.order, , drop = FALSE] } if (length(x = i) > 1) { # Add multiple pieces of metadata value <- rep_len(x = value, length.out = length(x = i)) for (index in 1:length(x = i)) { meta.data[i[index]] <- value[index] } } else { # Add a single column to metadata if (length(x = intersect(x = names(x = value), y = cell.names)) > 0) { meta.data[, i] <- value[cell.names] } else if (length(x = value) %in% c(nrow(x = meta.data), 1) || is.null(x = value)) { meta.data[, i] <- value } else { stop("Cannot add more or fewer cell meta.data information without values being named with cell names", call. = FALSE) } } # Check to ensure that we aren't adding duplicate names if (any(colnames(x = meta.data) %in% FilterObjects(object = x))) { bad.cols <- colnames(x = meta.data)[which(colnames(x = meta.data) %in% FilterObjects(object = x))] stop( paste0( "Cannot add a metadata column with the same name as an Assay or DimReduc - ", paste(bad.cols, collapse = ", ")), call. = FALSE ) } # Store the revised metadata slot(object = x, name = 'meta.data') <- meta.data } else { # Add other object to Seurat object # Ensure cells match in value and order if (!(class(x = value) %in% c('SeuratCommand', 'NULL')) && !all(Cells(x = value) == Cells(x = x))) { stop("All cells in the object being added must match the cells in this object", call. = FALSE) } # Ensure we're not duplicating object names if (!is.null(x = FindObject(object = x, name = i)) && !(class(x = value) %in% c(class(x = x[[i]]), 'NULL'))) { stop( "This object already contains ", i, " as a", ifelse( test = tolower(x = substring(text = class(x = x[[i]]), first = 1, last = 1)) %in% c('a', 'e', 'i', 'o', 'u'), yes = 'n ', no = ' ' ), class(x = x[[i]]), "; duplicate names are not allowed", call. = FALSE ) } # Check keyed objects if (inherits(x = value, what = c('Assay', 'DimReduc'))) { if (length(x = Key(object = value)) == 0) { Key(object = value) <- paste0(tolower(x = i), '_') } Key(object = value) <- UpdateKey(key = Key(object = value)) # Check for duplicate keys object.keys <- sapply( X = FilterObjects(object = x), FUN = function(i) { return(Key(object = x[[i]])) } ) if (Key(object = value) %in% object.keys && is.null(x = FindObject(object = x, name = i))) { # Attempt to create a duplicate key based off the name of the object being added new.keys <- c(paste0(tolower(x = i), c('_', paste0(RandomName(length = 2L), '_')))) # Select new key to use key.use <- min(which(x = !new.keys %in% object.keys)) new.key <- if (is.infinite(x = key.use)) { RandomName(length = 17L) } else { new.keys[key.use] } warning( "Cannot add objects with duplicate keys (offending key: ", Key(object = value), "), setting key to '", new.key, "'", call. = FALSE ) # Set new key Key(object = value) <- new.key } } # For Assays, run CalcN if (inherits(x = value, what = 'Assay')) { if ((!i %in% Assays(object = x)) | (i %in% Assays(object = x) && ! identical( x = GetAssayData(object = x, assay = i, slot = "counts"), y = GetAssayData(object = value, slot = "counts")) )) { n.calc <- CalcN(object = value) if (!is.null(x = n.calc)) { names(x = n.calc) <- paste(names(x = n.calc), i, sep = '_') x[[names(x = n.calc)]] <- n.calc } } } # When removing an Assay, clear out associated DimReducs, Graphs, and SeuratCommands if (is.null(x = value) && inherits(x = x[[i]], what = 'Assay')) { objs.assay <- FilterObjects( object = x, classes.keep = c('DimReduc', 'SeuratCommand', 'Graph') ) objs.assay <- Filter( f = function(o) { return(all(DefaultAssay(object = x[[o]]) == i) && !IsGlobal(object = x[[o]])) }, x = objs.assay ) for (o in objs.assay) { x[[o]] <- NULL } } # If adding a command, ensure it gets put at the end of the command list if (inherits(x = value, what = 'SeuratCommand')) { slot(object = x, name = slot.use)[[i]] <- NULL slot(object = x, name = slot.use) <- Filter( f = Negate(f = is.null), x = slot(object = x, name = slot.use) ) } slot(object = x, name = slot.use)[[i]] <- value slot(object = x, name = slot.use) <- Filter( f = Negate(f = is.null), x = slot(object = x, name = slot.use) ) } CheckGC() return(x) } ) setMethod( f = 'colMeans', signature = c('x' = 'Assay'), definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') { return(Matrix::colMeans( x = GetAssayData(object = x, slot = slot), na.rm = na.rm, dims = dims, ... )) } ) setMethod( f = 'colMeans', signature = c('x' = 'Seurat'), definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') { return(colMeans( x = GetAssayData(object = x, slot = slot), na.rm = na.rm, dims = dims, ... )) } ) setMethod( f = 'colSums', signature = c('x' = 'Assay'), definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') { return(Matrix::colSums( x = GetAssayData(object = x, slot = slot), na.rm = na.rm, dims = dims, ... )) } ) setMethod( f = 'colSums', signature = c('x' = 'Seurat'), definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') { return(Matrix::colSums( x = GetAssayData(object = x, slot = slot), na.rm = na.rm, dims = dims, ... )) } ) setMethod( f = 'rowMeans', signature = c('x' = 'Assay'), definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') { return(Matrix::rowMeans( x = GetAssayData(object = x, slot = slot), na.rm = na.rm, dims = dims, ... )) } ) setMethod( f = 'rowMeans', signature = c('x' = 'Seurat'), definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') { return(Matrix::rowMeans( x = GetAssayData(object = x, slot = slot), na.rm = na.rm, dims = dims, ... )) } ) setMethod( f = 'rowSums', signature = c('x' = 'Assay'), definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') { return(Matrix::rowSums( x = GetAssayData(object = x, slot = slot), na.rm = na.rm, dims = dims, ... )) } ) setMethod( f = 'rowSums', signature = c('x' = 'Seurat'), definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') { return(Matrix::rowSums( x = GetAssayData(object = x, slot = slot), na.rm = na.rm, dims = dims, ... )) } ) setMethod( f = 'show', signature = 'AnchorSet', definition = function(object) { cat('An AnchorSet object containing', nrow(x = slot(object = object, name = "anchors")), "anchors between", length(x = slot(object = object, name = "object.list")), "Seurat objects \n", "This can be used as input to IntegrateData or TransferData.") } ) setMethod( f = 'show', signature = 'Assay', definition = function(object) { cat('Assay data with', nrow(x = object), 'features for', ncol(x = object), 'cells\n') if (length(x = VariableFeatures(object = object)) > 0) { top.ten <- head(x = VariableFeatures(object = object), n = 10L) top <- 'Top' variable <- 'variable' } else { top.ten <- head(x = rownames(x = object), n = 10L) top <- 'First' variable <- '' } features <- paste0( variable, ' feature', if (length(x = top.ten) != 1) {'s'}, ":\n" ) features <- gsub(pattern = '^\\s+', replacement = '', x = features) cat( top, length(x = top.ten), features, paste(strwrap(x = paste(top.ten, collapse = ', ')), collapse = '\n'), '\n' ) } ) setMethod( f = 'show', signature = 'DimReduc', definition = function(object) { cat( "A dimensional reduction object with key", Key(object = object), '\n', 'Number of dimensions:', length(x = object), '\n', 'Projected dimensional reduction calculated: ', Projected(object = object), '\n', 'Jackstraw run:', as.logical(x = JS(object = object)), '\n', 'Computed using assay:', DefaultAssay(object = object), '\n' ) } ) setMethod( f = 'show', signature = 'JackStrawData', definition = function(object) { # empp <- GetJS(object = object, slot = "empirical.p.values") empp <- object$empirical.p.values # scored <- GetJS(object = object, slot = "overall.p.values") scored <- object$overall.p.values cat( "A JackStrawData object simulated on", nrow(x = empp), "features for", ncol(x = empp), "dimensions.\n", "Scored for:", nrow(x = scored), "dimensions.\n" ) } ) setMethod( f = "show", signature = "Seurat", definition = function(object) { assays <- FilterObjects(object = object, classes.keep = 'Assay') nfeatures <- sum(vapply( X = assays, FUN = function(x) { return(nrow(x = object[[x]])) }, FUN.VALUE = integer(length = 1L) )) num.assays <- length(x = assays) cat("An object of class", class(x = object), "\n") cat( nfeatures, 'features across', ncol(x = object), 'samples within', num.assays, ifelse(test = num.assays == 1, yes = 'assay', no = 'assays'), "\n" ) cat( "Active assay:", DefaultAssay(object = object), paste0('(', nrow(x = object), ' features)') ) other.assays <- assays[assays != DefaultAssay(object = object)] if (length(x = other.assays) > 0) { cat( '\n', length(x = other.assays), 'other', ifelse(test = length(x = other.assays) == 1, yes = 'assay', no = 'assays'), 'present:', strwrap(x = paste(other.assays, collapse = ', ')) ) } reductions <- FilterObjects(object = object, classes.keep = 'DimReduc') if (length(x = reductions) > 0) { cat( '\n', length(x = reductions), 'dimensional', ifelse(test = length(x = reductions) == 1, yes = 'reduction', no = 'reductions'), 'calculated:', strwrap(x = paste(reductions, collapse = ', ')) ) } cat('\n') } ) setMethod( f = 'show', signature = 'SeuratCommand', definition = function(object) { params <- slot(object = object, name = "params") params <- params[sapply(X = params, FUN = class) != "function"] cat( "Command: ", slot(object = object, name = "call.string"), '\n', "Time: ", as.character(slot(object = object, name = "time.stamp")), '\n', sep = "" ) for(p in 1:length(params)){ cat( names(params[p]), ":", params[[p]], "\n" ) } } ) setMethod( f = 'show', signature = 'seurat', definition = function(object) { cat( "An old seurat object\n", nrow(x = object@data), 'genes across', ncol(x = object@data), 'samples\n' ) } ) #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Internal #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Internal AddMetaData defintion # # @param object An object # @param metadata A vector, list, or data.frame with metadata to add # @param col.name A name for meta data if not a named list or data.frame # # @return object with metadata added # .AddMetaData <- function(object, metadata, col.name = NULL) { if (is.null(x = col.name) && is.atomic(x = metadata)) { stop("'col.name' must be provided for atomic metadata types (eg. vectors)") } if (inherits(x = metadata, what = c('matrix', 'Matrix'))) { metadata <- as.data.frame(x = metadata) } col.name <- col.name %||% names(x = metadata) %||% colnames(x = metadata) if (is.null(x = col.name)) { stop("No metadata name provided and could not infer it from metadata object") } object[[col.name]] <- metadata # if (class(x = metadata) == "data.frame") { # for (ii in 1:ncol(x = metadata)) { # object[[colnames(x = metadata)[ii]]] <- metadata[, ii, drop = FALSE] # } # } else { # object[[col.name]] <- metadata # } return(object) } # Find the names of collections in an object # # @return A vector with the names of slots that are a list # Collections <- function(object) { collections <- vapply( X = slotNames(x = object), FUN = function(x) { return(any(grepl(pattern = 'list', x = class(x = slot(object = object, name = x))))) }, FUN.VALUE = logical(length = 1L) ) collections <- Filter(f = isTRUE, x = collections) return(names(x = collections)) } # Calculate nCount and nFeature # # @param object An Assay object # # @return A named list with nCount and nFeature # #' @importFrom Matrix colSums # CalcN <- function(object) { if (IsMatrixEmpty(x = GetAssayData(object = object, slot = "counts"))) { return(NULL) } return(list( nCount = colSums(x = object, slot = 'counts'), nFeature = colSums(x = GetAssayData(object = object, slot = 'counts') > 0) )) } # Get the names of objects within a Seurat object that are of a certain class # # @param object A Seurat object # @param classes.keep A vector of names of classes to get # # @return A vector with the names of objects within the Seurat object that are of class \code{classes.keep} # FilterObjects <- function(object, classes.keep = c('Assay', 'DimReduc')) { slots <- na.omit(object = Filter( f = function(x) { sobj <- slot(object = object, name = x) return(is.list(x = sobj) && !is.data.frame(x = sobj) && !is.package_version(x = sobj)) }, x = slotNames(x = object) )) slots <- grep(pattern = 'tools', x = slots, value = TRUE, invert = TRUE) slots <- grep(pattern = 'misc', x = slots, value = TRUE, invert = TRUE) slots.objects <- unlist( x = lapply( X = slots, FUN = function(x) { return(names(x = slot(object = object, name = x))) } ), use.names = FALSE ) object.classes <- sapply( X = slots.objects, FUN = function(i) { return(inherits(x = object[[i]], what = classes.keep)) } ) object.classes <- which(x = object.classes, useNames = TRUE) return(names(x = object.classes)) } # Find the collection of an object within a Seurat object # # @param object A Seurat object # @param name Name of object to find # # @return The collection (slot) of the object # FindObject <- function(object, name) { collections <- c('assays', 'graphs', 'neighbors', 'reductions', 'commands') object.names <- lapply( X = collections, FUN = function(x) { return(names(x = slot(object = object, name = x))) } ) names(x = object.names) <- collections object.names <- Filter(f = Negate(f = is.null), x = object.names) for (i in names(x = object.names)) { if (name %in% names(x = slot(object = object, name = i))) { return(i) } } return(NULL) } # Check to see if projected loadings have been set # # @param object a DimReduc object # # @return TRUE if proejcted loadings have been set, else FALSE # Projected <- function(object) { projected.dims <- dim(x = slot(object = object, name = 'feature.loadings.projected')) if (all(projected.dims == 1)) { return(!all(is.na(x = slot(object = object, name = 'feature.loadings.projected')))) } return(!all(projected.dims == 0)) } # Get the top # # @param data Data to pull the top from # @param num Pull top \code{num} # @param balanced Pull even amounts of from positive and negative values # # @return The top \code{num} # @seealso \{code{\link{TopCells}}} \{code{\link{TopFeatures}}} # Top <- function(data, num, balanced) { top <- if (balanced) { num <- round(x = num / 2) data <- data[order(data, decreasing = TRUE), , drop = FALSE] positive <- head(x = rownames(x = data), n = num) negative <- rev(x = tail(x = rownames(x = data), n = num)) list(positive = positive, negative = negative) } else { data <- data[rev(x = order(abs(x = data))), , drop = FALSE] top <- head(x = rownames(x = data), n = num) top[order(data[top, ])] } return(top) } # Update Seurat assay # # @param old.assay Seurat2 assay # @param assay Name to store for assay in new object # UpdateAssay <- function(old.assay, assay){ cells <- colnames(x = old.assay@data) counts <- old.assay@raw.data data <- old.assay@data if (!inherits(x = counts, what = 'dgCMatrix')) { counts <- as(object = as.matrix(x = counts), Class = 'dgCMatrix') } if (!inherits(x = data, what = 'dgCMatrix')) { data <- as(object = as.matrix(x = data), Class = 'dgCMatrix') } new.assay <- new( Class = 'Assay', counts = counts[, cells], data = data, scale.data = old.assay@scale.data %||% new(Class = 'matrix'), meta.features = data.frame(row.names = rownames(x = counts)), var.features = old.assay@var.genes, key = paste0(assay, "_") ) return(new.assay) } # Update dimension reduction # # @param old.dr Seurat2 dimension reduction slot # @param assay.used Name of assay used to compute dimension reduction # UpdateDimReduction <- function(old.dr, assay) { new.dr <- list() for (i in names(x = old.dr)) { cell.embeddings <- old.dr[[i]]@cell.embeddings %||% new(Class = 'matrix') feature.loadings <- old.dr[[i]]@gene.loadings %||% new(Class = 'matrix') stdev <- old.dr[[i]]@sdev %||% numeric() misc <- old.dr[[i]]@misc %||% list() new.jackstraw <- UpdateJackstraw(old.jackstraw = old.dr[[i]]@jackstraw) old.key <- old.dr[[i]]@key if (length(x = old.key) == 0) { old.key <- gsub(pattern = "(.+?)(([0-9]+).*)", replacement = "\\1", x = colnames(cell.embeddings)[[1]]) if (length(x = old.key) == 0) { old.key <- i } } new.key <- suppressWarnings(expr = UpdateKey(key = old.key)) colnames(x = cell.embeddings) <- gsub( pattern = old.key, replacement = new.key, x = colnames(x = cell.embeddings) ) colnames(x = feature.loadings) <- gsub( pattern = old.key, replacement = new.key, x = colnames(x = feature.loadings) ) new.dr[[i]] <- new( Class = 'DimReduc', cell.embeddings = as(object = cell.embeddings, Class = 'matrix'), feature.loadings = as(object = feature.loadings, Class = 'matrix'), assay.used = assay, stdev = as(object = stdev, Class = 'numeric'), key = as(object = new.key, Class = 'character'), jackstraw = new.jackstraw, misc = as(object = misc, Class = 'list') ) } return(new.dr) } # Update jackstraw # # @param old.jackstraw # UpdateJackstraw <- function(old.jackstraw) { if (is.null(x = old.jackstraw)) { new.jackstraw <- new( Class = 'JackStrawData', empirical.p.values = new(Class = 'matrix'), fake.reduction.scores = new(Class = 'matrix'), empirical.p.values.full = new(Class = 'matrix'), overall.p.values = new(Class = 'matrix') ) } else { if (.hasSlot(object = old.jackstraw, name = 'overall.p.values')) { overall.p <- old.jackstraw@overall.p.values %||% new(Class = 'matrix') } else { overall.p <- new(Class = 'matrix') } new.jackstraw <- new( Class = 'JackStrawData', empirical.p.values = old.jackstraw@emperical.p.value %||% new(Class = 'matrix'), fake.reduction.scores = old.jackstraw@fake.pc.scores %||% new(Class = 'matrix'), empirical.p.values.full = old.jackstraw@emperical.p.value.full %||% new(Class = 'matrix'), overall.p.values = overall.p ) } return(new.jackstraw) } # Update a Key # # @param key A character to become a Seurat Key # # @return An updated Key that's valid for Seurat # UpdateKey <- function(key) { if (grepl(pattern = '^[[:alnum:]]+_$', x = key)) { return(key) } else { new.key <- regmatches( x = key, m = gregexpr(pattern = '[[:alnum:]]+', text = key) ) new.key <- paste0(paste(unlist(x = new.key), collapse = ''), '_') if (new.key == '_') { new.key <- paste0(RandomName(length = 3), '_') } warning( "Keys should be one or more alphanumeric characters followed by an underscore, setting key from ", key, " to ", new.key, call. = FALSE, immediate. = TRUE ) return(new.key) } } # Update slots in an object # # @param object An object to update # # @return \code{object} with the latest slot definitions # UpdateSlots <- function(object) { object.list <- sapply( X = slotNames(x = object), FUN = function(x) { return(tryCatch( expr = slot(object = object, name = x), error = function(...) { return(NULL) } )) }, simplify = FALSE, USE.NAMES = TRUE ) object.list <- Filter(f = Negate(f = is.null), x = object.list) object.list <- c('Class' = class(x = object)[1], object.list) object <- do.call(what = 'new', args = object.list) for (x in setdiff(x = slotNames(x = object), y = names(x = object.list))) { xobj <- slot(object = object, name = x) if (is.vector(x = xobj) && !is.list(x = xobj) && length(x = xobj) == 0) { slot(object = object, name = x) <- vector(mode = class(x = xobj), length = 1L) } } return(object) } # Pulls the proper data matrix for merging assay data. If the slot is empty, will return an empty # matrix with the proper dimensions from one of the remaining data slots. # # @param assay Assay to pull data from # @param slot Slot to pull from # # @return Returns the data matrix if present (i.e.) not 0x0. Otherwise, returns an # appropriately sized empty sparse matrix # ValidateDataForMerge <- function(assay, slot) { mat <- GetAssayData(object = assay, slot = slot) if (any(dim(x = mat) == c(0, 0))) { slots.to.check <- setdiff(x = c("counts", "data", "scale.data"), y = slot) for (ss in slots.to.check) { data.dims <- dim(x = GetAssayData(object = assay, slot = ss)) data.slot <- ss if (!any(data.dims == c(0, 0))) { break } } if (any(data.dims == c(0, 0))) { stop("The counts, data, and scale.data slots are all empty for the provided assay.") } mat <- Matrix( data = 0, nrow = data.dims[1], ncol = data.dims[2], dimnames = dimnames(x = GetAssayData(object = assay, slot = data.slot)) ) } return(mat) } Seurat/R/zzz.R0000644000176200001440000000243513527073365012715 0ustar liggesusers#' Tools for single-cell genomics #' #' @section Package options: #' #' Seurat uses the following [options()] to configure behaviour: #' #' \describe{ #' \item{\code{Seurat.memsafe}}{global option to call gc() after many operations. #' This can be helpful in cleaning up the memory status of the R session and #' prevent use of swap space. However, it does add to the computational overhead #' and setting to FALSE can speed things up if you're working in an environment #' where RAM availabiliy is not a concern.} #' \item{\code{Seurat.warn.umap.uwot}}{Show warning about the default backend #' for \code{\link{RunUMAP}} changing from Python UMAP via reticulate to UWOT} #' \item{\code{Seurat.checkdots}}{For functions that have ... as a parameter, #' this controls the behavior when an item isn't used. Can be one of warn, #' stop, or silent.} #' } #' #' @docType package #' @rdname Seurat-package #' @name Seurat-package #' NULL seurat_default_options <- list( Seurat.memsafe = FALSE, Seurat.warn.umap.uwot = TRUE, Seurat.checkdots = "warn" ) .onLoad <- function(libname, pkgname) { op <- options() toset <- !(names(x = seurat_default_options) %in% names(x = op)) if (any(toset)) options(seurat_default_options[toset]) invisible() } Seurat/R/utilities.R0000644000176200001440000017141013617623374014074 0ustar liggesusers#' @include generics.R #' NULL #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Functions #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' Calculate module scores for feature expression programs in single cells #' #' Calculate the average expression levels of each program (cluster) on single cell level, #' subtracted by the aggregated expression of control feature sets. #' All analyzed features are binned based on averaged expression, and the control features are #' randomly selected from each bin. #' #' @param object Seurat object #' @param features Feature expression programs in list #' @param pool List of features to check expression levels agains, defaults to \code{rownames(x = object)} #' @param nbin Number of bins of aggregate expression levels for all analyzed features #' @param ctrl Number of control features selected from the same bin per analyzed feature #' @param k Use feature clusters returned from DoKMeans #' @param assay Name of assay to use #' @param name Name for the expression programs #' @param seed Set a random seed. If NULL, seed is not set. #' @param search Search for symbol synonyms for features in \code{features} that #' don't match features in \code{object}? Searches the HGNC's gene names database; #' see \code{\link{UpdateSymbolList}} for more details #' @param ... Extra parameters passed to \code{\link{UpdateSymbolList}} #' #' @return Returns a Seurat object with module scores added to object meta data #' #' @importFrom ggplot2 cut_number #' @importFrom Matrix rowMeans colMeans #' #' @references Tirosh et al, Science (2016) #' #' @export #' #' @examples #' \dontrun{ #' cd_features <- list(c( #' 'CD79B', #' 'CD79A', #' 'CD19', #' 'CD180', #' 'CD200', #' 'CD3D', #' 'CD2', #' 'CD3E', #' 'CD7', #' 'CD8A', #' 'CD14', #' 'CD1C', #' 'CD68', #' 'CD9', #' 'CD247' #' )) #' pbmc_small <- AddModuleScore( #' object = pbmc_small, #' features = cd_features, #' ctrl = 5, #' name = 'CD_Features' #' ) #' head(x = pbmc_small[]) #' } #' AddModuleScore <- function( object, features, pool = NULL, nbin = 24, ctrl = 100, k = FALSE, assay = NULL, name = 'Cluster', seed = 1, search = FALSE, ... ) { if (!is.null(x = seed)) { set.seed(seed = seed) } assay.old <- DefaultAssay(object = object) assay <- assay %||% assay.old DefaultAssay(object = object) <- assay assay.data <- GetAssayData(object = object) features.old <- features if (k) { .NotYetUsed(arg = 'k') features <- list() for (i in as.numeric(x = names(x = table(object@kmeans.obj[[1]]$cluster)))) { features[[i]] <- names(x = which(x = object@kmeans.obj[[1]]$cluster == i)) } cluster.length <- length(x = features) } else { if (is.null(x = features)) { stop("Missing input feature list") } features <- lapply( X = features, FUN = function(x) { missing.features <- setdiff(x = x, y = rownames(x = object)) if (length(x = missing.features) > 0) { warning( "The following features are not present in the object: ", paste(missing.features, collapse = ", "), ifelse( test = search, yes = ", attempting to find updated synonyms", no = ", not searching for symbol synonyms" ), call. = FALSE, immediate. = TRUE ) if (search) { tryCatch( expr = { updated.features <- UpdateSymbolList(symbols = missing.features, ...) names(x = updated.features) <- missing.features for (miss in names(x = updated.features)) { index <- which(x == miss) x[index] <- updated.features[miss] } }, error = function(...) { warning( "Could not reach HGNC's gene names database", call. = FALSE, immediate. = TRUE ) } ) missing.features <- setdiff(x = x, y = rownames(x = object)) if (length(x = missing.features) > 0) { warning( "The following features are still not present in the object: ", paste(missing.features, collapse = ", "), call. = FALSE, immediate. = TRUE ) } } } return(intersect(x = x, y = rownames(x = object))) } ) cluster.length <- length(x = features) } if (!all(LengthCheck(values = features))) { warning(paste( 'Could not find enough features in the object from the following feature lists:', paste(names(x = which(x = !LengthCheck(values = features)))), 'Attempting to match case...' )) features <- lapply( X = features.old, FUN = CaseMatch, match = rownames(x = object) ) } if (!all(LengthCheck(values = features))) { stop(paste( 'The following feature lists do not have enough features present in the object:', paste(names(x = which(x = !LengthCheck(values = features)))), 'exiting...' )) } pool <- pool %||% rownames(x = object) data.avg <- Matrix::rowMeans(x = assay.data[pool, ]) data.avg <- data.avg[order(data.avg)] data.cut <- cut_number(x = data.avg + rnorm(n = length(data.avg))/1e30, n = nbin, labels = FALSE, right = FALSE) #data.cut <- as.numeric(x = Hmisc::cut2(x = data.avg, m = round(x = length(x = data.avg) / (nbin + 1)))) names(x = data.cut) <- names(x = data.avg) ctrl.use <- vector(mode = "list", length = cluster.length) for (i in 1:cluster.length) { features.use <- features[[i]] for (j in 1:length(x = features.use)) { ctrl.use[[i]] <- c( ctrl.use[[i]], names(x = sample( x = data.cut[which(x = data.cut == data.cut[features.use[j]])], size = ctrl, replace = FALSE )) ) } } ctrl.use <- lapply(X = ctrl.use, FUN = unique) ctrl.scores <- matrix( data = numeric(length = 1L), nrow = length(x = ctrl.use), ncol = ncol(x = object) ) for (i in 1:length(ctrl.use)) { features.use <- ctrl.use[[i]] ctrl.scores[i, ] <- Matrix::colMeans(x = assay.data[features.use, ]) } features.scores <- matrix( data = numeric(length = 1L), nrow = cluster.length, ncol = ncol(x = object) ) for (i in 1:cluster.length) { features.use <- features[[i]] data.use <- assay.data[features.use, , drop = FALSE] features.scores[i, ] <- Matrix::colMeans(x = data.use) } features.scores.use <- features.scores - ctrl.scores rownames(x = features.scores.use) <- paste0(name, 1:cluster.length) features.scores.use <- as.data.frame(x = t(x = features.scores.use)) rownames(x = features.scores.use) <- colnames(x = object) object[[colnames(x = features.scores.use)]] <- features.scores.use CheckGC() DefaultAssay(object = object) <- assay.old return(object) } #' Averaged feature expression by identity class #' #' Returns expression for an 'average' single cell in each identity class #' #' Output is in log-space when \code{return.seurat = TRUE}, otherwise it's in non-log space. #' Averaging is done in non-log space. #' #' @param object Seurat object #' @param assays Which assays to use. Default is all assays #' @param features Features to analyze. Default is all features in the assay #' @param return.seurat Whether to return the data as a Seurat object. Default is FALSE #' @param add.ident Place an additional label on each cell prior to averaging (very useful if you want to observe cluster averages, separated by replicate, for example) #' @param slot Slot to use; will be overriden by \code{use.scale} and \code{use.counts} #' @param use.scale Use scaled values for feature expression #' @param use.counts Use count values for feature expression #' @param verbose Print messages and show progress bar #' @param ... Arguments to be passed to methods such as \code{\link{CreateSeuratObject}} #' #' @return Returns a matrix with genes as rows, identity classes as columns. #' If return.seurat is TRUE, returns an object of class \code{\link{Seurat}}. #' #' @importFrom Matrix rowMeans #' @export #' #' @examples #' head(AverageExpression(object = pbmc_small)) #' AverageExpression <- function( object, assays = NULL, features = NULL, return.seurat = FALSE, add.ident = NULL, slot = 'data', use.scale = FALSE, use.counts = FALSE, verbose = TRUE, ... ) { CheckDots(..., fxns = 'CreateSeuratObject') if (use.scale) { .Deprecated(msg = "'use.scale' is a deprecated argument, please use the 'slot' argument instead") slot <- 'scale.data' } if (use.counts) { .Deprecated(msg = "'use.counts' is a deprecated argument, please use the 'slot' argument instead") if (use.scale) { warning("Both 'use.scale' and 'use.counts' were set; using counts", call. = FALSE, immediate. = TRUE) } slot <- 'counts' } fxn.average <- switch( EXPR = slot, 'data' = function(x) { rowMeans(x = expm1(x = x)) }, rowMeans ) object.assays <- FilterObjects(object = object, classes.keep = 'Assay') assays <- assays %||% object.assays ident.orig <- Idents(object = object) orig.levels <- levels(x = Idents(object = object)) ident.new <- c() if (!all(assays %in% object.assays)) { assays <- assays[assays %in% object.assays] if (length(assays) == 0) { stop("None of the requested assays are present in the object") } else { warning("Requested assays that do not exist in object. Proceeding with existing assays only.") } } if (!is.null(x = add.ident)) { new.data <- FetchData(object = object, vars = add.ident) new.ident <- paste( Idents(object)[rownames(x = new.data)], new.data[, 1], sep = '_' ) Idents(object, cells = rownames(new.data)) <- new.ident } data.return <- list() for (i in 1:length(x = assays)) { data.use <- GetAssayData( object = object, assay = assays[i], slot = slot ) features.assay <- features if (length(x = intersect(x = features, y = rownames(x = data.use))) < 1 ) { features.assay <- rownames(x = data.use) } data.all <- list(data.frame(row.names = features.assay)) for (j in levels(x = Idents(object))) { temp.cells <- WhichCells(object = object, idents = j) features.assay <- unique(x = intersect(x = features.assay, y = rownames(x = data.use))) if (length(x = temp.cells) == 1) { data.temp <- (data.use[features.assay, temp.cells]) # transform data if needed (alternative: apply fxn.average to single value above) # if (!(use.scale | use.counts)) { # equivalent: slot.use == "data" if (slot == 'data') { data.temp <- expm1(x = data.temp) } } if (length(x = temp.cells) > 1 ) { data.temp <- fxn.average(data.use[features.assay, temp.cells, drop = FALSE]) } data.all[[j]] <- data.temp if (verbose) { message(paste("Finished averaging", assays[i], "for cluster", j)) } if (i == 1) { ident.new <- c(ident.new, as.character(x = ident.orig[temp.cells[1]])) } } names(x = ident.new) <- levels(x = Idents(object)) data.return[[i]] <- do.call(cbind, data.all) names(x = data.return)[i] <- assays[[i]] } if (return.seurat) { toRet <- CreateSeuratObject( counts = data.return[[1]], project = "Average", assay = names(x = data.return)[1], ... ) #for multimodal data if (length(x = data.return) > 1) { for (i in 2:length(x = data.return)) { toRet[[names(x = data.return)[i]]] <- CreateAssayObject(counts = data.return[[i]]) } } if (DefaultAssay(object = object) %in% names(x = data.return)) { DefaultAssay(object = toRet) <- DefaultAssay(object = object) } Idents(toRet, cells = colnames(x = toRet)) <- ident.new[colnames(x = toRet)] Idents(object = toRet) <- factor( x = Idents(object = toRet), levels = as.character(x = orig.levels), ordered = TRUE ) # finish setting up object if it is to be returned toRet <- NormalizeData(object = toRet, verbose = verbose) toRet <- ScaleData(object = toRet, verbose = verbose) return(toRet) } else { return(data.return) } } #' Match the case of character vectors #' #' @param search A vector of search terms #' @param match A vector of characters whose case should be matched #' #' @return Values from search present in match with the case of match #' #' @export #' #' @examples #' cd_genes <- c('Cd79b', 'Cd19', 'Cd200') #' CaseMatch(search = cd_genes, match = rownames(x = pbmc_small)) #' CaseMatch <- function(search, match) { search.match <- sapply( X = search, FUN = function(s) { return(grep( pattern = paste0('^', s, '$'), x = match, ignore.case = TRUE, perl = TRUE, value = TRUE )) } ) return(unlist(x = search.match)) } #' Score cell cycle phases #' #' @param object A Seurat object #' @param s.features A vector of features associated with S phase #' @param g2m.features A vector of features associated with G2M phase #' @param set.ident If true, sets identity to phase assignments #' @param ... Arguments to be passed to \code{\link{AddModuleScore}} #' Stashes old identities in 'old.ident' #' #' @return A Seurat object with the following columns added to object meta data: S.Score, G2M.Score, and Phase #' #' @seealso \code{AddModuleScore} #' #' @export #' #' @examples #' \dontrun{ #' # pbmc_small doesn't have any cell-cycle genes #' # To run CellCycleScoring, please use a dataset with cell-cycle genes #' # An example is available at http://satijalab.org/seurat/cell_cycle_vignette.html #' pbmc_small <- CellCycleScoring( #' object = pbmc_small, #' g2m.features = cc.genes$g2m.genes, #' s.features = cc.genes$s.genes #' ) #' head(x = pbmc_small@meta.data) #' } #' CellCycleScoring <- function( object, s.features, g2m.features, set.ident = FALSE, ... ) { name <- 'Cell.Cycle' features <- list('S.Score' = s.features, 'G2M.Score' = g2m.features) object.cc <- AddModuleScore( object = object, features = features, name = name, ctrl = min(vapply(X = features, FUN = length, FUN.VALUE = numeric(length = 1))), ... ) cc.columns <- grep(pattern = name, x = colnames(x = object.cc[[]]), value = TRUE) cc.scores <- object.cc[[cc.columns]] rm(object.cc) CheckGC() assignments <- apply( X = cc.scores, MARGIN = 1, FUN = function(scores, first = 'S', second = 'G2M', null = 'G1') { if (all(scores < 0)) { return(null) } else { if (length(which(x = scores == max(scores))) > 1) { return('Undecided') } else { return(c(first, second)[which(x = scores == max(scores))]) } } } ) cc.scores <- merge(x = cc.scores, y = data.frame(assignments), by = 0) colnames(x = cc.scores) <- c('rownames', 'S.Score', 'G2M.Score', 'Phase') rownames(x = cc.scores) <- cc.scores$rownames cc.scores <- cc.scores[, c('S.Score', 'G2M.Score', 'Phase')] object[[colnames(x = cc.scores)]] <- cc.scores if (set.ident) { object[['old.ident']] <- Idents(object = object) Idents(object = object) <- 'Phase' } return(object) } #' Slim down a multi-species expression matrix, when only one species is primarily of interenst. #' #' Valuable for CITE-seq analyses, where we typically spike in rare populations of 'negative control' cells from a different species. #' #' @param object A UMI count matrix. Should contain rownames that start with #' the ensuing arguments prefix.1 or prefix.2 #' @param prefix The prefix denoting rownames for the species of interest. #' Default is "HUMAN_". These rownames will have this prefix removed in the returned matrix. #' @param controls The prefix denoting rownames for the species of 'negative #' control' cells. Default is "MOUSE_". #' @param ncontrols How many of the most highly expressed (average) negative #' control features (by default, 100 mouse genes), should be kept? All other #' rownames starting with prefix.2 are discarded. #' #' @return A UMI count matrix. Rownames that started with \code{prefix} have this #' prefix discarded. For rownames starting with \code{controls}, only the #' \code{ncontrols} most highly expressed features are kept, and the #' prefix is kept. All other rows are retained. #' #' @importFrom Matrix rowSums #' #' @export #' #' @examples #' \dontrun{ #' cbmc.rna.collapsed <- CollapseSpeciesExpressionMatrix(cbmc.rna) #' } #' CollapseSpeciesExpressionMatrix <- function( object, prefix = "HUMAN_", controls = "MOUSE_", ncontrols = 100 ) { features <- grep(pattern = prefix, x = rownames(x = object), value = TRUE) controls <- grep(pattern = controls, x = rownames(x = object), value = TRUE) others <- setdiff(x = rownames(x = object), y = c(features, controls)) controls <- rowSums(x = object[controls, ]) controls <- names(x = head( x = sort(x = controls, decreasing = TRUE), n = ncontrols )) object <- object[c(features, controls, others), ] rownames(x = object) <- gsub( pattern = prefix, replacement = '', x = rownames(x = object) ) return(object) } #' Run a custom distance function on an input data matrix #' #' @author Jean Fan #' #' @param my.mat A matrix to calculate distance on #' @param my.function A function to calculate distance #' @param ... Extra parameters to my.function #' #' @return A distance matrix #' #' @importFrom stats as.dist #' #' @export #' #' @examples #' # Define custom distance matrix #' manhattan.distance <- function(x, y) return(sum(abs(x-y))) #' #' input.data <- GetAssayData(pbmc_small, assay.type = "RNA", slot = "scale.data") #' cell.manhattan.dist <- CustomDistance(input.data, manhattan.distance) #' CustomDistance <- function(my.mat, my.function, ...) { CheckDots(..., fxns = my.function) n <- ncol(x = my.mat) mat <- matrix(data = 0, ncol = n, nrow = n) colnames(x = mat) <- rownames(x = mat) <- colnames(x = my.mat) for (i in 1:nrow(x = mat)) { for (j in 1:ncol(x = mat)) { mat[i,j] <- my.function(my.mat[, i], my.mat[, j], ...) } } return(as.dist(m = mat)) } #' Calculate the mean of logged values #' #' Calculate mean of logged values in non-log space (return answer in log-space) #' #' @param x A vector of values #' @param ... Other arguments (not used) #' #' @return Returns the mean in log-space #' #' @export #' #' @examples #' ExpMean(x = c(1, 2, 3)) #' ExpMean <- function(x, ...) { if (inherits(x = x, what = 'AnyMatrix')) { return(apply(X = x, FUN = function(i) {log(x = mean(x = exp(x = i) - 1) + 1)}, MARGIN = 1)) } else { return(log(x = mean(x = exp(x = x) - 1) + 1)) } } #' Export Seurat object for UCSC cell browser #' #' @param object Seurat object #' @param dir path to directory where to save exported files. These are: #' exprMatrix.tsv, tsne.coords.tsv, meta.tsv, markers.tsv and a default cellbrowser.conf #' @param dataset.name name of the dataset. Defaults to Seurat project name #' @param reductions vector of reduction names to export #' @param markers.file path to file with marker genes #' @param cluster.field name of the metadata field containing cell cluster #' @param cb.dir path to directory where to create UCSC cellbrowser static #' website content root, e.g. an index.html, .json files, etc. These files #' can be copied to any webserver. If this is specified, the cellbrowser #' package has to be accessible from R via reticulate. #' @param port on which port to run UCSC cellbrowser webserver after export #' @param skip.expr.matrix whether to skip exporting expression matrix #' @param skip.metadata whether to skip exporting metadata #' @param skip.reductions whether to skip exporting reductions #' @param ... specifies the metadata fields to export. To supply field with #' human readable name, pass name as \code{field="name"} parameter. #' #' @return This function exports Seurat object as a set of tsv files #' to \code{dir} directory, copying the \code{markers.file} if it is #' passed. It also creates the default \code{cellbrowser.conf} in the #' directory. This directory could be read by \code{cbBuild} to #' create a static website viewer for the dataset. If \code{cb.dir} #' parameter is passed, the function runs \code{cbBuild} (if it is #' installed) to create this static website in \code{cb.dir} directory. #' If \code{port} parameter is passed, it also runs the webserver for #' that directory and opens a browser. #' #' @author Maximilian Haeussler, Nikolay Markov #' #' @importFrom utils browseURL #' @importFrom reticulate py_module_available import #' @importFrom tools file_ext #' #' @export #' #' @examples #' \dontrun{ #' ExportToCellbrowser(object = pbmc_small, dataset.name = "PBMC", dir = "out") #' } #' ExportToCellbrowser <- function( object, dir, dataset.name = Project(object = object), reductions = "tsne", markers.file = NULL, cluster.field = "Cluster", cb.dir = NULL, port = NULL, skip.expr.matrix = FALSE, skip.metadata = FALSE, skip.reductions = FALSE, ... ) { vars <- c(...) if (is.null(x = vars)) { vars <- c("nCount_RNA", "nFeature_RNA") if (length(x = levels(x = Idents(object = object))) > 1) { vars <- c(vars, cluster.field) names(x = vars) <- c("", "", "ident") } } names(x = vars) <- names(x = vars) %||% vars names(x = vars) <- sapply( X = 1:length(x = vars), FUN = function(i) { return(ifelse( test = nchar(x = names(x = vars)[i]) > 0, yes = names(x = vars[i]), no = vars[i] )) } ) if (!is.null(x = port) && is.null(x = cb.dir)) { stop("cb.dir parameter is needed when port is set") } if (!dir.exists(paths = dir)) { dir.create(path = dir) } if (!dir.exists(paths = dir)) { stop("Output directory ", dir, " cannot be created or is a file") } if (dataset.name == "SeuratProject") { warning("Using default project name means that you may overwrite project with the same name in the cellbrowser html output folder") } order <- colnames(x = object) enum.fields <- c() # Export expression matrix: if (!skip.expr.matrix) { # Relatively memory inefficient - maybe better to convert to sparse-row and write in a loop, row-by-row? df <- as.data.frame(x = as.matrix(x = GetAssayData(object = object))) df <- data.frame(gene = rownames(x = object), df, check.names = FALSE) gzPath <- file.path(dir, "exprMatrix.tsv.gz") z <- gzfile(gzPath, "w") message("Writing expression matrix to ", gzPath) write.table(x = df, sep = "\t", file = z, quote = FALSE, row.names = FALSE) close(con = z) } # Export cell embeddings embeddings.conf <- c() for (reduction in reductions) { if (!skip.reductions) { df <- Embeddings(object = object, reduction = reduction) if (ncol(x = df) > 2) { warning( 'Embedding ', reduction, ' has more than 2 coordinates, taking only the first 2' ) df <- df[, 1:2] } colnames(x = df) <- c("x", "y") df <- data.frame(cellId = rownames(x = df), df) fname <- file.path(dir, paste0(reduction, '.coords.tsv')) message("Writing embeddings to ", fname) write.table( x = df[order, ], sep = "\t", file = fname, quote = FALSE, row.names = FALSE ) } conf <- sprintf( '{"file": "%s.coords.tsv", "shortLabel": "Seurat %1$s"}', reduction ) embeddings.conf <- c(embeddings.conf, conf) } # Export metadata df <- data.frame(row.names = rownames(x = object[[]])) df <- FetchData(object = object, vars = names(x = vars)) colnames(x = df) <- vars enum.fields <- Filter( f = function(name) {!is.numeric(x = df[[name]])}, x = vars ) if (!skip.metadata) { fname <- file.path(dir, "meta.tsv") message("Writing meta data to ", fname) df <- data.frame(Cell = rownames(x = df), df, check.names = FALSE) write.table( x = df[order, ], sep = "\t", file = fname, quote = FALSE, row.names = FALSE ) } # Export markers markers.string <- '' if (!is.null(x = markers.file)) { ext <- file_ext(x = markers.file) fname <- paste0("markers.", ext) file.copy(from = markers.file, to = file.path(dir, fname)) markers.string <- sprintf( 'markers = [{"file": "%s", "shortLabel": "Seurat Cluster Markers"}]', fname ) } config <- c( 'name="%s"', 'shortLabel="%1$s"', 'exprMatrix="exprMatrix.tsv.gz"', '#tags = ["10x", "smartseq2"]', 'meta="meta.tsv"', '# possible values: "gencode-human", "gencode-mouse", "symbol" or "auto"', 'geneIdType="auto"', 'clusterField="%s"', 'labelField="%2$s"', 'enumFields=%s', '%s', 'coords=%s' ) config <- paste(config, collapse = '\n') enum.string <- paste0( "[", paste(paste0('"', enum.fields, '"'), collapse = ", "), "]" ) coords.string <- paste0( "[", paste(embeddings.conf, collapse = ",\n"), "]" ) config <- sprintf( config, dataset.name, cluster.field, enum.string, markers.string, coords.string ) fname <- file.path(dir, "cellbrowser.conf") if (file.exists(fname)) { message( "`cellbrowser.conf` already exists in target directory, refusing to ", "overwrite it" ) } else { cat(config, file = fname) } message("Prepared cellbrowser directory ", dir) if (!is.null(x = cb.dir)) { if (!py_module_available(module = "cellbrowser")) { stop( "The Python package `cellbrowser` is required to prepare and run ", "Cellbrowser. Please install it ", "on the Unix command line with `sudo pip install cellbrowser` (if root) ", "or `pip install cellbrowser --user` (as a non-root user). ", "To adapt the Python that is used, you can either set the env. variable RETICULATE_PYTHON ", "or do `require(reticulate) and use one of these functions: use_python(), use_virtualenv(), use_condaenv(). ", "See https://rstudio.github.io/reticulate/articles/versions.html; ", "at the moment, R's reticulate is using this Python: ", import(module = 'sys')$executable, ". " ) } if (!is.null(x = port)) { port <- as.integer(x = port) } message("Converting cellbrowser directory to html/json files") cb <- import(module = "cellbrowser") cb$cellbrowser$build(dir, cb.dir) if (!is.null(port)) { message("Starting http server") cb$cellbrowser$stop() cb$cellbrowser$serve(cb.dir, port) Sys.sleep(time = 0.4) browseURL(url = paste0("http://localhost:", port)) } } } #' Calculate the standard deviation of logged values #' #' Calculate SD of logged values in non-log space (return answer in log-space) #' #' @param x A vector of values #' #' @return Returns the standard deviation in log-space #' #' @importFrom stats sd #' #' @export #' #' @examples #' ExpSD(x = c(1, 2, 3)) #' ExpSD <- function(x) { return(log1p(x = sd(x = expm1(x = x)))) } #' Calculate the variance of logged values #' #' Calculate variance of logged values in non-log space (return answer in #' log-space) #' #' @param x A vector of values #' #' @return Returns the variance in log-space #' #' @importFrom stats var #' #' @export #' #' @examples #' ExpVar(x = c(1, 2, 3)) #' ExpVar <- function(x) { return(log1p(x = var(x = expm1(x = x)))) } #' Get updated synonyms for gene symbols #' #' Find current gene symbols based on old or alias symbols using the gene #' names database from the HUGO Gene Nomenclature Committee (HGNC) #' #' @details For each symbol passed, we query the HGNC gene names database for #' current symbols that have the provided symbol as either an alias #' (\code{alias_symbol}) or old (\code{prev_symbol}) symbol. All other queries #' are \strong{not} supported. #' #' @note This function requires internet access #' #' @param symbols A vector of gene symbols #' @param timeout Time to wait before cancelling query in seconds #' @param several.ok Allow several current gene sybmols for each provided symbol #' @param verbose Show a progress bar depicting search progress #' @param ... Extra parameters passed to \code{\link[httr]{GET}} #' #' @return For \code{GeneSymbolThesarus}, if \code{several.ok}, a named list #' where each entry is the current symbol found for each symbol provided and the #' names are the provided symbols. Otherwise, a named vector with the same information. #' #' @source \url{https://www.genenames.org/} \url{http://rest.genenames.org/} #' #' @importFrom utils txtProgressBar setTxtProgressBar #' @importFrom httr GET accept_json timeout status_code content #' #' @rdname UpdateSymbolList #' @name UpdateSymbolList #' #' @export #' #' @seealso \code{\link[httr]{GET}} #' #' @examples #' \dontrun{ #' GeneSybmolThesarus(symbols = c("FAM64A")) #' } #' GeneSymbolThesarus <- function( symbols, timeout = 10, several.ok = FALSE, verbose = TRUE, ... ) { db.url <- 'http://rest.genenames.org/fetch' search.types <- c('alias_symbol', 'prev_symbol') synonyms <- vector(mode = 'list', length = length(x = symbols)) not.found <- vector(mode = 'logical', length = length(x = symbols)) multiple.found <- vector(mode = 'logical', length = length(x = symbols)) names(x = multiple.found) <- names(x = not.found) <- names(x = synonyms) <- symbols if (verbose) { pb <- txtProgressBar(max = length(x = symbols), style = 3, file = stderr()) } for (symbol in symbols) { sym.syn <- character() for (type in search.types) { response <- GET( url = paste(db.url, type, symbol, sep = '/'), config = c(accept_json(), timeout(seconds = timeout)), ... ) if (!identical(x = status_code(x = response), y = 200L)) { next } response <- content(x = response) if (response$response$numFound != 1) { if (response$response$numFound > 1) { warning( "Multiple hits found for ", symbol, " as ", type, ", skipping", call. = FALSE, immediate. = TRUE ) } next } sym.syn <- c(sym.syn, response$response$docs[[1]]$symbol) } not.found[symbol] <- length(x = sym.syn) < 1 multiple.found[symbol] <- length(x = sym.syn) > 1 if (length(x = sym.syn) == 1 || (length(x = sym.syn) > 1 && several.ok)) { synonyms[[symbol]] <- sym.syn } if (verbose) { setTxtProgressBar(pb = pb, value = pb$getVal() + 1) } } if (verbose) { close(con = pb) } if (sum(not.found) > 0) { warning( "The following symbols had no synonyms: ", paste(names(x = which(x = not.found)), collapse = ', '), call. = FALSE, immediate. = TRUE ) } if (sum(multiple.found) > 0) { msg <- paste( "The following symbols had multiple synonyms:", paste(names(x = which(x = multiple.found)), sep = ', ') ) if (several.ok) { message(msg) message("Including anyways") } else { warning(msg, call. = FALSE, immediate. = TRUE) } } synonyms <- Filter(f = Negate(f = is.null), x = synonyms) if (!several.ok) { synonyms <- unlist(x = synonyms) } return(synonyms) } #' Calculate the variance to mean ratio of logged values #' #' Calculate the variance to mean ratio (VMR) in non-logspace (return answer in #' log-space) #' #' @param x A vector of values #' @param ... Other arguments (not used) #' #' @return Returns the VMR in log-space #' #' @importFrom stats var #' #' @export #' #' @examples #' LogVMR(x = c(1, 2, 3)) #' LogVMR <- function(x, ...) { if (inherits(x = x, what = 'AnyMatrix')) { return(apply(X = x, FUN = function(i) {log(x = var(x = exp(x = i) - 1) / mean(x = exp(x = i) - 1))}, MARGIN = 1)) } else { return(log(x = var(x = exp(x = x) - 1) / mean(x = exp(x = x) - 1))) } } #' Aggregate expression of multiple features into a single feature #' #' Calculates relative contribution of each feature to each cell #' for given set of features. #' #' @param object A Seurat object #' @param features List of features to aggregate #' @param meta.name Name of column in metadata to store metafeature #' @param cells List of cells to use (default all cells) #' @param assay Which assay to use #' @param slot Which slot to take data from (default data) #' #' @return Returns a \code{Seurat} object with metafeature stored in objct metadata #' #' @importFrom Matrix rowSums colMeans #' #' @export #' #' @examples #' pbmc_small <- MetaFeature( #' object = pbmc_small, #' features = c("LTB", "EAF2"), #' meta.name = 'var.aggregate' #' ) #' head(pbmc_small[[]]) #' MetaFeature <- function( object, features, meta.name = 'metafeature', cells = NULL, assay = NULL, slot = 'data' ) { cells <- cells %||% colnames(x = object) assay <- assay %||% DefaultAssay(object = object) newmat <- GetAssayData(object = object, assay = assay, slot = slot) newmat <- newmat[features, cells] if (slot == 'scale.data') { newdata <- Matrix::colMeans(newmat) } else { rowtotals <- Matrix::rowSums(newmat) newmat <- newmat / rowtotals newdata <- Matrix::colMeans(newmat) } object[[meta.name]] <- newdata return(object) } #' Apply a ceiling and floor to all values in a matrix #' #' @param data Matrix or data frame #' @param min all values below this min value will be replaced with min #' @param max all values above this max value will be replaced with max #' @return Returns matrix after performing these floor and ceil operations #' @export #' #' @examples #' mat <- matrix(data = rbinom(n = 25, size = 20, prob = 0.2 ), nrow = 5) #' mat #' MinMax(data = mat, min = 4, max = 5) #' MinMax <- function(data, min, max) { data2 <- data data2[data2 > max] <- max data2[data2 < min] <- min return(data2) } #' Calculate the percentage of all counts that belong to a given set of features #' #' This function enables you to easily calculate the percentage of all the counts belonging to a #' subset of the possible features for each cell. This is useful when trying to compute the percentage #' of transcripts that map to mitochondrial genes for example. The calculation here is simply the #' column sum of the matrix present in the counts slot for features belonging to the set divided by #' the column sum for all features times 100. #' #' @param object A Seurat object #' @param pattern A regex pattern to match features against #' @param features A defined feature set. If features provided, will ignore the pattern matching #' @param col.name Name in meta.data column to assign. If this is not null, returns a Seurat object #' with the proportion of the feature set stored in metadata. #' @param assay Assay to use #' #' @return Returns a vector with the proportion of the feature set or if md.name is set, returns a #' Seurat object with the proportion of the feature set stored in metadata. #' @importFrom Matrix colSums #' @export #' #' @examples #' # Calculate the proportion of transcripts mapping to mitochondrial genes #' # NOTE: The pattern provided works for human gene names. You may need to adjust depending on your #' # system of interest #' pbmc_small[["percent.mt"]] <- PercentageFeatureSet(object = pbmc_small, pattern = "^MT-") #' PercentageFeatureSet <- function( object, pattern = NULL, features = NULL, col.name = NULL, assay = NULL ) { assay <- assay %||% DefaultAssay(object = object) if (!is.null(x = features) && !is.null(x = pattern)) { warning("Both pattern and features provided. Pattern is being ignored.") } features <- features %||% grep(pattern = pattern, x = rownames(x = object[[assay]]), value = TRUE) percent.featureset <- colSums(x = GetAssayData(object = object, assay = assay, slot = "counts")[features, , drop = FALSE])/ object[[paste0("nCount_", assay)]] * 100 if (!is.null(x = col.name)) { object <- AddMetaData(object = object, metadata = percent.featureset, col.name = col.name) return(object) } return(percent.featureset) } #' Regroup idents based on meta.data info #' #' For cells in each ident, set a new identity based on the most common value #' of a specified metadata column. #' #' @param object Seurat object #' @param metadata Name of metadata column #' @return A Seurat object with the active idents regrouped #' #' @export #' #' @examples #' pbmc_small <- RegroupIdents(pbmc_small, metadata = "groups") #' RegroupIdents <- function(object, metadata) { for (ii in levels(x = object)) { ident.cells <- WhichCells(object = object, idents = ii) if (length(x = ident.cells) == 0) { next } new.ident <- names(x = which.max(x = table(object[[metadata]][ident.cells, ]))) if (is.null(x = new.ident)) { stop("Cluster ", ii, " contains only cells with NA values in the '", metadata, "' metadata column.") } Idents(object = object, cells = ident.cells) <- new.ident } return(object) } #' Merge two matrices by rowname #' #' This function is for use on sparse matrices and #' should not be run on a Seurat object. #' #' Shared matrix rows (with the same row name) will be merged, #' and unshared rows (with different names) will be filled #' with zeros in the matrix not containing the row. #' #' @param mat1 First matrix #' @param mat2 Second matrix #' #' @return A merged matrix #' #' @return Returns a sparse matrix #' #' @importFrom methods as # #' @export #' RowMergeSparseMatrices <- function(mat1, mat2){ if (inherits(x = mat1, what = "data.frame")) { mat1 <- as.matrix(x = mat1) } if (inherits(x = mat2, what = "data.frame")) { mat2 <- as.matrix(x = mat2) } mat1.names <- rownames(x = mat1) mat2.names <- rownames(x = mat2) if (length(x = mat1.names) == length(x = mat2.names) && all(mat1.names == mat2.names)) { new.mat <- cbind(mat1, mat2) } else { mat1 <- as(object = mat1, Class = "RsparseMatrix") mat2 <- as(object = mat2, Class = "RsparseMatrix") all.names <- union(x = mat1.names, y = mat2.names) new.mat <- RowMergeMatrices( mat1 = mat1, mat2 = mat2, mat1_rownames = mat1.names, mat2_rownames = mat2.names, all_rownames = all.names ) rownames(x = new.mat) <- make.unique(names = all.names) } colnames(x = new.mat) <- make.unique(names = c( colnames(x = mat1), colnames(x = mat2) )) return(new.mat) } #' Stop Cellbrowser web server #' #' @importFrom reticulate py_module_available #' @importFrom reticulate import #' #' @export #' #' @examples #' \dontrun{ #' StopCellbrowser() #' } #' StopCellbrowser <- function() { if (py_module_available(module = "cellbrowser")) { cb <- import(module = "cellbrowser") cb$cellbrowser$stop() } else { stop("The `cellbrowser` package is not available in the Python used by R's reticulate") } } #' @rdname UpdateSymbolList #' #' @return For \code{UpdateSymbolList}, \code{symbols} with updated symbols from #' HGNC's gene names database #' #' @export #' #' @examples #' \dontrun{ #' UpdateSymbolList(symbols = cc.genes$s.genes) #' } #' UpdateSymbolList <- function( symbols, timeout = 10, several.ok = FALSE, verbose = TRUE, ... ) { new.symbols <- suppressWarnings(expr = GeneSymbolThesarus( symbols = symbols, timeout = timeout, several.ok = several.ok, verbose = verbose, ... )) if (length(x = new.symbols) < 1) { warning("No updated symbols found", call. = FALSE, immediate. = TRUE) } else { if (verbose) { message("Found updated symbols for ", length(x = new.symbols), " symbols") x <- sapply(X = new.symbols, FUN = paste, collapse = ', ') message(paste(names(x = x), x, sep = ' -> ', collapse = '\n')) } for (sym in names(x = new.symbols)) { index <- which(x = symbols == sym) symbols <- append( x = symbols[-index], values = new.symbols[[sym]], after = index - 1 ) } } return(symbols) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Methods for Seurat-defined generics #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Methods for R-defined generics #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' @inheritParams base::as.data.frame #' #' @return \code{as.data.frame.Matrix}: A data frame representation of the S4 Matrix #' #' @importFrom Matrix as.matrix #' #' @rdname as.sparse #' @export #' @method as.data.frame Matrix #' as.data.frame.Matrix <- function( x, row.names = NULL, optional = FALSE, ..., stringsAsFactors = default.stringsAsFactors() ) { return(as.data.frame( x = as.matrix(x = x), row.names = row.names, optional = optional, stringsAsFactors = stringsAsFactors, ... )) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Internal #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Set a default value if an object is null # # @param lhs An object to set if it's null # @param rhs The value to provide if x is null # # @return rhs if lhs is null, else lhs # # @author Hadley Wickham # @references https://adv-r.hadley.nz/functions.html#missing-arguments # `%||%` <- function(lhs, rhs) { if (!is.null(x = lhs)) { return(lhs) } else { return(rhs) } } # Set a default value if an object is NOT null # # @param lhs An object to set if it's NOT null # @param rhs The value to provide if x is NOT null # # @return lhs if lhs is null, else rhs # # @author Hadley Wickham # @references https://adv-r.hadley.nz/functions.html#missing-arguments # `%iff%` <- function(lhs, rhs) { if (!is.null(x = lhs)) { return(rhs) } else { return(lhs) } } # Generate chunk points # # @param dsize How big is the data being chunked # @param csize How big should each chunk be # # @return A matrix where each column is a chunk, row 1 is start points, row 2 is end points # ChunkPoints <- function(dsize, csize) { return(vapply( X = 1L:ceiling(x = dsize / csize), FUN = function(i) { return(c( start = (csize * (i - 1L)) + 1L, end = min(csize * i, dsize) )) }, FUN.VALUE = numeric(length = 2L) )) } # L2 normalize the columns (or rows) of a given matrix # @param mat Matrix to cosine normalize # @param MARGIN Perform normalization over rows (1) or columns (2) # # # @return returns l2-normalized matrix # # L2Norm <- function(mat, MARGIN = 1){ normalized <- Sweep( x = mat, MARGIN = MARGIN, STATS = apply( X = mat, MARGIN = MARGIN, FUN = function(x){ sqrt(x = sum(x ^ 2)) } ), FUN = "/" ) normalized[!is.finite(x = normalized)] <- 0 return(normalized) } # Check the use of ... # # @param ... Arguments passed to a function that fall under ... # @param fxns A list/vector of functions or function names # # @return ... # # @importFrom utils argsAnywhere getAnywhere #' @importFrom utils isS3stdGeneric methods argsAnywhere isS3method # # @examples # CheckDots <- function(..., fxns = NULL) { args.names <- names(x = list(...)) if (length(x = list(...)) == 0) { return(invisible(x = NULL)) } if (is.null(x = args.names)) { stop("No named arguments passed") } if (length(x = fxns) == 1) { fxns <- list(fxns) } for (f in fxns) { if (!(is.character(x = f) || is.function(x = f))) { stop("CheckDots only works on characters or functions, not ", class(x = f)) } } fxn.args <- suppressWarnings(expr = sapply( X = fxns, FUN = function(x) { x <- tryCatch( expr = if (isS3stdGeneric(f = x)) { as.character(x = methods(generic.function = x)) } else { x }, error = function(...) { return(x) } ) x <- if (is.character(x = x)) { sapply(X = x, FUN = argsAnywhere, simplify = FALSE, USE.NAMES = TRUE) } else if (length(x = x) <= 1) { list(x) } return(sapply( X = x, FUN = function(f) { return(names(x = formals(fun = f))) }, simplify = FALSE, USE.NAMES = TRUE )) }, simplify = FALSE, USE.NAMES = TRUE )) fxn.args <- unlist(x = fxn.args, recursive = FALSE) fxn.null <- vapply(X = fxn.args, FUN = is.null, FUN.VALUE = logical(length = 1L)) if (all(fxn.null) && !is.null(x = fxns)) { stop("None of the functions passed could be found") } else if (any(fxn.null)) { warning( "The following functions passed could not be found: ", paste(names(x = which(x = fxn.null)), collapse = ', '), call. = FALSE, immediate. = TRUE ) fxn.args <- Filter(f = Negate(f = is.null), x = fxn.args) } dfxns <- vector(mode = 'logical', length = length(x = fxn.args)) names(x = dfxns) <- names(x = fxn.args) for (i in 1:length(x = fxn.args)) { dfxns[i] <- any(grepl(pattern = '...', x = fxn.args[[i]], fixed = TRUE)) } if (any(dfxns)) { dfxns <- names(x = which(x = dfxns)) if (any(nchar(x = dfxns) > 0)) { fx <- vapply( X = Filter(f = nchar, x = dfxns), FUN = function(x) { if (isS3method(method = x)) { x <- unlist(x = strsplit(x = x, split = '\\.')) x <- x[length(x = x) - 1L] } return(x) }, FUN.VALUE = character(length = 1L) ) message( "The following functions and any applicable methods accept the dots: ", paste(unique(x = fx), collapse = ', ') ) if (any(nchar(x = dfxns) < 1)) { message( "In addition, there is/are ", length(x = Filter(f = Negate(f = nchar), x = dfxns)), " other function(s) that accept(s) the dots" ) } } else { message("There is/are ", length(x = dfxns), 'function(s) that accept(s) the dots') } } else { unused <- Filter( f = function(x) { return(!x %in% unlist(x = fxn.args)) }, x = args.names ) if (length(x = unused) > 0) { msg <- paste0( "The following arguments are not used: ", paste(unused, collapse = ', ') ) switch( EXPR = getOption(x = "Seurat.checkdots"), "warn" = warning(msg, call. = FALSE, immediate. = TRUE), "stop" = stop(msg), "silent" = NULL, stop("Invalid Seurat.checkdots option. Please choose one of warn, stop, silent") ) unused.hints <- sapply(X = unused, FUN = OldParamHints) names(x = unused.hints) <- unused unused.hints <- na.omit(object = unused.hints) if (length(x = unused.hints) > 0) { message( "Suggested parameter: ", paste(unused.hints, "instead of", names(x = unused.hints), collapse = '; '), "\n" ) } } } } # Check a list of objects for duplicate cell names # # @param object.list List of Seurat objects # @param verbose Print message about renaming # @param stop Error out if any duplicate names exist # # @return Returns list of objects with duplicate cells renamed to be unique # CheckDuplicateCellNames <- function(object.list, verbose = TRUE, stop = FALSE) { cell.names <- unlist(x = lapply(X = object.list, FUN = colnames)) if (any(duplicated(x = cell.names))) { if (stop) { stop("Duplicate cell names present across objects provided.") } if (verbose) { warning("Some cell names are duplicated across objects provided. Renaming to enforce unique cell names.") } object.list <- lapply( X = 1:length(x = object.list), FUN = function(x) { return(RenameCells( object = object.list[[x]], new.names = paste0(Cells(x = object.list[[x]]), "_", x) )) } ) } return(object.list) } # Call gc() to perform garbage collection # CheckGC <- function() { if (getOption(x = "Seurat.memsafe")) { gc(verbose = FALSE) } } # Extract delimiter information from a string. # # Parses a string (usually a cell name) and extracts fields based on a delimiter # # @param string String to parse. # @param field Integer(s) indicating which field(s) to extract. Can be a vector multiple numbers. # @param delim Delimiter to use, set to underscore by default. # # @return A new string, that parses out the requested fields, and (if multiple), rejoins them with the same delimiter # # @export # # @examples # ExtractField(string = 'Hello World', field = 1, delim = '_') # ExtractField <- function(string, field = 1, delim = "_") { fields <- as.numeric(x = unlist(x = strsplit(x = as.character(x = field), split = ","))) if (length(x = fields) == 1) { return(strsplit(x = string, split = delim)[[1]][field]) } return(paste(strsplit(x = string, split = delim)[[1]][fields], collapse = delim)) } # Resize GenomicRanges upstream and or downstream # from https://support.bioconductor.org/p/78652/ # Extend <- function(x, upstream = 0, downstream = 0) { if (any(GenomicRanges::strand(x = x) == "*")) { warning("'*' ranges were treated as '+'") } on_plus <- GenomicRanges::strand(x = x) == "+" | GenomicRanges::strand(x = x) == "*" new_start <- GenomicRanges::start(x = x) - ifelse(test = on_plus, yes = upstream, no = downstream) new_end <- GenomicRanges::end(x = x) + ifelse(test = on_plus, yes = downstream, no = upstream) IRanges::ranges(x = x) <- IRanges::IRanges(start = new_start, end = new_end) x <- GenomicRanges::trim(x = x) return(x) } # Interleave vectors together # # @param ... Vectors to be interleaved # # @return A vector with the values from each vector in ... interleaved # Interleave <- function(...) { return(as.vector(x = t(x = as.data.frame(x = list(...))))) } # Check if a matrix is empty # # Takes a matrix and asks if it's empty (either 0x0 or 1x1 with a value of NA) # # @param x A matrix # # @return Whether or not \code{x} is empty # IsMatrixEmpty <- function(x) { matrix.dims <- dim(x = x) matrix.na <- all(matrix.dims == 1) && all(is.na(x = x)) return(all(matrix.dims == 0) || matrix.na) } # Check whether an assay has been processed by sctransform # # @param assay assay to check # # @return Boolean # IsSCT <- function(assay) { if (is.list(x = assay)) { sct.check <- lapply(X = assay, FUN = function(x) { return(!is.null(x = Misc(object = x, slot = 'vst.out')) | !is.null(x = Misc(object = x, slot = 'vst.set'))) }) return(unlist(x = sct.check)) } return(!is.null(x = Misc(object = assay, slot = 'vst.out')) | !is.null(x = Misc(object = assay, slot = 'vst.set'))) } # Check the length of components of a list # # @param values A list whose components should be checked # @param cutoff A minimum value to check for # # @return a vector of logicals # LengthCheck <- function(values, cutoff = 0) { return(vapply( X = values, FUN = function(x) { return(length(x = x) > cutoff) }, FUN.VALUE = logical(1) )) } # Function to map values in a vector `v` as defined in `from`` to the values # defined in `to`. # # @param v vector of values to map # @param from vector of original values # @param to vector of values to map original values to (should be of equal # length as from) # @return returns vector of mapped values # MapVals <- function(v, from, to) { if (length(x = from) != length(x = to)) { stop("from and to vectors are not the equal length.") } vals.to.match <- match(x = v, table = from) vals.to.match.idx <- !is.na(x = vals.to.match) v[vals.to.match.idx] <- to[vals.to.match[vals.to.match.idx]] return(v) } # Independently shuffle values within each row of a matrix # # Creates a matrix where correlation structure has been removed, but overall values are the same # # @param x Matrix to shuffle # # @return Returns a scrambled matrix, where each row is shuffled independently # #' @importFrom stats runif # # @export # # @examples # mat <- matrix(data = rbinom(n = 25, size = 20, prob = 0.2 ), nrow = 5) # mat # MatrixRowShuffle(x = mat) # MatrixRowShuffle <- function(x) { x2 <- x x2 <- t(x = x) ind <- order(c(col(x = x2)), runif(n = length(x = x2))) x2 <- matrix( data = x2[ind], nrow = nrow(x = x), ncol = ncol(x = x), byrow = TRUE ) return(x2) } # Reverse the vector x and return the value at the Nth index. If N is larger # than the length of the vector, return the last value in the reversed vector. # # @param x vector of interest # @param N index in reversed vector # # @return returns element at given index # MaxN <- function(x, N = 2){ len <- length(x) if (N > len) { warning('N greater than length(x). Setting N=length(x)') N <- length(x) } sort(x, partial = len - N + 1)[len - N + 1] } # Melt a data frame # # @param x A data frame # # @return A molten data frame # Melt <- function(x) { if (!is.data.frame(x = x)) { x <- as.data.frame(x = x) } return(data.frame( rows = rep.int(x = rownames(x = x), times = ncol(x = x)), cols = unlist(x = lapply(X = colnames(x = x), FUN = rep.int, times = nrow(x = x))), vals = unlist(x = x, use.names = FALSE) )) } # Give hints for old paramters and their newer counterparts # # This is a non-exhaustive list. If your function isn't working properly based # on the parameters you give it, please read the documentation for your function # # @param param A vector of paramters to get hints for # # @return Parameter hints for the specified paramters # OldParamHints <- function(param) { param.conversion <- c( 'raw.data' = 'counts', 'min.genes' = 'min.features', 'features.plot' = 'features', 'pc.genes' = 'features', 'do.print' = 'verbose', 'genes.print' = 'nfeatures.print', 'pcs.print' = 'ndims.print', 'pcs.use' = 'dims', 'reduction.use' = 'reduction', 'cells.use' = 'cells', 'do.balanced' = 'balanced', 'display.progress' = 'verbose', 'print.output' = 'verbose', 'dims.use' = 'dims', 'reduction.type' = 'reduction', 'y.log' = 'log', 'cols.use' = 'cols', 'assay.use' = 'assay' ) return(param.conversion[param]) } # Check the existence of a package # # @param ... Package names # @param error If true, throw an error if the package doesn't exist # # @return Invisibly returns boolean denoting if the package is installed # PackageCheck <- function(..., error = TRUE) { pkgs <- unlist(x = c(...), use.names = FALSE) package.installed <- vapply( X = pkgs, FUN = requireNamespace, FUN.VALUE = logical(length = 1L), quietly = TRUE ) if (error && any(!package.installed)) { stop( "Cannot find ", paste(pkgs[!package.installed], collapse = ', '), "; please install" ) } invisible(x = package.installed) } # Parenting parameters from one environment to the next # # This function allows one to modifiy a parameter in a parent environement # The primary use of this is to ensure logging functions store correct parameters # if they've been modified by a child function or method # # @param parent.find Regex pattern of name of parent function call to modify. # For example, this can be the class name for a method that was dispatched previously # @param ... Parameter names and values to parent; both name and value must be supplied # in the standard \code{name = value} format; any number of name/value pairs can be specified # # @return No return, modifies parent environment directly # # @examples # Parenting(parent.find = 'Seurat', features = features[features > 7]) # Parenting <- function(parent.find = 'Seurat', ...) { calls <- as.character(x = sys.calls()) calls <- lapply( X = strsplit(x = calls, split = '(', fixed = TRUE), FUN = '[', 1 ) parent.index <- grep(pattern = parent.find, x = calls) if (length(x = parent.index) != 1) { warning( "Cannot find a parent environment called ", parent.find, immediate. = TRUE, call. = FALSE ) } else { to.parent <- list(...) if (length(x = to.parent) == 0) { warning("Nothing to parent", immediate. = TRUE, call. = FALSE) } else if (is.null(x = names(x = to.parent))) { stop("All input must be in a key = value pair") } else if (length(x = Filter(f = nchar, x = names(x = to.parent))) != length(x = to.parent)) { stop("All inputs must be named") } else { parent.environ <- sys.frame(which = parent.index) for (i in 1:length(x = to.parent)) { parent.environ[[names(x = to.parent)[i]]] <- to.parent[[i]] } } } } # Calculate the percentage of a vector above some threshold # # @param x Vector of values # @param threshold Threshold to use when calculating percentage # # @return Returns the percentage of `x` values above the given threshold # PercentAbove <- function(x, threshold) { return(length(x = x[x > threshold]) / length(x = x)) } # Generate a random name # # Make a name from randomly sampled lowercase letters, # pasted together with no spaces or other characters # # @param length How long should the name be # @param ... Extra parameters passed to sample # # @return A character with nchar == length of randomly sampled letters # # @seealso \code{\link{sample}} # RandomName <- function(length = 5L, ...) { CheckDots(..., fxns = 'sample') return(paste(sample(x = letters, size = length, ...), collapse = '')) } # Return what was passed # # @param x anything # # @return Returns x # Same <- function(x) { return(x) } # Sweep out array summaries # # Reimplmentation of \code{\link[base]{sweep}} to maintain compatability with # both R 3.X and 4.X # # @inheritParams base::sweep # @param x an array. # # @seealso \code{\link[base]{sweep}} # Sweep <- function(x, MARGIN, STATS, FUN = '-', check.margin = TRUE, ...) { if (any(grepl(pattern = 'X', x = names(x = formals(fun = sweep))))) { return(sweep( X = x, MARGIN = MARGIN, STATS = STATS, FUN = FUN, check.margin = check.margin, ... )) } else { return(sweep( x = x, MARGIN = MARGIN, STATS = STATS, FUN = FUN, check.margin = check.margin, ... )) } } # Get program paths in a system-agnostic way # # @param progs A vector of program names # @param error Throw an error if any programs are not found # @param add.exe Add '.exe' extension to program names that don't have it # # @return A named vector of program paths; missing programs are returned as # \code{NA} if \code{error = FALSE} # #' @importFrom tools file_ext # SysExec <- function( progs, error = ifelse(test = length(x = progs) == 1, yes = TRUE, no = FALSE), add.exe = .Platform$OS.type == 'windows' ) { cmd <- ifelse( test = .Platform$OS.type == 'windows', yes = 'where.exe', no = 'which' ) if (add.exe) { missing.exe <- file_ext(x = progs) != 'exe' progs[missing.exe] <- paste0(progs[missing.exe], '.exe') } paths <- sapply( X = progs, FUN = function(x) { return(tryCatch( expr = system2(command = cmd, args = x, stdout = TRUE)[1], warning = function(...) { return(NA_character_) } )) } ) if (error && any(is.na(x = paths))) { stop( "Could not find the following programs: ", paste(names(x = paths[is.na(x = paths)]), collapse = ', '), call. = FALSE ) } return(paths) } # Try to convert x to numeric, if NA's introduced return x as is # ToNumeric <- function(x){ # check for x:y range if (is.numeric(x = x)) { return(x) } if (length(x = unlist(x = strsplit(x = x, split = ":"))) == 2) { num <- unlist(x = strsplit(x = x, split = ":")) return(num[1]:num[2]) } num <- suppressWarnings(expr = as.numeric(x = x)) if (!is.na(x = num)) { return(num) } return(x) } Seurat/R/generics.R0000644000176200001440000010451513602476666013666 0ustar liggesusers#' Add in metadata associated with either cells or features. #' #' Adds additional data to the object. Can be any piece of information #' associated with a cell (examples include read depth, alignment rate, #' experimental batch, or subpopulation identity) or feature (ENSG name, #' variance). To add cell level information, add to the Seurat object. If adding #' feature-level metadata, add to the Assay object (e.g. object[["RNA"]])) #' #' @param x,object An object #' @param i,col.name Name to store metadata or object as #' @param value,metadata Metadata or object to add #' @param j Ignored #' @param ... Arguments passed to other methods #' #' @return An object with metadata or and object added #' #' @rdname AddMetaData #' @export AddMetaData #' #' @aliases SeuratAccess #' #' @examples #' cluster_letters <- LETTERS[Idents(object = pbmc_small)] #' names(cluster_letters) <- colnames(x = pbmc_small) #' pbmc_small <- AddMetaData( #' object = pbmc_small, #' metadata = cluster_letters, #' col.name = 'letter.idents' #' ) #' head(x = pbmc_small[[]]) #' AddMetaData <- function(object, metadata, col.name = NULL) { UseMethod(generic = 'AddMetaData', object = object) } #' Convert objects to CellDataSet objects #' #' @param x An object to convert to class \code{CellDataSet} #' @param ... Arguments passed to other methods #' #' @rdname as.CellDataSet #' @export as.CellDataSet #' as.CellDataSet <- function(x, ...) { UseMethod(generic = 'as.CellDataSet', object = x) } #' Convert a matrix (or Matrix) to the Graph class. #' #' @param x The matrix to convert #' @param ... Arguments passed to other methods (ignored for now) #' #' @rdname as.Graph #' @export as.Graph #' as.Graph <- function(x, ...) { UseMethod(generic = "as.Graph", object = x) } #' Convert objects to loom objects #' #' @param x An object to convert to class \code{loom} #' @inheritParams loomR::create #' #' @seealso \code{\link[loomR]{create}} #' #' @rdname as.loom #' @export as.loom #' as.loom <- function(x, ...) { UseMethod(generic = 'as.loom', object = x) } #' Convert objects to Seurat objects #' #' @param x An object to convert to class \code{Seurat} #' @param ... Arguments passed to other methods #' #' @rdname as.Seurat #' @export as.Seurat #' as.Seurat <- function(x, ...) { UseMethod(generic = 'as.Seurat', object = x) } #' Convert objects to SingleCellExperiment objects #' #' @param x An object to convert to class \code{SingleCellExperiment} #' @param ... Arguments passed to other methods #' #' @rdname as.SingleCellExperiment #' @export as.SingleCellExperiment #' as.SingleCellExperiment <- function(x, ...) { UseMethod(generic = 'as.SingleCellExperiment', object = x) } #' Convert between data frames and sparse matrices #' #' @param x An object #' @param ... Arguments passed to other methods #' #' @return \code{as.sparse}: A sparse representation of the input data #' #' @rdname as.sparse #' @export as.sparse #' as.sparse <- function(x, ...) { UseMethod(generic = 'as.sparse', object = x) } #' Get cells present in an object #' #' @param x An object #' #' @return A vector of cell names #' #' @rdname Cells #' @export Cells #' #' @examples #' Cells(x = pbmc_small) #' Cells <- function(x) { UseMethod(generic = 'Cells', object = x) } #' Get SeuratCommands #' #' Pull information on previously run commands in the Seurat object. #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @return Either a SeuratCommand object or the requested paramter value #' #' @rdname Command #' @export Command #' Command <- function(object, ...) { UseMethod(generic = 'Command', object = object) } #' Get and set the default assay #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @return The name of the default assay #' #' @rdname DefaultAssay #' @export DefaultAssay #' DefaultAssay <- function(object, ...) { UseMethod(generic = 'DefaultAssay', object = object) } #' @inheritParams DefaultAssay #' @param value Name of assay to set as default #' #' @return An object with the new default assay #' #' @rdname DefaultAssay #' @export DefaultAssay<- #' "DefaultAssay<-" <- function(object, ..., value) { UseMethod(generic = 'DefaultAssay<-', object = object) } #' Get cell embeddings #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @rdname Embeddings #' @export Embeddings #' Embeddings <- function(object, ...) { UseMethod(generic = 'Embeddings', object = object) } #' Cluster Determination #' #' Identify clusters of cells by a shared nearest neighbor (SNN) modularity #' optimization based clustering algorithm. First calculate k-nearest neighbors #' and construct the SNN graph. Then optimize the modularity function to #' determine clusters. For a full description of the algorithms, see Waltman and #' van Eck (2013) \emph{The European Physical Journal B}. Thanks to Nigel #' Delaney (evolvedmicrobe@github) for the rewrite of the Java modularity #' optimizer code in Rcpp! #' #' To run Leiden algorithm, you must first install the leidenalg python #' package (e.g. via pip install leidenalg), see Traag et al (2018). #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @return Returns a Seurat object where the idents have been updated with new cluster info; #' latest clustering results will be stored in object metadata under 'seurat_clusters'. #' Note that 'seurat_clusters' will be overwritten everytime FindClusters is run #' #' @export #' #' @rdname FindClusters #' @export FindClusters #' FindClusters <- function(object, ...) { UseMethod(generic = 'FindClusters', object = object) } #' Gene expression markers of identity classes #' #' Finds markers (differentially expressed genes) for identity classes #' #' @param object An object #' @param ... Arguments passed to other methods and to specific DE methods #' @return data.frame with a ranked list of putative markers as rows, and associated #' statistics as columns (p-values, ROC score, etc., depending on the test used (\code{test.use})). The following columns are always present: #' \itemize{ #' \item \code{avg_logFC}: log fold-chage of the average expression between the two groups. Positive values indicate that the gene is more highly expressed in the first group #' \item \code{pct.1}: The percentage of cells where the gene is detected in the first group #' \item \code{pct.2}: The percentage of cells where the gene is detected in the second group #' \item \code{p_val_adj}: Adjusted p-value, based on bonferroni correction using all genes in the dataset #' } #' #' @details p-value adjustment is performed using bonferroni correction based on #' the total number of genes in the dataset. Other correction methods are not #' recommended, as Seurat pre-filters genes using the arguments above, reducing #' the number of tests performed. Lastly, as Aaron Lun has pointed out, p-values #' should be interpreted cautiously, as the genes used for clustering are the #' same genes tested for differential expression. #' #' @references McDavid A, Finak G, Chattopadyay PK, et al. Data exploration, #' quality control and testing in single-cell qPCR-based gene expression experiments. #' Bioinformatics. 2013;29(4):461-467. doi:10.1093/bioinformatics/bts714 #' @references Trapnell C, et al. The dynamics and regulators of cell fate #' decisions are revealed by pseudotemporal ordering of single cells. Nature #' Biotechnology volume 32, pages 381-386 (2014) #' @references Andrew McDavid, Greg Finak and Masanao Yajima (2017). MAST: Model-based #' Analysis of Single Cell Transcriptomics. R package version 1.2.1. #' https://github.com/RGLab/MAST/ #' @references Love MI, Huber W and Anders S (2014). "Moderated estimation of #' fold change and dispersion for RNA-seq data with DESeq2." Genome Biology. #' https://bioconductor.org/packages/release/bioc/html/DESeq2.html #' #' @export #' #' @examples #' # Find markers for cluster 2 #' markers <- FindMarkers(object = pbmc_small, ident.1 = 2) #' head(x = markers) #' #' # Take all cells in cluster 2, and find markers that separate cells in the 'g1' group (metadata #' # variable 'group') #' markers <- FindMarkers(pbmc_small, ident.1 = "g1", group.by = 'groups', subset.ident = "2") #' head(x = markers) #' #' # Pass 'clustertree' or an object of class phylo to ident.1 and #' # a node to ident.2 as a replacement for FindMarkersNode #' pbmc_small <- BuildClusterTree(object = pbmc_small) #' markers <- FindMarkers(object = pbmc_small, ident.1 = 'clustertree', ident.2 = 5) #' head(x = markers) #' #' @rdname FindMarkers #' @export FindMarkers #' #' @aliases FindMarkersNode #' FindMarkers <- function(object, ...) { UseMethod(generic = 'FindMarkers', object = object) } #' SNN Graph Construction #' #' Constructs a Shared Nearest Neighbor (SNN) Graph for a given dataset. We #' first determine the k-nearest neighbors of each cell. We use this knn graph #' to construct the SNN graph by calculating the neighborhood overlap #' (Jaccard index) between every cell and its k.param nearest neighbors. #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @return Returns the object with object@@snn filled #' #' @examples #' pbmc_small #' # Compute an SNN on the gene expression level #' pbmc_small <- FindNeighbors(pbmc_small, features = VariableFeatures(object = pbmc_small)) #' #' # More commonly, we build the SNN on a dimensionally reduced form of the data #' # such as the first 10 principle components. #' #' pbmc_small <- FindNeighbors(pbmc_small, reduction = "pca", dims = 1:10) #' #' @rdname FindNeighbors #' @export FindNeighbors #' FindNeighbors <- function(object, ...) { UseMethod(generic = 'FindNeighbors', object = object) } #' Find variable features #' #' Identifies features that are outliers on a 'mean variability plot'. #' #' For the mean.var.plot method: #' Exact parameter settings may vary empirically from dataset to dataset, and #' based on visual inspection of the plot. Setting the y.cutoff parameter to 2 #' identifies features that are more than two standard deviations away from the #' average dispersion within a bin. The default X-axis function is the mean #' expression level, and for Y-axis it is the log(Variance/mean). All mean/variance #' calculations are not performed in log-space, but the results are reported in #' log-space - see relevant functions for exact details. #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @rdname FindVariableFeatures #' @export FindVariableFeatures #' #' @aliases FindVariableGenes #' FindVariableFeatures <- function(object, ...) { UseMethod(generic = 'FindVariableFeatures', object = object) } #' Get an Assay object from a given Seurat object. #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @return Returns an Assay object #' #' @rdname GetAssay #' @export GetAssay #' GetAssay <- function(object, ...) { UseMethod(generic = 'GetAssay', object = object) } #' General accessor function for the Assay class #' #' This function can be used to pull information from any of the slots in the Assay class. For #' example, pull one of the data matrices("counts", "data", or "scale.data"). #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @return Returns info from requested slot #' #' @rdname GetAssayData #' @export GetAssayData #' GetAssayData <- function(object, ...) { UseMethod(generic = 'GetAssayData', object = object) } #' Get highly variable feature information #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @return A dataframe with feature means, dispersion, and scaled dispersion #' #' @rdname HVFInfo #' @export HVFInfo #' HVFInfo <- function(object, ...) { UseMethod(generic = 'HVFInfo', object = object) } #' Get, set, and manipulate an object's identity classes #' #' @param x,object An object #' @param ... Arguments passed to other methods; for \code{RenameIdents}: named #' arguments as \code{old.ident = new.ident}; for \code{ReorderIdent}: arguments #' passed on to \code{\link{FetchData}} #' #' @return \code{Idents}: The cell identies #' #' @rdname Idents #' @export Idents #' #' @examples #' # Get cell identity classes #' Idents(object = pbmc_small) #' Idents <- function(object, ... ) { UseMethod(generic = 'Idents', object = object) } #' @inheritParams Idents #' @param value The name of the identites to pull from object metadata or the identities themselves #' #' @return \code{Idents<-}: An object with the cell identites changed #' #' @rdname Idents #' @export Idents<- #' #' @examples #' # Set cell identity classes #' # Can be used to set identities for specific cells to a new level #' Idents(object = pbmc_small, cells = 1:4) <- 'a' #' head(x = Idents(object = pbmc_small)) #' #' # Can also set idents from a value in object metadata #' colnames(x = pbmc_small[[]]) #' Idents(object = pbmc_small) <- 'RNA_snn_res.1' #' levels(x = pbmc_small) #' "Idents<-" <- function(object, ..., value) { UseMethod(generic = 'Idents<-', object = object) } #' Is an object global/persistent? #' #' Typically, when removing \code{Assay} objects from an \code{Seurat} object, #' all associated objects (eg. \code{DimReduc}, \code{Graph}, and \code{SeuratCommand} objects) #' are removed as well. If an associated object is marked as global/persistent, #' the associated object will remain even if its original assay was deleted #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @return \code{TRUE} if the object is global/persistent otherwise \code{FALSE} #' #' @rdname IsGlobal #' @export IsGlobal #' #' @examples #' IsGlobal(pbmc_small[['pca']]) #' IsGlobal <- function(object, ...) { UseMethod(generic = 'IsGlobal', object = object) } #' Get JackStraw information #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @rdname JS #' @export JS #' JS <- function(object, ...) { UseMethod(generic = 'JS', object = object) } #' Set JackStraw information #' #' @inherit JS #' @param value JackStraw information #' #' @rdname JS #' @export JS<- #' "JS<-" <- function(object, ..., value) { UseMethod(generic = 'JS<-', object = object) } #' Get a key #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @rdname Key #' @export Key #' Key <- function(object, ...) { UseMethod(generic = 'Key', object = object) } #' Set a key #' #' @inheritParams Key #' @param value Key value #' #' @rdname Key #' @export Key<- #' "Key<-" <- function(object, ..., value) { UseMethod(generic = 'Key<-', object = object) } #' Get feature loadings #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @rdname Loadings #' @export Loadings #' Loadings <- function(object, ...) { UseMethod(generic = 'Loadings', object = object) } #' Add feature loadings #' #' @inheritParams Loadings #' @param value Feature loadings to add #' #' @rdname Loadings #' @export Loadings<- #' "Loadings<-" <- function(object, ..., value) { UseMethod(generic = 'Loadings<-', object = object) } #' Access miscellaneous data #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @return Miscellaneous data #' #' @rdname Misc #' @export Misc #' Misc <- function(object, ...) { UseMethod(generic = 'Misc', object = object) } #' Set miscellaneous data #' #' @inheritParams Misc #' @param value Data to add #' #' @return An object with miscellaneous data added #' #' @rdname Misc #' @export Misc<- #' "Misc<-" <- function(object, ..., value) { UseMethod(generic = 'Misc<-', object = object) } #' Normalize Data #' #' Normalize the count data present in a given assay. #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @return Returns object after normalization #' #' @rdname NormalizeData #' @export NormalizeData #' NormalizeData <- function(object, ...) { UseMethod(generic = 'NormalizeData', object = object) } #' Identify cells matching certain criteria #' #' Returns a list of cells that match a particular set of criteria such as #' identity class, high/low values for particular PCs, ect.. #' #' @param object An object #' @param ... Arguments passed to other methods and \code{FetchData} #' #' @return A vector of cell names #' #' @rdname OldWhichCells #' @export OldWhichCells #' #' @examples #' \dontrun{ #' OldWhichCells(object = pbmc_small, ident.keep = 2) #' } #' OldWhichCells <- function(object, ...) { UseMethod(generic = 'OldWhichCells', object = object) } #' Get and set project information #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @return Project information #' #' @rdname Project #' @export Project #' Project <- function(object, ...) { UseMethod(generic = 'Project', object = object) } #' @param value Project information to set #' #' @return An object with project information added #' #' @rdname Project #' @export Project<- #' "Project<-" <- function(object, ..., value) { UseMethod(generic = 'Project<-', object = object) } #' Read from and write to h5ad files #' #' Utilize the Anndata h5ad file format for storing and sharing single-cell expression #' data. Provided are tools for writing objects to h5ad files, as well as reading #' h5ad files into a Seurat object #' #' @details #' \code{ReadH5AD} and \code{WriteH5AD} will try to automatically fill slots based #' on data type and presence. For example, objects will be filled with scaled and #' normalized data if \code{adata.X} is a dense matrix and \code{raw} is present #' (when reading), or if the \code{scale.data} slot is filled (when writing). The #' following is a list of how objects will be filled #' \describe{ #' \item{\code{adata.X} is dense and \code{adata.raw} is filled; \code{ScaleData} is filled}{Objects will be filled with scaled and normalized data} #' \item{ #' \code{adata.X} is sparse and \code{adata.raw} is filled; \code{NormalizeData} has been run, \code{ScaleData} has not been run #' }{ #' Objects will be filled with normalized and raw data #' } #' \item{\code{adata.X} is sparse and \code{adata.raw} is not filled; \code{NormalizeData} has not been run}{Objects will be filled with raw data only} #' } #' In addition, dimensional reduction information and nearest-neighbor graphs will #' be searched for and added if and only if scaled data is being added. #' #' When reading: project name is \code{basename(file)}; identity classes will be #' set as the project name; all cell-level metadata from \code{adata.obs} will be #' taken; feature level metadata from \code{data.var} and \code{adata.raw.var} #' (if present) will be merged and stored in assay \code{meta.features}; highly #' variable features will be set if \code{highly_variable} is present in feature-level #' metadata; dimensional reduction objects will be given the assay name provided #' to the function call; graphs will be named \code{assay_method} if method is #' present, otherwise \code{assay_adata} #' #' When writing: only one assay will be written; all dimensional reductions and #' graphs associated with that assay will be stored, no other reductions or graphs #' will be written; active identity classes will be stored in \code{adata.obs} as #' \code{active_ident} #' #' @param file Name of h5ad file, or an H5File object for reading in #' #' @return \code{ReadH5AD}: A Seurat object with data from the h5ad file #' #' @aliases ReadH5AD #' #' @rdname h5ad #' @export ReadH5AD #' ReadH5AD <- function(file, ...) { UseMethod(generic = 'ReadH5AD', object = file) } #' Rename cells #' #' Change the cell names in all the different parts of an object. Can #' be useful before combining multiple objects. #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @return An object with new cell names #' #' @rdname RenameCells #' @export RenameCells #' RenameCells <- function(object, ...) { UseMethod(generic = 'RenameCells', object = object) } #' @inheritParams Idents #' #' @return \code{RenameIdents}: An object with selected identity classes renamed #' #' @rdname Idents #' @export RenameIdents #' @aliases RenameIdent #' #' @examples #' # Rename cell identity classes #' # Can provide an arbitrary amount of idents to rename #' levels(x = pbmc_small) #' pbmc_small <- RenameIdents(object = pbmc_small, '0' = 'A', '2' = 'C') #' levels(x = pbmc_small) #' RenameIdents <- function(object, ...) { UseMethod(generic = 'RenameIdents', object = object) } #' @inheritParams Idents #' @param var Feature or variable to order on #' #' @return \code{ReorderIdent}: An object with #' #' @rdname Idents #' @export ReorderIdent #' @aliases ReorderIdent #' #' @examples #' \dontrun{ #' head(x = Idents(object = pbmc_small)) #' pbmc_small <- ReorderIdent(object = pbmc_small, var = 'PC_1') #' head(x = Idents(object = pbmc_small)) #' } #' ReorderIdent <- function(object, var, ...) { UseMethod(generic = 'ReorderIdent', object = object) } #' Run Adaptively-thresholded Low Rank Approximation (ALRA) #' #' Runs ALRA, a method for imputation of dropped out values in scRNA-seq data. #' Computes the k-rank approximation to A_norm and adjusts it according to the #' error distribution learned from the negative values. Described in #' Linderman, G. C., Zhao, J., Kluger, Y. (2018). "Zero-preserving imputation #' of scRNA-seq data using low rank approximation." (bioRxiv:138677) #' #' @note RunALRA and associated functions are being moved to SeuratWrappers; #' for more information on SeuratWrappers, please see \url{https://github.com/satijalab/seurat-wrappers} #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @rdname RunALRA #' @export RunALRA #' #' @author Jun Zhao, George Linderman #' @references Linderman, G. C., Zhao, J., Kluger, Y. (2018). "Zero-preserving imputation #' of scRNA-seq data using low rank approximation." (bioRxiv:138677) #' @seealso \code{\link{ALRAChooseKPlot}} #' #' @examples #' pbmc_small #' # Example 1: Simple usage, with automatic choice of k. #' pbmc_small_alra <- RunALRA(object = pbmc_small) #' \dontrun{ #' # Example 2: Visualize choice of k, then run ALRA #' # First, choose K #' pbmc_small_alra <- RunALRA(pbmc_small, k.only=TRUE) #' # Plot the spectrum, spacings, and p-values which are used to choose k #' ggouts <- ALRAChooseKPlot(pbmc_small_alra) #' do.call(gridExtra::grid.arrange, c(ggouts, nrow=1)) #' # Run ALRA with the chosen k #' pbmc_small_alra <- RunALRA(pbmc_small_alra) #' } #' RunALRA <- function(object, ...) { .Deprecated( new = 'SeruatWrappers::RunALRA', msg = paste( 'RunALRA and associated functions are being moved to SeuratWrappers;', 'for more information on SeuratWrappers, please see https://github.com/satijalab/seurat-wrappers' ) ) UseMethod(generic = 'RunALRA', object = object) } #' Perform Canonical Correlation Analysis #' #' Runs a canonical correlation analysis using a diagonal implementation of CCA. #' For details about stored CCA calculation parameters, see #' \code{PrintCCAParams}. #' @param object1 First Seurat object #' @param object2 Second Seurat object. # @param ... Arguments passed to other methods #' #' @return Returns a combined Seurat object with the CCA results stored. #' #' @seealso \code{\link{merge.Seurat}} #' #' @examples #' pbmc_small #' # As CCA requires two datasets, we will split our test object into two just for this example #' pbmc1 <- subset(pbmc_small, cells = colnames(pbmc_small)[1:40]) #' pbmc2 <- subset(pbmc_small, cells = colnames(x = pbmc_small)[41:80]) #' pbmc1[["group"]] <- "group1" #' pbmc2[["group"]] <- "group2" #' pbmc_cca <- RunCCA(object1 = pbmc1, object2 = pbmc2) #' # Print results #' print(x = pbmc_cca[["cca"]]) #' #' @rdname RunCCA #' @export RunCCA #' RunCCA <- function(object1, object2, ...) { UseMethod(generic = 'RunCCA', object = object1) } #' Run Independent Component Analysis on gene expression #' #' Run fastica algorithm from the ica package for ICA dimensionality reduction. #' For details about stored ICA calculation parameters, see #' \code{PrintICAParams}. #' #' @param object Seurat object #' #' @rdname RunICA #' @export RunICA #' RunICA <- function(object, ...) { UseMethod(generic = "RunICA", object = object) } #' Run Latent Semantic Indexing on binary count matrix #' #' For details about stored LSI calculation parameters, see #' \code{PrintLSIParams}. #' #' @note RunLSI is being moved to Signac. Equivalent functionality can be #' achieved via the Signac::RunTFIDF and Signac::RunSVD functions; #' for more information on Signac, please see #' \url{https://github.com/timoast/Signac} #' #' @param object Seurat object #' @param ... Arguments passed to other methods #' #' @rdname RunLSI #' @export RunLSI #' RunLSI <- function(object, ...) { .Deprecated( new = 'Signac::RunTFIDF', msg = paste( "RunLSI is being moved to Signac. Equivalent functionality can be", "achieved via the Signac::RunTFIDF and Signac::RunSVD functions; for", "more information on Signac, please see https://github.com/timoast/Signac" ) ) UseMethod(generic = "RunLSI", object = object) } #' Run Principal Component Analysis #' #' Run a PCA dimensionality reduction. For details about stored PCA calculation #' parameters, see \code{PrintPCAParams}. #' #' @param object An object #' @param ... Arguments passed to other methods and IRLBA #' #' @return Returns Seurat object with the PCA calculation stored in the reductions slot #' #' @export #' #' @rdname RunPCA #' @export RunPCA #' RunPCA <- function(object, ...) { UseMethod(generic = 'RunPCA', object = object) } #' Run t-distributed Stochastic Neighbor Embedding #' #' Run t-SNE dimensionality reduction on selected features. Has the option of #' running in a reduced dimensional space (i.e. spectral tSNE, recommended), #' or running based on a set of genes. For details about stored TSNE calculation #' parameters, see \code{PrintTSNEParams}. #' #' @param object Seurat object #' @param ... Arguments passed to other methods and to t-SNE call (most commonly used is perplexity) #' #' @rdname RunTSNE #' @export RunTSNE #' RunTSNE <- function(object, ...) { UseMethod(generic = 'RunTSNE', object = object) } #' Run UMAP #' #' Runs the Uniform Manifold Approximation and Projection (UMAP) dimensional #' reduction technique. To run, you must first install the umap-learn python #' package (e.g. via \code{pip install umap-learn}). Details on this package can be #' found here: \url{https://github.com/lmcinnes/umap}. For a more in depth #' discussion of the mathematics underlying UMAP, see the ArXiv paper here: #' \url{https://arxiv.org/abs/1802.03426}. #' #' @param object An object #' @param ... Arguments passed to other methods and UMAP #' #' @return Returns a Seurat object containing a UMAP representation #' #' @references McInnes, L, Healy, J, UMAP: Uniform Manifold Approximation and #' Projection for Dimension Reduction, ArXiv e-prints 1802.03426, 2018 #' #' @export #' #' @examples #' \dontrun{ #' pbmc_small #' # Run UMAP map on first 5 PCs #' pbmc_small <- RunUMAP(object = pbmc_small, dims = 1:5) #' # Plot results #' DimPlot(object = pbmc_small, reduction = 'umap') #' } #' #' @rdname RunUMAP #' @export RunUMAP #' RunUMAP <- function(object, ...) { UseMethod(generic = 'RunUMAP', object = object) } #' Scale and center the data. #' #' Scales and centers features in the dataset. If variables are provided in vars.to.regress, #' they are individually regressed against each feautre, and the resulting residuals are #' then scaled and centered. #' #' ScaleData now incorporates the functionality of the function formerly known #' as RegressOut (which regressed out given the effects of provided variables #' and then scaled the residuals). To make use of the regression functionality, #' simply pass the variables you want to remove to the vars.to.regress parameter. #' #' Setting center to TRUE will center the expression for each feautre by subtracting #' the average expression for that feautre. Setting scale to TRUE will scale the #' expression level for each feautre by dividing the centered feautre expression #' levels by their standard deviations if center is TRUE and by their root mean #' square otherwise. #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @rdname ScaleData #' @export ScaleData #' ScaleData <- function(object, ...) { UseMethod(generic = 'ScaleData', object = object) } #' Compute Jackstraw scores significance. #' #' Significant PCs should show a p-value distribution that is #' strongly skewed to the left compared to the null distribution. #' The p-value for each PC is based on a proportion test comparing the number #' of features with a p-value below a particular threshold (score.thresh), compared with the #' proportion of features expected under a uniform distribution of p-values. #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @return Returns a Seurat object #' #' @author Omri Wurtzel #' @seealso \code{\link{JackStrawPlot}} #' #' @rdname ScoreJackStraw #' @export ScoreJackStraw #' ScoreJackStraw <- function(object, ...) { UseMethod(generic = 'ScoreJackStraw', object = object) } #' Setter for multimodal data #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @return object with the assay data set #' #' @rdname SetAssayData #' @export SetAssayData #' SetAssayData <- function(object, ...) { UseMethod(generic = 'SetAssayData', object = object) } #' @return \code{SetIdent}: An object with new identity classes set #' #' @rdname Idents #' @export SetIdent #' #' @examples #' # Set cell identity classes using SetIdent #' cells.use <- WhichCells(object = pbmc_small, idents = '1') #' pbmc_small <- SetIdent(object = pbmc_small, cells = cells.use, value = 'B') #' SetIdent <- function(object, ...) { UseMethod(generic = 'SetIdent', object = object) } #' @return \code{StashIdent}: An object with the identities stashed #' #' @rdname Idents #' @export StashIdent #' #' @examples #' head(x = pbmc_small[[]]) #' pbmc_small <- StashIdent(object = pbmc_small, save.name = 'idents') #' head(x = pbmc_small[[]]) #' StashIdent <- function(object, save.name, ...) { UseMethod(generic = 'StashIdent', object = object) } #' Get the standard deviations for an object #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @rdname Stdev #' @export Stdev #' Stdev <- function(object, ...) { UseMethod(generic = 'Stdev', object = object) } #' Return a subset of the Seurat object #' #' Creates a Seurat object containing only a subset of the cells in the #' original object. Takes either a list of cells to use as a subset, or a #' parameter (for example, a gene), to subset on. #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @return Returns a Seurat object containing only the relevant subset of cells #' #' @rdname SubsetData #' @export SubsetData #' #' @examples #' \dontrun{ #' pbmc1 <- SubsetData(object = pbmc_small, cells = colnames(x = pbmc_small)[1:40]) #' pbmc1 #' } #' SubsetData <- function(object, ...) { UseMethod(generic = 'SubsetData', object = object) } #' Get and set additional tool data #' #' Use \code{Tool} to get tool data. If no additional arguments are provided, #' will return a vector with the names of tools in the object. #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @return If no additional arguments, returns the names of the tools in the #' object; otherwise returns the data placed by the tool requested #' #'@note For developers: set tool data using \code{Tool<-}. \code{Tool<-} will #'automatically set the name of the tool to the function that called \code{Tool<-}, #'so each function gets one entry in the tools list and cannot overwrite another #'function's entry. The automatic naming will also remove any method identifiers #'(eg. RunPCA.Seurat will become RunPCA); please plan accordingly. #' #' @rdname Tool #' @export Tool #' @aliases Tools #' Tool <- function(object, ...) { UseMethod(generic = 'Tool', object = object) } #' @inheritParams Tool #' @param value Information to be added to tool list #' #' @rdname Tool #' @export Tool<- #' "Tool<-" <- function(object, ..., value) { UseMethod(generic = 'Tool<-', object = object) } #' Get and set variable feature information #' #' @param object An object #' @param selection.method Method used to set variable features #' @param ... Arguments passed to other methods #' #' @rdname VariableFeatures #' @export VariableFeatures #' VariableFeatures <- function(object, ...) { UseMethod(generic = 'VariableFeatures', object = object) } #' @inheritParams VariableFeatures #' @param value A character vector of variable features #' #' @rdname VariableFeatures #' @export VariableFeatures<- #' "VariableFeatures<-" <- function(object, ..., value) { UseMethod(generic = 'VariableFeatures<-', object = object) } #' Identify cells matching certain criteria #' #' Returns a list of cells that match a particular set of criteria such as #' identity class, high/low values for particular PCs, ect.. #' #' @param object An object #' @param ... Arguments passed to other methods #' #' @return A vector of cell names #' #' @seealso \code{\link{FetchData}} #' @rdname WhichCells #' @export WhichCells #' #' @examples #' WhichCells(object = pbmc_small, idents = 2) #' WhichCells(object = pbmc_small, expression = MS4A1 > 3) #' levels(x = pbmc_small) #' WhichCells(object = pbmc_small, idents = c(1, 2), invert = TRUE) #' WhichCells <- function(object, ...) { UseMethod(generic = 'WhichCells', object = object) } #' @param object An object #' @param ... arguments passed to other methods #' #' @return \code{WriteH5AD}: None, writes to disk #' #' @rdname h5ad #' WriteH5AD <- function(object, ...) { UseMethod(generic = 'WriteH5AD', object = object) } Seurat/R/data.R0000644000176200001440000000510413602476666012772 0ustar liggesusers#' Cell cycle genes #' #' A list of genes used in cell-cycle regression #' #' @format A list of two vectors #' \describe{ #' \item{s.genes}{Genes associated with S-phase} #' \item{g2m.genes}{Genes associated with G2M-phase} #' } #' @source \url{http://science.sciencemag.org/content/352/6282/189} #' "cc.genes" #' Cell cycle genes: 2019 update #' #' A list of genes used in cell-cycle regression, updated with 2019 symbols #' #' @section Updated symbols: #' The following symbols were updated from \code{\link{cc.genes}} #' \describe{ #' \item{s.genes}{ #' \itemize{ #' \item \emph{MCM2}: \emph{MCM7} #' \item \emph{MLF1IP}: \emph{CENPU} #' \item \emph{RPA2}: \emph{POLR1B} #' \item \emph{BRIP1}: \emph{MRPL36} #' } #' } #' \item{g2m.genes}{ #' \itemize{ #' \item \emph{FAM64A}: \emph{PIMREG} #' \item \emph{HN1}: \emph{JPT1} #' } #' } #' } #' #' @format A list of two vectors #' \describe{ #' \item{s.genes}{Genes associated with S-phase} #' \item{g2m.genes}{Genes associated with G2M-phase} #' } #' @source \url{http://science.sciencemag.org/content/352/6282/189} #' #' @seealso \code{\link{cc.genes}} #' #' @examples #' \dontrun{ #' cc.genes.updated.2019 <- cc.genes #' cc.genes.updated.2019$s.genes <- UpdateSymbolList(symbols = cc.genes.updated.2019$s.genes) #' cc.genes.updated.2019$g2m.genes <- UpdateSymbolList(symbols = cc.genes.updated.2019$g2m.genes) #' } #' "cc.genes.updated.2019" #' A small example version of the PBMC dataset #' #' A subsetted version of 10X Genomics' 3k PBMC dataset #' #' @format A Seurat object with the following slots filled #' \describe{ #' \item{assays}{ #' \itemize{Currently only contains one assay ("RNA" - scRNA-seq expression data) #' \item{counts - Raw expression data} #' \item{data - Normalized expression data} #' \item{scale.data - Scaled expression data} #' \item{var.features - names of the current features selected as variable} #' \item{meta.features - Assay level metadata such as mean and variance} #' }} #' \item{meta.data}{Cell level metadata} #' \item{active.assay}{Current default assay} #' \item{active.ident}{Current default idents} #' \item{graphs}{Neighbor graphs computed, currently stores the SNN} #' \item{reductions}{Dimensional reductions: currently PCA and tSNE} #' \item{version}{Seurat version used to create the object} #' \item{commands}{Command history} #' } #' @source \url{https://support.10xgenomics.com/single-cell-gene-expression/datasets/1.1.0/pbmc3k} #' "pbmc_small" Seurat/R/RcppExports.R0000644000176200001440000001070313617631656014351 0ustar liggesusers# Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 RunModularityClusteringCpp <- function(SNN, modularityFunction, resolution, algorithm, nRandomStarts, nIterations, randomSeed, printOutput, edgefilename) { .Call('_Seurat_RunModularityClusteringCpp', PACKAGE = 'Seurat', SNN, modularityFunction, resolution, algorithm, nRandomStarts, nIterations, randomSeed, printOutput, edgefilename) } RunUMISampling <- function(data, sample_val, upsample = FALSE, display_progress = TRUE) { .Call('_Seurat_RunUMISampling', PACKAGE = 'Seurat', data, sample_val, upsample, display_progress) } RunUMISamplingPerCell <- function(data, sample_val, upsample = FALSE, display_progress = TRUE) { .Call('_Seurat_RunUMISamplingPerCell', PACKAGE = 'Seurat', data, sample_val, upsample, display_progress) } RowMergeMatrices <- function(mat1, mat2, mat1_rownames, mat2_rownames, all_rownames) { .Call('_Seurat_RowMergeMatrices', PACKAGE = 'Seurat', mat1, mat2, mat1_rownames, mat2_rownames, all_rownames) } LogNorm <- function(data, scale_factor, display_progress = TRUE) { .Call('_Seurat_LogNorm', PACKAGE = 'Seurat', data, scale_factor, display_progress) } FastRowScale <- function(mat, scale = TRUE, center = TRUE, scale_max = 10, display_progress = TRUE) { .Call('_Seurat_FastRowScale', PACKAGE = 'Seurat', mat, scale, center, scale_max, display_progress) } Standardize <- function(mat, display_progress = TRUE) { .Call('_Seurat_Standardize', PACKAGE = 'Seurat', mat, display_progress) } FastSparseRowScale <- function(mat, scale = TRUE, center = TRUE, scale_max = 10, display_progress = TRUE) { .Call('_Seurat_FastSparseRowScale', PACKAGE = 'Seurat', mat, scale, center, scale_max, display_progress) } FastSparseRowScaleWithKnownStats <- function(mat, mu, sigma, scale = TRUE, center = TRUE, scale_max = 10, display_progress = TRUE) { .Call('_Seurat_FastSparseRowScaleWithKnownStats', PACKAGE = 'Seurat', mat, mu, sigma, scale, center, scale_max, display_progress) } FastCov <- function(mat, center = TRUE) { .Call('_Seurat_FastCov', PACKAGE = 'Seurat', mat, center) } FastCovMats <- function(mat1, mat2, center = TRUE) { .Call('_Seurat_FastCovMats', PACKAGE = 'Seurat', mat1, mat2, center) } FastRBind <- function(mat1, mat2) { .Call('_Seurat_FastRBind', PACKAGE = 'Seurat', mat1, mat2) } FastExpMean <- function(mat, display_progress) { .Call('_Seurat_FastExpMean', PACKAGE = 'Seurat', mat, display_progress) } SparseRowVar2 <- function(mat, mu, display_progress) { .Call('_Seurat_SparseRowVar2', PACKAGE = 'Seurat', mat, mu, display_progress) } SparseRowVarStd <- function(mat, mu, sd, vmax, display_progress) { .Call('_Seurat_SparseRowVarStd', PACKAGE = 'Seurat', mat, mu, sd, vmax, display_progress) } FastLogVMR <- function(mat, display_progress) { .Call('_Seurat_FastLogVMR', PACKAGE = 'Seurat', mat, display_progress) } RowVar <- function(x) { .Call('_Seurat_RowVar', PACKAGE = 'Seurat', x) } SparseRowVar <- function(mat, display_progress) { .Call('_Seurat_SparseRowVar', PACKAGE = 'Seurat', mat, display_progress) } ReplaceColsC <- function(mat, col_idx, replacement) { .Call('_Seurat_ReplaceColsC', PACKAGE = 'Seurat', mat, col_idx, replacement) } FindWeightsC <- function(integration_matrix, cells2, distances, anchor_cells2, integration_matrix_rownames, cell_index, anchor_score, min_dist, sd, display_progress) { .Call('_Seurat_FindWeightsC', PACKAGE = 'Seurat', integration_matrix, cells2, distances, anchor_cells2, integration_matrix_rownames, cell_index, anchor_score, min_dist, sd, display_progress) } IntegrateDataC <- function(integration_matrix, weights, expression_cells2) { .Call('_Seurat_IntegrateDataC', PACKAGE = 'Seurat', integration_matrix, weights, expression_cells2) } SNNAnchor <- function(k_matrix, anchor_only) { .Call('_Seurat_SNNAnchor', PACKAGE = 'Seurat', k_matrix, anchor_only) } ComputeSNN <- function(nn_ranked, prune) { .Call('_Seurat_ComputeSNN', PACKAGE = 'Seurat', nn_ranked, prune) } WriteEdgeFile <- function(snn, filename, display_progress) { invisible(.Call('_Seurat_WriteEdgeFile', PACKAGE = 'Seurat', snn, filename, display_progress)) } DirectSNNToFile <- function(nn_ranked, prune, display_progress, filename) { .Call('_Seurat_DirectSNNToFile', PACKAGE = 'Seurat', nn_ranked, prune, display_progress, filename) } Seurat/R/convenience.R0000644000176200001440000000422713602476666014362 0ustar liggesusers#' @include generics.R #' @include visualization.R #' NULL #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Functions #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' @param ... Extra parameters passed to \code{DimHeatmap} #' #' @rdname DimHeatmap #' @export #' PCHeatmap <- function(object, ...) { args <- list('object' = object) args <- c(args, list(...)) args$reduction <- "pca" return(do.call(what = 'DimHeatmap', args = args)) } #' @rdname DimPlot #' @export #' PCAPlot <- function(object, ...) { return(SpecificDimPlot(object = object, ...)) } #' @rdname DimPlot #' @export #' TSNEPlot <- function(object, ...) { return(SpecificDimPlot(object = object, ...)) } #' @rdname DimPlot #' @export #' UMAPPlot <- function(object, ...) { return(SpecificDimPlot(object = object, ...)) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Methods for Seurat-defined generics #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Methods for R-defined generics #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Internal #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # @rdname DimPlot # SpecificDimPlot <- function(object, ...) { funs <- sys.calls() name <- as.character(x = funs[[length(x = funs) - 1]])[1] name <- tolower(x = gsub(pattern = 'Plot', replacement = '', x = name)) args <- list('object' = object) args <- c(args, list(...)) reduc <- grep( pattern = name, x = names(x = object), value = TRUE, ignore.case = TRUE ) reduc <- grep(pattern = DefaultAssay(object = object), x = reduc, value = TRUE) args$reduction <- ifelse(test = length(x = reduc) == 1, yes = reduc, no = name) tryCatch( expr = return(do.call(what = 'DimPlot', args = args)), error = function(e) { stop(e) } ) } Seurat/R/tree.R0000644000176200001440000002704613527073365013024 0ustar liggesusers#' @include generics.R #' NULL #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Functions #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' Phylogenetic Analysis of Identity Classes #' #' Constructs a phylogenetic tree relating the 'average' cell from each #' identity class. Tree is estimated based on a distance matrix constructed in #' either gene expression space or PCA space. #' #' Note that the tree is calculated for an 'average' cell, so gene expression #' or PC scores are averaged across all cells in an identity class before the #' tree is constructed. #' #' @param object Seurat object #' @param assay Assay to use for the analysis. #' @param features Genes to use for the analysis. Default is the set of #' variable genes (\code{VariableFeatures(object = object)}) #' @param dims If set, tree is calculated in PCA space; overrides \code{features} #' @param graph If graph is passed, build tree based on graph connectivity between #' clusters; overrides \code{dims} and \code{features} #' @param reorder Re-order identity classes (factor ordering), according to #' position on the tree. This groups similar classes together which can be #' helpful, for example, when drawing violin plots. #' @param reorder.numeric Re-order identity classes according to position on #' the tree, assigning a numeric value ('1' is the leftmost node) #' @param verbose Show progress updates #' @inheritParams AverageExpression #' #' @return A Seurat object where the cluster tree can be accessed with \code{\link{Tool}} #' #' @importFrom ape as.phylo #' @importFrom pbapply pblapply #' @importFrom stats dist hclust #' @importFrom utils txtProgressBar setTxtProgressBar #' #' @export #' #' @examples #' pbmc_small #' pbmc_small <- BuildClusterTree(object = pbmc_small) #' Tool(object = pbmc_small, slot = 'BuildClusterTree') #' BuildClusterTree <- function( object, assay = NULL, features = NULL, dims = NULL, graph = NULL, slot = 'data', reorder = FALSE, reorder.numeric = FALSE, verbose = TRUE ) { assay <- assay %||% DefaultAssay(object = object) if (!is.null(x = graph)) { idents <- levels(x = object) nclusters <- length(x = idents) data.dist <- matrix( data = numeric(length = 1L), nrow = nclusters, ncol = nclusters, dimnames = list(idents, idents) ) graph <- object[[graph]] cxi <- CellsByIdentities(object = object) cpairs <- na.omit(object = unique(x = t(x = apply( X = expand.grid(1:nclusters, 1:nclusters)[, c(2, 1)], MARGIN = 1, FUN = function(x) { if (length(x = x) == length(x = unique(x = x))) { return(sort(x = x)) } return(c(NA, NA)) } )))) if (verbose) { pb <- txtProgressBar(style = 3, file = stderr()) } for (i in 1:nrow(x = cpairs)) { i1 <- cpairs[i, ][1] i2 <- cpairs[i, ][2] graph.sub <- graph[cxi[[idents[i1]]], cxi[[idents[i2]]]] d <- mean(x = graph.sub) if (is.na(x = d)) { d <- 0 } data.dist[i1, i2] <- d if (verbose) { setTxtProgressBar(pb = pb, value = i / nrow(x = cpairs)) } } if (verbose) { close(con = pb) } diag(x = data.dist) <- 1 data.dist <- dist(x = data.dist) } else if (!is.null(x = dims)) { my.lapply <- ifelse(test = verbose, yes = pblapply, no = lapply) embeddings <- Embeddings(object = object, reduction = 'pca')[, dims] data.dims <- my.lapply( X = levels(x = object), FUN = function(x) { cells <- WhichCells(object = object, idents = x) if (length(x = cells) == 1) { cells <- c(cells, cells) } temp <- colMeans(x = embeddings[cells, ]) } ) data.dims <- do.call(what = 'cbind', args = data.dims) colnames(x = data.dims) <- levels(x = object) data.dist <- dist(x = t(x = data.dims)) } else { features <- features %||% VariableFeatures(object = object) features <- intersect(x = features, y = rownames(x = object)) data.avg <- AverageExpression( object = object, assays = assay, features = features, slot = slot, verbose = verbose )[[1]] data.dist <- dist(x = t(x = data.avg[features, ])) } data.tree <- as.phylo(x = hclust(d = data.dist)) Tool(object = object) <- data.tree if (reorder) { if (verbose) { message("Reordering identity classes and rebuilding tree") } old.ident.order <- levels(x = object) data.tree <- Tool(object = object, slot = 'BuildClusterTree') all.desc <- GetDescendants(tree = data.tree, node = (data.tree$Nnode + 2)) all.desc <- old.ident.order[all.desc[all.desc <= (data.tree$Nnode + 1)]] Idents(object = object) <- factor(x = Idents(object = object), levels = all.desc, ordered = TRUE) if (reorder.numeric) { new.levels <- sort(x = unique(x = as.integer(x = Idents(object = object)))) Idents(object = object) <- factor(x = as.integer(x = Idents(object = object)), levels = new.levels) object[['tree.ident']] <- as.integer(x = Idents(object = object)) } object <- BuildClusterTree( object = object, assay = assay, features = features, dims = dims, graph = graph, slot = slot, reorder = FALSE, verbose = verbose ) } # if (do.plot) { # PlotClusterTree(object) # } return(object) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Methods for Seurat-defined generics #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Methods for R-defined generics #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Internal #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Depth first traversal path of a given tree # # @param tree Tree object (from ape package) # @param node Internal node in the tree # @param path Path through the tree (for recursion) # @param include.children Include children in the output path # @param only.children Only include children in the output path # @return Returns a vector representing the depth first traversal path # DFT <- function( tree, node, path = NULL, include.children = FALSE, only.children = FALSE ) { if (only.children) { include.children = TRUE } children <- which(x = tree$edge[, 1] == node) child1 <- tree$edge[children[1], 2] child2 <- tree$edge[children[2], 2] if (child1 %in% tree$edge[, 1]) { if (!only.children) { path <- c(path, child1) } path <- DFT( tree = tree, node = child1, path = path, include.children = include.children, only.children = only.children ) } else { if (include.children) { path <- c(path, child1) } } if (child2 %in% tree$edge[, 1]) { if (!only.children) { path <- c(path, child2) } path <- DFT( tree = tree, node = child2, path = path, include.children = include.children, only.children = only.children ) } else { if (include.children) { path <- c(path, child2) } } return(path) } # Function to return all internal (non-terminal) nodes in a given tree # # @param tree Tree object (from ape package) # # @return Returns a vector of all internal nodes for the given tree # GetAllInternalNodes <- function(tree) { return(c(tree$edge[1, 1], DFT(tree = tree, node = tree$edge[1, 1]))) } # Function to get all the descendants on a tree of a given node # # @param tree Tree object (from ape package) # @param node Internal node in the tree # # @return Returns all descendants of the given node # GetDescendants <- function(tree, node, curr = NULL) { if (is.null(x = curr)) { curr <- vector() } daughters <- tree$edge[which(x = tree$edge[, 1] == node), 2] curr <- c(curr, daughters) w <- which(x = daughters >= length(x = tree$tip)) if (length(x = w) > 0) { for (i in 1:length(x = w)) { curr <- GetDescendants(tree = tree, node = daughters[w[i]], curr = curr) } } return(curr) } # Function to get all the descendants on a tree left of a given node # # @param tree Tree object (from ape package) # @param node Internal node in the tree # # @return Returns all descendants left of the given node # GetLeftDescendants <- function(tree, node) { daughters <- tree$edge[which(tree$edge[, 1] == node), 2] if (daughters[1] <= (tree$Nnode + 1)) { return(daughters[1]) } daughter.use <- GetDescendants(tree, daughters[1]) daughter.use <- daughter.use[daughter.use <= (tree$Nnode + 1)] return(daughter.use) } # Function to get all the descendants on a tree right of a given node # # @param tree Tree object (from ape package) # @param node Internal node in the tree # # @return Returns all descendants right of the given node # GetRightDescendants <- function(tree, node) { daughters <- tree$edge[which(x = tree$edge[, 1] == node), 2] if (daughters[2] <= (tree$Nnode + 1)) { return(daughters[2]) } daughter.use <- GetDescendants(tree = tree, node = daughters[2]) daughter.use <- daughter.use[daughter.use <= (tree$Nnode + 1)] return(daughter.use) } # Merge childen of a node # # Merge the childen of a node into a single identity class # # @param object Seurat object # @param node.use Merge children of this node # @param rebuild.tree Rebuild cluster tree after the merge? # @param ... Extra parameters to BuildClusterTree, used only if rebuild.tree = TRUE # # @seealso \code{BuildClusterTree} # # # @examples # PlotClusterTree(object = pbmc_small) # pbmc_small <- MergeNode(object = pbmc_small, node.use = 7, rebuild.tree = TRUE) # PlotClusterTree(object = pbmc_small) # MergeNode <- function(object, node.use, rebuild.tree = FALSE, ...) { CheckDots(..., fxns = 'BuldClusterTree') object.tree <- object@cluster.tree[[1]] node.children <- DFT( tree = object.tree, node = node.use, include.children = TRUE ) node.children <- intersect(x = node.children, y = levels(x = object@ident)) children.cells <- WhichCells(object = object, ident = node.children) if (length(x = children.cells > 0)) { object <- SetIdent( object = object, cells.use = children.cells, ident.use = min(node.children) ) } if (rebuild.tree) { object <- BuildClusterTree(object = object, ...) } return(object) } # Function to check whether a given node in a tree has a child (leaf node) # # @param tree Tree object (from ape package) # @param node Internal node in the tree # # @return Returns a Boolean of whether the given node is connected to a terminal leaf node NodeHasChild <- function(tree, node) { children <- tree$edge[which(x = tree$edge[, 1] == node), ][, 2] return(any(children %in% tree$edge[, 2] && !children %in% tree$edge[, 1])) } # Function to check whether a given node in a tree has only children(leaf nodes) # # @param tree Tree object (from ape package) # @param node Internal node in the tree # # @return Returns a Boolean of whether the given node is connected to only terminal leaf nodes NodeHasOnlyChildren <- function(tree, node) { children <- tree$edge[which(x = tree$edge[, 1] == node), ][, 2] return(!any(children %in% tree$edge[, 1])) } Seurat/R/integration.R0000644000176200001440000030740113617623374014405 0ustar liggesusers#' @include generics.R #' NULL #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Functions #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' Find integration anchors #' #' Finds the integration anchors #' #' @param object.list A list of objects between which to find anchors for #' downstream integration. #' @param assay A vector of assay names specifying which assay to use when #' constructing anchors. If NULL, the current default assay for each object is #' used. #' @param reference A vector specifying the object/s to be used as a reference #' during integration. If NULL (default), all pairwise anchors are found (no #' reference/s). If not NULL, the corresponding objects in \code{object.list} #' will be used as references. When using a set of specified references, anchors #' are first found between each query and each reference. The references are #' then integrated through pairwise integration. Each query is then mapped to #' the integrated reference. #' @param anchor.features Can be either: #' \itemize{ #' \item{A numeric value. This will call \code{\link{SelectIntegrationFeatures}} #' to select the provided number of features to be used in anchor finding} #' \item{A vector of features to be used as input to the anchor finding process} #' } #' @param scale Whether or not to scale the features provided. Only set to FALSE #' if you have previously scaled the features you want to use for each object in #' the object.list #' @param normalization.method Name of normalization method used: LogNormalize #' or SCT #' @param sct.clip.range Numeric of length two specifying the min and max values #' the Pearson residual will be clipped to #' @param reduction Dimensional reduction to perform when finding anchors. Can #' be one of: #' \itemize{ #' \item{cca: Canonical correlation analysis} #' \item{rpca: Reciprocal PCA} #' } #' @param l2.norm Perform L2 normalization on the CCA cell embeddings after #' dimensional reduction #' @param dims Which dimensions to use from the CCA to specify the neighbor #' search space #' @param k.anchor How many neighbors (k) to use when picking anchors #' @param k.filter How many neighbors (k) to use when filtering anchors #' @param k.score How many neighbors (k) to use when scoring anchors #' @param max.features The maximum number of features to use when specifying the #' neighborhood search space in the anchor filtering #' @param nn.method Method for nearest neighbor finding. Options include: rann, #' annoy #' @param eps Error bound on the neighbor finding algorithm (from RANN) #' @param verbose Print progress bars and output #' #' @return Returns an AnchorSet object #' #' @importFrom pbapply pblapply #' @importFrom future.apply future_lapply #' @importFrom future nbrOfWorkers #' #' @export #' FindIntegrationAnchors <- function( object.list = NULL, assay = NULL, reference = NULL, anchor.features = 2000, scale = TRUE, normalization.method = c("LogNormalize", "SCT"), sct.clip.range = NULL, reduction = c("cca", "rpca"), l2.norm = TRUE, dims = 1:30, k.anchor = 5, k.filter = 200, k.score = 30, max.features = 200, nn.method = "rann", eps = 0, verbose = TRUE ) { normalization.method <- match.arg(arg = normalization.method) reduction <- match.arg(arg = reduction) if (reduction == "rpca") { reduction <- "pca" } my.lapply <- ifelse( test = verbose && nbrOfWorkers() == 1, yes = pblapply, no = future_lapply ) object.ncells <- sapply(X = object.list, FUN = function(x) dim(x = x)[2]) if (any(object.ncells <= max(dims))) { bad.obs <- which(x = object.ncells <= max(dims)) stop("Max dimension too large: objects ", paste(bad.obs, collapse = ", "), " contain fewer than ", max(dims), " cells. \n Please specify a", " maximum dimensions that is less than the number of cells in any ", "object (", min(object.ncells), ").") } if (!is.null(x = assay)) { if (length(x = assay) != length(x = object.list)) { stop("If specifying the assay, please specify one assay per object in the object.list") } object.list <- sapply( X = 1:length(x = object.list), FUN = function(x) { DefaultAssay(object = object.list[[x]]) <- assay[x] return(object.list[[x]]) } ) } else { assay <- sapply(X = object.list, FUN = DefaultAssay) } object.list <- CheckDuplicateCellNames(object.list = object.list) slot <- "data" if (normalization.method == "SCT") { slot <- "scale.data" scale <- FALSE if (is.numeric(x = anchor.features)) { stop("Please specify the anchor.features to be used. The expected ", "workflow for integratinge assays produced by SCTransform is ", "SelectIntegrationFeatures -> PrepSCTIntegration -> ", "FindIntegrationAnchors.") } sct.check <- sapply( X = 1:length(x = object.list), FUN = function(x) { sct.cmd <- grep( pattern = 'PrepSCTIntegration', x = Command(object = object.list[[x]]), value = TRUE ) # check assay has gone through PrepSCTIntegration if (!any(grepl(pattern = "PrepSCTIntegration", x = Command(object = object.list[[x]]))) || Command(object = object.list[[x]], command = sct.cmd, value = "assay") != assay[x]) { stop("Object ", x, " assay - ", assay[x], " has not been processed ", "by PrepSCTIntegration. Please run PrepSCTIntegration prior to ", "FindIntegrationAnchors if using assays generated by SCTransform.", call. = FALSE) } # check that the correct features are being used if (all(Command(object = object.list[[x]], command = sct.cmd, value = "anchor.features") != anchor.features)) { stop("Object ", x, " assay - ", assay[x], " was processed using a ", "different feature set than in PrepSCTIntegration. Please rerun ", "PrepSCTIntegration with the same anchor.features for all objects in ", "the object.list.", call. = FALSE) } } ) } if (is.numeric(x = anchor.features) && normalization.method != "SCT") { if (verbose) { message("Computing ", anchor.features, " integration features") } anchor.features <- SelectIntegrationFeatures( object.list = object.list, nfeatures = anchor.features, assay = assay ) } if (scale) { if (verbose) { message("Scaling features for provided objects") } object.list <- my.lapply( X = object.list, FUN = function(object) { ScaleData(object = object, features = anchor.features, verbose = FALSE) } ) } nn.reduction <- reduction # if using pca, only need to compute the internal neighborhood structure once # for each dataset internal.neighbors <- list() if (nn.reduction == "pca") { k.filter <- NA if (verbose) { message("Computing within dataset neighborhoods") } k.neighbor <- max(k.anchor, k.score) internal.neighbors <- my.lapply( X = 1:length(x = object.list), FUN = function(x) { NNHelper( data = Embeddings(object = object.list[[x]][[nn.reduction]])[, dims], k = k.neighbor + 1, method = nn.method, eps = eps ) } ) } # determine pairwise combinations combinations <- expand.grid(1:length(x = object.list), 1:length(x = object.list)) combinations <- combinations[combinations$Var1 < combinations$Var2, , drop = FALSE] # determine the proper offsets for indexing anchors objects.ncell <- sapply(X = object.list, FUN = ncol) offsets <- as.vector(x = cumsum(x = c(0, objects.ncell)))[1:length(x = object.list)] if (is.null(x = reference)) { # case for all pairwise, leave the combinations matrix the same if (verbose) { message("Finding all pairwise anchors") } } else { reference <- unique(x = sort(x = reference)) if (max(reference) > length(x = object.list)) { stop('Error: requested reference object ', max(reference), " but only ", length(x = object.list), " objects provided") } # modify the combinations matrix to retain only R-R and R-Q comparisons if (verbose) { message("Finding anchors between all query and reference datasets") ok.rows <- (combinations$Var1 %in% reference) | (combinations$Var2 %in% reference) combinations <- combinations[ok.rows, ] } } # determine all anchors all.anchors <- my.lapply( X = 1:nrow(x = combinations), FUN = function(row) { i <- combinations[row, 1] j <- combinations[row, 2] object.1 <- DietSeurat( object = object.list[[i]], assays = assay[i], features = anchor.features, counts = FALSE, scale.data = TRUE, dimreducs = reduction ) object.2 <- DietSeurat( object = object.list[[j]], assays = assay[j], features = anchor.features, counts = FALSE, scale.data = TRUE, dimreducs = reduction ) # suppress key duplication warning suppressWarnings(object.1[["ToIntegrate"]] <- object.1[[assay[i]]]) DefaultAssay(object = object.1) <- "ToIntegrate" if (reduction %in% Reductions(object = object.1)) { slot(object = object.1[[reduction]], name = "assay.used") <- "ToIntegrate" } object.1 <- DietSeurat(object = object.1, assays = "ToIntegrate", scale.data = TRUE, dimreducs = reduction) suppressWarnings(object.2[["ToIntegrate"]] <- object.2[[assay[j]]]) DefaultAssay(object = object.2) <- "ToIntegrate" if (reduction %in% Reductions(object = object.2)) { slot(object = object.2[[reduction]], name = "assay.used") <- "ToIntegrate" } object.2 <- DietSeurat(object = object.2, assays = "ToIntegrate", scale.data = TRUE, dimreducs = reduction) object.pair <- switch( EXPR = reduction, 'cca' = { object.pair <- RunCCA( object1 = object.1, object2 = object.2, assay1 = "ToIntegrate", assay2 = "ToIntegrate", features = anchor.features, num.cc = max(dims), renormalize = FALSE, rescale = FALSE, verbose = verbose ) if (l2.norm){ object.pair <- L2Dim(object = object.pair, reduction = reduction) reduction <- paste0(reduction, ".l2") nn.reduction <- reduction } reduction.2 <- character() object.pair }, 'pca' = { common.features <- intersect( x = rownames(x = Loadings(object = object.1[["pca"]])), y = rownames(x = Loadings(object = object.2[["pca"]])) ) object.pair <- merge(x = object.1, y = object.2, merge.data = TRUE) projected.embeddings.1<- t(x = GetAssayData(object = object.1, slot = "scale.data")[common.features, ]) %*% Loadings(object = object.2[["pca"]])[common.features, ] object.pair[['projectedpca.1']] <- CreateDimReducObject( embeddings = rbind(projected.embeddings.1, Embeddings(object = object.2[["pca"]])), assay = DefaultAssay(object = object.1), key = "projectedpca1_" ) projected.embeddings.2 <- t(x = GetAssayData(object = object.2, slot = "scale.data")[common.features, ]) %*% Loadings(object = object.1[["pca"]])[common.features, ] object.pair[['projectedpca.2']] <- CreateDimReducObject( embeddings = rbind(projected.embeddings.2, Embeddings(object = object.1[["pca"]])), assay = DefaultAssay(object = object.2), key = "projectedpca2_" ) object.pair[["pca"]] <- CreateDimReducObject( embeddings = rbind( Embeddings(object = object.1[["pca"]]), Embeddings(object = object.2[["pca"]])), assay = DefaultAssay(object = object.1), key = "pca_" ) reduction <- "projectedpca.1" reduction.2 <- "projectedpca.2" if (l2.norm){ slot(object = object.pair[["projectedpca.1"]], name = "cell.embeddings") <- Sweep( x = Embeddings(object = object.pair[["projectedpca.1"]]), MARGIN = 2, STATS = apply(X = Embeddings(object = object.pair[["projectedpca.1"]]), MARGIN = 2, FUN = sd), FUN = "/" ) slot(object = object.pair[["projectedpca.2"]], name = "cell.embeddings") <- Sweep( x = Embeddings(object = object.pair[["projectedpca.2"]]), MARGIN = 2, STATS = apply(X = Embeddings(object = object.pair[["projectedpca.2"]]), MARGIN = 2, FUN = sd), FUN = "/" ) object.pair <- L2Dim(object = object.pair, reduction = "projectedpca.1") object.pair <- L2Dim(object = object.pair, reduction = "projectedpca.2") reduction <- paste0(reduction, ".l2") reduction.2 <- paste0(reduction.2, ".l2") } object.pair }, stop("Invalid reduction parameter. Please choose either cca or rpca") ) internal.neighbors <- internal.neighbors[c(i, j)] anchors <- FindAnchors( object.pair = object.pair, assay = c("ToIntegrate", "ToIntegrate"), slot = slot, cells1 = colnames(x = object.1), cells2 = colnames(x = object.2), internal.neighbors = internal.neighbors, reduction = reduction, reduction.2 = reduction.2, nn.reduction = nn.reduction, dims = dims, k.anchor = k.anchor, k.filter = k.filter, k.score = k.score, max.features = max.features, nn.method = nn.method, eps = eps, verbose = verbose ) anchors[, 1] <- anchors[, 1] + offsets[i] anchors[, 2] <- anchors[, 2] + offsets[j] return(anchors) } ) all.anchors <- do.call(what = 'rbind', args = all.anchors) all.anchors <- rbind(all.anchors, all.anchors[, c(2, 1, 3)]) all.anchors <- AddDatasetID(anchor.df = all.anchors, offsets = offsets, obj.lengths = objects.ncell) command <- LogSeuratCommand(object = object.list[[1]], return.command = TRUE) anchor.set <- new(Class = "AnchorSet", object.list = object.list, reference.objects = reference %||% seq_along(object.list), anchors = all.anchors, offsets = offsets, anchor.features = anchor.features, command = command ) return(anchor.set) } #' Find transfer anchors #' #' Finds the transfer anchors #' #' @param reference Seurat object to use as the reference #' @param query Seurat object to use as the query #' @param reference.assay Assay to use from reference #' @param query.assay Assay to use from query #' @param reduction Dimensional reduction to perform when finding anchors. Options are: #' \itemize{ #' \item{pcaproject: Project the PCA from the reference onto the query. We recommend using PCA #' when reference and query datasets are from scRNA-seq} #' \item{cca: Run a CCA on the reference and query } #' } #' @param project.query Project the PCA from the query dataset onto the reference. Use only in rare #' cases where the query dataset has a much larger cell number, but the reference dataset has a #' unique assay for transfer. #' @param features Features to use for dimensional reduction #' @param normalization.method Name of normalization method used: LogNormalize or SCT #' @param npcs Number of PCs to compute on reference. If null, then use an existing PCA structure in #' the reference object #' @param l2.norm Perform L2 normalization on the cell embeddings after dimensional reduction #' @param dims Which dimensions to use from the reduction to specify the neighbor search space #' @param k.anchor How many neighbors (k) to use when picking anchors #' @param k.filter How many neighbors (k) to use when filtering anchors #' @param k.score How many neighbors (k) to use when scoring anchors #' @param max.features The maximum number of features to use when specifying the neighborhood search #' space in the anchor filtering #'@param nn.method Method for nearest neighbor finding. Options include: rann, #' annoy #' @param eps Error bound on the neighbor finding algorithm (from RANN) #' @param approx.pca Use truncated singular value decomposition to approximate PCA #' @param verbose Print progress bars and output #' #' @return Returns an AnchorSet object #' #' #' @export #' FindTransferAnchors <- function( reference, query, normalization.method = c("LogNormalize", "SCT"), reference.assay = NULL, query.assay = NULL, reduction = "pcaproject", project.query = FALSE, features = NULL, npcs = 30, l2.norm = TRUE, dims = 1:30, k.anchor = 5, k.filter = 200, k.score = 30, max.features = 200, nn.method = "rann", eps = 0, approx.pca = TRUE, verbose = TRUE ) { if (length(x = reference) > 1 | length(x = query) > 1) { stop("We currently only support transfer between a single query and reference") } if (!reduction %in% c("pcaproject", "cca", "pcaqueryproject")) { stop("Please select either pcaproject, cca, or pcaqueryproject for the reduction parameter.") } if (reduction %in% c('pcaproject', 'pcaqueryproject')) { projected = TRUE } else { projected = FALSE } normalization.method <- match.arg(arg = normalization.method) query <- RenameCells( object = query, new.names = paste0(Cells(x = query), "_", "query") ) reference <- RenameCells( object = reference, new.names = paste0(Cells(x = reference), "_", "reference") ) features <- features %||% VariableFeatures(object = reference) reference.assay <- reference.assay %||% DefaultAssay(object = reference) query.assay <- query.assay %||% DefaultAssay(object = query) DefaultAssay(object = reference) <- reference.assay DefaultAssay(object = query) <- query.assay feature.mean <- NULL slot <- "data" if (normalization.method == "SCT") { features <- intersect(x = features, y = rownames(x = query)) query <- GetResidual(object = query, features = features, verbose = FALSE) query[[query.assay]] <- CreateAssayObject( counts = as.sparse(x = GetAssayData(object = query[[query.assay]], slot = "scale.data")[features, ]) ) query <- SetAssayData( object = query, slot = "data", assay = query.assay, new.data = GetAssayData(object = query[[query.assay]], slot = "counts") ) query <- SetAssayData( object = query, slot = "scale.data", assay = query.assay, new.data = as.matrix(x = GetAssayData(object = query[[query.assay]], slot = "counts")) ) if (IsSCT(assay = reference[[reference.assay]])) { reference <- GetResidual(object = reference, features = features, verbose = FALSE) } reference[[reference.assay]] <- CreateAssayObject( counts = as.sparse(x = GetAssayData(object = reference[[reference.assay]], slot = "scale.data")[features, ]) ) reference <- SetAssayData( object = reference, slot = "data", assay = reference.assay, new.data = GetAssayData(object = reference[[reference.assay]], slot = "counts") ) reference <- SetAssayData( object = reference, slot = "scale.data", assay = reference.assay, new.data = as.matrix(x = GetAssayData(object = reference[[reference.assay]], slot = "counts")) ) feature.mean <- "SCT" slot <- "scale.data" } ## find anchors using PCA projection if (reduction == 'pcaproject') { if (project.query) { if (!is.null(x = npcs)) { if (verbose) { message("Performing PCA on the provided query using ", length(x = features), " features as input.") } if (normalization.method == "LogNormalize") { query <- ScaleData(object = query, features = features, verbose = FALSE) } query <- RunPCA(object = query, npcs = npcs, verbose = FALSE, features = features, approx = approx.pca) } projected.pca <- ProjectCellEmbeddings( reference = query, query = reference, dims = dims, verbose = verbose ) query.pca <- Embeddings(object = query[["pca"]])[, dims] combined.pca <- CreateDimReducObject( embeddings = as.matrix(x = rbind(projected.pca,query.pca))[, dims], key = "ProjectPC_", assay = reference.assay ) combined.ob <- merge(x = reference, y = query) combined.ob[["pcaproject"]] <- combined.pca old.loadings <- Loadings(object = query[["pca"]]) colnames(x = old.loadings) <- paste0("ProjectPC_", 1:ncol(x = old.loadings)) Loadings(object = combined.ob[["pcaproject"]]) <- old.loadings[, dims] } else { if (!is.null(x = npcs)) { if (verbose) { message("Performing PCA on the provided reference using ", length(x = features), " features as input.") } if (normalization.method == "LogNormalize") { reference <- ScaleData(object = reference, features = features, verbose = FALSE) } reference <- RunPCA( object = reference, npcs = npcs, verbose = FALSE, features = features, approx = approx.pca ) } projected.pca <- ProjectCellEmbeddings( reference = reference, query = query, dims = dims, feature.mean = feature.mean, verbose = verbose ) ref.pca <- Embeddings(object = reference[["pca"]])[, dims] combined.pca <- CreateDimReducObject( embeddings = as.matrix(x = rbind(ref.pca, projected.pca))[, dims], key = "ProjectPC_", assay = reference.assay ) combined.ob <- merge(x = reference, y = query) combined.ob[["pcaproject"]] <- combined.pca old.loadings <- Loadings(object = reference[["pca"]]) colnames(x = old.loadings) <- paste0("ProjectPC_", 1:ncol(x = old.loadings)) Loadings(object = combined.ob[["pcaproject"]]) <- old.loadings[, dims] } } ## find anchors using CCA if (reduction == 'cca') { if (normalization.method == "LogNormalize") { reference <- ScaleData(object = reference, features = features, verbose = FALSE) query <- ScaleData(object = query, features = features, verbose = FALSE) } combined.ob <- RunCCA( object1 = reference, object2 = query, features = features, num.cc = max(dims), renormalize = FALSE, rescale = FALSE, verbose = verbose ) } if (l2.norm) { combined.ob <- L2Dim(object = combined.ob, reduction = reduction) reduction <- paste0(reduction, ".l2") } slot <- "data" anchors <- FindAnchors( object.pair = combined.ob, assay = c(reference.assay, query.assay), slot = slot, cells1 = colnames(x = reference), cells2 = colnames(x = query), reduction = reduction, internal.neighbors = list(NULL, NULL), dims = dims, k.anchor = k.anchor, k.filter = k.filter, k.score = k.score, max.features = max.features, nn.method = nn.method, eps = eps, projected = projected, verbose = verbose ) command <- LogSeuratCommand(object = combined.ob, return.command = TRUE) anchor.set <- new( Class = "AnchorSet", object.list = list(combined.ob), reference.cells = colnames(x = reference), query.cells = colnames(x = query), anchors = anchors, anchor.features = features, command = command ) return(anchor.set) } #' Integrate data #' #' Perform dataset integration using a pre-computed anchorset #' #' @param anchorset Results from FindIntegrationAnchors #' @param new.assay.name Name for the new assay containing the integrated data #' @param normalization.method Name of normalization method used: LogNormalize #' or SCT #' @param features Vector of features to use when computing the PCA to determine the weights. Only set #' if you want a different set from those used in the anchor finding process #' @param features.to.integrate Vector of features to integrate. By default, will use the features #' used in anchor finding. #' @param dims Number of PCs to use in the weighting procedure #' @param k.weight Number of neighbors to consider when weighting #' @param weight.reduction Dimension reduction to use when calculating anchor weights. #' This can be either: #' \itemize{ #' \item{A string, specifying the name of a dimension reduction present in all objects to be integrated} #' \item{A vector of strings, specifying the name of a dimension reduction to use for each object to be integrated} #' \item{A vector of Dimreduc objects, specifying the object to use for each object in the integration} #' \item{NULL, in which case a new PCA will be calculated and used to calculate anchor weights} #' } #' Note that, if specified, the requested dimension reduction will only be used for calculating anchor weights in the #' first merge between reference and query, as the merged object will subsequently contain more cells than was in #' query, and weights will need to be calculated for all cells in the object. #' @param sd.weight Controls the bandwidth of the Gaussian kernel for weighting #' @param sample.tree Specify the order of integration. If NULL, will compute automatically. #' @param preserve.order Do not reorder objects based on size for each pairwise integration. #' @param do.cpp Run cpp code where applicable #' @param eps Error bound on the neighbor finding algorithm (from \code{\link{RANN}}) #' @param verbose Print progress bars and output #' #' @return Returns a Seurat object with a new integrated Assay #' #' @export #' IntegrateData <- function( anchorset, new.assay.name = "integrated", normalization.method = c("LogNormalize", "SCT"), features = NULL, features.to.integrate = NULL, dims = 1:30, k.weight = 100, weight.reduction = NULL, sd.weight = 1, sample.tree = NULL, preserve.order = FALSE, do.cpp = TRUE, eps = 0, verbose = TRUE ) { normalization.method <- match.arg(arg = normalization.method) reference.datasets <- slot(object = anchorset, name = 'reference.objects') object.list <- slot(object = anchorset, name = 'object.list') anchors <- slot(object = anchorset, name = 'anchors') ref <- object.list[reference.datasets] features <- features %||% slot(object = anchorset, name = "anchor.features") unintegrated <- merge( x = object.list[[1]], y = object.list[2:length(x = object.list)] ) if (normalization.method == "SCT") { vst.set <- list() for (i in 1:length(x = object.list)) { assay <- DefaultAssay(object = object.list[[i]]) object.list[[i]][[assay]] <- CreateAssayObject( data = GetAssayData(object = object.list[[i]], assay = assay, slot = "scale.data") ) } slot(object = anchorset, name = "object.list") <- object.list } # perform pairwise integration of reference objects reference.integrated <- PairwiseIntegrateReference( anchorset = anchorset, new.assay.name = new.assay.name, normalization.method = normalization.method, features = features, features.to.integrate = features.to.integrate, dims = dims, k.weight = k.weight, weight.reduction = weight.reduction, sd.weight = sd.weight, sample.tree = sample.tree, preserve.order = preserve.order, do.cpp = do.cpp, eps = eps, verbose = verbose ) if (length(x = reference.datasets) == length(x = object.list)) { if (normalization.method == "SCT") { reference.integrated <- SetAssayData( object = reference.integrated, assay = new.assay.name, slot = "scale.data", new.data = ScaleData( object = GetAssayData(object = reference.integrated, assay = new.assay.name, slot = "scale.data"), do.scale = FALSE, do.center = TRUE, verbose = FALSE ) ) reference.integrated[[assay]] <- unintegrated[[assay]] } return(reference.integrated) } else { active.assay <- DefaultAssay(object = ref[[1]]) reference.integrated[[active.assay]] <- NULL reference.integrated[[active.assay]] <- CreateAssayObject( data = GetAssayData( object = reference.integrated[[new.assay.name]], slot = 'data' ) ) DefaultAssay(object = reference.integrated) <- active.assay reference.integrated[[new.assay.name]] <- NULL VariableFeatures(object = reference.integrated) <- features # Extract the query objects (if any) and map to reference integrated.data <- MapQuery( anchorset = anchorset, reference = reference.integrated, new.assay.name = new.assay.name, normalization.method = normalization.method, features = features, features.to.integrate = features.to.integrate, dims = dims, k.weight = k.weight, weight.reduction = weight.reduction, sd.weight = sd.weight, sample.tree = sample.tree, preserve.order = preserve.order, do.cpp = do.cpp, eps = eps, verbose = verbose ) # Construct final assay object integrated.assay <- CreateAssayObject( data = integrated.data ) if (normalization.method == "SCT") { integrated.assay <- SetAssayData( object = integrated.assay, slot = "scale.data", new.data = ScaleData( object = GetAssayData(object = integrated.assay, slot = "data"), do.scale = FALSE, do.center = TRUE, verbose = FALSE ) ) integrated.assay <- SetAssayData( object = integrated.assay, slot = "data", new.data = GetAssayData(object = integrated.assay, slot = "scale.data") ) } unintegrated[[new.assay.name]] <- integrated.assay unintegrated <- SetIntegrationData( object = unintegrated, integration.name = "Integration", slot = "anchors", new.data = anchors ) DefaultAssay(object = unintegrated) <- new.assay.name VariableFeatures(object = unintegrated) <- features unintegrated[["FindIntegrationAnchors"]] <- slot(object = anchorset, name = "command") unintegrated <- LogSeuratCommand(object = unintegrated) return(unintegrated) } } #' Calculate the local structure preservation metric #' #' Calculates a metric that describes how well the local structure of each group #' prior to integration is preserved after integration. This procedure works as #' follows: For each group, compute a PCA, compute the top num.neighbors in pca #' space, compute the top num.neighbors in corrected pca space, compute the #' size of the intersection of those two sets of neighbors. #' Return the average over all groups. #' #' @param object Seurat object #' @param grouping.var Grouping variable #' @param idents Optionally specify a set of idents to compute metric for #' @param neighbors Number of neighbors to compute in pca/corrected pca space #' @param reduction Dimensional reduction to use for corrected space #' @param reduced.dims Number of reduced dimensions to use #' @param orig.dims Number of PCs to use in original space #' @param verbose Display progress bar #' #' @return Returns the average preservation metric #' #' @importFrom RANN nn2 #' @importFrom utils txtProgressBar setTxtProgressBar #' #' @export #' LocalStruct <- function( object, grouping.var, idents = NULL, neighbors = 100, reduction = "pca", reduced.dims = 1:10, orig.dims = 1:10, verbose = TRUE ) { if (is.null(x = idents)) { cells.use <- colnames(x = object) } else { cells.use <- WhichCells(object = object, idents = idents) } Idents(object = object) <- grouping.var local.struct <- list() ob.list <- SplitObject(object = object, split.by = grouping.var) if (verbose) { pb <- txtProgressBar( min = 1, max = length(x = ob.list), style = 3, file = stderr() ) } embeddings <- Embeddings(object = object[[reduction]])[, reduced.dims] for (i in 1:length(x = ob.list)) { ob <- ob.list[[i]] ob <- FindVariableFeatures( object = ob, verbose = FALSE, selection.method = "dispersion", nfeatures = 2000 ) ob <- ScaleData( object = ob, features = VariableFeatures(object = ob), verbose = FALSE ) ob <- RunPCA( object = ob, features = VariableFeatures(object = ob), verbose = FALSE, npcs = max(orig.dims) ) ob.cells <- intersect(x = cells.use, y = colnames(x = ob)) if (length(x = ob.cells) == 0) next nn.corrected <- nn2( data = embeddings[colnames(x = ob), ], query = embeddings[ob.cells, ], k = neighbors )$nn.idx nn.orig <- nn2( data = Embeddings(object = ob[["pca"]])[, orig.dims], query = Embeddings(object = ob[["pca"]])[ob.cells, orig.dims], k = neighbors )$nn.idx local.struct[[i]] <- sapply(X = 1:nrow(x = nn.orig), FUN = function(x) { length(x = intersect(x = nn.orig[x, ], y = nn.corrected[x, ])) / neighbors }) if (verbose) { setTxtProgressBar(pb = pb, value = i) } } names(x = local.struct) <- names(x = ob.list) return(local.struct) } #' Calculates a mixing metric #' #' Here we compute a measure of how well mixed a composite dataset is. To #' compute, we first examine the local neighborhood for each cell (looking at #' max.k neighbors) and determine for each group (could be the dataset after #' integration) the k nearest neighbor and what rank that neighbor was in the #' overall neighborhood. We then take the median across all groups as the mixing #' metric per cell. #' #' @param object Seurat object #' @param grouping.var Grouping variable for dataset #' @param reduction Which dimensionally reduced space to use #' @param dims Dimensions to use #' @param k Neighbor number to examine per group #' @param max.k Maximum size of local neighborhood to compute #' @param eps Error bound on the neighbor finding algorithm (from RANN) #' @param verbose Displays progress bar #' #' @return Returns a vector of values representing the entropy metric from each #' bootstrapped iteration. #' #' @importFrom RANN nn2 #' @importFrom pbapply pbsapply #' @importFrom future.apply future_sapply #' @importFrom future nbrOfWorkers #' @export #' MixingMetric <- function( object, grouping.var, reduction = "pca", dims = 1:2, k = 5, max.k = 300, eps = 0, verbose = TRUE ) { my.sapply <- ifelse( test = verbose && nbrOfWorkers() == 1, yes = pbsapply, no = future_sapply ) embeddings <- Embeddings(object = object[[reduction]])[, dims] nn <- nn2( data = embeddings, k = max.k, eps = eps ) group.info <- object[[grouping.var, drop = TRUE]] groups <- unique(x = group.info) mixing <- my.sapply( X = 1:ncol(x = object), FUN = function(x) { sapply(X = groups, FUN = function(y) { which(x = group.info[nn$nn.idx[x, ]] == y)[k] }) } ) mixing[is.na(x = mixing)] <- max.k mixing <- apply( X = mixing, MARGIN = 2, FUN = median ) return(mixing) } #' Prepare an object list that has been run through SCTransform for integration #' #' @param object.list A list of objects to prep for integration #' @param assay Name or vector of assay names (one for each object) that correspond #' to the assay that SCTransform has been run on. If NULL, the current default #' assay for each object is used. #' @param anchor.features Can be either: #' \itemize{ #' \item{A numeric value. This will call \code{\link{SelectIntegrationFeatures}} #' to select the provided number of features to be used in anchor finding} #' \item{A vector of features to be used as input to the anchor finding #' process} #' } #' @param sct.clip.range Numeric of length two specifying the min and max values #' the Pearson residual will be clipped to #' @param verbose Display output/messages #' #' @return An object list with the \code{scale.data} slots set to the anchor #' features #' #' @importFrom pbapply pblapply #' @importFrom methods slot slot<- #' @importFrom future nbrOfWorkers #' @importFrom future.apply future_lapply #' #' @export #' PrepSCTIntegration <- function( object.list, assay = NULL, anchor.features = 2000, sct.clip.range = NULL, verbose = TRUE ) { my.lapply <- ifelse( test = verbose && nbrOfWorkers() == 1, yes = pblapply, no = future_lapply ) assay <- assay %||% sapply(X = object.list, FUN = DefaultAssay) assay <- rep_len(x = assay, length.out = length(x = object.list)) objects.names <- names(x = object.list) object.list <- lapply( X = 1:length(x = object.list), FUN = function(i) { DefaultAssay(object = object.list[[i]]) <- assay[i] return(object.list[[i]]) } ) sct.check <- vapply( X = 1:length(x = object.list), FUN = function(i) { sct.check <- IsSCT(assay = object.list[[i]][[assay[i]]]) if (!sct.check) { if ("FindIntegrationAnchors" %in% Command(object = object.list[[i]]) && Command(object = object.list[[i]], command = "FindIntegrationAnchors", value = "normalization.method") == "SCT") { sct.check <- TRUE } } return(sct.check) }, FUN.VALUE = logical(length = 1L), USE.NAMES = FALSE ) if (!all(sct.check)) { stop( "The following assays have not been processed with SCTransform:\n", paste( ' object:', which(x = !sct.check, useNames = FALSE), '- assay:', assay[!sct.check], collapse = '\n' ), call. = FALSE ) } object.list <- lapply( X = 1:length(x = object.list), FUN = function(i) { vst_out <- Misc(object = object.list[[i]][[assay[i]]], slot = "vst.out") vst_out$cell_attr <- vst_out$cell_attr[Cells(x = object.list[[i]]), ] vst_out$cells_step1 <- intersect(x = vst_out$cells_step1, y = Cells(x = object.list[[i]])) suppressWarnings(expr = Misc(object = object.list[[i]][[assay[i]]], slot = "vst.out") <- vst_out) return(object.list[[i]]) } ) if (is.numeric(x = anchor.features)) { anchor.features <- SelectIntegrationFeatures( object.list = object.list, nfeatures = anchor.features, verbose = verbose ) } object.list <- my.lapply( X = 1:length(x = object.list), FUN = function(i) { if (!IsSCT(assay = object.list[[i]][[assay[i]]])) { return(object.list[[i]]) } obj <- if (is.null(x = sct.clip.range)) { GetResidual( object = object.list[[i]], features = anchor.features, assay = assay[i], verbose = FALSE ) } else { GetResidual( object = object.list[[i]], assay = assay[i], features = anchor.features, replace.value = TRUE, clip.range = sct.clip.range, verbose = FALSE ) } scale.data <- GetAssayData( object = obj, assay = assay[i], slot = 'scale.data' ) obj <- SetAssayData( object = obj, slot = 'scale.data', new.data = scale.data[anchor.features, ], assay = assay[i] ) return(obj) } ) assays.used <- assay for (i in 1:length(x = object.list)) { assay <- as.character(x = assays.used[i]) object.list[[i]] <- LogSeuratCommand(object = object.list[[i]]) } names(x = object.list) <- objects.names return(object.list) } #' Select integration features #' #' Choose the features to use when integrating multiple datasets. This function #' ranks features by the number of datasets they appear in, breaking ties by the #' median rank across datasets. It returns the highest features by this ranking. #' #' @param object.list List of seurat objects #' @param nfeatures Number of features to return #' @param assay Name of assay from which to pull the variable features. #' @param verbose Print messages #' @param fvf.nfeatures nfeatures for FindVariableFeatures. Used if #' VariableFeatures have not been set for any object in object.list. #' @param ... Additional parameters to \code{\link{FindVariableFeatures}} #' #' @return A vector of selected features #' #' @export #' SelectIntegrationFeatures <- function( object.list, nfeatures = 2000, assay = NULL, verbose = TRUE, fvf.nfeatures = 2000, ... ) { if (!is.null(x = assay)) { if (length(x = assay) != length(x = object.list)) { stop("If specifying the assay, please specify one assay per object in the object.list") } for (ii in length(x = object.list)) { DefaultAssay(object = object.list[[ii]]) <- assay[ii] } } else { assay <- sapply(X = object.list, FUN = DefaultAssay) } for (ii in 1:length(x = object.list)) { if (length(x = VariableFeatures(object = object.list[[ii]])) == 0) { if (verbose) { message(paste0("No variable features found for object", ii, " in the object.list. Running FindVariableFeatures ...")) } object.list[[ii]] <- FindVariableFeatures(object = object.list[[ii]], nfeatures = fvf.nfeatures, verbose = verbose, ...) } } var.features <- unname(obj = unlist(x = lapply( X = 1:length(x = object.list), FUN = function(x) VariableFeatures(object = object.list[[x]], assay = assay[x])) )) var.features <- sort(x = table(var.features), decreasing = TRUE) for (i in 1:length(x = object.list)) { var.features <- var.features[names(x = var.features) %in% rownames(x = object.list[[i]][[assay[i]]])] } tie.val <- var.features[min(nfeatures, length(x = var.features))] features <- names(x = var.features[which(x = var.features > tie.val)]) if (length(x = features) > 0) { feature.ranks <- sapply(X = features, FUN = function(x) { ranks <- sapply(X = object.list, FUN = function(y) { vf <- VariableFeatures(object = y) if (x %in% vf) { return(which(x = x == vf)) } return(NULL) }) median(x = unlist(x = ranks)) }) features <- names(x = sort(x = feature.ranks)) } features.tie <- var.features[which(x = var.features == tie.val)] tie.ranks <- sapply(X = names(x = features.tie), FUN = function(x) { ranks <- sapply(X = object.list, FUN = function(y) { vf <- VariableFeatures(object = y) if (x %in% vf) { return(which(x = x == vf)) } return(NULL) }) median(x = unlist(x = ranks)) }) features <- c( features, names(x = head(x = sort(x = tie.ranks), nfeatures - length(x = features))) ) return(features) } #' Transfer Labels #' #' Transfers the labels #' #' @param anchorset Results from FindTransferAnchors #' @param refdata Data to transfer. Should be either a vector where the names #' correspond to reference cells, or a matrix, where the column names correspond #' to the reference cells. #' @param weight.reduction Dimensional reduction to use for the weighting. #' Options are: #' \itemize{ #' \item{pcaproject: Use the projected PCA used for anchor building} #' \item{pca: Use an internal PCA on the query only} #' \item{cca: Use the CCA used for anchor building} #' \item{custom DimReduc: User provided DimReduc object computed on the query #' cells} #' } #' @param l2.norm Perform L2 normalization on the cell embeddings after #' dimensional reduction #' @param dims Number of PCs to use in the weighting procedure #' @param k.weight Number of neighbors to consider when weighting #' @param sd.weight Controls the bandwidth of the Gaussian kernel for weighting #' @param eps Error bound on the neighbor finding algorithm (from RANN) #' @param do.cpp Run cpp code where applicable #' @param verbose Print progress bars and output #' @param slot Slot to store the imputed data #' #' @return If refdata is a vector, returns a dataframe with label predictions. #' If refdata is a matrix, returns an Assay object where the imputed data has #' been stored in the provided slot. #' #' @export #' TransferData <- function( anchorset, refdata, weight.reduction = 'pcaproject', l2.norm = FALSE, dims = 1:30, k.weight = 50, sd.weight = 1, eps = 0, do.cpp = TRUE, verbose = TRUE, slot = "data" ) { combined.ob <- slot(object = anchorset, name = "object.list")[[1]] anchors <- slot(object = anchorset, name = "anchors") reference.cells <- slot(object = anchorset, name = "reference.cells") query.cells <- slot(object = anchorset, name = "query.cells") if (inherits(x = refdata, what = c("character", "factor"))) { if (length(x = refdata) != length(x = reference.cells)) { stop(paste0("Please provide a vector that is the same length as the number of reference cells", " used in anchor finding.\n", "Length of vector provided: ", length(x = refdata), "\n", "Length of vector required: ", length(x = reference.cells))) } label.transfer <- TRUE } else if (inherits(x = refdata, what = c("dgCMatrix", "matrix"))) { if (ncol(x = refdata) != length(x = reference.cells)) { stop(paste0("Please provide a matrix that has the same number of columns as the number of reference cells", " used in anchor finding.\n", "Number of columns in provided matrix : ", ncol(x = refdata), "\n", "Number of columns required : ", length(x = reference.cells))) } colnames(x = refdata) <- paste0(colnames(x = refdata), "_reference") if (any(!colnames(x = refdata) == reference.cells)) { if (any(!colnames(x = refdata) %in% reference.cells) | any(!reference.cells %in% colnames(x = refdata))) { stop("Some (or all) of the column names of the provided refdata don't match the reference cells used in anchor finding.") } refdata <- refdata[, reference.cells] } if (!slot %in% c("counts", "data")) { stop("Please specify slot as either 'counts' or 'data'.") } label.transfer <- FALSE } else { stop(paste0("Please provide either a vector (character or factor) for label transfer or a matrix", "for feature transfer.\n", "Type provided: ", class(x = refdata))) } if (!inherits(x = weight.reduction, what = "DimReduc") && weight.reduction == 'pca') { message("Running PCA on query dataset") features <- slot(object = anchorset, name = "anchor.features") query <- combined.ob[features, query.cells] query <- ScaleData(object = query, features = features, verbose = FALSE) query <- RunPCA(object = query, npcs = max(dims), features = features, verbose = FALSE) query.pca <- Embeddings(query[['pca']]) #fill with 0s ref.pca <- matrix( data = 0, nrow = length(x = reference.cells), ncol = ncol(x = query.pca), dimnames = list(reference.cells, colnames(x = query.pca)) ) combined.pca.embeddings <- rbind(ref.pca, query.pca)[colnames(x = combined.ob), ] combined.pca <- CreateDimReducObject( embeddings = combined.pca.embeddings, key = "PC_", assay = DefaultAssay(object = combined.ob) ) combined.ob[["pca"]] <- combined.pca if (l2.norm) { combined.ob <- L2Dim(object = combined.ob, reduction = 'pca') } } if (l2.norm) { weight.reduction <- paste0(weight.reduction, ".l2") } if (inherits(x = weight.reduction, what = "DimReduc")) { weight.reduction <- RenameCells( object = weight.reduction, new.names = paste0(Cells(x = weight.reduction), "_query") ) } else { weight.reduction <- combined.ob[[weight.reduction]] } combined.ob <- SetIntegrationData( object = combined.ob, integration.name = "integrated", slot = 'anchors', new.data = anchors ) combined.ob <- SetIntegrationData( object = combined.ob, integration.name = "integrated", slot = 'neighbors', new.data = list('cells1' = reference.cells, 'cells2' = query.cells) ) combined.ob <- FindIntegrationMatrix( object = combined.ob, verbose = verbose ) combined.ob <- FindWeights( object = combined.ob, reduction = weight.reduction, dims = dims, k = k.weight, sd.weight = sd.weight, eps = eps, cpp = do.cpp, verbose = verbose ) weights <- GetIntegrationData( object = combined.ob, integration.name = "integrated", slot = 'weights' ) anchors <- as.data.frame(x = anchors) query.cells <- unname(obj = sapply( X = query.cells, FUN = function(x) gsub(pattern = "_query", replacement = "", x = x) )) # case for projection if (label.transfer) { anchors$id1 <- refdata[anchors[, "cell1"]] reference.ids <- factor(x = anchors$id1, levels = unique(x = refdata)) possible.ids <- levels(x = reference.ids) prediction.mat <- matrix(nrow = nrow(x = anchors), ncol = length(x = possible.ids), data = 0) for(i in 1:length(x = possible.ids)) { prediction.mat[which(reference.ids == possible.ids[i]), i] = 1 } if (verbose) { message("Predicting cell labels") } prediction.scores <- t(x = weights) %*% prediction.mat colnames(x = prediction.scores) <- possible.ids rownames(x = prediction.scores) <- query.cells prediction.ids <- possible.ids[apply(X = prediction.scores, MARGIN = 1, FUN = which.max)] prediction.ids <- as.character(prediction.ids) prediction.scores <- cbind(prediction.scores, max = apply(X = prediction.scores, MARGIN = 1, FUN = max)) predictions <- (data.frame( predicted.id = prediction.ids, prediction.score = as.matrix(prediction.scores), row.names = query.cells, stringsAsFactors = FALSE) ) return(predictions) } else { # case for transferring features reference.cell.indices <- reference.cells[anchors$cell1] refdata.anchors <- refdata[, reference.cell.indices] nfeatures <- nrow(x = refdata) if (verbose) { message(paste0("Transfering ", nfeatures, " features onto reference data")) } new.data <- refdata.anchors %*% weights rownames(x = new.data) <- rownames(x = refdata) colnames(x = new.data) <- query.cells if (inherits(x = new.data, what = "Matrix")) { new.data <- as(object = new.data, Class = "dgCMatrix") } if (slot == "counts") { new.assay <- CreateAssayObject(counts = new.data) } else if (slot == "data") { new.assay <- CreateAssayObject(data = new.data) } return(new.assay) } } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Methods for Seurat-defined generics #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Internal #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Add dataset number and remove cell offset # # Record which dataset number in the original list of Seurat objects # each anchor cell came from, and correct the cell index so it corresponds to # the position of the anchor cell in its own dataset # # @param anchor.df Dataframe of anchors # @param offsets size of each dataset in anchor dataframe # @param obj.length Vector of object lengths # # @return Anchor dataframe with additional columns corresponding to the dataset # of each cell AddDatasetID <- function( anchor.df, offsets, obj.lengths ) { ndataset <- length(x = offsets) total.cells <- sum(obj.lengths) offsets <- c(offsets, total.cells) row.offset <- rep.int(x = offsets[1:ndataset], times = obj.lengths) dataset <- rep.int(x = 1:ndataset, times = obj.lengths) anchor.df <- data.frame( 'cell1' = anchor.df[, 1] - row.offset[anchor.df[, 1]], 'cell2' = anchor.df[, 2] - row.offset[anchor.df[, 2]], 'score' = anchor.df[, 3], 'dataset1' = dataset[anchor.df[, 1]], 'dataset2' = dataset[anchor.df[, 2]] ) return(anchor.df) } # Adjust sample tree to only include given reference objects # # @param x A sample tree # @param reference.objects a sorted list of reference object IDs # AdjustSampleTree <- function(x, reference.objects) { for (i in 1:nrow(x = x)) { obj.id <- -(x[i, ]) if (obj.id[[1]] > 0) { x[i, 1] <- -(reference.objects[[obj.id[[1]]]]) } if (obj.id[[2]] > 0) { x[i, 2] <- -(reference.objects[[obj.id[[2]]]]) } } return(x) } # Add info to anchor matrix # # @param object Seurat object # @param toolname Name in tool slot to pull from # @param annotation Name in metadata to annotate anchors with # @param object.list List of objects using in FindIntegrationAnchors call # # @return Returns the anchor dataframe with additional columns for annotation # metadata AnnotateAnchors <- function( object, toolname = "integrated", annotation = NULL, object.list = NULL ) { anchors <- GetIntegrationData( object = object, integration.name = toolname, slot = 'anchors' ) for(i in annotation) { if (! i %in% colnames(x = object[[]])) { warning(i, " not in object metadata") next } if(!is.null(x = object.list)) { anchors[, paste0("cell1.", i)] <- apply(X = anchors, MARGIN = 1, function(x){ as.character(object.list[[as.numeric(x[["dataset1"]])]][[]][as.numeric(x[["cell1"]]), i]) }) anchors[, paste0("cell2.", i)] <- apply(X = anchors, MARGIN = 1, function(x){ as.character(object.list[[as.numeric(x[["dataset2"]])]][[]][as.numeric(x[["cell2"]]), i]) }) } else { cells1 <- GetIntegrationData( object = object, integration.name = toolname, slot = 'neighbors' )$cells1 cells2 <- GetIntegrationData( object = object, integration.name = toolname, slot = 'neighbors' )$cells2 anchors[, paste0("cell1.", i)] <- object[[i]][cells1[anchors$cell1], , drop = TRUE] anchors[, paste0("cell2.", i)] <- object[[i]][cells2[anchors$cell2], , drop = TRUE] anchors[, paste0(i, ".match")] <- anchors[, paste0("cell1.", i)] == anchors[, paste0("cell2.", i)] } } return(anchors) } # Build tree of datasets based on cell similarity # # @param similarity.matrix Dataset similarity matrix # # @return Returns a heirarchical clustering of datasets # #' @importFrom stats hclust # BuildSampleTree <- function(similarity.matrix) { dist.mat <- as.dist(m = 1 / similarity.matrix) clusters <- hclust(d = dist.mat) return(clusters$merge) } # Construct nearest neighbor matrix from nn.idx # # @param nn.idx Nearest neighbor index matrix (nn.idx from RANN) # @param offset1 Offsets for the first neighbor # @param offset2 Offsets for the second neighbor # # @return returns a sparse matrix representing the NN matrix # ConstructNNMat <- function(nn.idx, offset1, offset2, dims) { k <- ncol(x = nn.idx) j <- as.numeric(x = t(x = nn.idx)) + offset2 i <- ((1:length(x = j)) - 1) %/% k + 1 + offset1 nn.mat <- sparseMatrix(i = i, j = j, x = 1, dims = dims) return(nn.mat) } # Count anchors between all datasets # # Counts anchors between each dataset and scales based on total number of cells # in the datasets # # @param anchor.df Matrix of anchors # @param offsets Dataset sizes in anchor matrix. Used to identify boundaries of # each dataset in matrix, so that total pairwise anchors between all datasets # can be counted # # @return Returns a similarity matrix # CountAnchors <- function( anchor.df, offsets, obj.lengths ) { similarity.matrix <- matrix(data = 0, ncol = length(x = offsets), nrow = length(x = offsets)) similarity.matrix[upper.tri(x = similarity.matrix, diag = TRUE)] <- NA total.cells <- sum(obj.lengths) offsets <- c(offsets, total.cells) for (i in 1:nrow(x = similarity.matrix)){ for (j in 1:ncol(x = similarity.matrix)){ if (!is.na(x = similarity.matrix[i, j])){ relevant.rows <- anchor.df[(anchor.df$dataset1 %in% c(i, j)) & (anchor.df$dataset2 %in% c(i, j)), ] score <- nrow(x = relevant.rows) ncell <- min(obj.lengths[[i]], obj.lengths[[j]]) similarity.matrix[i, j] <- score / ncell } } } return(similarity.matrix) } FilterAnchors <- function( object, assay = NULL, slot = "data", integration.name = 'integrated', features = NULL, k.filter = 200, nn.method = "rann", eps = 0, verbose = TRUE ) { if (verbose) { message("Filtering anchors") } assay <- assay %||% DefaultAssay(object = object) features <- features %||% VariableFeatures(object = object) if (length(x = features) == 0) { stop("No features provided and no VariableFeatures computed.") } features <- unique(x = features) neighbors <- GetIntegrationData(object = object, integration.name = integration.name, slot = 'neighbors') nn.cells1 <- neighbors$cells1 nn.cells2 <- neighbors$cells2 cn.data1 <- L2Norm( mat = as.matrix(x = t(x = GetAssayData( object = object[[assay[1]]], slot = slot)[features, nn.cells1])), MARGIN = 1) cn.data2 <- L2Norm( mat = as.matrix(x = t(x = GetAssayData( object = object[[assay[2]]], slot = slot)[features, nn.cells2])), MARGIN = 1) nn <- NNHelper( data = cn.data2[nn.cells2, ], query = cn.data1[nn.cells1, ], k = k.filter, method = nn.method, eps = eps ) anchors <- GetIntegrationData(object = object, integration.name = integration.name, slot = "anchors") position <- sapply(X = 1:nrow(x = anchors), FUN = function(x) { which(x = anchors[x, "cell2"] == nn$nn.idx[anchors[x, "cell1"], ])[1] }) anchors <- anchors[!is.na(x = position), ] if (verbose) { message("\tRetained ", nrow(x = anchors), " anchors") } object <- SetIntegrationData( object = object, integration.name = integration.name, slot = "anchors", new.data = anchors ) return(object) } FindAnchors <- function( object.pair, assay, slot, cells1, cells2, internal.neighbors, reduction, reduction.2 = character(), nn.reduction = reduction, dims = 1:10, k.anchor = 5, k.filter = 200, k.score = 30, max.features = 200, nn.method = "rann", eps = 0, projected = FALSE, verbose = TRUE ) { # compute local neighborhoods, use max of k.anchor and k.score if also scoring to avoid # recomputing neighborhoods k.neighbor <- k.anchor if (!is.na(x = k.score)) { k.neighbor <- max(k.anchor, k.score) } object.pair <- FindNN( object = object.pair, cells1 = cells1, cells2 = cells2, internal.neighbors = internal.neighbors, dims = dims, reduction = reduction, reduction.2 = reduction.2, nn.reduction = nn.reduction, k = k.neighbor, nn.method = nn.method, eps = eps, verbose = verbose ) object.pair <- FindAnchorPairs( object = object.pair, integration.name = "integrated", k.anchor = k.anchor, verbose = verbose ) if (!is.na(x = k.filter)) { top.features <- TopDimFeatures( object = object.pair, reduction = reduction, dims = dims, features.per.dim = 100, max.features = max.features, projected = projected ) object.pair <- FilterAnchors( object = object.pair, assay = assay, slot = slot, integration.name = 'integrated', features = top.features, k.filter = k.filter, nn.method = nn.method, eps = eps, verbose = verbose ) } if (!is.na(x = k.score)) { object.pair = ScoreAnchors( object = object.pair, assay = DefaultAssay(object = object.pair), integration.name = "integrated", verbose = verbose, k.score = k.score ) } anchors <- GetIntegrationData( object = object.pair, integration.name = 'integrated', slot = 'anchors' ) return(anchors) } # Find Anchor pairs # FindAnchorPairs <- function( object, integration.name = 'integrated', cells1 = NULL, cells2 = NULL, k.anchor = 5, verbose = TRUE ) { neighbors <- GetIntegrationData(object = object, integration.name = integration.name, slot = 'neighbors') max.nn <- c(ncol(x = neighbors$nnab$nn.idx), ncol(x = neighbors$nnba$nn.idx)) if (any(k.anchor > max.nn)) { message(paste0('warning: requested k.anchor = ', k.anchor, ', only ', min(max.nn), ' in dataset')) k.anchor <- min(max.nn) } if (verbose) { message("Finding anchors") } if (is.null(x = cells1)) { cells1 <- colnames(x = object) } if (is.null(x = cells2)) { cells2 <- colnames(x = object) } if (!(cells1 %in% colnames(object)) || !(cells2 %in% colnames(object))) { warning("Requested cells not contained in Seurat object. Subsetting list of cells.") cells1 <- intersect(x = cells1, y = colnames(x = object)) cells2 <- intersect(x = cells2, y = colnames(x = object)) } # convert cell name to neighbor index nn.cells1 <- neighbors$cells1 nn.cells2 <- neighbors$cells2 cell1.index <- sapply(X = cells1, FUN = function(x) return(which(x == nn.cells1))) cell2.index <- sapply(X = cells2, FUN = function(x) return(which(x == nn.cells2))) ncell <- 1:nrow(x = neighbors$nnab$nn.idx) ncell <- ncell[ncell %in% cell1.index] anchors <- list() # pre allocate vector anchors$cell1 <- rep(x = 0, length(x = ncell) * 5) anchors$cell2 <- anchors$cell1 anchors$score <- anchors$cell1 + 1 idx <- 0 for (cell in ncell) { neighbors.ab <- neighbors$nnab$nn.idx[cell, 1:k.anchor] mutual.neighbors <- which( x = neighbors$nnba$nn.idx[neighbors.ab, 1:k.anchor, drop = FALSE] == cell, arr.ind = TRUE )[, 1] for (i in neighbors.ab[mutual.neighbors]){ idx <- idx + 1 anchors$cell1[idx] <- cell anchors$cell2[idx] <- i anchors$score[idx] <- 1 } } anchors$cell1 <- anchors$cell1[1:idx] anchors$cell2 <- anchors$cell2[1:idx] anchors$score <- anchors$score[1:idx] anchors <- t(x = do.call(what = rbind, args = anchors)) anchors <- as.matrix(x = anchors) object <- SetIntegrationData( object = object, integration.name = integration.name, slot = 'anchors', new.data = anchors ) if (verbose) { message(paste0("\tFound ", nrow(x = anchors), " anchors")) } return(object) } FindIntegrationMatrix <- function( object, assay = NULL, integration.name = 'integrated', features.integrate = NULL, verbose = TRUE ) { assay <- assay %||% DefaultAssay(object = object) neighbors <- GetIntegrationData(object = object, integration.name = integration.name, slot = 'neighbors') nn.cells1 <- neighbors$cells1 nn.cells2 <- neighbors$cells2 anchors <- GetIntegrationData( object = object, integration.name = integration.name, slot = 'anchors' ) if (verbose) { message("Finding integration vectors") } features.integrate <- features.integrate %||% rownames( x = GetAssayData(object = object, assay = assay, slot = "data") ) data.use1 <- t(x = GetAssayData( object = object, assay = assay, slot = "data")[features.integrate, nn.cells1] ) data.use2 <- t(x = GetAssayData( object = object, assay = assay, slot = "data")[features.integrate, nn.cells2] ) anchors1 <- nn.cells1[anchors[, "cell1"]] anchors2 <- nn.cells2[anchors[, "cell2"]] data.use1 <- data.use1[anchors1, ] data.use2 <- data.use2[anchors2, ] integration.matrix <- data.use2 - data.use1 object <- SetIntegrationData( object = object, integration.name = integration.name, slot = 'integration.matrix', new.data = integration.matrix ) return(object) } # Find nearest neighbors # FindNN <- function( object, cells1 = NULL, cells2 = NULL, internal.neighbors, grouping.var = NULL, dims = 1:10, reduction = "cca.l2", reduction.2 = character(), nn.dims = dims, nn.reduction = reduction, k = 300, nn.method = "rann", eps = 0, integration.name = 'integrated', verbose = TRUE ) { if (xor(x = is.null(x = cells1), y = is.null(x = cells2))) { stop("cells1 and cells2 must both be specified") } if (!is.null(x = cells1) && !is.null(x = cells2) && !is.null(x = grouping.var)) { stop("Specify EITHER grouping.var or cells1/2.") } if (is.null(x = cells1) && is.null(x = cells2) && is.null(x = grouping.var)) { stop("Please set either cells1/2 or grouping.var") } if (!is.null(x = grouping.var)) { if (nrow(x = unique(x = object[[grouping.var]])) != 2) { stop("Number of groups in grouping.var not equal to 2.") } groups <- names(x = sort(x = table(object[[grouping.var]]), decreasing = TRUE)) cells1 <- colnames(x = object)[object[[grouping.var]] == groups[[1]]] cells2 <- colnames(x = object)[object[[grouping.var]] == groups[[2]]] } if (verbose) { message("Finding neighborhoods") } if (!is.null(x = internal.neighbors[[1]])) { nnaa <- internal.neighbors[[1]] nnbb <- internal.neighbors[[2]] } else { dim.data.self <- Embeddings(object = object[[nn.reduction]])[ ,nn.dims] dims.cells1.self <- dim.data.self[cells1, ] dims.cells2.self <- dim.data.self[cells2, ] nnaa <- NNHelper( data = dims.cells1.self, k = k + 1, method = nn.method, eps = eps ) nnbb <- NNHelper( data = dims.cells2.self, k = k + 1, method = nn.method, eps = eps ) } if (length(x = reduction.2) > 0) { nnab <- NNHelper( data = Embeddings(object = object[[reduction.2]])[cells2, ], query = Embeddings(object = object[[reduction.2]])[cells1, ], k = k, method = nn.method, eps = eps ) nnba <- NNHelper( data = Embeddings(object = object[[reduction]])[cells1, ], query = Embeddings(object = object[[reduction]])[cells2, ], k = k, method = nn.method, eps = eps ) } else { dim.data.opposite <- Embeddings(object = object[[reduction]])[ ,dims] dims.cells1.opposite <- dim.data.opposite[cells1, ] dims.cells2.opposite <- dim.data.opposite[cells2, ] nnab <- NNHelper( data = dims.cells2.opposite, query = dims.cells1.opposite, k = k, method = nn.method, eps = eps ) nnba <- NNHelper( data = dims.cells1.opposite, query = dims.cells2.opposite, k = k, method = nn.method, eps = eps ) } object <- SetIntegrationData( object = object, integration.name = integration.name, slot = 'neighbors', new.data = list('nnaa' = nnaa, 'nnab' = nnab, 'nnba' = nnba, 'nnbb' = nnbb, 'cells1' = cells1, 'cells2' = cells2) ) return(object) } # @param reduction a DimReduc object containing cells in the query object FindWeights <- function( object, reduction = NULL, assay = NULL, integration.name = 'integrated', dims = 1:10, features = NULL, k = 300, sd.weight = 1, nn.method = "rann", eps = 0, verbose = TRUE, cpp = FALSE ) { if (verbose) { message("Finding integration vector weights") } if (is.null(x = reduction) & is.null(x = features)) { stop("Need to specify either dimension reduction object or a set of features") } assay <- assay %||% DefaultAssay(object = object) neighbors <- GetIntegrationData(object = object, integration.name = integration.name, slot = 'neighbors') nn.cells1 <- neighbors$cells1 nn.cells2 <- neighbors$cells2 anchors <- GetIntegrationData( object = object, integration.name = integration.name, slot = 'anchors' ) anchors.cells2 <- nn.cells2[anchors[, "cell2"]] if (is.null(x = features)) { data.use <- Embeddings(reduction)[nn.cells2, dims] } else { data.use <- t(x = GetAssayData(object = object, slot = 'data', assay = assay)[features, nn.cells2]) } knn_2_2 <- NNHelper( data = data.use[anchors.cells2, ], query = data.use, k = k + 1, method = nn.method, eps = eps ) distances <- knn_2_2$nn.dists[, -1] distances <- 1 - (distances / distances[, ncol(x = distances)]) cell.index <- knn_2_2$nn.idx[, -1] integration.matrix <- GetIntegrationData( object = object, integration.name = integration.name, slot = "integration.matrix" ) if (cpp) { weights <- FindWeightsC( integration_matrix = as(integration.matrix, "dgCMatrix"), cells2 = 0:(length(x = nn.cells2) - 1), distances = as.matrix(x = distances), anchor_cells2 = anchors.cells2, integration_matrix_rownames = rownames(x = integration.matrix), cell_index = cell.index, anchor_score = anchors[, "score"], min_dist = 0, sd = sd.weight, display_progress = verbose ) } else { if (verbose) { pb <- txtProgressBar(min = 1, max = length(x = nn.cells2), initial = 1, style = 3, file = stderr()) } dist.weights <- matrix( data = 0, nrow = nrow(x = integration.matrix), ncol = length(x = nn.cells2) ) for (cell in 1:length(x = nn.cells2)) { wt <- distances[cell, ] cellnames <- anchors.cells2[cell.index[cell, ]] names(x = wt) <- cellnames for (i in cellnames){ anchor.index <- which(rownames(integration.matrix) == i) dist.weights[anchor.index, cell] <- wt[[i]] } if (verbose) setTxtProgressBar(pb, cell) } if (verbose) message("") dist.anchor.weight <- dist.weights * anchors[, "score"] weights <- 1 - exp(-1 * dist.anchor.weight / (2 * (1 / sd.weight)) ^ 2) weights <- Sweep(x = weights, MARGIN = 2, STATS = Matrix::colSums(weights), FUN = "/") } object <- SetIntegrationData( object = object, integration.name = integration.name, slot = 'weights', new.data = weights ) return(object) } # Work out the anchor cell offsets for given set of cells in anchor list # # @param anchors A dataframe of anchors, from AnchorSet object # @param dataset Dataset number (1 or 2) # @param cell Cell number (1 or 2) # @param cellnames.list List of cell names in all objects # @param cellnames list of cell names for only the object in question # # @return Returns a list of offsets # GetCellOffsets <- function(anchors, dataset, cell, cellnames.list, cellnames) { cell.id <- sapply(X = 1:nrow(x = anchors), FUN = function(x) { cellnames.list[[anchors[, dataset+3][x]]][anchors[, cell][x]] }) cell.offset <- sapply( X = 1:length(x = cell.id), FUN = function(x) { return(which(x = cellnames == cell.id[x])) } ) return(cell.offset) } # Map queries to reference # # Map query objects onto assembled reference dataset # # @param anchorset Anchorset found by FindIntegrationAnchors # @param reference Pre-integrated reference dataset to map query datasets to # @param new.assay.name Name for the new assay containing the integrated data # @param normalization.method Name of normalization method used: LogNormalize # or SCT # @param features Vector of features to use when computing the PCA to determine the weights. Only set # if you want a different set from those used in the anchor finding process # @param features.to.integrate Vector of features to integrate. By default, will use the features # used in anchor finding. # @param dims Number of PCs to use in the weighting procedure # @param k.weight Number of neighbors to consider when weighting # @param weight.reduction Dimension reduction to use when calculating anchor weights. # This can be either: # \itemize{ # \item{A string, specifying the name of a dimension reduction present in all objects to be integrated} # \item{A vector of strings, specifying the name of a dimension reduction to use for each object to be integrated} # \item{NULL, in which case a new PCA will be calculated and used to calculate anchor weights} # } # Note that, if specified, the requested dimension reduction will only be used for calculating anchor weights in the # first merge between reference and query, as the merged object will subsequently contain more cells than was in # query, and weights will need to be calculated for all cells in the object. # @param sd.weight Controls the bandwidth of the Gaussian kernel for weighting # @param sample.tree Specify the order of integration. If NULL, will compute automatically. # @param preserve.order Do not reorder objects based on size for each pairwise integration. # @param do.cpp Run cpp code where applicable # @param eps Error bound on the neighbor finding algorithm (from \code{\link{RANN}}) # @param verbose Print progress bars and output # # @return Returns an integrated matrix # MapQuery <- function( anchorset, reference, new.assay.name = "integrated", normalization.method = c("LogNormalize", "SCT"), features = NULL, features.to.integrate = NULL, dims = 1:30, k.weight = 100, weight.reduction = NULL, sd.weight = 1, sample.tree = NULL, preserve.order = FALSE, do.cpp = TRUE, eps = 0, verbose = TRUE ) { normalization.method <- match.arg(arg = normalization.method) reference.datasets <- slot(object = anchorset, name = 'reference.objects') object.list <- slot(object = anchorset, name = 'object.list') anchors <- slot(object = anchorset, name = 'anchors') features <- features %||% slot(object = anchorset, name = "anchor.features") features.to.integrate <- features.to.integrate %||% features cellnames.list <- list() for (ii in 1:length(x = object.list)) { cellnames.list[[ii]] <- colnames(x = object.list[[ii]]) } if (length(x = reference.datasets) == length(x = object.list)) { query.datasets <- NULL } else { query.datasets <- setdiff(x = seq_along(along.with = object.list), y = reference.datasets) } my.lapply <- ifelse( test = verbose && nbrOfWorkers() == 1, yes = pblapply, no = future_lapply ) query.corrected <- my.lapply( X = query.datasets, FUN = function(dataset1) { if (verbose) { message("Integrating dataset ", dataset1, " with reference dataset") } filtered.anchors <- anchors[anchors$dataset1 %in% reference.datasets & anchors$dataset2 == dataset1, ] integrated <- RunIntegration( filtered.anchors = filtered.anchors, reference = reference, query = object.list[[dataset1]], new.assay.name = new.assay.name, normalization.method = normalization.method, cellnames.list = cellnames.list, features.to.integrate = features.to.integrate, weight.reduction = weight.reduction, features = features, dims = dims, do.cpp = do.cpp, k.weight = k.weight, sd.weight = sd.weight, eps = eps, verbose = verbose ) return(integrated) } ) reference.integrated <- GetAssayData( object = reference, slot = 'data' )[features.to.integrate, ] query.corrected[[length(x = query.corrected) + 1]] <- reference.integrated all.integrated <- do.call(cbind, query.corrected) return(all.integrated) } # Convert nearest neighbor information to a sparse matrix # # @param idx Nearest neighbor index # @param distance Nearest neighbor distance # @param k Number of nearest neighbors # NNtoMatrix <- function(idx, distance, k) { nn <- list() x <- 1 for (i in 1:nrow(x = idx)) { for (j in 2:k) { nn.idx <- idx[i, j] nn.dist <- distance[i, j] nn[[x]] <- c('i' = i, 'j' = nn.idx, 'x' = 1/nn.dist) x <- x + 1 } } nn <- do.call(what = rbind, args = nn) nn.matrix <- new( Class = 'dgTMatrix', i = as.integer(x = nn[, 1] - 1), j = as.integer(x = nn[, 2] - 1), x = as.numeric(x = nn[, 3]), Dim = as.integer(x = c(nrow(idx), nrow(x = idx))) ) nn.matrix <- as(object = nn.matrix, Class = 'dgCMatrix') return(nn.matrix) } # Pairwise dataset integration # # Used for reference construction # # @param anchorset Results from FindIntegrationAnchors # @param new.assay.name Name for the new assay containing the integrated data # @param normalization.method Name of normalization method used: LogNormalize # or SCT # @param features Vector of features to use when computing the PCA to determine # the weights. Only set if you want a different set from those used in the # anchor finding process # @param features.to.integrate Vector of features to integrate. By default, # will use the features used in anchor finding. # @param dims Number of PCs to use in the weighting procedure # @param k.weight Number of neighbors to consider when weighting # @param weight.reduction Dimension reduction to use when calculating anchor # weights. This can be either: # \itemize{ # \item{A string, specifying the name of a dimension reduction present in # all objects to be integrated} # \item{A vector of strings, specifying the name of a dimension reduction to # use for each object to be integrated} # \item{NULL, in which case a new PCA will be calculated and used to # calculate anchor weights} # } # Note that, if specified, the requested dimension reduction will only be used # for calculating anchor weights in the first merge between reference and # query, as the merged object will subsequently contain more cells than was in # query, and weights will need to be calculated for all cells in the object. # @param sd.weight Controls the bandwidth of the Gaussian kernel for weighting # @param sample.tree Specify the order of integration. If NULL, will compute # automatically. # @param preserve.order Do not reorder objects based on size for each pairwise # integration. # @param do.cpp Run cpp code where applicable # @param eps Error bound on the neighbor finding algorithm (from # \code{\link{RANN}}) # @param verbose Print progress bars and output # # @return Returns a Seurat object with a new integrated Assay # PairwiseIntegrateReference <- function( anchorset, new.assay.name = "integrated", normalization.method = c("LogNormalize", "SCT"), features = NULL, features.to.integrate = NULL, dims = 1:30, k.weight = 100, weight.reduction = NULL, sd.weight = 1, sample.tree = NULL, preserve.order = FALSE, do.cpp = TRUE, eps = 0, verbose = TRUE ) { object.list <- slot(object = anchorset, name = "object.list") reference.objects <- slot(object = anchorset, name = "reference.objects") features <- features %||% slot(object = anchorset, name = "anchor.features") features.to.integrate <- features.to.integrate %||% features if (length(x = reference.objects) == 1) { ref.obj <- object.list[[reference.objects]] ref.obj[[new.assay.name]] <- CreateAssayObject( data = GetAssayData(ref.obj, slot = 'data')[features.to.integrate, ] ) DefaultAssay(object = ref.obj) <- new.assay.name return(ref.obj) } anchors <- slot(object = anchorset, name = "anchors") offsets <- slot(object = anchorset, name = "offsets") objects.ncell <- sapply(X = object.list, FUN = ncol) if (!is.null(x = weight.reduction)) { if (length(x = weight.reduction) == 1 | inherits(x = weight.reduction, what = "DimReduc")) { if (length(x = object.list) == 2) { weight.reduction <- list(NULL, weight.reduction) } else if (inherits(x = weight.reduction, what = "character")) { weight.reduction <- rep(x = weight.reduction, times = length(x = object.list)) } else { stop("Invalid input for weight.reduction. Please specify either the names of the dimension", "reduction for each object in the list or provide DimReduc objects.") } } if (length(x = weight.reduction) != length(x = object.list)) { stop("Please specify a dimension reduction for each object, or one dimension reduction to be used for all objects") } available.reductions <- lapply(X = object.list, FUN = FilterObjects, classes.keep = 'DimReduc') for (ii in 1:length(x = weight.reduction)) { if (ii == 1 & is.null(x = weight.reduction[[ii]])) next if (!inherits(x = weight.reduction[[ii]], what = "DimReduc")) { if (!weight.reduction[[ii]] %in% available.reductions[[ii]]) { stop("Requested dimension reduction (", weight.reduction[[ii]], ") is not present in object ", ii) } weight.reduction[[ii]] <- object.list[[ii]][[weight.reduction[[ii]]]] } } } if (is.null(x = sample.tree)) { similarity.matrix <- CountAnchors( anchor.df = anchors, offsets = offsets, obj.lengths = objects.ncell ) similarity.matrix <- similarity.matrix[reference.objects, reference.objects] sample.tree <- BuildSampleTree(similarity.matrix = similarity.matrix) sample.tree <- AdjustSampleTree(x = sample.tree, reference.objects = reference.objects) } cellnames.list <- list() for (ii in 1:length(x = object.list)) { cellnames.list[[ii]] <- colnames(x = object.list[[ii]]) } unintegrated <- merge( x = object.list[[reference.objects[[1]]]], y = object.list[reference.objects[2:length(x = reference.objects)]] ) names(x = object.list) <- as.character(-(1:length(x = object.list))) if (verbose & (length(x = reference.objects) != length(x = object.list))) { message("Building integrated reference") } for (ii in 1:nrow(x = sample.tree)) { merge.pair <- as.character(x = sample.tree[ii, ]) length1 <- ncol(x = object.list[[merge.pair[1]]]) length2 <- ncol(x = object.list[[merge.pair[2]]]) if (!(preserve.order) & (length2 > length1)) { merge.pair <- rev(x = merge.pair) sample.tree[ii, ] <- as.numeric(merge.pair) } object.1 <- DietSeurat( object = object.list[[merge.pair[1]]], assays = DefaultAssay(object = object.list[[merge.pair[1]]]), counts = FALSE ) object.2 <- DietSeurat( object = object.list[[merge.pair[2]]], assays = DefaultAssay(object = object.list[[merge.pair[2]]]), counts = FALSE ) # suppress key duplication warning suppressWarnings(object.1[["ToIntegrate"]] <- object.1[[DefaultAssay(object = object.1)]]) DefaultAssay(object = object.1) <- "ToIntegrate" object.1 <- DietSeurat(object = object.1, assays = "ToIntegrate") suppressWarnings(object.2[["ToIntegrate"]] <- object.2[[DefaultAssay(object = object.2)]]) DefaultAssay(object = object.2) <- "ToIntegrate" object.2 <- DietSeurat(object = object.2, assays = "ToIntegrate") datasets <- ParseMergePair(sample.tree, ii) if (verbose) { message( "Merging dataset ", paste(datasets$object2, collapse = " "), " into ", paste(datasets$object1, collapse = " ") ) } merged.obj <- merge(x = object.1, y = object.2, merge.data = TRUE) if (verbose) { message("Extracting anchors for merged samples") } filtered.anchors <- anchors[anchors$dataset1 %in% datasets$object1 & anchors$dataset2 %in% datasets$object2, ] integrated.matrix <- RunIntegration( filtered.anchors = filtered.anchors, normalization.method = normalization.method, reference = object.1, query = object.2, cellnames.list = cellnames.list, new.assay.name = new.assay.name, features.to.integrate = features.to.integrate, features = features, dims = dims, weight.reduction = weight.reduction, do.cpp = do.cpp, k.weight = k.weight, sd.weight = sd.weight, eps = eps, verbose = verbose ) integrated.matrix <- cbind(integrated.matrix, GetAssayData(object = object.1, slot = 'data')[features.to.integrate, ]) merged.obj[[new.assay.name]] <- CreateAssayObject(data = integrated.matrix) DefaultAssay(object = merged.obj) <- new.assay.name object.list[[as.character(x = ii)]] <- merged.obj object.list[[merge.pair[[1]]]] <- NULL object.list[[merge.pair[[2]]]] <- NULL invisible(x = CheckGC()) } integrated.data <- GetAssayData( object = object.list[[as.character(x = ii)]], assay = new.assay.name, slot = 'data' ) integrated.data <- integrated.data[, colnames(x = unintegrated)] new.assay <- new( Class = 'Assay', counts = new(Class = "dgCMatrix"), data = integrated.data, scale.data = matrix(), var.features = vector(), meta.features = data.frame(row.names = rownames(x = integrated.data)), misc = NULL ) unintegrated[[new.assay.name]] <- new.assay # "unintegrated" now contains the integrated assay DefaultAssay(object = unintegrated) <- new.assay.name VariableFeatures(object = unintegrated) <- features if (normalization.method == "SCT"){ unintegrated[[new.assay.name]] <- SetAssayData( object = unintegrated[[new.assay.name]], slot = "scale.data", new.data = as.matrix(x = GetAssayData(object = unintegrated[[new.assay.name]], slot = "data")) ) } unintegrated <- SetIntegrationData( object = unintegrated, integration.name = "Integration", slot = "anchors", new.data = anchors ) unintegrated <- SetIntegrationData( object = unintegrated, integration.name = "Integration", slot = "sample.tree", new.data = sample.tree ) unintegrated[["FindIntegrationAnchors"]] <- slot(object = anchorset, name = "command") unintegrated <- LogSeuratCommand(object = unintegrated) return(unintegrated) } # Parse merge information from dataset clustering # # @param clustering clustering dataframe from hclust ($merge). # Gives the order of merging datasets to get to the root of the tree. # @param i current row in clustering dataframe # ParseMergePair <- function(clustering, i){ # return 2-element list of datasets in first and second object datasets <- list('object1' = clustering[i, 1], 'object2' = clustering[i, 2]) if (datasets$object1 > 0) { datasets$object1 <- ParseRow(clustering, datasets$object1) } if (datasets$object2 > 0) { datasets$object2 <- ParseRow(clustering, datasets$object2) } datasets$object1 <- abs(x = datasets$object1) datasets$object2 <- abs(x = datasets$object2) return(datasets) } # Parse row of clustering order # # Used recursively to work out the dataset composition of a merged object # # @param clustering clustering dataframe from hclust ($merge). # Gives the order of merging datasets to get to the root of the tree. # @param i current row in clustering dataframe # ParseRow <- function(clustering, i){ # returns vector of datasets datasets <- as.list(x = clustering[i, ]) if (datasets[[1]] > 0) { datasets[[1]] <- ParseRow(clustering = clustering, i = datasets[[1]]) } if (datasets[[2]] > 0) { datasets[[2]] <- ParseRow(clustering = clustering, i = datasets[[2]]) } return(unlist(datasets)) } ProjectCellEmbeddings <- function( reference, query, reference.assay = NULL, query.assay = NULL, dims = 1:50, verbose = TRUE, feature.mean = NULL, feature.sd = NULL ) { if (verbose) { message("Projecting PCA") } reduction <- "pca" reference.assay <- reference.assay %||% DefaultAssay(object = reference) query.assay <- query.assay %||% DefaultAssay(object = query) features <- rownames(x = Loadings(object = reference[[reduction]])) features <- intersect(x = features, y = rownames(x = query[[query.assay]])) reference.data <- GetAssayData( object = reference, assay = reference.assay, slot = "data")[features, ] query.data <- GetAssayData( object = query, assay = query.assay, slot = "data")[features, ] if (is.null(x = feature.mean)) { feature.mean <- rowMeans(x = reference.data) feature.sd <- sqrt(SparseRowVar2(mat = reference.data, mu = feature.mean, display_progress = FALSE)) feature.sd[is.na(x = feature.sd)] <- 1 feature.mean[is.na(x = feature.mean)] <- 1 } proj.data <- GetAssayData( object = query, assay = query.assay, slot = "data" )[features, ] store.names <- dimnames(x = proj.data) if (is.numeric(x = feature.mean) && feature.mean != "SCT") { proj.data <- FastSparseRowScaleWithKnownStats( mat = proj.data, mu = feature.mean, sigma = feature.sd, display_progress = FALSE ) } dimnames(x = proj.data) <- store.names ref.feature.loadings <- Loadings(object = reference[[reduction]])[features, dims] proj.pca <- t(crossprod(x = ref.feature.loadings, y = proj.data)) return(proj.pca) } # Calculate position along a defined reference range for a given vector of # numerics. Will range from 0 to 1. # # @param x Vector of numeric type # @param lower Lower end of reference range # @param upper Upper end of reference range # #' @importFrom stats quantile # # @return Returns a vector that describes the position of each element in # x along the defined reference range # ReferenceRange <- function(x, lower = 0.025, upper = 0.975) { return((x - quantile(x = x, probs = lower)) / (quantile(x = x, probs = upper) - quantile(x = x, probs = lower))) } # Run integration between a reference and query object # # Should only be called from within another function # # @param filtered.anchors A dataframe containing only anchors between reference and query # @param reference A reference object # @param query A query object # @param cellnames.list List of all cell names in all objects to be integrated # @param new.assay.name Name for the new assay containing the integrated data # @param features Vector of features to use when computing the PCA to determine the weights. Only set # if you want a different set from those used in the anchor finding process # @param features.to.integrate Vector of features to integrate. By default, will use the features # used in anchor finding. # @param dims Number of PCs to use in the weighting procedure # @param k.weight Number of neighbors to consider when weighting # @param weight.reduction Dimension reduction to use when calculating anchor weights. # This can be either: # \itemize{ # \item{A string, specifying the name of a dimension reduction present in all objects to be integrated} # \item{A vector of strings, specifying the name of a dimension reduction to use for each object to be integrated} # \item{NULL, in which case a new PCA will be calculated and used to calculate anchor weights} # } # Note that, if specified, the requested dimension reduction will only be used for calculating anchor weights in the # first merge between reference and query, as the merged object will subsequently contain more cells than was in # query, and weights will need to be calculated for all cells in the object. # @param sd.weight Controls the bandwidth of the Gaussian kernel for weighting # @param sample.tree Specify the order of integration. If NULL, will compute automatically. # @param do.cpp Run cpp code where applicable # @param eps Error bound on the neighbor finding algorithm (from \code{\link{RANN}}) # @param verbose Print progress bars and output # RunIntegration <- function( filtered.anchors, normalization.method, reference, query, cellnames.list, new.assay.name, features.to.integrate, weight.reduction, features, dims, do.cpp, k.weight, sd.weight, eps, verbose ) { cells1 <- colnames(x = reference) cells2 <- colnames(x = query) merged.obj <- merge(x = reference, y = query, merge.data = TRUE) cell1.offset <- GetCellOffsets( anchors = filtered.anchors, dataset = 1, cell = 1, cellnames.list = cellnames.list, cellnames = cells1 ) cell2.offset <- GetCellOffsets( anchors = filtered.anchors, dataset = 2, cell = 2, cellnames.list = cellnames.list, cellnames = cells2 ) filtered.anchors[, 1] <- cell1.offset filtered.anchors[, 2] <- cell2.offset integration.name <- "integrated" merged.obj <- SetIntegrationData( object = merged.obj, integration.name = integration.name, slot = 'anchors', new.data = filtered.anchors ) merged.obj <- SetIntegrationData( object = merged.obj, integration.name = integration.name, slot = 'neighbors', new.data = list('cells1' = cells1, 'cells2' = cells2) ) merged.obj <- FindIntegrationMatrix( object = merged.obj, integration.name = integration.name, features.integrate = features.to.integrate, verbose = verbose ) assay <- DefaultAssay(object = merged.obj) if (is.null(x = weight.reduction)) { if (normalization.method == "SCT"){ # recenter residuals centered.resids <- ScaleData( object = GetAssayData(object = merged.obj, assay = assay, slot = "data"), do.scale = FALSE, do.center = TRUE, verbose = FALSE ) merged.obj[["pca"]] <- RunPCA( object = centered.resids[features, ], assay = assay, npcs = max(dims), verbose = FALSE, features = features ) } else { merged.obj <- ScaleData( object = merged.obj, features = features, verbose = FALSE ) merged.obj <- RunPCA( object = merged.obj, npcs = max(dims), verbose = FALSE, features = features ) } dr.weights <- merged.obj[['pca']] } else { dr <- weight.reduction[[2]] if (!all(cells2 %in% rownames(x = dr))) { stop("Query cells not present in supplied DimReduc object. Set weight.reduction to a DimReduc object containing the query cells.") } if (inherits(x = dr, what = "DimReduc")) { dr.weights <- dr } else { dr.weights <- query[[dr]] } } merged.obj <- FindWeights( object = merged.obj, integration.name = integration.name, reduction = dr.weights, cpp = do.cpp, dims = dims, k = k.weight, sd.weight = sd.weight, eps = eps, verbose = verbose ) merged.obj <- TransformDataMatrix( object = merged.obj, new.assay.name = new.assay.name, features.to.integrate = features.to.integrate, integration.name = integration.name, do.cpp = do.cpp, verbose = verbose ) integrated.matrix <- GetAssayData( object = merged.obj, assay = new.assay.name, slot = 'data' ) return(integrated.matrix[, cells2]) } ScoreAnchors <- function( object, assay = NULL, integration.name = 'integrated', verbose = TRUE, k.score = 30, do.cpp = TRUE ) { assay <- assay %||% DefaultAssay(object = object) anchor.df <- as.data.frame(x = GetIntegrationData(object = object, integration.name = integration.name, slot = 'anchors')) neighbors <- GetIntegrationData(object = object, integration.name = integration.name, slot = "neighbors") offset <- length(x = neighbors$cells1) anchor.df$cell2 <- anchor.df$cell2 + offset # make within dataset df if (verbose) { message("Extracting within-dataset neighbors") } total.cells <- offset + length(neighbors$cells2) nn.m1 <- ConstructNNMat(nn.idx = neighbors$nnaa$nn.idx[,1:k.score], offset1 = 0, offset2 = 0, dims = c(total.cells, total.cells)) nn.m2 <- ConstructNNMat(nn.idx = neighbors$nnab$nn.idx[,1:k.score], offset1 = 0, offset2 = offset, dims = c(total.cells, total.cells)) nn.m3 <- ConstructNNMat(nn.idx = neighbors$nnba$nn.idx[,1:k.score], offset1 = offset, offset2 = 0, dims = c(total.cells, total.cells)) nn.m4 <- ConstructNNMat(nn.idx = neighbors$nnbb$nn.idx[,1:k.score], offset1 = offset, offset2 = offset, dims = c(total.cells, total.cells)) k.matrix <- nn.m1 + nn.m2 + nn.m3 + nn.m4 anchor.only <- sparseMatrix(i = anchor.df[, 1], j = anchor.df[, 2], x = 1, dims = c(total.cells, total.cells)) if (do.cpp){ anchor.matrix <- SNNAnchor(k_matrix = k.matrix, anchor_only = anchor.only) } else { jaccard.dist <- tcrossprod(x = k.matrix) anchor.matrix <- jaccard.dist * anchor.only } anchor.matrix <- as(object = anchor.matrix, Class = "dgTMatrix") anchor.new <- data.frame( 'cell1' = anchor.matrix@i + 1, 'cell2' = anchor.matrix@j + 1, 'score' = anchor.matrix@x ) anchor.new$cell2 <- anchor.new$cell2 - offset max.score <- quantile(anchor.new$score, 0.9) min.score <- quantile(anchor.new$score, 0.01) anchor.new$score <- anchor.new$score - min.score anchor.new$score <- anchor.new$score / (max.score - min.score) anchor.new$score[anchor.new$score > 1] <- 1 anchor.new$score[anchor.new$score < 0] <- 0 anchor.new <- as.matrix(x = anchor.new) object <- SetIntegrationData( object = object, integration.name = integration.name, slot = 'anchors', new.data = anchor.new ) return(object) } # Get top n features across given set of dimensions # # @param object Seurat object # @param reduction Which dimension reduction to use # @param dims Which dimensions to use # @param features.per.dim How many features to consider per dimension # @param max.features Number of features to return at most # @param projected Use projected loadings # TopDimFeatures <- function( object, reduction, dims = 1:10, features.per.dim = 100, max.features = 200, projected = FALSE ) { dim.reduction <- object[[reduction]] max.features <- max(length(x = dims) * 2, max.features) num.features <- sapply(X = 1:features.per.dim, FUN = function(y) { length(x = unique(x = as.vector(x = sapply(X = dims, FUN = function(x) { unlist(x = TopFeatures(object = dim.reduction, dim = x, nfeatures = y, balanced = TRUE, projected = projected)) })))) }) max.per.pc <- which.max(x = num.features[num.features < max.features]) features <- unique(x = as.vector(x = sapply(X = dims, FUN = function(x) { unlist(x = TopFeatures(object = dim.reduction, dim = x, nfeatures = max.per.pc, balanced = TRUE, projected = projected)) }))) features <- unique(x = features) return(features) } TransformDataMatrix <- function( object, assay = NULL, new.assay.name = 'integrated', integration.name = 'integrated', features.to.integrate = NULL, reduction = "cca", do.cpp = TRUE, verbose = TRUE ) { if(verbose) { message("Integrating data") } assay <- assay %||% DefaultAssay(object = object) weights <- GetIntegrationData( object = object, integration.name = integration.name, slot = 'weights' ) integration.matrix <- GetIntegrationData( object = object, integration.name = integration.name, slot = 'integration.matrix' ) neighbors <- GetIntegrationData(object = object, integration.name = integration.name, slot = 'neighbors') nn.cells1 <- neighbors$cells1 nn.cells2 <- neighbors$cells2 data.use1 <- t(x = GetAssayData( object = object, assay = assay, slot = "data")[features.to.integrate, nn.cells1] ) data.use2 <- t(x = GetAssayData( object = object, assay = assay, slot = "data")[features.to.integrate, nn.cells2] ) if (do.cpp) { integrated <- IntegrateDataC(integration_matrix = as(integration.matrix, "dgCMatrix"), weights = as(weights, "dgCMatrix"), expression_cells2 = as(data.use2, "dgCMatrix")) dimnames(integrated) <- dimnames(data.use2) } else { bv <- t(weights) %*% integration.matrix integrated <- data.use2 - bv } new.expression <- t(rbind(data.use1, integrated)) new.expression <- new.expression[, colnames(object)] new.assay <- new( Class = 'Assay', counts = new(Class = "dgCMatrix"), data = new.expression, scale.data = matrix(), var.features = vector(), meta.features = data.frame(row.names = rownames(x = new.expression)), misc = NULL ) object[[new.assay.name]] <- new.assay return(object) } Seurat/R/dimensional_reduction.R0000644000176200001440000017620613617623374016447 0ustar liggesusers#' @include generics.R #' NULL #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Functions #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' Determine statistical significance of PCA scores. #' #' Randomly permutes a subset of data, and calculates projected PCA scores for #' these 'random' genes. Then compares the PCA scores for the 'random' genes #' with the observed PCA scores to determine statistical signifance. End result #' is a p-value for each gene's association with each principal component. #' #' @param object Seurat object #' @param reduction DimReduc to use. ONLY PCA CURRENTLY SUPPORTED. #' @param assay Assay used to calculate reduction. #' @param dims Number of PCs to compute significance for #' @param num.replicate Number of replicate samplings to perform #' @param prop.freq Proportion of the data to randomly permute for each #' replicate #' @param verbose Print progress bar showing the number of replicates #' that have been processed. #' @param maxit maximum number of iterations to be performed by the irlba function of RunPCA #' #' @return Returns a Seurat object where JS(object = object[['pca']], slot = 'empirical') #' represents p-values for each gene in the PCA analysis. If ProjectPCA is #' subsequently run, JS(object = object[['pca']], slot = 'full') then #' represents p-values for all genes. #' #' @importFrom methods new #' @importFrom pbapply pblapply pbsapply #' @importFrom future.apply future_lapply future_sapply #' @importFrom future nbrOfWorkers #' #' @references Inspired by Chung et al, Bioinformatics (2014) #' #' @export #' #' @examples #' \dontrun{ #' pbmc_small = suppressWarnings(JackStraw(pbmc_small)) #' head(JS(object = pbmc_small[['pca']], slot = 'empirical')) #' } #' JackStraw <- function( object, reduction = "pca", assay = NULL, dims = 20, num.replicate = 100, prop.freq = 0.01, verbose = TRUE, maxit = 1000 ) { if (reduction != "pca") { stop("Only pca for reduction is currently supported") } if (verbose && nbrOfWorkers() == 1) { my.lapply <- pblapply my.sapply <- pbsapply } else { my.lapply <- future_lapply my.sapply <- future_sapply } assay <- assay %||% DefaultAssay(object = object) if (dims > length(x = object[[reduction]])) { dims <- length(x = object[[reduction]]) warning("Number of dimensions specified is greater than those available. Setting dims to ", dims, " and continuing", immediate. = TRUE) } if (dims > nrow(x = object)) { dims <- nrow(x = object) warning("Number of dimensions specified is greater than the number of cells. Setting dims to ", dims, " and continuing", immediate. = TRUE) } loadings <- Loadings(object = object[[reduction]], projected = FALSE) reduc.features <- rownames(x = loadings) if (length(x = reduc.features) < 3) { stop("Too few features") } if (length(x = reduc.features) * prop.freq < 3) { warning( "Number of variable genes given ", prop.freq, " as the prop.freq is low. Consider including more variable genes and/or increasing prop.freq. ", "Continuing with 3 genes in every random sampling." ) } data.use <- GetAssayData(object = object, assay = assay, slot = "scale.data")[reduc.features, ] rev.pca <- object[[paste0('RunPCA.', assay)]]$rev.pca weight.by.var <- object[[paste0('RunPCA.', assay)]]$weight.by.var fake.vals.raw <- my.lapply( X = 1:num.replicate, FUN = JackRandom, scaled.data = data.use, prop.use = prop.freq, r1.use = 1, r2.use = dims, rev.pca = rev.pca, weight.by.var = weight.by.var, maxit = maxit ) fake.vals <- sapply( X = 1:dims, FUN = function(x) { return(as.numeric(x = unlist(x = lapply( X = 1:num.replicate, FUN = function(y) { return(fake.vals.raw[[y]][, x]) } )))) } ) fake.vals <- as.matrix(x = fake.vals) jackStraw.empP <- as.matrix( my.sapply( X = 1:dims, FUN = function(x) { return(unlist(x = lapply( X = abs(loadings[, x]), FUN = EmpiricalP, nullval = abs(fake.vals[,x]) ))) } ) ) colnames(x = jackStraw.empP) <- paste0("PC", 1:ncol(x = jackStraw.empP)) jackstraw.obj <- new( Class = "JackStrawData", empirical.p.values = jackStraw.empP, fake.reduction.scores = fake.vals, empirical.p.values.full = matrix() ) JS(object = object[[reduction]]) <- jackstraw.obj object <- LogSeuratCommand(object = object) return(object) } #' L2-normalization #' #' Perform l2 normalization on given dimensional reduction #' #' @param object Seurat object #' @param reduction Dimensional reduction to normalize #' @param new.dr name of new dimensional reduction to store #' (default is olddr.l2) #' @param new.key name of key for new dimensional reduction #' #' @return Returns a \code{\link{Seurat}} object #' #' @export #' L2Dim <- function(object, reduction, new.dr = NULL, new.key = NULL) { l2.norm <- L2Norm(mat = Embeddings(object[[reduction]])) if(is.null(new.dr)){ new.dr <- paste0(reduction, ".l2") } if(is.null(new.key)){ new.key <- paste0("L2", Key(object[[reduction]])) } colnames(x = l2.norm) <- paste0(new.key, 1:ncol(x = l2.norm)) l2.dr <- CreateDimReducObject( embeddings = l2.norm, loadings = Loadings(object = object[[reduction]], projected = FALSE), projected = Loadings(object = object[[reduction]], projected = TRUE), assay = DefaultAssay(object = object), stdev = slot(object = object[[reduction]], name = 'stdev'), key = new.key, jackstraw = slot(object = object[[reduction]], name = 'jackstraw'), misc = slot(object = object[[reduction]], name = 'misc') ) object[[new.dr]] <- l2.dr return(object) } #' L2-Normalize CCA #' #' Perform l2 normalization on CCs #' #' @param object Seurat object #' @param \dots Additional parameters to L2Dim. #' #' @export #' L2CCA <- function(object, ...){ CheckDots(..., fxns = 'L2Dim') return(L2Dim(object = object, reduction = "cca", ...)) } #' Significant genes from a PCA #' #' Returns a set of genes, based on the JackStraw analysis, that have #' statistically significant associations with a set of PCs. #' #' @param object Seurat object #' @param pcs.use PCS to use. #' @param pval.cut P-value cutoff #' @param use.full Use the full list of genes (from the projected PCA). Assumes #' that \code{ProjectDim} has been run. Currently, must be set to FALSE. #' @param max.per.pc Maximum number of genes to return per PC. Used to avoid genes from one PC dominating the entire analysis. #' #' @return A vector of genes whose p-values are statistically significant for #' at least one of the given PCs. #' #' @export #' #' @seealso \code{\link{ProjectDim}} \code{\link{JackStraw}} #' #' @examples #' PCASigGenes(pbmc_small, pcs.use = 1:2) #' PCASigGenes <- function( object, pcs.use, pval.cut = 0.1, use.full = FALSE, max.per.pc = NULL ) { # pvals.use <- GetDimReduction(object,reduction.type = "pca",slot = "jackstraw")@empirical.p.values empirical.use <- ifelse(test = use.full, yes = 'full', no = 'empirical') pvals.use <- JS(object = object[['pca']], slot = empirical.use) if (length(x = pcs.use) == 1) { pvals.min <- pvals.use[, pcs.use] } if (length(x = pcs.use) > 1) { pvals.min <- apply(X = pvals.use[, pcs.use], MARGIN = 1, FUN = min) } names(x = pvals.min) <- rownames(x = pvals.use) features <- names(x = pvals.min)[pvals.min < pval.cut] if (!is.null(x = max.per.pc)) { top.features <- TopFeatures( object = object[['pca']], dim = pcs.use, nfeatures = max.per.pc, projected = use.full, balanced = FALSE ) features <- intersect(x = top.features, y = features) } return(features) } #' Project Dimensional reduction onto full dataset #' #' Takes a pre-computed dimensional reduction (typically calculated on a subset #' of genes) and projects this onto the entire dataset (all genes). Note that #' the cell loadings will remain unchanged, but now there are gene loadings for #' all genes. #' #' @param object Seurat object #' @param reduction Reduction to use #' @param assay Assay to use #' @param dims.print Number of dims to print features for #' @param nfeatures.print Number of features with highest/lowest loadings to print for #' each dimension #' @param overwrite Replace the existing data in feature.loadings #' @param do.center Center the dataset prior to projection (should be set to TRUE) #' @param verbose Print top genes associated with the projected dimensions #' #' @return Returns Seurat object with the projected values #' #' @export #' #' @examples #' pbmc_small #' pbmc_small <- ProjectDim(object = pbmc_small, reduction = "pca") #' # Vizualize top projected genes in heatmap #' DimHeatmap(object = pbmc_small, reduction = "pca", dims = 1, balanced = TRUE) #' ProjectDim <- function( object, reduction = "pca", assay = NULL, dims.print = 1:5, nfeatures.print = 20, overwrite = FALSE, do.center = FALSE, verbose = TRUE ) { redeuc <- object[[reduction]] assay <- assay %||% DefaultAssay(object = redeuc) data.use <- GetAssayData( object = object[[assay]], slot = "scale.data" ) if (do.center) { data.use <- scale(x = as.matrix(x = data.use), center = TRUE, scale = FALSE) } cell.embeddings <- Embeddings(object = redeuc) new.feature.loadings.full <- data.use %*% cell.embeddings rownames(x = new.feature.loadings.full) <- rownames(x = data.use) colnames(x = new.feature.loadings.full) <- colnames(x = cell.embeddings) Loadings(object = redeuc, projected = TRUE) <- new.feature.loadings.full if (overwrite) { Loadings(object = redeuc, projected = FALSE) <- new.feature.loadings.full } object[[reduction]] <- redeuc if (verbose) { print( x = redeuc, dims = dims.print, nfeatures = nfeatures.print, projected = TRUE ) } object <- LogSeuratCommand(object = object) return(object) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Methods for Seurat-defined generics #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' @param standardize Standardize matrices - scales columns to have unit variance #' and mean 0 #' @param num.cc Number of canonical vectors to calculate #' @param seed.use Random seed to set. If NULL, does not set a seed #' @param verbose Show progress messages #' #' @importFrom irlba irlba #' #' @rdname RunCCA #' @export #' RunCCA.default <- function( object1, object2, standardize = TRUE, num.cc = 20, seed.use = 42, verbose = FALSE, ... ) { if (!is.null(x = seed.use)) { set.seed(seed = seed.use) } cells1 <- colnames(x = object1) cells2 <- colnames(x = object2) if (standardize) { object1 <- Standardize(mat = object1, display_progress = FALSE) object2 <- Standardize(mat = object2, display_progress = FALSE) } mat3 <- crossprod(x = object1, y = object2) cca.svd <- irlba(A = mat3, nv = num.cc) cca.data <- rbind(cca.svd$u, cca.svd$v) colnames(x = cca.data) <- paste0("CC", 1:num.cc) rownames(cca.data) <- c(cells1, cells2) cca.data <- apply( X = cca.data, MARGIN = 2, FUN = function(x) { if (sign(x[1]) == -1) { x <- x * -1 } return(x) } ) return(list(ccv = cca.data, d = cca.svd$d)) } #' @param assay1,assay2 Assays to pull from in the first and second objects, respectively #' @param features Set of genes to use in CCA. Default is the union of both #' the variable features sets present in both objects. #' @param renormalize Renormalize raw data after merging the objects. If FALSE, #' merge the data matrices also. #' @param rescale Rescale the datasets prior to CCA. If FALSE, uses existing data in the scale data slots. #' @param compute.gene.loadings Also compute the gene loadings. NOTE - this will #' scale every gene in the dataset which may impose a high memory cost. #' @param add.cell.id1,add.cell.id2 Add ... #' @param ... Extra parameters (passed onto MergeSeurat in case with two objects #' passed, passed onto ScaleData in case with single object and rescale.groups #' set to TRUE) #' #' @rdname RunCCA #' @export #' @method RunCCA Seurat #' RunCCA.Seurat <- function( object1, object2, assay1 = NULL, assay2 = NULL, num.cc = 20, features = NULL, renormalize = FALSE, rescale = FALSE, compute.gene.loadings = TRUE, add.cell.id1 = NULL, add.cell.id2 = NULL, verbose = TRUE, ... ) { assay1 <- assay1 %||% DefaultAssay(object = object1) assay2 <- assay2 %||% DefaultAssay(object = object2) if (assay1 != assay2) { warning("Running CCA on different assays") } if (is.null(x = features)) { if (length(x = VariableFeatures(object = object1, assay = assay1)) == 0) { stop(paste0("VariableFeatures not computed for the ", assay1, " assay in object1")) } if (length(x = VariableFeatures(object = object2, assay = assay2)) == 0) { stop(paste0("VariableFeatures not computed for the ", assay2, " assay in object2")) } features <- union(x = VariableFeatures(object = object1), y = VariableFeatures(object = object2)) if (length(x = features) == 0) { stop("Zero features in the union of the VariableFeature sets ") } } nfeatures <- length(x = features) if (!(rescale)) { data.use1 <- GetAssayData(object = object1, assay = assay1, slot = "scale.data") data.use2 <- GetAssayData(object = object2, assay = assay2, slot = "scale.data") features <- CheckFeatures(data.use = data.use1, features = features, object.name = "object1", verbose = FALSE) features <- CheckFeatures(data.use = data.use2, features = features, object.name = "object2", verbose = FALSE) data1 <- data.use1[features, ] data2 <- data.use2[features, ] } if (rescale) { data.use1 <- GetAssayData(object = object1, assay = assay1, slot = "data") data.use2 <- GetAssayData(object = object2, assay = assay2, slot = "data") features <- CheckFeatures(data.use = data.use1, features = features, object.name = "object1", verbose = FALSE) features <- CheckFeatures(data.use = data.use2, features = features, object.name = "object2", verbose = FALSE) data1 <- data.use1[features,] data2 <- data.use2[features,] if (verbose) message("Rescaling groups") data1 <- FastRowScale(as.matrix(data1)) dimnames(data1) <- list(features, colnames(x = object1)) data2 <- FastRowScale(as.matrix(data2)) dimnames(data2) <- list(features, colnames(x = object2)) } if (length(x = features) / nfeatures < 0.1 & verbose) { warning("More than 10% of provided features filtered out. Please check that the given features are present in the scale.data slot for both the assays provided here and that they have non-zero variance.") } if (length(x = features) < 50) { warning("Fewer than 50 features used as input for CCA.") } if (verbose) { message("Running CCA") } cca.results <- RunCCA( object1 = data1, object2 = data2, standardize = TRUE, num.cc = num.cc, verbose = verbose, ) if (verbose) { message("Merging objects") } combined.object <- merge( x = object1, y = object2, merge.data = TRUE, ... ) combined.object[['cca']] <- CreateDimReducObject( embeddings = cca.results$ccv[colnames(combined.object), ], assay = assay1, key = "CC_" ) combined.object[['cca']]@assay.used <- DefaultAssay(combined.object) if (ncol(combined.object) != (ncol(object1) + ncol(object2))) { warning("Some cells removed after object merge due to minimum feature count cutoff") } combined.scale <- cbind(data1,data2) combined.object <- SetAssayData(object = combined.object,new.data = combined.scale, slot = "scale.data") if (renormalize) { combined.object <- NormalizeData( object = combined.object, assay = assay1, normalization.method = object1[[paste0("NormalizeData.", assay1)]]$normalization.method, scale.factor = object1[[paste0("NormalizeData.", assay1)]]$scale.factor ) } if (compute.gene.loadings) { combined.object <- ProjectDim( object = combined.object, reduction = "cca", verbose = FALSE, overwrite = TRUE) } return(combined.object) } #' @param assay Name of Assay ICA is being run on #' @param nics Number of ICs to compute #' @param rev.ica By default, computes the dimensional reduction on the cell x #' feature matrix. Setting to true will compute it on the transpose (feature x cell #' matrix). #' @param ica.function ICA function from ica package to run (options: icafast, #' icaimax, icajade) #' @param verbose Print the top genes associated with high/low loadings for #' the ICs #' @param ndims.print ICs to print genes for #' @param nfeatures.print Number of genes to print for each IC #' @param reduction.key dimensional reduction key, specifies the string before #' the number for the dimension names. #' @param seed.use Set a random seed. Setting NULL will not set a seed. #' @param \dots Additional arguments to be passed to fastica #' #' @importFrom ica icafast icaimax icajade #' #' @rdname RunICA #' @export #' @method RunICA default #' RunICA.default <- function( object, assay = NULL, nics = 50, rev.ica = FALSE, ica.function = "icafast", verbose = TRUE, ndims.print = 1:5, nfeatures.print = 30, reduction.name = "ica", reduction.key = "ica_", seed.use = 42, ... ) { CheckDots(..., fxns = ica.function) if (!is.null(x = seed.use)) { set.seed(seed = seed.use) } nics <- min(nics, ncol(x = object)) ica.fxn <- eval(expr = parse(text = ica.function)) if (rev.ica) { ica.results <- ica.fxn(object, nc = nics,...) cell.embeddings <- ica.results$M } else { ica.results <- ica.fxn(t(x = object), nc = nics,...) cell.embeddings <- ica.results$S } feature.loadings <- (as.matrix(x = object ) %*% as.matrix(x = cell.embeddings)) colnames(x = feature.loadings) <- paste0(reduction.key, 1:ncol(x = feature.loadings)) colnames(x = cell.embeddings) <- paste0(reduction.key, 1:ncol(x = cell.embeddings)) reduction.data <- CreateDimReducObject( embeddings = cell.embeddings, loadings = feature.loadings, assay = assay, key = reduction.key ) if (verbose) { print(x = reduction.data, dims = ndims.print, nfeatures = nfeatures.print) } return(reduction.data) } #' @param features Features to compute ICA on #' #' @rdname RunICA #' @export #' @method RunICA Assay #' RunICA.Assay <- function( object, assay = NULL, features = NULL, nics = 50, rev.ica = FALSE, ica.function = "icafast", verbose = TRUE, ndims.print = 1:5, nfeatures.print = 30, reduction.name = "ica", reduction.key = "ica_", seed.use = 42, ... ) { data.use <- PrepDR( object = object, features = features, verbose = verbose ) reduction.data <- RunICA( object = data.use, assay = assay, nics = nics, rev.ica = rev.ica, ica.function = ica.function, verbose = verbose, ndims.print = ndims.print, nfeatures.print = nfeatures.print, reduction.key = reduction.key, seed.use = seed.use, ... ) return(reduction.data) } #' @param reduction.name dimensional reduction name #' #' @rdname RunICA #' @method RunICA Seurat #' @export #' RunICA.Seurat <- function( object, assay = NULL, features = NULL, nics = 50, rev.ica = FALSE, ica.function = "icafast", verbose = TRUE, ndims.print = 1:5, nfeatures.print = 30, reduction.name = "ica", reduction.key = "IC_", seed.use = 42, ... ) { assay <- assay %||% DefaultAssay(object = object) assay.data <- GetAssay(object = object, assay = assay) reduction.data <- RunICA( object = assay.data, assay = assay, features = features, nics = nics, rev.ica = rev.ica, ica.function = ica.function, verbose = verbose, ndims.print = ndims.print, nfeatures.print = nfeatures.print, reduction.key = reduction.key, seed.use = seed.use, ... ) object[[reduction.name]] <- reduction.data object <- LogSeuratCommand(object = object) return(object) } #' @param assay Which assay to use. If NULL, use the default assay #' @param n Number of singular values to compute #' @param reduction.key Key for dimension reduction object #' @param scale.max Clipping value for cell embeddings. Default (NULL) is no clipping. #' @param seed.use Set a random seed. By default, sets the seed to 42. Setting #' NULL will not set a seed. #' @param verbose Print messages #' #' @importFrom irlba irlba #' #' @rdname RunLSI #' @export RunLSI.default <- function( object, assay = NULL, n = 50, reduction.key = 'LSI_', scale.max = NULL, seed.use = 42, verbose = TRUE, ... ) { CheckDots(...) if (!is.null(seed.use)) { set.seed(seed = seed.use) } tf.idf <- TF.IDF(data = object, verbose = verbose) tf.idf <- LogNorm(data = tf.idf, display_progress = verbose, scale_factor = 1e4) colnames(x = tf.idf) <- colnames(x = object) rownames(x = tf.idf) <- rownames(x = object) n <- min(n, ncol(x = object) - 1) if (verbose) { message("Running SVD on TF-IDF matrix") } lsi <- irlba(A = t(tf.idf), nv = n) feature.loadings <- lsi$v sdev <- lsi$d / sqrt(max(1, nrow(x = object) - 1)) cell.embeddings <- lsi$u if (verbose) { message('Scaling cell embeddings') } embed.mean <- apply(X = cell.embeddings, MARGIN = 1, FUN = mean) embed.sd <- apply(X = cell.embeddings, MARGIN = 1, FUN = sd) norm.embeddings <- (cell.embeddings - embed.mean) / embed.sd if (!is.null(x = scale.max)) { norm.embeddings[norm.embeddings > scale.max] <- scale.max norm.embeddings[norm.embeddings < -scale.max] <- -scale.max } rownames(x = feature.loadings) <- rownames(x = object) colnames(x = feature.loadings) <- paste0(reduction.key, 1:n) rownames(x = norm.embeddings) <- colnames(x = object) colnames(x = norm.embeddings) <- paste0(reduction.key, 1:n) reduction.data <- CreateDimReducObject( embeddings = norm.embeddings, loadings = feature.loadings, assay = assay, stdev = sdev, key = reduction.key ) return(reduction.data) } #' @param features Which features to use. If NULL, use variable features #' #' @rdname RunLSI #' @export #' @method RunLSI Assay RunLSI.Assay <- function( object, assay = NULL, features = NULL, n = 50, reduction.key = 'LSI_', scale.max = NULL, verbose = TRUE, ... ) { features <- features %||% VariableFeatures(object) data.use <- GetAssayData( object = object, slot = 'counts' )[features, ] reduction.data <- RunLSI( object = data.use, assay = assay, n = n, reduction.key = reduction.key, scale.max = scale.max, verbose = verbose, ... ) return(reduction.data) } #' @param reduction.name Name for stored dimension reduction object. Default 'lsi' #' @examples #' lsi <- RunLSI(object = pbmc_small, n = 5) #' #' @rdname RunLSI #' #' @export #' @method RunLSI Seurat RunLSI.Seurat <- function( object, assay = NULL, features = NULL, n = 50, reduction.key = 'LSI_', reduction.name = 'lsi', scale.max = NULL, verbose = TRUE, ... ) { assay <- assay %||% DefaultAssay(object) assay.data <- GetAssay(object = object, assay = assay) reduction.data <- RunLSI( object = assay.data, assay = assay, features = features, n = n, reduction.key = reduction.key, scale.max = scale.max, verbose = verbose, ... ) object[[reduction.name]] <- reduction.data object <- LogSeuratCommand(object = object) return(object) } #' @param assay Name of Assay PCA is being run on #' @param npcs Total Number of PCs to compute and store (50 by default) #' @param rev.pca By default computes the PCA on the cell x gene matrix. Setting #' to true will compute it on gene x cell matrix. #' @param weight.by.var Weight the cell embeddings by the variance of each PC #' (weights the gene loadings if rev.pca is TRUE) #' @param verbose Print the top genes associated with high/low loadings for #' the PCs #' @param ndims.print PCs to print genes for #' @param nfeatures.print Number of genes to print for each PC #' @param reduction.key dimensional reduction key, specifies the string before #' the number for the dimension names. PC by default #' @param seed.use Set a random seed. By default, sets the seed to 42. Setting #' NULL will not set a seed. #' @param approx Use truncated singular value decomposition to approximate PCA #' #' @importFrom irlba irlba #' @importFrom stats prcomp #' @importFrom utils capture.output #' #' @rdname RunPCA #' @export #' RunPCA.default <- function( object, assay = NULL, npcs = 50, rev.pca = FALSE, weight.by.var = TRUE, verbose = TRUE, ndims.print = 1:5, nfeatures.print = 30, reduction.key = "PC_", seed.use = 42, approx = TRUE, ... ) { if (!is.null(x = seed.use)) { set.seed(seed = seed.use) } if (rev.pca) { npcs <- min(npcs, ncol(x = object) - 1) pca.results <- irlba(A = object, nv = npcs, ...) total.variance <- sum(RowVar(x = t(x = object))) sdev <- pca.results$d/sqrt(max(1, nrow(x = object) - 1)) if (weight.by.var) { feature.loadings <- pca.results$u %*% diag(pca.results$d) } else{ feature.loadings <- pca.results$u } cell.embeddings <- pca.results$v } else { total.variance <- sum(RowVar(x = object)) if (approx) { npcs <- min(npcs, nrow(x = object) - 1) pca.results <- irlba(A = t(x = object), nv = npcs, ...) feature.loadings <- pca.results$v sdev <- pca.results$d/sqrt(max(1, ncol(object) - 1)) if (weight.by.var) { cell.embeddings <- pca.results$u %*% diag(pca.results$d) } else { cell.embeddings <- pca.results$u } } else { npcs <- min(npcs, nrow(x = object)) pca.results <- prcomp(x = t(object), rank. = npcs, ...) feature.loadings <- pca.results$rotation sdev <- pca.results$sdev if (weight.by.var) { cell.embeddings <- pca.results$x %*% diag(pca.results$sdev[1:npcs]^2) } else { cell.embeddings <- pca.results$x } } } rownames(x = feature.loadings) <- rownames(x = object) colnames(x = feature.loadings) <- paste0(reduction.key, 1:npcs) rownames(x = cell.embeddings) <- colnames(x = object) colnames(x = cell.embeddings) <- colnames(x = feature.loadings) reduction.data <- CreateDimReducObject( embeddings = cell.embeddings, loadings = feature.loadings, assay = assay, stdev = sdev, key = reduction.key, misc = list(total.variance = total.variance) ) if (verbose) { msg <- capture.output(print( x = reduction.data, dims = ndims.print, nfeatures = nfeatures.print )) message(paste(msg, collapse = '\n')) } return(reduction.data) } #' @param features Features to compute PCA on. If features=NULL, PCA will be run #' using the variable features for the Assay. Note that the features must be present #' in the scaled data. Any requested features that are not scaled or have 0 variance #' will be dropped, and the PCA will be run using the remaining features. #' #' @rdname RunPCA #' @export #' @method RunPCA Assay #' RunPCA.Assay <- function( object, assay = NULL, features = NULL, npcs = 50, rev.pca = FALSE, weight.by.var = TRUE, verbose = TRUE, ndims.print = 1:5, nfeatures.print = 30, reduction.key = "PC_", seed.use = 42, ... ) { data.use <- PrepDR( object = object, features = features, verbose = verbose ) reduction.data <- RunPCA( object = data.use, assay = assay, npcs = npcs, rev.pca = rev.pca, weight.by.var = weight.by.var, verbose = verbose, ndims.print = ndims.print, nfeatures.print = nfeatures.print, reduction.key = reduction.key, seed.use = seed.use, ... ) return(reduction.data) } #' @param reduction.name dimensional reduction name, pca by default #' #' @rdname RunPCA #' @export #' @method RunPCA Seurat #' RunPCA.Seurat <- function( object, assay = NULL, features = NULL, npcs = 50, rev.pca = FALSE, weight.by.var = TRUE, verbose = TRUE, ndims.print = 1:5, nfeatures.print = 30, reduction.name = "pca", reduction.key = "PC_", seed.use = 42, ... ) { assay <- assay %||% DefaultAssay(object = object) assay.data <- GetAssay(object = object, assay = assay) reduction.data <- RunPCA( object = assay.data, assay = assay, features = features, npcs = npcs, rev.pca = rev.pca, weight.by.var = weight.by.var, verbose = verbose, ndims.print = ndims.print, nfeatures.print = nfeatures.print, reduction.key = reduction.key, seed.use = seed.use, ... ) object[[reduction.name]] <- reduction.data object <- LogSeuratCommand(object = object) return(object) } #' @param assay Name of assay that that t-SNE is being run on #' @param seed.use Random seed for the t-SNE. If NULL, does not set the seed #' @param tsne.method Select the method to use to compute the tSNE. Available #' methods are: #' \itemize{ #' \item{Rtsne: }{Use the Rtsne package Barnes-Hut implementation of tSNE (default)} # \item{tsne: }{standard tsne - not recommended for large datasets} #' \item{FIt-SNE: }{Use the FFT-accelerated Interpolation-based t-SNE. Based on #' Kluger Lab code found here: https://github.com/KlugerLab/FIt-SNE} #' } #' @param add.iter If an existing tSNE has already been computed, uses the #' current tSNE to seed the algorithm and then adds additional iterations on top #' of this #' @param dim.embed The dimensional space of the resulting tSNE embedding #' (default is 2). For example, set to 3 for a 3d tSNE #' @param reduction.key dimensional reduction key, specifies the string before the number for the dimension names. tSNE_ by default #' #' @importFrom tsne tsne #' @importFrom Rtsne Rtsne #' #' @rdname RunTSNE #' @export #' @method RunTSNE matrix #' RunTSNE.matrix <- function( object, assay = NULL, seed.use = 1, tsne.method = "Rtsne", add.iter = 0, dim.embed = 2, reduction.key = "tSNE_", ... ) { if (!is.null(x = seed.use)) { set.seed(seed = seed.use) } tsne.data <- switch( EXPR = tsne.method, 'Rtsne' = Rtsne( X = object, dims = dim.embed, ... # PCA/is_distance )$Y, 'FIt-SNE' = fftRtsne(X = object, dims = dim.embed, rand_seed = seed.use, ...), stop("Invalid tSNE method: please choose from 'Rtsne' or 'FIt-SNE'") ) if (add.iter > 0) { tsne.data <- tsne( X = object, initial_config = as.matrix(x = tsne.data), max_iter = add.iter, ... ) } colnames(x = tsne.data) <- paste0(reduction.key, 1:ncol(x = tsne.data)) rownames(x = tsne.data) <- rownames(x = object) tsne.reduction <- CreateDimReducObject( embeddings = tsne.data, key = reduction.key, assay = assay, global = TRUE ) return(tsne.reduction) } #' @param cells Which cells to analyze (default, all cells) #' @param dims Which dimensions to use as input features #' #' @rdname RunTSNE #' @export #' @method RunTSNE DimReduc #' RunTSNE.DimReduc <- function( object, cells = NULL, dims = 1:5, seed.use = 1, tsne.method = "Rtsne", add.iter = 0, dim.embed = 2, reduction.key = "tSNE_", ... ) { args <- as.list(x = sys.frame(which = sys.nframe())) args <- c(args, list(...)) args$object <- args$object[[cells, args$dims]] args$dims <- NULL args$cells <- NULL args$assay <- DefaultAssay(object = object) return(do.call(what = 'RunTSNE', args = args)) } #' @rdname RunTSNE #' @export #' @method RunTSNE dist #' RunTSNE.dist <- function( object, assay = NULL, seed.use = 1, tsne.method = "Rtsne", add.iter = 0, dim.embed = 2, reduction.key = "tSNE_", ... ) { args <- as.list(x = sys.frame(which = sys.nframe())) args <- c(args, list(...)) args$object <- as.matrix(x = args$object) args$is_distance <- TRUE return(do.call(what = 'RunTSNE', args = args)) } #' @param reduction Which dimensional reduction (e.g. PCA, ICA) to use for #' the tSNE. Default is PCA #' @param features If set, run the tSNE on this subset of features #' (instead of running on a set of reduced dimensions). Not set (NULL) by default; #' \code{dims} must be NULL to run on features #' @param distance.matrix If set, runs tSNE on the given distance matrix #' instead of data matrix (experimental) #' @param reduction.name dimensional reduction name, specifies the position in the object$dr list. tsne by default #' #' @rdname RunTSNE #' @export #' @method RunTSNE Seurat #' RunTSNE.Seurat <- function( object, reduction = "pca", cells = NULL, dims = 1:5, features = NULL, seed.use = 1, tsne.method = "Rtsne", add.iter = 0, dim.embed = 2, distance.matrix = NULL, reduction.name = "tsne", reduction.key = "tSNE_", ... ) { cells <- cells %||% Cells(x = object) tsne.reduction <- if (!is.null(x = distance.matrix)) { RunTSNE( object = distance.matrix, assay = DefaultAssay(object = object), seed.use = seed.use, tsne.method = tsne.method, add.iter = add.iter, dim.embed = dim.embed, reduction.key = reduction.key, is_distance = TRUE, ... ) } else if (!is.null(x = dims)) { RunTSNE( object = object[[reduction]], cells = cells, dims = dims, seed.use = seed.use, tsne.method = tsne.method, add.iter = add.iter, dim.embed = dim.embed, reduction.key = reduction.key, pca = FALSE, ... ) } else if (!is.null(x = features)) { RunTSNE( object = t(x = as.matrix(x = GetAssayData(object = object)[features, cells])), assay = DefaultAssay(object = object), seed.use = seed.use, tsne.method = tsne.method, add.iter = add.iter, dim.embed = dim.embed, reduction.key = reduction.key, pca = FALSE, ... ) } else { stop("Unknown way of running tSNE") } object[[reduction.name]] <- tsne.reduction object <- LogSeuratCommand(object = object) return(object) } #' @importFrom reticulate py_module_available py_set_seed import #' @importFrom uwot umap #' @importFrom future nbrOfWorkers #' #' @rdname RunUMAP #' @method RunUMAP default #' @export #' RunUMAP.default <- function( object, assay = NULL, umap.method = 'uwot', n.neighbors = 30L, n.components = 2L, metric = 'cosine', n.epochs = NULL, learning.rate = 1.0, min.dist = 0.3, spread = 1.0, set.op.mix.ratio = 1.0, local.connectivity = 1L, repulsion.strength = 1, negative.sample.rate = 5, a = NULL, b = NULL, uwot.sgd = FALSE, seed.use = 42, metric.kwds = NULL, angular.rp.forest = FALSE, reduction.key = 'UMAP_', verbose = TRUE, ... ) { CheckDots(...) if (!is.null(x = seed.use)) { set.seed(seed = seed.use) } if (umap.method != 'umap-learn' && getOption('Seurat.warn.umap.uwot', TRUE)) { warning( "The default method for RunUMAP has changed from calling Python UMAP via reticulate to the R-native UWOT using the cosine metric", "\nTo use Python UMAP via reticulate, set umap.method to 'umap-learn' and metric to 'correlation'", "\nThis message will be shown once per session", call. = FALSE, immediate. = TRUE ) options(Seurat.warn.umap.uwot = FALSE) } umap.output <- switch( EXPR = umap.method, 'umap-learn' = { if (!py_module_available(module = 'umap')) { stop("Cannot find UMAP, please install through pip (e.g. pip install umap-learn).") } if (!is.null(x = seed.use)) { py_set_seed(seed = seed.use) } if (typeof(x = n.epochs) == "double") { n.epochs <- as.integer(x = n.epochs) } umap_import <- import(module = "umap", delay_load = TRUE) umap <- umap_import$UMAP( n_neighbors = as.integer(x = n.neighbors), n_components = as.integer(x = n.components), metric = metric, n_epochs = n.epochs, learning_rate = learning.rate, min_dist = min.dist, spread = spread, set_op_mix_ratio = set.op.mix.ratio, local_connectivity = local.connectivity, repulsion_strength = repulsion.strength, negative_sample_rate = negative.sample.rate, a = a, b = b, metric_kwds = metric.kwds, angular_rp_forest = angular.rp.forest, verbose = verbose ) umap$fit_transform(as.matrix(x = object)) }, 'uwot' = { if (metric == 'correlation') { warning( "UWOT does not implement the correlation metric, using cosine instead", call. = FALSE, immediate. = TRUE ) metric <- 'cosine' } umap( X = object, n_threads = nbrOfWorkers(), n_neighbors = as.integer(x = n.neighbors), n_components = as.integer(x = n.components), metric = metric, n_epochs = n.epochs, learning_rate = learning.rate, min_dist = min.dist, spread = spread, set_op_mix_ratio = set.op.mix.ratio, local_connectivity = local.connectivity, repulsion_strength = repulsion.strength, negative_sample_rate = negative.sample.rate, a = a, b = b, fast_sgd = uwot.sgd, verbose = verbose ) }, stop("Unknown umap method: ", umap.method, call. = FALSE) ) colnames(x = umap.output) <- paste0(reduction.key, 1:ncol(x = umap.output)) if (inherits(x = object, what = 'dist')) { rownames(x = umap.output) <- attr(x = object, "Labels") } else { rownames(x = umap.output) <- rownames(x = object) } umap.reduction <- CreateDimReducObject( embeddings = umap.output, key = reduction.key, assay = assay, global = TRUE ) return(umap.reduction) } #' @importFrom reticulate py_module_available import #' #' @rdname RunUMAP #' @method RunUMAP Graph #' @export #' RunUMAP.Graph <- function( object, assay = NULL, umap.method = 'umap-learn', n.components = 2L, metric = 'correlation', n.epochs = 0L, learning.rate = 1, min.dist = 0.3, spread = 1, repulsion.strength = 1, negative.sample.rate = 5L, a = NULL, b = NULL, uwot.sgd = FALSE, seed.use = 42L, metric.kwds = NULL, verbose = TRUE, reduction.key = 'UMAP_', ... ) { CheckDots(...) if (umap.method != 'umap-learn') { warning( "Running UMAP on Graph objects is only supported using the umap-learn method", call. = FALSE, immediate. = TRUE ) } if (!py_module_available(module = 'umap')) { stop("Cannot find UMAP, please install through pip (e.g. pip install umap-learn).") } if (!py_module_available(module = 'numpy')) { stop("Cannot find numpy, please install through pip (e.g. pip install numpy).") } if (!py_module_available(module = 'sklearn')) { stop("Cannot find sklearn, please install through pip (e.g. pip install scikit-learn).") } if (!py_module_available(module = 'scipy')) { stop("Cannot find scipy, please install through pip (e.g. pip install scipy).") } np <- import("numpy", delay_load = TRUE) sp <- import("scipy", delay_load = TRUE) sklearn <- import("sklearn", delay_load = TRUE) umap <- import("umap", delay_load = TRUE) diag(x = object) <- 0 data <- object object <- sp$sparse$coo_matrix(arg1 = object) ab.params <- umap$umap_$find_ab_params(spread = spread, min_dist = min.dist) a <- a %||% ab.params[[1]] b <- b %||% ab.params[[2]] n.epochs <- n.epochs %||% 0L random.state <- sklearn$utils$check_random_state(seed = as.integer(x = seed.use)) embeddings <- umap$umap_$simplicial_set_embedding( data = data, graph = object, n_components = n.components, initial_alpha = learning.rate, a = a, b = b, gamma = repulsion.strength, negative_sample_rate = negative.sample.rate, n_epochs = as.integer(x = n.epochs), random_state = random.state, init = "spectral", metric = metric, metric_kwds = metric.kwds, verbose = verbose ) rownames(x = embeddings) <- colnames(x = data) colnames(x = embeddings) <- paste0("UMAP_", 1:n.components) # center the embeddings on zero embeddings <- scale(x = embeddings, scale = FALSE) umap <- CreateDimReducObject( embeddings = embeddings, key = reduction.key, assay = assay, global = TRUE ) return(umap) } #' @param dims Which dimensions to use as input features, used only if #' \code{features} is NULL #' @param reduction Which dimensional reduction (PCA or ICA) to use for the #' UMAP input. Default is PCA #' @param features If set, run UMAP on this subset of features (instead of running on a #' set of reduced dimensions). Not set (NULL) by default; \code{dims} must be NULL to run #' on features #' @param graph Name of graph on which to run UMAP #' @param assay Assay to pull data for when using \code{features}, or assay used to construct Graph #' if running UMAP on a Graph #' @param umap.method UMAP implementation to run. Can be #' \describe{ #' \item{\code{uwot}:}{Runs umap via the uwot R package} #' \item{\code{umap-learn}:}{Run the Seurat wrapper of the python umap-learn package} #' } #' @param n.neighbors This determines the number of neighboring points used in #' local approximations of manifold structure. Larger values will result in more #' global structure being preserved at the loss of detailed local structure. In #' general this parameter should often be in the range 5 to 50. #' @param n.components The dimension of the space to embed into. #' @param metric metric: This determines the choice of metric used to measure #' distance in the input space. A wide variety of metrics are already coded, and #' a user defined function can be passed as long as it has been JITd by numba. #' @param n.epochs he number of training epochs to be used in optimizing the low dimensional #' embedding. Larger values result in more accurate embeddings. If NULL is specified, a value will #' be selected based on the size of the input dataset (200 for large datasets, 500 for small). #' @param learning.rate The initial learning rate for the embedding optimization. #' @param min.dist This controls how tightly the embedding is allowed compress points together. #' Larger values ensure embedded points are moreevenly distributed, while smaller values allow the #' algorithm to optimise more accurately with regard to local structure. Sensible values are in #' the range 0.001 to 0.5. #' @param spread The effective scale of embedded points. In combination with min.dist this #' determines how clustered/clumped the embedded points are. #' @param set.op.mix.ratio Interpolate between (fuzzy) union and intersection as the set operation #' used to combine local fuzzy simplicial sets to obtain a global fuzzy simplicial sets. Both fuzzy #' set operations use the product t-norm. The value of this parameter should be between 0.0 and #' 1.0; a value of 1.0 will use a pure fuzzy union, while 0.0 will use a pure fuzzy intersection. #' @param local.connectivity The local connectivity required - i.e. the number of nearest neighbors #' that should be assumed to be connected at a local level. The higher this value the more connected #' the manifold becomes locally. In practice this should be not more than the local intrinsic #' dimension of the manifold. #' @param repulsion.strength Weighting applied to negative samples in low dimensional embedding #' optimization. Values higher than one will result in greater weight being given to negative #' samples. #' @param negative.sample.rate The number of negative samples to select per positive sample in the #' optimization process. Increasing this value will result in greater repulsive force being applied, #' greater optimization cost, but slightly more accuracy. #' @param a More specific parameters controlling the embedding. If NULL, these values are set #' automatically as determined by min. dist and spread. Parameter of differentiable approximation of #' right adjoint functor. #' @param b More specific parameters controlling the embedding. If NULL, these values are set #' automatically as determined by min. dist and spread. Parameter of differentiable approximation of #' right adjoint functor. #' @param uwot.sgd Set \code{uwot::umap(fast_sgd = TRUE)}; see \code{\link[uwot]{umap}} for more details #' @param metric.kwds A dictionary of arguments to pass on to the metric, such as the p value for #' Minkowski distance. If NULL then no arguments are passed on. #' @param angular.rp.forest Whether to use an angular random projection forest to initialise the #' approximate nearest neighbor search. This can be faster, but is mostly on useful for metric that #' use an angular style distance such as cosine, correlation etc. In the case of those metrics #' angular forests will be chosen automatically. #' @param reduction.name Name to store dimensional reduction under in the Seurat object #' @param reduction.key dimensional reduction key, specifies the string before #' the number for the dimension names. UMAP by default #' @param seed.use Set a random seed. By default, sets the seed to 42. Setting #' NULL will not set a seed #' @param verbose Controls verbosity #' #' @rdname RunUMAP #' @export #' @method RunUMAP Seurat #' RunUMAP.Seurat <- function( object, dims = NULL, reduction = 'pca', features = NULL, graph = NULL, assay = 'RNA', umap.method = 'uwot', n.neighbors = 30L, n.components = 2L, metric = 'cosine', n.epochs = NULL, learning.rate = 1, min.dist = 0.3, spread = 1, set.op.mix.ratio = 1, local.connectivity = 1L, repulsion.strength = 1, negative.sample.rate = 5L, a = NULL, b = NULL, uwot.sgd = FALSE, seed.use = 42L, metric.kwds = NULL, angular.rp.forest = FALSE, verbose = TRUE, reduction.name = 'umap', reduction.key = 'UMAP_', ... ) { CheckDots(...) if (sum(c(is.null(x = dims), is.null(x = features), is.null(x = graph))) < 2) { stop("Please specify only one of the following arguments: dims, features, or graph") } if (!is.null(x = features)) { data.use <- as.matrix(x = t(x = GetAssayData(object = object, slot = 'data', assay = assay)[features, , drop = FALSE])) if (ncol(x = data.use) < n.components) { stop( "Please provide as many or more features than n.components: ", length(x = features), " features provided, ", n.components, " UMAP components requested", call. = FALSE ) } } else if (!is.null(x = dims)) { data.use <- Embeddings(object[[reduction]])[, dims] assay <- DefaultAssay(object = object[[reduction]]) if (length(x = dims) < n.components) { stop( "Please provide as many or more dims than n.components: ", length(x = dims), " dims provided, ", n.components, " UMAP components requested", call. = FALSE ) } } else if (!is.null(x = graph)) { data.use <- object[[graph]] } else { stop("Please specify one of dims, features, or graph") } object[[reduction.name]] <- RunUMAP( object = data.use, assay = assay, umap.method = umap.method, n.neighbors = n.neighbors, n.components = n.components, metric = metric, n.epochs = n.epochs, learning.rate = learning.rate, min.dist = min.dist, spread = spread, set.op.mix.ratio = set.op.mix.ratio, local.connectivity = local.connectivity, repulsion.strength = repulsion.strength, negative.sample.rate = negative.sample.rate, a = a, b = b, uwot.sgd = uwot.sgd, seed.use = seed.use, metric.kwds = metric.kwds, angular.rp.forest = angular.rp.forest, reduction.key = reduction.key, verbose = verbose ) object <- LogSeuratCommand(object = object) return(object) } #' @param dims Which dimensions to examine #' @param score.thresh Threshold to use for the proportion test of PC #' significance (see Details) #' #' @importFrom stats prop.test #' #' @rdname ScoreJackStraw #' @export #' @method ScoreJackStraw JackStrawData #' ScoreJackStraw.JackStrawData <- function( object, dims = 1:5, score.thresh = 1e-5, ... ) { CheckDots(...) pAll <- JS(object = object, slot = "empirical.p.values") pAll <- pAll[, dims, drop = FALSE] pAll <- as.data.frame(pAll) pAll$Contig <- rownames(x = pAll) score.df <- NULL for (i in dims) { pc.score <- suppressWarnings(prop.test( x = c( length(x = which(x = pAll[, i] <= score.thresh)), floor(x = nrow(x = pAll) * score.thresh) ), n = c(nrow(pAll), nrow(pAll)) )$p.val) if (length(x = which(x = pAll[, i] <= score.thresh)) == 0) { pc.score <- 1 } if (is.null(x = score.df)) { score.df <- data.frame(PC = paste0("PC", i), Score = pc.score) } else { score.df <- rbind(score.df, data.frame(PC = paste0("PC", i), Score = pc.score)) } } score.df$PC <- dims score.df <- as.matrix(score.df) JS(object = object, slot = 'overall') <- score.df return(object) } #' @rdname ScoreJackStraw #' @export #' @method ScoreJackStraw DimReduc #' ScoreJackStraw.DimReduc <- function(object, dims = 1:5, score.thresh = 1e-5, ...) { JS(object = object) <- ScoreJackStraw( object = JS(object = object), dims = dims, score.thresh = 1e-5, ... ) return(object) } #' @param reduction Reduction associated with JackStraw to score #' @param do.plot Show plot. To return ggplot object, use \code{JackStrawPlot} after #' running ScoreJackStraw. #' #' @seealso \code{\link{JackStrawPlot}} #' #' @rdname ScoreJackStraw #' @export #' @method ScoreJackStraw Seurat #' ScoreJackStraw.Seurat <- function( object, reduction = "pca", dims = 1:5, score.thresh = 1e-5, do.plot = FALSE, ... ) { object[[reduction]] <- ScoreJackStraw( object = object[[reduction]], dims = dims, ... ) if (do.plot) { CheckDots(..., fxns = 'JackStrawPlot') suppressWarnings(expr = print(JackStrawPlot( object = object, reduction = reduction, dims = dims, ... ))) } object <- LogSeuratCommand(object = object) return(object) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Methods for R-defined generics #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Internal #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Check that features are present and have non-zero variance # # @param data.use Feature matrix (features are rows) # @param features Features to check # @param object.name Name of object for message printing # @param verbose Print warnings # # @return Returns a vector of features that is the subset of features # that have non-zero variance # CheckFeatures <- function( data.use, features, object.name, verbose = TRUE ) { if (any(!features %in% rownames(x = data.use))) { missing.features <- features[!features %in% rownames(x = data.use)] features <- setdiff(x = features, y = missing.features) if (verbose){ warning( paste0( "The following ", length(x = missing.features), " features are not scaled in ", object.name, ": ", paste0(missing.features, collapse = ", ") )) } } if (inherits(x = data.use, what = 'dgCMatrix')) { features.var <- SparseRowVar(mat = data.use[features, ], display_progress = F) } else { features.var <- RowVar(x = data.use[features, ]) } no.var.features <- features[features.var == 0] if (length(x = no.var.features) > 0 && verbose) { warning( paste0( "The following features have zero variance in ", object.name, ": ", paste0(no.var.features, collapse = ", ") )) } features <- setdiff(x = features, y = no.var.features) features <- features[!is.na(x = features)] return(features) } #internal EmpiricalP <- function(x, nullval) { return(sum(nullval > x) / length(x = nullval)) } # FIt-SNE helper function for calling fast_tsne from R # # Based on Kluger Lab FIt-SNE v1.1.0 code on https://github.com/KlugerLab/FIt-SNE/blob/master/fast_tsne.R # commit d2cf403 on Feb 8, 2019 # #' @importFrom utils file_test # fftRtsne <- function(X, dims = 2, perplexity = 30, theta = 0.5, check_duplicates = TRUE, max_iter = 1000, fft_not_bh = TRUE, ann_not_vptree = TRUE, stop_early_exag_iter = 250, exaggeration_factor = 12.0, no_momentum_during_exag = FALSE, start_late_exag_iter = -1.0, late_exag_coeff = 1.0, mom_switch_iter = 250, momentum = 0.5, final_momentum = 0.8, learning_rate = 200, n_trees = 50, search_k = -1, rand_seed = -1, nterms = 3, intervals_per_integer = 1, min_num_intervals = 50, K = -1, sigma = -30, initialization = NULL, data_path = NULL, result_path = NULL, load_affinities = NULL, fast_tsne_path = NULL, nthreads = getOption('mc.cores', default = 1), perplexity_list = NULL, get_costs = FALSE, df = 1.0, ... ) { CheckDots(...) if (is.null(x = data_path)) { data_path <- tempfile(pattern = 'fftRtsne_data_', fileext = '.dat') } if (is.null(x = result_path)) { result_path <- tempfile(pattern = 'fftRtsne_result_', fileext = '.dat') } if (is.null(x = fast_tsne_path)) { # suppressWarnings(expr = fast_tsne_path <- system2(command = 'which', args = 'fast_tsne', stdout = TRUE)) fast_tsne_path <- SysExec(progs = ifelse( test = .Platform$OS.type == 'windows', yes = 'FItSNE.exe', no = 'fast_tsne' )) if (length(x = fast_tsne_path) == 0) { stop("no fast_tsne_path specified and fast_tsne binary is not in the search path") } } fast_tsne_path <- normalizePath(path = fast_tsne_path) if (!file_test(op = '-x', x = fast_tsne_path)) { stop("fast_tsne_path '", fast_tsne_path, "' does not exist or is not executable") } # check fast_tsne version ft.out <- suppressWarnings(expr = system2(command = fast_tsne_path, stdout = TRUE)) if (grepl(pattern = '= t-SNE v1.1', x = ft.out[1])) { version_number <- '1.1.0' } else if (grepl(pattern = '= t-SNE v1.0', x = ft.out[1])) { version_number <- '1.0' } else { message("First line of fast_tsne output is") message(ft.out[1]) stop("Our FIt-SNE wrapper requires FIt-SNE v1.X.X, please install the appropriate version from github.com/KlugerLab/FIt-SNE and have fast_tsne_path point to it if it's not in your path") } is.wholenumber <- function(x, tol = .Machine$double.eps ^ 0.5) { return(abs(x = x - round(x = x)) < tol) } if (version_number == '1.0' && df != 1.0) { stop("This version of FIt-SNE does not support df!=1. Please install the appropriate version from github.com/KlugerLab/FIt-SNE") } if (!is.numeric(x = theta) || (theta < 0.0) || (theta > 1.0) ) { stop("Incorrect theta.") } if (nrow(x = X) - 1 < 3 * perplexity) { stop("Perplexity is too large.") } if (!is.matrix(x = X)) { stop("Input X is not a matrix") } if (!(max_iter > 0)) { stop("Incorrect number of iterations.") } if (!is.wholenumber(x = stop_early_exag_iter) || stop_early_exag_iter < 0) { stop("stop_early_exag_iter should be a positive integer") } if (!is.numeric(x = exaggeration_factor)) { stop("exaggeration_factor should be numeric") } if (!is.wholenumber(x = dims) || dims <= 0) { stop("Incorrect dimensionality.") } if (search_k == -1) { if (perplexity > 0) { search_k <- n_trees * perplexity * 3 } else if (perplexity == 0) { search_k <- n_trees * max(perplexity_list) * 3 } else { search_k <- n_trees * K * 3 } } nbody_algo <- ifelse(test = fft_not_bh, yes = 2, no = 1) if (is.null(load_affinities)) { load_affinities <- 0 } else { if (load_affinities == 'load') { load_affinities <- 1 } else if (load_affinities == 'save') { load_affinities <- 2 } else { load_affinities <- 0 } } knn_algo <- ifelse(test = ann_not_vptree, yes = 1, no = 2) f <- file(description = data_path, open = "wb") n = nrow(x = X) D = ncol(x = X) writeBin(object = as.integer(x = n), con = f, size = 4) writeBin(object = as.integer(x = D), con = f, size = 4) writeBin(object = as.numeric(x = theta), con = f, size = 8) #theta writeBin(object = as.numeric(x = perplexity), con = f, size = 8) #theta if (perplexity == 0) { writeBin(object = as.integer(x = length(x = perplexity_list)), con = f, size = 4) writeBin(object = perplexity_list, con = f) } writeBin(object = as.integer(x = dims), con = f, size = 4) #theta writeBin(object = as.integer(x = max_iter), con = f, size = 4) writeBin(object = as.integer(x = stop_early_exag_iter), con = f, size = 4) writeBin(object = as.integer(x = mom_switch_iter), con = f, size = 4) writeBin(object = as.numeric(x = momentum), con = f, size = 8) writeBin(object = as.numeric(x = final_momentum), con = f, size = 8) writeBin(object = as.numeric(x = learning_rate), con = f, size = 8) writeBin(object = as.integer(x = K), con = f, size = 4) #K writeBin(object = as.numeric(x = sigma), con = f, size = 8) #sigma writeBin(object = as.integer(x = nbody_algo), con = f, size = 4) #not barnes hut writeBin(object = as.integer(x = knn_algo), con = f, size = 4) writeBin(object = as.numeric(x = exaggeration_factor), con = f, size = 8) #compexag writeBin(object = as.integer(x = no_momentum_during_exag), con = f, size = 4) writeBin(object = as.integer(x = n_trees), con = f, size = 4) writeBin(object = as.integer(x = search_k), con = f, size = 4) writeBin(object = as.integer(x = start_late_exag_iter), con = f, size = 4) writeBin(object = as.numeric(x = late_exag_coeff), con = f, size = 8) writeBin(object = as.integer(x = nterms), con = f, size = 4) writeBin(object = as.numeric(x = intervals_per_integer), con = f, size = 8) writeBin(object = as.integer(x = min_num_intervals), con = f, size = 4) tX = c(t(X)) writeBin(object = tX, con = f) writeBin(object = as.integer(x = rand_seed), con = f, size = 4) if (version_number != "1.0") { writeBin(object = as.numeric(x = df), con = f, size = 8) } writeBin(object = as.integer(x = load_affinities), con = f, size = 4) if (!is.null(x = initialization)) { writeBin(object = c(t(x = initialization)), con = f) } close(con = f) if (version_number == "1.0") { flag <- system2( command = fast_tsne_path, args = c(data_path, result_path, nthreads) ) } else { flag <- system2( command = fast_tsne_path, args = c(version_number, data_path, result_path, nthreads) ) } if (flag != 0) { stop('tsne call failed') } f <- file(description = result_path, open = "rb") n <- readBin(con = f, what = integer(), n = 1, size = 4) d <- readBin(con = f, what = integer(), n = 1, size = 4) Y <- readBin(con = f, what = numeric(), n = n * d) Y <- t(x = matrix(Y, nrow = d)) if (get_costs) { tmp <- readBin(con = f, what = integer(), n = 1, size = 4) costs <- readBin(con = f, what = numeric(), n = max_iter, size = 8) Yout <- list(Y = Y, costs = costs) } else { Yout <- Y } close(con = f) file.remove(data_path) file.remove(result_path) return(Yout) } #internal # JackRandom <- function( scaled.data, prop.use = 0.01, r1.use = 1, r2.use = 5, seed.use = 1, rev.pca = FALSE, weight.by.var = weight.by.var, maxit = 1000 ) { if (!is.null(x = seed.use)) { set.seed(seed = seed.use) } rand.genes <- sample( x = rownames(x = scaled.data), size = nrow(x = scaled.data) * prop.use ) # make sure that rand.genes is at least 3 if (length(x = rand.genes) < 3) { rand.genes <- sample(x = rownames(x = scaled.data), size = 3) } data.mod <- scaled.data data.mod[rand.genes, ] <- MatrixRowShuffle(x = scaled.data[rand.genes, ]) temp.object <- RunPCA( object = data.mod, assay = "temp", npcs = r2.use, features = rownames(x = data.mod), rev.pca = rev.pca, weight.by.var = weight.by.var, verbose = FALSE, maxit = maxit ) return(Loadings(temp.object)[rand.genes, r1.use:r2.use]) } # Calculates the l2-norm of a vector # # Modified from PMA package # @references Witten, Tibshirani, and Hastie, Biostatistics 2009 # @references \url{https://github.com/cran/PMA/blob/master/R/PMD.R} # # @param vec numeric vector # # @return returns the l2-norm. # L2Norm <- function(vec) { a <- sqrt(x = sum(vec ^ 2)) if (a == 0) { a <- .05 } return(a) } # Prep data for dimensional reduction # # Common checks and preparatory steps before running certain dimensional # reduction techniques # # @param object Assay object # @param features Features to use as input for the dimensional reduction technique. # Default is variable features # @ param verbose Print messages and warnings # # PrepDR <- function( object, features = NULL, verbose = TRUE ) { if (length(x = VariableFeatures(object = object)) == 0 && is.null(x = features)) { stop("Variable features haven't been set. Run FindVariableFeatures() or provide a vector of feature names.") } data.use <- GetAssayData(object = object, slot = "scale.data") if (nrow(x = data.use ) == 0) { stop("Data has not been scaled. Please run ScaleData and retry") } features <- features %||% VariableFeatures(object = object) features.keep <- unique(x = features[features %in% rownames(x = data.use)]) if (length(x = features.keep) < length(x = features)) { features.exclude <- setdiff(x = features, y = features.keep) if (verbose) { warning(paste0("The following ", length(x = features.exclude), " features requested have not been scaled (running reduction without them): ", paste0(features.exclude, collapse = ", "))) } } features <- features.keep features.var <- apply(X = data.use[features, ], MARGIN = 1, FUN = var) features.keep <- features[features.var > 0] if (length(x = features.keep) < length(x = features)) { features.exclude <- setdiff(x = features, y = features.keep) if (verbose) { warning(paste0("The following ", length(x = features.exclude), " features requested have zero variance (running reduction without them): ", paste0(features.exclude, collapse = ", "))) } } features <- features.keep features <- features[!is.na(x = features)] data.use <- data.use[features, ] return(data.use) } Seurat/R/clustering.R0000644000176200001440000006420413617623374014242 0ustar liggesusers#' @include generics.R #' NULL #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Functions #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Methods for Seurat-defined generics #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' @importFrom pbapply pblapply #' @importFrom future.apply future_lapply #' @importFrom future nbrOfWorkers #' #' @param modularity.fxn Modularity function (1 = standard; 2 = alternative). #' @param initial.membership,weights,node.sizes Parameters to pass to the Python leidenalg function. #' @param resolution Value of the resolution parameter, use a value above #' (below) 1.0 if you want to obtain a larger (smaller) number of communities. #' @param algorithm Algorithm for modularity optimization (1 = original Louvain #' algorithm; 2 = Louvain algorithm with multilevel refinement; 3 = SLM #' algorithm; 4 = Leiden algorithm). Leiden requires the leidenalg python. #' @param method Method for running leiden (defaults to matrix which is fast for small datasets). #' Enable method = "igraph" to avoid casting large data to a dense matrix. #' @param n.start Number of random starts. #' @param n.iter Maximal number of iterations per random start. #' @param random.seed Seed of the random number generator. #' @param group.singletons Group singletons into nearest cluster. If FALSE, assign all singletons to #' a "singleton" group #' @param temp.file.location Directory where intermediate files will be written. #' Specify the ABSOLUTE path. #' @param edge.file.name Edge file to use as input for modularity optimizer jar. #' @param verbose Print output #' #' @rdname FindClusters #' @export #' FindClusters.default <- function( object, modularity.fxn = 1, initial.membership = NULL, weights = NULL, node.sizes = NULL, resolution = 0.8, method = "matrix", algorithm = 1, n.start = 10, n.iter = 10, random.seed = 0, group.singletons = TRUE, temp.file.location = NULL, edge.file.name = NULL, verbose = TRUE, ... ) { CheckDots(...) if (is.null(x = object)) { stop("Please provide an SNN graph") } if (tolower(x = algorithm) == "louvain") { algorithm <- 1 } if (tolower(x = algorithm) == "leiden") { algorithm <- 4 } if (nbrOfWorkers() > 1) { clustering.results <- future_lapply( X = resolution, FUN = function(r) { if (algorithm %in% c(1:3)) { ids <- RunModularityClustering( SNN = object, modularity = modularity.fxn, resolution = r, algorithm = algorithm, n.start = n.start, n.iter = n.iter, random.seed = random.seed, print.output = verbose, temp.file.location = temp.file.location, edge.file.name = edge.file.name ) } else if (algorithm == 4) { ids <- RunLeiden( object = object, method = method, partition.type = "RBConfigurationVertexPartition", initial.membership = initial.membership, weights = weights, node.sizes = node.sizes, resolution.parameter = r, random.seed = random.seed, n.iter = n.iter ) } else { stop("algorithm not recognised, please specify as an integer or string") } names(x = ids) <- colnames(x = object) ids <- GroupSingletons(ids = ids, SNN = object, verbose = verbose) results <- list(factor(x = ids)) names(x = results) <- paste0('res.', r) return(results) } ) clustering.results <- as.data.frame(x = clustering.results) } else { clustering.results <- data.frame(row.names = colnames(x = object)) for (r in resolution) { if (algorithm %in% c(1:3)) { ids <- RunModularityClustering( SNN = object, modularity = modularity.fxn, resolution = r, algorithm = algorithm, n.start = n.start, n.iter = n.iter, random.seed = random.seed, print.output = verbose, temp.file.location = temp.file.location, edge.file.name = edge.file.name) } else if (algorithm == 4) { ids <- RunLeiden( object = object, method = method, partition.type = "RBConfigurationVertexPartition", initial.membership = initial.membership, weights = weights, node.sizes = node.sizes, resolution.parameter = r, random.seed = random.seed, n.iter = n.iter ) } else { stop("algorithm not recognised, please specify as an integer or string") } names(x = ids) <- colnames(x = object) ids <- GroupSingletons(ids = ids, SNN = object, group.singletons = group.singletons, verbose = verbose) clustering.results[, paste0("res.", r)] <- factor(x = ids) } } return(clustering.results) } #' @importFrom methods is #' #' @param graph.name Name of graph to use for the clustering algorithm #' #' @rdname FindClusters #' @export #' @method FindClusters Seurat #' FindClusters.Seurat <- function( object, graph.name = NULL, modularity.fxn = 1, initial.membership = NULL, weights = NULL, node.sizes = NULL, resolution = 0.8, method = "matrix", algorithm = 1, n.start = 10, n.iter = 10, random.seed = 0, group.singletons = TRUE, temp.file.location = NULL, edge.file.name = NULL, verbose = TRUE, ... ) { CheckDots(...) graph.name <- graph.name %||% paste0(DefaultAssay(object = object), "_snn") if (!graph.name %in% names(x = object)) { stop("Provided graph.name not present in Seurat object") } if (!is(object = object[[graph.name]], class2 = "Graph")) { stop("Provided graph.name does not correspond to a graph object.") } clustering.results <- FindClusters( object = object[[graph.name]], modularity.fxn = modularity.fxn, initial.membership = initial.membership, weights = weights, node.sizes = node.sizes, resolution = resolution, method = method, algorithm = algorithm, n.start = n.start, n.iter = n.iter, random.seed = random.seed, group.singletons = group.singletons, temp.file.location = temp.file.location, edge.file.name = edge.file.name, verbose = verbose, ... ) colnames(x = clustering.results) <- paste0(graph.name, "_", colnames(x = clustering.results)) object <- AddMetaData(object = object, metadata = clustering.results) Idents(object = object) <- colnames(x = clustering.results)[ncol(x = clustering.results)] levels <- levels(x = object) levels <- tryCatch( expr = as.numeric(x = levels), warning = function(...) { return(levels) }, error = function(...) { return(levels) } ) Idents(object = object) <- factor(x = Idents(object = object), levels = sort(x = levels)) object[['seurat_clusters']] <- Idents(object = object) cmd <- LogSeuratCommand(object = object, return.command = TRUE) slot(object = cmd, name = 'assay.used') <- DefaultAssay(object = object[[graph.name]]) object[[slot(object = cmd, name = 'name')]] <- cmd return(object) } #' @param distance.matrix Boolean value of whether the provided matrix is a #' distance matrix; note, for objects of class \code{dist}, this parameter will #' be set automatically #' @param k.param Defines k for the k-nearest neighbor algorithm #' @param compute.SNN also compute the shared nearest neighbor graph #' @param prune.SNN Sets the cutoff for acceptable Jaccard index when #' computing the neighborhood overlap for the SNN construction. Any edges with #' values less than or equal to this will be set to 0 and removed from the SNN #' graph. Essentially sets the strigency of pruning (0 --- no pruning, 1 --- #' prune everything). #' @param nn.method Method for nearest neighbor finding. Options include: rann, #' annoy #' @param annoy.metric Distance metric for annoy. Options include: euclidean, #' cosine, manhattan, and hamming #' @param nn.eps Error bound when performing nearest neighbor seach using RANN; #' default of 0.0 implies exact nearest neighbor search #' @param verbose Whether or not to print output to the console #' @param force.recalc Force recalculation of SNN. #' #' @importFrom RANN nn2 #' @importFrom methods as #' #' @rdname FindNeighbors #' @export #' @method FindNeighbors default #' FindNeighbors.default <- function( object, distance.matrix = FALSE, k.param = 20, compute.SNN = TRUE, prune.SNN = 1/15, nn.method = 'rann', annoy.metric = "euclidean", nn.eps = 0, verbose = TRUE, force.recalc = FALSE, ... ) { CheckDots(...) if (is.null(x = dim(x = object))) { warning( "Object should have two dimensions, attempting to coerce to matrix", call. = FALSE ) object <- as.matrix(x = object) } if (is.null(rownames(x = object))) { stop("Please provide rownames (cell names) with the input object") } n.cells <- nrow(x = object) if (n.cells < k.param) { warning( "k.param set larger than number of cells. Setting k.param to number of cells - 1.", call. = FALSE ) k.param <- n.cells - 1 } # find the k-nearest neighbors for each single cell if (!distance.matrix) { if (verbose) { message("Computing nearest neighbor graph") } nn.ranked <- NNHelper( data = object, k = k.param, method = nn.method, searchtype = "standard", eps = nn.eps, metric = annoy.metric) nn.ranked <- nn.ranked$nn.idx } else { if (verbose) { message("Building SNN based on a provided distance matrix") } knn.mat <- matrix(data = 0, ncol = k.param, nrow = n.cells) knd.mat <- knn.mat for (i in 1:n.cells) { knn.mat[i, ] <- order(object[i, ])[1:k.param] knd.mat[i, ] <- object[i, knn.mat[i, ]] } nn.ranked <- knn.mat[, 1:k.param] } # convert nn.ranked into a Graph j <- as.numeric(x = t(x = nn.ranked)) i <- ((1:length(x = j)) - 1) %/% k.param + 1 nn.matrix <- as(object = sparseMatrix(i = i, j = j, x = 1, dims = c(nrow(x = object), nrow(x = object))), Class = "Graph") rownames(x = nn.matrix) <- rownames(x = object) colnames(x = nn.matrix) <- rownames(x = object) neighbor.graphs <- list(nn = nn.matrix) if (compute.SNN) { if (verbose) { message("Computing SNN") } snn.matrix <- ComputeSNN( nn_ranked = nn.ranked, prune = prune.SNN ) rownames(x = snn.matrix) <- rownames(x = object) colnames(x = snn.matrix) <- rownames(x = object) snn.matrix <- as.Graph(x = snn.matrix) neighbor.graphs[["snn"]] <- snn.matrix } return(neighbor.graphs) } #' @rdname FindNeighbors #' @export #' @method FindNeighbors Assay #' FindNeighbors.Assay <- function( object, features = NULL, k.param = 20, compute.SNN = TRUE, prune.SNN = 1/15, nn.method = 'rann', annoy.metric = "euclidean", nn.eps = 0, verbose = TRUE, force.recalc = FALSE, ... ) { CheckDots(...) features <- features %||% VariableFeatures(object = object) data.use <- t(x = GetAssayData(object = object, slot = "data")[features, ]) neighbor.graphs <- FindNeighbors( object = data.use, k.param = k.param, compute.SNN = compute.SNN, prune.SNN = prune.SNN, nn.method = nn.method, annoy.metric = annoy.metric, nn.eps = nn.eps, verbose = verbose, force.recalc = force.recalc, ... ) return(neighbor.graphs) } #' @rdname FindNeighbors #' @export #' @method FindNeighbors dist #' FindNeighbors.dist <- function( object, k.param = 20, compute.SNN = TRUE, prune.SNN = 1/15, nn.method = "rann", annoy.metric = "euclidean", nn.eps = 0, verbose = TRUE, force.recalc = FALSE, ... ) { CheckDots(...) return(FindNeighbors( object = as.matrix(x = object), distance.matrix = TRUE, k.param = k.param, compute.SNN = compute.SNN, prune.SNN = prune.SNN, nn.eps = nn.eps, nn.method = nn.method, annoy.metric = annoy.metric, verbose = verbose, force.recalc = force.recalc, ... )) } #' @param assay Assay to use in construction of SNN #' @param features Features to use as input for building the SNN #' @param reduction Reduction to use as input for building the SNN #' @param dims Dimensions of reduction to use as input #' @param do.plot Plot SNN graph on tSNE coordinates #' @param graph.name Optional naming parameter for stored SNN graph. Default is #' assay.name_snn. #' #' @importFrom igraph graph.adjacency plot.igraph E #' #' @rdname FindNeighbors #' @export #' @method FindNeighbors Seurat #' FindNeighbors.Seurat <- function( object, reduction = "pca", dims = 1:10, assay = NULL, features = NULL, k.param = 20, compute.SNN = TRUE, prune.SNN = 1/15, nn.method = "rann", annoy.metric = "euclidean", nn.eps = 0, verbose = TRUE, force.recalc = FALSE, do.plot = FALSE, graph.name = NULL, ... ) { CheckDots(...) if (!is.null(x = dims)) { # assay <- assay %||% DefaultAssay(object = object) assay <- DefaultAssay(object = object[[reduction]]) data.use <- Embeddings(object = object[[reduction]]) if (max(dims) > ncol(x = data.use)) { stop("More dimensions specified in dims than have been computed") } data.use <- data.use[, dims] neighbor.graphs <- FindNeighbors( object = data.use, k.param = k.param, compute.SNN = compute.SNN, prune.SNN = prune.SNN, nn.method = nn.method, annoy.metric = annoy.metric, nn.eps = nn.eps, verbose = verbose, force.recalc = force.recalc, ... ) } else { assay <- assay %||% DefaultAssay(object = object) data.use <- GetAssay(object = object, assay = assay) neighbor.graphs <- FindNeighbors( object = data.use, features = features, k.param = k.param, compute.SNN = compute.SNN, prune.SNN = prune.SNN, nn.method = nn.method, annoy.metric = annoy.metric, nn.eps = nn.eps, verbose = verbose, force.recalc = force.recalc, ... ) } graph.name <- graph.name %||% paste0(assay, "_", names(x = neighbor.graphs)) for (ii in 1:length(x = graph.name)) { DefaultAssay(object = neighbor.graphs[[ii]]) <- assay object[[graph.name[[ii]]]] <- neighbor.graphs[[ii]] } if (do.plot) { if (!"tsne" %in% names(x = object@reductions)) { warning("Please compute a tSNE for SNN visualization. See RunTSNE().") } else { if (nrow(x = Embeddings(object = object[["tsne"]])) != ncol(x = object)) { warning("Please compute a tSNE for SNN visualization. See RunTSNE().") } else { net <- graph.adjacency( adjmatrix = as.matrix(x = neighbor.graphs[[2]]), mode = "undirected", weighted = TRUE, diag = FALSE ) plot.igraph( x = net, layout = as.matrix(x = Embeddings(object = object[["tsne"]])), edge.width = E(graph = net)$weight, vertex.label = NA, vertex.size = 0 ) } } } object <- LogSeuratCommand(object = object) return(object) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Internal #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Run annoy # # @param data Data to build the index with # @param query A set of data to be queried against data # @param metric Distance metric; can be one of "euclidean", "cosine", "manhattan", # "hamming" # @param n.trees More trees gives higher precision when querying # @param k Number of neighbors # @param search.k During the query it will inspect up to search_k nodes which # gives you a run-time tradeoff between better accuracy and speed. # @ param include.distance Include the corresponding distances # AnnoyNN <- function(data, query = data, metric = "euclidean", n.trees = 50, k, search.k = -1, include.distance = TRUE) { idx <- AnnoyBuildIndex( data = data, metric = metric, n.trees = n.trees) nn <- AnnoySearch( index = idx, query = query, k = k, search.k = search.k, include.distance = include.distance) return(nn) } # Build the annoy index # # @param data Data to build the index with # @param metric Distance metric; can be one of "euclidean", "cosine", "manhattan", # "hamming" # @param n.trees More trees gives higher precision when querying #' @importFrom RcppAnnoy AnnoyEuclidean AnnoyAngular AnnoyManhattan AnnoyHamming # AnnoyBuildIndex <- function(data, metric = "euclidean", n.trees = 50) { f <- ncol(x = data) a <- switch( EXPR = metric, "euclidean" = new(Class = RcppAnnoy::AnnoyEuclidean, f), "cosine" = new(Class = RcppAnnoy::AnnoyAngular, f), "manhattan" = new(Class = RcppAnnoy::AnnoyManhattan, f), "hamming" = new(Class = RcppAnnoy::AnnoyHamming, f), stop ("Invalid metric") ) for (ii in seq(nrow(x = data))) { a$addItem(ii - 1, data[ii, ]) } a$build(n.trees) return(a) } # Search the annoy index # # @param Annoy index, build with AnnoyBuildIndex # @param query A set of data to be queried against the index # @param k Number of neighbors # @param search.k During the query it will inspect up to search_k nodes which # gives you a run-time tradeoff between better accuracy and speed. # @ param include.distance Include the corresponding distances # AnnoySearch <- function(index, query, k, search.k = -1, include.distance = TRUE) { n <- nrow(x = query) idx <- matrix(nrow = n, ncol = k) dist <- matrix(nrow = n, ncol = k) convert <- methods::is(index, "Rcpp_AnnoyAngular") res <- future_lapply(X = 1:n, FUN = function(x) { res <- index$getNNsByVectorList(query[x, ], k, search.k, include.distance) # Convert from Angular to Cosine distance if (convert) { res$dist <- 0.5 * (res$dist * res$dist) } list(res$item + 1, res$distance) }) for (i in 1:n) { idx[i, ] <- res[[i]][[1]] if (include.distance) { dist[i, ] <- res[[i]][[2]] } } return(list(nn.idx = idx, nn.dists = dist)) } # Group single cells that make up their own cluster in with the cluster they are # most connected to. # # @param ids Named vector of cluster ids # @param SNN SNN graph used in clustering # @param group.singletons Group singletons into nearest cluster. If FALSE, assign all singletons to # a "singleton" group # # @return Returns Seurat object with all singletons merged with most connected cluster # GroupSingletons <- function(ids, SNN, group.singletons = TRUE, verbose = TRUE) { # identify singletons singletons <- c() singletons <- names(x = which(x = table(ids) == 1)) singletons <- intersect(x = unique(x = ids), singletons) if (!group.singletons) { ids[which(ids %in% singletons)] <- "singleton" return(ids) } # calculate connectivity of singletons to other clusters, add singleton # to cluster it is most connected to cluster_names <- as.character(x = unique(x = ids)) cluster_names <- setdiff(x = cluster_names, y = singletons) connectivity <- vector(mode = "numeric", length = length(x = cluster_names)) names(x = connectivity) <- cluster_names new.ids <- ids for (i in singletons) { i.cells <- names(which(ids == i)) for (j in cluster_names) { j.cells <- names(which(ids == j)) subSNN <- SNN[i.cells, j.cells] set.seed(1) # to match previous behavior, random seed being set in WhichCells if (is.object(x = subSNN)) { connectivity[j] <- sum(subSNN) / (nrow(x = subSNN) * ncol(x = subSNN)) } else { connectivity[j] <- mean(x = subSNN) } } m <- max(connectivity, na.rm = T) mi <- which(x = connectivity == m, arr.ind = TRUE) closest_cluster <- sample(x = names(x = connectivity[mi]), 1) ids[i.cells] <- closest_cluster } if (length(x = singletons) > 0 && verbose) { message(paste( length(x = singletons), "singletons identified.", length(x = unique(x = ids)), "final clusters." )) } return(ids) } # Internal helper function to dispatch to various neighbor finding methods # # @param data Input data # @param query Data to query against data # @param k Number of nearest neighbors to compute # @param method Nearest neighbor method to use: "rann", "annoy" # @param ... additional parameters to specific neighbor finding method # NNHelper <- function(data, query = data, k, method, ...) { args <- as.list(x = sys.frame(which = sys.nframe())) args <- c(args, list(...)) return( switch( EXPR = method, "rann" = { args <- args[intersect(x = names(x = args), y = names(x = formals(fun = nn2)))] do.call(what = 'nn2', args = args) }, "annoy" = { args <- args[intersect(x = names(x = args), y = names(x = formals(fun = AnnoyNN)))] do.call(what = 'AnnoyNN', args = args) }, stop("Invalid method. Please choose one of 'rann', 'annoy'") ) ) } # Run Leiden clustering algorithm # # Implements the Leiden clustering algorithm in R using reticulate # to run the Python version. Requires the python "leidenalg" and "igraph" modules # to be installed. Returns a vector of partition indices. # # @param adj_mat An adjacency matrix or SNN matrix # @param partition.type Type of partition to use for Leiden algorithm. # Defaults to RBConfigurationVertexPartition. Options include: ModularityVertexPartition, # RBERVertexPartition, CPMVertexPartition, MutableVertexPartition, # SignificanceVertexPartition, SurpriseVertexPartition (see the Leiden python # module documentation for more details) # @param initial.membership,weights,node.sizes Parameters to pass to the Python leidenalg function. # @param resolution.parameter A parameter controlling the coarseness of the clusters # for Leiden algorithm. Higher values lead to more clusters. (defaults to 1.0 for # partition types that accept a resolution parameter) # @param random.seed Seed of the random number generator # @param n.iter Maximal number of iterations per random start # # @keywords graph network igraph mvtnorm simulation # #' @importFrom leiden leiden #' @importFrom reticulate py_module_available #' @importFrom igraph graph_from_adjacency_matrix graph_from_adj_list # # @author Tom Kelly # # @export # RunLeiden <- function( object, method = c("matrix", "igraph"), partition.type = c( 'RBConfigurationVertexPartition', 'ModularityVertexPartition', 'RBERVertexPartition', 'CPMVertexPartition', 'MutableVertexPartition', 'SignificanceVertexPartition', 'SurpriseVertexPartition' ), initial.membership = NULL, weights = NULL, node.sizes = NULL, resolution.parameter = 1, random.seed = 0, n.iter = 10 ) { if (!py_module_available(module = 'leidenalg')) { stop( "Cannot find Leiden algorithm, please install through pip (e.g. pip install leidenalg).", call. = FALSE ) } switch( EXPR = method, "matrix" = { input <- as(object = object, Class = "matrix") }, "igraph" = { input <- if (inherits(x = object, what = 'list')) { if (is.null(x = weights)) { graph_from_adj_list(adjlist = object) } else { graph_from_adj_list(adjlist = object) } } else if (inherits(x = object, what = c('dgCMatrix', 'matrix', "Matrix"))) { if (is.null(x = weights)) { graph_from_adjacency_matrix(adjmatrix = object) } else { graph_from_adjacency_matrix(adjmatrix = object, weighted = TRUE) } } else if (inherits(x = object, what = 'igraph')) { object } else { stop( "Method for Leiden not found for class", class(x = object), call. = FALSE ) } }, stop("Method for Leiden must be either 'matrix' or igraph'") ) #run leiden from CRAN package (calls python with reticulate) partition <- leiden( object = input, partition_type = partition.type, initial_membership = initial.membership, weights = weights, node_sizes = node.sizes, resolution_parameter = resolution.parameter, seed = random.seed, n_iterations = n.iter ) return(partition) } # Runs the modularity optimizer (C++ port of java program ModularityOptimizer.jar) # # @param SNN SNN matrix to use as input for the clustering algorithms # @param modularity Modularity function to use in clustering (1 = standard; 2 = alternative) # @param resolution Value of the resolution parameter, use a value above (below) 1.0 if you want to obtain a larger (smaller) number of communities # @param algorithm Algorithm for modularity optimization (1 = original Louvain algorithm; 2 = Louvain algorithm with multilevel refinement; 3 = SLM algorithm; 4 = Leiden algorithm). Leiden requires the leidenalg python module. # @param n.start Number of random starts # @param n.iter Maximal number of iterations per random start # @param random.seed Seed of the random number generator # @param print.output Whether or not to print output to the console # @param temp.file.location Deprecated and no longer used # @param edge.file.name Path to edge file to use # # @return Seurat object with identities set to the results of the clustering procedure # #' @importFrom utils read.table write.table # RunModularityClustering <- function( SNN = matrix(), modularity = 1, resolution = 0.8, algorithm = 1, n.start = 10, n.iter = 10, random.seed = 0, print.output = TRUE, temp.file.location = NULL, edge.file.name = NULL ) { edge_file <- edge.file.name %||% '' clusters <- RunModularityClusteringCpp( SNN, modularity, resolution, algorithm, n.start, n.iter, random.seed, print.output, edge_file ) return(clusters) } Seurat/R/visualization.R0000644000176200001440000046311313617623374014766 0ustar liggesusers#' @importFrom utils globalVariables #' @importFrom ggplot2 ggproto GeomViolin #' NULL #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Heatmaps #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' Dimensional reduction heatmap #' #' Draws a heatmap focusing on a principal component. Both cells and genes are sorted by their #' principal component scores. Allows for nice visualization of sources of heterogeneity in the dataset. #' #' @inheritParams DoHeatmap #' @param dims Dimensions to plot #' @param nfeatures Number of genes to plot #' @param cells A list of cells to plot. If numeric, just plots the top cells. #' @param reduction Which dimmensional reduction to use #' @param balanced Plot an equal number of genes with both + and - scores. #' @param projected Use the full projected dimensional reduction #' @param ncol Number of columns to plot #' @param fast If true, use \code{image} to generate plots; faster than using ggplot2, but not customizable #' @param assays A vector of assays to pull data from #' #' @return No return value by default. If using fast = FALSE, will return a ggplot object. #' #' @export #' #' @seealso \code{\link[graphics]{image}} \code{\link[ggplot2]{geom_raster}} #' #' @examples #' DimHeatmap(object = pbmc_small) #' DimHeatmap <- function( object, dims = 1, nfeatures = 30, cells = NULL, reduction = 'pca', disp.min = -2.5, disp.max = NULL, balanced = TRUE, projected = FALSE, ncol = NULL, combine = TRUE, fast = TRUE, raster = TRUE, slot = 'scale.data', assays = NULL ) { ncol <- ncol %||% ifelse(test = length(x = dims) > 2, yes = 3, no = length(x = dims)) plots <- vector(mode = 'list', length = length(x = dims)) assays <- assays %||% DefaultAssay(object = object) disp.max <- disp.max %||% ifelse( test = slot == 'scale.data', yes = 2.5, no = 6 ) if (!DefaultAssay(object = object[[reduction]]) %in% assays) { warning("The original assay that the reduction was computed on is different than the assay specified") } cells <- cells %||% ncol(x = object) if (is.numeric(x = cells)) { cells <- lapply( X = dims, FUN = function(x) { cells <- TopCells( object = object[[reduction]], dim = x, ncells = cells, balanced = balanced ) if (balanced) { cells$negative <- rev(x = cells$negative) } cells <- unlist(x = unname(obj = cells)) return(cells) } ) } if (!is.list(x = cells)) { cells <- lapply(X = 1:length(x = dims), FUN = function(x) {return(cells)}) } features <- lapply( X = dims, FUN = TopFeatures, object = object[[reduction]], nfeatures = nfeatures, balanced = balanced, projected = projected ) features.all <- unique(x = unlist(x = features)) if (length(x = assays) > 1) { features.keyed <- lapply( X = assays, FUN = function(assay) { features <- features.all[features.all %in% rownames(x = object[[assay]])] if (length(x = features) > 0) { return(paste0(Key(object = object[[assay]]), features)) } } ) features.keyed <- Filter(f = Negate(f = is.null), x = features.keyed) features.keyed <- unlist(x = features.keyed) } else { features.keyed <- features.all DefaultAssay(object = object) <- assays } data.all <- FetchData( object = object, vars = features.keyed, cells = unique(x = unlist(x = cells)), slot = slot ) data.all <- MinMax(data = data.all, min = disp.min, max = disp.max) data.limits <- c(min(data.all), max(data.all)) # if (check.plot && any(c(length(x = features.keyed), length(x = cells[[1]])) > 700)) { # choice <- menu(c("Continue with plotting", "Quit"), title = "Plot(s) requested will likely take a while to plot.") # if (choice != 1) { # return(invisible(x = NULL)) # } # } if (fast) { nrow <- floor(x = length(x = dims) / 3.01) + 1 orig.par <- par()$mfrow par(mfrow = c(nrow, ncol)) } for (i in 1:length(x = dims)) { dim.features <- c(features[[i]][[2]], rev(x = features[[i]][[1]])) dim.features <- rev(x = unlist(x = lapply( X = dim.features, FUN = function(feat) { return(grep(pattern = paste0(feat, '$'), x = features.keyed, value = TRUE)) } ))) dim.cells <- cells[[i]] data.plot <- data.all[dim.cells, dim.features] if (fast) { SingleImageMap( data = data.plot, title = paste0(Key(object = object[[reduction]]), dims[i]), order = dim.cells ) } else { plots[[i]] <- SingleRasterMap( data = data.plot, raster = raster, limits = data.limits, cell.order = dim.cells, feature.order = dim.features ) } } if (fast) { par(mfrow = orig.par) return(invisible(x = NULL)) } if (combine) { plots <- CombinePlots( plots = plots, ncol = ncol, legend = 'right' ) } return(plots) } #' Feature expression heatmap #' #' Draws a heatmap of single cell feature expression. #' #' @param object Seurat object #' @param features A vector of features to plot, defaults to \code{VariableFeatures(object = object)} #' @param cells A vector of cells to plot #' @param disp.min Minimum display value (all values below are clipped) #' @param disp.max Maximum display value (all values above are clipped); defaults to 2.5 #' if \code{slot} is 'scale.data', 6 otherwise #' @param group.by A vector of variables to group cells by; pass 'ident' to group by cell identity classes #' @param group.bar Add a color bar showing group status for cells #' @param group.colors Colors to use for the color bar #' @param slot Data slot to use, choose from 'raw.data', 'data', or 'scale.data' #' @param assay Assay to pull from # @param check.plot Check that plotting will finish in a reasonable amount of time #' @param label Label the cell identies above the color bar #' @param size Size of text above color bar #' @param hjust Horizontal justification of text above color bar #' @param angle Angle of text above color bar #' @param raster If true, plot with geom_raster, else use geom_tile. geom_raster may look blurry on #' some viewing applications such as Preview due to how the raster is interpolated. Set this to FALSE #' if you are encountering that issue (note that plots may take longer to produce/render). #' @param draw.lines Include white lines to separate the groups #' @param lines.width Integer number to adjust the width of the separating white lines. #' Corresponds to the number of "cells" between each group. #' @param group.bar.height Scale the height of the color bar #' @param combine Combine plots into a single gg object; note that if TRUE; themeing will not work #' when plotting multiple dimensions #' #' @return A ggplot object #' #' @importFrom stats median #' @importFrom scales hue_pal #' @importFrom ggplot2 annotation_raster coord_cartesian scale_color_manual #' ggplot_build aes_string #' @export #' #' @examples #' DoHeatmap(object = pbmc_small) #' DoHeatmap <- function( object, features = NULL, cells = NULL, group.by = 'ident', group.bar = TRUE, group.colors = NULL, disp.min = -2.5, disp.max = NULL, slot = 'scale.data', assay = NULL, label = TRUE, size = 5.5, hjust = 0, angle = 45, raster = TRUE, draw.lines = TRUE, lines.width = NULL, group.bar.height = 0.02, combine = TRUE ) { cells <- cells %||% colnames(x = object) if (is.numeric(x = cells)) { cells <- colnames(x = object)[cells] } assay <- assay %||% DefaultAssay(object = object) DefaultAssay(object = object) <- assay features <- features %||% VariableFeatures(object = object) features <- rev(x = unique(x = features)) disp.max <- disp.max %||% ifelse( test = slot == 'scale.data', yes = 2.5, no = 6 ) # make sure features are present possible.features <- rownames(x = GetAssayData(object = object, slot = slot)) if (any(!features %in% possible.features)) { bad.features <- features[!features %in% possible.features] features <- features[features %in% possible.features] if(length(x = features) == 0) { stop("No requested features found in the ", slot, " slot for the ", assay, " assay.") } warning("The following features were omitted as they were not found in the ", slot, " slot for the ", assay, " assay: ", paste(bad.features, collapse = ", ")) } data <- as.data.frame(x = as.matrix(x = t(x = GetAssayData( object = object, slot = slot)[features, cells, drop = FALSE]))) object <- suppressMessages(expr = StashIdent(object = object, save.name = 'ident')) group.by <- group.by %||% 'ident' groups.use <- object[[group.by]][cells, , drop = FALSE] # group.use <- switch( # EXPR = group.by, # 'ident' = Idents(object = object), # object[[group.by, drop = TRUE]] # ) # group.use <- factor(x = group.use[cells]) plots <- vector(mode = 'list', length = ncol(x = groups.use)) for (i in 1:ncol(x = groups.use)) { data.group <- data group.use <- groups.use[, i, drop = TRUE] if (!is.factor(x = group.use)) { group.use <- factor(x = group.use) } names(x = group.use) <- cells if (draw.lines) { # create fake cells to serve as the white lines, fill with NAs lines.width <- lines.width %||% ceiling(x = nrow(x = data.group) * 0.0025) placeholder.cells <- sapply( X = 1:(length(x = levels(x = group.use)) * lines.width), FUN = function(x) { return(RandomName(length = 20)) } ) placeholder.groups <- rep(x = levels(x = group.use), times = lines.width) group.levels <- levels(x = group.use) names(x = placeholder.groups) <- placeholder.cells group.use <- as.vector(x = group.use) names(x = group.use) <- cells group.use <- factor(x = c(group.use, placeholder.groups), levels = group.levels) na.data.group <- matrix( data = NA, nrow = length(x = placeholder.cells), ncol = ncol(x = data.group), dimnames = list(placeholder.cells, colnames(x = data.group)) ) data.group <- rbind(data.group, na.data.group) } lgroup <- length(levels(group.use)) plot <- SingleRasterMap( data = data.group, raster = raster, disp.min = disp.min, disp.max = disp.max, feature.order = features, cell.order = names(x = sort(x = group.use)), group.by = group.use ) if (group.bar) { # TODO: Change group.bar to annotation.bar default.colors <- c(hue_pal()(length(x = levels(x = group.use)))) cols <- group.colors[1:length(x = levels(x = group.use))] %||% default.colors if (any(is.na(x = cols))) { cols[is.na(x = cols)] <- default.colors[is.na(x = cols)] cols <- Col2Hex(cols) col.dups <- sort(x = unique(x = which(x = duplicated(x = substr( x = cols, start = 1, stop = 7 ))))) through <- length(x = default.colors) while (length(x = col.dups) > 0) { pal.max <- length(x = col.dups) + through cols.extra <- hue_pal()(pal.max)[(through + 1):pal.max] cols[col.dups] <- cols.extra col.dups <- sort(x = unique(x = which(x = duplicated(x = substr( x = cols, start = 1, stop = 7 ))))) } } group.use2 <- sort(x = group.use) if (draw.lines) { na.group <- RandomName(length = 20) levels(x = group.use2) <- c(levels(x = group.use2), na.group) group.use2[placeholder.cells] <- na.group cols <- c(cols, "#FFFFFF") } pbuild <- ggplot_build(plot = plot) names(x = cols) <- levels(x = group.use2) # scale the height of the bar y.range <- diff(x = pbuild$layout$panel_params[[1]]$y.range) y.pos <- max(pbuild$layout$panel_params[[1]]$y.range) + y.range * 0.015 y.max <- y.pos + group.bar.height * y.range plot <- plot + annotation_raster( raster = t(x = cols[group.use2]), xmin = -Inf, xmax = Inf, ymin = y.pos, ymax = y.max ) + coord_cartesian(ylim = c(0, y.max), clip = 'off') + scale_color_manual(values = cols) if (label) { x.max <- max(pbuild$layout$panel_params[[1]]$x.range) x.divs <- pbuild$layout$panel_params[[1]]$x.major x <- data.frame(group = sort(x = group.use), x = x.divs) label.x.pos <- tapply(X = x$x, INDEX = x$group, FUN = median) * x.max label.x.pos <- data.frame(group = names(x = label.x.pos), label.x.pos) plot <- plot + geom_text( stat = "identity", data = label.x.pos, aes_string(label = 'group', x = 'label.x.pos'), y = y.max + y.max * 0.03 * 0.5, angle = angle, hjust = hjust, size = size ) plot <- suppressMessages(plot + coord_cartesian( ylim = c(0, y.max + y.max * 0.002 * max(nchar(x = levels(x = group.use))) * size), clip = 'off') ) } } plot <- plot + theme(line = element_blank()) plots[[i]] <- plot } if (combine) { plots <- CombinePlots(plots = plots) } return(plots) } #' Hashtag oligo heatmap #' #' Draws a heatmap of hashtag oligo signals across singlets/doublets/negative cells. Allows for the visualization of HTO demultiplexing results. #' #' @param object Seurat object. Assumes that the hash tag oligo (HTO) data has been added and normalized, and demultiplexing has been run with HTODemux(). #' @param classification The naming for metadata column with classification result from HTODemux(). #' @param global.classification The slot for metadata column specifying a cell as singlet/doublet/negative. #' @param assay Hashtag assay name. #' @param ncells Number of cells to plot. Default is to choose 5000 cells by random subsampling, to avoid having to draw exceptionally large heatmaps. #' @param singlet.names Namings for the singlets. Default is to use the same names as HTOs. #' @param raster If true, plot with geom_raster, else use geom_tile. geom_raster may look blurry on #' some viewing applications such as Preview due to how the raster is interpolated. Set this to FALSE #' if you are encountering that issue (note that plots may take longer to produce/render). #' @return Returns a ggplot2 plot object. #' #' @importFrom ggplot2 guides #' @export #' #' @seealso \code{\link{HTODemux}} #' #' @examples #' \dontrun{ #' object <- HTODemux(object) #' HTOHeatmap(object) #' } #' HTOHeatmap <- function( object, assay = 'HTO', classification = paste0(assay, '_classification'), global.classification = paste0(assay, '_classification.global'), ncells = 5000, singlet.names = NULL, raster = TRUE ) { DefaultAssay(object = object) <- assay Idents(object = object) <- object[[classification, drop = TRUE]] if (ncells > ncol(x = object)) { warning("ncells (", ncells, ") is larger than the number of cells present in the provided object (", ncol(x = object), "). Plotting heatmap for all cells.") } else { object <- subset( x = object, cells = sample(x = colnames(x = object), size = ncells) ) } classification <- object[[classification]] singlets <- which(x = object[[global.classification]] == 'Singlet') singlet.ids <- sort(x = unique(x = as.character(x = classification[singlets, ]))) doublets <- which(object[[global.classification]] == 'Doublet') doublet.ids <- sort(x = unique(x = as.character(x = classification[doublets, ]))) heatmap.levels <- c(singlet.ids, doublet.ids, 'Negative') object <- ScaleData(object = object, assay = assay, verbose = FALSE) data <- FetchData(object = object, vars = singlet.ids) Idents(object = object) <- factor(x = classification[, 1], levels = heatmap.levels) plot <- SingleRasterMap( data = data, raster = raster, feature.order = rev(x = singlet.ids), cell.order = names(x = sort(x = Idents(object = object))), group.by = Idents(object = object) ) + guides(color = FALSE) return(plot) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Expression by identity plots #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' Single cell ridge plot #' #' Draws a ridge plot of single cell data (gene expression, metrics, PC #' scores, etc.) #' #' @param object Seurat object #' @param features Features to plot (gene expression, metrics, PC scores, #' anything that can be retreived by FetchData) #' @param cols Colors to use for plotting #' @param idents Which classes to include in the plot (default is all) #' @param sort Sort identity classes (on the x-axis) by the average #' expression of the attribute being potted, can also pass 'increasing' or 'decreasing' to change sort direction #' @param assay Name of assay to use, defaults to the active assay #' @param group.by Group (color) cells in different ways (for example, orig.ident) #' @param y.max Maximum y axis value #' @param same.y.lims Set all the y-axis limits to the same values #' @param log plot the feature axis on log scale #' @param ncol Number of columns if multiple plots are displayed #' @param combine Combine plots into a single gg object; note that if TRUE; themeing will not work when plotting multiple features #' @param slot Use non-normalized counts data for plotting #' @param ... Extra parameters passed on to \code{\link{CombinePlots}} #' #' @return A ggplot object #' #' @export #' #' @examples #' RidgePlot(object = pbmc_small, features = 'PC_1') #' RidgePlot <- function( object, features, cols = NULL, idents = NULL, sort = FALSE, assay = NULL, group.by = NULL, y.max = NULL, same.y.lims = FALSE, log = FALSE, ncol = NULL, combine = TRUE, slot = 'data', ... ) { return(ExIPlot( object = object, type = 'ridge', features = features, idents = idents, ncol = ncol, sort = sort, assay = assay, y.max = y.max, same.y.lims = same.y.lims, cols = cols, group.by = group.by, log = log, combine = combine, slot = slot, ... )) } #' Single cell violin plot #' #' Draws a violin plot of single cell data (gene expression, metrics, PC #' scores, etc.) #' #' @inheritParams RidgePlot #' @param pt.size Point size for geom_violin #' @param split.by A variable to split the violin plots by, #' @param multi.group plot each group of the split violin plots by multiple or single violin shapes #' see \code{\link{FetchData}} for more details #' @param adjust Adjust parameter for geom_violin #' #' @return A ggplot object #' #' @export #' #' @seealso \code{\link{FetchData}} #' #' @examples #' VlnPlot(object = pbmc_small, features = 'PC_1') #' VlnPlot(object = pbmc_small, features = 'LYZ', split.by = 'groups') #' VlnPlot <- function( object, features, cols = NULL, pt.size = 1, idents = NULL, sort = FALSE, assay = NULL, group.by = NULL, split.by = NULL, adjust = 1, y.max = NULL, same.y.lims = FALSE, log = FALSE, ncol = NULL, combine = TRUE, slot = 'data', multi.group = FALSE, ... ) { return(ExIPlot( object = object, type = ifelse(test = multi.group, yes = 'multiViolin', no = 'violin'), features = features, idents = idents, ncol = ncol, sort = sort, assay = assay, y.max = y.max, same.y.lims = same.y.lims, adjust = adjust, pt.size = pt.size, cols = cols, group.by = group.by, split.by = split.by, log = log, slot = slot, combine = combine, ... )) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Dimensional reduction plots #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' Color dimensional reduction plot by tree split #' #' Returns a DimPlot colored based on whether the cells fall in clusters #' to the left or to the right of a node split in the cluster tree. #' #' @param object Seurat object #' @param node Node in cluster tree on which to base the split #' @param left.color Color for the left side of the split #' @param right.color Color for the right side of the split #' @param other.color Color for all other cells #' @inheritDotParams DimPlot -object #' #' @return Returns a DimPlot #' #' @export #' #' @examples #' pbmc_small #' pbmc_small <- BuildClusterTree(object = pbmc_small, verbose = FALSE) #' PlotClusterTree(pbmc_small) #' ColorDimSplit(pbmc_small, node = 5) #' ColorDimSplit <- function( object, node, left.color = 'red', right.color = 'blue', other.color = 'grey50', ... ) { CheckDots(..., fxns = 'DimPlot') tree <- Tool(object = object, slot = "BuildClusterTree") split <- tree$edge[which(x = tree$edge[, 1] == node), ][, 2] all.children <- sort(x = tree$edge[, 2][! tree$edge[, 2] %in% tree$edge[, 1]]) left.group <- DFT(tree = tree, node = split[1], only.children = TRUE) right.group <- DFT(tree = tree, node = split[2], only.children = TRUE) if (any(is.na(x = left.group))) { left.group <- split[1] } if (any(is.na(x = right.group))) { right.group <- split[2] } left.group <- MapVals(v = left.group, from = all.children, to = tree$tip.label) right.group <- MapVals(v = right.group, from = all.children, to = tree$tip.label) remaining.group <- setdiff(x = tree$tip.label, y = c(left.group, right.group)) left.cells <- WhichCells(object = object, ident = left.group) right.cells <- WhichCells(object = object, ident = right.group) remaining.cells <- WhichCells(object = object, ident = remaining.group) object <- SetIdent( object = object, cells = left.cells, value = "Left Split" ) object <- SetIdent( object = object, cells = right.cells, value = "Right Split" ) object <- SetIdent( object = object, cells = remaining.cells, value = "Not in Split" ) levels(x = object) <- c("Left Split", "Right Split", "Not in Split") colors.use = c(left.color, right.color, other.color) return(DimPlot(object = object, cols = colors.use, ...)) } #' Dimensional reduction plot #' #' Graphs the output of a dimensional reduction technique on a 2D scatter plot where each point is a #' cell and it's positioned based on the cell embeddings determined by the reduction technique. By #' default, cells are colored by their identity class (can be changed with the group.by parameter). #' #' @param object Seurat object #' @param dims Dimensions to plot, must be a two-length numeric vector specifying x- and y-dimensions #' @param cells Vector of cells to plot (default is all cells) #' @param cols Vector of colors, each color corresponds to an identity class. This may also be a single character #' or numeric value corresponding to a palette as specified by \code{\link[RColorBrewer]{brewer.pal.info}}. #' By default, ggplot2 assigns colors. We also include a number of palettes from the pals package. #' See \code{\link{DiscretePalette}} for details. #' @param pt.size Adjust point size for plotting #' @param reduction Which dimensionality reduction to use. If not specified, first searches for umap, then tsne, then pca #' @param group.by Name of one or more metadata columns to group (color) cells by #' (for example, orig.ident); pass 'ident' to group by identity class #' @param split.by Name of a metadata column to split plot by; #' see \code{\link{FetchData}} for more details #' @param shape.by If NULL, all points are circles (default). You can specify any #' cell attribute (that can be pulled with FetchData) allowing for both #' different colors and different shapes on cells #' @param order Specify the order of plotting for the idents. This can be #' useful for crowded plots if points of interest are being buried. Provide #' either a full list of valid idents or a subset to be plotted last (on top) #' @param label Whether to label the clusters #' @param label.size Sets size of labels #' @param repel Repel labels #' @param cells.highlight A list of character or numeric vectors of cells to #' highlight. If only one group of cells desired, can simply #' pass a vector instead of a list. If set, colors selected cells to the color(s) #' in \code{cols.highlight} and other cells black (white if dark.theme = TRUE); #' will also resize to the size(s) passed to \code{sizes.highlight} #' @param cols.highlight A vector of colors to highlight the cells as; will #' repeat to the length groups in cells.highlight #' @param sizes.highlight Size of highlighted cells; will repeat to the length #' groups in cells.highlight #' @param na.value Color value for NA points when using custom scale #' @param combine Combine plots into a single gg object; note that if TRUE; themeing will not work when plotting multiple features #' @param ncol Number of columns for display when combining plots #' @param ... Extra parameters passed on to \code{\link{CombinePlots}} #' #' @return A ggplot object #' #' @importFrom rlang !! #' @importFrom ggplot2 facet_wrap vars sym #' #' @export #' #' @note For the old \code{do.hover} and \code{do.identify} functionality, please see #' \code{HoverLocator} and \code{CellSelector}, respectively. #' #' @aliases TSNEPlot PCAPlot ICAPlot #' @seealso \code{\link{FeaturePlot}} \code{\link{HoverLocator}} #' \code{\link{CellSelector}} \code{link{FetchData}} #' #' @examples #' DimPlot(object = pbmc_small) #' DimPlot(object = pbmc_small, split.by = 'ident') #' DimPlot <- function( object, dims = c(1, 2), cells = NULL, cols = NULL, pt.size = NULL, reduction = NULL, group.by = NULL, split.by = NULL, shape.by = NULL, order = NULL, label = FALSE, label.size = 4, repel = FALSE, cells.highlight = NULL, cols.highlight = '#DE2D26', sizes.highlight = 1, na.value = 'grey50', combine = TRUE, ncol = NULL, ... ) { CheckDots(..., fxns = 'CombinePlots') if (length(x = dims) != 2) { stop("'dims' must be a two-length vector") } reduction <- reduction %||% DefaultDimReduc(object = object) cells <- cells %||% colnames(x = object) data <- Embeddings(object = object[[reduction]])[cells, dims] data <- as.data.frame(x = data) dims <- paste0(Key(object = object[[reduction]]), dims) object[['ident']] <- Idents(object = object) group.by <- group.by %||% 'ident' data[, group.by] <- object[[group.by]][cells, , drop = FALSE] for (group in group.by) { if (!is.factor(x = data[, group])) { data[, group] <- factor(x = data[, group]) } } if (!is.null(x = shape.by)) { data[, shape.by] <- object[[shape.by, drop = TRUE]] } if (!is.null(x = split.by)) { data[, split.by] <- object[[split.by, drop = TRUE]] } plots <- lapply( X = group.by, FUN = function(x) { plot <- SingleDimPlot( data = data[, c(dims, x, split.by, shape.by)], dims = dims, col.by = x, cols = cols, pt.size = pt.size, shape.by = shape.by, order = order, label = FALSE, cells.highlight = cells.highlight, cols.highlight = cols.highlight, sizes.highlight = sizes.highlight, na.value = na.value ) if (label) { plot <- LabelClusters( plot = plot, id = x, repel = repel, size = label.size, split.by = split.by ) } if (!is.null(x = split.by)) { plot <- plot + FacetTheme() + facet_wrap( facets = vars(!!sym(x = split.by)), ncol = if (length(x = group.by) > 1 || is.null(x = ncol)) { length(x = unique(x = data[, split.by])) } else { ncol } ) } return(plot) } ) if (combine) { plots <- CombinePlots( plots = plots, ncol = if (!is.null(x = split.by) && length(x = group.by) > 1) { 1 } else { ncol }, ... ) } return(plots) } #' Visualize 'features' on a dimensional reduction plot #' #' Colors single cells on a dimensional reduction plot according to a 'feature' #' (i.e. gene expression, PC scores, number of genes detected, etc.) #' #' @inheritParams DimPlot #' @param order Boolean determining whether to plot cells in order of expression. Can be useful if #' cells expressing given feature are getting buried. #' @param features Vector of features to plot. Features can come from: #' \itemize{ #' \item An \code{Assay} feature (e.g. a gene name - "MS4A1") #' \item A column name from meta.data (e.g. mitochondrial percentage - "percent.mito") #' \item A column name from a \code{DimReduc} object corresponding to the cell embedding values #' (e.g. the PC 1 scores - "PC_1") #' } #' @param cols The two colors to form the gradient over. Provide as string vector with #' the first color corresponding to low values, the second to high. Also accepts a Brewer #' color scale or vector of colors. Note: this will bin the data into number of colors provided. #' When blend is \code{TRUE}, takes anywhere from 1-3 colors: #' \describe{ #' \item{1 color:}{Treated as color for double-negatives, will use default colors 2 and 3 for per-feature expression} #' \item{2 colors:}{Treated as colors for per-feature expression, will use default color 1 for double-negatives} #' \item{3+ colors:}{First color used for double-negatives, colors 2 and 3 used for per-feature expression, all others ignored} #' } #' @param min.cutoff,max.cutoff Vector of minimum and maximum cutoff values for each feature, #' may specify quantile in the form of 'q##' where '##' is the quantile (eg, 'q1', 'q10') #' @param split.by A factor in object metadata to split the feature plot by, pass 'ident' #' to split by cell identity'; similar to the old \code{FeatureHeatmap} #' @param slot Which slot to pull expression data from? #' @param blend Scale and blend expression values to visualize coexpression of two features #' @param blend.threshold The color cutoff from weak signal to strong signal; ranges from 0 to 1. #' @param ncol Number of columns to combine multiple feature plots to, ignored if \code{split.by} is not \code{NULL} #' @param combine Combine plots into a single gg object; note that if \code{TRUE}; themeing will not work when plotting multiple features #' @param coord.fixed Plot cartesian coordinates with fixed aspect ratio #' @param by.col If splitting by a factor, plot the splits per column with the features as rows; ignored if \code{blend = TRUE} #' @param sort.cell If \code{TRUE}, the positive cells will overlap the negative cells #' #' @return Returns a ggplot object if only 1 feature is plotted. #' If >1 features are plotted and \code{combine=TRUE}, returns a combined ggplot object using \code{cowplot::plot_grid}. #' If >1 features are plotted and \code{combine=FALSE}, returns a list of ggplot objects. #' #' @importFrom grDevices rgb #' @importFrom cowplot theme_cowplot #' @importFrom RColorBrewer brewer.pal.info #' @importFrom ggplot2 labs scale_x_continuous scale_y_continuous theme element_rect #' dup_axis guides element_blank element_text margin scale_color_brewer scale_color_gradientn #' scale_color_manual coord_fixed ggtitle #' #' @export #' #' @note For the old \code{do.hover} and \code{do.identify} functionality, please see #' \code{HoverLocator} and \code{CellSelector}, respectively. #' #' @aliases FeatureHeatmap #' @seealso \code{\link{DimPlot}} \code{\link{HoverLocator}} #' \code{\link{CellSelector}} #' #' @examples #' FeaturePlot(object = pbmc_small, features = 'PC_1') #' FeaturePlot <- function( object, features, dims = c(1, 2), cells = NULL, cols = if (blend) { c('lightgrey', '#ff0000', '#00ff00') } else { c('lightgrey', 'blue') }, pt.size = NULL, order = FALSE, min.cutoff = NA, max.cutoff = NA, reduction = NULL, split.by = NULL, shape.by = NULL, slot = 'data', blend = FALSE, blend.threshold = 0.5, label = FALSE, label.size = 4, repel = FALSE, ncol = NULL, combine = TRUE, coord.fixed = FALSE, by.col = TRUE, sort.cell = FALSE ) { # Set a theme to remove right-hand Y axis lines # Also sets right-hand Y axis text label formatting no.right <- theme( axis.line.y.right = element_blank(), axis.ticks.y.right = element_blank(), axis.text.y.right = element_blank(), axis.title.y.right = element_text( face = "bold", size = 14, margin = margin(r = 7) ) ) # Get the DimReduc to use reduction <- reduction %||% DefaultDimReduc(object = object) if (length(x = dims) != 2 || !is.numeric(x = dims)) { stop("'dims' must be a two-length integer vector") } # Figure out blending stuff if (blend && length(x = features) != 2) { stop("Blending feature plots only works with two features") } # Set color scheme for blended FeaturePlots if (blend) { default.colors <- eval(expr = formals(fun = FeaturePlot)$cols) cols <- switch( EXPR = as.character(x = length(x = cols)), '0' = { warning( "No colors provided, using default colors", call. = FALSE, immediate. = TRUE ) default.colors }, '1' = { warning( "Only one color provided, assuming specified is double-negative and augmenting with default colors", call. = FALSE, immediate. = TRUE ) c(cols, default.colors[2:3]) }, '2' = { warning( "Only two colors provided, assuming specified are for features and agumenting with '", default.colors[1], "' for double-negatives", call. = FALSE, immediate. = TRUE ) c(default.colors[1], cols) }, '3' = cols, { warning( "More than three colors provided, using only first three", call. = FALSE, immediate. = TRUE ) cols[1:3] } ) } if (blend && length(x = cols) != 3) { stop("Blending feature plots only works with three colors; first one for negative cells") } # Name the reductions dims <- paste0(Key(object = object[[reduction]]), dims) cells <- cells %||% colnames(x = object) # Get plotting data data <- FetchData( object = object, vars = c(dims, 'ident', features), cells = cells, slot = slot ) # Check presence of features/dimensions if (ncol(x = data) < 4) { stop( "None of the requested features were found: ", paste(features, collapse = ', '), " in slot ", slot, call. = FALSE ) } else if (!all(dims %in% colnames(x = data))) { stop("The dimensions requested were not found", call. = FALSE) } features <- colnames(x = data)[4:ncol(x = data)] # Determine cutoffs min.cutoff <- mapply( FUN = function(cutoff, feature) { return(ifelse( test = is.na(x = cutoff), yes = min(data[, feature]), no = cutoff )) }, cutoff = min.cutoff, feature = features ) max.cutoff <- mapply( FUN = function(cutoff, feature) { return(ifelse( test = is.na(x = cutoff), yes = max(data[, feature]), no = cutoff )) }, cutoff = max.cutoff, feature = features ) check.lengths <- unique(x = vapply( X = list(features, min.cutoff, max.cutoff), FUN = length, FUN.VALUE = numeric(length = 1) )) if (length(x = check.lengths) != 1) { stop("There must be the same number of minimum and maximum cuttoffs as there are features") } brewer.gran <- ifelse( test = length(x = cols) == 1, yes = brewer.pal.info[cols, ]$maxcolors, no = length(x = cols) ) # Apply cutoffs data[, 4:ncol(x = data)] <- sapply( X = 4:ncol(x = data), FUN = function(index) { data.feature <- as.vector(x = data[, index]) min.use <- SetQuantile(cutoff = min.cutoff[index - 3], data.feature) max.use <- SetQuantile(cutoff = max.cutoff[index - 3], data.feature) data.feature[data.feature < min.use] <- min.use data.feature[data.feature > max.use] <- max.use if (brewer.gran == 2) { return(data.feature) } data.cut <- if (all(data.feature == 0)) { 0 } else { as.numeric(x = as.factor(x = cut( x = as.numeric(x = data.feature), breaks = brewer.gran ))) } return(data.cut) } ) colnames(x = data)[4:ncol(x = data)] <- features rownames(x = data) <- cells # Figure out splits (FeatureHeatmap) data$split <- if (is.null(x = split.by)) { RandomName() } else { switch( EXPR = split.by, ident = Idents(object = object)[cells], object[[split.by, drop = TRUE]][cells] ) } if (!is.factor(x = data$split)) { data$split <- factor(x = data$split) } # Set shaping variable if (!is.null(x = shape.by)) { data[, shape.by] <- object[[shape.by, drop = TRUE]] } # Make list of plots plots <- vector( mode = "list", length = ifelse( test = blend, yes = 4, no = length(x = features) * length(x = levels(x = data$split)) ) ) # Apply common limits xlims <- c(floor(x = min(data[, dims[1]])), ceiling(x = max(data[, dims[1]]))) ylims <- c(floor(min(data[, dims[2]])), ceiling(x = max(data[, dims[2]]))) # Set blended colors if (blend) { ncol <- 4 color.matrix <- BlendMatrix( two.colors = cols[2:3], col.threshold = blend.threshold, negative.color = cols[1] ) cols <- cols[2:3] colors <- list( color.matrix[, 1], color.matrix[1, ], as.vector(x = color.matrix) ) } # Make the plots for (i in 1:length(x = levels(x = data$split))) { # Figre out which split we're working with ident <- levels(x = data$split)[i] data.plot <- data[as.character(x = data$split) == ident, , drop = FALSE] # Blend expression values if (blend) { features <- features[1:2] no.expression <- features[colMeans(x = data.plot[, features]) == 0] if (length(x = no.expression) != 0) { stop( "The following features have no value: ", paste(no.expression, collapse = ', '), call. = FALSE ) } data.plot <- cbind(data.plot[, c(dims, 'ident')], BlendExpression(data = data.plot[, features[1:2]])) features <- colnames(x = data.plot)[4:ncol(x = data.plot)] } # Make per-feature plots for (j in 1:length(x = features)) { feature <- features[j] # Get blended colors if (blend) { cols.use <- as.numeric(x = as.character(x = data.plot[, feature])) + 1 cols.use <- colors[[j]][sort(x = unique(x = cols.use))] } else { cols.use <- NULL } data.single <- data.plot[, c(dims, 'ident', feature, shape.by)] if (sort.cell) { data.single <- data.single[order(data.single[, feature]),] } # Make the plot plot <- SingleDimPlot( data = data.single, dims = dims, col.by = feature, order = order, pt.size = pt.size, cols = cols.use, shape.by = shape.by, label = FALSE ) + scale_x_continuous(limits = xlims) + scale_y_continuous(limits = ylims) + theme_cowplot() + theme(plot.title = element_text(hjust = 0.5)) # Add labels if (label) { plot <- LabelClusters( plot = plot, id = 'ident', repel = repel, size = label.size ) } # Make FeatureHeatmaps look nice(ish) if (length(x = levels(x = data$split)) > 1) { plot <- plot + theme(panel.border = element_rect(fill = NA, colour = 'black')) # Add title plot <- plot + if (i == 1) { labs(title = feature) } else { labs(title = NULL) } # Add second axis if (j == length(x = features) && !blend) { suppressMessages( expr = plot <- plot + scale_y_continuous(sec.axis = dup_axis(name = ident)) + no.right ) } # Remove left Y axis if (j != 1) { plot <- plot + theme( axis.line.y = element_blank(), axis.ticks.y = element_blank(), axis.text.y = element_blank(), axis.title.y.left = element_blank() ) } # Remove bottom X axis if (i != length(x = levels(x = data$split))) { plot <- plot + theme( axis.line.x = element_blank(), axis.ticks.x = element_blank(), axis.text.x = element_blank(), axis.title.x = element_blank() ) } } else { plot <- plot + labs(title = feature) } # Add colors scale for normal FeaturePlots if (!blend) { plot <- plot + guides(color = NULL) cols.grad <- cols if (length(x = cols) == 1) { plot <- plot + scale_color_brewer(palette = cols) } else if (length(x = cols) > 1) { unique.feature.exp <- unique(data.plot[, feature]) if (length(unique.feature.exp) == 1) { warning("All cells have the same value (", unique.feature.exp, ") of ", feature, ".") if (unique.feature.exp == 0) { cols.grad <- cols[1] } else{ cols.grad <- cols } } plot <- suppressMessages( expr = plot + scale_color_gradientn( colors = cols.grad, guide = "colorbar" ) ) } } # Add coord_fixed if (coord.fixed) { plot <- plot + coord_fixed() } # I'm not sure why, but sometimes the damn thing fails without this # Thanks ggplot2 plot <- plot # Place the plot plots[[(length(x = features) * (i - 1)) + j]] <- plot } } # Add blended color key if (blend) { blend.legend <- BlendMap(color.matrix = color.matrix) for (ii in 1:length(x = levels(x = data$split))) { suppressMessages(expr = plots <- append( x = plots, values = list( blend.legend + scale_y_continuous( sec.axis = dup_axis(name = ifelse( test = length(x = levels(x = data$split)) > 1, yes = levels(x = data$split)[ii], no = '' )), expand = c(0, 0) ) + labs( x = features[1], y = features[2], title = if (ii == 1) { paste('Color threshold:', blend.threshold) } else { NULL } ) + no.right ), after = 4 * ii - 1 )) } } # Remove NULL plots plots <- Filter(f = Negate(f = is.null), x = plots) # Combine the plots if (combine) { if (is.null(x = ncol)) { ncol <- 2 if (length(x = features) == 1) { ncol <- 1 } if (length(x = features) > 6) { ncol <- 3 } if (length(x = features) > 9) { ncol <- 4 } } ncol <- ifelse( test = is.null(x = split.by) || blend, yes = ncol, no = length(x = features) ) legend <- if (blend) { 'none' } else { split.by %iff% 'none' } # Transpose the FeatureHeatmap matrix (not applicable for blended FeaturePlots) if (by.col && !is.null(x = split.by) && !blend) { plots <- lapply( X = plots, FUN = function(x) { return(suppressMessages( expr = x + theme_cowplot() + ggtitle("") + scale_y_continuous(sec.axis = dup_axis(name = "")) + no.right )) } ) nsplits <- length(x = levels(x = data$split)) idx <- 1 for (i in (length(x = features) * (nsplits - 1) + 1):(length(x = features) * nsplits)) { plots[[i]] <- suppressMessages(plots[[i]] + scale_y_continuous(sec.axis = dup_axis(name = features[[idx]])) + no.right) idx <- idx + 1 } idx <- 1 for (i in which(x = 1:length(x = plots) %% length(x = features) == 1)) { plots[[i]] <- plots[[i]] + ggtitle(levels(x = data$split)[[idx]]) + theme(plot.title = element_text(hjust = 0.5)) idx <- idx + 1 } idx <- 1 if (length(x = features) == 1) { for (i in 1:length(x = plots)) { plots[[i]] <- plots[[i]] + ggtitle(levels(x = data$split)[[idx]]) + theme(plot.title = element_text(hjust = 0.5)) idx <- idx + 1 } } plots <- plots[c(do.call( what = rbind, args = split(x = 1:length(x = plots), f = ceiling(x = seq_along(along.with = 1:length(x = plots))/length(x = features))) ))] plots <- CombinePlots( plots = plots, ncol = nsplits, legend = legend ) } else { plots <- CombinePlots( plots = plots, ncol = ncol, legend = legend, nrow = split.by %iff% length(x = levels(x = data$split)) ) } } return(plots) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Scatter plots #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' Cell-cell scatter plot #' #' Creates a plot of scatter plot of features across two single cells. Pearson #' correlation between the two cells is displayed above the plot. #' #' @inheritParams FeatureScatter #' @param cell1 Cell 1 name #' @param cell2 Cell 2 name #' @param features Features to plot (default, all features) #' @param highlight Features to highlight #' @return A ggplot object #' #' @export #' #' @aliases CellPlot #' #' @examples #' CellScatter(object = pbmc_small, cell1 = 'ATAGGAGAAACAGA', cell2 = 'CATCAGGATGCACA') #' CellScatter <- function( object, cell1, cell2, features = NULL, highlight = NULL, cols = NULL, pt.size = 1, smooth = FALSE ) { features <- features %||% rownames(x = object) data <- FetchData( object = object, vars = features, cells = c(cell1, cell2) ) data <- as.data.frame(x = t(x = data)) plot <- SingleCorPlot( data = data, cols = cols, pt.size = pt.size, rows.highlight = highlight, smooth = smooth ) return(plot) } #' Scatter plot of single cell data #' #' Creates a scatter plot of two features (typically feature expression), across a #' set of single cells. Cells are colored by their identity class. Pearson #' correlation between the two features is displayed above the plot. #' #' @param object Seurat object #' @param feature1 First feature to plot. Typically feature expression but can also #' be metrics, PC scores, etc. - anything that can be retreived with FetchData #' @param feature2 Second feature to plot. #' @param cells Cells to include on the scatter plot. #' @param group.by Name of one or more metadata columns to group (color) cells by #' (for example, orig.ident); pass 'ident' to group by identity class #' @param cols Colors to use for identity class plotting. #' @param pt.size Size of the points on the plot #' @param shape.by Ignored for now #' @param span Spline span in loess function call, if \code{NULL}, no spline added #' @param smooth Smooth the graph (similar to smoothScatter) #' @param slot Slot to pull data from, should be one of 'counts', 'data', or 'scale.data' #' #' @return A ggplot object #' #' @importFrom ggplot2 geom_smooth aes_string #' @export #' #' @aliases GenePlot #' #' @examples #' FeatureScatter(object = pbmc_small, feature1 = 'CD9', feature2 = 'CD3E') #' FeatureScatter <- function( object, feature1, feature2, cells = NULL, group.by = NULL, cols = NULL, pt.size = 1, shape.by = NULL, span = NULL, smooth = FALSE, slot = 'data' ) { cells <- cells %||% colnames(x = object) group.by <- group.by %||% Idents(object = object)[cells] if (length(x = group.by) == 1) { group.by <- object[[]][, group.by] } plot <- SingleCorPlot( data = FetchData( object = object, vars = c(feature1, feature2), cells = cells, slot = slot ), col.by = group.by, cols = cols, pt.size = pt.size, smooth = smooth, legend.title = 'Identity', span = span ) return(plot) } #' View variable features #' #' @inheritParams FeatureScatter #' @inheritParams HVFInfo #' @param cols Colors to specify non-variable/variable status #' @param assay Assay to pull variable features from #' @param log Plot the x-axis in log scale #' #' @return A ggplot object #' #' @importFrom ggplot2 labs scale_color_manual scale_x_log10 #' @export #' #' @aliases VariableGenePlot MeanVarPlot #' #' @seealso \code{\link{FindVariableFeatures}} #' #' @examples #' VariableFeaturePlot(object = pbmc_small) #' VariableFeaturePlot <- function( object, cols = c('black', 'red'), pt.size = 1, log = NULL, selection.method = NULL, assay = NULL ) { if (length(x = cols) != 2) { stop("'cols' must be of length 2") } hvf.info <- HVFInfo( object = object, assay = assay, selection.method = selection.method, status = TRUE ) var.status <- c('no', 'yes')[unlist(x = hvf.info[, ncol(x = hvf.info)]) + 1] hvf.info <- hvf.info[, c(1, 3)] axis.labels <- switch( EXPR = colnames(x = hvf.info)[2], 'variance.standardized' = c('Average Expression', 'Standardized Variance'), 'dispersion.scaled' = c('Average Expression', 'Dispersion'), 'residual_variance' = c('Geometric Mean of Expression', 'Residual Variance') ) log <- log %||% (any(c('variance.standardized', 'residual_variance') %in% colnames(x = hvf.info))) # var.features <- VariableFeatures(object = object, assay = assay) # var.status <- ifelse( # test = rownames(x = hvf.info) %in% var.features, # yes = 'yes', # no = 'no' # ) plot <- SingleCorPlot( data = hvf.info, col.by = var.status, pt.size = pt.size ) plot <- plot + labs(title = NULL, x = axis.labels[1], y = axis.labels[2]) + scale_color_manual( labels = paste(c('Non-variable', 'Variable'), 'count:', table(var.status)), values = cols ) if (log) { plot <- plot + scale_x_log10() } return(plot) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Polygon Plots #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' Polygon DimPlot #' #' Plot cells as polygons, rather than single points. Color cells by identity, or a categorical variable #' in metadata #' #' @inheritParams PolyFeaturePlot #' @param group.by A grouping variable present in the metadata. Default is to use the groupings present #' in the current cell identities (\code{Idents(object = object)}) #' #' @return Returns a ggplot object #' #' @export #' PolyDimPlot <- function( object, group.by = NULL, cells = NULL, poly.data = 'spatial', flip.coords = FALSE ) { polygons <- Misc(object = object, slot = poly.data) if (is.null(x = polygons)) { stop("Could not find polygon data in misc slot") } group.by <- group.by %||% 'ident' group.data <- FetchData( object = object, vars = group.by, cells = cells ) group.data$cell <- rownames(x = group.data) data <- merge(x = polygons, y = group.data, by = 'cell') if (flip.coords) { coord.x <- data$x data$x <- data$y data$y <- coord.x } plot <- SinglePolyPlot(data = data, group.by = group.by) return(plot) } #' Polygon FeaturePlot #' #' Plot cells as polygons, rather than single points. Color cells by any value accessible by \code{\link{FetchData}}. #' #' @inheritParams FeaturePlot #' @param poly.data Name of the polygon dataframe in the misc slot #' @param ncol Number of columns to split the plot into #' @param common.scale ... #' @param flip.coords Flip x and y coordinates #' #' @return Returns a ggplot object #' #' @importFrom ggplot2 scale_fill_viridis_c facet_wrap #' #' @export #' PolyFeaturePlot <- function( object, features, cells = NULL, poly.data = 'spatial', ncol = ceiling(x = length(x = features) / 2), min.cutoff = 0, max.cutoff = NA, common.scale = TRUE, flip.coords = FALSE ) { polygons <- Misc(object = object, slot = poly.data) if (is.null(x = polygons)) { stop("Could not find polygon data in misc slot") } assay.data <- FetchData( object = object, vars = features, cells = cells ) features <- colnames(x = assay.data) cells <- rownames(x = assay.data) min.cutoff <- mapply( FUN = function(cutoff, feature) { return(ifelse( test = is.na(x = cutoff), yes = min(assay.data[, feature]), no = cutoff )) }, cutoff = min.cutoff, feature = features ) max.cutoff <- mapply( FUN = function(cutoff, feature) { return(ifelse( test = is.na(x = cutoff), yes = max(assay.data[, feature]), no = cutoff )) }, cutoff = max.cutoff, feature = features ) check.lengths <- unique(x = vapply( X = list(features, min.cutoff, max.cutoff), FUN = length, FUN.VALUE = numeric(length = 1) )) if (length(x = check.lengths) != 1) { stop("There must be the same number of minimum and maximum cuttoffs as there are features") } assay.data <- mapply( FUN = function(feature, min, max) { return(ScaleColumn(vec = assay.data[, feature], cutoffs = c(min, max))) }, feature = features, min = min.cutoff, max = max.cutoff ) if (common.scale) { assay.data <- apply( X = assay.data, MARGIN = 2, FUN = function(x) { return(x - min(x)) } ) assay.data <- t( x = t(x = assay.data) / apply(X = assay.data, MARGIN = 2, FUN = max) ) } assay.data <- as.data.frame(x = assay.data) assay.data <- data.frame( cell = as.vector(x = replicate(n = length(x = features), expr = cells)), feature = as.vector(x = t(x = replicate(n = length(x = cells), expr = features))), expression = unlist(x = assay.data, use.names = FALSE) ) data <- merge(x = polygons, y = assay.data, by = 'cell') data$feature <- factor(x = data$feature, levels = features) if (flip.coords) { coord.x <- data$x data$x <- data$y data$y <- coord.x } plot <- SinglePolyPlot(data = data, group.by = 'expression', font_size = 8) + scale_fill_viridis_c() + facet_wrap(facets = 'feature', ncol = ncol) return(plot) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Other plotting functions #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' ALRA Approximate Rank Selection Plot #' #' Plots the results of the approximate rank selection process for ALRA. #' #' @note ALRAChooseKPlot and associated functions are being moved to SeuratWrappers; #' for more information on SeuratWrappers, please see \url{https://github.com/satijalab/seurat-wrappers} #' #' @param object Seurat object #' @param start Index to start plotting singular value spacings from. #' The transition from "signal" to "noise" in the is hard to see because the #' first singular value spacings are so large. Nicer visualizations result from #' skipping the first few. If set to 0 (default) starts from k/2. #' @param combine Combine plots into a single gg object; note that if TRUE, #' themeing will not work when plotting multiple features #' #' @return A list of 3 ggplot objects splotting the singular values, the #' spacings of the singular values, and the p-values of the singular values. #' #' @author Jun Zhao, George Linderman #' @seealso \code{\link{RunALRA}} #' #' @importFrom cowplot theme_cowplot #' @importFrom ggplot2 ggplot aes_string geom_point geom_line #' geom_vline scale_x_continuous labs #' @export #' ALRAChooseKPlot <- function(object, start = 0, combine = TRUE) { .Deprecated( new = 'SeruatWrappers::ALRAChooseKPlot', msg = paste( 'ALRAChooseKPlot and associated functions are being moved to SeuratWrappers;', 'for more information on SeuratWrappers, please see https://github.com/satijalab/seurat-wrappers' ) ) alra.data <- Tool(object = object, slot = 'RunALRA') if (is.null(x = alra.data)) { stop('RunALRA should be run prior to using this function.') } d <- alra.data[["d"]] diffs <- alra.data[["diffs"]] k <- alra.data[["k"]] if (start == 0) { start <- floor(x = k / 2) } if (start > k) { stop("Plots should include k (i.e. starting.from should be less than k)") } breaks <- seq(from = 10, to = length(x = d), by = 10) ggdata <- data.frame(x = 1:length(x = d), y = d) gg1 <- ggplot(data = ggdata, mapping = aes_string(x = 'x', y = 'y')) + geom_point(size = 1) + geom_line(size = 0.5) + geom_vline(xintercept = k) + theme_cowplot() + scale_x_continuous(breaks = breaks) + labs(x = NULL, y = 's_i', title = 'Singular values') ggdata <- data.frame(x = 1:(length(x = d) - 1), y = diffs)[-(1:(start - 1)), ] gg2 <- ggplot(data = ggdata, mapping = aes_string(x = 'x', y = 'y')) + geom_point(size = 1) + geom_line(size = 0.5) + geom_vline(xintercept = k + 1) + theme_cowplot() + scale_x_continuous(breaks = breaks) + labs(x = NULL, y = 's_{i} - s_{i-1}', title = 'Singular value spacings') plots <- list(spectrum = gg1, spacings = gg2) if (combine) { plots <- CombinePlots(plots = plots) } return(plots) } #' Plot the Barcode Distribution and Calculated Inflection Points #' #' This function plots the calculated inflection points derived from the barcode-rank #' distribution. #' #' See [CalculateBarcodeInflections()] to calculate inflection points and #' [SubsetByBarcodeInflections()] to subsequently subset the Seurat object. #' #' @param object Seurat object #' #' @return Returns a `ggplot2` object showing the by-group inflection points and provided #' (or default) rank threshold values in grey. #' #' @importFrom methods slot #' @importFrom cowplot theme_cowplot #' @importFrom ggplot2 ggplot geom_line geom_vline aes_string #' #' @export #' #' @author Robert A. Amezquita, \email{robert.amezquita@fredhutch.org} #' @seealso \code{\link{CalculateBarcodeInflections}} \code{\link{SubsetByBarcodeInflections}} #' #' @examples #' pbmc_small <- CalculateBarcodeInflections(pbmc_small, group.column = 'groups') #' BarcodeInflectionsPlot(pbmc_small) #' BarcodeInflectionsPlot <- function(object) { cbi.data <- Tool(object = object, slot = 'CalculateBarcodeInflections') if (is.null(x = cbi.data)) { stop("Barcode inflections not calculated, please run CalculateBarcodeInflections") } ## Extract necessary data frames inflection_points <- cbi.data$inflection_points barcode_distribution <- cbi.data$barcode_distribution threshold_values <- cbi.data$threshold_values # Set a cap to max rank to avoid plot being overextended if (threshold_values$rank[[2]] > max(barcode_distribution$rank, na.rm = TRUE)) { threshold_values$rank[[2]] <- max(barcode_distribution$rank, na.rm = TRUE) } ## Infer the grouping/barcode variables group_var <- colnames(x = barcode_distribution)[1] barcode_var <- colnames(x = barcode_distribution)[2] barcode_distribution[, barcode_var] <- log10(x = barcode_distribution[, barcode_var] + 1) ## Make the plot plot <- ggplot( data = barcode_distribution, mapping = aes_string( x = 'rank', y = barcode_var, group = group_var, colour = group_var ) ) + geom_line() + geom_vline( data = threshold_values, aes_string(xintercept = 'rank'), linetype = "dashed", colour = 'grey60', size = 0.5 ) + geom_vline( data = inflection_points, mapping = aes_string( xintercept = 'rank', group = group_var, colour = group_var ), linetype = "dashed" ) + theme_cowplot() return(plot) } #' Dot plot visualization #' #' Intuitive way of visualizing how feature expression changes across different #' identity classes (clusters). The size of the dot encodes the percentage of #' cells within a class, while the color encodes the AverageExpression level #' across all cells within a class (blue is high). #' #' @param object Seurat object #' @param assay Name of assay to use, defaults to the active assay #' @param features Input vector of features #' @param cols Colors to plot, can pass a single character giving the name of #' a palette from \code{RColorBrewer::brewer.pal.info} #' @param col.min Minimum scaled average expression threshold (everything smaller #' will be set to this) #' @param col.max Maximum scaled average expression threshold (everything larger #' will be set to this) #' @param dot.min The fraction of cells at which to draw the smallest dot #' (default is 0). All cell groups with less than this expressing the given #' gene will have no dot drawn. #' @param dot.scale Scale the size of the points, similar to cex #' @param group.by Factor to group the cells by #' @param split.by Factor to split the groups by (replicates the functionality of the old SplitDotPlotGG); #' see \code{\link{FetchData}} for more details #' @param scale.by Scale the size of the points by 'size' or by 'radius' #' @param scale.min Set lower limit for scaling, use NA for default #' @param scale.max Set upper limit for scaling, use NA for default #' #' @return A ggplot object #' #' @importFrom grDevices colorRampPalette #' @importFrom cowplot theme_cowplot #' @importFrom ggplot2 ggplot aes_string scale_size scale_radius geom_point theme element_blank labs #' scale_color_identity scale_color_distiller scale_color_gradient guides guide_legend guide_colorbar #' @export #' #' @aliases SplitDotPlotGG #' @seealso \code{RColorBrewer::brewer.pal.info} #' #' @examples #' cd_genes <- c("CD247", "CD3E", "CD9") #' DotPlot(object = pbmc_small, features = cd_genes) #' pbmc_small[['groups']] <- sample(x = c('g1', 'g2'), size = ncol(x = pbmc_small), replace = TRUE) #' DotPlot(object = pbmc_small, features = cd_genes, split.by = 'groups') #' DotPlot <- function( object, assay = NULL, features, cols = c("lightgrey", "blue"), col.min = -2.5, col.max = 2.5, dot.min = 0, dot.scale = 6, group.by = NULL, split.by = NULL, scale.by = 'radius', scale.min = NA, scale.max = NA ) { assay <- assay %||% DefaultAssay(object = object) DefaultAssay(object = object) <- assay scale.func <- switch( EXPR = scale.by, 'size' = scale_size, 'radius' = scale_radius, stop("'scale.by' must be either 'size' or 'radius'") ) data.features <- FetchData(object = object, vars = features) data.features$id <- if (is.null(x = group.by)) { Idents(object = object) } else { object[[group.by, drop = TRUE]] } if (!is.factor(x = data.features$id)) { data.features$id <- factor(x = data.features$id) } id.levels <- levels(x = data.features$id) data.features$id <- as.vector(x = data.features$id) if (!is.null(x = split.by)) { splits <- object[[split.by, drop = TRUE]] if (length(x = unique(x = splits)) > length(x = cols)) { stop("Not enought colors for the number of groups") } cols <- cols[1:length(x = unique(x = splits))] names(x = cols) <- unique(x = splits) data.features$id <- paste(data.features$id, splits, sep = '_') unique.splits <- unique(x = splits) id.levels <- paste0(rep(x = id.levels, each = length(x = unique.splits)), "_", rep(x = unique(x = splits), times = length(x = id.levels))) } data.plot <- lapply( X = unique(x = data.features$id), FUN = function(ident) { data.use <- data.features[data.features$id == ident, 1:(ncol(x = data.features) - 1), drop = FALSE] avg.exp <- apply( X = data.use, MARGIN = 2, FUN = function(x) { return(mean(x = expm1(x = x))) } ) pct.exp <- apply(X = data.use, MARGIN = 2, FUN = PercentAbove, threshold = 0) return(list(avg.exp = avg.exp, pct.exp = pct.exp)) } ) names(x = data.plot) <- unique(x = data.features$id) data.plot <- lapply( X = names(x = data.plot), FUN = function(x) { data.use <- as.data.frame(x = data.plot[[x]]) data.use$features.plot <- rownames(x = data.use) data.use$id <- x return(data.use) } ) data.plot <- do.call(what = 'rbind', args = data.plot) if (!is.null(x = id.levels)) { data.plot$id <- factor(x = data.plot$id, levels = id.levels) } avg.exp.scaled <- sapply( X = unique(x = data.plot$features.plot), FUN = function(x) { data.use <- data.plot[data.plot$features.plot == x, 'avg.exp'] data.use <- scale(x = data.use) data.use <- MinMax(data = data.use, min = col.min, max = col.max) return(data.use) } ) avg.exp.scaled <- as.vector(x = t(x = avg.exp.scaled)) if (!is.null(x = split.by)) { avg.exp.scaled <- as.numeric(x = cut(x = avg.exp.scaled, breaks = 20)) } data.plot$avg.exp.scaled <- avg.exp.scaled data.plot$features.plot <- factor( x = data.plot$features.plot, levels = rev(x = features) ) data.plot$pct.exp[data.plot$pct.exp < dot.min] <- NA data.plot$pct.exp <- data.plot$pct.exp * 100 if (!is.null(x = split.by)) { splits.use <- vapply( X = strsplit(x = as.character(x = data.plot$id), split = '_'), FUN = '[[', FUN.VALUE = character(length = 1L), 2 ) data.plot$colors <- mapply( FUN = function(color, value) { return(colorRampPalette(colors = c('grey', color))(20)[value]) }, color = cols[splits.use], value = avg.exp.scaled ) } color.by <- ifelse(test = is.null(x = split.by), yes = 'avg.exp.scaled', no = 'colors') if (!is.na(x = scale.min)) { data.plot[data.plot$pct.exp < scale.min, 'pct.exp'] <- scale.min } if (!is.na(x = scale.max)) { data.plot[data.plot$pct.exp > scale.max, 'pct.exp'] <- scale.max } plot <- ggplot(data = data.plot, mapping = aes_string(x = 'features.plot', y = 'id')) + geom_point(mapping = aes_string(size = 'pct.exp', color = color.by)) + scale.func(range = c(0, dot.scale), limits = c(scale.min, scale.max)) + theme(axis.title.x = element_blank(), axis.title.y = element_blank()) + guides(size = guide_legend(title = 'Percent Expressed')) + labs( x = 'Features', y = ifelse(test = is.null(x = split.by), yes = 'Identity', no = 'Split Identity') ) + theme_cowplot() if (!is.null(x = split.by)) { plot <- plot + scale_color_identity() } else if (length(x = cols) == 1) { plot <- plot + scale_color_distiller(palette = cols) } else { plot <- plot + scale_color_gradient(low = cols[1], high = cols[2]) } if (is.null(x = split.by)) { plot <- plot + guides(color = guide_colorbar(title = 'Average Expression')) } return(plot) } #' Quickly Pick Relevant Dimensions #' #' Plots the standard deviations (or approximate singular values if running PCAFast) #' of the principle components for easy identification of an elbow in the graph. #' This elbow often corresponds well with the significant dims and is much faster to run than #' Jackstraw #' #' @param object Seurat object #' @param ndims Number of dimensions to plot standard deviation for #' @param reduction Reduction technique to plot standard deviation for #' #' @return A ggplot object #' #' @importFrom cowplot theme_cowplot #' @importFrom ggplot2 ggplot aes_string geom_point labs element_line #' @export #' #' @examples #' ElbowPlot(object = pbmc_small) #' ElbowPlot <- function(object, ndims = 20, reduction = 'pca') { data.use <- Stdev(object = object, reduction = reduction) if (length(x = data.use) == 0) { stop(paste("No standard deviation info stored for", reduction)) } if (ndims > length(x = data.use)) { warning("The object only has information for ", length(x = data.use), " reductions") ndims <- length(x = data.use) } stdev <- 'Standard Deviation' plot <- ggplot(data = data.frame(dims = 1:ndims, stdev = data.use[1:ndims])) + geom_point(mapping = aes_string(x = 'dims', y = 'stdev')) + labs( x = gsub( pattern = '_$', replacement = '', x = Key(object = object[[reduction]]) ), y = stdev ) + theme_cowplot() return(plot) } #' JackStraw Plot #' #' Plots the results of the JackStraw analysis for PCA significance. For each #' PC, plots a QQ-plot comparing the distribution of p-values for all genes #' across each PC, compared with a uniform distribution. Also determines a #' p-value for the overall significance of each PC (see Details). #' #' Significant PCs should show a p-value distribution (black curve) that is #' strongly skewed to the left compared to the null distribution (dashed line) #' The p-value for each PC is based on a proportion test comparing the number #' of genes with a p-value below a particular threshold (score.thresh), compared with the #' proportion of genes expected under a uniform distribution of p-values. #' #' @param object Seurat object #' @param dims Dims to plot #' @param reduction reduction to pull jackstraw info from #' @param xmax X-axis maximum on each QQ plot. #' @param ymax Y-axis maximum on each QQ plot. #' #' @return A ggplot object #' #' @author Omri Wurtzel #' @seealso \code{\link{ScoreJackStraw}} #' #' @importFrom stats qunif #' @importFrom ggplot2 ggplot aes_string stat_qq labs xlim ylim #' coord_flip geom_abline guides guide_legend #' @importFrom cowplot theme_cowplot #' #' @export #' #' @examples #' JackStrawPlot(object = pbmc_small) #' JackStrawPlot <- function( object, dims = 1:5, reduction = 'pca', xmax = 0.1, ymax = 0.3 ) { pAll <- JS(object = object[[reduction]], slot = 'empirical') if (max(dims) > ncol(x = pAll)) { stop("Max dimension is ", ncol(x = pAll)) } pAll <- pAll[, dims, drop = FALSE] pAll <- as.data.frame(x = pAll) data.plot <- Melt(x = pAll) colnames(x = data.plot) <- c("Contig", "PC", "Value") score.df <- JS(object = object[[reduction]], slot = 'overall') if (nrow(x = score.df) < max(dims)) { stop("Jackstraw procedure not scored for all the provided dims. Please run ScoreJackStraw.") } score.df <- score.df[dims, , drop = FALSE] if (nrow(x = score.df) == 0) { stop(paste0("JackStraw hasn't been scored. Please run ScoreJackStraw before plotting.")) } data.plot$PC.Score <- rep( x = paste0("PC ", score.df[ ,"PC"], ": ", sprintf("%1.3g", score.df[ ,"Score"])), each = length(x = unique(x = data.plot$Contig)) ) data.plot$PC.Score <- factor( x = data.plot$PC.Score, levels = paste0("PC ", score.df[, "PC"], ": ", sprintf("%1.3g", score.df[, "Score"])) ) gp <- ggplot(data = data.plot, mapping = aes_string(sample = 'Value', color = 'PC.Score')) + stat_qq(distribution = qunif) + labs(x = "Theoretical [runif(1000)]", y = "Empirical") + xlim(0, ymax) + ylim(0, xmax) + coord_flip() + geom_abline(intercept = 0, slope = 1, linetype = "dashed", na.rm = TRUE) + guides(color = guide_legend(title = "PC: p-value")) + theme_cowplot() return(gp) } #' Plot clusters as a tree #' #' Plots previously computed tree (from BuildClusterTree) #' #' @param object Seurat object #' @param \dots Additional arguments to ape::plot.phylo #' #' @return Plots dendogram (must be precomputed using BuildClusterTree), returns no value #' #' @importFrom ape plot.phylo #' @importFrom ape nodelabels #' #' @export #' #' @examples #' pbmc_small <- BuildClusterTree(object = pbmc_small) #' PlotClusterTree(object = pbmc_small) #' PlotClusterTree <- function(object, ...) { if (is.null(x = Tool(object = object, slot = "BuildClusterTree"))) { stop("Phylogenetic tree does not exist, build using BuildClusterTree") } data.tree <- Tool(object = object, slot = "BuildClusterTree") plot.phylo(x = data.tree, direction = "downwards", ...) nodelabels() } #' Visualize Dimensional Reduction genes #' #' Visualize top genes associated with reduction components #' #' @param object Seurat object #' @param reduction Reduction technique to visualize results for #' @param dims Number of dimensions to display #' @param nfeatures Number of genes to display #' @param col Color of points to use #' @param projected Use reduction values for full dataset (i.e. projected #' dimensional reduction values) #' @param balanced Return an equal number of genes with + and - scores. If #' FALSE (default), returns the top genes ranked by the scores absolute values #' @param ncol Number of columns to display #' @param combine Combine plots into a single gg object; note that if TRUE; #' themeing will not work when plotting multiple features #' #' @return A ggplot object #' #' @importFrom cowplot theme_cowplot #' @importFrom ggplot2 ggplot aes_string geom_point labs #' @export #' #' @examples #' VizDimLoadings(object = pbmc_small) #' VizDimLoadings <- function( object, dims = 1:5, nfeatures = 30, col = 'blue', reduction = 'pca', projected = FALSE, balanced = FALSE, ncol = NULL, combine = TRUE ) { if (is.null(x = ncol)) { ncol <- 2 if (length(x = dims) == 1) { ncol <- 1 } if (length(x = dims) > 6) { ncol <- 3 } if (length(x = dims) > 9) { ncol <- 4 } } loadings <- Loadings(object = object[[reduction]], projected = projected) features <- lapply( X = dims, FUN = TopFeatures, object = object[[reduction]], nfeatures = nfeatures, projected = projected, balanced = balanced ) features <- lapply( X = features, FUN = unlist, use.names = FALSE ) loadings <- loadings[unlist(x = features), dims, drop = FALSE] names(x = features) <- colnames(x = loadings) <- as.character(x = dims) plots <- lapply( X = as.character(x = dims), FUN = function(i) { data.plot <- as.data.frame(x = loadings[features[[i]], i, drop = FALSE]) colnames(x = data.plot) <- paste0(Key(object = object[[reduction]]), i) data.plot$feature <- factor(x = rownames(x = data.plot), levels = rownames(x = data.plot)) plot <- ggplot( data = data.plot, mapping = aes_string(x = colnames(x = data.plot)[1], y = 'feature') ) + geom_point(col = col) + labs(y = NULL) + theme_cowplot() return(plot) } ) if (combine) { plots <- CombinePlots(plots = plots, ncol = ncol, legend = NULL) } return(plots) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Exported utility functions #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' Augments ggplot2-based plot with a PNG image. #' #' Creates "vector-friendly" plots. Does this by saving a copy of the plot as a PNG file, #' then adding the PNG image with \code{\link[ggplot2]{annotation_raster}} to a blank plot #' of the same dimensions as \code{plot}. Please note: original legends and axes will be lost #' during augmentation. #' #' @param plot A ggplot object #' @param width,height Width and height of PNG version of plot #' @param dpi Plot resolution #' #' @return A ggplot object #' #' @importFrom png readPNG #' @importFrom ggplot2 ggplot_build ggsave ggplot aes_string geom_blank annotation_raster ggtitle #' #' @export #' #' @examples #' \dontrun{ #' plot <- DimPlot(object = pbmc_small) #' AugmentPlot(plot = plot) #' } #' AugmentPlot <- function(plot, width = 10, height = 10, dpi = 100) { pbuild.params <- ggplot_build(plot = plot)$layout$panel_params[[1]] range.values <- c( pbuild.params$x.range, pbuild.params$y.range ) xyparams <- GetXYAesthetics( plot = plot, geom = class(x = plot$layers[[1]]$geom)[1] ) title <- plot$labels$title tmpfile <- tempfile(fileext = '.png') ggsave( filename = tmpfile, plot = plot + NoLegend() + NoAxes() + theme(plot.title = element_blank()), width = width, height = height, dpi = dpi ) img <- readPNG(source = tmpfile) file.remove(tmpfile) blank <- ggplot( data = plot$data, mapping = aes_string(x = xyparams$x, y = xyparams$y) ) + geom_blank() blank <- blank + plot$theme + ggtitle(label = title) blank <- blank + annotation_raster( raster = img, xmin = range.values[1], xmax = range.values[2], ymin = range.values[3], ymax = range.values[4] ) return(blank) } #' @inheritParams CustomPalette #' #' @export #' #' @rdname CustomPalette #' @aliases BlackAndWhite #' #' @examples #' df <- data.frame(x = rnorm(n = 100, mean = 20, sd = 2), y = rbinom(n = 100, size = 100, prob = 0.2)) #' plot(df, col = BlackAndWhite()) #' BlackAndWhite <- function(mid = NULL, k = 50) { return(CustomPalette(low = "white", high = "black", mid = mid, k = k)) } #' @inheritParams CustomPalette #' #' @export #' #' @rdname CustomPalette #' @aliases BlueAndRed #' #' @examples #' df <- data.frame(x = rnorm(n = 100, mean = 20, sd = 2), y = rbinom(n = 100, size = 100, prob = 0.2)) #' plot(df, col = BlueAndRed()) #' BlueAndRed <- function(k = 50) { return(CustomPalette(low = "#313695" , high = "#A50026", mid = "#FFFFBF", k = k)) } #' Cell selector #' #' Select points on a scatterplot and get information about them #' #' @param plot A ggplot2 plot #' @param object An optional Seurat object; if passes, will return an object with #' the identities of selected cells set to \code{ident} #' @param ident An optional new identity class to assign the selected cells #' @param ... Extra parameters, such as dark.theme, recolor, or smooth for using a dark theme, #' recoloring based on selected cells, or using a smooth scatterplot, respectively #' #' @return If \code{object} is \code{NULL}, the names of the points selected; otherwise, #' a Seurat object with the selected cells identity classes set to \code{ident} #' #' @importFrom ggplot2 ggplot_build #' @export #' # @aliases FeatureLocator #' @seealso \code{\link[graphics]{locator}} \code{\link[ggplot2]{ggplot_build}} #' \code{\link[SDMTools]{pnt.in.poly}} \code{\link{DimPlot}} \code{\link{FeaturePlot}} #' #' @examples #' \dontrun{ #' plot <- DimPlot(object = pbmc_small) #' # Follow instructions in the terminal to select points #' cells.located <- CellSelector(plot = plot) #' cells.located #' # Automatically set the identity class of selected cells and return a new Seurat object #' pbmc_small <- CellSelector(plot = plot, object = pbmc_small, ident = 'SelectedCells') #' } #' CellSelector <- function(plot, object = NULL, ident = 'SelectedCells', ...) { located <- PointLocator(plot = plot, ...) data <- ggplot_build(plot = plot)$plot$data selected <- rownames(x = data[as.numeric(x = rownames(x = located)), ]) if (inherits(x = object, what = 'Seurat')) { if (!all(selected %in% Cells(x = object))) { stop("Cannot find selected cells in the Seurat object, please be sure you pass the same object used to generate the plot", call. = FALSE) } Idents(object = object, cells = selected) <- ident return(object) } return(selected) } #' Move outliers towards center on dimension reduction plot #' #' @param object Seurat object #' @param reduction Name of DimReduc to adjust #' @param dims Dimensions to visualize #' @param group.by Group (color) cells in different ways (for example, orig.ident) #' @param outlier.sd Controls the outlier distance #' @param reduction.key Key for DimReduc that is returned #' #' @return Returns a DimReduc object with the modified embeddings #' #' @export #' #' @examples #' \dontrun{ #' pbmc_small <- FindClusters(pbmc_small, resolution = 1.1) #' pbmc_small <- RunUMAP(pbmc_small, dims = 1:5) #' DimPlot(pbmc_small, reduction = "umap") #' pbmc_small[["umap_new"]] <- CollapseEmbeddingOutliers(pbmc_small, #' reduction = "umap", reduction.key = 'umap_', outlier.sd = 0.5) #' DimPlot(pbmc_small, reduction = "umap_new") #' } #' CollapseEmbeddingOutliers <- function( object, reduction = 'umap', dims = 1:2, group.by = 'ident', outlier.sd = 2, reduction.key = 'UMAP_' ) { embeddings <- Embeddings(object = object[[reduction]])[, dims] idents <- FetchData(object = object, vars = group.by) data.medians <- sapply(X = dims, FUN = function(x) { tapply(X = embeddings[, x], INDEX = idents, FUN = median) }) data.sd <- apply(X = data.medians, MARGIN = 2, FUN = sd) data.medians.scale <- as.matrix(x = scale(x = data.medians, center = TRUE, scale = TRUE)) data.medians.scale[abs(x = data.medians.scale) < outlier.sd] <- 0 data.medians.scale <- sign(x = data.medians.scale) * (abs(x = data.medians.scale) - outlier.sd) data.correct <- Sweep( x = data.medians.scale, MARGIN = 2, STATS = data.sd, FUN = "*" ) data.correct <- data.correct[abs(x = apply(X = data.correct, MARGIN = 1, FUN = min)) > 0, ] new.embeddings <- embeddings for (i in rownames(x = data.correct)) { cells.correct <- rownames(x = idents)[idents[, "ident"] == i] new.embeddings[cells.correct, ] <- Sweep( x = new.embeddings[cells.correct,], MARGIN = 2, STATS = data.correct[i, ], FUN = "-" ) } reduc <- CreateDimReducObject( embeddings = new.embeddings, loadings = Loadings(object = object[[reduction]]), assay = slot(object = object[[reduction]], name = "assay.used"), key = reduction.key ) return(reduc) } #' Combine ggplot2-based plots into a single plot #' #' @param plots A list of gg objects #' @param ncol Number of columns #' @param legend Combine legends into a single legend #' choose from 'right' or 'bottom'; pass 'none' to remove legends, or \code{NULL} #' to leave legends as they are #' @param ... Extra parameters passed to plot_grid #' #' @return A combined plot #' #' @importFrom cowplot plot_grid get_legend #' @export #' #' @examples #' pbmc_small[['group']] <- sample( #' x = c('g1', 'g2'), #' size = ncol(x = pbmc_small), #' replace = TRUE #' ) #' plots <- FeaturePlot( #' object = pbmc_small, #' features = c('MS4A1', 'FCN1'), #' split.by = 'group', #' combine = FALSE #' ) #' CombinePlots( #' plots = plots, #' legend = 'none', #' nrow = length(x = unique(x = pbmc_small[['group', drop = TRUE]])) #' ) #' CombinePlots <- function(plots, ncol = NULL, legend = NULL, ...) { plots.combined <- if (length(x = plots) > 1) { if (!is.null(x = legend)) { if (legend != 'none') { plot.legend <- get_legend(plot = plots[[1]] + theme(legend.position = legend)) } plots <- lapply( X = plots, FUN = function(x) { return(x + NoLegend()) } ) } plots.combined <- plot_grid( plotlist = plots, ncol = ncol, align = 'hv', ... ) if (!is.null(x = legend)) { plots.combined <- switch( EXPR = legend, 'bottom' = plot_grid( plots.combined, plot.legend, ncol = 1, rel_heights = c(1, 0.2) ), 'right' = plot_grid( plots.combined, plot.legend, rel_widths = c(3, 0.3) ), plots.combined ) } plots.combined } else { plots[[1]] } return(plots.combined) } #' Create a custom color palette #' #' Creates a custom color palette based on low, middle, and high color values #' #' @param low low color #' @param high high color #' @param mid middle color. Optional. #' @param k number of steps (colors levels) to include between low and high values #' #' @return A color palette for plotting #' #' @importFrom grDevices col2rgb rgb #' @export #' #' @rdname CustomPalette #' @examples #' myPalette <- CustomPalette() #' myPalette #' CustomPalette <- function( low = "white", high = "red", mid = NULL, k = 50 ) { low <- col2rgb(col = low) / 255 high <- col2rgb(col = high) / 255 if (is.null(x = mid)) { r <- seq(from = low[1], to = high[1], len = k) g <- seq(from = low[2], to = high[2], len = k) b <- seq(from = low[3], to = high[3], len = k) } else { k2 <- round(x = k / 2) mid <- col2rgb(col = mid) / 255 r <- c( seq(from = low[1], to = mid[1], len = k2), seq(from = mid[1], to = high[1], len = k2) ) g <- c( seq(from = low[2], to = mid[2], len = k2), seq(from = mid[2], to = high[2],len = k2) ) b <- c( seq(from = low[3], to = mid[3], len = k2), seq(from = mid[3], to = high[3], len = k2) ) } return(rgb(red = r, green = g, blue = b)) } #' Discrete colour palettes from the pals package #' #' These are included here because pals depends on a number of compiled #' packages, and this can lead to increases in run time for Travis, #' and generally should be avoided when possible. #' #' These palettes are a much better default for data with many classes #' than the default ggplot2 palette. #' #' Many thanks to Kevin Wright for writing the pals package. #' #' @param n Number of colours to be generated. #' @param palette Options are #' "alphabet", "alphabet2", "glasbey", "polychrome", and "stepped". #' Can be omitted and the function will use the one based on the requested n. #' #' @return A vector of colors #' #' @details #' Taken from the pals package (Licence: GPL-3). #' \url{https://cran.r-project.org/package=pals} #' Credit: Kevin Wright #' #' @export #' DiscretePalette <- function(n, palette = NULL) { palettes <- list( alphabet = c( "#F0A0FF", "#0075DC", "#993F00", "#4C005C", "#191919", "#005C31", "#2BCE48", "#FFCC99", "#808080", "#94FFB5", "#8F7C00", "#9DCC00", "#C20088", "#003380", "#FFA405", "#FFA8BB", "#426600", "#FF0010", "#5EF1F2", "#00998F", "#E0FF66", "#740AFF", "#990000", "#FFFF80", "#FFE100", "#FF5005" ), alphabet2 = c( "#AA0DFE", "#3283FE", "#85660D", "#782AB6", "#565656", "#1C8356", "#16FF32", "#F7E1A0", "#E2E2E2", "#1CBE4F", "#C4451C", "#DEA0FD", "#FE00FA", "#325A9B", "#FEAF16", "#F8A19F", "#90AD1C", "#F6222E", "#1CFFCE", "#2ED9FF", "#B10DA1", "#C075A6", "#FC1CBF", "#B00068", "#FBE426", "#FA0087" ), glasbey = c( "#0000FF", "#FF0000", "#00FF00", "#000033", "#FF00B6", "#005300", "#FFD300", "#009FFF", "#9A4D42", "#00FFBE", "#783FC1", "#1F9698", "#FFACFD", "#B1CC71", "#F1085C", "#FE8F42", "#DD00FF", "#201A01", "#720055", "#766C95", "#02AD24", "#C8FF00", "#886C00", "#FFB79F", "#858567", "#A10300", "#14F9FF", "#00479E", "#DC5E93", "#93D4FF", "#004CFF", "#F2F318" ), polychrome = c( "#5A5156", "#E4E1E3", "#F6222E", "#FE00FA", "#16FF32", "#3283FE", "#FEAF16", "#B00068", "#1CFFCE", "#90AD1C", "#2ED9FF", "#DEA0FD", "#AA0DFE", "#F8A19F", "#325A9B", "#C4451C", "#1C8356", "#85660D", "#B10DA1", "#FBE426", "#1CBE4F", "#FA0087", "#FC1CBF", "#F7E1A0", "#C075A6", "#782AB6", "#AAF400", "#BDCDFF", "#822E1C", "#B5EFB5", "#7ED7D1", "#1C7F93", "#D85FF7", "#683B79", "#66B0FF", "#3B00FB" ), stepped = c( "#990F26", "#B33E52", "#CC7A88", "#E6B8BF", "#99600F", "#B3823E", "#CCAA7A", "#E6D2B8", "#54990F", "#78B33E", "#A3CC7A", "#CFE6B8", "#0F8299", "#3E9FB3", "#7ABECC", "#B8DEE6", "#3D0F99", "#653EB3", "#967ACC", "#C7B8E6", "#333333", "#666666", "#999999", "#CCCCCC" ) ) if (is.null(x = palette)) { if (n <= 26) { palette <- "alphabet" } else if (n <= 32) { palette <- "glasbey" } else { palette <- "polychrome" } } palette.vec <- palettes[[palette]] if (n > length(x = palette.vec)) { warning("Not enough colours in specified palette") } palette.vec[seq_len(length.out = n)] } #' @rdname CellSelector #' @export #' FeatureLocator <- function(plot, ...) { .Defunct( new = 'CellSelector', package = 'Seurat', msg = "'FeatureLocator' has been replaced by 'CellSelector'" ) } #' Hover Locator #' #' Get quick information from a scatterplot by hovering over points #' #' @param plot A ggplot2 plot #' @param information An optional dataframe or matrix of extra information to be displayed on hover #' @param dark.theme Plot using a dark theme? #' @param ... Extra parameters to be passed to \code{plotly::layout} #' #' @importFrom ggplot2 ggplot_build #' @importFrom plotly plot_ly layout #' @export #' #' @seealso \code{\link[plotly]{layout}} \code{\link[ggplot2]{ggplot_build}} #' \code{\link{DimPlot}} \code{\link{FeaturePlot}} #' #' @examples #' \dontrun{ #' plot <- DimPlot(object = pbmc_small) #' HoverLocator(plot = plot, information = FetchData(object = pbmc_small, vars = 'percent.mito')) #' } #' HoverLocator <- function( plot, information = NULL, dark.theme = FALSE, ... ) { # Use GGpointToBase because we already have ggplot objects # with colors (which are annoying in plotly) plot.build <- GGpointToBase(plot = plot, do.plot = FALSE) data <- ggplot_build(plot = plot)$plot$data rownames(x = plot.build) <- rownames(x = data) # Reset the names to 'x' and 'y' names(x = plot.build) <- c( 'x', 'y', names(x = plot.build)[3:length(x = plot.build)] ) # Add the names we're looking for (eg. cell name, gene name) if (is.null(x = information)) { plot.build$feature <- rownames(x = data) } else { info <- apply( X = information, MARGIN = 1, FUN = function(x, names) { return(paste0(names, ': ', x, collapse = '
')) }, names = colnames(x = information) ) data.info <- data.frame( feature = paste(rownames(x = information), info, sep = '
'), row.names = rownames(x = information) ) plot.build <- merge(x = plot.build, y = data.info, by = 0) } # Set up axis labels here # Also, a bunch of stuff to get axis lines done properly xaxis <- list( title = names(x = data)[1], showgrid = FALSE, zeroline = FALSE, showline = TRUE ) yaxis <- list( title = names(x = data)[2], showgrid = FALSE, zeroline = FALSE, showline = TRUE ) # Check for dark theme if (dark.theme) { title <- list(color = 'white') xaxis <- c(xaxis, color = 'white') yaxis <- c(yaxis, color = 'white') plotbg <- 'black' } else { title = list(color = 'black') plotbg = 'white' } # The `~' means pull from the data passed (this is why we reset the names) # Use I() to get plotly to accept the colors from the data as is # Set hoverinfo to 'text' to override the default hover information # rather than append to it p <- plotly::layout( p = plot_ly( data = plot.build, x = ~x, y = ~y, type = 'scatter', mode = 'markers', color = ~I(color), hoverinfo = 'text', text = ~feature ), xaxis = xaxis, yaxis = yaxis, title = plot$labels$title, titlefont = title, paper_bgcolor = plotbg, plot_bgcolor = plotbg, ... ) # add labels label.layer <- which(x = sapply( X = plot$layers, FUN = function(x) class(x$geom)[1] == "GeomText") ) if (length(x = label.layer) == 1) { p <- plotly::add_annotations( p = p, x = plot$layers[[label.layer]]$data[, 1], y = plot$layers[[label.layer]]$data[, 2], xref = "x", yref = "y", text = plot$layers[[label.layer]]$data[, 3], xanchor = 'right', showarrow = FALSE, font = list(size = plot$layers[[label.layer]]$aes_params$size * 4) ) } return(p) } #' Label clusters on a ggplot2-based scatter plot #' #' @param plot A ggplot2-based scatter plot #' @param id Name of variable used for coloring scatter plot #' @param clusters Vector of cluster ids to label #' @param labels Custom labels for the clusters #' @param split.by Split labels by some grouping label, useful when using #' \code{\link[ggplot2]{facet_wrap}} or \code{\link[ggplot2]{facet_grid}} #' @param repel Use \code{geom_text_repel} to create nicely-repelled labels #' @param ... Extra parameters to \code{\link[ggrepel]{geom_text_repel}}, such as \code{size} #' #' @return A ggplot2-based scatter plot with cluster labels #' #' @importFrom stats median #' @importFrom ggrepel geom_text_repel #' @importFrom ggplot2 aes_string geom_text #' @export #' #' @seealso \code{\link[ggrepel]{geom_text_repel}} \code{\link[ggplot2]{geom_text}} #' #' @examples #' plot <- DimPlot(object = pbmc_small) #' LabelClusters(plot = plot, id = 'ident') #' LabelClusters <- function( plot, id, clusters = NULL, labels = NULL, split.by = NULL, repel = TRUE, ... ) { xynames <- unlist(x = GetXYAesthetics(plot = plot), use.names = TRUE) if (!id %in% colnames(x = plot$data)) { stop("Cannot find variable ", id, " in plotting data") } if (!is.null(x = split.by) && !split.by %in% colnames(x = plot$data)) { warning("Cannot find splitting variable ", id, " in plotting data") split.by <- NULL } data <- plot$data[, c(xynames, id, split.by)] possible.clusters <- as.character(x = na.omit(object = unique(x = data[, id]))) groups <- clusters %||% as.character(x = na.omit(object = unique(x = data[, id]))) if (any(!groups %in% possible.clusters)) { stop("The following clusters were not found: ", paste(groups[!groups %in% possible.clusters], collapse = ",")) } labels.loc <- lapply( X = groups, FUN = function(group) { data.use <- data[data[, id] == group, , drop = FALSE] data.medians <- if (!is.null(x = split.by)) { do.call( what = 'rbind', args = lapply( X = unique(x = data.use[, split.by]), FUN = function(split) { medians <- apply( X = data.use[data.use[, split.by] == split, xynames, drop = FALSE], MARGIN = 2, FUN = median, na.rm = TRUE ) medians <- as.data.frame(x = t(x = medians)) medians[, split.by] <- split return(medians) } ) ) } else { as.data.frame(x = t(x = apply( X = data.use[, xynames, drop = FALSE], MARGIN = 2, FUN = median, na.rm = TRUE ))) } data.medians[, id] <- group return(data.medians) } ) labels.loc <- do.call(what = 'rbind', args = labels.loc) labels <- labels %||% groups if (length(x = unique(x = labels.loc[, id])) != length(x = labels)) { stop("Length of labels (", length(x = labels), ") must be equal to the number of clusters being labeled (", length(x = labels.loc), ").") } names(x = labels) <- groups for (group in groups) { labels.loc[labels.loc[, id] == group, id] <- labels[group] } geom.use <- ifelse(test = repel, yes = geom_text_repel, no = geom_text) plot <- plot + geom.use( data = labels.loc, mapping = aes_string(x = xynames['x'], y = xynames['y'], label = id), ... ) return(plot) } #' Add text labels to a ggplot2 plot #' #' @param plot A ggplot2 plot with a GeomPoint layer #' @param points A vector of points to label; if \code{NULL}, will use all points in the plot #' @param labels A vector of labels for the points; if \code{NULL}, will use #' rownames of the data provided to the plot at the points selected #' @param repel Use \code{geom_text_repel} to create a nicely-repelled labels; this #' is slow when a lot of points are being plotted. If using \code{repel}, set \code{xnudge} #' and \code{ynudge} to 0 #' @param xnudge,ynudge Amount to nudge X and Y coordinates of labels by #' @param ... Extra parameters passed to \code{geom_text} #' #' @return A ggplot object #' #' @importFrom ggrepel geom_text_repel #' @importFrom ggplot2 geom_text aes_string #' @export #' #' @aliases Labeler #' @seealso \code{\link[ggplot2]{geom_text}} #' #' @examples #' ff <- TopFeatures(object = pbmc_small[['pca']]) #' cc <- TopCells(object = pbmc_small[['pca']]) #' plot <- FeatureScatter(object = pbmc_small, feature1 = ff[1], feature2 = ff[2]) #' LabelPoints(plot = plot, points = cc) #' LabelPoints <- function( plot, points, labels = NULL, repel = FALSE, xnudge = 0.3, ynudge = 0.05, ... ) { xynames <- GetXYAesthetics(plot = plot) points <- points %||% rownames(x = plot$data) if (is.numeric(x = points)) { points <- rownames(x = plot$data) } points <- intersect(x = points, y = rownames(x = plot$data)) if (length(x = points) == 0) { stop("Cannot find points provided") } labels <- labels %||% points labels <- as.character(x = labels) label.data <- plot$data[points, ] label.data$labels <- labels geom.use <- ifelse(test = repel, yes = geom_text_repel, no = geom_text) if (repel) { if (!all(c(xnudge, ynudge) == 0)) { message("When using repel, set xnudge and ynudge to 0 for optimal results") } } plot <- plot + geom.use( mapping = aes_string(x = xynames$x, y = xynames$y, label = 'labels'), data = label.data, nudge_x = xnudge, nudge_y = ynudge, ... ) return(plot) } #' @inheritParams CustomPalette #' #' @export #' #' @rdname CustomPalette #' @aliases PurpleAndYellow #' #' @examples #' df <- data.frame(x = rnorm(n = 100, mean = 20, sd = 2), y = rbinom(n = 100, size = 100, prob = 0.2)) #' plot(df, col = PurpleAndYellow()) #' PurpleAndYellow <- function(k = 50) { return(CustomPalette(low = "magenta", high = "yellow", mid = "black", k = k)) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Seurat themes #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' Seurat Themes #' #' Various themes to be applied to ggplot2-based plots #' \describe{ #' \item{\code{SeuratTheme}}{The curated Seurat theme, consists of ...} #' \item{\code{DarkTheme}}{A dark theme, axes and text turn to white, the background becomes black} #' \item{\code{NoAxes}}{Removes axis lines, text, and ticks} #' \item{\code{NoLegend}}{Removes the legend} #' \item{\code{FontSize}}{Sets axis and title font sizes} #' \item{\code{NoGrid}}{Removes grid lines} #' \item{\code{SeuratAxes}}{Set Seurat-style axes} #' \item{\code{SpatialTheme}}{A theme designed for spatial visualizations (eg \code{\link{PolyFeaturePlot}}, \code{\link{PolyDimPlot}})} #' \item{\code{RestoreLegend}}{Restore a legend after removal} #' \item{\code{RotatedAxis}}{Rotate X axis text 45 degrees} #' \item{\code{BoldTitle}}{Enlarges and emphasizes the title} #' } #' #' @param ... Extra parameters to be passed to \code{theme} #' #' @return A ggplot2 theme object #' #' @export #' #' @rdname SeuratTheme #' @seealso \code{\link[ggplot2]{theme}} #' @aliases SeuratTheme #' SeuratTheme <- function() { return(DarkTheme() + NoLegend() + NoGrid() + SeuratAxes()) } #' @inheritParams SeuratTheme #' #' @importFrom ggplot2 theme element_rect element_text element_line margin #' @export #' #' @rdname SeuratTheme #' @aliases DarkTheme #' #' @examples #' # Generate a plot with a dark theme #' library(ggplot2) #' df <- data.frame(x = rnorm(n = 100, mean = 20, sd = 2), y = rbinom(n = 100, size = 100, prob = 0.2)) #' p <- ggplot(data = df, mapping = aes(x = x, y = y)) + geom_point(mapping = aes(color = 'red')) #' p + DarkTheme(legend.position = 'none') #' DarkTheme <- function(...) { # Some constants for easier changing in the future black.background <- element_rect(fill = 'black') black.background.no.border <- element_rect(fill = 'black', size = 0) font.margin <- 4 white.text <- element_text( colour = 'white', margin = margin( t = font.margin, r = font.margin, b = font.margin, l = font.margin ) ) white.line <- element_line(colour = 'white', size = 1) no.line <- element_line(size = 0) # Create the dark theme dark.theme <- theme( # Set background colors plot.background = black.background, panel.background = black.background, legend.background = black.background, legend.box.background = black.background.no.border, legend.key = black.background.no.border, strip.background = element_rect(fill = 'grey50', colour = NA), # Set text colors plot.title = white.text, plot.subtitle = white.text, axis.title = white.text, axis.text = white.text, legend.title = white.text, legend.text = white.text, strip.text = white.text, # Set line colors axis.line.x = white.line, axis.line.y = white.line, panel.grid = no.line, panel.grid.minor = no.line, # Validate the theme validate = TRUE, # Extra parameters ... ) return(dark.theme) } #' @inheritParams SeuratTheme #' @param x.text,y.text X and Y axis text sizes #' @param x.title,y.title X and Y axis title sizes #' @param main Plot title size #' #' @importFrom ggplot2 theme element_text #' @export #' #' @rdname SeuratTheme #' @aliases FontSize #' FontSize <- function( x.text = NULL, y.text = NULL, x.title = NULL, y.title = NULL, main = NULL, ... ) { font.size <- theme( # Set font sizes axis.text.x = element_text(size = x.text), axis.text.y = element_text(size = y.text), axis.title.x = element_text(size = x.title), axis.title.y = element_text(size = y.title), plot.title = element_text(size = main), # Validate the theme validate = TRUE, # Extra parameters ... ) } #' @inheritParams SeuratTheme #' @param keep.text Keep axis text #' @param keep.ticks Keep axis ticks #' #' @importFrom ggplot2 theme element_blank #' @export #' #' @rdname SeuratTheme #' @aliases NoAxes #' #' @examples #' # Generate a plot with no axes #' library(ggplot2) #' df <- data.frame(x = rnorm(n = 100, mean = 20, sd = 2), y = rbinom(n = 100, size = 100, prob = 0.2)) #' p <- ggplot(data = df, mapping = aes(x = x, y = y)) + geom_point(mapping = aes(color = 'red')) #' p + NoAxes() #' NoAxes <- function(..., keep.text = FALSE, keep.ticks = FALSE) { blank <- element_blank() no.axes.theme <- theme( # Remove the axis elements axis.line.x = blank, axis.line.y = blank, # Validate the theme validate = TRUE, ... ) if (!keep.text) { no.axes.theme <- no.axes.theme + theme( axis.text.x = blank, axis.text.y = blank, axis.title.x = blank, axis.title.y = blank, validate = TRUE, ... ) } if (!keep.ticks){ no.axes.theme <- no.axes.theme + theme( axis.ticks.x = blank, axis.ticks.y = blank, validate = TRUE, ... ) } return(no.axes.theme) } #' @inheritParams SeuratTheme #' #' @importFrom ggplot2 theme #' @export #' #' @rdname SeuratTheme #' @aliases NoLegend #' #' @examples #' # Generate a plot with no legend #' library(ggplot2) #' df <- data.frame(x = rnorm(n = 100, mean = 20, sd = 2), y = rbinom(n = 100, size = 100, prob = 0.2)) #' p <- ggplot(data = df, mapping = aes(x = x, y = y)) + geom_point(mapping = aes(color = 'red')) #' p + NoLegend() #' NoLegend <- function(...) { no.legend.theme <- theme( # Remove the legend legend.position = 'none', # Validate the theme validate = TRUE, ... ) return(no.legend.theme) } #' @inheritParams SeuratTheme #' #' @importFrom ggplot2 theme element_blank #' @export #' #' @rdname SeuratTheme #' @aliases NoGrid #' #' @examples #' # Generate a plot with no grid lines #' library(ggplot2) #' df <- data.frame(x = rnorm(n = 100, mean = 20, sd = 2), y = rbinom(n = 100, size = 100, prob = 0.2)) #' p <- ggplot(data = df, mapping = aes(x = x, y = y)) + geom_point(mapping = aes(color = 'red')) #' p + NoGrid() #' NoGrid <- function(...) { no.grid.theme <- theme( # Set grid lines to blank panel.grid.major = element_blank(), panel.grid.minor = element_blank(), # Validate the theme validate = TRUE, ... ) return(no.grid.theme) } #' @inheritParams SeuratTheme #' #' @importFrom ggplot2 theme element_text #' @export #' #' @rdname SeuratTheme #' @aliases SeuratAxes #' SeuratAxes <- function(...) { axes.theme <- theme( # Set axis things axis.title = element_text(face = 'bold', color = '#990000', size = 16), axis.text = element_text(vjust = 0.5, size = 12), # Validate the theme validate = TRUE, ... ) return(axes.theme) } #' @inheritParams SeuratTheme #' #' @export #' #' @rdname SeuratTheme #' @aliases SpatialTheme #' SpatialTheme <- function(...) { return(DarkTheme() + NoAxes() + NoGrid() + NoLegend(...)) } #' @inheritParams SeuratTheme #' @param position A position to restore the legend to #' #' @importFrom ggplot2 theme #' @export #' #' @rdname SeuratTheme #' @aliases RestoreLegend #' RestoreLegend <- function(..., position = 'right') { restored.theme <- theme( # Restore legend position legend.position = 'right', # Validate the theme validate = TRUE, ... ) return(restored.theme) } #' @inheritParams SeuratTheme #' #' @importFrom ggplot2 theme element_text #' @export #' #' @rdname SeuratTheme #' @aliases RotatedAxis #' RotatedAxis <- function(...) { rotated.theme <- theme( # Rotate X axis text axis.text.x = element_text(angle = 45, hjust = 1), # Validate the theme validate = TRUE, ... ) return(rotated.theme) } #' @inheritParams SeuratTheme #' #' @importFrom ggplot2 theme element_text #' @export #' #' @rdname SeuratTheme #' @aliases BoldTitle #' BoldTitle <- function(...) { bold.theme <- theme( # Make the title bold plot.title = element_text(size = 20, face = 'bold'), # Validate the theme validate = TRUE, ... ) return(bold.theme) } #' @inheritParams SeuratTheme #' #' @importFrom ggplot2 theme element_rect #' @export #' #' @rdname SeuratTheme #' @aliases WhiteBackground #' WhiteBackground <- function(...) { white.rect = element_rect(fill = 'white') white.theme <- theme( # Make the plot, panel, and legend key backgrounds white plot.background = white.rect, panel.background = white.rect, legend.key = white.rect, # Validate the theme validate = TRUE, ... ) return(white.theme) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Internal #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Automagically calculate a point size for ggplot2-based scatter plots # # It happens to look good # # @param data A data frame being passed to ggplot2 # # @return The "optimal" point size for visualizing these data # # @examples # df <- data.frame(x = rnorm(n = 10000), y = runif(n = 10000)) # AutoPointSize(data = df) # AutoPointSize <- function(data) { return(min(1583 / nrow(x = data), 1)) } # Calculate bandwidth for use in ggplot2-based smooth scatter plots # # Inspired by MASS::bandwidth.nrd and graphics:::.smoothScatterCalcDensity # # @param data A two-column data frame with X and Y coordinates for a plot # # @return The calculated bandwidth # #' @importFrom stats quantile var # Bandwidth <- function(data) { r <- diff(x = apply( X = data, MARGIN = 2, FUN = quantile, probs = c(0.05, 0.95), na.rm = TRUE, names = FALSE )) h <- abs(x = r[2L] - r[1L]) / 1.34 h <- ifelse(test = h == 0, yes = 1, no = h) bandwidth <- 4 * 1.06 * min(sqrt(x = apply(X = data, MARGIN = 2, FUN = var)), h) * nrow(x = data) ^ (-0.2) return(bandwidth) } # Blend expression values together # # @param data A two-column data frame with expression values for two features # # @return A three-column data frame with transformed and blended expression values # BlendExpression <- function(data) { if (ncol(x = data) != 2) { stop("'BlendExpression' only blends two features") } features <- colnames(x = data) data <- as.data.frame(x = apply( X = data, MARGIN = 2, FUN = function(x) { return(round(x = 9 * (x - min(x)) / (max(x) - min(x)))) } )) data[, 3] <- data[, 1] + data[, 2] * 10 colnames(x = data) <- c(features, paste(features, collapse = '_')) for (i in 1:ncol(x = data)) { data[, i] <- factor(x = data[, i]) } return(data) } # Create a heatmap of blended colors # # @param color.matrix A color matrix of blended colors # # @return A ggplot object # #' @importFrom grid unit #' @importFrom cowplot theme_cowplot #' @importFrom ggplot2 ggplot aes_string scale_fill_manual geom_raster #' theme scale_y_continuous scale_x_continuous scale_fill_manual # # @seealso \code{\link{BlendMatrix}} # BlendMap <- function(color.matrix) { color.heat <- matrix( data = 1:prod(dim(x = color.matrix)) - 1, nrow = nrow(x = color.matrix), ncol = ncol(x = color.matrix), dimnames = list( 1:nrow(x = color.matrix), 1:ncol(x = color.matrix) ) ) xbreaks <- seq.int(from = 0, to = nrow(x = color.matrix), by = 2) ybreaks <- seq.int(from = 0, to = ncol(x = color.matrix), by = 2) color.heat <- Melt(x = color.heat) color.heat$rows <- as.numeric(x = as.character(x = color.heat$rows)) color.heat$cols <- as.numeric(x = as.character(x = color.heat$cols)) color.heat$vals <- factor(x = color.heat$vals) plot <- ggplot( data = color.heat, mapping = aes_string(x = 'rows', y = 'cols', fill = 'vals') ) + geom_raster(show.legend = FALSE) + theme(plot.margin = unit(x = rep.int(x = 0, times = 4), units = 'cm')) + scale_x_continuous(breaks = xbreaks, expand = c(0, 0), labels = xbreaks) + scale_y_continuous(breaks = ybreaks, expand = c(0, 0), labels = ybreaks) + scale_fill_manual(values = as.vector(x = color.matrix)) + theme_cowplot() return(plot) } # Create a color matrix of blended colors # # @param n Dimensions of blended matrix (n x n) # @param col.threshold The color cutoff from weak signal to strong signal; ranges from 0 to 1. # @param two.colors Two colors used for the blend expression. # # @return An n x n matrix of blended colors # #' @importFrom grDevices rgb colorRamp # BlendMatrix <- function( n = 10, col.threshold = 0.5, two.colors = c("#ff0000", "#00ff00"), negative.color = "black" ) { if (0 > col.threshold || col.threshold > 1) { stop("col.threshold must be between 0 and 1") } C0 <- colorRamp(colors = negative.color)(1) ramp <- colorRamp(colors = two.colors) C1 <- ramp(x = 0) C2 <- ramp(x = 1) merge.weight <- min(255 / (C1 + C2 + C0 + 0.01)) sigmoid <- function(x) { return(1 / (1 + exp(-x))) } blend_color <- function( i, j, col.threshold, n, C0, C1, C2, merge.weight ) { c.min <- sigmoid(5 * (1 / n - col.threshold)) c.max <- sigmoid(5 * (1 - col.threshold)) c1_weight <- sigmoid(5 * (i / n - col.threshold)) c2_weight <- sigmoid(5 * (j / n - col.threshold)) c0_weight <- sigmoid(5 * ((i + j) / (2 * n) - col.threshold)) c1_weight <- (c1_weight - c.min) / (c.max - c.min) c2_weight <- (c2_weight - c.min) / (c.max - c.min) c0_weight <- (c0_weight - c.min) / (c.max - c.min) C1_length <- sqrt(sum((C1 - C0) ** 2)) C2_length <- sqrt(sum((C2 - C0) ** 2)) C1_unit <- (C1 - C0) / C1_length C2_unit <- (C2 - C0) / C2_length C1_weight <- C1_unit * c1_weight C2_weight <- C2_unit * c2_weight C_blend <- C1_weight * (i - 1) * C1_length / (n - 1) + C2_weight * (j - 1) * C2_length / (n - 1) + (i - 1) * (j - 1) * c0_weight * C0 / (n - 1) ** 2 + C0 C_blend[C_blend > 255] <- 255 C_blend[C_blend < 0] <- 0 return(rgb( red = C_blend[, 1], green = C_blend[, 2], blue = C_blend[, 3], alpha = 255, maxColorValue = 255 )) } blend_matrix <- matrix(nrow = n, ncol = n) for (i in 1:n) { for (j in 1:n) { blend_matrix[i, j] <- blend_color( i = i, j = j, col.threshold = col.threshold, n = n, C0 = C0, C1 = C1, C2 = C2, merge.weight = merge.weight ) } } return(blend_matrix) } # Convert R colors to hexadecimal # # @param ... R colors # # @return The hexadecimal representations of input colors # #' @importFrom grDevices rgb col2rgb # Col2Hex <- function(...) { colors <- as.character(x = c(...)) alpha <- rep.int(x = 255, times = length(x = colors)) if (sum(sapply(X = colors, FUN = grepl, pattern = '^#')) != 0) { hex <- colors[which(x = grepl(pattern = '^#', x = colors))] hex.length <- sapply(X = hex, FUN = nchar) if (9 %in% hex.length) { hex.alpha <- hex[which(x = hex.length == 9)] hex.vals <- sapply(X = hex.alpha, FUN = substr, start = 8, stop = 9) dec.vals <- sapply(X = hex.vals, FUN = strtoi, base = 16) alpha[match(x = hex[which(x = hex.length == 9)], table = colors)] <- dec.vals } } colors <- t(x = col2rgb(col = colors)) colors <- mapply( FUN = function(i, alpha) { return(rgb(colors[i, , drop = FALSE], alpha = alpha, maxColorValue = 255)) }, i = 1:nrow(x = colors), alpha = alpha ) return(colors) } # Find the default DimReduc # # Searches for DimReducs matching 'umap', 'tsne', or 'pca', case-insensitive, and # in that order. Priority given to DimReducs matching the DefaultAssay or assay specified # (eg. 'pca' for the default assay weights higher than 'umap' for a non-default assay) # # @param object A Seurat object # @param assay Name of assay to use; defaults to the default assay of the object # # @return The default DimReduc, if possible # DefaultDimReduc <- function(object, assay = NULL) { assay <- assay %||% DefaultAssay(object = object) drs.use <- c('umap', 'tsne', 'pca') dim.reducs <- FilterObjects(object = object, classes.keep = 'DimReduc') drs.assay <- Filter( f = function(x) { return(DefaultAssay(object = object[[x]]) == assay) }, x = dim.reducs ) if (length(x = drs.assay) > 0) { index <- lapply( X = drs.use, FUN = grep, x = drs.assay, ignore.case = TRUE ) index <- Filter(f = length, x = index) if (length(x = index) > 0) { return(drs.assay[min(index[[1]])]) } } index <- lapply( X = drs.use, FUN = grep, x = dim.reducs, ignore.case = TRUE ) index <- Filter(f = length, x = index) if (length(x = index) < 1) { stop( "Unable to find a DimReduc matching one of '", paste(drs.use[1:(length(x = drs.use) - 1)], collapse = "', '"), "', or '", drs.use[length(x = drs.use)], "', please specify a dimensional reduction to use", call. = FALSE ) } return(dim.reducs[min(index[[1]])]) } # Plot feature expression by identity # # Basically combines the codebase for VlnPlot and RidgePlot # # @param object Seurat object # @param type Plot type, choose from 'ridge', 'violin', or 'multiViolin' # @param features Features to plot (gene expression, metrics, PC scores, # anything that can be retreived by FetchData) # @param idents Which classes to include in the plot (default is all) # @param ncol Number of columns if multiple plots are displayed # @param sort Sort identity classes (on the x-axis) by the average expression of the attribute being potted # @param y.max Maximum y axis value # @param same.y.lims Set all the y-axis limits to the same values # @param adjust Adjust parameter for geom_violin # @param pt.size Point size for geom_violin # @param cols Colors to use for plotting # @param group.by Group (color) cells in different ways (for example, orig.ident) # @param split.by A variable to split the plot by # @param log plot Y axis on log scale # @param combine Combine plots using cowplot::plot_grid # @param slot Use non-normalized counts data for plotting # @param ... Extra parameters passed to \code{\link{CombinePlots}} # #' @importFrom scales hue_pal #' @importFrom ggplot2 xlab ylab # ExIPlot <- function( object, features, type = 'violin', idents = NULL, ncol = NULL, sort = FALSE, assay = NULL, y.max = NULL, same.y.lims = FALSE, adjust = 1, cols = NULL, pt.size = 0, group.by = NULL, split.by = NULL, log = FALSE, combine = TRUE, slot = 'data', ... ) { assay <- assay %||% DefaultAssay(object = object) DefaultAssay(object = object) <- assay ncol <- ncol %||% ifelse( test = length(x = features) > 9, yes = 4, no = min(length(x = features), 3) ) data <- FetchData(object = object, vars = features, slot = slot) features <- colnames(x = data) if (is.null(x = idents)) { cells <- colnames(x = object) } else { cells <- names(x = Idents(object = object)[Idents(object = object) %in% idents]) } data <- data[cells, , drop = FALSE] idents <- if (is.null(x = group.by)) { Idents(object = object)[cells] } else { object[[group.by, drop = TRUE]][cells] } if (!is.factor(x = idents)) { idents <- factor(x = idents) } if (is.null(x = split.by)) { split <- NULL } else { split <- object[[split.by, drop = TRUE]][cells] if (!is.factor(x = split)) { split <- factor(x = split) } if (is.null(x = cols)) { cols <- hue_pal()(length(x = levels(x = idents))) cols <- Interleave(cols, InvertHex(hexadecimal = cols)) } else if (length(x = cols) == 1 && cols == 'interaction') { split <- interaction(idents, split) cols <- hue_pal()(length(x = levels(x = idents))) } else { cols <- Col2Hex(cols) } if (length(x = cols) < length(x = levels(x = split))) { cols <- Interleave(cols, InvertHex(hexadecimal = cols)) } cols <- rep_len(x = cols, length.out = length(x = levels(x = split))) names(x = cols) <- sort(x = levels(x = split)) } if (same.y.lims && is.null(x = y.max)) { y.max <- max(data) } plots <- lapply( X = features, FUN = function(x) { return(SingleExIPlot( type = type, data = data[, x, drop = FALSE], idents = idents, split = split, sort = sort, y.max = y.max, adjust = adjust, cols = cols, pt.size = pt.size, log = log, ... )) } ) label.fxn <- switch( EXPR = type, 'violin' = ylab, "multiViolin" = ylab, 'ridge' = xlab, stop("Unknown ExIPlot type ", type, call. = FALSE) ) for (i in 1:length(x = plots)) { key <- paste0(unlist(x = strsplit(x = features[i], split = '_'))[1], '_') obj <- names(x = which(x = Key(object = object) == key)) if (length(x = obj) == 1) { if (inherits(x = object[[obj]], what = 'DimReduc')) { plots[[i]] <- plots[[i]] + label.fxn(label = 'Embeddings Value') } else if (inherits(x = object[[obj]], what = 'Assay')) { next } else { warning("Unknown object type ", class(x = object), immediate. = TRUE, call. = FALSE) plots[[i]] <- plots[[i]] + label.fxn(label = NULL) } } else if (!features[i] %in% rownames(x = object)) { plots[[i]] <- plots[[i]] + label.fxn(label = NULL) } } if (combine) { combine.args <- list( 'plots' = plots, 'ncol' = ncol ) combine.args <- c(combine.args, list(...)) if (!'legend' %in% names(x = combine.args)) { combine.args$legend <- 'none' } plots <- do.call(what = 'CombinePlots', args = combine.args) } return(plots) } # Make a theme for facet plots # # @inheritParams SeuratTheme # @export # # @rdname SeuratTheme # @aliases FacetTheme # FacetTheme <- function(...) { return(theme( strip.background = element_blank(), strip.text = element_text(face = 'bold'), # Validate the theme validate = TRUE, ... )) } # Convert a ggplot2 scatterplot to base R graphics # # @param plot A ggplot2 scatterplot # @param do.plot Create the plot with base R graphics # @param ... Extra parameters passed to PlotBuild # # @return A dataframe with the data that created the ggplot2 scatterplot # #' @importFrom ggplot2 ggplot_build # GGpointToBase <- function(plot, do.plot = TRUE, ...) { plot.build <- ggplot_build(plot = plot) cols <- c('x', 'y', 'colour', 'shape', 'size') build.use <- which(x = vapply( X = plot.build$data, FUN = function(dat) { return(all(cols %in% colnames(x = dat))) }, FUN.VALUE = logical(length = 1L) )) if (length(x = build.use) == 0) { stop("GGpointToBase only works on geom_point ggplot objects") } build.data <- plot.build$data[[min(build.use)]] plot.data <- build.data[, cols] names(x = plot.data) <- c( plot.build$plot$labels$x, plot.build$plot$labels$y, 'color', 'pch', 'cex' ) if (do.plot) { PlotBuild(data = plot.data, ...) } return(plot.data) } # Get X and Y aesthetics from a plot for a certain geom # # @param plot A ggplot2 object # @param geom Geom class to filter to # @param plot.first Use plot-wide X/Y aesthetics before geom-specific aesthetics # # @return A named list with values 'x' for the name of the x aesthetic and 'y' for the y aesthetic # GetXYAesthetics <- function(plot, geom = 'GeomPoint', plot.first = TRUE) { geoms <- sapply( X = plot$layers, FUN = function(layer) { return(class(x = layer$geom)[1]) } ) geoms <- which(x = geoms == geom) if (length(x = geoms) == 0) { stop("Cannot find a geom of class ", geom) } geoms <- min(geoms) if (plot.first) { x <- as.character(x = plot$mapping$x %||% plot$layers[[geoms]]$mapping$x)[2] y <- as.character(x = plot$mapping$y %||% plot$layers[[geoms]]$mapping$y)[2] } else { x <- as.character(x = plot$layers[[geoms]]$mapping$x %||% plot$mapping$x)[2] y <- as.character(x = plot$layers[[geoms]]$mapping$y %||% plot$mapping$y)[2] } return(list('x' = x, 'y' = y)) } # A split violin plot geom # #' @importFrom scales zero_range #' @importFrom ggplot2 GeomPolygon #' @importFrom grid grobTree grobName # # @author jan-glx on StackOverflow # @references \url{https://stackoverflow.com/questions/35717353/split-violin-plot-with-ggplot2} # @seealso \code{\link[ggplot2]{geom_violin}} # GeomSplitViolin <- ggproto( "GeomSplitViolin", GeomViolin, # setup_data = function(data, params) { # data$width <- data$width %||% params$width %||% (resolution(data$x, FALSE) * 0.9) # data <- plyr::ddply(data, "group", transform, xmin = x - width/2, xmax = x + width/2) # e <- globalenv() # name <- paste(sample(x = letters, size = 5), collapse = '') # message("Saving initial data to ", name) # e[[name]] <- data # return(data) # }, draw_group = function(self, data, ..., draw_quantiles = NULL) { data$xminv <- data$x - data$violinwidth * (data$x - data$xmin) data$xmaxv <- data$x + data$violinwidth * (data$xmax - data$x) grp <- data[1, 'group'] if (grp %% 2 == 1) { data$x <- data$xminv data.order <- data$y } else { data$x <- data$xmaxv data.order <- -data$y } newdata <- data[order(data.order), , drop = FALSE] newdata <- rbind( newdata[1, ], newdata, newdata[nrow(x = newdata), ], newdata[1, ] ) newdata[c(1, nrow(x = newdata) - 1, nrow(x = newdata)), 'x'] <- round(x = newdata[1, 'x']) grob <- if (length(x = draw_quantiles) > 0 & !zero_range(x = range(data$y))) { stopifnot(all(draw_quantiles >= 0), all(draw_quantiles <= 1)) quantiles <- QuantileSegments(data = data, draw.quantiles = draw_quantiles) aesthetics <- data[rep.int(x = 1, times = nrow(x = quantiles)), setdiff(x = names(x = data), y = c("x", "y")), drop = FALSE] aesthetics$alpha <- rep.int(x = 1, nrow(x = quantiles)) both <- cbind(quantiles, aesthetics) quantile.grob <- GeomPath$draw_panel(both, ...) grobTree(GeomPolygon$draw_panel(newdata, ...), name = quantile.grob) } else { GeomPolygon$draw_panel(newdata, ...) } grob$name <- grobName(grob = grob, prefix = 'geom_split_violin') return(grob) } ) # Create a split violin plot geom # # @inheritParams ggplot2::geom_violin # #' @importFrom ggplot2 layer # # @author jan-glx on StackOverflow # @references \url{https://stackoverflow.com/questions/35717353/split-violin-plot-with-ggplot2} # @seealso \code{\link[ggplot2]{geom_violin}} # geom_split_violin <- function( mapping = NULL, data = NULL, stat = 'ydensity', position = 'identity', ..., draw_quantiles = NULL, trim = TRUE, scale = 'area', na.rm = FALSE, show.legend = NA, inherit.aes = TRUE ) { return(layer( data = data, mapping = mapping, stat = stat, geom = GeomSplitViolin, position = position, show.legend = show.legend, inherit.aes = inherit.aes, params = list( trim = trim, scale = scale, draw_quantiles = draw_quantiles, na.rm = na.rm, ... ) )) } # Invert a Hexadecimal color # # @param hexadecimal A character vector of hexadecimal colors # # @return Hexadecimal representations of the inverted color # # @author Matt Lagrandeur # @references \url{http://www.mattlag.com/scripting/hexcolorinverter.php} # InvertHex <- function(hexadecimal) { return(vapply( X = toupper(x = hexadecimal), FUN = function(hex) { hex <- unlist(x = strsplit( x = gsub(pattern = '#', replacement = '', x = hex), split = '' )) key <- toupper(x = as.hexmode(x = 15:0)) if (!all(hex %in% key)) { stop('All hexadecimal colors must be valid hexidecimal numbers from 0-9 and A-F') } if (length(x = hex) == 8) { alpha <- hex[7:8] hex <- hex[1:6] } else if (length(x = hex) == 6) { alpha <- NULL } else { stop("All hexidecimal colors must be either 6 or 8 characters in length, excluding the '#'") } value <- rev(x = key) inv.hex <- vapply( X = hex, FUN = function(x) { return(value[grep(pattern = x, x = key)]) }, FUN.VALUE = character(length = 1L) ) inv.hex <- paste(inv.hex, collapse = '') return(paste0('#', inv.hex, paste(alpha, collapse = ''))) }, FUN.VALUE = character(length = 1L), USE.NAMES = FALSE )) } # Make label information for ggplot2-based scatter plots # # @param data A three-column data frame (accessed with \code{plot$data}) # The first column should be the X axis, the second the Y, and the third should be grouping information # # @return A dataframe with three columns: centers along the X axis, centers along the Y axis, and group information # #' @importFrom stats median # MakeLabels <- function(data) { groups <- as.character(x = na.omit(object = unique(x = data[, 3]))) labels <- lapply( X = groups, FUN = function(group) { data.use <- data[data[, 3] == group, 1:2] return(apply(X = data.use, MARGIN = 2, FUN = median, na.rm = TRUE)) } ) names(x = labels) <- groups labels <- as.data.frame(x = t(x = as.data.frame(x = labels))) labels[, colnames(x = data)[3]] <- groups return(labels) } # Create a scatterplot with data from a ggplot2 scatterplot # # @param plot.data The original ggplot2 scatterplot data # This is taken from ggplot2::ggplot_build # @param dark.theme Plot using a dark theme # @param smooth Use a smooth scatterplot instead of a standard scatterplot # @param ... Extra parameters passed to graphics::plot or graphics::smoothScatter # #' @importFrom graphics axis plot smoothScatter # PlotBuild <- function(data, dark.theme = FALSE, smooth = FALSE, ...) { # Do we use a smooth scatterplot? # Take advantage of functions as first class objects # to dynamically choose normal vs smooth scatterplot myplot <- ifelse(test = smooth, yes = smoothScatter, no = plot) CheckDots(..., fxns = myplot) if (dark.theme) { par(bg = 'black') axes = FALSE col.lab = 'white' } else { axes = 'TRUE' col.lab = 'black' } myplot( data[, c(1, 2)], col = data$color, pch = data$pch, cex = vapply( X = data$cex, FUN = function(x) { return(max(x / 2, 0.5)) }, FUN.VALUE = numeric(1) ), axes = axes, col.lab = col.lab, col.main = col.lab, ... ) if (dark.theme) { axis( side = 1, at = NULL, labels = TRUE, col.axis = col.lab, col = col.lab ) axis( side = 2, at = NULL, labels = TRUE, col.axis = col.lab, col = col.lab ) } } # Locate points on a plot and return them # # @param plot A ggplot2 plot # @param recolor Do we recolor the plot to highlight selected points? # @param dark.theme Plot using a dark theme # @param ... Exptra parameters to PlotBuild # # @return A dataframe of x and y coordinates for points selected # #' @importFrom graphics locator # @importFrom SDMTools pnt.in.poly # PointLocator <- function(plot, recolor = TRUE, dark.theme = FALSE, ...) { # Convert the ggplot object to a data.frame PackageCheck('SDMTools') plot.data <- GGpointToBase(plot = plot, dark.theme = dark.theme, ...) npoints <- nrow(x = plot.data) cat("Click around the cluster of points you wish to select\n") cat("ie. select the vertecies of a shape around the cluster you\n") cat("are interested in. Press when finished (right click for R-terminal users)\n\n") polygon <- locator(n = npoints, type = 'l') polygon <- data.frame(polygon) # pnt.in.poly returns a data.frame of points points.all <- SDMTools::pnt.in.poly( pnts = plot.data[, c(1, 2)], poly.pnts = polygon ) # Find the located points points.located <- points.all[which(x = points.all$pip == 1), ] # If we're recoloring, do the recolor if (recolor) { no <- ifelse(test = dark.theme, yes = 'white', no = '#C3C3C3') points.all$color <- ifelse(test = points.all$pip == 1, yes = '#DE2D26', no = no) plot.data$color <- points.all$color PlotBuild(data = plot.data, dark.theme = dark.theme, ...) } return(points.located[, c(1, 2)]) } # Create quantile segments for quantiles on violin plots in ggplot2 # # @param data Data being plotted # @param draw.quantiles Quantiles to draw # #' @importFrom stats approxfun # # @author Hadley Wickham (I presume) # @seealso \code{\link[ggplot2]{geom_violin}} # QuantileSegments <- function(data, draw.quantiles) { densities <- cumsum(x = data$density) / sum(data$density) ecdf <- approxfun(x = densities, y = data$y) ys <- ecdf(v = draw.quantiles) violin.xminvs <- approxfun(x = data$y, y = data$xminv)(v = ys) violin.xmaxvs <- approxfun(x = data$y, y = data$xmaxv)(v = ys) return(data.frame( x = as.vector(x = t(x = data.frame(violin.xminvs, violin.xmaxvs))), y = rep(x = ys, each = 2), group = rep(x = ys, each = 2) )) } # Scale vector to min and max cutoff values # # @param vec a vector # @param cutoffs A two-length vector of cutoffs to be passed to \code{\link{SetQuantile}} # # @return Returns a vector # ScaleColumn <- function(vec, cutoffs) { if (!length(x = cutoffs) == 2) { stop("Two cutoffs (a low and high) are needed") } cutoffs <- sapply( X = cutoffs, FUN = SetQuantile, data = vec ) vec[vec < min(cutoffs)] <- min(cutoffs) vec[vec > max(cutoffs)] <- max(cutoffs) return(vec) } # Set highlight information # # @param cells.highlight Cells to highlight # @param cells.all A character vector of all cell names # @param sizes.highlight Sizes of cells to highlight # @param cols.highlight Colors to highlight cells as # @param col.base Base color to use for unselected cells # @param pt.size Size of unselected cells # # @return A list will cell highlight information # \describe{ # \item{plot.order}{An order to plot cells in} # \item{highlight}{A vector giving group information for each cell} # \item{size}{A vector giving size information for each cell} # \item{color}{Colors for highlighting in the order of plot.order} # } # SetHighlight <- function( cells.highlight, cells.all, sizes.highlight, cols.highlight, col.base = 'black', pt.size = 1 ) { if (is.character(x = cells.highlight)) { cells.highlight <- list(cells.highlight) } else if (is.data.frame(x = cells.highlight) || !is.list(x = cells.highlight)) { cells.highlight <- as.list(x = cells.highlight) } cells.highlight <- lapply( X = cells.highlight, FUN = function(cells) { cells.return <- if (is.character(x = cells)) { cells[cells %in% cells.all] } else { cells <- as.numeric(x = cells) cells <- cells[cells <= length(x = cells.all)] cells.all[cells] } return(cells.return) } ) cells.highlight <- Filter(f = length, x = cells.highlight) names.highlight <- if (is.null(x = names(x = cells.highlight))) { paste0('Group_', 1L:length(x = cells.highlight)) } else { names(x = cells.highlight) } sizes.highlight <- rep_len( x = sizes.highlight, length.out = length(x = cells.highlight) ) cols.highlight <- c( col.base, rep_len(x = cols.highlight, length.out = length(x = cells.highlight)) ) size <- rep_len(x = pt.size, length.out = length(x = cells.all)) highlight <- rep_len(x = NA_character_, length.out = length(x = cells.all)) if (length(x = cells.highlight) > 0) { for (i in 1:length(x = cells.highlight)) { cells.check <- cells.highlight[[i]] index.check <- match(x = cells.check, cells.all) highlight[index.check] <- names.highlight[i] size[index.check] <- sizes.highlight[i] } } plot.order <- sort(x = unique(x = highlight), na.last = TRUE) plot.order[is.na(x = plot.order)] <- 'Unselected' highlight[is.na(x = highlight)] <- 'Unselected' highlight <- as.factor(x = highlight) return(list( plot.order = plot.order, highlight = highlight, size = size, color = cols.highlight )) } # Find the quantile of a data # # Converts a quantile in character form to a number regarding some data # String form for a quantile is represented as a number prefixed with 'q' # For example, 10th quantile is 'q10' while 2nd quantile is 'q2' # # Will only take a quantile of non-zero data values # # @param cutoff The cutoff to turn into a quantile # @param data The data to turn find the quantile of # # @return The numerical representation of the quantile # #' @importFrom stats quantile # SetQuantile <- function(cutoff, data) { if (grepl(pattern = '^q[0-9]{1,2}$', x = as.character(x = cutoff), perl = TRUE)) { this.quantile <- as.numeric(x = sub( pattern = 'q', replacement = '', x = as.character(x = cutoff) )) / 100 data <- unlist(x = data) data <- data[data > 0] cutoff <- quantile(x = data, probs = this.quantile) } return(as.numeric(x = cutoff)) } globalVariables(names = '..density..', package = 'Seurat') # A single correlation plot # # @param data.plot A data frame with two columns to be plotted # @param col.by A vector or factor of values to color the plot by # @param cols An optional vector of colors to use # @param pt.size Point size for the plot # @param smooth Make a smoothed scatter plot # @param rows.highight A vector of rows to highlight (like cells.highlight in SingleDimPlot) # @param legend.title Optional legend title # @param ... Extra parameters to MASS::kde2d # #' @importFrom stats cor # #' @importFrom MASS kde2d #' @importFrom cowplot theme_cowplot #' @importFrom RColorBrewer brewer.pal.info #' @importFrom ggplot2 ggplot geom_point aes_string labs scale_color_brewer #' scale_color_manual guides stat_density2d aes scale_fill_continuous #' SingleCorPlot <- function( data, col.by = NULL, cols = NULL, pt.size = NULL, smooth = FALSE, rows.highlight = NULL, legend.title = NULL, na.value = 'grey50', span = NULL ) { pt.size <- pt.size <- pt.size %||% AutoPointSize(data = data) orig.names <- colnames(x = data) names.plot <- colnames(x = data) <- gsub( pattern = '-', replacement = '.', x = colnames(x = data), fixed = TRUE ) names.plot <- colnames(x = data) <- gsub( pattern = ':', replacement = '.', x = colnames(x = data), fixed = TRUE ) if (ncol(x = data) < 2) { msg <- "Too few variables passed" if (ncol(x = data) == 1) { msg <- paste0(msg, ', only have ', colnames(x = data)[1]) } stop(msg, call. = FALSE) } plot.cor <- round(x = cor(x = data[, 1], y = data[, 2]), digits = 2) if (!is.null(x = rows.highlight)) { highlight.info <- SetHighlight( cells.highlight = rows.highlight, cells.all = rownames(x = data), sizes.highlight = pt.size, cols.highlight = 'red', col.base = 'black', pt.size = pt.size ) cols <- highlight.info$color col.by <- factor( x = highlight.info$highlight, levels = rev(x = highlight.info$plot.order) ) plot.order <- order(col.by) data <- data[plot.order, ] col.by <- col.by[plot.order] } if (!is.null(x = col.by)) { data$colors <- col.by } plot <- ggplot( data = data, mapping = aes_string(x = names.plot[1], y = names.plot[2]) ) + labs( x = orig.names[1], y = orig.names[2], title = plot.cor, color = legend.title ) if (smooth) { # density <- kde2d(x = data[, names.plot[1]], y = data[, names.plot[2]], h = Bandwidth(data = data[, names.plot]), n = 200) # density <- data.frame( # expand.grid( # x = density$x, # y = density$y # ), # density = as.vector(x = density$z) # ) plot <- plot + stat_density2d( mapping = aes(fill = ..density.. ^ 0.25), geom = 'tile', contour = FALSE, n = 200, h = Bandwidth(data = data[, names.plot]) ) + # geom_tile( # mapping = aes_string( # x = 'x', # y = 'y', # fill = 'density' # ), # data = density # ) + scale_fill_continuous(low = 'white', high = 'dodgerblue4') + guides(fill = FALSE) } if (!is.null(x = col.by)) { plot <- plot + geom_point( mapping = aes_string(color = 'colors'), position = 'jitter', size = pt.size ) } else { plot <- plot + geom_point(position = 'jitter', size = pt.size) } if (!is.null(x = cols)) { cols.scale <- if (length(x = cols) == 1 && cols %in% rownames(x = brewer.pal.info)) { scale_color_brewer(palette = cols) } else { scale_color_manual(values = cols, na.value = na.value) } plot <- plot + cols.scale if (!is.null(x = rows.highlight)) { plot <- plot + guides(color = FALSE) } } plot <- plot + theme_cowplot() + theme(plot.title = element_text(hjust = 0.5)) if (!is.null(x = span)) { plot <- plot + geom_smooth( mapping = aes_string(x = names.plot[1], y = names.plot[2]), method = 'loess', span = span ) } return(plot) } # Plot a single dimension # # @param data Data to plot # @param dims A two-length numeric vector with dimensions to use # @param pt.size Adjust point size for plotting # @param col.by ... # @param cols Vector of colors, each color corresponds to an identity class. This may also be a single character # or numeric value corresponding to a palette as specified by \code{\link[RColorBrewer]{brewer.pal.info}}. # By default, ggplot2 assigns colors # @param shape.by If NULL, all points are circles (default). You can specify any cell attribute # (that can be pulled with FetchData) allowing for both different colors and different shapes on # cells. # @param order Specify the order of plotting for the idents. This can be useful for crowded plots if # points of interest are being buried. Provide either a full list of valid idents or a subset to be # plotted last (on top). # @param label Whether to label the clusters # @param repel Repel labels # @param label.size Sets size of labels # @param cells.highlight A list of character or numeric vectors of cells to # highlight. If only one group of cells desired, can simply # pass a vector instead of a list. If set, colors selected cells to the color(s) # in \code{cols.highlight} and other cells black (white if dark.theme = TRUE); # will also resize to the size(s) passed to \code{sizes.highlight} # @param cols.highlight A vector of colors to highlight the cells as; will # repeat to the length groups in cells.highlight # @param sizes.highlight Size of highlighted cells; will repeat to the length # groups in cells.highlight # @param na.value Color value for NA points when using custom scale. # #' @importFrom cowplot theme_cowplot #' @importFrom RColorBrewer brewer.pal.info #' @importFrom ggplot2 ggplot aes_string labs geom_text guides #' scale_color_brewer scale_color_manual element_rect guide_legend discrete_scale #' SingleDimPlot <- function( data, dims, col.by = NULL, cols = NULL, pt.size = NULL, shape.by = NULL, order = NULL, label = FALSE, repel = FALSE, label.size = 4, cells.highlight = NULL, cols.highlight = '#DE2D26', sizes.highlight = 1, na.value = 'grey50' ) { pt.size <- pt.size %||% AutoPointSize(data = data) if (length(x = dims) != 2) { stop("'dims' must be a two-length vector") } if (!is.data.frame(x = data)) { data <- as.data.frame(x = data) } if (is.character(x = dims) && !all(dims %in% colnames(x = data))) { stop("Cannot find dimensions to plot in data") } else if (is.numeric(x = dims)) { dims <- colnames(x = data)[dims] } if (!is.null(x = cells.highlight)) { highlight.info <- SetHighlight( cells.highlight = cells.highlight, cells.all = rownames(x = data), sizes.highlight = sizes.highlight %||% pt.size, cols.highlight = cols.highlight, col.base = cols[1] %||% '#C3C3C3', pt.size = pt.size ) order <- highlight.info$plot.order data$highlight <- highlight.info$highlight col.by <- 'highlight' pt.size <- highlight.info$size cols <- highlight.info$color } if (!is.null(x = order) && !is.null(x = col.by)) { if (typeof(x = order) == "logical") { if (order) { data <- data[order(data[, col.by]), ] } } else { order <- rev(x = c( order, setdiff(x = unique(x = data[, col.by]), y = order) )) data[, col.by] <- factor(x = data[, col.by], levels = order) new.order <- order(x = data[, col.by]) data <- data[new.order, ] if (length(x = pt.size) == length(x = new.order)) { pt.size <- pt.size[new.order] } } } if (!is.null(x = col.by) && !col.by %in% colnames(x = data)) { warning("Cannot find ", col.by, " in plotting data, not coloring plot") col.by <- NULL } else { # col.index <- grep(pattern = col.by, x = colnames(x = data), fixed = TRUE) col.index <- match(x = col.by, table = colnames(x = data)) if (grepl(pattern = '^\\d', x = col.by)) { # Do something for numbers col.by <- paste0('x', col.by) } else if (grepl(pattern = '-', x = col.by)) { # Do something for dashes col.by <- gsub(pattern = '-', replacement = '.', x = col.by) } colnames(x = data)[col.index] <- col.by } if (!is.null(x = shape.by) && !shape.by %in% colnames(x = data)) { warning("Cannot find ", shape.by, " in plotting data, not shaping plot") } plot <- ggplot(data = data) + geom_point( mapping = aes_string( x = dims[1], y = dims[2], color = paste0("`", col.by, "`"), shape = shape.by ), size = pt.size ) + guides(color = guide_legend(override.aes = list(size = 3))) + labs(color = NULL) if (label && !is.null(x = col.by)) { plot <- LabelClusters( plot = plot, id = col.by, repel = repel, size = label.size ) } if (!is.null(x = cols)) { if (length(x = cols) == 1 && (is.numeric(x = cols) || cols %in% rownames(x = brewer.pal.info))) { scale <- scale_color_brewer(palette = cols, na.value = na.value) } else if (length(x = cols) == 1 && (cols %in% c('alphabet', 'alphabet2', 'glasbey', 'polychrome', 'stepped'))) { colors <- DiscretePalette(length(unique(data[[col.by]])), palette = cols) scale <- scale_color_manual(values = colors, na.value = na.value) } else { scale <- scale_color_manual(values = cols, na.value = na.value) } plot <- plot + scale } plot <- plot + theme_cowplot() return(plot) } # Plot a single expression by identity on a plot # # @param type Make either a 'ridge' or 'violin' plot # @param data Data to plot # @param idents Idents to use # @param sort Sort identity classes (on the x-axis) by the average # expression of the attribute being potted # @param y.max Maximum Y value to plot # @param adjust Adjust parameter for geom_violin # @param cols Colors to use for plotting # @param log plot Y axis on log scale # @param seed.use Random seed to use. If NULL, don't set a seed # # @return A ggplot-based Expression-by-Identity plot # # @import ggplot2 #' @importFrom stats rnorm #' @importFrom utils globalVariables #' @importFrom ggridges geom_density_ridges theme_ridges #' @importFrom ggplot2 ggplot aes_string theme labs geom_violin geom_jitter ylim #' scale_fill_manual scale_y_log10 scale_x_log10 scale_y_discrete scale_x_continuous waiver #' @importFrom cowplot theme_cowplot #' SingleExIPlot <- function( data, idents, split = NULL, type = 'violin', sort = FALSE, y.max = NULL, adjust = 1, pt.size = 0, cols = NULL, seed.use = 42, log = FALSE ) { if (!is.null(x = seed.use)) { set.seed(seed = seed.use) } if (!is.data.frame(x = data) || ncol(x = data) != 1) { stop("'SingleExIPlot requires a data frame with 1 column") } feature <- colnames(x = data) data$ident <- idents if ((is.character(x = sort) && nchar(x = sort) > 0) || sort) { data$ident <- factor( x = data$ident, levels = names(x = rev(x = sort( x = tapply( X = data[, feature], INDEX = data$ident, FUN = mean ), decreasing = grepl(pattern = paste0('^', tolower(x = sort)), x = 'decreasing') ))) ) } if (log) { noise <- rnorm(n = length(x = data[, feature])) / 200 data[, feature] <- data[, feature] + 1 } else { noise <- rnorm(n = length(x = data[, feature])) / 100000 } if (all(data[, feature] == data[, feature][1])) { warning(paste0("All cells have the same value of ", feature, ".")) } else{ data[, feature] <- data[, feature] + noise } axis.label <- 'Expression Level' y.max <- y.max %||% max(data[, feature]) if (type == 'violin' && !is.null(x = split)) { data$split <- split vln.geom <- geom_split_violin fill <- 'split' } else if (type == 'multiViolin' && !is.null(x = split )) { data$split <- split vln.geom <- geom_violin fill <- 'split' type <- 'violin' } else { vln.geom <- geom_violin fill <- 'ident' } switch( EXPR = type, 'violin' = { x <- 'ident' y <- paste0("`", feature, "`") xlab <- 'Identity' ylab <- axis.label geom <- list( vln.geom(scale = 'width', adjust = adjust, trim = TRUE), theme(axis.text.x = element_text(angle = 45, hjust = 1)) ) jitter <- geom_jitter(height = 0, size = pt.size) log.scale <- scale_y_log10() axis.scale <- ylim }, 'ridge' = { x <- paste0("`", feature, "`") y <- 'ident' xlab <- axis.label ylab <- 'Identity' geom <- list( geom_density_ridges(scale = 4), theme_ridges(), scale_y_discrete(expand = c(0.01, 0)), scale_x_continuous(expand = c(0, 0)) ) jitter <- geom_jitter(width = 0, size = pt.size) log.scale <- scale_x_log10() axis.scale <- function(...) { invisible(x = NULL) } }, stop("Unknown plot type: ", type) ) plot <- ggplot( data = data, mapping = aes_string(x = x, y = y, fill = fill)[c(2, 3, 1)] ) + labs(x = xlab, y = ylab, title = feature, fill = NULL) + theme_cowplot() + theme(plot.title = element_text(hjust = 0.5)) plot <- do.call(what = '+', args = list(plot, geom)) plot <- plot + if (log) { log.scale } else { axis.scale(min(data[, feature]), y.max) } if (pt.size > 0) { plot <- plot + jitter } if (!is.null(x = cols)) { if (!is.null(x = split)) { idents <- unique(x = as.vector(x = data$ident)) splits <- unique(x = as.vector(x = data$split)) labels <- if (length(x = splits) == 2) { splits } else { unlist(x = lapply( X = idents, FUN = function(pattern, x) { x.mod <- gsub( pattern = paste0(pattern, '.'), replacement = paste0(pattern, ': '), x = x, fixed = TRUE ) x.keep <- grep(pattern = ': ', x = x.mod, fixed = TRUE) x.return <- x.mod[x.keep] names(x = x.return) <- x[x.keep] return(x.return) }, x = unique(x = as.vector(x = data$split)) )) } if (is.null(x = names(x = labels))) { names(x = labels) <- labels } } else { labels <- levels(x = droplevels(data$ident)) } plot <- plot + scale_fill_manual(values = cols, labels = labels) } return(plot) } # A single heatmap from base R using image # # @param data matrix of data to plot # @param order optional vector of cell names to specify order in plot # @param title Title for plot # #' @importFrom graphics par plot.new # SingleImageMap <- function(data, order = NULL, title = NULL) { if (!is.null(x = order)) { data <- data[order, ] } par(mar = c(1, 1, 3, 3)) plot.new() image( x = as.matrix(x = data), axes = FALSE, add = TRUE, col = PurpleAndYellow() ) axis( side = 4, at = seq(from = 0, to = 1, length = ncol(x = data)), labels = colnames(x = data), las = 1, tick = FALSE, mgp = c(0, -0.5, 0), cex.axis = 0.75 ) title(main = title) } # A single polygon plot # # @param data Data to plot # @param group.by Grouping variable # @param ... Extra parameters passed to \code{\link[cowplot]{theme_cowplot}} # # @return A ggplot-based plot # #' @importFrom cowplot theme_cowplot #' @importFrom ggplot2 ggplot aes_string geom_polygon # # @seealso \code{\link[cowplot]{theme_cowplot}} # SinglePolyPlot <- function(data, group.by, ...) { plot <- ggplot(data = data, mapping = aes_string(x = 'x', y = 'y')) + geom_polygon(mapping = aes_string(fill = group.by, group = 'cell')) + coord_fixed() + theme_cowplot(...) return(plot) } # A single heatmap from ggplot2 using geom_raster # # @param data A matrix or data frame with data to plot # @param raster switch between geom_raster and geom_tile # @param cell.order ... # @param feature.order ... # @param cols A vector of colors to use # @param disp.min Minimum display value (all values below are clipped) # @param disp.max Maximum display value (all values above are clipped) # @param limits A two-length numeric vector with the limits for colors on the plot # @param group.by A vector to group cells by, should be one grouping identity per cell # #' @importFrom ggplot2 ggplot aes_string geom_raster scale_fill_gradient #' scale_fill_gradientn theme element_blank labs geom_point guides guide_legend geom_tile # SingleRasterMap <- function( data, raster = TRUE, cell.order = NULL, feature.order = NULL, colors = PurpleAndYellow(), disp.min = -2.5, disp.max = 2.5, limits = NULL, group.by = NULL ) { data <- MinMax(data = data, min = disp.min, max = disp.max) data <- Melt(x = t(x = data)) colnames(x = data) <- c('Feature', 'Cell', 'Expression') if (!is.null(x = feature.order)) { data$Feature <- factor(x = data$Feature, levels = unique(x = feature.order)) } if (!is.null(x = cell.order)) { data$Cell <- factor(x = data$Cell, levels = unique(x = cell.order)) } if (!is.null(x = group.by)) { data$Identity <- group.by[data$Cell] } limits <- limits %||% c(min(data$Expression), max(data$Expression)) if (length(x = limits) != 2 || !is.numeric(x = limits)) { stop("limits' must be a two-length numeric vector") } my_geom <- ifelse(test = raster, yes = geom_raster, no = geom_tile) plot <- ggplot(data = data) + my_geom(mapping = aes_string(x = 'Cell', y = 'Feature', fill = 'Expression')) + theme(axis.text.x = element_blank(), axis.ticks.x = element_blank()) + scale_fill_gradientn(limits = limits, colors = colors, na.value = "white") + labs(x = NULL, y = NULL, fill = group.by %iff% 'Expression') + WhiteBackground() + NoAxes(keep.text = TRUE) if (!is.null(x = group.by)) { plot <- plot + geom_point( mapping = aes_string(x = 'Cell', y = 'Feature', color = 'Identity'), alpha = 0 ) + guides(color = guide_legend(override.aes = list(alpha = 1))) } return(plot) } Seurat/R/preprocessing.R0000644000176200001440000031462713617632510014745 0ustar liggesusers#' @include generics.R #' NULL #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Functions #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' Calculate the Barcode Distribution Inflection #' #' This function calculates an adaptive inflection point ("knee") of the barcode distribution #' for each sample group. This is useful for determining a threshold for removing #' low-quality samples. #' #' The function operates by calculating the slope of the barcode number vs. rank #' distribution, and then finding the point at which the distribution changes most #' steeply (the "knee"). Of note, this calculation often must be restricted as to the #' range at which it performs, so `threshold` parameters are provided to restrict the #' range of the calculation based on the rank of the barcodes. [BarcodeInflectionsPlot()] #' is provided as a convenience function to visualize and test different thresholds and #' thus provide more sensical end results. #' #' See [BarcodeInflectionsPlot()] to visualize the calculated inflection points and #' [SubsetByBarcodeInflections()] to subsequently subset the Seurat object. #' #' @param object Seurat object #' @param barcode.column Column to use as proxy for barcodes ("nCount_RNA" by default) #' @param group.column Column to group by ("orig.ident" by default) #' @param threshold.high Ignore barcodes of rank above thisf threshold in inflection calculation #' @param threshold.low Ignore barcodes of rank below this threshold in inflection calculation #' #' @return Returns Seurat object with a new list in the `tools` slot, `CalculateBarcodeInflections` with values: #' #' * `barcode_distribution` - contains the full barcode distribution across the entire dataset #' * `inflection_points` - the calculated inflection points within the thresholds #' * `threshold_values` - the provided (or default) threshold values to search within for inflections #' * `cells_pass` - the cells that pass the inflection point calculation #' #' @importFrom methods slot #' @importFrom stats ave aggregate #' #' @export #' #' @author Robert A. Amezquita, \email{robert.amezquita@fredhutch.org} #' @seealso \code{\link{BarcodeInflectionsPlot}} \code{\link{SubsetByBarcodeInflections}} #' #' @examples #' CalculateBarcodeInflections(pbmc_small, group.column = 'groups') #' CalculateBarcodeInflections <- function( object, barcode.column = "nCount_RNA", group.column = "orig.ident", threshold.low = NULL, threshold.high = NULL ) { ## Check that barcode.column exists in meta.data if (!(barcode.column %in% colnames(x = object[[]]))) { stop("`barcode.column` specified not present in Seurat object provided") } # Calculation of barcode distribution ## Append rank by grouping x umi column # barcode_dist <- as.data.frame(object@meta.data)[, c(group.column, barcode.column)] barcode_dist <- object[[c(group.column, barcode.column)]] barcode_dist <- barcode_dist[do.call(what = order, args = barcode_dist), ] # order by columns left to right barcode_dist$rank <- ave( x = barcode_dist[, barcode.column], barcode_dist[, group.column], FUN = function(x) { return(rev(x = order(x))) } ) barcode_dist <- barcode_dist[order(barcode_dist[, group.column], barcode_dist[, 'rank']), ] ## calculate rawdiff and append per group top <- aggregate( x = barcode_dist[, barcode.column], by = list(barcode_dist[, group.column]), FUN = function(x) { return(c(0, diff(x = log10(x = x + 1)))) })$x bot <- aggregate( x = barcode_dist[, 'rank'], by = list(barcode_dist[, group.column]), FUN = function(x) { return(c(0, diff(x = x))) } )$x barcode_dist$rawdiff <- unlist(x = mapply( FUN = function(x, y) { return(ifelse(test = is.na(x = x / y), yes = 0, no = x / y)) }, x = top, y = bot )) # Calculation of inflection points ## Set thresholds for rank of barcodes to ignore threshold.low <- threshold.low %||% 1 threshold.high <- threshold.high %||% max(barcode_dist$rank) ## Subset the barcode distribution by thresholds barcode_dist_sub <- barcode_dist[barcode_dist$rank > threshold.low & barcode_dist$rank < threshold.high, ] ## Calculate inflection points ## note: if thresholds are s.t. it produces the same length across both groups, ## aggregate will create a data.frame with x.* columns, where * is the length ## using the same combine approach will yield non-symmetrical results! whichmin_list <- aggregate( x = barcode_dist_sub[, 'rawdiff'], by = list(barcode_dist_sub[, group.column]), FUN = function(x) { return(x == min(x)) } )$x ## workaround for aggregate behavior noted above if (is.list(x = whichmin_list)) { # uneven lengths is_inflection <- unlist(x = whichmin_list) } else if (is.matrix(x = whichmin_list)) { # even lengths is_inflection <- as.vector(x = t(x = whichmin_list)) } tmp <- cbind(barcode_dist_sub, is_inflection) # inflections <- tmp[tmp$is_inflection == TRUE, c(group.column, barcode.column, "rank")] inflections <- tmp[which(x = tmp$is_inflection), c(group.column, barcode.column, 'rank')] # Use inflection point for what cells to keep ## use the inflection points to cut the subsetted dist to what to keep ## keep only the barcodes above the inflection points keep <- unlist(x = lapply( X = whichmin_list, FUN = function(x) { keep <- !x if (sum(keep) == length(x = keep)) { return(keep) # prevents bug in case of keeping all cells } # toss <- which(keep == FALSE):length(x = keep) # the end cells below knee toss <- which(x = !keep):length(x = keep) keep[toss] <- FALSE return(keep) } )) barcode_dist_sub_keep <- barcode_dist_sub[keep, ] cells_keep <- rownames(x = barcode_dist_sub_keep) # Bind thresholds to keep track of where they are placed thresholds <- data.frame( threshold = c('threshold.low', 'threshold.high'), rank = c(threshold.low, threshold.high) ) # Combine relevant info together ## Combine Barcode dist, inflection point, and cells to keep into list info <- list( barcode_distribution = barcode_dist, inflection_points = inflections, threshold_values = thresholds, cells_pass = cells_keep ) # save results into object Tool(object = object) <- info return(object) } #' Convert a peak matrix to a gene activity matrix #' #' This function will take in a peak matrix and an annotation file (gtf) and collapse the peak #' matrix to a gene activity matrix. It makes the simplifying assumption that all counts in the gene #' body plus X kb up and or downstream should be attributed to that gene. #' #' @param peak.matrix Matrix of peak counts #' @param annotation.file Path to GTF annotation file #' @param seq.levels Which seqlevels to keep (corresponds to chromosomes usually) #' @param include.body Include the gene body? #' @param upstream Number of bases upstream to consider #' @param downstream Number of bases downstream to consider #' @param verbose Print progress/messages #' #' @importFrom future nbrOfWorkers #' @export #' CreateGeneActivityMatrix <- function( peak.matrix, annotation.file, seq.levels = c(1:22, "X", "Y"), include.body = TRUE, upstream = 2000, downstream = 0, verbose = TRUE ) { if (!PackageCheck('GenomicRanges', error = FALSE)) { stop("Please install GenomicRanges from Bioconductor.") } if (!PackageCheck('rtracklayer', error = FALSE)) { stop("Please install rtracklayer from Bioconductor.") } # convert peak matrix to GRanges object peak.df <- rownames(x = peak.matrix) peak.df <- do.call(what = rbind, args = strsplit(x = gsub(peak.df, pattern = ":", replacement = "-"), split = "-")) peak.df <- as.data.frame(x = peak.df) colnames(x = peak.df) <- c("chromosome", 'start', 'end') peaks.gr <- GenomicRanges::makeGRangesFromDataFrame(df = peak.df) # if any peaks start at 0, change to 1 # otherwise GenomicRanges::distanceToNearest will not work BiocGenerics::start(peaks.gr[BiocGenerics::start(peaks.gr) == 0, ]) <- 1 # get annotation file, select genes gtf <- rtracklayer::import(con = annotation.file) gtf <- GenomeInfoDb::keepSeqlevels(x = gtf, value = seq.levels, pruning.mode = 'coarse') # change seqlevelsStyle if not the same if (!any(GenomeInfoDb::seqlevelsStyle(x = gtf) == GenomeInfoDb::seqlevelsStyle(x = peaks.gr))) { GenomeInfoDb::seqlevelsStyle(gtf) <- GenomeInfoDb::seqlevelsStyle(peaks.gr) } gtf.genes <- gtf[gtf$type == 'gene'] # Extend definition up/downstream if (include.body) { gtf.body_prom <- Extend(x = gtf.genes, upstream = upstream, downstream = downstream) } else { gtf.body_prom <- SummarizedExperiment::promoters(x = gtf.genes, upstream = upstream, downstream = downstream) } gene.distances <- GenomicRanges::distanceToNearest(x = peaks.gr, subject = gtf.body_prom) keep.overlaps <- gene.distances[rtracklayer::mcols(x = gene.distances)$distance == 0] peak.ids <- peaks.gr[S4Vectors::queryHits(x = keep.overlaps)] gene.ids <- gtf.genes[S4Vectors::subjectHits(x = keep.overlaps)] # Some GTF rows will not have gene_name attribute # Replace it by gene_id attribute gene.ids$gene_name[is.na(gene.ids$gene_name)] <- gene.ids$gene_id[is.na(gene.ids$gene_name)] peak.ids$gene.name <- gene.ids$gene_name peak.ids <- as.data.frame(x = peak.ids) peak.ids$peak <- rownames(peak.matrix)[S4Vectors::queryHits(x = keep.overlaps)] annotations <- peak.ids[, c('peak', 'gene.name')] colnames(x = annotations) <- c('feature', 'new_feature') # collapse into expression matrix peak.matrix <- as(object = peak.matrix, Class = 'matrix') all.features <- unique(x = annotations$new_feature) if (nbrOfWorkers() > 1) { mysapply <- future_sapply } else { mysapply <- ifelse(test = verbose, yes = pbsapply, no = sapply) } newmat <- mysapply(X = 1:length(x = all.features), FUN = function(x){ features.use <- annotations[annotations$new_feature == all.features[[x]], ]$feature submat <- peak.matrix[features.use, ] if (length(x = features.use) > 1) { return(Matrix::colSums(x = submat)) } else { return(submat) } }) newmat <- t(x = newmat) rownames(x = newmat) <- all.features colnames(x = newmat) <- colnames(x = peak.matrix) return(as(object = newmat, Class = 'dgCMatrix')) } #' Demultiplex samples based on data from cell 'hashing' #' #' Assign sample-of-origin for each cell, annotate doublets. #' #' @param object Seurat object. Assumes that the hash tag oligo (HTO) data has been added and normalized. #' @param assay Name of the Hashtag assay (HTO by default) #' @param positive.quantile The quantile of inferred 'negative' distribution for each hashtag - over which the cell is considered 'positive'. Default is 0.99 #' @param init Initial number of clusters for hashtags. Default is the # of hashtag oligo names + 1 (to account for negatives) #' @param kfunc Clustering function for initial hashtag grouping. Default is "clara" for fast k-medoids clustering on large applications, also support "kmeans" for kmeans clustering #' @param nsamples Number of samples to be drawn from the dataset used for clustering, for kfunc = "clara" #' @param nstarts nstarts value for k-means clustering (for kfunc = "kmeans"). 100 by default #' @param seed Sets the random seed. If NULL, seed is not set #' @param verbose Prints the output #' #' @return The Seurat object with the following demultiplexed information stored in the meta data: #' \describe{ #' \item{hash.maxID}{Name of hashtag with the highest signal} #' \item{hash.secondID}{Name of hashtag with the second highest signal} #' \item{hash.margin}{The difference between signals for hash.maxID and hash.secondID} #' \item{classification}{Classification result, with doublets/multiplets named by the top two highest hashtags} #' \item{classification.global}{Global classification result (singlet, doublet or negative)} #' \item{hash.ID}{Classification result where doublet IDs are collapsed} #' } #' #' @importFrom cluster clara #' @importFrom Matrix colSums #' @importFrom fitdistrplus fitdist #' @importFrom stats pnbinom kmeans #' #' @export #' #' @seealso \code{\link{HTOHeatmap}} #' #' @examples #' \dontrun{ #' object <- HTODemux(object) #' } #' HTODemux <- function( object, assay = "HTO", positive.quantile = 0.99, init = NULL, nstarts = 100, kfunc = "clara", nsamples = 100, seed = 42, verbose = TRUE ) { if (!is.null(x = seed)) { set.seed(seed = seed) } #initial clustering assay <- assay %||% DefaultAssay(object = object) data <- GetAssayData(object = object, assay = assay) counts <- GetAssayData( object = object, assay = assay, slot = 'counts' )[, colnames(x = object)] counts <- as.matrix(x = counts) ncenters <- init %||% (nrow(x = data) + 1) switch( EXPR = kfunc, 'kmeans' = { init.clusters <- kmeans( x = t(x = GetAssayData(object = object, assay = assay)), centers = ncenters, nstart = nstarts ) #identify positive and negative signals for all HTO Idents(object = object, cells = names(x = init.clusters$cluster)) <- init.clusters$cluster }, 'clara' = { #use fast k-medoid clustering init.clusters <- clara( x = t(x = GetAssayData(object = object, assay = assay)), k = ncenters, samples = nsamples ) #identify positive and negative signals for all HTO Idents(object = object, cells = names(x = init.clusters$clustering), drop = TRUE) <- init.clusters$clustering }, stop("Unknown k-means function ", kfunc, ", please choose from 'kmeans' or 'clara'") ) #average hto signals per cluster #work around so we don't average all the RNA levels which takes time average.expression <- AverageExpression( object = object, assays = assay, verbose = FALSE )[[assay]] #checking for any cluster with all zero counts for any barcode if (sum(average.expression == 0) > 0) { stop("Cells with zero counts exist as a cluster.") } #create a matrix to store classification result discrete <- GetAssayData(object = object, assay = assay) discrete[discrete > 0] <- 0 # for each HTO, we will use the minimum cluster for fitting for (iter in rownames(x = data)) { values <- counts[iter, colnames(object)] #commented out if we take all but the top cluster as background #values_negative=values[setdiff(object@cell.names,WhichCells(object,which.max(average.expression[iter,])))] values.use <- values[WhichCells( object = object, idents = levels(x = Idents(object = object))[[which.min(x = average.expression[iter, ])]] )] fit <- suppressWarnings(expr = fitdist(data = values.use, distr = "nbinom")) cutoff <- as.numeric(x = quantile(x = fit, probs = positive.quantile)$quantiles[1]) discrete[iter, names(x = which(x = values > cutoff))] <- 1 if (verbose) { message(paste0("Cutoff for ", iter, " : ", cutoff, " reads")) } } # now assign cells to HTO based on discretized values npositive <- colSums(x = discrete) classification.global <- npositive classification.global[npositive == 0] <- "Negative" classification.global[npositive == 1] <- "Singlet" classification.global[npositive > 1] <- "Doublet" donor.id = rownames(x = data) hash.max <- apply(X = data, MARGIN = 2, FUN = max) hash.maxID <- apply(X = data, MARGIN = 2, FUN = which.max) hash.second <- apply(X = data, MARGIN = 2, FUN = MaxN, N = 2) hash.maxID <- as.character(x = donor.id[sapply( X = 1:ncol(x = data), FUN = function(x) { return(which(x = data[, x] == hash.max[x])[1]) } )]) hash.secondID <- as.character(x = donor.id[sapply( X = 1:ncol(x = data), FUN = function(x) { return(which(x = data[, x] == hash.second[x])[1]) } )]) hash.margin <- hash.max - hash.second doublet_id <- sapply( X = 1:length(x = hash.maxID), FUN = function(x) { return(paste(sort(x = c(hash.maxID[x], hash.secondID[x])), collapse = "_")) } ) # doublet_names <- names(x = table(doublet_id))[-1] # Not used classification <- classification.global classification[classification.global == "Negative"] <- "Negative" classification[classification.global == "Singlet"] <- hash.maxID[which(x = classification.global == "Singlet")] classification[classification.global == "Doublet"] <- doublet_id[which(x = classification.global == "Doublet")] classification.metadata <- data.frame( hash.maxID, hash.secondID, hash.margin, classification, classification.global ) colnames(x = classification.metadata) <- paste( assay, c('maxID', 'secondID', 'margin', 'classification', 'classification.global'), sep = '_' ) object <- AddMetaData(object = object, metadata = classification.metadata) Idents(object) <- paste0(assay, '_classification') # Idents(object, cells = rownames(object@meta.data[object@meta.data$classification.global == "Doublet", ])) <- "Doublet" doublets <- rownames(x = object[[]])[which(object[[paste0(assay, "_classification.global")]] == "Doublet")] Idents(object = object, cells = doublets) <- 'Doublet' # object@meta.data$hash.ID <- Idents(object) object$hash.ID <- Idents(object = object) return(object) } #' Calculate pearson residuals of features not in the scale.data #' #' This function calls sctransform::get_residuals. #' #' @param object A seurat object #' @param features Name of features to add into the scale.data #' @param assay Name of the assay of the seurat object generated by SCTransform #' @param umi.assay Name of the assay of the seurat object containing UMI matrix and the default is #' RNA #' @param clip.range Numeric of length two specifying the min and max values the Pearson residual #' will be clipped to #' @param replace.value Recalculate residuals for all features, even if they are already present. #' Useful if you want to change the clip.range. #' @param verbose Whether to print messages and progress bars #' #' @return Returns a Seurat object containing pearson residuals of added features in its scale.data #' #' @importFrom sctransform get_residuals #' #' @export #' #' @seealso \code{\link[sctransform]{get_residuals}} #' #' @examples #' pbmc_small <- SCTransform(object = pbmc_small, variable.features.n = 20) #' pbmc_small <- GetResidual(object = pbmc_small, features = c('MS4A1', 'TCL1A')) #' GetResidual <- function( object, features, assay = "SCT", umi.assay = "RNA", clip.range = NULL, replace.value = FALSE, verbose = TRUE ) { if (!IsSCT(assay = object[[assay]])) { stop(assay, " assay was not generated by SCTransform") } if (replace.value) { new_features <- features } else { new_features <- setdiff( x = features, y = rownames(x = GetAssayData(object = object, assay = assay, slot = "scale.data")) ) } if (length(x = new_features) == 0) { if (verbose) { message("Pearson residuals of input features exist already") } } else { if (is.null(x = Misc(object = object[[assay]], slot = 'vst.set'))) { vst_out <- Misc(object = object[[assay]], slot = 'vst.out') # filter cells not in the object but in the SCT model vst_out$cell_attr <- vst_out$cell_attr[Cells(x = object), ] vst_out$cells_step1 <- intersect(x = vst_out$cells_step1, y = Cells(x = object)) object <- GetResidualVstOut( object = object, assay = assay, umi.assay = umi.assay, new_features = new_features, vst_out = vst_out, clip.range = clip.range, verbose = verbose ) } else { # Calculate Pearson Residual from integrated object SCT assay vst.set <- Misc(object = object[[assay]], slot = 'vst.set') scale.data <- GetAssayData( object = object, assay = assay, slot = "scale.data" ) vst_set_genes <- sapply(1:length(vst.set), function(x) rownames(vst.set[[x]]$model_pars_fit)) vst_set_genes <- Reduce(intersect, vst_set_genes) diff_features <- setdiff( x = new_features, y = vst_set_genes ) if (length(x = diff_features) !=0) { warning( "The following ", length(x = diff_features), " features do not exist in all SCT models: ", paste(diff_features, collapse = " ") ) } new_features <- intersect( x = new_features, y = vst_set_genes ) if (length(new_features) != 0){ object <- SetAssayData( object = object, assay = assay, slot = "scale.data", new.data = scale.data[!rownames(x = scale.data) %in% new_features, , drop = FALSE] ) new.scale.data <- matrix(nrow = length(new_features), ncol = 0) rownames(x = new.scale.data) <- new_features for (v in 1:length(x = vst.set)) { vst_out <- vst.set[[v]] # confirm that cells from SCT model also exist in the integrated object cells.v <- intersect(x = rownames(x = vst_out$cell_attr), y = Cells(x = object)) vst_out$cell_attr <- vst_out$cell_attr[cells.v, ] vst_out$cells_step1 <- intersect(x = vst_out$cells_step1, y = cells.v) object.v <- subset(x = object, cells = cells.v) object.v <- GetResidualVstOut( object = object.v, assay = assay, umi.assay = umi.assay, new_features = new_features, vst_out = vst_out, clip.range = clip.range, verbose = verbose ) new.scale.data <- cbind( new.scale.data, GetAssayData(object = object.v, assay = assay, slot ="scale.data" )[new_features, , drop = FALSE] ) } object <- SetAssayData( object = object, assay = assay, slot = "scale.data", new.data = rbind( GetAssayData(object = object, slot = 'scale.data', assay = assay), new.scale.data ) ) } } } return(object) } #' Normalize raw data #' #' Normalize count data per cell and transform to log scale #' #' @param data Matrix with the raw count data #' @param scale.factor Scale the data. Default is 1e4 #' @param verbose Print progress #' #' @return Returns a matrix with the normalize and log transformed data #' #' @import Matrix #' @importFrom methods as #' #' @export #' #' @examples #' mat <- matrix(data = rbinom(n = 25, size = 5, prob = 0.2), nrow = 5) #' mat #' mat_norm <- LogNormalize(data = mat) #' mat_norm #' LogNormalize <- function(data, scale.factor = 1e4, verbose = TRUE) { if (is.data.frame(x = data)) { data <- as.matrix(x = data) } if (!inherits(x = data, what = 'dgCMatrix')) { data <- as(object = data, Class = "dgCMatrix") } # call Rcpp function to normalize if (verbose) { cat("Performing log-normalization\n", file = stderr()) } norm.data <- LogNorm(data, scale_factor = scale.factor, display_progress = verbose) colnames(x = norm.data) <- colnames(x = data) rownames(x = norm.data) <- rownames(x = data) return(norm.data) } #' Demultiplex samples based on classification method from MULTI-seq (McGinnis et al., bioRxiv 2018) #' #' Identify singlets, doublets and negative cells from multiplexing experiments. Annotate singlets by tags. #' #' @param object Seurat object. Assumes that the specified assay data has been added #' @param assay Name of the multiplexing assay (HTO by default) #' @param quantile The quantile to use for classification #' @param autoThresh Whether to perform automated threshold finding to define the best quantile. Default is FALSE #' @param maxiter Maximum number of iterations if autoThresh = TRUE. Default is 5 #' @param qrange A range of possible quantile values to try if autoThresh = TRUE #' @param verbose Prints the output #' #' @return A Seurat object with demultiplexing results stored at \code{object$MULTI_ID} #' #' @import Matrix #' #' @export #' #' @references \url{https://www.biorxiv.org/content/early/2018/08/08/387241} #' #' @examples #' \dontrun{ #' object <- MULTIseqDemux(object) #' } #' MULTIseqDemux <- function( object, assay = "HTO", quantile = 0.7, autoThresh = FALSE, maxiter = 5, qrange = seq(from = 0.1, to = 0.9, by = 0.05), verbose = TRUE ) { assay <- assay %||% DefaultAssay(object = object) multi_data_norm <- t(x = GetAssayData( object = object, slot = "data", assay = assay )) if (autoThresh) { iter <- 1 negatives <- c() neg.vector <- c() while (iter <= maxiter) { # Iterate over q values to find ideal barcode thresholding results by maximizing singlet classifications bar.table_sweep.list <- list() n <- 0 for (q in qrange) { n <- n + 1 # Generate list of singlet/doublet/negative classifications across q sweep bar.table_sweep.list[[n]] <- ClassifyCells(data = multi_data_norm, q = q) names(x = bar.table_sweep.list)[n] <- paste0("q=" , q) } # Determine which q values results in the highest pSinglet res_round <- FindThresh(call.list = bar.table_sweep.list)$res res.use <- res_round[res_round$Subset == "pSinglet", ] q.use <- res.use[which.max(res.use$Proportion),"q"] if (verbose) { message("Iteration ", iter) message("Using quantile ", q.use) } round.calls <- ClassifyCells(data = multi_data_norm, q = q.use) #remove negative cells neg.cells <- names(x = round.calls)[which(x = round.calls == "Negative")] neg.vector <- c(neg.vector, rep(x = "Negative", length(x = neg.cells))) negatives <- c(negatives, neg.cells) if (length(x = neg.cells) == 0) { break } multi_data_norm <- multi_data_norm[-which(x = rownames(x = multi_data_norm) %in% neg.cells), ] iter <- iter + 1 } names(x = neg.vector) <- negatives demux_result <- c(round.calls,neg.vector) demux_result <- demux_result[rownames(x = object[[]])] } else{ demux_result <- ClassifyCells(data = multi_data_norm, q = quantile) } demux_result <- demux_result[rownames(x = object[[]])] object[['MULTI_ID']] <- factor(x = demux_result) Idents(object = object) <- "MULTI_ID" bcs <- colnames(x = multi_data_norm) bc.max <- bcs[apply(X = multi_data_norm, MARGIN = 1, FUN = which.max)] bc.second <- bcs[unlist(x = apply( X = multi_data_norm, MARGIN = 1, FUN = function(x) { return(which(x == MaxN(x))) } ))] doublet.names <- unlist(x = lapply( X = 1:length(x = bc.max), FUN = function(x) { return(paste(sort(x = c(bc.max[x], bc.second[x])), collapse = "_")) } )) doublet.id <- which(x = demux_result == "Doublet") MULTI_classification <- as.character(object$MULTI_ID) MULTI_classification[doublet.id] <- doublet.names[doublet.id] object$MULTI_classification <- factor(x = MULTI_classification) return(object) } #' Load in data from Alevin pipeline #' #' Enables easy loading of csv format matrix provided by Alevin #' ran with `--dumpCsvCounts` flags. #' #' @param base.path Directory containing the alevin/quant_mat* #' files provided by Alevin. #' #' @return Returns a matrix with rows and columns labeled #' #' @importFrom utils read.csv read.delim #' @export #' #' @author Avi Srivastava #' #' @examples #' \dontrun{ #' data_dir <- 'path/to/output/directory' #' list.files(data_dir) # Should show alevin/quants_mat* files #' expression_matrix <- ReadAlevinCsv(base.path = data_dir) #' seurat_object = CreateSeuratObject(counts = expression_matrix) #' } #' ReadAlevinCsv <- function(base.path) { if (!dir.exists(base.path)) { stop("Directory provided does not exist") } barcode.loc <- file.path(base.path, "alevin", "quants_mat_rows.txt") gene.loc <- file.path(base.path, "alevin", "quants_mat_cols.txt") matrix.loc <- file.path( base.path, "alevin", "quants_mat.csv" ) if (!file.exists(barcode.loc)) { stop("Barcode file missing") } if (!file.exists(gene.loc)) { stop("Gene name file missing") } if (!file.exists(matrix.loc)) { stop("Expression matrix file missing") } matrix <- as.matrix(x = read.csv(file = matrix.loc, header = FALSE)) matrix <- t(x = matrix[, 1:ncol(x = matrix) - 1]) cell.names <- readLines(con = barcode.loc) gene.names <- readLines(con = gene.loc) colnames(x = matrix) <- cell.names rownames(x = matrix) <- gene.names matrix[is.na(x = matrix)] <- 0 return(matrix) } #' Load in data from Alevin pipeline #' #' Enables easy loading of binary format matrix provided by Alevin #' #' @param base.path Directory containing the alevin/quant_mat* #' files provided by Alevin. #' #' @return Returns a matrix with rows and columns labeled #' #' @export #' #' @author Avi Srivastava #' #' @examples #' \dontrun{ #' data_dir <- 'path/to/output/directory' #' list.files(data_dir) # Should show alevin/quants_mat* files #' expression_matrix <- ReadAlevin(base.path = data_dir) #' seurat_object = CreateSeuratObject(counts = expression_matrix) #' } #' ReadAlevin <- function(base.path) { if (!dir.exists(base.path)) { stop("Directory provided does not exist") } barcode.loc <- file.path(base.path, "alevin", "quants_mat_rows.txt") gene.loc <- file.path(base.path, "alevin", "quants_mat_cols.txt") matrix.loc <- file.path(base.path, "alevin", "quants_mat.gz") if (!file.exists(barcode.loc)) { stop("Barcode file missing") } if (!file.exists(gene.loc)) { stop("Gene name file missing") } if (!file.exists(matrix.loc)) { stop("Expression matrix file missing") } cell.names <- readLines(con = barcode.loc) gene.names <- readLines(con = gene.loc) num.cells <- length(x = cell.names) num.genes <- length(x = gene.names) out.matrix <- matrix(data = NA, nrow = num.genes, ncol = num.cells) con <- gzcon(con = file(description = matrix.loc, open = "rb")) total.molecules <- 0.0 for (n in seq_len(length.out = num.cells)) { out.matrix[, n] <- readBin( con = con, what = double(), endian = "little", n = num.genes ) total.molecules <- total.molecules + sum(out.matrix[, n]) } colnames(x = out.matrix) <- cell.names rownames(x = out.matrix) <- gene.names message("Found total ", total.molecules, " molecules") return(out.matrix) } #' Load in data from 10X #' #' Enables easy loading of sparse data matrices provided by 10X genomics. #' #' @param data.dir Directory containing the matrix.mtx, genes.tsv (or features.tsv), and barcodes.tsv #' files provided by 10X. A vector or named vector can be given in order to load #' several data directories. If a named vector is given, the cell barcode names #' will be prefixed with the name. #' @param gene.column Specify which column of genes.tsv or features.tsv to use for gene names; default is 2 #' @param unique.features Make feature names unique (default TRUE) #' #' @return If features.csv indicates the data has multiple data types, a list #' containing a sparse matrix of the data from each type will be returned. #' Otherwise a sparse matrix containing the expression data will be returned. #' #' @importFrom Matrix readMM #' #' @export #' #' @examples #' \dontrun{ #' # For output from CellRanger < 3.0 #' data_dir <- 'path/to/data/directory' #' list.files(data_dir) # Should show barcodes.tsv, genes.tsv, and matrix.mtx #' expression_matrix <- Read10X(data.dir = data_dir) #' seurat_object = CreateSeuratObject(counts = expression_matrix) #' #' # For output from CellRanger >= 3.0 with multiple data types #' data_dir <- 'path/to/data/directory' #' list.files(data_dir) # Should show barcodes.tsv.gz, features.tsv.gz, and matrix.mtx.gz #' data <- Read10X(data.dir = data_dir) #' seurat_object = CreateSeuratObject(counts = data$`Gene Expression`) #' seurat_object[['Protein']] = CreateAssayObject(counts = data$`Antibody Capture`) #' } #' Read10X <- function(data.dir = NULL, gene.column = 2, unique.features = TRUE) { full.data <- list() for (i in seq_along(along.with = data.dir)) { run <- data.dir[i] if (!dir.exists(paths = run)) { stop("Directory provided does not exist") } barcode.loc <- file.path(run, 'barcodes.tsv') gene.loc <- file.path(run, 'genes.tsv') features.loc <- file.path(run, 'features.tsv.gz') matrix.loc <- file.path(run, 'matrix.mtx') # Flag to indicate if this data is from CellRanger >= 3.0 pre_ver_3 <- file.exists(gene.loc) if (!pre_ver_3) { addgz <- function(s) { return(paste0(s, ".gz")) } barcode.loc <- addgz(s = barcode.loc) matrix.loc <- addgz(s = matrix.loc) } if (!file.exists(barcode.loc)) { stop("Barcode file missing. Expecting ", basename(path = barcode.loc)) } if (!pre_ver_3 && !file.exists(features.loc) ) { stop("Gene name or features file missing. Expecting ", basename(path = features.loc)) } if (!file.exists(matrix.loc)) { stop("Expression matrix file missing. Expecting ", basename(path = matrix.loc)) } data <- readMM(file = matrix.loc) cell.names <- readLines(barcode.loc) if (all(grepl(pattern = "\\-1$", x = cell.names))) { cell.names <- as.vector(x = as.character(x = sapply( X = cell.names, FUN = ExtractField, field = 1, delim = "-" ))) } if (is.null(x = names(x = data.dir))) { if (i < 2) { colnames(x = data) <- cell.names } else { colnames(x = data) <- paste0(i, "_", cell.names) } } else { colnames(x = data) <- paste0(names(x = data.dir)[i], "_", cell.names) } feature.names <- read.delim( file = ifelse(test = pre_ver_3, yes = gene.loc, no = features.loc), header = FALSE, stringsAsFactors = FALSE ) if (any(is.na(x = feature.names[, gene.column]))) { warning( 'Some features names are NA. Replacing NA names with ID from the opposite column requested', call. = FALSE, immediate. = TRUE ) na.features <- which(x = is.na(x = feature.names[, gene.column])) replacement.column <- ifelse(test = gene.column == 2, yes = 1, no = 2) feature.names[na.features, gene.column] <- feature.names[na.features, replacement.column] } if (unique.features) { fcols = ncol(x = feature.names) if (fcols < gene.column) { stop(paste0("gene.column was set to ", gene.column, " but feature.tsv.gz (or genes.tsv) only has ", fcols, " columns.", " Try setting the gene.column argument to a value <= to ", fcols, ".")) } rownames(x = data) <- make.unique(names = feature.names[, gene.column]) } # In cell ranger 3.0, a third column specifying the type of data was added # and we will return each type of data as a separate matrix if (ncol(x = feature.names) > 2) { data_types <- factor(x = feature.names$V3) lvls <- levels(x = data_types) if (length(x = lvls) > 1 && length(x = full.data) == 0) { message("10X data contains more than one type and is being returned as a list containing matrices of each type.") } expr_name <- "Gene Expression" if (expr_name %in% lvls) { # Return Gene Expression first lvls <- c(expr_name, lvls[-which(x = lvls == expr_name)]) } data <- lapply( X = lvls, FUN = function(l) { return(data[data_types == l, ]) } ) names(x = data) <- lvls } else{ data <- list(data) } full.data[[length(x = full.data) + 1]] <- data } # Combine all the data from different directories into one big matrix, note this # assumes that all data directories essentially have the same features files list_of_data <- list() for (j in 1:length(x = full.data[[1]])) { list_of_data[[j]] <- do.call(cbind, lapply(X = full.data, FUN = `[[`, j)) # Fix for Issue #913 list_of_data[[j]] <- as(object = list_of_data[[j]], Class = "dgCMatrix") } names(x = list_of_data) <- names(x = full.data[[1]]) # If multiple features, will return a list, otherwise # a matrix. if (length(x = list_of_data) == 1) { return(list_of_data[[1]]) } else { return(list_of_data) } } #' Read 10X hdf5 file #' #' Read count matrix from 10X CellRanger hdf5 file. #' This can be used to read both scATAC-seq and scRNA-seq matrices. #' #' @param filename Path to h5 file #' @param use.names Label row names with feature names rather than ID numbers. #' @param unique.features Make feature names unique (default TRUE) #' #' @return Returns a sparse matrix with rows and columns labeled. If multiple #' genomes are present, returns a list of sparse matrices (one per genome). #' #' @export #' Read10X_h5 <- function(filename, use.names = TRUE, unique.features = TRUE) { if (!requireNamespace('hdf5r', quietly = TRUE)) { stop("Please install hdf5r to read HDF5 files") } if (!file.exists(filename)) { stop("File not found") } infile <- hdf5r::H5File$new(filename = filename, mode = 'r') genomes <- names(x = infile) output <- list() if (!infile$attr_exists("PYTABLES_FORMAT_VERSION")) { # cellranger version 3 if (use.names) { feature_slot <- 'features/name' } else { feature_slot <- 'features/id' } } else { if (use.names) { feature_slot <- 'gene_names' } else { feature_slot <- 'genes' } } for (genome in genomes) { counts <- infile[[paste0(genome, '/data')]] indices <- infile[[paste0(genome, '/indices')]] indptr <- infile[[paste0(genome, '/indptr')]] shp <- infile[[paste0(genome, '/shape')]] features <- infile[[paste0(genome, '/', feature_slot)]][] barcodes <- infile[[paste0(genome, '/barcodes')]] sparse.mat <- sparseMatrix( i = indices[] + 1, p = indptr[], x = as.numeric(x = counts[]), dims = shp[], giveCsparse = FALSE ) if (unique.features) { features <- make.unique(names = features) } rownames(x = sparse.mat) <- features colnames(x = sparse.mat) <- barcodes[] sparse.mat <- as(object = sparse.mat, Class = 'dgCMatrix') # Split v3 multimodal if (infile$exists(name = paste0(genome, '/features'))) { types <- infile[[paste0(genome, '/features/feature_type')]][] types.unique <- unique(x = types) if (length(x = types.unique) > 1) { message("Genome ", genome, " has multiple modalities, returning a list of matrices for this genome") sparse.mat <- sapply( X = types.unique, FUN = function(x) { return(sparse.mat[which(x = types == x), ]) }, simplify = FALSE, USE.NAMES = TRUE ) } } output[[genome]] <- sparse.mat } infile$close_all() if (length(x = output) == 1) { return(output[[genome]]) } else{ return(output) } } #' Normalize raw data to fractions #' #' Normalize count data to relative counts per cell by dividing by the total #' per cell. Optionally use a scale factor, e.g. for counts per million (CPM) #' use \code{scale.factor = 1e6}. #' #' @param data Matrix with the raw count data #' @param scale.factor Scale the result. Default is 1 #' @param verbose Print progress #' @return Returns a matrix with the relative counts #' #' @import Matrix #' @importFrom methods as #' #' @export #' #' @examples #' mat <- matrix(data = rbinom(n = 25, size = 5, prob = 0.2), nrow = 5) #' mat #' mat_norm <- RelativeCounts(data = mat) #' mat_norm #' RelativeCounts <- function(data, scale.factor = 1, verbose = TRUE) { if (is.data.frame(x = data)) { data <- as.matrix(x = data) } if (!inherits(x = data, what = 'dgCMatrix')) { data <- as(object = data, Class = "dgCMatrix") } if (verbose) { cat("Performing relative-counts-normalization\n", file = stderr()) } norm.data <- data norm.data@x <- norm.data@x / rep.int(colSums(norm.data), diff(norm.data@p)) * scale.factor return(norm.data) } #' Sample UMI #' #' Downsample each cell to a specified number of UMIs. Includes #' an option to upsample cells below specified UMI as well. #' #' @param data Matrix with the raw count data #' @param max.umi Number of UMIs to sample to #' @param upsample Upsamples all cells with fewer than max.umi #' @param verbose Display the progress bar #' #' @import Matrix #' @importFrom methods as #' #' @return Matrix with downsampled data #' #' @export #' #' @examples #' counts = as.matrix(x = GetAssayData(object = pbmc_small, assay = "RNA", slot = "counts")) #' downsampled = SampleUMI(data = counts) #' head(x = downsampled) #' SampleUMI <- function( data, max.umi = 1000, upsample = FALSE, verbose = FALSE ) { data <- as(object = data, Class = "dgCMatrix") if (length(x = max.umi) == 1) { return( RunUMISampling( data = data, sample_val = max.umi, upsample = upsample, display_progress = verbose ) ) } else if (length(x = max.umi) != ncol(x = data)) { stop("max.umi vector not equal to number of cells") } new_data = RunUMISamplingPerCell( data = data, sample_val = max.umi, upsample = upsample, display_progress = verbose ) dimnames(new_data) <- dimnames(data) return(new_data) } #' Use regularized negative binomial regression to normalize UMI count data #' #' This function calls sctransform::vst. The sctransform package is available at #' https://github.com/ChristophH/sctransform. #' Use this function as an alternative to the NormalizeData, #' FindVariableFeatures, ScaleData workflow. Results are saved in a new assay #' (named SCT by default) with counts being (corrected) counts, data being log1p(counts), #' scale.data being pearson residuals; sctransform::vst intermediate results are saved #' in misc slot of new assay. #' #' @param object A seurat object #' @param assay Name of assay to pull the count data from; default is 'RNA' #' @param new.assay.name Name for the new assay containing the normalized data #' @param do.correct.umi Place corrected UMI matrix in assay counts slot; default is TRUE #' @param ncells Number of subsampling cells used to build NB regression; default is NULL #' @param variable.features.n Use this many features as variable features after #' ranking by residual variance; default is 3000 #' @param variable.features.rv.th Instead of setting a fixed number of variable features, #' use this residual variance cutoff; this is only used when \code{variable.features.n} #' is set to NULL; default is 1.3 #' @param vars.to.regress Variables to regress out in a second non-regularized linear #' regression. For example, percent.mito. Default is NULL #' @param do.scale Whether to scale residuals to have unit variance; default is FALSE #' @param do.center Whether to center residuals to have mean zero; default is TRUE #' @param clip.range Range to clip the residuals to; default is \code{c(-sqrt(n/30), sqrt(n/30))}, #' where n is the number of cells #' @param conserve.memory If set to TRUE the residual matrix for all genes is never #' created in full; useful for large data sets, but will take longer to run; #' this will also set return.only.var.genes to TRUE; default is FALSE #' @param return.only.var.genes If set to TRUE the scale.data matrices in output assay are #' subset to contain only the variable genes; default is TRUE #' @param seed.use Set a random seed. By default, sets the seed to 1448145. Setting #' NULL will not set a seed. #' @param verbose Whether to print messages and progress bars #' @param ... Additional parameters passed to \code{sctransform::vst} #' #' @return Returns a Seurat object with a new assay (named SCT by default) with #' counts being (corrected) counts, data being log1p(counts), scale.data being #' pearson residuals; sctransform::vst intermediate results are saved in misc #' slot of the new assay. #' #' @importFrom stats setNames #' @importFrom sctransform vst get_residual_var get_residuals correct_counts #' #' @seealso \code{\link[sctransform]{correct_counts}} \code{\link[sctransform]{get_residuals}} #' @export #' #' @examples #' SCTransform(object = pbmc_small) #' SCTransform <- function( object, assay = 'RNA', new.assay.name = 'SCT', do.correct.umi = TRUE, ncells = NULL, variable.features.n = 3000, variable.features.rv.th = 1.3, vars.to.regress = NULL, do.scale = FALSE, do.center = TRUE, clip.range = c(-sqrt(x = ncol(x = object[[assay]]) / 30), sqrt(x = ncol(x = object[[assay]]) / 30)), conserve.memory = FALSE, return.only.var.genes = TRUE, seed.use = 1448145, verbose = TRUE, ... ) { if (!is.null(x = seed.use)) { set.seed(seed = seed.use) } assay <- assay %||% DefaultAssay(object = object) assay.obj <- GetAssay(object = object, assay = assay) umi <- GetAssayData(object = assay.obj, slot = 'counts') cell.attr <- slot(object = object, name = 'meta.data') vst.args <- list(...) # check for batch_var in meta data if ('batch_var' %in% names(x = vst.args)) { if (!(vst.args[['batch_var']] %in% colnames(x = cell.attr))) { stop('batch_var not found in seurat object meta data') } } # check for latent_var in meta data if ('latent_var' %in% names(x = vst.args)) { known.attr <- c('umi', 'gene', 'log_umi', 'log_gene', 'umi_per_gene', 'log_umi_per_gene') if (!all(vst.args[['latent_var']] %in% c(colnames(x = cell.attr), known.attr))) { stop('latent_var values are not from the set of cell attributes sctransform calculates by default and cannot be found in seurat object meta data') } } # check for vars.to.regress in meta data if (any(!vars.to.regress %in% colnames(x = cell.attr))) { stop('problem with second non-regularized linear regression; not all variables found in seurat object meta data; check vars.to.regress parameter') } if (any(c('cell_attr', 'show_progress', 'return_cell_attr', 'return_gene_attr', 'return_corrected_umi') %in% names(x = vst.args))) { warning( 'the following arguments will be ignored because they are set within this function:', paste( c( 'cell_attr', 'show_progress', 'return_cell_attr', 'return_gene_attr', 'return_corrected_umi' ), collapse = ', ' ), call. = FALSE, immediate. = TRUE ) } vst.args[['umi']] <- umi vst.args[['cell_attr']] <- cell.attr vst.args[['show_progress']] <- verbose vst.args[['return_cell_attr']] <- TRUE vst.args[['return_gene_attr']] <- TRUE vst.args[['return_corrected_umi']] <- do.correct.umi vst.args[['n_cells']] <- ncells residual.type <- vst.args[['residual_type']] %||% 'pearson' res.clip.range <- vst.args[['res_clip_range']] %||% c(-sqrt(x = ncol(x = umi)), sqrt(x = ncol(x = umi))) if (conserve.memory) { return.only.var.genes <- TRUE } if (conserve.memory) { vst.args[['residual_type']] <- 'none' vst.out <- do.call(what = 'vst', args = vst.args) feature.variance <- get_residual_var( vst_out = vst.out, umi = umi, residual_type = residual.type, res_clip_range = res.clip.range ) vst.out$gene_attr$residual_variance <- NA_real_ vst.out$gene_attr[names(x = feature.variance), 'residual_variance'] <- feature.variance } else { vst.out <- do.call(what = 'vst', args = vst.args) feature.variance <- setNames( object = vst.out$gene_attr$residual_variance, nm = rownames(x = vst.out$gene_attr) ) } if (verbose) { message('Determine variable features') } feature.variance <- sort(x = feature.variance, decreasing = TRUE) if (!is.null(x = variable.features.n)) { top.features <- names(x = feature.variance)[1:min(variable.features.n, length(x = feature.variance))] } else { top.features <- names(x = feature.variance)[feature.variance >= variable.features.rv.th] } if (verbose) { message('Set ', length(x = top.features), ' variable features') } if (conserve.memory) { # actually get the residuals this time if (verbose) { message("Return only variable features for scale.data slot of the output assay") } vst.out$y <- get_residuals( vst_out = vst.out, umi = umi[top.features, ], residual_type = residual.type, res_clip_range = res.clip.range ) if (do.correct.umi & residual.type == 'pearson') { vst.out$umi_corrected <- correct_counts( x = vst.out, umi = umi, show_progress = verbose ) } } # create output assay and put (corrected) umi counts in count slot if (do.correct.umi & residual.type == 'pearson') { if (verbose) { message('Place corrected count matrix in counts slot') } assay.out <- CreateAssayObject(counts = vst.out$umi_corrected) vst.out$umi_corrected <- NULL } else { assay.out <- CreateAssayObject(counts = umi) } # set the variable genes VariableFeatures(object = assay.out) <- top.features # put log1p transformed counts in data assay.out <- SetAssayData( object = assay.out, slot = 'data', new.data = log1p(x = GetAssayData(object = assay.out, slot = 'counts')) ) if (return.only.var.genes & !conserve.memory) { scale.data <- vst.out$y[top.features, ] } else { scale.data <- vst.out$y } # clip the residuals scale.data[scale.data < clip.range[1]] <- clip.range[1] scale.data[scale.data > clip.range[2]] <- clip.range[2] # 2nd regression scale.data <- ScaleData( scale.data, features = NULL, vars.to.regress = vars.to.regress, latent.data = cell.attr[, vars.to.regress, drop = FALSE], model.use = 'linear', use.umi = FALSE, do.scale = do.scale, do.center = do.center, scale.max = Inf, block.size = 750, min.cells.to.block = 3000, verbose = verbose ) assay.out <- SetAssayData( object = assay.out, slot = 'scale.data', new.data = scale.data ) # save vst output (except y) in @misc slot vst.out$y <- NULL # save clip.range into vst model vst.out$arguments$sct.clip.range <- clip.range Misc(object = assay.out, slot = 'vst.out') <- vst.out # also put gene attributes in meta.features assay.out[[paste0('sct.', names(x = vst.out$gene_attr))]] <- vst.out$gene_attr assay.out[['sct.variable']] <- rownames(x = assay.out[[]]) %in% top.features object[[new.assay.name]] <- assay.out if (verbose) { message(paste("Set default assay to", new.assay.name)) } DefaultAssay(object = object) <- new.assay.name object <- LogSeuratCommand(object = object) return(object) } #' Subset a Seurat Object based on the Barcode Distribution Inflection Points #' #' This convenience function subsets a Seurat object based on calculated inflection points. #' #' See [CalculateBarcodeInflections()] to calculate inflection points and #' [BarcodeInflectionsPlot()] to visualize and test inflection point calculations. #' #' @param object Seurat object #' #' @return Returns a subsetted Seurat object. #' #' @export #' #' @author Robert A. Amezquita, \email{robert.amezquita@fredhutch.org} #' @seealso \code{\link{CalculateBarcodeInflections}} \code{\link{BarcodeInflectionsPlot}} #' #' @examples #' pbmc_small <- CalculateBarcodeInflections( #' object = pbmc_small, #' group.column = 'groups', #' threshold.low = 20, #' threshold.high = 30 #' ) #' SubsetByBarcodeInflections(object = pbmc_small) #' SubsetByBarcodeInflections <- function(object) { cbi.data <- Tool(object = object, slot = 'CalculateBarcodeInflections') if (is.null(x = cbi.data)) { stop("Barcode inflections not calculated, please run CalculateBarcodeInflections") } return(object[, cbi.data$cells_pass]) } #' Term frequency-inverse document frequency #' #' Normalize binary data per cell using the term frequency-inverse document frequency #' normalization method (TF-IDF). #' This is suitable for the normalization of binary ATAC peak datasets. #' #' @param data Matrix with the raw count data #' @param verbose Print progress #' #' @return Returns a matrix with the normalized data #' #' @importFrom Matrix colSums rowSums #' #' @export #' #' @examples #' mat <- matrix(data = rbinom(n = 25, size = 5, prob = 0.2), nrow = 5) #' mat_norm <- TF.IDF(data = mat) #' TF.IDF <- function(data, verbose = TRUE) { if (is.data.frame(x = data)) { data <- as.matrix(x = data) } if (!inherits(x = data, what = 'dgCMatrix')) { data <- as(object = data, Class = "dgCMatrix") } if (verbose) { message("Performing TF-IDF normalization") } npeaks <- colSums(x = data) tf <- t(x = t(x = data) / npeaks) idf <- ncol(x = data) / rowSums(x = data) norm.data <- Diagonal(n = length(x = idf), x = idf) %*% tf norm.data[which(x = is.na(x = norm.data))] <- 0 return(norm.data) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Methods for Seurat-defined generics #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' @param selection.method How to choose top variable features. Choose one of : #' \itemize{ #' \item{vst:}{ First, fits a line to the relationship of log(variance) and #' log(mean) using local polynomial regression (loess). Then standardizes the #' feature values using the observed mean and expected variance (given by the #' fitted line). Feature variance is then calculated on the standardized values #' after clipping to a maximum (see clip.max parameter).} #' \item{mean.var.plot (mvp):}{ First, uses a function to calculate average #' expression (mean.function) and dispersion (dispersion.function) for each #' feature. Next, divides features into num.bin (deafult 20) bins based on #' their average expression, and calculates z-scores for dispersion within #' each bin. The purpose of this is to identify variable features while #' controlling for the strong relationship between variability and average #' expression.} #' \item{dispersion (disp):}{ selects the genes with the highest dispersion values} #' } #' @param loess.span (vst method) Loess span parameter used when fitting the #' variance-mean relationship #' @param clip.max (vst method) After standardization values larger than #' clip.max will be set to clip.max; default is 'auto' which sets this value to #' the square root of the number of cells #' @param mean.function Function to compute x-axis value (average expression). #' Default is to take the mean of the detected (i.e. non-zero) values #' @param dispersion.function Function to compute y-axis value (dispersion). #' Default is to take the standard deviation of all values #' @param num.bin Total number of bins to use in the scaled analysis (default #' is 20) #' @param binning.method Specifies how the bins should be computed. Available #' methods are: #' \itemize{ #' \item{equal_width:}{ each bin is of equal width along the x-axis [default]} #' \item{equal_frequency:}{ each bin contains an equal number of features (can #' increase statistical power to detect overdispersed features at high #' expression values, at the cost of reduced resolution along the x-axis)} #' } #' @param verbose show progress bar for calculations #' #' @rdname FindVariableFeatures #' @export #' FindVariableFeatures.default <- function( object, selection.method = "vst", loess.span = 0.3, clip.max = 'auto', mean.function = FastExpMean, dispersion.function = FastLogVMR, num.bin = 20, binning.method = "equal_width", verbose = TRUE, ... ) { CheckDots(...) if (!inherits(x = object, 'Matrix')) { object <- as(object = as.matrix(x = object), Class = 'Matrix') } if (!inherits(x = object, what = 'dgCMatrix')) { object <- as(object = object, Class = 'dgCMatrix') } if (selection.method == "vst") { if (clip.max == 'auto') { clip.max <- sqrt(x = ncol(x = object)) } hvf.info <- data.frame(mean = rowMeans(x = object)) hvf.info$variance <- SparseRowVar2( mat = object, mu = hvf.info$mean, display_progress = verbose ) hvf.info$variance.expected <- 0 hvf.info$variance.standardized <- 0 not.const <- hvf.info$variance > 0 fit <- loess( formula = log10(x = variance) ~ log10(x = mean), data = hvf.info[not.const, ], span = loess.span ) hvf.info$variance.expected[not.const] <- 10 ^ fit$fitted # use c function to get variance after feature standardization hvf.info$variance.standardized <- SparseRowVarStd( mat = object, mu = hvf.info$mean, sd = sqrt(hvf.info$variance.expected), vmax = clip.max, display_progress = verbose ) colnames(x = hvf.info) <- paste0('vst.', colnames(x = hvf.info)) } else { if (!inherits(x = mean.function, what = 'function')) { stop("'mean.function' must be a function") } if (!inherits(x = dispersion.function, what = 'function')) { stop("'dispersion.function' must be a function") } feature.mean <- mean.function(object, verbose) feature.dispersion <- dispersion.function(object, verbose) names(x = feature.mean) <- names(x = feature.dispersion) <- rownames(x = object) feature.dispersion[is.na(x = feature.dispersion)] <- 0 feature.mean[is.na(x = feature.mean)] <- 0 data.x.breaks <- switch( EXPR = binning.method, 'equal_width' = num.bin, 'equal_frequency' = c( -1, quantile( x = feature.mean[feature.mean > 0], probs = seq.int(from = 0, to = 1, length.out = num.bin) ) ), stop("Unknown binning method: ", binning.method) ) data.x.bin <- cut(x = feature.mean, breaks = data.x.breaks) names(x = data.x.bin) <- names(x = feature.mean) mean.y <- tapply(X = feature.dispersion, INDEX = data.x.bin, FUN = mean) sd.y <- tapply(X = feature.dispersion, INDEX = data.x.bin, FUN = sd) feature.dispersion.scaled <- (feature.dispersion - mean.y[as.numeric(x = data.x.bin)]) / sd.y[as.numeric(x = data.x.bin)] names(x = feature.dispersion.scaled) <- names(x = feature.mean) hvf.info <- data.frame(feature.mean, feature.dispersion, feature.dispersion.scaled) rownames(x = hvf.info) <- rownames(x = object) colnames(x = hvf.info) <- paste0('mvp.', c('mean', 'dispersion', 'dispersion.scaled')) } return(hvf.info) } #' @param nfeatures Number of features to select as top variable features; #' only used when \code{selection.method} is set to \code{'dispersion'} or #' \code{'vst'} #' @param mean.cutoff A two-length numeric vector with low- and high-cutoffs for #' feature means #' @param dispersion.cutoff A two-length numeric vector with low- and high-cutoffs for #' feature dispersions #' #' @rdname FindVariableFeatures #' @export #' @method FindVariableFeatures Assay #' FindVariableFeatures.Assay <- function( object, selection.method = "vst", loess.span = 0.3, clip.max = 'auto', mean.function = FastExpMean, dispersion.function = FastLogVMR, num.bin = 20, binning.method = "equal_width", nfeatures = 2000, mean.cutoff = c(0.1, 8), dispersion.cutoff = c(1, Inf), verbose = TRUE, ... ) { if (length(x = mean.cutoff) != 2 || length(x = dispersion.cutoff) != 2) { stop("Both 'mean.cutoff' and 'dispersion.cutoff' must be two numbers") } if (selection.method == "vst") { data <- GetAssayData(object = object, slot = "counts") # if (ncol(x = data) < 1 || nrow(x = data) < 1) { if (IsMatrixEmpty(x = data)) { warning("selection.method set to 'vst' but count slot is empty; will use data slot instead") data <- GetAssayData(object = object, slot = "data") } } else { data <- GetAssayData(object = object, slot = "data") } hvf.info <- FindVariableFeatures( object = data, selection.method = selection.method, loess.span = loess.span, clip.max = clip.max, mean.function = mean.function, dispersion.function = dispersion.function, num.bin = num.bin, binning.method = binning.method, verbose = verbose, ... ) object[[names(x = hvf.info)]] <- hvf.info hvf.info <- hvf.info[which(x = hvf.info[, 1, drop = TRUE] != 0), ] if (selection.method == "vst") { hvf.info <- hvf.info[order(hvf.info$vst.variance.standardized, decreasing = TRUE), , drop = FALSE] } else { hvf.info <- hvf.info[order(hvf.info$mvp.dispersion, decreasing = TRUE), , drop = FALSE] } selection.method <- switch( EXPR = selection.method, 'mvp' = 'mean.var.plot', 'disp' = 'dispersion', selection.method ) top.features <- switch( EXPR = selection.method, 'mean.var.plot' = { means.use <- (hvf.info[, 1] > mean.cutoff[1]) & (hvf.info[, 1] < mean.cutoff[2]) dispersions.use <- (hvf.info[, 3] > dispersion.cutoff[1]) & (hvf.info[, 3] < dispersion.cutoff[2]) rownames(x = hvf.info)[which(x = means.use & dispersions.use)] }, 'dispersion' = head(x = rownames(x = hvf.info), n = nfeatures), 'vst' = head(x = rownames(x = hvf.info), n = nfeatures), stop("Unkown selection method: ", selection.method) ) VariableFeatures(object = object) <- top.features vf.name <- ifelse( test = selection.method == 'vst', yes = 'vst', no = 'mvp' ) vf.name <- paste0(vf.name, '.variable') object[[vf.name]] <- rownames(x = object[[]]) %in% top.features return(object) } #' @inheritParams FindVariableFeatures.Assay #' @param assay Assay to use #' #' @rdname FindVariableFeatures #' @export #' @method FindVariableFeatures Seurat #' FindVariableFeatures.Seurat <- function( object, assay = NULL, selection.method = "vst", loess.span = 0.3, clip.max = 'auto', mean.function = FastExpMean, dispersion.function = FastLogVMR, num.bin = 20, binning.method = "equal_width", nfeatures = 2000, mean.cutoff = c(0.1, 8), dispersion.cutoff = c(1, Inf), verbose = TRUE, ... ) { assay <- assay %||% DefaultAssay(object = object) assay.data <- GetAssay(object = object, assay = assay) assay.data <- FindVariableFeatures( object = assay.data, selection.method = selection.method, loess.span = loess.span, clip.max = clip.max, mean.function = mean.function, dispersion.function = dispersion.function, num.bin = num.bin, binning.method = binning.method, nfeatures = nfeatures, mean.cutoff = mean.cutoff, dispersion.cutoff = dispersion.cutoff, verbose = verbose, ... ) object[[assay]] <- assay.data object <- LogSeuratCommand(object = object) return(object) } #' @importFrom future.apply future_lapply #' @importFrom future nbrOfWorkers #' #' @param normalization.method Method for normalization. #' \itemize{ #' \item{LogNormalize: }{Feature counts for each cell are divided by the total #' counts for that cell and multiplied by the scale.factor. This is then #' natural-log transformed using log1p.} #' \item{CLR: }{Applies a centered log ratio transformation} #' \item{RC: }{Relative counts. Feature counts for each cell are divided by the total #' counts for that cell and multiplied by the scale.factor. No log-transformation is applied. #' For counts per million (CPM) set \code{scale.factor = 1e6}} #' } #' @param scale.factor Sets the scale factor for cell-level normalization #' @param margin If performing CLR normalization, normalize across features (1) or cells (2) # @param across If performing CLR normalization, normalize across either "features" or "cells". #' @param block.size How many cells should be run in each chunk, will try to split evenly across threads #' @param verbose display progress bar for normalization procedure #' #' @rdname NormalizeData #' @export #' NormalizeData.default <- function( object, normalization.method = "LogNormalize", scale.factor = 1e4, margin = 1, block.size = NULL, verbose = TRUE, ... ) { CheckDots(...) if (is.null(x = normalization.method)) { return(object) } normalized.data <- if (nbrOfWorkers() > 1) { norm.function <- switch( EXPR = normalization.method, 'LogNormalize' = LogNormalize, 'CLR' = CustomNormalize, 'RC' = RelativeCounts, stop("Unknown normalization method: ", normalization.method) ) if (normalization.method != 'CLR') { margin <- 2 } tryCatch( expr = Parenting(parent.find = 'Seurat', margin = margin), error = function(e) { invisible(x = NULL) } ) dsize <- switch( EXPR = margin, '1' = nrow(x = object), '2' = ncol(x = object), stop("'margin' must be 1 or 2") ) chunk.points <- ChunkPoints( dsize = dsize, csize = block.size %||% ceiling(x = dsize / nbrOfWorkers()) ) normalized.data <- future_lapply( X = 1:ncol(x = chunk.points), FUN = function(i) { block <- chunk.points[, i] data <- if (margin == 1) { object[block[1]:block[2], , drop = FALSE] } else { object[, block[1]:block[2], drop = FALSE] } clr_function <- function(x) { return(log1p(x = x / (exp(x = sum(log1p(x = x[x > 0]), na.rm = TRUE) / length(x = x))))) } args <- list( data = data, scale.factor = scale.factor, verbose = FALSE, custom_function = clr_function, margin = margin ) args <- args[names(x = formals(fun = norm.function))] return(do.call( what = norm.function, args = args )) } ) do.call( what = switch( EXPR = margin, '1' = 'rbind', '2' = 'cbind', stop("'margin' must be 1 or 2") ), args = normalized.data ) } else { switch( EXPR = normalization.method, 'LogNormalize' = LogNormalize( data = object, scale.factor = scale.factor, verbose = verbose ), 'CLR' = CustomNormalize( data = object, custom_function = function(x) { return(log1p(x = x / (exp(x = sum(log1p(x = x[x > 0]), na.rm = TRUE) / length(x = x))))) }, margin = margin, verbose = verbose # across = across ), 'RC' = RelativeCounts( data = object, scale.factor = scale.factor, verbose = verbose ), stop("Unkown normalization method: ", normalization.method) ) } return(normalized.data) } #' @rdname NormalizeData #' @export #' @method NormalizeData Assay #' NormalizeData.Assay <- function( object, normalization.method = "LogNormalize", scale.factor = 1e4, margin = 1, verbose = TRUE, ... ) { object <- SetAssayData( object = object, slot = 'data', new.data = NormalizeData( object = GetAssayData(object = object, slot = 'counts'), normalization.method = normalization.method, scale.factor = scale.factor, verbose = verbose, margin = margin, ... ) ) return(object) } #' @param assay Name of assay to use #' #' @rdname NormalizeData #' @export #' @method NormalizeData Seurat #' #' @examples #' \dontrun{ #' pbmc_small #' pmbc_small <- NormalizeData(object = pbmc_small) #' } #' NormalizeData.Seurat <- function( object, assay = NULL, normalization.method = "LogNormalize", scale.factor = 1e4, margin = 1, verbose = TRUE, ... ) { assay <- assay %||% DefaultAssay(object = object) assay.data <- GetAssay(object = object, assay = assay) assay.data <- NormalizeData( object = assay.data, normalization.method = normalization.method, scale.factor = scale.factor, verbose = verbose, margin = margin, ... ) object[[assay]] <- assay.data object <- LogSeuratCommand(object = object) return(object) } #' @param k The rank of the rank-k approximation. Set to NULL for automated choice of k. #' @param q The number of additional power iterations in randomized SVD when #' computing rank k approximation. By default, q=10. #' @param quantile.prob The quantile probability to use when calculating threshold. #' By default, quantile.prob = 0.001. #' @param use.mkl Use the Intel MKL based implementation of SVD. Needs to be #' installed from https://github.com/KlugerLab/rpca-mkl. \strong{Note}: this requires #' the \href{https://github.com/satijalab/seurat-wrappers}{SeuratWrappers} implementation #' of \code{RunALRA} #' @param mkl.seed Only relevant if \code{use.mkl = TRUE}. Set the seed for the random #' generator for the Intel MKL implementation of SVD. Any number <0 will #' use the current timestamp. If \code{use.mkl = FALSE}, set the seed using #' \code{\link{set.seed}()} function as usual. #' #' @rdname RunALRA #' @export #' RunALRA.default <- function( object, k = NULL, q = 10, quantile.prob = 0.001, use.mkl = FALSE, mkl.seed = -1, ... ) { CheckDots(...) A.norm <- t(x = as.matrix(x = object)) message("Identifying non-zero values") originally.nonzero <- A.norm > 0 message("Computing Randomized SVD") if (use.mkl) { warning( "Using the Intel MKL-based implementation of SVD requires RunALRA from SeuratWrappers\n", "For more details, see https://github.com/satijalab/seurat-wrappers\n", "Continuing with standard SVD implementation", call. = FALSE, immediate. = TRUE ) } fastDecomp.noc <- rsvd(A = A.norm, k = k, q = q) A.norm.rank.k <- fastDecomp.noc$u[, 1:k] %*% diag(x = fastDecomp.noc$d[1:k]) %*% t(x = fastDecomp.noc$v[,1:k]) message(sprintf("Find the %f quantile of each gene", quantile.prob)) A.norm.rank.k.mins <- abs(x = apply( X = A.norm.rank.k, MARGIN = 2, FUN = function(x) { return(quantile(x = x, probs = quantile.prob)) } )) message("Thresholding by the most negative value of each gene") A.norm.rank.k.cor <- replace( x = A.norm.rank.k, list = A.norm.rank.k <= A.norm.rank.k.mins[col(A.norm.rank.k)], values = 0 ) sd.nonzero <- function(x) { return(sd(x[!x == 0])) } sigma.1 <- apply(X = A.norm.rank.k.cor, MARGIN = 2, FUN = sd.nonzero) sigma.2 <- apply(X = A.norm, MARGIN = 2, FUN = sd.nonzero) mu.1 <- colSums(x = A.norm.rank.k.cor) / colSums(x = !!A.norm.rank.k.cor) mu.2 <- colSums(x = A.norm) / colSums(x = !!A.norm) toscale <- !is.na(sigma.1) & !is.na(sigma.2) & !(sigma.1 == 0 & sigma.2 == 0) & !(sigma.1 == 0) message(sprintf(fmt = "Scaling all except for %d columns", sum(!toscale))) sigma.1.2 <- sigma.2 / sigma.1 toadd <- -1 * mu.1 * sigma.2 / sigma.1 + mu.2 A.norm.rank.k.temp <- A.norm.rank.k.cor[, toscale] A.norm.rank.k.temp <- Sweep( x = A.norm.rank.k.temp, MARGIN = 2, STATS = sigma.1.2[toscale], FUN = "*" ) A.norm.rank.k.temp <- Sweep( x = A.norm.rank.k.temp, MARGIN = 2, STATS = toadd[toscale], FUN = "+" ) A.norm.rank.k.cor.sc <- A.norm.rank.k.cor A.norm.rank.k.cor.sc[, toscale] <- A.norm.rank.k.temp A.norm.rank.k.cor.sc[A.norm.rank.k.cor == 0] <- 0 lt0 <- A.norm.rank.k.cor.sc < 0 A.norm.rank.k.cor.sc[lt0] <- 0 message(sprintf( fmt = "%.2f%% of the values became negative in the scaling process and were set to zero", 100 * sum(lt0) / prod(dim(x = A.norm)) )) A.norm.rank.k.cor.sc[originally.nonzero & A.norm.rank.k.cor.sc == 0] <- A.norm[originally.nonzero & A.norm.rank.k.cor.sc == 0] colnames(x = A.norm.rank.k) <- colnames(x = A.norm.rank.k.cor.sc) <- colnames(x = A.norm.rank.k.cor) <- colnames(x = A.norm) original.nz <- sum(A.norm > 0) / prod(dim(x = A.norm)) completed.nz <- sum(A.norm.rank.k.cor.sc > 0) / prod(dim(x = A.norm)) message(sprintf( fmt = "The matrix went from %.2f%% nonzero to %.2f%% nonzero", 100 * original.nz, 100 * completed.nz )) return(A.norm.rank.k.cor.sc) } #' @param assay Assay to use #' @param slot slot to use #' @param setDefaultAssay If TRUE, will set imputed results as default Assay #' @param genes.use genes to impute #' @param K Number of singular values to compute when choosing k. Must be less #' than the smallest dimension of the matrix. Default 100 or smallest dimension. #' @param thresh The threshold for ''significance'' when choosing k. Default 1e-10. #' @param noise.start Index for which all smaller singular values are considered noise. #' Default K - 20. #' @param q.k Number of additional power iterations when choosing k. Default 2. #' @param k.only If TRUE, only computes optimal k WITHOUT performing ALRA #' #' @importFrom rsvd rsvd #' @importFrom Matrix Matrix #' @importFrom stats sd setNames quantile #' #' @rdname RunALRA #' @export #' @method RunALRA Seurat #' RunALRA.Seurat <- function( object, k = NULL, q = 10, quantile.prob = 0.001, use.mkl = FALSE, mkl.seed=-1, assay = NULL, slot = "data", setDefaultAssay = TRUE, genes.use = NULL, K = NULL, thresh = 6, noise.start = NULL, q.k = 2, k.only = FALSE, ... ) { if (!is.null(x = k) && k.only) { warning("Stop: k is already given, set k.only = FALSE or k = NULL") } genes.use <- genes.use %||% rownames(x = object) assay <- assay %||% DefaultAssay(object = object) alra.previous <- Tool(object = object, slot = 'RunALRA') alra.info <- list() # Check if k is already stored if (is.null(x = k) & !is.null(alra.previous[["k"]])) { k <- alra.previous[["k"]] message("Using previously computed value of k") } data.used <- GetAssayData(object = object, assay = assay, slot = slot)[genes.use,] # Choose k with heuristics if k is not given if (is.null(x = k)) { # set K based on data dimension if (is.null(x = K)) { K <- 100 if (K > min(dim(x = data.used))) { K <- min(dim(x = data.used)) warning("For best performance, we recommend using ALRA on expression matrices larger than 100 by 100") } } if (K > min(dim(x = data.used))) { stop("For an m by n data, K must be smaller than the min(m,n)") } # set noise.start based on K if (is.null(x = noise.start)) { noise.start <- K - 20 if (noise.start <= 0) { noise.start <- max(K - 5, 1) } } if (noise.start > K - 5) { stop("There need to be at least 5 singular values considered noise") } noise.svals <- noise.start:K if (use.mkl) { warning( "Using the Intel MKL-based implementation of SVD requires RunALRA from SeuratWrappers\n", "For more details, see https://github.com/satijalab/seurat-wrappers\n", "Continuing with standard SVD implementation", call. = FALSE, immediate. = TRUE ) } rsvd.out <- rsvd(A = t(x = as.matrix(x = data.used)), k = K, q = q.k) diffs <- rsvd.out$d[1:(length(x = rsvd.out$d)-1)] - rsvd.out$d[2:length(x = rsvd.out$d)] mu <- mean(x = diffs[noise.svals - 1]) sigma <- sd(x = diffs[noise.svals - 1]) num_of_sds <- (diffs - mu) / sigma k <- max(which(x = num_of_sds > thresh)) alra.info[["d"]] <- rsvd.out$d alra.info[["k"]] <- k alra.info[["diffs"]] <- diffs Tool(object = object) <- alra.info } if (k.only) { message("Chose rank k = ", k, ", WITHOUT performing ALRA") return(object) } message("Rank k = ", k) # Perform ALRA on data.used output.alra <- RunALRA( object = data.used, k = k, q = q, quantile.prob = quantile.prob, use.mkl = use.mkl, mkl.seed = mkl.seed ) # Save ALRA data in object@assay data.alra <- Matrix(data = t(x = output.alra), sparse = TRUE) rownames(x = data.alra) <- genes.use colnames(x = data.alra) <- colnames(x = object) assay.alra <- CreateAssayObject(data = data.alra) object[["alra"]] <- assay.alra if (setDefaultAssay) { message("Setting default assay as alra") DefaultAssay(object = object) <- "alra" } return(object) } #' @importFrom future nbrOfWorkers #' #' @param features Vector of features names to scale/center. Default is variable features. #' @param vars.to.regress Variables to regress out (previously latent.vars in #' RegressOut). For example, nUMI, or percent.mito. #' @param latent.data Extra data to regress out, should be cells x latent data #' @param split.by Name of variable in object metadata or a vector or factor defining #' grouping of cells. See argument \code{f} in \code{\link[base]{split}} for more details #' @param model.use Use a linear model or generalized linear model #' (poisson, negative binomial) for the regression. Options are 'linear' #' (default), 'poisson', and 'negbinom' #' @param use.umi Regress on UMI count data. Default is FALSE for linear #' modeling, but automatically set to TRUE if model.use is 'negbinom' or 'poisson' #' @param do.scale Whether to scale the data. #' @param do.center Whether to center the data. #' @param scale.max Max value to return for scaled data. The default is 10. #' Setting this can help reduce the effects of feautres that are only expressed in #' a very small number of cells. If regressing out latent variables and using a #' non-linear model, the default is 50. #' @param block.size Default size for number of feautres to scale at in a single #' computation. Increasing block.size may speed up calculations but at an #' additional memory cost. #' @param min.cells.to.block If object contains fewer than this number of cells, #' don't block for scaling calculations. #' @param verbose Displays a progress bar for scaling procedure #' #' @importFrom future.apply future_lapply #' #' @rdname ScaleData #' @export #' ScaleData.default <- function( object, features = NULL, vars.to.regress = NULL, latent.data = NULL, split.by = NULL, model.use = 'linear', use.umi = FALSE, do.scale = TRUE, do.center = TRUE, scale.max = 10, block.size = 1000, min.cells.to.block = 3000, verbose = TRUE, ... ) { CheckDots(...) features <- features %||% rownames(x = object) features <- as.vector(x = intersect(x = features, y = rownames(x = object))) object <- object[features, , drop = FALSE] object.names <- dimnames(x = object) min.cells.to.block <- min(min.cells.to.block, ncol(x = object)) suppressWarnings(expr = Parenting( parent.find = "ScaleData.Assay", features = features, min.cells.to.block = min.cells.to.block )) split.by <- split.by %||% TRUE split.cells <- split(x = colnames(x = object), f = split.by) CheckGC() if (!is.null(x = vars.to.regress)) { if (is.null(x = latent.data)) { latent.data <- data.frame(row.names = colnames(x = object)) } else { latent.data <- latent.data[colnames(x = object), , drop = FALSE] rownames(x = latent.data) <- colnames(x = object) } if (any(vars.to.regress %in% rownames(x = object))) { latent.data <- cbind( latent.data, t(x = object[vars.to.regress[vars.to.regress %in% rownames(x = object)], ]) ) } # Currently, RegressOutMatrix will do nothing if latent.data = NULL if (verbose) { message("Regressing out ", paste(vars.to.regress, collapse = ', ')) } chunk.points <- ChunkPoints(dsize = nrow(x = object), csize = block.size) if (nbrOfWorkers() > 1) { # TODO: lapply chunks <- expand.grid( names(x = split.cells), 1:ncol(x = chunk.points), stringsAsFactors = FALSE ) object <- future_lapply( X = 1:nrow(x = chunks), FUN = function(i) { row <- chunks[i, ] group <- row[[1]] index <- as.numeric(x = row[[2]]) return(RegressOutMatrix( data.expr = object[chunk.points[1, index]:chunk.points[2, index], split.cells[[group]], drop = FALSE], latent.data = latent.data[split.cells[[group]], , drop = FALSE], features.regress = features, model.use = model.use, use.umi = use.umi, verbose = FALSE )) } ) if (length(x = split.cells) > 1) { merge.indices <- lapply( X = 1:length(x = split.cells), FUN = seq.int, to = length(x = object), by = length(x = split.cells) ) object <- lapply( X = merge.indices, FUN = function(x) { return(do.call(what = 'rbind', args = object[x])) } ) object <- do.call(what = 'cbind', args = object) } else { object <- do.call(what = 'rbind', args = object) } } else { object <- lapply( X = names(x = split.cells), FUN = function(x) { if (verbose && length(x = split.cells) > 1) { message("Regressing out variables from split ", x) } return(RegressOutMatrix( data.expr = object[, split.cells[[x]], drop = FALSE], latent.data = latent.data[split.cells[[x]], , drop = FALSE], features.regress = features, model.use = model.use, use.umi = use.umi, verbose = verbose )) } ) object <- do.call(what = 'cbind', args = object) } dimnames(x = object) <- object.names CheckGC() } if (verbose && (do.scale || do.center)) { msg <- paste( na.omit(object = c( ifelse(test = do.center, yes = 'centering', no = NA_character_), ifelse(test = do.scale, yes = 'scaling', no = NA_character_) )), collapse = ' and ' ) msg <- paste0( toupper(x = substr(x = msg, start = 1, stop = 1)), substr(x = msg, start = 2, stop = nchar(x = msg)), ' data matrix' ) message(msg) } if (inherits(x = object, what = c('dgCMatrix', 'dgTMatrix'))) { scale.function <- FastSparseRowScale } else { object <- as.matrix(x = object) scale.function <- FastRowScale } if (nbrOfWorkers() > 1) { blocks <- ChunkPoints(dsize = length(x = features), csize = block.size) chunks <- expand.grid( names(x = split.cells), 1:ncol(x = blocks), stringsAsFactors = FALSE ) scaled.data <- future_lapply( X = 1:nrow(x = chunks), FUN = function(index) { row <- chunks[index, ] group <- row[[1]] block <- as.vector(x = blocks[, as.numeric(x = row[[2]])]) data.scale <- scale.function( mat = object[features[block[1]:block[2]], split.cells[[group]], drop = FALSE], scale = do.scale, center = do.center, scale_max = scale.max, display_progress = FALSE ) dimnames(x = data.scale) <- dimnames(x = object[features[block[1]:block[2]], split.cells[[group]]]) suppressWarnings(expr = data.scale[is.na(x = data.scale)] <- 0) CheckGC() return(data.scale) } ) if (length(x = split.cells) > 1) { merge.indices <- lapply( X = 1:length(x = split.cells), FUN = seq.int, to = length(x = scaled.data), by = length(x = split.cells) ) scaled.data <- lapply( X = merge.indices, FUN = function(x) { return(suppressWarnings(expr = do.call(what = 'rbind', args = scaled.data[x]))) } ) scaled.data <- suppressWarnings(expr = do.call(what = 'cbind', args = scaled.data)) } else { suppressWarnings(expr = scaled.data <- do.call(what = 'rbind', args = scaled.data)) } } else { scaled.data <- matrix( data = NA_real_, nrow = nrow(x = object), ncol = ncol(x = object), dimnames = object.names ) max.block <- ceiling(x = length(x = features) / block.size) for (x in names(x = split.cells)) { if (verbose) { if (length(x = split.cells) > 1 && (do.scale || do.center)) { message(gsub(pattern = 'matrix', replacement = 'from split ', x = msg), x) } pb <- txtProgressBar(min = 0, max = max.block, style = 3, file = stderr()) } for (i in 1:max.block) { my.inds <- ((block.size * (i - 1)):(block.size * i - 1)) + 1 my.inds <- my.inds[my.inds <= length(x = features)] data.scale <- scale.function( mat = object[features[my.inds], split.cells[[x]], drop = FALSE], scale = do.scale, center = do.center, scale_max = scale.max, display_progress = FALSE ) dimnames(x = data.scale) <- dimnames(x = object[features[my.inds], split.cells[[x]]]) scaled.data[features[my.inds], split.cells[[x]]] <- data.scale rm(data.scale) CheckGC() if (verbose) { setTxtProgressBar(pb = pb, value = i) } } if (verbose) { close(con = pb) } } } dimnames(x = scaled.data) <- object.names scaled.data[is.na(x = scaled.data)] <- 0 CheckGC() return(scaled.data) } #' @rdname ScaleData #' @export #' @method ScaleData Assay #' ScaleData.Assay <- function( object, features = NULL, vars.to.regress = NULL, latent.data = NULL, split.by = NULL, model.use = 'linear', use.umi = FALSE, do.scale = TRUE, do.center = TRUE, scale.max = 10, block.size = 1000, min.cells.to.block = 3000, verbose = TRUE, ... ) { use.umi <- ifelse(test = model.use != 'linear', yes = TRUE, no = use.umi) slot.use <- ifelse(test = use.umi, yes = 'counts', no = 'data') features <- features %||% VariableFeatures(object) if (length(x = features) == 0) { features <- rownames(x = GetAssayData(object = object, slot = slot.use)) } object <- SetAssayData( object = object, slot = 'scale.data', new.data = ScaleData( object = GetAssayData(object = object, slot = slot.use), features = features, vars.to.regress = vars.to.regress, latent.data = latent.data, split.by = split.by, model.use = model.use, use.umi = use.umi, do.scale = do.scale, do.center = do.center, scale.max = scale.max, block.size = block.size, min.cells.to.block = min.cells.to.block, verbose = verbose, ... ) ) suppressWarnings(expr = Parenting( parent.find = "ScaleData.Seurat", features = features, min.cells.to.block = min.cells.to.block, use.umi = use.umi )) return(object) } #' @param assay Name of Assay to scale #' #' @rdname ScaleData #' @export #' @method ScaleData Seurat #' ScaleData.Seurat <- function( object, features = NULL, assay = NULL, vars.to.regress = NULL, split.by = NULL, model.use = 'linear', use.umi = FALSE, do.scale = TRUE, do.center = TRUE, scale.max = 10, block.size = 1000, min.cells.to.block = 3000, verbose = TRUE, ... ) { assay <- assay %||% DefaultAssay(object = object) assay.data <- GetAssay(object = object, assay = assay) if (any(vars.to.regress %in% colnames(x = object[[]]))) { latent.data <- object[[vars.to.regress[vars.to.regress %in% colnames(x = object[[]])]]] } else { latent.data <- NULL } if (is.character(x = split.by) && length(x = split.by) == 1) { split.by <- object[[split.by]] } assay.data <- ScaleData( object = assay.data, features = features, vars.to.regress = vars.to.regress, latent.data = latent.data, split.by = split.by, model.use = model.use, use.umi = use.umi, do.scale = do.scale, do.center = do.center, scale.max = scale.max, block.size = block.size, min.cells.to.block = min.cells.to.block, verbose = verbose, ... ) object[[assay]] <- assay.data object <- LogSeuratCommand(object = object) return(object) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Internal #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Sample classification from MULTI-seq # # Identify singlets, doublets and negative cells from multiplexing experiments. # # @param data Data frame with the raw count data (cell x tags) # @param q Scale the data. Default is 1e4 # # @return Returns a named vector with demultiplexed identities # #' @importFrom KernSmooth bkde #' @importFrom stats approxfun quantile # # @author Chris McGinnis, Gartner Lab, UCSF # # @examples # demux_result <- ClassifyCells(data = counts_data, q = 0.7) # ClassifyCells <- function(data, q) { ## Generate Thresholds: Gaussian KDE with bad barcode detection, outlier trimming ## local maxima estimation with bad barcode detection, threshold definition and adjustment # n_BC <- ncol(x = data) n_cells <- nrow(x = data) bc_calls <- vector(mode = "list", length = n_cells) n_bc_calls <- numeric(length = n_cells) for (i in 1:ncol(x = data)) { model <- tryCatch( expr = approxfun(x = bkde(x = data[, i], kernel = "normal")), error = function(e) { message("No threshold found for ", colnames(x = data)[i], "...") } ) if (is.character(x = model)) { next } x <- seq.int( from = quantile(x = data[, i], probs = 0.001), to = quantile(x = data[, i], probs = 0.999), length.out = 100 ) extrema <- LocalMaxima(x = model(x)) if (length(x = extrema) <= 1) { message("No threshold found for ", colnames(x = data)[i], "...") next } low.extremum <- min(extrema) high.extremum <- max(extrema) thresh <- (x[high.extremum] + x[low.extremum])/2 ## Account for GKDE noise by adjusting low threshold to most prominent peak low.extremae <- extrema[which(x = x[extrema] <= thresh)] new.low.extremum <- low.extremae[which.max(x = model(x)[low.extremae])] thresh <- quantile(x = c(x[high.extremum], x[new.low.extremum]), probs = q) ## Find which cells are above the ith threshold cell_i <- which(x = data[, i] >= thresh) n <- length(x = cell_i) if (n == 0) { ## Skips to next BC if no cells belong to the ith group next } bc <- colnames(x = data)[i] if (n == 1) { bc_calls[[cell_i]] <- c(bc_calls[[cell_i]], bc) n_bc_calls[cell_i] <- n_bc_calls[cell_i] + 1 } else { # have to iterate, lame for (cell in cell_i) { bc_calls[[cell]] <- c(bc_calls[[cell]], bc) n_bc_calls[cell] <- n_bc_calls[cell] + 1 } } } calls <- character(length = n_cells) for (i in 1:n_cells) { if (n_bc_calls[i] == 0) { calls[i] <- "Negative"; next } if (n_bc_calls[i] > 1) { calls[i] <- "Doublet"; next } if (n_bc_calls[i] == 1) { calls[i] <- bc_calls[[i]] } } names(x = calls) <- rownames(x = data) return(calls) } # Normalize a given data matrix # # Normalize a given matrix with a custom function. Essentially just a wrapper # around apply. Used primarily in the context of CLR normalization. # # @param data Matrix with the raw count data # @param custom_function A custom normalization function # @param margin Which way to we normalize. Set 1 for rows (features) or 2 for columns (genes) # @parm across Which way to we normalize? Choose form 'cells' or 'features' # @param verbose Show progress bar # # @return Returns a matrix with the custom normalization # #' @importFrom methods as #' @importFrom pbapply pbapply # @import Matrix # CustomNormalize <- function(data, custom_function, margin, verbose = TRUE) { if (is.data.frame(x = data)) { data <- as.matrix(x = data) } if (!inherits(x = data, what = 'dgCMatrix')) { data <- as(object = data, Class = "dgCMatrix") } myapply <- ifelse(test = verbose, yes = pbapply, no = apply) # margin <- switch( # EXPR = across, # 'cells' = 2, # 'features' = 1, # stop("'across' must be either 'cells' or 'features'") # ) if (verbose) { message("Normalizing across ", c('features', 'cells')[margin]) } norm.data <- myapply( X = data, MARGIN = margin, FUN = custom_function) if (margin == 1) { norm.data = t(x = norm.data) } colnames(x = norm.data) <- colnames(x = data) rownames(x = norm.data) <- rownames(x = data) return(norm.data) } # Inter-maxima quantile sweep to find ideal barcode thresholds # # Finding ideal thresholds for positive-negative signal classification per multiplex barcode # # @param call.list A list of sample classification result from different quantiles using ClassifyCells # # @return A list with two values: \code{res} and \code{extrema}: # \describe{ # \item{res}{A data.frame named res_id documenting the quantile used, subset, number of cells and proportion} # \item{extrema}{...} # } # # @author Chris McGinnis, Gartner Lab, UCSF # # @examples # FindThresh(call.list = bar.table_sweep.list) # FindThresh <- function(call.list) { # require(reshape2) res <- as.data.frame(x = matrix( data = 0L, nrow = length(x = call.list), ncol = 4 )) colnames(x = res) <- c("q","pDoublet","pNegative","pSinglet") q.range <- unlist(x = strsplit(x = names(x = call.list), split = "q=")) res$q <- as.numeric(x = q.range[grep(pattern = "0", x = q.range)]) nCell <- length(x = call.list[[1]]) for (i in 1:nrow(x = res)) { temp <- table(call.list[[i]]) if ("Doublet" %in% names(x = temp) == TRUE) { res$pDoublet[i] <- temp[which(x = names(x = temp) == "Doublet")] } if ( "Negative" %in% names(temp) == TRUE ) { res$pNegative[i] <- temp[which(x = names(x = temp) == "Negative")] } res$pSinglet[i] <- sum(temp[which(x = !names(x = temp) %in% c("Doublet", "Negative"))]) } res.q <- res$q q.ind <- grep(pattern = 'q', x = colnames(x = res)) res <- Melt(x = res[, -q.ind]) res[, 1] <- rep.int(x = res.q, times = length(x = unique(res[, 2]))) colnames(x = res) <- c('q', 'variable', 'value') res[, 4] <- res$value/nCell colnames(x = res)[2:4] <- c("Subset", "nCells", "Proportion") extrema <- res$q[LocalMaxima(x = res$Proportion[which(x = res$Subset == "pSinglet")])] return(list(res = res, extrema = extrema)) } # Calculate pearson residuals of features not in the scale.data # This function is the secondary function under GetResidual # # @param object A seurat object # @param features Name of features to add into the scale.data # @param assay Name of the assay of the seurat object generated by SCTransform # @param vst_out The SCT parameter list # @param clip.range Numeric of length two specifying the min and max values the Pearson residual # will be clipped to # Useful if you want to change the clip.range. # @param verbose Whether to print messages and progress bars # # @return Returns a Seurat object containing pearson residuals of added features in its scale.data # #' @importFrom sctransform get_residuals # GetResidualVstOut <- function( object, assay, umi.assay, new_features, vst_out, clip.range, verbose ) { diff_features <- setdiff( x = new_features, y = rownames(x = vst_out$model_pars_fit) ) intersect_feature <- intersect( x = new_features, y = rownames(x = vst_out$model_pars_fit) ) if (length(x = diff_features) == 0) { umi <- GetAssayData(object = object, assay = umi.assay, slot = "counts" )[new_features, , drop = FALSE] } else { warning( "The following ", length(x = diff_features), " features do not exist in the counts slot: ", paste(diff_features, collapse = " ") ) if (length(x = intersect_feature) == 0) { return(object) } umi <- GetAssayData(object = object, assay = umi.assay, slot = "counts" )[intersect_feature, , drop = FALSE] } if (is.null(x = clip.range)) { if(length(vst_out$arguments$sct.clip.range)!=0 ){ clip.max <- max(vst_out$arguments$sct.clip.range) clip.min <- min(vst_out$arguments$sct.clip.range) } else{ clip.max <- max(vst_out$arguments$res_clip_range) clip.min <- min(vst_out$arguments$res_clip_range) } } else { clip.max <- max(clip.range) clip.min <- min(clip.range) } new_residual <- get_residuals( vst_out = vst_out, umi = umi, residual_type = "pearson", res_clip_range = c(clip.min, clip.max), show_progress = verbose ) new_residual <- as.matrix(x = new_residual) # centered data new_residual <- new_residual - rowMeans(new_residual) # remove genes from the scale.data if genes are part of new_features scale.data <- GetAssayData(object = object, assay = assay, slot = "scale.data") object <- SetAssayData( object = object, assay = assay, slot = "scale.data", new.data = scale.data[!rownames(x = scale.data) %in% new_features, , drop = FALSE] ) if (nrow(x = GetAssayData(object = object, slot = 'scale.data', assay = assay)) == 0 ) { object <- SetAssayData( object = object, slot = 'scale.data', new.data = new_residual, assay = assay ) } else { object <- SetAssayData( object = object, slot = 'scale.data', new.data = rbind( GetAssayData(object = object, slot = 'scale.data', assay = assay), new_residual ), assay = assay ) } return(object) } # Local maxima estimator # # Finding local maxima given a numeric vector # # @param x A continuous vector # # @return Returns a (named) vector showing positions of local maximas # # @author Tommy # @references \url{https://stackoverflow.com/questions/6836409/finding-local-maxima-and-minima} # # @examples # x <- c(1, 2, 9, 9, 2, 1, 1, 5, 5, 1) # LocalMaxima(x = x) # LocalMaxima <- function(x) { # Use -Inf instead if x is numeric (non-integer) y <- diff(x = c(-.Machine$integer.max, x)) > 0L y <- cumsum(x = rle(x = y)$lengths) y <- y[seq.int(from = 1L, to = length(x = y), by = 2L)] if (x[[1]] == x[[2]]) { y <- y[-1] } return(y) } # #' @importFrom stats residuals # NBResiduals <- function(fmla, regression.mat, gene, return.mode = FALSE) { fit <- 0 try( fit <- glm.nb( formula = fmla, data = regression.mat ), silent = TRUE) if (is.numeric(x = fit)) { message(sprintf('glm.nb failed for gene %s; falling back to scale(log(y+1))', gene)) resid <- scale(x = log(x = regression.mat[, 'GENE'] + 1))[, 1] mode <- 'scale' } else { resid <- residuals(fit, type = 'pearson') mode = 'nbreg' } do.return <- list(resid = resid, mode = mode) if (return.mode) { return(do.return) } else { return(do.return$resid) } } # Regress out techincal effects and cell cycle from a matrix # # Remove unwanted effects from a matrix # # @parm data.expr An expression matrix to regress the effects of latent.data out # of should be the complete expression matrix in genes x cells # @param latent.data A matrix or data.frame of latent variables, should be cells # x latent variables, the colnames should be the variables to regress # @param features.regress An integer vector representing the indices of the # genes to run regression on # @param model.use Model to use, one of 'linear', 'poisson', or 'negbinom'; pass # NULL to simply return data.expr # @param use.umi Regress on UMI count data # @param verbose Display a progress bar # #' @importFrom stats as.formula lm #' @importFrom utils txtProgressBar setTxtProgressBar # RegressOutMatrix <- function( data.expr, latent.data = NULL, features.regress = NULL, model.use = NULL, use.umi = FALSE, verbose = TRUE ) { # Do we bypass regression and simply return data.expr? bypass <- vapply( X = list(latent.data, model.use), FUN = is.null, FUN.VALUE = logical(length = 1L) ) if (any(bypass)) { return(data.expr) } # Check model.use possible.models <- c("linear", "poisson", "negbinom") if (!model.use %in% possible.models) { stop(paste( model.use, "is not a valid model. Please use one the following:", paste0(possible.models, collapse = ", ") )) } # Check features.regress if (is.null(x = features.regress)) { features.regress <- 1:nrow(x = data.expr) } if (is.character(x = features.regress)) { features.regress <- intersect(x = features.regress, y = rownames(x = data.expr)) if (length(x = features.regress) == 0) { stop("Cannot use features that are beyond the scope of data.expr") } } else if (max(features.regress) > nrow(x = data.expr)) { stop("Cannot use features that are beyond the scope of data.expr") } # Check dataset dimensions if (nrow(x = latent.data) != ncol(x = data.expr)) { stop("Uneven number of cells between latent data and expression data") } use.umi <- ifelse(test = model.use != 'linear', yes = TRUE, no = use.umi) # Create formula for regression vars.to.regress <- colnames(x = latent.data) fmla <- paste('GENE ~', paste(vars.to.regress, collapse = '+')) fmla <- as.formula(object = fmla) if (model.use == "linear") { # In this code, we'll repeatedly regress different Y against the same X # (latent.data) in order to calculate residuals. Rather that repeatedly # call lm to do this, we'll avoid recalculating the QR decomposition for the # latent.data matrix each time by reusing it after calculating it once regression.mat <- cbind(latent.data, data.expr[1,]) colnames(regression.mat) <- c(colnames(x = latent.data), "GENE") qr <- lm(fmla, data = regression.mat, qr = TRUE)$qr rm(regression.mat) } # Make results matrix data.resid <- matrix( nrow = nrow(x = data.expr), ncol = ncol(x = data.expr) ) if (verbose) { pb <- txtProgressBar(char = '=', style = 3, file = stderr()) } for (i in 1:length(x = features.regress)) { x <- features.regress[i] regression.mat <- cbind(latent.data, data.expr[x, ]) colnames(x = regression.mat) <- c(vars.to.regress, 'GENE') regression.mat <- switch( EXPR = model.use, 'linear' = qr.resid(qr = qr, y = data.expr[x,]), 'poisson' = residuals(object = glm( formula = fmla, family = 'poisson', data = regression.mat), type = 'pearson' ), 'negbinom' = NBResiduals( fmla = fmla, regression.mat = regression.mat, gene = x ) ) data.resid[i, ] <- regression.mat if (verbose) { setTxtProgressBar(pb = pb, value = i / length(x = features.regress)) } } if (verbose) { close(con = pb) } if (use.umi) { data.resid <- log1p(x = Sweep( x = data.resid, MARGIN = 1, STATS = apply(X = data.resid, MARGIN = 1, FUN = min), FUN = '-' )) } dimnames(x = data.resid) <- dimnames(x = data.expr) return(data.resid) } Seurat/R/differential_expression.R0000644000176200001440000014707313602476666017010 0ustar liggesusers#' @include generics.R #' NULL #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Functions #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% globalVariables( names = c('myAUC', 'p_val', 'avg_logFC'), package = 'Seurat', add = TRUE ) #' Gene expression markers for all identity classes #' #' Finds markers (differentially expressed genes) for each of the identity classes in a dataset #' #' @inheritParams FindMarkers #' @param node A node to find markers for and all its children; requires #' \code{\link{BuildClusterTree}} to have been run previously; replaces \code{FindAllMarkersNode} #' @param return.thresh Only return markers that have a p-value < return.thresh, or a power > return.thresh (if the test is ROC) #' #' @return Matrix containing a ranked list of putative markers, and associated #' statistics (p-values, ROC score, etc.) #' #' @importFrom ape drop.tip #' @importFrom stats setNames #' #' @export #' #' @aliases FindAllMarkersNode #' #' @examples #' # Find markers for all clusters #' all.markers <- FindAllMarkers(object = pbmc_small) #' head(x = all.markers) #' \dontrun{ #' # Pass a value to node as a replacement for FindAllMarkersNode #' pbmc_small <- BuildClusterTree(object = pbmc_small) #' all.markers <- FindAllMarkers(object = pbmc_small, node = 4) #' head(x = all.markers) #' } #' FindAllMarkers <- function( object, assay = NULL, features = NULL, logfc.threshold = 0.25, test.use = 'wilcox', slot = 'data', min.pct = 0.1, min.diff.pct = -Inf, node = NULL, verbose = TRUE, only.pos = FALSE, max.cells.per.ident = Inf, random.seed = 1, latent.vars = NULL, min.cells.feature = 3, min.cells.group = 3, pseudocount.use = 1, return.thresh = 1e-2, ... ) { MapVals <- function(vec, from, to) { vec2 <- setNames(object = to, nm = from)[as.character(x = vec)] vec2[is.na(x = vec2)] <- vec[is.na(x = vec2)] return(unname(obj = vec2)) } if ((test.use == "roc") && (return.thresh == 1e-2)) { return.thresh <- 0.7 } if (is.null(x = node)) { idents.all <- sort(x = unique(x = Idents(object = object))) } else { tree <- Tool(object = object, slot = 'BuildClusterTree') if (is.null(x = tree)) { stop("Please run 'BuildClusterTree' before finding markers on nodes") } descendants <- DFT(tree = tree, node = node, include.children = TRUE) all.children <- sort(x = tree$edge[, 2][!tree$edge[, 2] %in% tree$edge[, 1]]) descendants <- MapVals( vec = descendants, from = all.children, to = tree$tip.label ) drop.children <- setdiff(x = tree$tip.label, y = descendants) keep.children <- setdiff(x = tree$tip.label, y = drop.children) orig.nodes <- c( node, as.numeric(x = setdiff(x = descendants, y = keep.children)) ) tree <- drop.tip(phy = tree, tip = drop.children) new.nodes <- unique(x = tree$edge[, 1, drop = TRUE]) idents.all <- (tree$Nnode + 2):max(tree$edge) } genes.de <- list() messages <- list() for (i in 1:length(x = idents.all)) { if (verbose) { message("Calculating cluster ", idents.all[i]) } genes.de[[i]] <- tryCatch( expr = { FindMarkers( object = object, assay = assay, ident.1 = if (is.null(x = node)) { idents.all[i] } else { tree }, ident.2 = if (is.null(x = node)) { NULL } else { idents.all[i] }, features = features, logfc.threshold = logfc.threshold, test.use = test.use, slot = slot, min.pct = min.pct, min.diff.pct = min.diff.pct, verbose = verbose, only.pos = only.pos, max.cells.per.ident = max.cells.per.ident, random.seed = random.seed, latent.vars = latent.vars, min.cells.feature = min.cells.feature, min.cells.group = min.cells.group, pseudocount.use = pseudocount.use, ... ) }, error = function(cond) { return(cond$message) } ) if (is.character(x = genes.de[[i]])) { messages[[i]] <- genes.de[[i]] genes.de[[i]] <- NULL } } gde.all <- data.frame() for (i in 1:length(x = idents.all)) { if (is.null(x = unlist(x = genes.de[i]))) { next } gde <- genes.de[[i]] if (nrow(x = gde) > 0) { if (test.use == "roc") { gde <- subset( x = gde, subset = (myAUC > return.thresh | myAUC < (1 - return.thresh)) ) } else if (is.null(x = node) || test.use %in% c('bimod', 't')) { gde <- gde[order(gde$p_val, -gde[, 2]), ] gde <- subset(x = gde, subset = p_val < return.thresh) } if (nrow(x = gde) > 0) { gde$cluster <- idents.all[i] gde$gene <- rownames(x = gde) } if (nrow(x = gde) > 0) { gde.all <- rbind(gde.all, gde) } } } if ((only.pos) && nrow(x = gde.all) > 0) { return(subset(x = gde.all, subset = gde.all[, 2] > 0)) } rownames(x = gde.all) <- make.unique(names = as.character(x = gde.all$gene)) if (nrow(x = gde.all) == 0) { warning("No DE genes identified", call. = FALSE, immediate. = TRUE) } if (length(x = messages) > 0) { warning("The following tests were not performed: ", call. = FALSE, immediate. = TRUE) for (i in 1:length(x = messages)) { if (!is.null(x = messages[[i]])) { warning("When testing ", idents.all[i], " versus all:\n\t", messages[[i]], call. = FALSE, immediate. = TRUE) } } } if (!is.null(x = node)) { gde.all$cluster <- MapVals( vec = gde.all$cluster, from = new.nodes, to = orig.nodes ) } return(gde.all) } #' Finds markers that are conserved between the groups #' #' @inheritParams FindMarkers #' @param ident.1 Identity class to define markers for #' @param ident.2 A second identity class for comparison. If NULL (default) - #' use all other cells for comparison. #' @param grouping.var grouping variable #' @param assay of assay to fetch data for (default is RNA) #' @param meta.method method for combining p-values. Should be a function from #' the metap package (NOTE: pass the function, not a string) #' @param \dots parameters to pass to FindMarkers #' #' @return data.frame containing a ranked list of putative conserved markers, and #' associated statistics (p-values within each group and a combined p-value #' (such as Fishers combined p-value or others from the metap package), #' percentage of cells expressing the marker, average differences). Name of group is appended to each #' associated output column (e.g. CTRL_p_val). If only one group is tested in the grouping.var, max #' and combined p-values are not returned. #' #' @importFrom metap minimump #' #' @export #' #' @examples #' \dontrun{ #' pbmc_small #' # Create a simulated grouping variable #' pbmc_small[['groups']] <- sample(x = c('g1', 'g2'), size = ncol(x = pbmc_small), replace = TRUE) #' FindConservedMarkers(pbmc_small, ident.1 = 0, ident.2 = 1, grouping.var = "groups") #' } #' FindConservedMarkers <- function( object, ident.1, ident.2 = NULL, grouping.var, assay = 'RNA', slot = 'data', meta.method = minimump, verbose = TRUE, ... ) { if (!is.function(x = meta.method)) { stop("meta.method should be a function from the metap package. Please see https://cran.r-project.org/web/packages/metap/metap.pdf for a detailed description of the available functions.") } object.var <- FetchData(object = object, vars = grouping.var) object <- SetIdent( object = object, cells = colnames(x = object), value = paste(Idents(object = object), object.var[, 1], sep = "_") ) levels.split <- names(x = sort(x = table(object.var[, 1]))) num.groups <- length(levels.split) cells <- list() for (i in 1:num.groups) { cells[[i]] <- rownames( x = object.var[object.var[, 1] == levels.split[i], , drop = FALSE] ) } marker.test <- list() # do marker tests ident.2.save <- ident.2 for (i in 1:num.groups) { level.use <- levels.split[i] ident.use.1 <- paste(ident.1, level.use, sep = "_") ident.use.1.exists <- ident.use.1 %in% Idents(object = object) if (!all(ident.use.1.exists)) { bad.ids <- ident.1[!ident.use.1.exists] warning( "Identity: ", paste(bad.ids, collapse = ", "), " not present in group ", level.use, ". Skipping ", level.use, call. = FALSE, immediate. = TRUE ) next } ident.2 <- ident.2.save cells.1 <- WhichCells(object = object, idents = ident.use.1) if (is.null(x = ident.2)) { cells.2 <- setdiff(x = cells[[i]], y = cells.1) ident.use.2 <- names(x = which(x = table(Idents(object = object)[cells.2]) > 0)) ident.2 <- gsub(pattern = paste0("_", level.use), replacement = "", x = ident.use.2) if (length(x = ident.use.2) == 0) { stop(paste("Only one identity class present:", ident.1)) } } else { ident.use.2 <- paste(ident.2, level.use, sep = "_") } if (verbose) { message( "Testing group ", level.use, ": (", paste(ident.1, collapse = ", "), ") vs (", paste(ident.2, collapse = ", "), ")" ) } ident.use.2.exists <- ident.use.2 %in% Idents(object = object) if (!all(ident.use.2.exists)) { bad.ids <- ident.2[!ident.use.2.exists] warning( "Identity: ", paste(bad.ids, collapse = ", "), " not present in group ", level.use, ". Skipping ", level.use, call. = FALSE, immediate. = TRUE ) next } marker.test[[i]] <- FindMarkers( object = object, assay = assay, slot = slot, ident.1 = ident.use.1, ident.2 = ident.use.2, verbose = verbose, ... ) names(x = marker.test)[i] <- levels.split[i] } marker.test <- Filter(f = Negate(f = is.null), x = marker.test) genes.conserved <- Reduce( f = intersect, x = lapply( X = marker.test, FUN = function(x) { return(rownames(x = x)) } ) ) markers.conserved <- list() for (i in 1:length(x = marker.test)) { markers.conserved[[i]] <- marker.test[[i]][genes.conserved, ] colnames(x = markers.conserved[[i]]) <- paste( names(x = marker.test)[i], colnames(x = markers.conserved[[i]]), sep = "_" ) } markers.combined <- Reduce(cbind, markers.conserved) pval.codes <- colnames(x = markers.combined)[grepl(pattern = "*_p_val$", x = colnames(x = markers.combined))] if (length(x = pval.codes) > 1) { markers.combined$max_pval <- apply( X = markers.combined[, pval.codes, drop = FALSE], MARGIN = 1, FUN = max ) combined.pval <- data.frame(cp = apply( X = markers.combined[, pval.codes, drop = FALSE], MARGIN = 1, FUN = function(x) { return(meta.method(x)$p) } )) colnames(x = combined.pval) <- paste0( as.character(x = formals()$meta.method), "_p_val" ) markers.combined <- cbind(markers.combined, combined.pval) markers.combined <- markers.combined[order(markers.combined[, paste0(as.character(x = formals()$meta.method), "_p_val")]), ] } else { warning("Only a single group was tested", call. = FALSE, immediate. = TRUE) } return(markers.combined) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Methods for Seurat-defined generics #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #' @param cells.1 Vector of cell names belonging to group 1 #' @param cells.2 Vector of cell names belonging to group 2 #' @param counts Count matrix if using scale.data for DE tests. This is used for #' computing pct.1 and pct.2 and for filtering features based on fraction #' expressing #' @param features Genes to test. Default is to use all genes #' @param logfc.threshold Limit testing to genes which show, on average, at least #' X-fold difference (log-scale) between the two groups of cells. Default is 0.25 #' Increasing logfc.threshold speeds up the function, but can miss weaker signals. #' @param test.use Denotes which test to use. Available options are: #' \itemize{ #' \item{"wilcox"} : Identifies differentially expressed genes between two #' groups of cells using a Wilcoxon Rank Sum test (default) #' \item{"bimod"} : Likelihood-ratio test for single cell gene expression, #' (McDavid et al., Bioinformatics, 2013) #' \item{"roc"} : Identifies 'markers' of gene expression using ROC analysis. #' For each gene, evaluates (using AUC) a classifier built on that gene alone, #' to classify between two groups of cells. An AUC value of 1 means that #' expression values for this gene alone can perfectly classify the two #' groupings (i.e. Each of the cells in cells.1 exhibit a higher level than #' each of the cells in cells.2). An AUC value of 0 also means there is perfect #' classification, but in the other direction. A value of 0.5 implies that #' the gene has no predictive power to classify the two groups. Returns a #' 'predictive power' (abs(AUC-0.5) * 2) ranked matrix of putative differentially #' expressed genes. #' \item{"t"} : Identify differentially expressed genes between two groups of #' cells using the Student's t-test. #' \item{"negbinom"} : Identifies differentially expressed genes between two #' groups of cells using a negative binomial generalized linear model. #' Use only for UMI-based datasets #' \item{"poisson"} : Identifies differentially expressed genes between two #' groups of cells using a poisson generalized linear model. #' Use only for UMI-based datasets #' \item{"LR"} : Uses a logistic regression framework to determine differentially #' expressed genes. Constructs a logistic regression model predicting group #' membership based on each feature individually and compares this to a null #' model with a likelihood ratio test. #' \item{"MAST"} : Identifies differentially expressed genes between two groups #' of cells using a hurdle model tailored to scRNA-seq data. Utilizes the MAST #' package to run the DE testing. #' \item{"DESeq2"} : Identifies differentially expressed genes between two groups #' of cells based on a model using DESeq2 which uses a negative binomial #' distribution (Love et al, Genome Biology, 2014).This test does not support #' pre-filtering of genes based on average difference (or percent detection rate) #' between cell groups. However, genes may be pre-filtered based on their #' minimum detection rate (min.pct) across both cell groups. To use this method, #' please install DESeq2, using the instructions at #' https://bioconductor.org/packages/release/bioc/html/DESeq2.html #' } #' @param min.pct only test genes that are detected in a minimum fraction of #' min.pct cells in either of the two populations. Meant to speed up the function #' by not testing genes that are very infrequently expressed. Default is 0.1 #' @param min.diff.pct only test genes that show a minimum difference in the #' fraction of detection between the two groups. Set to -Inf by default #' @param only.pos Only return positive markers (FALSE by default) #' @param verbose Print a progress bar once expression testing begins #' @param max.cells.per.ident Down sample each identity class to a max number. #' Default is no downsampling. Not activated by default (set to Inf) #' @param random.seed Random seed for downsampling #' @param latent.vars Variables to test, used only when \code{test.use} is one of #' 'LR', 'negbinom', 'poisson', or 'MAST' #' @param min.cells.feature Minimum number of cells expressing the feature in at least one #' of the two groups, currently only used for poisson and negative binomial tests #' @param min.cells.group Minimum number of cells in one of the groups #' @param pseudocount.use Pseudocount to add to averaged expression values when #' calculating logFC. 1 by default. #' #' @importFrom Matrix rowSums rowMeans #' @importFrom stats p.adjust #' #' @rdname FindMarkers #' @export #' @method FindMarkers default #' FindMarkers.default <- function( object, slot = "data", counts = numeric(), cells.1 = NULL, cells.2 = NULL, features = NULL, reduction = NULL, logfc.threshold = 0.25, test.use = 'wilcox', min.pct = 0.1, min.diff.pct = -Inf, verbose = TRUE, only.pos = FALSE, max.cells.per.ident = Inf, random.seed = 1, latent.vars = NULL, min.cells.feature = 3, min.cells.group = 3, pseudocount.use = 1, ... ) { features <- features %||% rownames(x = object) methods.noprefiliter <- c("DESeq2") if (test.use %in% methods.noprefiliter) { features <- rownames(x = object) min.diff.pct <- -Inf logfc.threshold <- 0 } # error checking if (length(x = cells.1) == 0) { stop("Cell group 1 is empty - no cells with identity class ", cells.1) } else if (length(x = cells.2) == 0) { stop("Cell group 2 is empty - no cells with identity class ", cells.2) return(NULL) } else if (length(x = cells.1) < min.cells.group) { stop("Cell group 1 has fewer than ", min.cells.group, " cells") } else if (length(x = cells.2) < min.cells.group) { stop("Cell group 2 has fewer than ", min.cells.group, " cells") } else if (any(!cells.1 %in% colnames(x = object))) { bad.cells <- colnames(x = object)[which(x = !as.character(x = cells.1) %in% colnames(x = object))] stop( "The following cell names provided to cells.1 are not present: ", paste(bad.cells, collapse = ", ") ) } else if (any(!cells.2 %in% colnames(x = object))) { bad.cells <- colnames(x = object)[which(x = !as.character(x = cells.2) %in% colnames(x = object))] stop( "The following cell names provided to cells.2 are not present: ", paste(bad.cells, collapse = ", ") ) } # feature selection (based on percentages) data <- switch( EXPR = slot, 'scale.data' = counts, object ) if (is.null(x = reduction)) { thresh.min <- 0 pct.1 <- round( x = rowSums(x = data[features, cells.1, drop = FALSE] > thresh.min) / length(x = cells.1), digits = 3 ) pct.2 <- round( x = rowSums(x = data[features, cells.2, drop = FALSE] > thresh.min) / length(x = cells.2), digits = 3 ) data.alpha <- cbind(pct.1, pct.2) colnames(x = data.alpha) <- c("pct.1", "pct.2") alpha.min <- apply(X = data.alpha, MARGIN = 1, FUN = max) names(x = alpha.min) <- rownames(x = data.alpha) features <- names(x = which(x = alpha.min > min.pct)) if (length(x = features) == 0) { stop("No features pass min.pct threshold") } alpha.diff <- alpha.min - apply(X = data.alpha, MARGIN = 1, FUN = min) features <- names( x = which(x = alpha.min > min.pct & alpha.diff > min.diff.pct) ) if (length(x = features) == 0) { stop("No features pass min.diff.pct threshold") } } else { data.alpha <- data.frame( pct.1 = rep(x = NA, times = length(x = features)), pct.2 = rep(x = NA, times = length(x = features)) ) } # feature selection (based on average difference) mean.fxn <- if (is.null(x = reduction) && slot != "scale.data") { switch( EXPR = slot, 'data' = function(x) { return(log(x = rowMeans(x = expm1(x = x)) + pseudocount.use)) }, function(x) { return(log(x = rowMeans(x = x) + pseudocount.use)) } ) } else { rowMeans } data.1 <- mean.fxn(data[features, cells.1, drop = FALSE]) data.2 <- mean.fxn(data[features, cells.2, drop = FALSE]) total.diff <- (data.1 - data.2) if (is.null(x = reduction) && slot != "scale.data") { features.diff <- if (only.pos) { names(x = which(x = total.diff > logfc.threshold)) } else { names(x = which(x = abs(x = total.diff) > logfc.threshold)) } features <- intersect(x = features, y = features.diff) if (length(x = features) == 0) { stop("No features pass logfc.threshold threshold") } } if (max.cells.per.ident < Inf) { set.seed(seed = random.seed) # Should be cells.1 and cells.2? if (length(x = cells.1) > max.cells.per.ident) { cells.1 <- sample(x = cells.1, size = max.cells.per.ident) } if (length(x = cells.2) > max.cells.per.ident) { cells.2 <- sample(x = cells.2, size = max.cells.per.ident) } if (!is.null(x = latent.vars)) { latent.vars <- latent.vars[c(cells.1, cells.2), , drop = FALSE] } } # perform DE if (!(test.use %in% c('negbinom', 'poisson', 'MAST', "LR")) && !is.null(x = latent.vars)) { warning( "'latent.vars' is only used for 'negbinom', 'poisson', 'LR', and 'MAST' tests", call. = FALSE, immediate. = TRUE ) } if (!test.use %in% c('wilcox', 'MAST', 'DESeq2')) { CheckDots(...) } de.results <- switch( EXPR = test.use, 'wilcox' = WilcoxDETest( data.use = object[features, c(cells.1, cells.2), drop = FALSE], cells.1 = cells.1, cells.2 = cells.2, verbose = verbose, ... ), 'bimod' = DiffExpTest( data.use = object[features, c(cells.1, cells.2), drop = FALSE], cells.1 = cells.1, cells.2 = cells.2, verbose = verbose ), 'roc' = MarkerTest( data.use = object[features, c(cells.1, cells.2), drop = FALSE], cells.1 = cells.1, cells.2 = cells.2, verbose = verbose ), 't' = DiffTTest( data.use = object[features, c(cells.1, cells.2), drop = FALSE], cells.1 = cells.1, cells.2 = cells.2, verbose = verbose ), 'negbinom' = GLMDETest( data.use = object[features, c(cells.1, cells.2), drop = FALSE], cells.1 = cells.1, cells.2 = cells.2, min.cells = min.cells.feature, latent.vars = latent.vars, test.use = test.use, verbose = verbose ), 'poisson' = GLMDETest( data.use = object[features, c(cells.1, cells.2), drop = FALSE], cells.1 = cells.1, cells.2 = cells.2, min.cells = min.cells.feature, latent.vars = latent.vars, test.use = test.use, verbose = verbose ), 'MAST' = MASTDETest( data.use = object[features, c(cells.1, cells.2), drop = FALSE], cells.1 = cells.1, cells.2 = cells.2, latent.vars = latent.vars, verbose = verbose, ... ), "DESeq2" = DESeq2DETest( data.use = object[features, c(cells.1, cells.2), drop = FALSE], cells.1 = cells.1, cells.2 = cells.2, verbose = verbose, ... ), "LR" = LRDETest( data.use = object[features, c(cells.1, cells.2), drop = FALSE], cells.1 = cells.1, cells.2 = cells.2, latent.vars = latent.vars, verbose = verbose ), stop("Unknown test: ", test.use) ) if (is.null(x = reduction)) { diff.col <- ifelse( test = slot == "scale.data" || test.use == 'roc', yes = "avg_diff", no = "avg_logFC" ) de.results[, diff.col] <- total.diff[rownames(x = de.results)] de.results <- cbind(de.results, data.alpha[rownames(x = de.results), , drop = FALSE]) } else { diff.col <- "avg_diff" de.results[, diff.col] <- total.diff[rownames(x = de.results)] } if (only.pos) { de.results <- de.results[de.results[, diff.col] > 0, , drop = FALSE] } if (test.use == "roc") { de.results <- de.results[order(-de.results$power, -de.results[, diff.col]), ] } else { de.results <- de.results[order(de.results$p_val, -de.results[, diff.col]), ] de.results$p_val_adj = p.adjust( p = de.results$p_val, method = "bonferroni", n = nrow(x = object) ) } return(de.results) } #' @param ident.1 Identity class to define markers for; pass an object of class #' \code{phylo} or 'clustertree' to find markers for a node in a cluster tree; #' passing 'clustertree' requires \code{\link{BuildClusterTree}} to have been run #' @param ident.2 A second identity class for comparison; if \code{NULL}, #' use all other cells for comparison; if an object of class \code{phylo} or #' 'clustertree' is passed to \code{ident.1}, must pass a node to find markers for #' @param reduction Reduction to use in differential expression testing - will test for DE on cell embeddings #' @param group.by Regroup cells into a different identity class prior to performing differential expression (see example) #' @param subset.ident Subset a particular identity class prior to regrouping. Only relevant if group.by is set (see example) #' @param assay Assay to use in differential expression testing #' @param slot Slot to pull data from; note that if \code{test.use} is "negbinom", "poisson", or "DESeq2", #' \code{slot} will be set to "counts" #' #' @importFrom methods is #' #' @rdname FindMarkers #' @export #' @method FindMarkers Seurat #' FindMarkers.Seurat <- function( object, ident.1 = NULL, ident.2 = NULL, group.by = NULL, subset.ident = NULL, assay = NULL, slot = 'data', reduction = NULL, features = NULL, logfc.threshold = 0.25, test.use = "wilcox", min.pct = 0.1, min.diff.pct = -Inf, verbose = TRUE, only.pos = FALSE, max.cells.per.ident = Inf, random.seed = 1, latent.vars = NULL, min.cells.feature = 3, min.cells.group = 3, pseudocount.use = 1, ... ) { if (!is.null(x = group.by)) { if (!is.null(x = subset.ident)) { object <- subset(x = object, idents = subset.ident) } Idents(object = object) <- group.by } if (!is.null(x = assay) && !is.null(x = reduction)) { stop("Please only specify either assay or reduction.") } data.slot <- ifelse( test = test.use %in% c("negbinom", "poisson", "DESeq2"), yes = 'counts', no = slot ) if (is.null(x = reduction)) { assay <- assay %||% DefaultAssay(object = object) data.use <- GetAssayData(object = object[[assay]], slot = data.slot) } else { if (data.slot == "counts") { stop("The following tests cannot be used when specifying a reduction as they assume a count model: negbinom, poisson, DESeq2") } data.use <- t(x = Embeddings(object = object, reduction = reduction)) } if (is.null(x = ident.1)) { stop("Please provide ident.1") } else if ((length(x = ident.1) == 1 && ident.1[1] == 'clustertree') || is(object = ident.1, class2 = 'phylo')) { if (is.null(x = ident.2)) { stop("Please pass a node to 'ident.2' to run FindMarkers on a tree") } tree <- if (is(object = ident.1, class2 = 'phylo')) { ident.1 } else { Tool(object = object, slot = 'BuildClusterTree') } if (is.null(x = tree)) { stop("Please run 'BuildClusterTree' or pass an object of class 'phylo' as 'ident.1'") } ident.1 <- tree$tip.label[GetLeftDescendants(tree = tree, node = ident.2)] ident.2 <- tree$tip.label[GetRightDescendants(tree = tree, node = ident.2)] } if (length(x = as.vector(x = ident.1)) > 1 && any(as.character(x = ident.1) %in% colnames(x = data.use))) { bad.cells <- colnames(x = data.use)[which(x = !as.character(x = ident.1) %in% colnames(x = data.use))] if (length(x = bad.cells) > 0) { stop(paste0("The following cell names provided to ident.1 are not present in the object: ", paste(bad.cells, collapse = ", "))) } } else { ident.1 <- WhichCells(object = object, idents = ident.1) } # if NULL for ident.2, use all other cells if (length(x = as.vector(x = ident.2)) > 1 && any(as.character(x = ident.2) %in% colnames(x = data.use))) { bad.cells <- colnames(x = data.use)[which(!as.character(x = ident.2) %in% colnames(x = data.use))] if (length(x = bad.cells) > 0) { stop(paste0("The following cell names provided to ident.2 are not present in the object: ", paste(bad.cells, collapse = ", "))) } } else { if (is.null(x = ident.2)) { ident.2 <- setdiff(x = colnames(x = data.use), y = ident.1) } else { ident.2 <- WhichCells(object = object, idents = ident.2) } } if (!is.null(x = latent.vars)) { latent.vars <- FetchData( object = object, vars = latent.vars, cells = c(ident.1, ident.2) ) } counts <- switch( EXPR = data.slot, 'scale.data' = GetAssayData(object = object[[assay]], slot = "counts"), numeric() ) de.results <- FindMarkers( object = data.use, slot = data.slot, counts = counts, cells.1 = ident.1, cells.2 = ident.2, features = features, reduction = reduction, logfc.threshold = logfc.threshold, test.use = test.use, min.pct = min.pct, min.diff.pct = min.diff.pct, verbose = verbose, only.pos = only.pos, max.cells.per.ident = max.cells.per.ident, random.seed = random.seed, latent.vars = latent.vars, min.cells.feature = min.cells.feature, min.cells.group = min.cells.group, pseudocount.use = pseudocount.use, ... ) return(de.results) } #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # Internal #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% # internal function to calculate AUC values #' @importFrom pbapply pblapply # AUCMarkerTest <- function(data1, data2, mygenes, print.bar = TRUE) { myAUC <- unlist(x = lapply( X = mygenes, FUN = function(x) { return(DifferentialAUC( x = as.numeric(x = data1[x, ]), y = as.numeric(x = data2[x, ]) )) } )) myAUC[is.na(x = myAUC)] <- 0 iterate.fxn <- ifelse(test = print.bar, yes = pblapply, no = lapply) avg_diff <- unlist(x = iterate.fxn( X = mygenes, FUN = function(x) { return( ExpMean( x = as.numeric(x = data1[x, ]) ) - ExpMean( x = as.numeric(x = data2[x, ]) ) ) } )) toRet <- data.frame(cbind(myAUC, avg_diff), row.names = mygenes) toRet <- toRet[rev(x = order(toRet$myAUC)), ] return(toRet) } #internal function to run mcdavid et al. DE test # #' @importFrom stats sd dnorm # bimodLikData <- function(x, xmin = 0) { x1 <- x[x <= xmin] x2 <- x[x > xmin] xal <- MinMax( data = length(x = x2) / length(x = x), min = 1e-5, max = (1 - 1e-5) ) likA <- length(x = x1) * log(x = 1 - xal) if (length(x = x2) < 2) { mysd <- 1 } else { mysd <- sd(x = x2) } likB <- length(x = x2) * log(x = xal) + sum(dnorm(x = x2, mean = mean(x = x2), sd = mysd, log = TRUE)) return(likA + likB) } # Differential expression using DESeq2 # # Identifies differentially expressed genes between two groups of cells using # DESeq2 # # @references Love MI, Huber W and Anders S (2014). "Moderated estimation of # fold change and dispersion for RNA-seq data with DESeq2." Genome Biology. # https://bioconductor.org/packages/release/bioc/html/DESeq2.html # @param data.use Data matrix to test # @param cells.1 Group 1 cells # @param cells.2 Group 2 cells # @param verbose Print a progress bar # @param ... Extra parameters to pass to DESeq2::results # @return Returns a p-value ranked matrix of putative differentially expressed # genes. # # @details # This test does not support pre-filtering of genes based on average difference # (or percent detection rate) between cell groups. However, genes may be # pre-filtered based on their minimum detection rate (min.pct) across both cell # groups. To use this method, please install DESeq2, using the instructions at # https://bioconductor.org/packages/release/bioc/html/DESeq2.html # # @export # # @examples # \dontrun{ # pbmc_small # DESeq2DETest(pbmc_small, cells.1 = WhichCells(object = pbmc_small, idents = 1), # cells.2 = WhichCells(object = pbmc_small, idents = 2)) # } # DESeq2DETest <- function( data.use, cells.1, cells.2, verbose = TRUE, ... ) { if (!PackageCheck('DESeq2', error = FALSE)) { stop("Please install DESeq2 - learn more at https://bioconductor.org/packages/release/bioc/html/DESeq2.html") } CheckDots(..., fxns = 'DESeq2::results') group.info <- data.frame(row.names = c(cells.1, cells.2)) group.info[cells.1, "group"] <- "Group1" group.info[cells.2, "group"] <- "Group2" group.info[, "group"] <- factor(x = group.info[, "group"]) group.info$wellKey <- rownames(x = group.info) dds1 <- DESeq2::DESeqDataSetFromMatrix( countData = data.use, colData = group.info, design = ~ group ) dds1 <- DESeq2::estimateSizeFactors(object = dds1) dds1 <- DESeq2::estimateDispersions(object = dds1, fitType = "local") dds1 <- DESeq2::nbinomWaldTest(object = dds1) res <- DESeq2::results( object = dds1, contrast = c("group", "Group1", "Group2"), alpha = 0.05, ... ) to.return <- data.frame(p_val = res$pvalue, row.names = rownames(res)) return(to.return) } # internal function to calculate AUC values #' @importFrom ROCR prediction performance #' DifferentialAUC <- function(x, y) { prediction.use <- prediction( predictions = c(x, y), labels = c(rep(x = 1, length(x = x)), rep(x = 0, length(x = y))), label.ordering = 0:1 ) perf.use <- performance(prediction.obj = prediction.use, measure = "auc") auc.use <- round(x = perf.use@y.values[[1]], digits = 3) return(auc.use) } #internal function to run mcdavid et al. DE test # #' @importFrom stats pchisq # DifferentialLRT <- function(x, y, xmin = 0) { lrtX <- bimodLikData(x = x) lrtY <- bimodLikData(x = y) lrtZ <- bimodLikData(x = c(x, y)) lrt_diff <- 2 * (lrtX + lrtY - lrtZ) return(pchisq(q = lrt_diff, df = 3, lower.tail = F)) } # Likelihood ratio test for zero-inflated data # # Identifies differentially expressed genes between two groups of cells using # the LRT model proposed in McDavid et al, Bioinformatics, 2013 # # @inheritParams FindMarkers # @param object Seurat object # @param cells.1 Group 1 cells # @param cells.2 Group 2 cells # @param assay.type Type of assay to fetch data for (default is RNA) # @return Returns a p-value ranked matrix of putative differentially expressed # genes. # #' @importFrom pbapply pbsapply #' @importFrom future.apply future_sapply #' @importFrom future nbrOfWorkers # # @export # @examples # pbmc_small # DiffExpTest(pbmc_small, cells.1 = WhichCells(object = pbmc_small, idents = 1), # cells.2 = WhichCells(object = pbmc_small, idents = 2)) # DiffExpTest <- function( data.use, cells.1, cells.2, verbose = TRUE ) { my.sapply <- ifelse( test = verbose && nbrOfWorkers() == 1, yes = pbsapply, no = future_sapply ) p_val <- unlist( x = my.sapply( X = 1:nrow(x = data.use), FUN = function(x) { return(DifferentialLRT( x = as.numeric(x = data.use[x, cells.1]), y = as.numeric(x = data.use[x, cells.2]) )) } ) ) to.return <- data.frame(p_val, row.names = rownames(x = data.use)) return(to.return) } # Differential expression testing using Student's t-test # # Identify differentially expressed genes between two groups of cells using # the Student's t-test # # @return Returns a p-value ranked matrix of putative differentially expressed # genes. # #' @importFrom stats t.test #' @importFrom pbapply pbsapply #' @importFrom future.apply future_sapply #' @importFrom future nbrOfWorkers # # @export # # @examples # pbmc_small # DiffTTest(pbmc_small, cells.1 = WhichCells(object = pbmc_small, idents = 1), # cells.2 = WhichCells(object = pbmc_small, idents = 2)) DiffTTest <- function( data.use, cells.1, cells.2, verbose = TRUE ) { my.sapply <- ifelse( test = verbose && nbrOfWorkers() == 1, yes = pbsapply, no = future_sapply ) p_val <- unlist( x = my.sapply( X = 1:nrow(data.use), FUN = function(x) { t.test(x = data.use[x, cells.1], y = data.use[x, cells.2])$p.value } ) ) to.return <- data.frame(p_val,row.names = rownames(x = data.use)) return(to.return) } # Tests for UMI-count based data # # Identifies differentially expressed genes between two groups of cells using # either a negative binomial or poisson generalized linear model # # @param data.use Data to test # @param cells.1 Group 1 cells # @param cells.2 Group 2 cells # @param min.cells Minimum number of cells threshold # @param latent.vars Latent variables to test # @param test.use parameterizes the glm # @param verbose Print progress bar # # @return Returns a p-value ranked matrix of putative differentially expressed # genes. # #' @importFrom MASS glm.nb #' @importFrom pbapply pbsapply #' @importFrom stats var as.formula #' @importFrom future.apply future_sapply #' @importFrom future nbrOfWorkers #' # @export # # @examples # pbmc_small # # Note, not recommended for particularly small datasets - expect warnings # NegBinomDETest(pbmc_small, cells.1 = WhichCells(object = pbmc_small, idents = 1), # cells.2 = WhichCells(object = pbmc_small, idents = 2)) # GLMDETest <- function( data.use, cells.1, cells.2, min.cells = 3, latent.vars = NULL, test.use = NULL, verbose = TRUE ) { group.info <- data.frame( group = rep( x = c('Group1', 'Group2'), times = c(length(x = cells.1), length(x = cells.2)) ) ) rownames(group.info) <- c(cells.1, cells.2) group.info[, "group"] <- factor(x = group.info[, "group"]) latent.vars <- if (is.null(x = latent.vars)) { group.info } else { cbind(x = group.info, latent.vars) } latent.var.names <- colnames(x = latent.vars) my.sapply <- ifelse( test = verbose && nbrOfWorkers() == 1, yes = pbsapply, no = future_sapply ) p_val <- unlist( x = my.sapply( X = 1:nrow(data.use), FUN = function(x) { latent.vars[, "GENE"] <- as.numeric(x = data.use[x, ]) # check that gene is expressed in specified number of cells in one group if (sum(latent.vars$GENE[latent.vars$group == "Group1"] > 0) < min.cells && sum(latent.vars$GENE[latent.vars$group == "Group2"] > 0) < min.cells) { warning(paste0( "Skipping gene --- ", x, ". Fewer than ", min.cells, " cells in both clusters." )) return(2) } # check that variance between groups is not 0 if (var(x = latent.vars$GENE) == 0) { warning(paste0( "Skipping gene -- ", x, ". No variance in expression between the two clusters." )) return(2) } fmla <- as.formula(object = paste( "GENE ~", paste(latent.var.names, collapse = "+") )) p.estimate <- 2 if (test.use == "negbinom") { try( expr = p.estimate <- summary( object = glm.nb(formula = fmla, data = latent.vars) )$coef[2, 4], silent = TRUE ) return(p.estimate) } else if (test.use == "poisson") { return(summary(object = glm( formula = fmla, data = latent.vars, family = "poisson" ))$coef[2,4]) } } ) ) features.keep <- rownames(data.use) if (length(x = which(x = p_val == 2)) > 0) { features.keep <- features.keep[-which(x = p_val == 2)] p_val <- p_val[!p_val == 2] } to.return <- data.frame(p_val, row.names = features.keep) return(to.return) } # Perform differential expression testing using a logistic regression framework # # Constructs a logistic regression model predicting group membership based on a # given feature and compares this to a null model with a likelihood ratio test. # # @param data.use expression matrix # @param cells.1 Vector of cells in group 1 # @param cells2. Vector of cells in group 2 # @param latent.vars Latent variables to include in model # @param verbose Print messages # #' @importFrom lmtest lrtest #' @importFrom pbapply pbsapply #' @importFrom stats as.formula glm #' @importFrom future.apply future_sapply #' @importFrom future nbrOfWorkers # LRDETest <- function( data.use, cells.1, cells.2, latent.vars = NULL, verbose = TRUE ) { group.info <- data.frame(row.names = c(cells.1, cells.2)) group.info[cells.1, "group"] <- "Group1" group.info[cells.2, "group"] <- "Group2" group.info[, "group"] <- factor(x = group.info[, "group"]) data.use <- data.use[, rownames(group.info), drop = FALSE] latent.vars <- latent.vars[rownames(group.info), , drop = FALSE] my.sapply <- ifelse( test = verbose && nbrOfWorkers() == 1, yes = pbsapply, no = future_sapply ) p_val <- my.sapply( X = 1:nrow(x = data.use), FUN = function(x) { if (is.null(x = latent.vars)) { model.data <- cbind(GENE = data.use[x, ], group.info) fmla <- as.formula(object = "group ~ GENE") fmla2 <- as.formula(object = "group ~ 1") } else { model.data <- cbind(GENE = data.use[x, ], group.info, latent.vars) fmla <- as.formula(object = paste( "group ~ GENE +", paste(colnames(x = latent.vars), collapse = "+") )) fmla2 <- as.formula(object = paste( "group ~", paste(colnames(x = latent.vars), collapse = "+") )) } model1 <- glm(formula = fmla, data = model.data, family = "binomial") model2 <- glm(formula = fmla2, data = model.data, family = "binomial") lrtest <- lrtest(model1, model2) return(lrtest$Pr[2]) } ) to.return <- data.frame(p_val, row.names = rownames(data.use)) return(to.return) } # ROC-based marker discovery # # Identifies 'markers' of gene expression using ROC analysis. For each gene, # evaluates (using AUC) a classifier built on that gene alone, to classify # between two groups of cells. # # An AUC value of 1 means that expression values for this gene alone can # perfectly classify the two groupings (i.e. Each of the cells in cells.1 # exhibit a higher level than each of the cells in cells.2). An AUC value of 0 # also means there is perfect classification, but in the other direction. A # value of 0.5 implies that the gene has no predictive power to classify the # two groups. # # @return Returns a 'predictive power' (abs(AUC-0.5) * 2) ranked matrix of # putative differentially expressed genes. # # @export # # @examples # pbmc_small # MarkerTest(pbmc_small, cells.1 = WhichCells(object = pbmc_small, idents = 1), # cells.2 = WhichCells(object = pbmc_small, idents = 2)) # MarkerTest <- function( data.use, cells.1, cells.2, verbose = TRUE ) { to.return <- AUCMarkerTest( data1 = data.use[, cells.1, drop = FALSE], data2 = data.use[, cells.2, drop = FALSE], mygenes = rownames(x = data.use), print.bar = verbose ) to.return$power <- abs(x = to.return$myAUC - 0.5) * 2 return(to.return) } # Differential expression using MAST # # Identifies differentially expressed genes between two groups of cells using # a hurdle model tailored to scRNA-seq data. Utilizes the MAST package to run # the DE testing. # # @references Andrew McDavid, Greg Finak and Masanao Yajima (2017). MAST: Model-based # Analysis of Single Cell Transcriptomics. R package version 1.2.1. # https://github.com/RGLab/MAST/ # # @param data.use Data to test # @param cells.1 Group 1 cells # @param cells.2 Group 2 cells # @param latent.vars Confounding variables to adjust for in DE test. Default is # "nUMI", which adjusts for cellular depth (i.e. cellular detection rate). For # non-UMI based data, set to nGene instead. # @param verbose print output # @param \dots Additional parameters to zero-inflated regression (zlm) function # in MAST # @details # To use this method, please install MAST, using instructions at https://github.com/RGLab/MAST/ # # @return Returns a p-value ranked matrix of putative differentially expressed # genes. # #' @importFrom stats relevel # # @export # # @examples # \dontrun{ # pbmc_small # MASTDETest(pbmc_small, cells.1 = WhichCells(object = pbmc_small, idents = 1), # cells.2 = WhichCells(object = pbmc_small, idents = 2)) # } # MASTDETest <- function( data.use, cells.1, cells.2, latent.vars = NULL, verbose = TRUE, ... ) { # Check for MAST if (!PackageCheck('MAST', error = FALSE)) { stop("Please install MAST - learn more at https://github.com/RGLab/MAST") } if (length(x = latent.vars) > 0) { latent.vars <- scale(x = latent.vars) } group.info <- data.frame(row.names = c(cells.1, cells.2)) latent.vars <- latent.vars %||% group.info group.info[cells.1, "group"] <- "Group1" group.info[cells.2, "group"] <- "Group2" group.info[, "group"] <- factor(x = group.info[, "group"]) latent.vars.names <- c("condition", colnames(x = latent.vars)) latent.vars <- cbind(latent.vars, group.info) latent.vars$wellKey <- rownames(x = latent.vars) fdat <- data.frame(rownames(x = data.use)) colnames(x = fdat)[1] <- "primerid" rownames(x = fdat) <- fdat[, 1] sca <- MAST::FromMatrix( exprsArray = as.matrix(x = data.use), cData = latent.vars, fData = fdat ) cond <- factor(x = SummarizedExperiment::colData(sca)$group) cond <- relevel(x = cond, ref = "Group1") SummarizedExperiment::colData(sca)$condition <- cond fmla <- as.formula( object = paste0(" ~ ", paste(latent.vars.names, collapse = "+")) ) zlmCond <- MAST::zlm(formula = fmla, sca = sca, ...) summaryCond <- summary(object = zlmCond, doLRT = 'conditionGroup2') summaryDt <- summaryCond$datatable # fcHurdle <- merge( # summaryDt[contrast=='conditionGroup2' & component=='H', .(primerid, `Pr(>Chisq)`)], #hurdle P values # summaryDt[contrast=='conditionGroup2' & component=='logFC', .(primerid, coef, ci.hi, ci.lo)], by='primerid' # ) #logFC coefficients # fcHurdle[,fdr:=p.adjust(`Pr(>Chisq)`, 'fdr')] p_val <- summaryDt[summaryDt[, "component"] == "H", 4] genes.return <- summaryDt[summaryDt[, "component"] == "H", 1] # p_val <- subset(summaryDt, component == "H")[, 4] # genes.return <- subset(summaryDt, component == "H")[, 1] to.return <- data.frame(p_val, row.names = genes.return) return(to.return) } # compare two negative binomial regression models # model one uses only common factors (com.fac) # model two additionally uses group factor (grp.fac) # #' @importFrom stats glm anova coef # NBModelComparison <- function(y, theta, latent.data, com.fac, grp.fac) { tab <- as.matrix(x = table(y > 0, latent.data[, grp.fac])) freqs <- tab['TRUE', ] / apply(X = tab, MARGIN = 2, FUN = sum) fit2 <- 0 fit4 <- 0 try( expr = fit2 <- glm( formula = y ~ ., data = latent.data[, com.fac, drop = FALSE], family = MASS::negative.binomial(theta = theta) ), silent=TRUE ) try( fit4 <- glm( formula = y ~ ., data = latent.data[, c(com.fac, grp.fac)], family = MASS::negative.binomial(theta = theta) ), silent = TRUE ) if (is.numeric(x = fit2) || is.numeric(x = fit4)) { message('One of the glm.nb calls failed') return(c(rep(x = NA, 5), freqs)) } pval <- anova(fit2, fit4, test = 'Chisq')$'Pr(>Chi)'[2] foi <- 2 + length(x = com.fac) log2.fc <- log2(x = 1 / exp(x = coef(object = fit4)[foi])) ret <- c( fit2$deviance, fit4$deviance, pval, coef(object = fit4)[foi], log2.fc, freqs ) names(x = ret) <- c( 'dev1', 'dev2', 'pval', 'coef', 'log2.fc', 'freq1', 'freq2' ) return(ret) } # given a UMI count matrix, estimate NB theta parameter for each gene # and use fit of relationship with mean to assign regularized theta to each gene # #' @importFrom stats glm loess poisson #' @importFrom utils txtProgressBar setTxtProgressBar # RegularizedTheta <- function(cm, latent.data, min.theta = 0.01, bin.size = 128) { genes.regress <- rownames(x = cm) bin.ind <- ceiling(x = 1:length(x = genes.regress) / bin.size) max.bin <- max(bin.ind) message('Running Poisson regression (to get initial mean), and theta estimation per gene') pb <- txtProgressBar(min = 0, max = max.bin, style = 3, file = stderr()) theta.estimate <- c() for (i in 1:max.bin) { genes.bin.regress <- genes.regress[bin.ind == i] bin.theta.estimate <- unlist( x = parallel::mclapply( X = genes.bin.regress, FUN = function(j) { return(as.numeric(x = MASS::theta.ml( y = cm[j, ], mu = glm( formula = cm[j, ] ~ ., data = latent.data, family = poisson )$fitted ))) } ), use.names = FALSE ) theta.estimate <- c(theta.estimate, bin.theta.estimate) setTxtProgressBar(pb = pb, value = i) } close(con = pb) UMI.mean <- apply(X = cm, MARGIN = 1, FUN = mean) var.estimate <- UMI.mean + (UMI.mean ^ 2) / theta.estimate for (span in c(1/3, 1/2, 3/4, 1)) { fit <- loess( formula = log10(x = var.estimate) ~ log10(x = UMI.mean), span = span ) if (! any(is.na(x = fit$fitted))) { message(sprintf( 'Used loess with span %1.2f to fit mean-variance relationship\n', span )) break } } if (any(is.na(x = fit$fitted))) { stop('Problem when fitting NB gene variance in RegularizedTheta - NA values were fitted.') } theta.fit <- (UMI.mean ^ 2) / ((10 ^ fit$fitted) - UMI.mean) names(x = theta.fit) <- genes.regress to.fix <- theta.fit <= min.theta | is.infinite(x = theta.fit) if (any(to.fix)) { message( 'Fitted theta below ', min.theta, ' for ', sum(to.fix), ' genes, setting them to ', min.theta ) theta.fit[to.fix] <- min.theta } return(theta.fit) } # Differential expression using Wilcoxon Rank Sum # # Identifies differentially expressed genes between two groups of cells using # a Wilcoxon Rank Sum test # # @param data.use Data matrix to test # @param cells.1 Group 1 cells # @param cells.2 Group 2 cells # @param verbose Print a progress bar # @param ... Extra parameters passed to wilcox.test # # @return Returns a p-value ranked matrix of putative differentially expressed # features # #' @importFrom pbapply pbsapply #' @importFrom stats wilcox.test #' @importFrom future.apply future_sapply #' @importFrom future nbrOfWorkers # # @export # # @examples # pbmc_small # WilcoxDETest(pbmc_small, cells.1 = WhichCells(object = pbmc_small, idents = 1), # cells.2 = WhichCells(object = pbmc_small, idents = 2)) # WilcoxDETest <- function( data.use, cells.1, cells.2, verbose = TRUE, ... ) { group.info <- data.frame(row.names = c(cells.1, cells.2)) group.info[cells.1, "group"] <- "Group1" group.info[cells.2, "group"] <- "Group2" group.info[, "group"] <- factor(x = group.info[, "group"]) data.use <- data.use[, rownames(x = group.info), drop = FALSE] my.sapply <- ifelse( test = verbose && nbrOfWorkers() == 1, yes = pbsapply, no = future_sapply ) p_val <- my.sapply( X = 1:nrow(x = data.use), FUN = function(x) { return(wilcox.test(data.use[x, ] ~ group.info[, "group"], ...)$p.value) } ) return(data.frame(p_val, row.names = rownames(x = data.use))) } Seurat/NEWS.md0000644000176200001440000002146013617623374012632 0ustar liggesusers# News All notable changes to Seurat will be documented in this file. The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) ## [3.1.3] = 2020-02-07 ### Added - New system agnostic `Which` function to address problems with FItSNE on Windows ### Changes - Export `CellsByIdentities` and `RowMergeSparseMatrices` functions - nCount and nFeature metadata variables retained after subset and updated properly with `UpdateSeuratObject` - Fix uwot support for running directly on feature matrices - Fixes for keys with underscores - Fix issue with leiden option for `FindClusters` - Fix for data transfer when using sctransform - SDMTools moved to Suggests as package is orphaned ## [3.1.2] - 2019-12-11 ### Added - New silent slot updater - New random seed options to `RunCCA`, `RunTSNE`, `WhichCells`, `HTODemux`, `AddModuleScore`, `VlnPlot`, and `RidgePlot` - Enhancements for dealing with `Assay`-derived objects ### Changed - Only run `CalcN` (generates nFeatures and nCounts) when `counts` changes - Fix issue regarding colons in feature names - Change object class testing to use `inherits` or `is.*` for R 4.0 compatability ## [3.1.1] - 2019-09-20 ### Added - New `RegroupIdents` function to reassign idents based on metadata column majority - `UpdateSymbolList` function to pull new gene names from HGNC - Added support for H5AD layers as additional assays in a `Seurat` object ### Changed - Fix rownames issue when running UMAP on dist object - Add support for new H5AD `obsm` and `varm` stucture - Fix issue when trying to read non-existent feature-level metadata from an H5AD file - Fix in integration workflow when using SCTransform - Improved error checking for `AddModuleScore` - cbind fix in reference-based integration (`MapQuery`) - Fix for convenience plots error hanging - Ensure Seurat objects aren't stored in the command logs ## [3.1.0] - 2019-08-20 ### Added - New `PrepSCTIntegration` function to facilitate integration after `SCTransform` - Reference-based integration with the `reference` parameter in `FindIntegrationAnchors` - Reciprocal PCA as a `reduction` option in `FindIntegrationAnchors` - New `CollapseEmbeddingOutliers` function - Enable `FindTransferAnchors` after `SCTransform` - Added back `ColorDimSplit` functionality - Include a code of conduct - Added uwot support as new default UMAP method - Added `CheckDots` to catch unused parameters and suggest updated names - `Reductions` and `Assays` assays functions to list stored DimReducs and Assays ### Changed - Fix regex in `LogSeuratCommand` - Check for NAs in feature names in `Read10X` - Prevent dimnames for counts/data/scale.data matrices from being arrays - Updates `ReadH5AD` to distinguish FVF methods - Fixes to UpdateSeuratObject for v2 objects - Sink all output from stdout to stderr - Fix to scale.data cell ordering after subsetting - Enable `Assay` specification in `BuildClusterTree` - Fix `FeaturePlot` when using both `blend` and `split.by` - Fix to `WhichCells` when passing `cells` and `invert` - Fix to `HoverLocator` labels and title - Ensure features names don't contain pipes (`|`) - Deprecation of `RunLSI` and `RunALRA` - Fix legend bug when sorting in `ExIPlot` ## [3.0.2] - 2019-06-07 ### Added - Flag to skip singleton grouping in `FindClusters` - New custom colors for blended `FeaturePlot`s - New `GetResidual` function - New Seurat/Monocle converters ### Changed - Fix issue where certain assays weren't being shown in the `Seurat` object - Fix issue where we weren't updating `DimReduc` object column names - Fix line spacers in `DoHeatmap` - Fix uninformative labels in `FeaturePlot` - Fix unset identities when converting from SCE to Seurat - Fix single colors being interpreted as palettes in `SingleDimPlot` - Ensure factor levels are always numerically increasing after `FindClusters` - Better cell highlighting colors for `DimPlot` - Fix to `levels<-.Seurat` - Add ability to use counts/scaled data in `BuildClusterTree` - Minor fix to split `ScaleData` ## [3.0.1] - 2019-05-16 ### Added - Add global option (Seurat.memsafe) to skip gc() calls - Restore draw.lines to DoHeatmap, maintain size of color bar with different number of features (#1429) - Enable split.by parameter for ScaleData - Add slot parameter to FeaturePlot (#1483) - Add assay parameter to DotPlot (#1404) ### Changed - Fix to color options for VlnPlot with split.by option (#1425) - Improvements to conversion functions (loom, SCE) - Fix for cluster tree reordering (#1434) - Fix PercentageFeatureSet for single feature case - Fix to fold change calculation and filtering for other slots in FindMarkers (#1454) - Keep title vectorized in AugmentPlot (#1515) - Export LogSeuratCommand function - Fix for FindConservedMarkers when one ident is missing from a group (#1517) ## [3.0.0] - 2019-04-16 ### Added - New method for identifying anchors across single-cell datasets - Parallelization support via future - Additional method for demultiplexing with MULTIseqDemux - Support normalization via sctransform - New option for clustering with the Leiden algorithm - Support for reading 10X v3 files - New function to export Seurat objects for the UCSC cell browser - Support for data import from Alevin outputs - Imputation of dropped out values via ALRA ### Changed - Significant code restructuring - Most occurances of "gene(s)" in function names/arguments renamed to "feature(s)" - Changes to the Seurat object class to facilitate multimodal data - New BlendPlot implementation ## [2.3.4] - 2018-07-13 ### Added - GetIdent function added to pull identity info ### Changed - DiffusionMap dependency replaced with destiny to avoid archival - Java dependency removed and functionality rewritten in Rcpp - Speed and efficiency improvements for Rcpp code - More robust duplicate handling in CellCycleScoring ## [2.3.3] - 2018-07-02 ### Added - New HTOHeatmap function - Support for custom PNG arguments for vector-friendly plotting - Fix for 'NA'-labeled cells disappearing with custom color scale ### Changed - Replaced FNN with RANN - Removed unused compiler flags - Moved several lightly-used packages from 'imports' to 'suggests' ## [2.3.2] - 2018-06-11 ### Added - RenameCells added for easy renaming of all cells - Read10X_h5 added to read in 10X formatted h5 files - SetAssayData ensures cell order is the same between assay objects and the Seurat object - Compatability updates for ggplot2 v2.3.0 ## [2.3.1] - 2018-05-03 ### Added - Support for [UMAP](https://github.com/lmcinnes/umap) dimensional reduction technique - New conversion functions for SingleCellExperiment and anndata ### Changed - FetchData preserves cell order - Require Matrix 1.2-14 or higher - AddModuleScore no longer densifies sparse-matrices - Various visualization fixes and improvements - Default value for latent.vars in FindMarkers/FindAllMarkers changed to NULL. ## [2.3.0] - 2018-03-22 ### Added - Support for HTO demultiplexing - Utility functions: TransferIdent, CombineIdent, SplitObject, vector.friendly - C++ implementation for parts of BuildSNN - Preliminary parallelization support (regression and JackStraw) - Support for FItSNE ### Changed - MetaDE replaced with metap for combining p-values (MetaDE was removed from CRAN) - NMF heatmaps replaced (NMF to be archived by CRAN) ## [2.2.1] - 2018-02-14 ### Changed - MetaDE replaced with metap for combining p-values (MetaDE was removed from CRAN) - NMF heatmaps replaced (NMF to be archived by CRAN) ## [2.2.0] - 2018-01-10 ### Added - Multiple alignment functionality with RunMultiCCA and AlignSubspace extended to multiple datasets - CalcAlignmentScore added to evaluate alignment quality - MetageneBicorPlot added to guide CC selection - Change cluster order in DoHeatmap with group.order parameter - Ability to change plotting order and add a title to DimPlot - do.clean and subset.raw options for SubsetData ### Changed - JoyPlot has been replaced with RidgePlot - FindClusters is now more robust in making temp files - MetaDE support for combining p-values in DE testing ## [2.1.0] - 2017-10-12 ### Added - Support for using MAST and DESeq2 packages for differential expression testing in FindMarkers - Support for multi-modal single-cell data via @assay slot ### Changed - Default DE test changed to Wilcoxon rank sum test ## [2.0.1] - 2017-08-18 ### Added - Now available on CRAN - Updated documentation complete with examples - Example datasets: `pbmc_small` and `cc.genes` - C++ implementation for parts of FindVariableGenes - Minor bug fixes ## [2.0.0] - 2017-07-26 ### Added - New method for aligning scRNA-seq datasets - Significant code restructuring - New methods for scoring gene expression and cell-cycle phases - New visualization features (do.hover, do.identify) Seurat/MD50000644000176200001440000002622413620617476012047 0ustar liggesusers5ae18da61be3342701bbe181862a0b41 *DESCRIPTION 9c25e1cdc3b5122842a6a70fab49a522 *LICENSE 0918d10cf5e2c6be0350187d519deab8 *NAMESPACE a24d83ad4140aa7870f23a8ac71777f6 *NEWS.md 97db00af10424e771678fab92c76a003 *R/RcppExports.R 920ac9b21d3b89fea009cef15e0d4382 *R/clustering.R 3e3b12a2a7699398bc1127d4153fa7d8 *R/convenience.R bdac8be7ba2c8534f249753c7212f1c5 *R/data.R bef77e3af04b9f8a58a44597ee38b9c5 *R/differential_expression.R da173e452fbecea71cb70028680e63ae *R/dimensional_reduction.R 0d1ce1fbf28ba409e8fa3c3aa7ef1fe5 *R/generics.R f1009beef7c71dbbf54fe49ec4fe73ec *R/integration.R 1fa9b214395d1ee7da99c204a24cd3b6 *R/objects.R d2acdfb39bf35edc8902ed80615a1c3c *R/preprocessing.R 7e8c80633698d4c21250fbd708a7aa70 *R/tree.R 060bf78d135713b7be09423394d4491f *R/utilities.R c0e6c074ac42163a1f7fa07d81b4f7f0 *R/visualization.R 229941c409a680dbc2d50ab7a83053df *R/zzz.R cc0fdde0659ba33b41ea70e85c747ae8 *README.md e84661f995a9f29d1a09ebcdc27d3a82 *data/cc.genes.rda 55d7e35793436d5e91646d774d9f86c4 *data/cc.genes.updated.2019.rda f31fc6d89626ed493ef21557a33021ac *data/pbmc_small.rda 662d863954257adcd30cc16d711cbb90 *inst/CITATION 52ddf2b7d1f36b68cacc5999ae7999ab *inst/extdata/pbmc_raw.txt 21435fc6d24eb49cccff5c65dc439d3a *man/ALRAChooseKPlot.Rd 22f30653f7b918e77fd2e3d0ef5a9530 *man/AddMetaData.Rd 7277f141b725c18b60c1da6dfdce8bf7 *man/AddModuleScore.Rd fc1e32e780e8a7d362fc55aaf84511df *man/AnchorSet-class.Rd 47f8a19437d734c8fd044d974b7a5cee *man/Assay-class.Rd 885d6b2b0bd2c855ec51e9be397e6236 *man/Assays.Rd bcd219b03fab2f26c2cb4ea6fd6fe540 *man/AugmentPlot.Rd 582807be6b908fb218a88bfb36cfd156 *man/AverageExpression.Rd 8b7985bbb62f100004e067575d330590 *man/BarcodeInflectionsPlot.Rd 9ddfb9f91652312a8f352aa38167d17d *man/BuildClusterTree.Rd cbaabf4db486c722cf62132d1633396a *man/CalculateBarcodeInflections.Rd cc0a314413bb8c6a15cc1f105d702923 *man/CaseMatch.Rd 0e67c3a094d660cf6c872063ae38e13c *man/CellCycleScoring.Rd 1eb989bd847de5e41bbad5d898fcff7b *man/CellScatter.Rd 4cc11b4ce242d00e40b0544ecbda0aa0 *man/CellSelector.Rd 9b3a02c103b56beeb48d367a10becaa6 *man/Cells.Rd 2986665e7f6d680c668dc48a8d778dd7 *man/CellsByIdentities.Rd 568c0c0eac74710662a872699cf20d21 *man/CollapseEmbeddingOutliers.Rd 5dde4374ca65fe8a754428eb353dc9ab *man/CollapseSpeciesExpressionMatrix.Rd 890f3e6d9df648d8bcc23455927079d9 *man/ColorDimSplit.Rd 4adb128be5b76053e7625b9412914dcb *man/CombinePlots.Rd 52697ff5a18af08bf8763ef973d02fde *man/Command.Rd f73197539a63b6b027210d6a03d79e52 *man/CreateAssayObject.Rd 9b52707045e46fbef3ae823fb003fb85 *man/CreateDimReducObject.Rd 853f7aa98c36c2688bfe08e18207eb09 *man/CreateGeneActivityMatrix.Rd 19f1132a2f54c53a8a799dc74e616105 *man/CreateSeuratObject.Rd c55c88bba088dbcf2bbeee727d5c1f16 *man/CustomDistance.Rd bfe7f5a846ae4ce5bac25ada1557d68e *man/CustomPalette.Rd caf9af4f74651e51d65c12e018a1176f *man/DefaultAssay.Rd 916de4b1b05c85f5fb585ec98d0b4cc9 *man/DietSeurat.Rd a7d7d53703c4b5552f7f51f636535cee *man/DimHeatmap.Rd 4a7a7ce59c211fe08164848189d3610c *man/DimPlot.Rd ce6aa828b4d2020bbe9f23879daf10aa *man/DimReduc-class.Rd 1ab2385404a1b607870e286929b99bff *man/DiscretePalette.Rd 174595eb5d0ad1fb7dcb540aa21ec52f *man/DoHeatmap.Rd a92d1382c8308850e76d9d2d72f01a79 *man/DotPlot.Rd 5f5e1235640302c375250ce841dc8cb4 *man/ElbowPlot.Rd 6788585dfeb3a14096b4a1c2d6140f17 *man/Embeddings.Rd f4d281d8d14ec91a09a2552a2b1e769e *man/ExpMean.Rd b66218ad3459c126f94bf7e5cdd1dcf2 *man/ExpSD.Rd 2314f05367c2e3e8edd763385dccb573 *man/ExpVar.Rd b7f493203362765739117beef1f22f90 *man/ExportToCellbrowser.Rd d33cb0db30f138916a15a41fb02bd886 *man/FeaturePlot.Rd eea364e27cd729ca0722e18b225e9b81 *man/FeatureScatter.Rd 9573f0806d8682c7be2dcea5d1b39bf6 *man/FetchData.Rd cab63c46ba2bb2c14e2ab8cb0ebe036c *man/FindAllMarkers.Rd b36881a169f6ea89ab5789be888275de *man/FindClusters.Rd 7b12e641dc59a33a808db4f0b76201d5 *man/FindConservedMarkers.Rd cddfb959b67fc2aa8b8d69856ca251b4 *man/FindIntegrationAnchors.Rd 6b9f4141b7d0edc3f3f974a9e5394c98 *man/FindMarkers.Rd f374d35bd2131e6a7eab3296f0a231b6 *man/FindNeighbors.Rd 911fd7132a7cfbefb48f16508b5c2257 *man/FindTransferAnchors.Rd 0e5bacfcf6c733e5ba3df32ff04415d9 *man/FindVariableFeatures.Rd dc26708b4018df6733c66220cdf0e41f *man/GetAssay.Rd 70b7aa814f22a8a3eef8832b286bb474 *man/GetAssayData.Rd 673090eaa69f8c391a30690a87a274c6 *man/GetIntegrationData.Rd f2cb0be1bc030fdc0bcbee01eafcfa78 *man/GetResidual.Rd 2943436304ef4e4a8f1b2c1f4c383ba4 *man/Graph-class.Rd 26b6b255b31f03d5c37b91158c2945d1 *man/HTODemux.Rd c118a8a752ff8741ea500ebab8d5eab6 *man/HTOHeatmap.Rd 7a996525284ecb623aa73f32b32427a5 *man/HVFInfo.Rd a631c905d165eae36a33fe7d95555d66 *man/HoverLocator.Rd a5471c7564c11248a6f9144be6b2b7e1 *man/Idents.Rd 048e99cdd46a4966ffca4c7ee1ae64b4 *man/IntegrateData.Rd d7217b2882661e341b9155f4e38369d9 *man/IntegrationData-class.Rd 7d479367e6ec0d8051cb9cbeee17fd42 *man/IsGlobal.Rd 2c47fd4e6e7ab1fc653c5013890757f6 *man/JS.Rd 3ad2efc76b1d5677037220972d6493c0 *man/JackStraw.Rd 2459805089fb783abb67d95d3174622f *man/JackStrawData-class.Rd c7e510400ec8c40ee402dc4f43fe3839 *man/JackStrawPlot.Rd 76c92aa91b5a81e7ebfa6815f8f64efe *man/Key.Rd a5053ba207606f45ebfca190c7ed8675 *man/L2CCA.Rd 94768e959f5fdcdf4cf70de7265523d3 *man/L2Dim.Rd 9bf40fa1504b0fe082661afea1533cc9 *man/LabelClusters.Rd e11008045d50382d95ed09257698ead6 *man/LabelPoints.Rd 99e48d2980f3fdbd2c02c544806d114d *man/Loadings.Rd 202ff42982980407596cc3167281fac7 *man/LocalStruct.Rd 475e6793dcf155a1e81424ed44b23b46 *man/LogNormalize.Rd 42784618c5dddb71b78eb34c0980948f *man/LogSeuratCommand.Rd 1c79d665744ca5d57b72f12a0de1a778 *man/LogVMR.Rd e1677e298bed791e795c26815225f3f0 *man/MULTIseqDemux.Rd 55848b2d9fa371bbd29e54b31f6a19de *man/MetaFeature.Rd 16c09b639e717a9ec3f38a78bbebbf4b *man/MinMax.Rd 52eb69a6ce40dcf050a36cec259490c1 *man/Misc.Rd 4d115e0c7bbc41494bd62e1cd45ffb11 *man/MixingMetric.Rd 568bcb0229649fc1ba55f88cc3c27a4a *man/NormalizeData.Rd f20b3c4a3e776677044de148433b70a5 *man/OldWhichCells.Rd aafc07286776108288db03086ed6d8b2 *man/PCASigGenes.Rd d2b1db2c16e576645692b18598fc94d8 *man/PercentageFeatureSet.Rd 018009eac9203e049ec32a371df4619d *man/PlotClusterTree.Rd ca453b02026a147db18ff4b0cef74683 *man/PolyDimPlot.Rd 8b79d7306c788d53acd8594de6affd8d *man/PolyFeaturePlot.Rd f3f5a596a9024e91c3d045940e1692f2 *man/PrepSCTIntegration.Rd f08e6f21f3edcae5d0e7577d366dce31 *man/Project.Rd ec342b87442dd0091e938a82634b219c *man/ProjectDim.Rd faea67b4091ab9d7e29edf31f8a28c0a *man/Read10X.Rd dd62120fc7b6ed0657193ccdf741f147 *man/Read10X_h5.Rd 8c0b92e67653970f1d3ee91ca1455f54 *man/ReadAlevin.Rd 9efd87c22140d18b3ff13c2eb0b05830 *man/ReadAlevinCsv.Rd 1bc84bd4b729e5f237bf2c659a03b7b8 *man/Reductions.Rd 7328137bddacf80776da772375555b29 *man/RegroupIdents.Rd 3179a6fa07439b1ed59cdd7692d7ba46 *man/RelativeCounts.Rd 62b801ae21d20a029e68d0b17dc3ffe7 *man/RenameAssays.Rd a4fbb0c5d32d99a0852afc9736ce77cd *man/RenameCells.Rd 2ba4ef0bf0a1218bbcb97d471762d962 *man/RidgePlot.Rd 177d95a6cf06194628ce2b6622c3fa33 *man/RowMergeSparseMatrices.Rd a68059a10c7ed3abd8c05589c8e2d84e *man/RunALRA.Rd 2ec6fa97cbdcfbddf74b341dc0d58368 *man/RunCCA.Rd 26c0b266b2b91c0be0c903585a0ee843 *man/RunICA.Rd 6fbdd2efa4f8268948444aa44982f6f7 *man/RunLSI.Rd 582454931f58f91bc1d40696f1bed627 *man/RunPCA.Rd d9f97953f9c4ad9489cd1c3702b17e25 *man/RunTSNE.Rd b4da98b66b0d8862708f1e3dea4dfa27 *man/RunUMAP.Rd fb2c482e7feb5d44e0255be902ea5392 *man/SCTransform.Rd e8524849f00d972a310ab1f8ce3fcb6c *man/SampleUMI.Rd d59f1cd5986cab559c440e252726e61a *man/ScaleData.Rd f0c5dd474096e2077c2d1825c4072419 *man/ScoreJackStraw.Rd eeaa56c25785ecaa68e895cd1740df8d *man/SelectIntegrationFeatures.Rd b447d0d370cd4bd92e42bbaa271cab5b *man/SetAssayData.Rd d555269e6aef45cbf48709c6fd2e431b *man/SetIntegrationData.Rd 8fb347bf062bc1615f82ca213558b503 *man/Seurat-class.Rd c0cdf581949674c79201c53cc89e5242 *man/Seurat-package.Rd 7b39e8320331d16264fe1bf6765af306 *man/SeuratCommand-class.Rd a949661339a807844119e481a719c7cd *man/SeuratTheme.Rd 914d89b7627f52c4aad0991c9d1d5252 *man/SplitObject.Rd 7bf9437472782d899c99195989748805 *man/Stdev.Rd dae24f17568ca7be5ff8df985b706a9c *man/StopCellbrowser.Rd 1a4b11721877facfdc0d41a1f5dae06c *man/SubsetByBarcodeInflections.Rd 53cfd2448891087730e7ed2765fb58cb *man/SubsetData.Rd 548f9a0987399b28e85298da01f33d38 *man/TF.IDF.Rd 01f7b357e051ee2fce044a9090a69c62 *man/Tool.Rd 8554cf6ad7ffd58b19037bd93ef2ceaf *man/TopCells.Rd 1c11756718b1f36f1667af181abf1290 *man/TopFeatures.Rd 0f56b3161c7b89396923b4ff09603730 *man/TransferData.Rd a43dcc594a38b67de54d258e3d4ff6f8 *man/UpdateSeuratObject.Rd 341cf1a419f8d5a81b95b3c9feeb9549 *man/UpdateSymbolList.Rd b7e37f42978a61e3d2fe8dc615c67f69 *man/VariableFeaturePlot.Rd 88421e75c4325f9b759e87e537ec4f7a *man/VariableFeatures.Rd 36c44894bd245e2cd09fab2e65ca5595 *man/VizDimLoadings.Rd ec0ec245016f04dbffe970d699967e20 *man/VlnPlot.Rd 1191ee7fc0f91e2e8e706d4ddcbbd2bc *man/WhichCells.Rd 7b2abc81e5660c80efd7c22b75473f05 *man/as.CellDataSet.Rd df49313d5508aabfa7c422761141c284 *man/as.Graph.Rd a4f000b130d0a5df7b0daa8c4465a2e1 *man/as.Seurat.Rd 36c56723b990c1f022e5f013a1211608 *man/as.SingleCellExperiment.Rd 6808573b01358f4d51403b1cc4f3da68 *man/as.list.SeuratCommand.Rd b47896f4ed59d95fbd65e3abdaa607c2 *man/as.loom.Rd e23ac8d06541c7f211f244e494190988 *man/as.sparse.Rd e1b3223dadeeec76d59bc921d4fb56df *man/cc.genes.Rd 2906fb1cc0ce615eed51ed5f2c6ad867 *man/cc.genes.updated.2019.Rd 55db69b801875552ab968ee39b5d53d7 *man/h5ad.Rd 0a143b61245ab3456eab1a8eb2282a19 *man/merge.Seurat.Rd 235fab384ae98a859fd4c480206d7560 *man/oldseurat-class.Rd d3f4559eb99fca51f0191291d830670a *man/pbmc_small.Rd a29fa9364bbb23437981fe6dd024454e *man/print.DimReduc.Rd b30c38b11482b85662b2de0fee491814 *man/subset.Seurat.Rd e3d3cb360fbfdb3c6974e14eb5f09870 *src/Makevars f03d010111845b0e4b4cb1528f61d767 *src/ModularityOptimizer.cpp fa50cfd47c172ecdbb147c0958a068a4 *src/ModularityOptimizer.h 6b14b655eade640931673c1cc1357a6c *src/RModularityOptimizer.cpp 91663f44f8381d76fc119e6a8c5d842b *src/RcppExports.cpp 55a7c5f0d560a759aadbc621952d2f60 *src/data_manipulation.cpp 33c323c457423699649a725513449e14 *src/data_manipulation.h efdafe6d860a47a3c5ed9642846eb009 *src/integration.cpp d03bd7b8e78939ba29e8f31697e3fc48 *src/integration.h fa46a78e09a6479196ef7a4bcc0ee0b9 *src/snn.cpp 694a8ab034ccab2c5f7c35bf47b3469e *src/snn.h f61be39a5d39017eefc485d4c02709b5 *tests/testdata/barcodes.tsv d2554fb8e4d5af543605d0a729e36109 *tests/testdata/cr3.0/barcodes.tsv.gz 70e1ed4c347e2563a90fd2144f375a26 *tests/testdata/cr3.0/features.tsv.gz 75dc5f8ba97f4c3bc30ceb7926c5759b *tests/testdata/cr3.0/matrix.mtx.gz 0e7e429d3ff304f912a98271e0efa579 *tests/testdata/genes.tsv dabdfd9c527765a2184403c659974bf2 *tests/testdata/matrix.mtx 646ac9cb85813dbe838d804f78f717a4 *tests/testdata/nbt_small.Rdata 0367da25405ea209b4ff01a3a07b0a22 *tests/testthat.R 396e2ef0c410f9c4ca015927759bf92c *tests/testthat/test_data_manipulation.R d71cef750531b6281360e3dfe065ba4c *tests/testthat/test_differential_expression.R 04f48cb6bed63c9e02c1179e0e2a30a2 *tests/testthat/test_dimensional_reduction.R f1614a0931b51b09bd8703b7a4acde55 *tests/testthat/test_load_10X.R 26d216b88a600a9559b5e965b15c1d55 *tests/testthat/test_modularity_optimizer.R dd187965ead7eac41aa951662203e57b *tests/testthat/test_objects.R e4a7218c10b10d456ee3edb2c2bfe057 *tests/testthat/test_preprocessing.R 4824fff7b4cf64198a16ec86b55dc309 *tests/testthat/test_utilities.R 3fabe6f5750d72ef66a527dbcc323992 *tests/testthat/test_visualization.R Seurat/inst/0000755000176200001440000000000013527073365012505 5ustar liggesusersSeurat/inst/extdata/0000755000176200001440000000000013527073365014137 5ustar liggesusersSeurat/inst/extdata/pbmc_raw.txt0000644000176200001440000011626713527073365016507 0ustar liggesusersATGCCAGAACGACT CATGGCCTGTGCAT GAACCTGATGAACC TGACTGGATTCTCA AGTCAGACTGCACA TCTGATACACGTGT TGGTATCTAAACAG GCAGCTCTGTTTCT GATATAACACGCAT AATGTTGACAGTCA AGGTCATGAGTGTC AGAGATGATCTCGC GGGTAACTCTAGTG CATGAGACACGGGA TACGCCACTCCGAA CTAAACCTGTGCAT GTAAGCACTCATTC TTGGTACTGAATCC CATCATACGGAGCA TACATCACGCTAAC TTACCATGAATCGC ATAGGAGAAACAGA GCGCACGACTTTAC ACTCGCACGAAAGT ATTACCTGCCTTAT CCCAACTGCAATCG AAATTCGAATCACG CCATCCGATTCGCC TCCACTCTGAGCTT CATCAGGATGCACA CTAAACCTCTGACA GATAGAGAAGGGTG CTAACGGAACCGAT AGATATACCCGTAA TACTCTGAATCGAC GCGCATCTTGCTCC GTTGACGATATCGG ACAGGTACTGGTGT GGCATATGCTTATC CATTACACCAACTG TAGGGACTGAACTC GCTCCATGAGAAGT TACAATGATGCTAG CTTCATGACCGAAT CTGCCAACAGGAGC TTGCATTGAGCTAC AAGCAAGAGCTTAG CGGCACGAACTCAG GGTGGAGATTACTC GGCCGATGTACTCT CGTAGCCTGTATGC TGAGCTGAATGCTG CCTATAACGAGACG ATAAGTTGGTACGT AAGCGACTTTGACG ACCAGTGAATACCG ATTGCACTTGCTTT CTAGGTGATGGTTG GCACTAGACCTTTA CATGCGCTAGTCAC TTGAGGACTACGCA ATACCACTCTAAGC CATATAGACTAAGC TTTAGCTGTACTCT GACATTCTCCACCT ACGTGATGCCATGA ATTGTAGATTCCCG GATAGAGATCACGA AATGCGTGGACGGA GCGTAAACACGGTT ATTCAGCTCATTGG GGCATATGGGGAGT ATCATCTGACACCA GTCATACTTCGCCT TTACGTACGTTCAG GAGTTGTGGTAGCT GACGCTCTCTCTCG AGTCTTACTTCGGA GGAACACTTCAGAC CTTGATTGATCTTC MS4A1 0 0 0 0 0 0 0 0 0 0 2 2 4 4 2 3 3 4 2 3 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 CD79B 1 0 0 0 0 0 0 0 0 1 2 4 3 3 2 3 1 2 2 5 0 0 0 0 0 0 0 0 0 1 1 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 1 2 2 0 0 3 0 0 0 0 4 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 CD79A 0 0 0 0 0 0 0 0 0 0 0 5 2 2 5 8 1 5 5 12 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 8 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 HLA-DRA 0 1 0 0 1 1 0 1 0 0 14 28 18 7 15 28 7 26 10 16 7 22 0 10 6 0 4 3 7 13 0 1 0 0 1 0 1 1 0 0 0 0 0 0 0 1 1 1 0 0 10 10 4 1 6 28 10 13 5 8 108 93 41 42 138 77 76 15 19 104 1 0 0 0 2 1 1 0 2 7 TCL1A 0 0 0 0 0 0 0 0 0 0 3 0 2 4 0 0 3 3 3 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 HLA-DQB1 1 0 0 0 0 0 0 0 0 0 1 6 2 2 2 8 2 2 1 2 0 3 0 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 2 0 0 1 1 0 21 21 3 5 11 11 10 1 2 11 0 0 0 0 0 0 0 0 0 1 HVCN1 0 0 0 0 0 0 0 0 0 0 3 1 0 0 2 0 2 1 1 2 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 HLA-DMB 0 0 0 0 0 0 0 0 0 0 0 4 1 1 2 2 1 2 0 1 0 1 0 1 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 1 0 1 3 2 1 4 5 2 1 1 1 5 0 0 0 0 0 0 0 0 0 0 LTB 3 7 11 13 3 4 6 4 2 21 2 9 2 4 4 0 3 6 5 7 1 0 0 1 1 0 0 0 0 1 1 0 0 1 0 0 0 0 0 0 0 1 1 1 7 1 0 1 5 3 1 2 0 0 1 1 1 1 2 1 0 1 0 5 0 0 0 0 1 4 0 0 1 0 0 0 0 0 0 0 LINC00926 0 0 0 0 0 0 0 0 0 0 0 2 0 1 1 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 FCER2 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 1 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 SP100 1 0 1 1 0 0 0 0 0 1 0 3 2 0 1 2 2 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 1 0 0 3 1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 NCF1 0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 1 2 2 0 0 0 1 0 1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 PPP3CC 0 0 0 0 0 1 0 0 0 0 0 1 0 1 0 3 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 EAF2 0 0 0 0 0 0 0 0 0 0 3 0 1 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 1 0 0 0 0 0 1 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 PPAPDC1B 0 0 0 0 0 0 0 0 0 0 0 3 0 1 0 0 0 1 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 CD19 0 0 0 0 0 0 0 0 0 0 0 1 0 2 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 KIAA0125 0 0 0 0 0 0 0 0 0 0 0 1 0 0 1 0 0 1 0 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 CYB561A3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 2 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 CD180 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 RP11-693J15.5 0 0 0 0 0 0 0 0 0 0 1 0 1 1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 FAM96A 0 1 0 0 0 0 0 0 0 0 1 0 0 0 2 0 0 2 1 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 2 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 CXCR4 1 1 0 6 0 2 4 1 0 4 2 0 4 1 0 0 4 2 6 2 3 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 4 0 7 1 3 0 6 1 0 1 0 1 0 1 0 1 0 0 0 0 1 2 12 3 1 3 0 1 2 0 0 2 0 0 0 0 0 0 0 0 0 0 STX10 0 0 1 0 0 1 0 1 0 0 2 0 0 0 2 0 0 0 1 1 0 0 0 1 0 0 0 1 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 SNHG7 0 2 0 0 0 0 0 0 0 1 0 1 1 0 2 3 0 1 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 2 1 1 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 NT5C 0 0 0 0 0 0 0 0 0 0 2 2 1 0 0 0 1 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 0 1 0 0 0 0 0 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 1 1 0 0 0 1 0 0 0 0 0 0 0 0 0 0 1 BANK1 0 1 0 0 0 0 0 0 0 0 0 4 0 0 1 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 0 IGLL5 0 0 0 0 0 0 0 0 0 0 1 0 15 0 0 0 0 23 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 CD200 0 0 0 0 0 0 0 0 0 0 1 0 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 FCRLA 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 1 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 CD3D 4 4 4 5 4 4 3 2 2 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 7 0 0 0 0 1 0 1 0 0 2 3 0 3 15 1 3 6 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 NOSIP 0 3 2 2 3 1 1 3 2 1 0 0 0 0 0 2 0 0 0 0 0 2 0 0 1 0 0 0 0 0 1 0 1 1 0 0 0 2 0 0 1 0 0 0 0 0 1 0 0 1 0 2 0 0 0 1 1 0 0 0 1 1 0 0 0 1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 SAFB2 0 1 0 1 0 1 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 CD2 1 0 2 2 0 1 0 1 2 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 2 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 IL7R 5 2 1 2 2 0 1 12 0 9 0 0 0 0 1 0 0 0 1 0 1 0 0 0 0 1 0 0 0 1 2 0 0 0 0 0 0 0 0 0 0 1 3 1 1 1 0 2 0 2 0 0 0 0 0 0 0 0 0 0 1 1 1 0 1 0 0 1 0 0 0 0 0 0 0 1 0 0 0 0 PIK3IP1 0 0 1 0 0 2 3 2 3 0 0 0 1 0 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 MPHOSPH6 1 1 0 0 0 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 KHDRBS1 0 1 1 1 36 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 1 0 1 0 1 0 0 0 1 0 1 0 0 2 0 0 0 0 0 0 0 0 0 0 MAL 1 1 0 1 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 CCR7 0 5 0 0 2 0 1 1 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 THYN1 0 2 1 1 0 2 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 TAF7 0 2 0 2 1 2 0 2 3 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 2 3 0 0 1 0 0 1 1 1 1 0 1 0 0 0 0 0 0 0 0 0 0 0 1 LDHB 3 2 1 6 5 3 4 0 1 6 0 1 0 0 0 0 2 0 1 0 1 2 0 2 1 0 1 0 0 0 0 0 0 2 2 0 1 0 0 0 2 1 4 0 4 4 0 0 0 2 0 0 1 0 0 2 0 1 0 1 2 0 0 5 2 2 0 1 2 0 1 0 0 0 0 1 0 0 0 1 TMEM123 3 3 0 4 2 1 1 2 1 1 0 1 1 0 0 0 1 3 1 1 0 0 0 0 3 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 2 2 0 1 0 0 0 1 0 0 1 1 0 1 1 0 0 0 0 1 0 0 0 2 3 1 0 0 0 0 0 0 0 0 0 0 0 1 0 1 CCDC104 0 0 0 2 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 EPC1 1 0 1 0 0 1 0 1 1 1 0 0 0 0 1 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 EIF4A2 3 1 2 5 2 4 3 2 3 0 0 2 1 1 5 0 0 1 0 0 0 0 0 0 1 0 1 1 0 1 2 2 0 2 0 0 0 1 3 1 1 0 0 1 2 0 2 3 0 1 0 2 0 0 2 0 1 0 2 1 4 0 0 4 2 4 1 0 0 1 0 0 0 0 0 0 0 0 0 0 CD3E 0 2 1 4 3 1 3 4 2 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 0 1 0 1 0 2 0 1 2 0 1 5 2 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 TMUB1 1 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 BLOC1S4 1 0 2 0 2 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ACSM3 1 2 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 TMEM204 1 0 0 0 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 SRSF7 2 0 1 1 54 2 1 1 1 3 1 2 0 1 0 0 0 0 0 0 0 2 0 0 1 0 0 0 0 3 1 0 1 15 0 0 0 0 0 1 2 1 3 1 0 1 1 1 0 1 0 1 0 0 0 1 0 3 1 0 0 2 1 1 3 0 1 5 13 2 0 0 0 0 0 0 0 0 0 0 ACAP1 0 0 1 2 0 1 2 2 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 1 0 1 0 0 1 0 0 0 0 0 0 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 TNFAIP8 1 3 2 3 2 0 0 0 1 0 0 0 0 0 1 1 0 0 1 1 0 0 0 0 1 0 0 1 0 0 0 0 0 1 0 0 1 0 0 0 0 0 1 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 1 0 1 1 0 4 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 CD7 2 2 2 3 2 1 0 0 3 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 0 1 1 1 3 4 2 1 1 2 1 4 0 2 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 TAGAP 1 1 1 1 0 0 0 1 2 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 DNAJB1 2 0 0 2 0 0 2 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 2 0 0 0 0 1 0 0 0 0 0 0 0 1 1 1 1 0 0 0 1 0 0 1 0 2 0 2 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 ASNSD1 1 0 0 1 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 S1PR4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 1 0 0 0 0 0 0 1 0 0 0 1 0 1 0 0 0 0 0 1 1 1 0 0 1 1 1 0 0 1 0 39 0 0 0 0 0 0 0 1 0 0 2 3 0 0 2 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 CTSW 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 1 3 2 3 2 4 8 6 1 11 1 4 1 2 1 2 2 1 5 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 GZMK 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 2 1 2 0 0 2 0 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 NKG7 0 0 0 0 1 0 0 0 0 0 0 0 0 2 0 0 0 1 0 0 2 1 0 0 0 0 1 0 0 1 35 14 12 30 20 27 28 10 25 27 31 22 7 2 4 14 16 4 29 8 5 3 0 0 0 0 5 0 0 0 0 1 0 0 1 3 0 1 0 1 0 0 0 0 0 0 0 0 0 0 IL32 1 0 9 8 1 0 3 3 0 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 5 4 0 0 0 0 7 8 5 5 0 7 1 6 7 6 1 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 DNAJC2 0 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 1 1 1 1 0 0 0 0 0 0 1 0 0 1 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 LYAR 0 1 1 1 3 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 1 1 0 1 1 2 47 0 1 1 1 1 0 2 0 0 0 0 2 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 CST7 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 4 4 2 7 2 4 3 3 2 5 2 3 1 1 0 2 8 4 5 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 1 0 0 0 0 0 0 0 0 0 0 LCK 0 3 2 0 1 1 2 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 2 1 1 1 2 1 0 1 1 2 0 1 2 1 1 1 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 CCL5 0 0 0 2 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1 0 2 5 14 0 29 1 7 5 25 0 14 27 3 13 17 7 3 16 12 3 1 0 0 0 0 0 0 0 0 0 1 0 0 1 1 0 0 0 0 8 5 4 10 11 30 8 5 9 2 HNRNPH1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 1 0 1 0 0 1 0 1 1 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 SSR2 0 2 2 4 1 1 0 0 0 6 0 1 0 0 1 1 0 1 0 0 0 0 0 0 3 0 1 0 1 0 0 2 0 0 1 0 1 0 1 2 1 2 1 1 1 2 4 1 2 4 2 1 0 0 2 0 3 1 3 1 0 2 3 0 1 3 2 0 4 2 0 0 0 0 0 0 0 0 0 0 DLGAP1-AS1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 1 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 GIMAP1 0 2 0 0 0 0 0 1 0 2 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 0 1 1 0 2 0 1 1 1 1 0 2 1 0 0 1 1 17 0 0 0 1 0 1 0 1 0 2 0 1 0 0 1 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 MMADHC 0 0 0 0 1 0 0 0 0 0 0 2 0 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 1 1 2 0 1 1 1 0 1 1 0 1 0 0 0 0 0 0 0 0 0 1 0 0 1 2 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ZNF76 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 CD8A 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 3 0 1 3 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 PTPN22 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 1 1 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 GYPC 1 2 2 0 0 1 0 0 2 1 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 1 0 1 1 0 1 1 0 0 1 0 1 0 1 3 0 1 0 0 7 0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 HNRNPF 0 0 0 1 0 1 0 1 2 0 0 2 1 0 1 0 0 1 0 1 1 0 0 0 1 0 0 0 0 1 0 0 0 0 0 1 1 1 2 1 1 2 1 1 1 0 1 2 0 2 0 1 0 0 0 0 1 1 0 1 0 0 1 1 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 RPL7L1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 1 0 1 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 KLRG1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 3 0 2 0 1 0 0 0 0 1 4 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 CRBN 1 0 0 0 0 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 2 1 1 0 1 1 1 1 0 1 0 0 0 0 0 0 0 0 0 2 0 1 0 1 0 1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 SATB1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 13 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 SIT1 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 PMPCB 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 1 0 0 0 2 1 0 1 0 0 0 1 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 NRBP1 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 2 0 0 0 0 1 0 1 1 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 TCF7 0 0 1 0 1 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 1 1 2 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 HNRNPA3 0 0 0 1 2 0 0 0 0 0 1 1 0 0 0 0 0 0 1 0 2 0 0 0 0 0 0 0 0 0 0 0 0 2 2 1 1 1 1 0 2 1 2 0 2 1 0 1 2 0 0 1 0 0 0 2 1 1 0 1 1 0 0 0 1 4 0 1 0 2 0 0 0 0 0 0 0 0 0 0 S100A8 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 18 5 25 5 25 6 24 40 16 11 1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 2 0 4 3 0 1 1 2 0 0 2 0 2 1 9 1 23 4 0 0 1 0 0 0 1 0 0 0 2 S100A9 0 1 1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 30 12 51 22 85 3 54 55 35 17 0 0 0 1 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 20 6 1 0 10 4 8 6 0 0 0 0 1 10 0 41 11 32 17 0 3 0 0 0 0 0 0 0 0 7 LYZ 1 1 1 0 0 1 0 0 1 0 1 4 0 1 0 0 0 1 1 0 50 29 25 49 98 11 59 28 34 16 0 0 1 0 2 0 0 1 0 0 0 1 1 0 0 0 0 1 0 0 41 4 3 3 14 17 7 6 9 6 76 20 24 79 53 53 87 76 42 114 3 1 1 0 1 0 0 0 0 22 CD14 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 2 2 4 1 0 1 1 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 2 2 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 FCN1 1 1 0 0 0 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 10 6 5 9 7 1 1 2 8 7 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 2 13 7 5 1 4 3 1 1 2 0 0 0 3 1 2 4 6 1 0 0 0 0 0 0 0 0 0 0 0 0 TYROBP 0 0 0 2 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 14 13 3 10 16 4 13 12 19 12 3 0 4 3 6 7 3 4 5 15 2 0 1 1 0 0 0 0 0 0 11 21 2 5 21 13 16 9 16 17 2 8 6 9 11 14 10 10 6 7 0 0 0 0 0 0 0 0 0 14 ASGR1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 2 0 0 1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 1 1 0 0 0 0 0 0 0 0 0 0 NFKBIA 0 0 1 1 0 0 0 0 0 4 0 1 1 0 1 0 0 0 1 1 3 13 5 0 11 0 2 3 5 10 0 1 0 1 0 1 0 0 0 0 5 1 1 0 0 0 1 0 1 0 2 2 2 0 2 1 1 1 2 9 2 2 0 1 1 6 1 3 2 4 0 0 0 0 0 0 0 0 0 6 TYMP 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 7 1 6 5 1 6 4 5 1 0 0 0 2 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 6 5 1 1 6 4 3 2 4 5 1 3 2 5 14 11 3 4 8 4 0 0 0 0 0 0 0 0 0 2 CTSS 1 1 0 0 1 2 0 1 1 1 1 0 1 0 0 0 1 2 0 2 15 9 1 5 7 3 4 4 11 7 0 0 1 0 0 0 1 0 0 4 1 1 0 0 1 0 0 0 0 0 8 8 7 3 10 15 18 19 4 17 5 3 1 5 0 3 6 2 0 3 1 0 0 0 0 0 0 0 0 3 TSPO 0 0 0 0 1 1 1 0 0 1 0 1 0 0 0 1 1 0 0 0 1 2 6 0 36 1 5 0 3 5 1 0 0 0 0 0 1 1 1 0 1 1 0 0 2 0 1 0 0 0 2 4 0 1 2 3 6 4 2 5 1 0 0 4 2 5 10 6 4 2 0 0 0 0 0 2 0 0 0 3 RBP7 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 1 0 2 1 4 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 CTSB 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 4 1 1 7 1 1 2 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 1 0 4 0 1 0 1 0 3 0 0 2 1 1 0 2 0 2 2 1 0 0 0 0 0 0 1 0 0 0 0 1 LGALS1 1 0 1 2 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 14 10 8 11 4 6 7 22 37 3 4 9 6 1 3 14 2 1 4 1 3 0 0 0 0 1 0 1 0 5 12 4 2 16 10 6 2 12 16 8 13 21 9 20 10 23 5 28 13 0 0 0 0 1 0 0 0 0 10 FPR1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 1 0 2 1 0 0 0 0 0 2 1 0 0 0 0 0 0 0 0 0 0 0 0 0 VSTM1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 1 0 1 2 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 BLVRA 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 1 3 1 2 0 1 0 1 1 3 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 2 2 5 1 2 0 1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 MPEG1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1 1 0 1 1 1 0 0 2 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 1 0 2 1 0 1 0 0 0 0 0 0 0 1 0 0 0 0 BID 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 27 0 1 1 1 0 0 1 1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 3 6 1 2 2 4 2 2 2 2 0 0 3 1 0 2 0 0 0 0 0 0 0 0 0 0 SMCO4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 2 1 0 1 0 2 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 1 2 1 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 CFD 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 4 2 1 1 0 0 2 15 2 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 4 5 2 0 0 5 2 3 2 3 0 0 0 0 1 2 0 0 0 0 0 0 0 0 0 0 0 0 0 3 LINC00936 0 0 0 1 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 5 1 0 0 1 1 0 0 2 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 1 3 1 2 1 1 0 3 1 1 1 1 1 0 0 0 0 0 0 0 0 0 1 LGALS2 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 12 6 2 1 6 0 0 0 5 2 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 3 0 0 0 0 0 0 0 0 0 3 10 1 2 3 4 4 1 3 6 0 0 0 0 0 0 0 0 0 3 MS4A6A 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 2 2 1 3 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 4 1 0 7 7 0 2 1 2 0 0 0 0 0 0 0 0 0 0 1 FCGRT 0 1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 2 0 0 1 14 1 2 0 1 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 2 0 1 3 1 1 0 1 1 3 1 0 2 2 3 3 1 4 3 0 0 0 0 0 0 0 0 0 2 LGALS3 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 0 4 4 1 3 0 2 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 1 0 0 2 2 0 0 4 2 0 2 1 0 0 5 1 0 6 2 7 2 2 0 0 0 0 0 0 1 0 0 0 1 NUP214 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 3 2 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 1 2 0 0 0 0 1 1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 1 SCO2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 2 0 5 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 1 1 0 0 1 2 0 0 2 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 IL17RA 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 IFI6 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 5 3 0 0 3 0 1 5 0 4 0 0 0 0 1 0 1 1 2 0 0 0 0 0 0 0 0 0 1 0 0 2 0 1 1 3 1 3 0 2 0 4 0 2 6 2 5 1 0 0 0 0 0 0 0 0 0 0 0 4 HLA-DPA1 0 0 0 0 0 0 0 0 0 0 3 8 2 2 5 9 0 5 1 5 0 13 2 1 0 1 0 0 7 6 0 1 0 2 0 0 1 0 0 0 0 0 0 0 1 3 0 0 1 0 12 4 2 1 5 5 7 14 5 11 75 52 11 19 54 23 45 10 23 37 0 0 0 0 0 0 0 0 0 5 FCER1A 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16 1 2 4 8 5 8 4 7 0 0 0 0 0 0 0 0 0 0 0 CLEC10A 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 5 2 4 2 3 6 4 2 1 0 0 0 0 0 0 0 0 0 1 HLA-DMA 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 4 1 1 0 1 0 4 1 1 0 0 0 0 1 2 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 4 0 0 0 0 6 6 5 4 6 5 6 5 3 5 0 0 0 0 0 0 0 0 0 1 RGS1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 3 1 3 0 1 3 0 1 2 0 0 0 0 0 0 0 0 0 0 HLA-DPB1 0 0 0 0 0 0 0 0 0 0 4 10 4 4 8 23 7 0 4 6 0 18 1 2 0 3 0 1 7 7 2 4 0 0 0 0 0 0 0 0 0 4 0 0 1 2 0 0 0 0 8 3 5 2 3 7 6 5 9 4 102 78 23 25 69 24 43 8 10 50 1 0 0 0 0 0 0 0 0 5 HLA-DQA1 0 0 0 1 0 0 0 0 0 0 0 4 4 1 0 8 1 5 0 1 1 5 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 2 0 0 0 1 1 2 0 0 25 39 5 2 16 6 11 3 4 9 0 0 0 0 0 0 0 0 0 0 RNF130 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 2 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 1 1 2 2 2 2 0 1 1 1 6 3 5 1 0 0 0 0 0 0 0 0 0 0 HLA-DRB5 0 0 0 0 0 0 1 0 0 0 1 4 3 0 4 8 1 2 2 4 0 8 1 1 0 0 0 0 4 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 4 5 0 0 3 3 6 3 6 2 11 26 5 2 31 21 21 2 3 10 0 0 0 0 0 0 0 0 0 1 HLA-DRB1 0 0 0 0 0 0 0 0 0 0 2 10 6 1 5 16 5 11 5 8 2 12 1 5 1 0 3 0 5 3 0 2 0 1 0 0 0 0 1 0 0 0 0 0 0 3 0 0 0 0 8 4 0 0 7 7 13 6 6 4 50 53 10 9 68 36 49 3 9 26 0 0 0 0 0 0 0 0 0 4 CST3 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 1 13 28 15 11 13 7 37 5 20 18 1 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 1 0 0 16 32 7 9 11 17 33 10 15 25 61 31 25 14 58 112 37 18 29 125 5 1 0 0 5 1 3 0 0 16 IL1B 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 0 0 0 0 1 0 0 2 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 8 0 3 1 2 3 6 1 0 0 0 1 0 0 0 0 0 0 5 POP7 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 2 1 0 0 0 1 1 33 0 0 0 0 1 3 0 0 0 0 0 0 0 0 0 0 HLA-DQA2 0 0 0 0 0 0 0 0 0 0 0 2 0 0 1 0 1 1 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 2 0 0 7 9 1 0 6 1 4 1 0 5 0 0 0 0 0 0 0 0 0 0 CD1C 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 5 0 0 3 3 0 0 0 1 0 0 0 0 0 0 0 0 0 0 GSTP1 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 3 0 1 0 0 2 3 1 6 5 1 3 1 4 2 1 2 0 1 2 0 1 2 0 1 2 0 0 0 0 0 0 0 1 0 4 1 2 0 1 5 0 0 1 1 9 4 5 7 2 5 12 7 10 18 0 0 0 0 1 0 0 0 0 4 EIF3G 1 1 1 1 2 0 0 1 0 2 0 1 0 0 0 2 0 0 0 0 0 0 1 0 2 0 0 1 2 1 3 0 1 0 3 0 0 1 0 3 1 1 0 0 0 0 2 1 1 1 3 3 0 1 2 2 0 1 2 0 1 0 1 2 1 0 1 1 3 43 0 0 0 0 0 0 0 0 0 3 VPS28 0 0 0 3 0 0 0 0 1 0 0 0 1 0 2 0 0 0 0 0 0 0 0 1 2 0 1 1 1 0 0 0 1 1 1 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 1 1 0 1 0 0 0 2 3 0 4 3 0 1 0 1 38 0 0 1 0 0 1 0 0 2 0 0 0 2 LY86 0 0 0 0 0 0 0 0 0 0 1 1 0 1 0 0 0 2 1 1 0 0 0 0 2 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 2 0 3 2 3 1 2 0 1 8 1 0 0 0 0 0 0 0 0 0 ZFP36L1 0 0 1 0 1 1 0 0 0 0 0 0 0 0 1 0 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1 1 0 21 0 1 0 0 0 0 0 0 0 0 0 0 0 ZNF330 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 1 32 0 0 0 0 0 0 0 0 0 0 0 ANXA2 0 0 0 0 1 1 0 0 0 1 0 1 1 0 0 1 0 0 0 0 1 3 0 3 1 1 1 0 2 3 1 0 0 4 1 0 4 1 0 1 0 0 1 0 0 0 1 1 0 2 9 3 1 0 4 2 3 2 0 6 5 1 5 1 22 10 9 1 3 3 0 0 0 0 0 0 0 0 0 4 GRN 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 1 1 0 1 0 5 1 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 1 1 2 3 0 1 1 3 6 1 0 2 5 4 8 2 4 5 0 1 0 0 0 0 0 0 0 0 CFP 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 7 1 1 1 0 2 0 2 1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 1 3 0 0 1 1 0 3 2 4 0 2 0 1 39 1 3 5 1 0 0 0 0 0 0 0 0 0 1 HSP90AA1 2 0 1 2 3 2 2 1 0 3 0 0 1 0 0 2 4 0 0 1 0 0 0 0 0 0 0 0 3 3 1 4 5 1 1 0 1 0 0 0 0 0 0 2 0 1 0 1 3 0 3 1 0 0 0 1 0 0 1 1 3 1 0 2 64 2 3 1 1 1 0 0 0 0 0 0 0 0 0 0 FUOM 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 1 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 LST1 0 0 0 3 2 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 3 6 1 4 8 3 5 0 7 13 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 15 17 8 11 18 13 36 17 12 27 12 7 7 4 8 10 4 2 6 6 0 0 0 0 0 0 0 0 0 7 AIF1 2 0 1 0 0 0 2 1 0 0 0 0 0 0 1 0 0 0 0 1 5 7 6 5 4 3 1 2 10 12 1 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 7 12 7 6 32 33 12 19 18 29 6 7 1 3 11 7 9 4 1 4 0 0 0 0 1 0 0 0 0 5 PSAP 0 0 2 0 3 2 0 0 0 0 0 0 0 0 2 0 0 0 0 0 6 5 1 5 3 2 1 1 6 4 0 1 2 0 1 0 1 1 0 0 3 1 0 0 1 0 0 1 2 1 8 8 6 2 9 9 10 8 5 10 1 2 1 6 6 4 4 2 2 7 0 0 1 1 1 0 0 0 0 1 YWHAB 0 0 0 1 1 0 0 1 0 1 0 0 2 0 1 0 0 1 1 0 1 0 0 1 2 0 0 1 2 0 2 0 1 1 0 1 0 1 0 2 0 1 1 0 0 1 2 2 1 1 2 2 1 0 50 1 1 1 3 1 5 0 0 0 2 5 4 0 1 3 0 0 0 0 0 0 0 0 0 1 MYO1G 0 0 2 1 0 1 0 0 0 0 0 1 1 0 1 0 0 0 0 0 0 1 1 0 0 0 0 0 2 0 1 0 1 0 0 0 0 0 1 1 1 1 0 0 1 1 0 0 1 0 0 1 0 0 3 3 1 27 1 1 0 0 0 0 0 0 2 2 1 2 0 0 0 0 0 0 0 0 0 1 SAT1 0 1 0 0 0 1 1 1 1 2 0 1 0 0 2 5 0 0 0 0 4 15 8 5 4 2 8 2 11 18 3 0 0 0 0 0 1 0 1 1 0 1 3 0 0 0 0 0 2 1 21 25 6 10 26 26 16 15 11 22 10 5 5 16 2 3 16 3 4 5 3 4 2 6 3 17 3 6 4 3 RGS2 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 0 0 0 3 0 1 1 1 1 0 1 0 0 0 0 0 0 0 0 1 0 1 0 0 0 1 0 0 0 2 3 16 0 1 11 3 5 4 6 8 1 1 0 0 0 1 1 1 2 0 0 0 0 0 0 0 0 0 0 SERPINA1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 6 4 0 2 0 0 1 0 3 3 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 2 1 1 1 3 4 5 5 3 6 1 1 0 3 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 2 IFITM3 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 5 0 0 0 2 4 1 2 7 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 5 3 4 1 11 9 2 5 7 10 0 12 2 1 3 4 4 0 0 1 0 0 0 0 0 0 0 0 0 1 FCGR3A 0 0 0 0 1 0 0 1 0 0 0 1 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 1 6 2 2 1 0 1 2 1 2 6 2 0 0 0 0 0 1 0 0 0 0 5 1 2 14 4 18 9 5 11 0 0 0 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 LILRA3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 3 0 0 1 1 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 S100A11 2 0 1 2 1 0 0 1 1 0 0 1 0 0 0 0 0 0 0 0 2 10 4 2 2 2 1 6 5 6 6 0 0 0 0 0 1 1 0 0 1 0 0 0 1 1 0 1 0 0 17 13 1 2 9 12 14 8 7 13 5 4 5 3 11 9 9 4 5 2 0 0 0 0 0 0 0 0 0 1 FCER1G 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 6 3 4 6 1 2 4 4 9 8 8 0 3 1 2 5 6 6 1 6 3 0 0 0 0 0 0 0 0 0 12 12 2 4 35 16 24 9 9 30 8 8 3 3 13 8 7 5 8 3 0 0 0 1 0 0 0 1 0 4 TNFRSF1B 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 2 1 0 3 4 1 2 1 1 0 0 0 0 0 1 0 0 0 2 0 0 0 0 0 0 0 0 0 0 IFITM2 3 0 3 3 1 3 3 1 0 3 0 1 2 0 1 0 0 0 2 3 6 4 0 0 1 1 0 1 3 6 8 2 3 5 2 1 5 1 3 2 7 4 2 2 5 1 1 4 1 2 5 10 1 4 17 8 33 8 14 19 4 7 4 3 2 2 0 1 6 4 0 0 0 0 1 1 0 0 0 1 WARS 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 1 0 2 2 1 1 0 3 1 1 2 0 0 0 0 0 2 1 0 1 0 0 0 0 0 0 0 0 0 0 0 IFI30 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 2 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 3 0 1 2 1 6 1 5 6 6 0 3 1 1 3 3 0 1 4 0 0 0 0 0 0 0 0 0 1 MS4A7 0 0 0 1 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 5 1 0 2 4 3 1 0 2 0 0 1 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 C5AR1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 4 2 1 1 3 0 1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 HCK 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 1 0 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 2 0 1 0 3 1 2 3 5 0 1 0 0 1 1 0 0 1 4 0 0 0 0 0 0 0 0 0 1 COTL1 0 0 4 2 1 2 0 1 1 3 0 2 0 0 0 1 0 1 0 0 6 15 2 4 7 3 6 0 4 20 0 1 1 0 0 0 1 0 0 0 1 2 0 0 5 1 0 0 2 0 9 20 9 3 6 9 91 11 18 18 18 2 9 11 12 11 7 5 4 25 1 2 0 3 0 2 3 0 4 7 LGALS9 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 3 0 0 6 0 0 3 0 3 0 0 1 1 0 1 0 1 1 1 0 0 0 0 0 0 0 0 0 0 CD68 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 4 0 0 0 3 0 1 3 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 4 1 0 4 3 0 4 2 8 0 0 0 0 1 1 0 0 0 1 0 0 0 0 1 0 0 1 1 1 RP11-290F20.3 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 2 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 5 0 0 4 0 5 2 1 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 RHOC 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 0 0 1 2 0 0 1 0 1 3 1 1 2 0 0 0 0 0 0 1 1 0 0 1 6 0 1 1 2 7 2 6 3 2 0 1 0 2 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 CARD16 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 1 1 1 1 1 1 0 0 2 0 2 1 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 2 2 0 2 2 1 0 6 3 6 1 0 0 1 2 1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 LRRC25 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 0 1 6 4 1 0 2 0 1 1 0 0 0 1 1 0 2 0 0 0 0 0 0 0 0 0 1 COPS6 0 0 1 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 1 0 0 3 0 1 0 0 0 0 0 0 1 0 0 26 0 0 2 2 1 0 0 1 0 0 0 1 1 1 1 0 1 0 0 0 0 0 0 0 0 0 0 1 ADAR 0 0 0 1 1 0 0 0 0 0 0 1 0 1 0 0 0 0 1 0 0 1 1 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 1 2 25 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 PPBP 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 43 41 36 55 58 54 66 34 30 6 GPX1 0 0 0 1 1 1 0 1 0 1 0 1 1 0 1 0 1 0 0 0 4 5 3 5 12 1 15 2 3 1 0 1 0 0 0 0 2 0 1 0 0 0 0 1 1 0 1 2 0 0 5 3 0 0 1 1 0 1 1 2 6 7 2 6 24 16 28 3 6 3 18 8 12 18 18 28 11 13 16 9 TPM4 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 1 0 1 0 0 0 2 1 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 1 1 0 0 0 1 2 1 0 1 1 4 4 2 2 2 15 2 1 3 2 PF4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 14 11 14 18 23 62 9 14 6 0 SDPR 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 11 3 13 8 8 29 3 6 5 2 NRGN 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 2 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 1 5 3 3 2 7 3 1 1 2 SPARC 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 8 3 2 2 3 9 3 3 4 2 GNG11 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 5 9 10 7 23 12 6 11 1 CLU 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 14 5 8 11 15 6 4 3 5 2 HIST1H2AC 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 5 3 5 5 2 42 2 1 2 1 NCOA4 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 1 0 0 2 1 1 0 0 1 0 0 0 0 0 8 2 0 12 8 7 3 2 6 0 GP9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 3 3 2 3 11 6 5 3 0 FERMT3 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 1 0 0 0 0 0 0 1 0 0 0 1 0 1 0 0 0 0 0 0 1 1 0 0 1 0 0 0 0 2 0 0 0 2 0 0 1 0 0 1 2 5 4 4 1 6 0 4 0 1 ODC1 1 0 0 0 0 1 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 0 0 2 0 1 0 0 0 3 0 1 2 1 14 2 0 4 1 CD9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 4 4 3 4 3 4 20 5 0 RUFY1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 3 3 2 3 2 9 0 0 1 0 TUBB1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 3 5 2 14 32 2 0 8 0 TALDO1 1 2 0 0 2 0 0 0 0 0 0 0 0 0 1 2 0 0 0 0 1 1 2 3 5 1 2 0 3 2 0 0 0 0 0 0 0 0 0 2 1 0 0 0 0 0 0 0 1 0 1 2 0 0 0 2 2 2 1 2 1 0 0 1 3 1 3 1 1 2 2 0 1 2 1 10 37 0 2 3 TREML1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 0 2 7 4 0 1 3 5 2 NGFRAP1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 1 2 0 2 3 1 2 4 0 PGRMC1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 1 0 4 2 6 2 2 0 0 CA2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 3 1 4 1 3 8 0 13 2 0 ITGA2B 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 5 1 4 2 4 1 4 1 0 0 MYL9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 0 3 4 8 1 2 0 0 1 TMEM40 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 1 1 2 1 2 3 0 PARVB 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 5 4 1 4 0 0 1 0 0 0 PTCRA 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 4 0 0 20 2 2 1 0 ACRBP 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 25 0 3 1 1 TSC22D1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 1 0 26 1 0 0 1 VDAC3 0 0 0 1 0 0 1 0 0 1 0 29 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 2 0 0 1 1 0 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 2 1 0 0 0 0 0 0 0 0 0 0 41 0 0 2 1 0 1 1 1 GZMB 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 1 0 0 0 0 0 27 2 1 10 8 5 10 7 4 11 3 0 0 0 0 0 6 0 2 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 GZMA 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 5 3 4 10 8 12 10 3 13 1 8 2 1 0 0 0 3 3 2 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 GNLY 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 35 0 15 3 29 11 22 15 18 18 10 0 0 3 0 0 4 1 3 0 0 0 0 0 0 0 1 0 0 1 0 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 FGFBP2 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 5 3 9 2 6 3 6 8 2 5 4 1 0 0 0 2 9 0 3 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 AKR1C3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7 0 1 1 0 1 5 4 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 CCL4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 5 3 1 0 3 1 1 2 1 1 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 PRF1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 14 1 4 9 7 10 10 2 4 7 6 13 0 0 0 0 6 0 5 3 0 0 0 0 0 0 0 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 GZMH 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 5 7 1 0 3 1 0 2 6 0 0 0 0 0 10 0 9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 XBP1 1 0 1 1 2 0 0 1 0 0 0 1 0 0 1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 1 2 2 4 1 0 2 1 3 1 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 1 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 GZMM 0 1 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 2 1 1 2 3 2 2 6 2 1 0 0 1 0 3 2 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 PTGDR 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 1 0 1 51 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 IGFBP7 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 0 4 0 0 3 0 1 7 4 0 3 1 0 0 0 0 0 0 0 0 0 1 0 0 1 0 0 0 0 1 1 0 0 0 1 3 2 0 0 1 0 0 0 0 0 0 0 0 0 0 0 TTC38 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 1 1 1 0 0 1 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 KLRD1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 0 1 1 0 1 2 2 1 0 1 0 1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ARHGDIA 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 1 1 1 0 1 1 1 1 1 0 1 0 1 25 1 0 0 0 0 0 0 0 0 0 2 0 1 0 0 3 2 1 0 0 1 0 1 1 1 2 4 1 0 0 0 0 0 0 0 1 0 0 0 0 IL2RB 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 2 1 1 1 0 3 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 CLIC3 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 0 4 0 1 2 3 0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 PPP1R18 0 1 0 0 0 1 0 0 0 1 0 0 1 0 1 0 0 0 1 0 0 2 0 0 0 0 0 1 0 0 2 2 1 1 1 1 3 0 3 1 0 1 2 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 1 0 0 0 0 0 0 0 0 0 1 CD247 0 1 1 0 2 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 3 1 1 3 0 2 2 0 1 1 2 1 0 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ALOX5AP 1 0 0 0 1 0 0 1 0 0 1 0 0 0 0 2 1 0 1 0 0 0 0 0 0 0 0 1 0 0 3 0 2 1 1 3 1 2 1 2 0 2 0 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 XCL2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 3 2 0 0 0 0 1 2 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 C12orf75 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 1 0 1 0 0 4 2 1 2 0 1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 0 2 0 0 0 0 0 0 RARRES3 1 0 0 3 0 1 1 0 1 0 0 2 0 0 1 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 7 3 2 0 1 3 3 5 0 1 0 2 1 1 0 2 2 0 1 1 0 0 0 0 2 0 0 0 0 0 0 1 0 0 2 1 1 0 0 0 0 0 1 0 0 1 0 0 0 0 PCMT1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 2 1 0 58 0 0 1 0 2 1 0 0 1 0 0 0 0 1 0 0 0 0 1 0 0 2 0 1 0 0 0 2 0 0 0 4 2 1 0 3 1 0 0 0 0 0 0 0 0 0 0 LAMP1 1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 2 1 3 2 1 2 1 0 1 0 1 0 0 1 2 0 1 0 1 0 0 0 0 0 0 0 3 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 SPON2 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 3 5 1 3 0 0 1 2 0 2 3 0 0 0 0 0 3 1 3 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 S100B 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 10 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 Seurat/inst/CITATION0000644000176200001440000000154113527073365013643 0ustar liggesuserscitHeader("To cite Seurat in publications, please use:") citEntry(entry = "article", author = personList(as.person("Tim Stuart"), as.person("Andrew Butler"), as.person("Paul Hoffman"), as.person("Christoph Hafemeister"), as.person("Efthymia Papalexi"), as.person("William M Mauck III"), as.person("Marlon Stoeckius"), as.person("Peter Smibert"), as.person("Rahul Satija")), title = "Comprehensive integration of single cell data", journal = "bioRxiv", year = "2018", doi = "10.1101/460147", url = "https://www.biorxiv.org/content/10.1101/460147v1", textVersion = "Stuart and Butler et al. Comprehensive integration of single cell data. bioRxiv (2018)." )