├── .Rbuildignore ├── .gitignore ├── .travis.yml ├── DESCRIPTION ├── LICENSE ├── NAMESPACE ├── R ├── data.R ├── psupertime.R └── psupertime_plots.R ├── README.md ├── data ├── acinar_hvg_sce.rda ├── tf_human.rda └── tf_mouse.rda ├── inst └── extdata │ └── psuperlogo.png ├── man ├── dot-calc_clusters_dt.Rd ├── dot-calc_expressed_genes.Rd ├── dot-calc_hvg_genes.Rd ├── dot-check_conf_params.Rd ├── dot-check_params.Rd ├── dot-check_x.Rd ├── dot-check_y.Rd ├── dot-do_topgo_for_cluster.Rd ├── dot-get_test_idx.Rd ├── dot-get_tf_list.Rd ├── dot-glmnetcr_propn.Rd ├── dot-make_best_beta.Rd ├── dot-make_col_vals.Rd ├── dot-make_plot_dt.Rd ├── dot-make_x_data.Rd ├── dot-psummarize.Rd ├── dot-restrict_to_y_labels.Rd ├── dot-select_genes.Rd ├── double_psupertime.Rd ├── plot_double_psupertime.Rd ├── plot_double_psupertime_confusion.Rd ├── plot_double_psupertime_contour.Rd ├── plot_double_psupertime_genes.Rd ├── plot_go_results.Rd ├── plot_heatmap_of_gene_clusters.Rd ├── plot_identified_gene_coefficients.Rd ├── plot_identified_genes_over_psupertime.Rd ├── plot_labels_over_psupertime.Rd ├── plot_new_data_over_psupertime.Rd ├── plot_predictions_against_classes.Rd ├── plot_profiles_of_gene_clusters.Rd ├── plot_specified_genes_over_psupertime.Rd ├── plot_train_results.Rd ├── project_onto_psupertime.Rd ├── psupertime.Rd ├── psupertime_go_analysis.Rd ├── psupertime_go_analysis_old.Rd ├── psupertime_plot_all.Rd ├── tf_human.Rd └── tf_mouse.Rd ├── psupertime.Rproj ├── tests ├── testthat.R └── testthat │ └── test-01_basic_tests.R └── vignettes ├── .gitignore └── psuper_intro.Rmd /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^Meta$ 2 | ^doc$ 3 | ^.*\.Rproj$ 4 | ^\.Rproj\.user$ 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | Meta 2 | doc 3 | inst/doc 4 | .Rproj.user 5 | .Rhistory 6 | .RData 7 | *.sublime-project 8 | *.sublime-workspace 9 | ._* 10 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: r 2 | warnings_are_errors: false 3 | bioc_packages: 4 | - scran 5 | - SummarizedExperiment 6 | - BiocStyle 7 | - SingleCellExperiment 8 | - SummarizedExperiment 9 | - topGO 10 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: psupertime 2 | Title: Psupertime is supervised pseudotime for single cell RNAseq data 3 | Version: 0.2.6 4 | Authors@R: person("Will", "Macnair", email = "willmacnair@gmail.com", role = c("aut", "cre")) 5 | Description: Psupertime uses single cell RNAseq data, where the cells have a known ordering (which may be fuzzy) to identify a small number of genes which place cells in that known order. It can be used for discovery of relevant genes, for identification of subpopulations, and characterization of further unknown or differently labelled data. 6 | Depends: R (>= 3.4.3) 7 | License: GPL-3 8 | Encoding: UTF-8 9 | LazyData: true 10 | Imports: cowplot, 11 | data.table, 12 | fastcluster, 13 | forcats, 14 | ggplot2, 15 | glmnet, 16 | knitr, 17 | Matrix, 18 | RColorBrewer, 19 | SummarizedExperiment, 20 | SingleCellExperiment, 21 | scran, 22 | stringr, 23 | grDevices, 24 | scales, 25 | topGO 26 | Suggests: 27 | BiocStyle, 28 | rmarkdown, 29 | testthat 30 | RoxygenNote: 7.1.1 31 | VignetteBuilder: knitr 32 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | The GNU General Public License is a free, copyleft license for 11 | software and other kinds of works. 12 | 13 | The licenses for most software and other practical works are designed 14 | to take away your freedom to share and change the works. By contrast, 15 | the GNU General Public License is intended to guarantee your freedom to 16 | share and change all versions of a program--to make sure it remains free 17 | software for all its users. We, the Free Software Foundation, use the 18 | GNU General Public License for most of our software; it applies also to 19 | any other work released this way by its authors. You can apply it to 20 | your programs, too. 21 | 22 | When we speak of free software, we are referring to freedom, not 23 | price. Our General Public Licenses are designed to make sure that you 24 | have the freedom to distribute copies of free software (and charge for 25 | them if you wish), that you receive source code or can get it if you 26 | want it, that you can change the software or use pieces of it in new 27 | free programs, and that you know you can do these things. 28 | 29 | To protect your rights, we need to prevent others from denying you 30 | these rights or asking you to surrender the rights. Therefore, you have 31 | certain responsibilities if you distribute copies of the software, or if 32 | you modify it: responsibilities to respect the freedom of others. 33 | 34 | For example, if you distribute copies of such a program, whether 35 | gratis or for a fee, you must pass on to the recipients the same 36 | freedoms that you received. You must make sure that they, too, receive 37 | or can get the source code. And you must show them these terms so they 38 | know their rights. 39 | 40 | Developers that use the GNU GPL protect your rights with two steps: 41 | (1) assert copyright on the software, and (2) offer you this License 42 | giving you legal permission to copy, distribute and/or modify it. 43 | 44 | For the developers' and authors' protection, the GPL clearly explains 45 | that there is no warranty for this free software. For both users' and 46 | authors' sake, the GPL requires that modified versions be marked as 47 | changed, so that their problems will not be attributed erroneously to 48 | authors of previous versions. 49 | 50 | Some devices are designed to deny users access to install or run 51 | modified versions of the software inside them, although the manufacturer 52 | can do so. This is fundamentally incompatible with the aim of 53 | protecting users' freedom to change the software. The systematic 54 | pattern of such abuse occurs in the area of products for individuals to 55 | use, which is precisely where it is most unacceptable. Therefore, we 56 | have designed this version of the GPL to prohibit the practice for those 57 | products. If such problems arise substantially in other domains, we 58 | stand ready to extend this provision to those domains in future versions 59 | of the GPL, as needed to protect the freedom of users. 60 | 61 | Finally, every program is threatened constantly by software patents. 62 | States should not allow patents to restrict development and use of 63 | software on general-purpose computers, but in those that do, we wish to 64 | avoid the special danger that patents applied to a free program could 65 | make it effectively proprietary. To prevent this, the GPL assures that 66 | patents cannot be used to render the program non-free. 67 | 68 | The precise terms and conditions for copying, distribution and 69 | modification follow. 70 | 71 | TERMS AND CONDITIONS 72 | 73 | 0. Definitions. 74 | 75 | "This License" refers to version 3 of the GNU General Public License. 76 | 77 | "Copyright" also means copyright-like laws that apply to other kinds of 78 | works, such as semiconductor masks. 79 | 80 | "The Program" refers to any copyrightable work licensed under this 81 | License. Each licensee is addressed as "you". "Licensees" and 82 | "recipients" may be individuals or organizations. 83 | 84 | To "modify" a work means to copy from or adapt all or part of the work 85 | in a fashion requiring copyright permission, other than the making of an 86 | exact copy. The resulting work is called a "modified version" of the 87 | earlier work or a work "based on" the earlier work. 88 | 89 | A "covered work" means either the unmodified Program or a work based 90 | on the Program. 91 | 92 | To "propagate" a work means to do anything with it that, without 93 | permission, would make you directly or secondarily liable for 94 | infringement under applicable copyright law, except executing it on a 95 | computer or modifying a private copy. Propagation includes copying, 96 | distribution (with or without modification), making available to the 97 | public, and in some countries other activities as well. 98 | 99 | To "convey" a work means any kind of propagation that enables other 100 | parties to make or receive copies. Mere interaction with a user through 101 | a computer network, with no transfer of a copy, is not conveying. 102 | 103 | An interactive user interface displays "Appropriate Legal Notices" 104 | to the extent that it includes a convenient and prominently visible 105 | feature that (1) displays an appropriate copyright notice, and (2) 106 | tells the user that there is no warranty for the work (except to the 107 | extent that warranties are provided), that licensees may convey the 108 | work under this License, and how to view a copy of this License. If 109 | the interface presents a list of user commands or options, such as a 110 | menu, a prominent item in the list meets this criterion. 111 | 112 | 1. Source Code. 113 | 114 | The "source code" for a work means the preferred form of the work 115 | for making modifications to it. "Object code" means any non-source 116 | form of a work. 117 | 118 | A "Standard Interface" means an interface that either is an official 119 | standard defined by a recognized standards body, or, in the case of 120 | interfaces specified for a particular programming language, one that 121 | is widely used among developers working in that language. 122 | 123 | The "System Libraries" of an executable work include anything, other 124 | than the work as a whole, that (a) is included in the normal form of 125 | packaging a Major Component, but which is not part of that Major 126 | Component, and (b) serves only to enable use of the work with that 127 | Major Component, or to implement a Standard Interface for which an 128 | implementation is available to the public in source code form. A 129 | "Major Component", in this context, means a major essential component 130 | (kernel, window system, and so on) of the specific operating system 131 | (if any) on which the executable work runs, or a compiler used to 132 | produce the work, or an object code interpreter used to run it. 133 | 134 | The "Corresponding Source" for a work in object code form means all 135 | the source code needed to generate, install, and (for an executable 136 | work) run the object code and to modify the work, including scripts to 137 | control those activities. However, it does not include the work's 138 | System Libraries, or general-purpose tools or generally available free 139 | programs which are used unmodified in performing those activities but 140 | which are not part of the work. For example, Corresponding Source 141 | includes interface definition files associated with source files for 142 | the work, and the source code for shared libraries and dynamically 143 | linked subprograms that the work is specifically designed to require, 144 | such as by intimate data communication or control flow between those 145 | subprograms and other parts of the work. 146 | 147 | The Corresponding Source need not include anything that users 148 | can regenerate automatically from other parts of the Corresponding 149 | Source. 150 | 151 | The Corresponding Source for a work in source code form is that 152 | same work. 153 | 154 | 2. Basic Permissions. 155 | 156 | All rights granted under this License are granted for the term of 157 | copyright on the Program, and are irrevocable provided the stated 158 | conditions are met. This License explicitly affirms your unlimited 159 | permission to run the unmodified Program. The output from running a 160 | covered work is covered by this License only if the output, given its 161 | content, constitutes a covered work. This License acknowledges your 162 | rights of fair use or other equivalent, as provided by copyright law. 163 | 164 | You may make, run and propagate covered works that you do not 165 | convey, without conditions so long as your license otherwise remains 166 | in force. You may convey covered works to others for the sole purpose 167 | of having them make modifications exclusively for you, or provide you 168 | with facilities for running those works, provided that you comply with 169 | the terms of this License in conveying all material for which you do 170 | not control copyright. Those thus making or running the covered works 171 | for you must do so exclusively on your behalf, under your direction 172 | and control, on terms that prohibit them from making any copies of 173 | your copyrighted material outside their relationship with you. 174 | 175 | Conveying under any other circumstances is permitted solely under 176 | the conditions stated below. Sublicensing is not allowed; section 10 177 | makes it unnecessary. 178 | 179 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 180 | 181 | No covered work shall be deemed part of an effective technological 182 | measure under any applicable law fulfilling obligations under article 183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 184 | similar laws prohibiting or restricting circumvention of such 185 | measures. 186 | 187 | When you convey a covered work, you waive any legal power to forbid 188 | circumvention of technological measures to the extent such circumvention 189 | is effected by exercising rights under this License with respect to 190 | the covered work, and you disclaim any intention to limit operation or 191 | modification of the work as a means of enforcing, against the work's 192 | users, your or third parties' legal rights to forbid circumvention of 193 | technological measures. 194 | 195 | 4. Conveying Verbatim Copies. 196 | 197 | You may convey verbatim copies of the Program's source code as you 198 | receive it, in any medium, provided that you conspicuously and 199 | appropriately publish on each copy an appropriate copyright notice; 200 | keep intact all notices stating that this License and any 201 | non-permissive terms added in accord with section 7 apply to the code; 202 | keep intact all notices of the absence of any warranty; and give all 203 | recipients a copy of this License along with the Program. 204 | 205 | You may charge any price or no price for each copy that you convey, 206 | and you may offer support or warranty protection for a fee. 207 | 208 | 5. Conveying Modified Source Versions. 209 | 210 | You may convey a work based on the Program, or the modifications to 211 | produce it from the Program, in the form of source code under the 212 | terms of section 4, provided that you also meet all of these conditions: 213 | 214 | a) The work must carry prominent notices stating that you modified 215 | it, and giving a relevant date. 216 | 217 | b) The work must carry prominent notices stating that it is 218 | released under this License and any conditions added under section 219 | 7. This requirement modifies the requirement in section 4 to 220 | "keep intact all notices". 221 | 222 | c) You must license the entire work, as a whole, under this 223 | License to anyone who comes into possession of a copy. This 224 | License will therefore apply, along with any applicable section 7 225 | additional terms, to the whole of the work, and all its parts, 226 | regardless of how they are packaged. This License gives no 227 | permission to license the work in any other way, but it does not 228 | invalidate such permission if you have separately received it. 229 | 230 | d) If the work has interactive user interfaces, each must display 231 | Appropriate Legal Notices; however, if the Program has interactive 232 | interfaces that do not display Appropriate Legal Notices, your 233 | work need not make them do so. 234 | 235 | A compilation of a covered work with other separate and independent 236 | works, which are not by their nature extensions of the covered work, 237 | and which are not combined with it such as to form a larger program, 238 | in or on a volume of a storage or distribution medium, is called an 239 | "aggregate" if the compilation and its resulting copyright are not 240 | used to limit the access or legal rights of the compilation's users 241 | beyond what the individual works permit. Inclusion of a covered work 242 | in an aggregate does not cause this License to apply to the other 243 | parts of the aggregate. 244 | 245 | 6. Conveying Non-Source Forms. 246 | 247 | You may convey a covered work in object code form under the terms 248 | of sections 4 and 5, provided that you also convey the 249 | machine-readable Corresponding Source under the terms of this License, 250 | in one of these ways: 251 | 252 | a) Convey the object code in, or embodied in, a physical product 253 | (including a physical distribution medium), accompanied by the 254 | Corresponding Source fixed on a durable physical medium 255 | customarily used for software interchange. 256 | 257 | b) Convey the object code in, or embodied in, a physical product 258 | (including a physical distribution medium), accompanied by a 259 | written offer, valid for at least three years and valid for as 260 | long as you offer spare parts or customer support for that product 261 | model, to give anyone who possesses the object code either (1) a 262 | copy of the Corresponding Source for all the software in the 263 | product that is covered by this License, on a durable physical 264 | medium customarily used for software interchange, for a price no 265 | more than your reasonable cost of physically performing this 266 | conveying of source, or (2) access to copy the 267 | Corresponding Source from a network server at no charge. 268 | 269 | c) Convey individual copies of the object code with a copy of the 270 | written offer to provide the Corresponding Source. This 271 | alternative is allowed only occasionally and noncommercially, and 272 | only if you received the object code with such an offer, in accord 273 | with subsection 6b. 274 | 275 | d) Convey the object code by offering access from a designated 276 | place (gratis or for a charge), and offer equivalent access to the 277 | Corresponding Source in the same way through the same place at no 278 | further charge. You need not require recipients to copy the 279 | Corresponding Source along with the object code. If the place to 280 | copy the object code is a network server, the Corresponding Source 281 | may be on a different server (operated by you or a third party) 282 | that supports equivalent copying facilities, provided you maintain 283 | clear directions next to the object code saying where to find the 284 | Corresponding Source. Regardless of what server hosts the 285 | Corresponding Source, you remain obligated to ensure that it is 286 | available for as long as needed to satisfy these requirements. 287 | 288 | e) Convey the object code using peer-to-peer transmission, provided 289 | you inform other peers where the object code and Corresponding 290 | Source of the work are being offered to the general public at no 291 | charge under subsection 6d. 292 | 293 | A separable portion of the object code, whose source code is excluded 294 | from the Corresponding Source as a System Library, need not be 295 | included in conveying the object code work. 296 | 297 | A "User Product" is either (1) a "consumer product", which means any 298 | tangible personal property which is normally used for personal, family, 299 | or household purposes, or (2) anything designed or sold for incorporation 300 | into a dwelling. In determining whether a product is a consumer product, 301 | doubtful cases shall be resolved in favor of coverage. For a particular 302 | product received by a particular user, "normally used" refers to a 303 | typical or common use of that class of product, regardless of the status 304 | of the particular user or of the way in which the particular user 305 | actually uses, or expects or is expected to use, the product. A product 306 | is a consumer product regardless of whether the product has substantial 307 | commercial, industrial or non-consumer uses, unless such uses represent 308 | the only significant mode of use of the product. 309 | 310 | "Installation Information" for a User Product means any methods, 311 | procedures, authorization keys, or other information required to install 312 | and execute modified versions of a covered work in that User Product from 313 | a modified version of its Corresponding Source. The information must 314 | suffice to ensure that the continued functioning of the modified object 315 | code is in no case prevented or interfered with solely because 316 | modification has been made. 317 | 318 | If you convey an object code work under this section in, or with, or 319 | specifically for use in, a User Product, and the conveying occurs as 320 | part of a transaction in which the right of possession and use of the 321 | User Product is transferred to the recipient in perpetuity or for a 322 | fixed term (regardless of how the transaction is characterized), the 323 | Corresponding Source conveyed under this section must be accompanied 324 | by the Installation Information. But this requirement does not apply 325 | if neither you nor any third party retains the ability to install 326 | modified object code on the User Product (for example, the work has 327 | been installed in ROM). 328 | 329 | The requirement to provide Installation Information does not include a 330 | requirement to continue to provide support service, warranty, or updates 331 | for a work that has been modified or installed by the recipient, or for 332 | the User Product in which it has been modified or installed. Access to a 333 | network may be denied when the modification itself materially and 334 | adversely affects the operation of the network or violates the rules and 335 | protocols for communication across the network. 336 | 337 | Corresponding Source conveyed, and Installation Information provided, 338 | in accord with this section must be in a format that is publicly 339 | documented (and with an implementation available to the public in 340 | source code form), and must require no special password or key for 341 | unpacking, reading or copying. 342 | 343 | 7. Additional Terms. 344 | 345 | "Additional permissions" are terms that supplement the terms of this 346 | License by making exceptions from one or more of its conditions. 347 | Additional permissions that are applicable to the entire Program shall 348 | be treated as though they were included in this License, to the extent 349 | that they are valid under applicable law. If additional permissions 350 | apply only to part of the Program, that part may be used separately 351 | under those permissions, but the entire Program remains governed by 352 | this License without regard to the additional permissions. 353 | 354 | When you convey a copy of a covered work, you may at your option 355 | remove any additional permissions from that copy, or from any part of 356 | it. (Additional permissions may be written to require their own 357 | removal in certain cases when you modify the work.) You may place 358 | additional permissions on material, added by you to a covered work, 359 | for which you have or can give appropriate copyright permission. 360 | 361 | Notwithstanding any other provision of this License, for material you 362 | add to a covered work, you may (if authorized by the copyright holders of 363 | that material) supplement the terms of this License with terms: 364 | 365 | a) Disclaiming warranty or limiting liability differently from the 366 | terms of sections 15 and 16 of this License; or 367 | 368 | b) Requiring preservation of specified reasonable legal notices or 369 | author attributions in that material or in the Appropriate Legal 370 | Notices displayed by works containing it; or 371 | 372 | c) Prohibiting misrepresentation of the origin of that material, or 373 | requiring that modified versions of such material be marked in 374 | reasonable ways as different from the original version; or 375 | 376 | d) Limiting the use for publicity purposes of names of licensors or 377 | authors of the material; or 378 | 379 | e) Declining to grant rights under trademark law for use of some 380 | trade names, trademarks, or service marks; or 381 | 382 | f) Requiring indemnification of licensors and authors of that 383 | material by anyone who conveys the material (or modified versions of 384 | it) with contractual assumptions of liability to the recipient, for 385 | any liability that these contractual assumptions directly impose on 386 | those licensors and authors. 387 | 388 | All other non-permissive additional terms are considered "further 389 | restrictions" within the meaning of section 10. If the Program as you 390 | received it, or any part of it, contains a notice stating that it is 391 | governed by this License along with a term that is a further 392 | restriction, you may remove that term. If a license document contains 393 | a further restriction but permits relicensing or conveying under this 394 | License, you may add to a covered work material governed by the terms 395 | of that license document, provided that the further restriction does 396 | not survive such relicensing or conveying. 397 | 398 | If you add terms to a covered work in accord with this section, you 399 | must place, in the relevant source files, a statement of the 400 | additional terms that apply to those files, or a notice indicating 401 | where to find the applicable terms. 402 | 403 | Additional terms, permissive or non-permissive, may be stated in the 404 | form of a separately written license, or stated as exceptions; 405 | the above requirements apply either way. 406 | 407 | 8. Termination. 408 | 409 | You may not propagate or modify a covered work except as expressly 410 | provided under this License. Any attempt otherwise to propagate or 411 | modify it is void, and will automatically terminate your rights under 412 | this License (including any patent licenses granted under the third 413 | paragraph of section 11). 414 | 415 | However, if you cease all violation of this License, then your 416 | license from a particular copyright holder is reinstated (a) 417 | provisionally, unless and until the copyright holder explicitly and 418 | finally terminates your license, and (b) permanently, if the copyright 419 | holder fails to notify you of the violation by some reasonable means 420 | prior to 60 days after the cessation. 421 | 422 | Moreover, your license from a particular copyright holder is 423 | reinstated permanently if the copyright holder notifies you of the 424 | violation by some reasonable means, this is the first time you have 425 | received notice of violation of this License (for any work) from that 426 | copyright holder, and you cure the violation prior to 30 days after 427 | your receipt of the notice. 428 | 429 | Termination of your rights under this section does not terminate the 430 | licenses of parties who have received copies or rights from you under 431 | this License. If your rights have been terminated and not permanently 432 | reinstated, you do not qualify to receive new licenses for the same 433 | material under section 10. 434 | 435 | 9. Acceptance Not Required for Having Copies. 436 | 437 | You are not required to accept this License in order to receive or 438 | run a copy of the Program. Ancillary propagation of a covered work 439 | occurring solely as a consequence of using peer-to-peer transmission 440 | to receive a copy likewise does not require acceptance. However, 441 | nothing other than this License grants you permission to propagate or 442 | modify any covered work. These actions infringe copyright if you do 443 | not accept this License. Therefore, by modifying or propagating a 444 | covered work, you indicate your acceptance of this License to do so. 445 | 446 | 10. Automatic Licensing of Downstream Recipients. 447 | 448 | Each time you convey a covered work, the recipient automatically 449 | receives a license from the original licensors, to run, modify and 450 | propagate that work, subject to this License. You are not responsible 451 | for enforcing compliance by third parties with this License. 452 | 453 | An "entity transaction" is a transaction transferring control of an 454 | organization, or substantially all assets of one, or subdividing an 455 | organization, or merging organizations. If propagation of a covered 456 | work results from an entity transaction, each party to that 457 | transaction who receives a copy of the work also receives whatever 458 | licenses to the work the party's predecessor in interest had or could 459 | give under the previous paragraph, plus a right to possession of the 460 | Corresponding Source of the work from the predecessor in interest, if 461 | the predecessor has it or can get it with reasonable efforts. 462 | 463 | You may not impose any further restrictions on the exercise of the 464 | rights granted or affirmed under this License. For example, you may 465 | not impose a license fee, royalty, or other charge for exercise of 466 | rights granted under this License, and you may not initiate litigation 467 | (including a cross-claim or counterclaim in a lawsuit) alleging that 468 | any patent claim is infringed by making, using, selling, offering for 469 | sale, or importing the Program or any portion of it. 470 | 471 | 11. Patents. 472 | 473 | A "contributor" is a copyright holder who authorizes use under this 474 | License of the Program or a work on which the Program is based. The 475 | work thus licensed is called the contributor's "contributor version". 476 | 477 | A contributor's "essential patent claims" are all patent claims 478 | owned or controlled by the contributor, whether already acquired or 479 | hereafter acquired, that would be infringed by some manner, permitted 480 | by this License, of making, using, or selling its contributor version, 481 | but do not include claims that would be infringed only as a 482 | consequence of further modification of the contributor version. For 483 | purposes of this definition, "control" includes the right to grant 484 | patent sublicenses in a manner consistent with the requirements of 485 | this License. 486 | 487 | Each contributor grants you a non-exclusive, worldwide, royalty-free 488 | patent license under the contributor's essential patent claims, to 489 | make, use, sell, offer for sale, import and otherwise run, modify and 490 | propagate the contents of its contributor version. 491 | 492 | In the following three paragraphs, a "patent license" is any express 493 | agreement or commitment, however denominated, not to enforce a patent 494 | (such as an express permission to practice a patent or covenant not to 495 | sue for patent infringement). To "grant" such a patent license to a 496 | party means to make such an agreement or commitment not to enforce a 497 | patent against the party. 498 | 499 | If you convey a covered work, knowingly relying on a patent license, 500 | and the Corresponding Source of the work is not available for anyone 501 | to copy, free of charge and under the terms of this License, through a 502 | publicly available network server or other readily accessible means, 503 | then you must either (1) cause the Corresponding Source to be so 504 | available, or (2) arrange to deprive yourself of the benefit of the 505 | patent license for this particular work, or (3) arrange, in a manner 506 | consistent with the requirements of this License, to extend the patent 507 | license to downstream recipients. "Knowingly relying" means you have 508 | actual knowledge that, but for the patent license, your conveying the 509 | covered work in a country, or your recipient's use of the covered work 510 | in a country, would infringe one or more identifiable patents in that 511 | country that you have reason to believe are valid. 512 | 513 | If, pursuant to or in connection with a single transaction or 514 | arrangement, you convey, or propagate by procuring conveyance of, a 515 | covered work, and grant a patent license to some of the parties 516 | receiving the covered work authorizing them to use, propagate, modify 517 | or convey a specific copy of the covered work, then the patent license 518 | you grant is automatically extended to all recipients of the covered 519 | work and works based on it. 520 | 521 | A patent license is "discriminatory" if it does not include within 522 | the scope of its coverage, prohibits the exercise of, or is 523 | conditioned on the non-exercise of one or more of the rights that are 524 | specifically granted under this License. You may not convey a covered 525 | work if you are a party to an arrangement with a third party that is 526 | in the business of distributing software, under which you make payment 527 | to the third party based on the extent of your activity of conveying 528 | the work, and under which the third party grants, to any of the 529 | parties who would receive the covered work from you, a discriminatory 530 | patent license (a) in connection with copies of the covered work 531 | conveyed by you (or copies made from those copies), or (b) primarily 532 | for and in connection with specific products or compilations that 533 | contain the covered work, unless you entered into that arrangement, 534 | or that patent license was granted, prior to 28 March 2007. 535 | 536 | Nothing in this License shall be construed as excluding or limiting 537 | any implied license or other defenses to infringement that may 538 | otherwise be available to you under applicable patent law. 539 | 540 | 12. No Surrender of Others' Freedom. 541 | 542 | If conditions are imposed on you (whether by court order, agreement or 543 | otherwise) that contradict the conditions of this License, they do not 544 | excuse you from the conditions of this License. If you cannot convey a 545 | covered work so as to satisfy simultaneously your obligations under this 546 | License and any other pertinent obligations, then as a consequence you may 547 | not convey it at all. For example, if you agree to terms that obligate you 548 | to collect a royalty for further conveying from those to whom you convey 549 | the Program, the only way you could satisfy both those terms and this 550 | License would be to refrain entirely from conveying the Program. 551 | 552 | 13. Use with the GNU Affero General Public License. 553 | 554 | Notwithstanding any other provision of this License, you have 555 | permission to link or combine any covered work with a work licensed 556 | under version 3 of the GNU Affero General Public License into a single 557 | combined work, and to convey the resulting work. The terms of this 558 | License will continue to apply to the part which is the covered work, 559 | but the special requirements of the GNU Affero General Public License, 560 | section 13, concerning interaction through a network will apply to the 561 | combination as such. 562 | 563 | 14. Revised Versions of this License. 564 | 565 | The Free Software Foundation may publish revised and/or new versions of 566 | the GNU General Public License from time to time. Such new versions will 567 | be similar in spirit to the present version, but may differ in detail to 568 | address new problems or concerns. 569 | 570 | Each version is given a distinguishing version number. If the 571 | Program specifies that a certain numbered version of the GNU General 572 | Public License "or any later version" applies to it, you have the 573 | option of following the terms and conditions either of that numbered 574 | version or of any later version published by the Free Software 575 | Foundation. If the Program does not specify a version number of the 576 | GNU General Public License, you may choose any version ever published 577 | by the Free Software Foundation. 578 | 579 | If the Program specifies that a proxy can decide which future 580 | versions of the GNU General Public License can be used, that proxy's 581 | public statement of acceptance of a version permanently authorizes you 582 | to choose that version for the Program. 583 | 584 | Later license versions may give you additional or different 585 | permissions. However, no additional obligations are imposed on any 586 | author or copyright holder as a result of your choosing to follow a 587 | later version. 588 | 589 | 15. Disclaimer of Warranty. 590 | 591 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 592 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 596 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 597 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 599 | 600 | 16. Limitation of Liability. 601 | 602 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 610 | SUCH DAMAGES. 611 | 612 | 17. Interpretation of Sections 15 and 16. 613 | 614 | If the disclaimer of warranty and limitation of liability provided 615 | above cannot be given local legal effect according to their terms, 616 | reviewing courts shall apply local law that most closely approximates 617 | an absolute waiver of all civil liability in connection with the 618 | Program, unless a warranty or assumption of liability accompanies a 619 | copy of the Program in return for a fee. 620 | 621 | END OF TERMS AND CONDITIONS 622 | 623 | How to Apply These Terms to Your New Programs 624 | 625 | If you develop a new program, and you want it to be of the greatest 626 | possible use to the public, the best way to achieve this is to make it 627 | free software which everyone can redistribute and change under these terms. 628 | 629 | To do so, attach the following notices to the program. It is safest 630 | to attach them to the start of each source file to most effectively 631 | state the exclusion of warranty; and each file should have at least 632 | the "copyright" line and a pointer to where the full notice is found. 633 | 634 | 635 | Copyright (C) 636 | 637 | This program is free software: you can redistribute it and/or modify 638 | it under the terms of the GNU General Public License as published by 639 | the Free Software Foundation, either version 3 of the License, or 640 | (at your option) any later version. 641 | 642 | This program is distributed in the hope that it will be useful, 643 | but WITHOUT ANY WARRANTY; without even the implied warranty of 644 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 645 | GNU General Public License for more details. 646 | 647 | You should have received a copy of the GNU General Public License 648 | along with this program. If not, see . 649 | 650 | Also add information on how to contact you by electronic and paper mail. 651 | 652 | If the program does terminal interaction, make it output a short 653 | notice like this when it starts in an interactive mode: 654 | 655 | Copyright (C) 656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 657 | This is free software, and you are welcome to redistribute it 658 | under certain conditions; type `show c' for details. 659 | 660 | The hypothetical commands `show w' and `show c' should show the appropriate 661 | parts of the General Public License. Of course, your program's commands 662 | might be different; for a GUI interface, you would use an "about box". 663 | 664 | You should also get your employer (if you work as a programmer) or school, 665 | if any, to sign a "copyright disclaimer" for the program, if necessary. 666 | For more information on this, and how to apply and follow the GNU GPL, see 667 | . 668 | 669 | The GNU General Public License does not permit incorporating your program 670 | into proprietary programs. If your program is a subroutine library, you 671 | may consider it more useful to permit linking proprietary applications with 672 | the library. If this is what you want to do, use the GNU Lesser General 673 | Public License instead of this License. But first, please read 674 | . 675 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(print,psupertime) 4 | export(double_psupertime) 5 | export(plot_double_psupertime) 6 | export(plot_double_psupertime_confusion) 7 | export(plot_double_psupertime_contour) 8 | export(plot_double_psupertime_genes) 9 | export(plot_go_results) 10 | export(plot_heatmap_of_gene_clusters) 11 | export(plot_identified_gene_coefficients) 12 | export(plot_identified_genes_over_psupertime) 13 | export(plot_labels_over_psupertime) 14 | export(plot_new_data_over_psupertime) 15 | export(plot_predictions_against_classes) 16 | export(plot_profiles_of_gene_clusters) 17 | export(plot_specified_genes_over_psupertime) 18 | export(plot_train_results) 19 | export(project_onto_psupertime) 20 | export(psupertime) 21 | export(psupertime_go_analysis) 22 | export(psupertime_plot_all) 23 | import(data.table) 24 | importFrom(Matrix,rowMeans) 25 | importFrom(Matrix,t) 26 | importFrom(RColorBrewer,brewer.pal) 27 | importFrom(SingleCellExperiment,SingleCellExperiment) 28 | importFrom(SummarizedExperiment,assay) 29 | importFrom(SummarizedExperiment,assays) 30 | importFrom(cowplot,plot_grid) 31 | importFrom(data.table,data.table) 32 | importFrom(data.table,fread) 33 | importFrom(data.table,melt.data.table) 34 | importFrom(data.table,set) 35 | importFrom(data.table,setnames) 36 | importFrom(data.table,setorder) 37 | importFrom(fastcluster,hclust) 38 | importFrom(forcats,fct_drop) 39 | importFrom(ggplot2,aes) 40 | importFrom(ggplot2,aes_string) 41 | importFrom(ggplot2,coord_flip) 42 | importFrom(ggplot2,element_blank) 43 | importFrom(ggplot2,element_text) 44 | importFrom(ggplot2,expand_limits) 45 | importFrom(ggplot2,facet_grid) 46 | importFrom(ggplot2,facet_wrap) 47 | importFrom(ggplot2,geom_bin2d) 48 | importFrom(ggplot2,geom_col) 49 | importFrom(ggplot2,geom_density) 50 | importFrom(ggplot2,geom_density2d) 51 | importFrom(ggplot2,geom_hline) 52 | importFrom(ggplot2,geom_line) 53 | importFrom(ggplot2,geom_linerange) 54 | importFrom(ggplot2,geom_point) 55 | importFrom(ggplot2,geom_raster) 56 | importFrom(ggplot2,geom_rug) 57 | importFrom(ggplot2,geom_segment) 58 | importFrom(ggplot2,geom_smooth) 59 | importFrom(ggplot2,geom_text) 60 | importFrom(ggplot2,geom_tile) 61 | importFrom(ggplot2,geom_vline) 62 | importFrom(ggplot2,ggplot) 63 | importFrom(ggplot2,ggsave) 64 | importFrom(ggplot2,guide_legend) 65 | importFrom(ggplot2,guides) 66 | importFrom(ggplot2,labs) 67 | importFrom(ggplot2,scale_colour_brewer) 68 | importFrom(ggplot2,scale_colour_manual) 69 | importFrom(ggplot2,scale_fill_brewer) 70 | importFrom(ggplot2,scale_fill_distiller) 71 | importFrom(ggplot2,scale_fill_manual) 72 | importFrom(ggplot2,scale_shape_manual) 73 | importFrom(ggplot2,scale_size_manual) 74 | importFrom(ggplot2,scale_x_continuous) 75 | importFrom(ggplot2,scale_x_discrete) 76 | importFrom(ggplot2,scale_y_continuous) 77 | importFrom(ggplot2,theme) 78 | importFrom(ggplot2,theme_bw) 79 | importFrom(ggplot2,theme_light) 80 | importFrom(glmnet,glmnet) 81 | importFrom(grDevices,colorRampPalette) 82 | importFrom(knitr,asis_output) 83 | importFrom(scales,pretty_breaks) 84 | importFrom(scran,modelGeneVar) 85 | importFrom(stringr,str_detect) 86 | importFrom(stringr,str_replace_all) 87 | importFrom(topGO,GenTable) 88 | importFrom(topGO,runTest) 89 | -------------------------------------------------------------------------------- /R/data.R: -------------------------------------------------------------------------------- 1 | #' List of human transcription factors 2 | #' 3 | #' Derived from the TRRUST project: https://www.grnpedia.org/trrust/ 4 | #' 5 | #' @format A character vector of length 795 6 | #' @source \url{https://www.grnpedia.org/trrust/downloadnetwork.php} 7 | "tf_human" 8 | 9 | #' List of mouse transcription factors 10 | #' 11 | #' Derived from the TRRUST project: https://www.grnpedia.org/trrust/ 12 | #' 13 | #' @format A character vector of length 827 14 | #' @source \url{https://www.grnpedia.org/trrust/downloadnetwork.php} 15 | "tf_mouse" 16 | -------------------------------------------------------------------------------- /R/psupertime.R: -------------------------------------------------------------------------------- 1 | ################# 2 | #' Supervised pseudotime 3 | #' 4 | #' @param x Either SingleCellExperiment object containing a matrix of genes * 5 | #' cells required, or a matrix of log TPM values (also genes * cells). 6 | #' @param y Vector of labels, which should have same length as number of 7 | #' columns in sce / x. Factor levels will be taken as the intended order for 8 | #' training. 9 | #' @param y_labels Alternative ordering and/or subset of the labels in y. All 10 | #' labels must be present in y. Smoothing and scaling are done on the whole 11 | #' dataset, before any subsetting takes place. 12 | #' @param assay_type If a SingleCellExperiment object is used as input, 13 | #' specifies which assay is to be used. 14 | #' @param sel_genes Method to be used to select interesting genes to be used 15 | #' in psupertime. Must be a string, with permitted values 'hvg', 'all', 16 | #' 'tf_mouse', 'tf_human' and 'list', corresponding to: highly variable genes, 17 | #' all genes, transcription factors in mouse, transcription factors in human, 18 | #' and a user-selected list. If sel_genes='list', then the parameter gene_list 19 | #' must also be specified as input, containing the user-specified list of 20 | #' genes. sel_genes may alternatively be a list, itself, specifying the 21 | #' parameters to be used for selecting highly variable genes via scran, with 22 | #' names 'hvg_cutoff', 'bio_cutoff'. 23 | #' @param gene_list If sel_genes is specified as 'list', gene_list specifies 24 | #' the list of user-specified genes. 25 | #' @param scale Should the log expression data for each gene be scaled to have 26 | #' mean zero and SD 1? Having the same scale ensures that L1-penalization 27 | #' functions properly; typically you would only set this to FALSE if you have 28 | #' already done your own scaling. 29 | #' @param smooth Should the data be smoothed over neighbours? This is done to 30 | #' denoise the data; if you already done your own denoising, set this to FALSE. 31 | #' We recommend doing your own denoising! 32 | #' @param min_expression Cutoff for excluding genes based on non-zero 33 | #' expression in only a small proportion of cells; default is 1\% of cells. 34 | #' @param penalization Method of selecting level of L1-penalization. 'best' 35 | #' uses the value of lambda giving the best cross-validation accuracy; '1se' 36 | #' corresponds to largest value of lambda within 1 standard error of the best. 37 | #' This increases sparsity with minimal increased error (and is the default). 38 | #' @param method Statistical model used for ordinal logistic regression, one 39 | #' of 'proportional', 'forward' and 'backward', corresponding to cumulative 40 | #' proportional odds, forward continuation ratio and backward continuation 41 | #' ratio. 42 | #' @param score Cross-validated accuracy to be used to select model. May take 43 | #' values 'x_entropy' (default), or 'class_error', corresponding to cross- 44 | #' entropy and classification error respectively. Cross-entropy is a smooth 45 | #' measure, while classification error is based on discrete labels and tends 46 | #' to be a bit 'lumpy'. 47 | #' @param n_folds Number of folds to use for cross-validation; default is 5. 48 | #' @param test_propn Proportion of data to hold out for testing, separate to 49 | #' the cross-validation; default is 0.1 (10\%). 50 | #' @param lambdas User-specified sequence of lambda values. Should be in 51 | #' decreasing order. 52 | #' @param max_iters Maximum number of iterations to run in glmnet. 53 | #' @param seed Random seed for specifying cross-validation folds and test data 54 | #' @return psupertime object 55 | #' @export 56 | psupertime <- function(x, y, y_labels=NULL, assay_type='logcounts', 57 | sel_genes='hvg', gene_list=NULL, scale=TRUE, smooth=TRUE, 58 | min_expression=0.01, penalization='1se', method='proportional', 59 | score='xentropy', n_folds=5, test_propn=0.1, lambdas=NULL, max_iters=1e3, 60 | seed=1234) { 61 | # parse params 62 | x = .check_x(x, y, assay_type) 63 | y = .check_y(y, y_labels) 64 | ps_params = .check_params(x, y, y_labels, 65 | assay_type, sel_genes, gene_list, scale, smooth, 66 | min_expression, penalization, method, score, 67 | n_folds, test_propn, lambdas, max_iters, seed) 68 | 69 | # select genes, do processing of data 70 | sel_genes = .select_genes(x, ps_params) 71 | x_data = .make_x_data(x, sel_genes, ps_params) 72 | 73 | # restrict to y_labels, if specified 74 | data_list = .restrict_to_y_labels(x_data, y, y_labels) 75 | 76 | # make nice data for ordinal regression 77 | test_idx = .get_test_idx(y, ps_params) 78 | 79 | # get test data 80 | y_test = y[test_idx] 81 | x_test = x_data[test_idx, ] 82 | y_train = y[!test_idx] 83 | x_train = x_data[!test_idx, ] 84 | 85 | # do tests on different folds 86 | fold_list = .get_fold_list(y_train, ps_params) 87 | scores_train = .train_on_folds(x_train, y_train, fold_list, ps_params) 88 | 89 | # find best scoring lambda options, train model on these 90 | mean_train = .calc_mean_train(scores_train) 91 | best_dt = .calc_best_lambdas(mean_train) 92 | best_lambdas = .get_best_lambdas(best_dt, ps_params) 93 | glmnet_best = .get_best_fit(x_train, y_train, ps_params) 94 | scores_dt = .make_scores_dt(glmnet_best, x_test, y_test, 95 | scores_train) 96 | 97 | # do projections with this model 98 | proj_dt = .calc_proj_dt(glmnet_best, x_data, y, best_lambdas) 99 | beta_dt = .make_best_beta(glmnet_best, best_lambdas) 100 | 101 | # make output 102 | psuper_obj = .make_psuper_obj(glmnet_best, x_data, y, x_test, y_test, 103 | test_idx, fold_list, proj_dt, beta_dt, best_lambdas, best_dt, 104 | scores_dt, ps_params) 105 | 106 | return(psuper_obj) 107 | } 108 | 109 | #' Checks the gene info 110 | #' 111 | #' @importFrom SummarizedExperiment assays 112 | #' @return list of validated parameters 113 | #' @keywords internal 114 | .check_x <- function(x, y, assay_type) { 115 | # check input data looks ok 116 | if (!(class(x) %in% c('SingleCellExperiment', 'matrix', 'dgCMatrix', 117 | 'dgRMatrix', 'dgTMatrix'))) { 118 | stop('x must be either a SingleCellExperiment or a matrix of log counts') 119 | } 120 | if ( class(x)=='SingleCellExperiment') { 121 | if ( !(assay_type %in% names(assays(x))) ) { 122 | stop(paste0('SingleCellExperiment x does not contain the specified assay, ', assay_type)) 123 | } 124 | } else { 125 | if ( is.null(rownames(x)) ) { 126 | stop('row names of x must be given, as gene names') 127 | } 128 | } 129 | if (ncol(x)!=length(y)) { 130 | stop('length of y must be same as number of cells (columns) in SingleCellExperiment x') 131 | } 132 | if (is.null(colnames(x))) { 133 | warning("x has no colnames; giving arbitrary colnames") 134 | n_cells = ncol(x) 135 | n_digits = ceiling(log10(n_cells)) 136 | format_str = sprintf("cell%%0%dd", n_digits) 137 | colnames(x) = sprintf(format_str, 1:n_cells) 138 | } 139 | if ( length(unique(colnames(x))) != ncol(x) ) 140 | stop("colnames of x should be unique (= cell identifiers)") 141 | 142 | return(x) 143 | } 144 | 145 | #' Checks the labels 146 | #' 147 | #' @return checked labels 148 | #' @keywords internal 149 | .check_y <- function(y, y_labels) { 150 | if ( any(is.na(y)) ) { 151 | stop('input y contains missing values') 152 | } 153 | if (!is.factor(y)) { 154 | y = factor(y) 155 | message('converting y to a factor. label ordering used for training psupertime is:') 156 | message(paste(levels(y), collapse=', ')) 157 | } 158 | if ( length(levels(y)) <=2 ) { 159 | stop('psupertime must be run with at least 3 time-series labels') 160 | } 161 | if (!is.null(y_labels)) { 162 | if ( !is.character(y) ) { 163 | stop('y_labels must be a character vector') 164 | } 165 | if ( !all(y_labels %in% levels(y)) ) { 166 | stop('y_labels must be a subset of the labels for y') 167 | } 168 | if ( length(unique(y_labels)) <=2 ) { 169 | stop('to use y_labels, y_labels must have at least 3 distinct values') 170 | } 171 | } 172 | 173 | return(y) 174 | } 175 | 176 | #' check all parameters 177 | #' 178 | #' @importFrom SummarizedExperiment assays 179 | #' @return list of validated parameters 180 | #' @keywords internal 181 | .check_params <- function(x, y, y_labels, assay_type, sel_genes, gene_list, scale, smooth, min_expression, 182 | penalization, method, score, n_folds, test_propn, lambdas, max_iters, seed) { 183 | n_genes = nrow(x) 184 | 185 | # check selection of genes is valid 186 | sel_genes_list = c('hvg', 'all', 'tf_mouse', 'tf_human', 'list') 187 | if (!is.character(sel_genes)) { 188 | if ( !is.list(sel_genes) || !all(c('hvg_cutoff', 'bio_cutoff') %in% names(sel_genes)) ) { 189 | err_message = paste0('sel_genes must be one of ', paste(sel_genes_list, collapse=', '), ', or a list containing the following named numeric elements: hvg_cutoff, bio_cutoff') 190 | stop(err_message) 191 | } 192 | hvg_cutoff = sel_genes$hvg_cutoff 193 | bio_cutoff = sel_genes$bio_cutoff 194 | sel_genes = 'hvg' 195 | } else { 196 | if ( !(sel_genes %in% sel_genes_list) ) { 197 | err_message = paste0('invalid value for sel_genes; please use one of ', paste(sel_genes_list, collapse=', ')) 198 | stop(err_message) 199 | } else if (sel_genes=='list') { 200 | if (is.null(gene_list) || !is.character(gene_list)) { 201 | stop("to use 'list' as sel_genes value, you must also give a character vector as gene_list") 202 | } 203 | hvg_cutoff = NULL 204 | bio_cutoff = NULL 205 | } else if (sel_genes=='hvg') { 206 | message('using default parameters to identify highly variable genes') 207 | hvg_cutoff = 0.1 208 | bio_cutoff = 0.5 209 | } else { 210 | hvg_cutoff = NULL 211 | bio_cutoff = NULL 212 | } 213 | } 214 | 215 | # do smoothing, scaling? 216 | stopifnot(is.logical(smooth)) 217 | stopifnot(is.logical(scale)) 218 | 219 | # give warning about scaling 220 | if (scale==FALSE) { 221 | warning("'scale' is set to FALSE. If you are using pre-scaled data, ignore this warning.\nIf not, be aware that for LASSO regression to work properly, the input variables should be on the same scale.") 222 | if (min_expression > 0) { 223 | warning("If you are using pre-scaled data, then psupertime cannot tell which are zero values; consider setting 'min_expression' to 0.") 224 | } 225 | } 226 | 227 | # what proportion of cells must express a gene for it to be included? 228 | if ( !( is.numeric(min_expression) && ( min_expression>=0 & min_expression<=1) ) ) { 229 | stop('min_expression must be a number between 0 and 1') 230 | } 231 | 232 | # how much regularization to use? 233 | penalty_list = c('1se', 'best') 234 | penalization = match.arg(penalization, penalty_list) 235 | 236 | # which statisical model to use for orginal logistic regression? 237 | method_list = c('proportional', 'forward', 'backward') 238 | method = match.arg(method, method_list) 239 | 240 | # which statistical model to use for orginal logistic regression? 241 | score_list = c('xentropy', 'class_error') 242 | score = match.arg(score, score_list) 243 | 244 | # check inputs for training 245 | if ( !(floor(n_folds)==n_folds) || n_folds<=2 ) { 246 | stop('n_folds must be an integer greater than 2') 247 | } 248 | if ( !( is.numeric(test_propn) && ( test_propn>0 & test_propn<1) ) ) { 249 | stop('test_propn must be a number greater than 0 and less than 1') 250 | } 251 | if (is.null(lambdas)) { 252 | lambdas = 10^seq(from=0, to=-4, by=-0.1) 253 | } else { 254 | if ( !( is.numeric(lambdas) && all(lambdas == cummin(lambdas)) ) ) { 255 | stop('lambdas must be a monotonically decreasing vector') 256 | } 257 | } 258 | if ( !(floor(max_iters)==max_iters) || max_iters<=0 ) { 259 | stop('max_iters must be a positive integer') 260 | } 261 | if ( !(floor(seed)==seed) ) { 262 | stop('seed must be an integer') 263 | } 264 | 265 | # put into list 266 | ps_params = list( 267 | n_genes = n_genes 268 | ,assay_type = assay_type 269 | ,sel_genes = sel_genes 270 | ,hvg_cutoff = hvg_cutoff 271 | ,bio_cutoff = bio_cutoff 272 | ,gene_list = gene_list 273 | ,smooth = smooth 274 | ,scale = scale 275 | ,min_expression = min_expression 276 | ,penalization = penalization 277 | ,method = method 278 | ,score = score 279 | ,n_folds = n_folds 280 | ,test_propn = test_propn 281 | ,lambdas = lambdas 282 | ,max_iters = max_iters 283 | ,seed = seed 284 | ) 285 | return(ps_params) 286 | } 287 | 288 | #' Select genes for use in regression 289 | #' 290 | #' @importFrom SingleCellExperiment SingleCellExperiment 291 | #' @param x SingleCellExperiment class containing all cells and genes required, or matrix of counts 292 | #' @param ps_params List of all parameters specified. 293 | #' @keywords internal 294 | .select_genes <- function(x, ps_params) { 295 | # unpack 296 | sel_genes = ps_params$sel_genes 297 | if ( sel_genes=='hvg' ) { 298 | if ( class(x)=='SingleCellExperiment' ) { 299 | sce = x 300 | } else if ( class(x) %in% c('matrix', 'dgCMatrix', 'dgRMatrix') ) { 301 | sce = SingleCellExperiment(assays = list(logcounts = x)) 302 | } else { stop('class of x must be either matrix or SingleCellExperiment') } 303 | 304 | # calculate selected genes 305 | sel_genes = .calc_hvg_genes(sce, ps_params, do_plot=FALSE) 306 | 307 | } else if ( sel_genes=='list' ) { 308 | sel_genes = ps_params$gene_list 309 | 310 | } else { 311 | if ( sel_genes=='all' ) { 312 | sel_genes = rownames(x) 313 | 314 | } else if ( sel_genes=='tf_mouse' ) { 315 | sel_genes = tf_mouse 316 | 317 | } else if ( sel_genes=='tf_human' ) { 318 | sel_genes = tf_human 319 | 320 | } else { 321 | stop() 322 | } 323 | } 324 | 325 | # restrict to genes which are expressed in at least some proportion of cells 326 | if ( ps_params$min_expression > 0 ) { 327 | # calc expressed genes 328 | expressed_genes = .calc_expressed_genes(x, ps_params) 329 | 330 | # list missing genes 331 | missing_g = setdiff(sel_genes, expressed_genes) 332 | n_missing = length(missing_g) 333 | if (n_missing>0) { 334 | message(sprintf('%d genes have insufficient expression and will not be used as input to psupertime', n_missing)) 335 | } 336 | sel_genes = intersect(expressed_genes, sel_genes) 337 | } 338 | stopifnot( length(sel_genes)>0 ) 339 | 340 | return(sel_genes) 341 | } 342 | 343 | #' Calculates list of highly variable genes (according to approach in scran). 344 | #' 345 | #' @param x SingleCellExperiment class or matrix of log counts 346 | #' @param ps_params List of all parameters specified. 347 | #' @import data.table 348 | #' @importFrom data.table setorder 349 | #' @importFrom ggplot2 ggplot 350 | #' @importFrom ggplot2 aes 351 | #' @importFrom ggplot2 geom_bin2d 352 | #' @importFrom ggplot2 geom_point 353 | #' @importFrom ggplot2 geom_line 354 | #' @importFrom ggplot2 scale_fill_distiller 355 | #' @importFrom ggplot2 theme_light 356 | #' @importFrom ggplot2 labs 357 | #' @importFrom Matrix rowMeans 358 | #' @importFrom scran modelGeneVar 359 | #' @importFrom SummarizedExperiment assay 360 | #' @keywords internal 361 | .calc_hvg_genes <- function(sce, ps_params, do_plot=FALSE) { 362 | message('identifying highly variable genes') 363 | assay_type = 'logcounts' 364 | if (!(assay_type %in% names(assays(sce)))) { 365 | stop('to calculate highly variable genes (HVGs) with scran, x must contain the assay "logcounts"') 366 | } 367 | # check that values seem reasonabl 368 | gene_means = Matrix::rowMeans(assay(sce, assay_type)) 369 | scran_min_mean = 0.1 370 | if ( all(gene_means<=scran_min_mean) ) { 371 | stop('Gene mean values are too low to identify HVGs (scran removes genes with\n mean less than 0.1. Is your data scaled correctly?') 372 | } 373 | 374 | # fit variance trend 375 | var_out = modelGeneVar(sce) 376 | 377 | # plot trends identified 378 | var_dt = as.data.table(var_out) 379 | var_dt = var_dt[, symbol:=rownames(var_out) ] 380 | setorder(var_dt, mean) 381 | if (do_plot) { 382 | g = ggplot(var_dt[ mean>0.5 ]) + 383 | aes( x=mean, y=total ) + 384 | geom_bin2d() + 385 | geom_point( size=0.1 ) + 386 | geom_line( aes(y=tech)) + 387 | scale_fill_distiller( palette='RdBu' ) + 388 | theme_light() + 389 | labs( 390 | x = "Mean log-expression", 391 | y = "Variance of log-expression" 392 | ) 393 | print(g) 394 | } 395 | 396 | # restrict to highly variable genes 397 | hvg_dt = var_dt[ FDR <= ps_params$hvg_cutoff & bio >= ps_params$bio_cutoff ] 398 | setorder(hvg_dt, -bio) 399 | sel_genes = hvg_dt$symbol 400 | 401 | return(sel_genes) 402 | } 403 | 404 | #' Restrict to genes with minimum proportion of expression defined in ps_params$min_expression 405 | #' 406 | #' @param x SingleCellExperiment class containing all cells and genes required 407 | #' @param ps_params List of all parameters specified. 408 | #' @importFrom Matrix rowMeans 409 | #' @importFrom SummarizedExperiment assay 410 | #' @keywords internal 411 | .calc_expressed_genes <- function(x, ps_params) { 412 | # check whether necessary 413 | if (ps_params$min_expression==0) { 414 | return(rownames(x)) 415 | } 416 | 417 | # otherwise calculate it 418 | if ( class(x)=='SingleCellExperiment' ) { 419 | x_mat = assay(x, 'logcounts') 420 | } else if ( class(x) %in% c('matrix', 'dgCMatrix', 'dgCMatrix') ) { 421 | x_mat = x 422 | } else { stop('x must be either SingleCellExperiment or (possibly sparse) matrix') } 423 | prop_expressed = rowMeans( x_mat>0 ) 424 | expressed_genes = names(prop_expressed[ prop_expressed>ps_params$min_expression ]) 425 | 426 | return(expressed_genes) 427 | } 428 | 429 | #' Get list of transcription factors 430 | #' 431 | #' @importFrom data.table fread 432 | #' @return List of all transcription factors specified. 433 | #' @keywords internal 434 | .get_tf_list <- function(dirs) { 435 | tf_path = file.path(dirs$data_root, 'fgcz_annotations', 'tf_list.txt') 436 | tf_full = fread(tf_path) 437 | tf_list = tf_full$symbol 438 | return(tf_list) 439 | } 440 | 441 | #' @importFrom data.table setnames 442 | #' @importFrom stringr str_replace_all 443 | #' @importFrom stringr str_detect 444 | #' @keywords internal 445 | .get_go_list <- function(dirs) { 446 | stop('not implemented yet') 447 | lookup_path = file.path(dirs$data_root, 'fgcz_annotations', 'genes_annotation_byGene.txt') 448 | ensembl_dt = fread(lookup_path) 449 | old_names = names(ensembl_dt) 450 | new_names = str_replace_all(old_names, ' ', '_') 451 | setnames(ensembl_dt, old_names, new_names) 452 | tf_term = 'GO:0003700' 453 | tf_full = ensembl_dt[ str_detect(GO_MF, tf_term) ] 454 | tf_list = tf_full[, list(symbol=gene_name, description)] 455 | 456 | return(tf_list) 457 | } 458 | 459 | #' Process input data 460 | #' 461 | #' Note that input is matrix with rows=genes, cols=cells, and that output 462 | #' has rows=cells, genes=cols 463 | #' 464 | #' @param x SingleCellExperiment or matrix of log counts 465 | #' @param sel_genes Selected genes 466 | #' @param ps_params Full list of parameters 467 | #' @importFrom Matrix t 468 | #' @importFrom stringr str_detect 469 | #' @importFrom stringr str_replace_all 470 | #' @importFrom SummarizedExperiment assay 471 | #' @return Matrix of dimension # cells by # selected genes 472 | #' @keywords internal 473 | .make_x_data <- function(x, sel_genes, ps_params) { 474 | message('processing data') 475 | # get matrix 476 | if ( class(x)=='SingleCellExperiment' ) { 477 | x_data = assay(x, ps_params$assay_type) 478 | } else if (class(x) %in% c('matrix', 'dgCMatrix', 'dgRMatrix', 'dgTMatrix')) { 479 | x_data = x 480 | } else { 481 | stop('x must be either a SingleCellExperiment or a matrix of counts') 482 | } 483 | 484 | # transpose 485 | x_data = t(x_data) 486 | 487 | # check if any genes missing, restrict to selected genes 488 | all_genes = colnames(x_data) 489 | missing_genes = setdiff(sel_genes, all_genes) 490 | n_missing = length(missing_genes) 491 | if ( n_missing>0 ) { 492 | message(' ', n_missing, ' genes missing:', sep='') 493 | message(' ', paste(missing_genes[1:min(n_missing,20)], collapse=', '), sep='') 494 | } 495 | x_data = x_data[, intersect(sel_genes, all_genes)] 496 | 497 | # exclude any genes with zero SD 498 | message(' checking for zero SD genes') 499 | col_sd = apply(x_data, 2, sd) 500 | sd_0_idx = col_sd==0 501 | if ( sum(sd_0_idx)>0 ) { 502 | message('\nthe following genes have zero SD and are removed:') 503 | message(paste(colnames(x_data[, sd_0_idx]), collapse=', ')) 504 | x_data = x_data[, !sd_0_idx] 505 | } 506 | 507 | # do smoothing 508 | if (ps_params$smooth) { 509 | message(' denoising data') 510 | if ( is.null(ps_params$knn) ) { 511 | knn = 10 512 | } else { 513 | knn = ps_params$knn 514 | } 515 | 516 | # calculate correlations between all cells 517 | x_t = t(x_data) 518 | cor_mat = cor(as.matrix(x_t)) 519 | 520 | # each column is ranked list of nearest neighbours of the column cell 521 | nhbr_mat = apply(-cor_mat, 1, rank, ties.method='random') 522 | idx_mat = nhbr_mat <= knn 523 | avg_knn_mat = sweep(idx_mat, 2, colSums(idx_mat), '/') 524 | stopifnot( all(colSums(avg_knn_mat)==1) ) 525 | 526 | # calculate average over all kNNs 527 | imputed_mat = x_t %*% avg_knn_mat 528 | x_t = imputed_mat 529 | x_data = t(x_t) 530 | } 531 | 532 | # do scaling 533 | if (ps_params$scale) { 534 | message(' scaling data') 535 | x_data = apply(x_data, 2, scale) 536 | } 537 | 538 | # make all gene names nice 539 | old_names = colnames(x_data) 540 | hyphen_idx = str_detect(old_names, '-') 541 | if (any(hyphen_idx)) { 542 | message(' hyphens detected in the following gene names:') 543 | message(' ', appendLF=FALSE) 544 | message(paste(old_names[hyphen_idx], collapse=', ')) 545 | message(' these have been replaced with .s') 546 | new_names = str_replace_all(old_names, '-', '.') 547 | colnames(x_data) = new_names 548 | } 549 | 550 | # add rownames to x 551 | rownames(x_data) = colnames(x) 552 | 553 | message(sprintf(' processed data is %d cells * %d genes', nrow(x_data), ncol(x_data))) 554 | 555 | return(x_data) 556 | } 557 | 558 | #' Use y_labels to define cells to use, and order of labels 559 | #' 560 | #' @param x_data matrix output from make_x_data (rows=cells, cols=genes) 561 | #' @param y factor of cell labels 562 | #' @param y_labels list of labels to restrict to, and order to use 563 | .restrict_to_y_labels <- function(x_data, y, y_labels) { 564 | if (is.null(y_labels)) { 565 | data_list = list(x_data=x_data, y=y) 566 | } else { 567 | # restrict to correct bit of y, set levels 568 | y_idx = y %in% y_labels 569 | data_list = list( 570 | x_data = x_data[y_idx, ], 571 | y = factor(y[y_idx], levels=y_labels) 572 | ) 573 | } 574 | return(data_list) 575 | } 576 | 577 | #' Get list of cells to keep aside as test set 578 | #' 579 | #' @param y list of y labels 580 | #' @return Indices for test set 581 | #' @keywords internal 582 | .get_test_idx <- function(y, ps_params) { 583 | set.seed(ps_params$seed) 584 | n_samples = length(y) 585 | test_idx = sample(n_samples, round(n_samples*ps_params$test_propn)) 586 | test_idx = 1:n_samples %in% test_idx 587 | 588 | return(test_idx) 589 | } 590 | 591 | #' @keywords internal 592 | .get_fold_list <- function(y_train, ps_params) { 593 | set.seed(ps_params$seed + 1) 594 | n_samples = length(y_train) 595 | fold_labels = rep_len(1:ps_params$n_folds, n_samples) 596 | fold_list = fold_labels[ sample(n_samples, n_samples) ] 597 | 598 | return(fold_list) 599 | } 600 | 601 | #' @importFrom data.table data.table 602 | #' @keywords internal 603 | .train_on_folds <- function(x_train, y_train, fold_list, ps_params) { 604 | message(sprintf('cross-validation training, %d folds:', ps_params$n_folds)) 605 | # unpack 606 | n_folds = ps_params$n_folds 607 | lambdas = ps_params$lambdas 608 | max_iters = ps_params$max_iters 609 | method = ps_params$method 610 | 611 | # loop 612 | scores_dt = data.table() 613 | for (kk in 1:n_folds) { 614 | message(sprintf(' fold %d', kk)) 615 | 616 | # split the folds 617 | fold_idx = fold_list==kk 618 | y_valid_k = y_train[ fold_idx ] 619 | x_valid_k = x_train[ fold_idx, ] 620 | y_train_k = y_train[ !fold_idx ] 621 | x_train_k = x_train[ !fold_idx, ] 622 | 623 | # train model 624 | glmnet_fit = .glmnetcr_propn(x_train_k, y_train_k, 625 | method = method 626 | ,lambda = lambdas 627 | ,maxit = max_iters 628 | ) 629 | 630 | # validate model 631 | temp_dt = .calc_scores_for_one_fit(glmnet_fit, x_valid_k, y_valid_k) 632 | temp_dt[, fold := kk ] 633 | scores_dt = rbind(scores_dt, temp_dt) 634 | } 635 | 636 | # add label 637 | scores_dt[, data := 'train' ] 638 | 639 | return(scores_dt) 640 | } 641 | 642 | #' This is based on an equivalent function from the package \code{glmnetcr}, 643 | #' which is sadly no longer on CRAN. 644 | #' 645 | #' @importFrom glmnet glmnet 646 | #' @keywords internal 647 | .glmnetcr_propn <- function(x, y, method = "proportional", weights = NULL, offset = NULL, 648 | alpha = 1, nlambda = 100, lambda.min.ratio = NULL, lambda = NULL, 649 | standardize = TRUE, thresh = 1e-04, exclude = NULL, penalty.factor = NULL, 650 | maxit = 100) { 651 | if (length(unique(y)) == 2) 652 | stop("Binary response: Use glmnet with family='binomial' parameter") 653 | method <- c("backward", "forward", "proportional")[charmatch(method, 654 | c("backward", "forward", "proportional"))] 655 | n <- nobs <- dim(x)[1] 656 | p <- m <- nvars <- dim(x)[2] 657 | k <- length(unique(y)) 658 | x <- as.matrix(x) 659 | if (is.null(penalty.factor)) 660 | penalty.factor <- rep(1, nvars) 661 | else penalty.factor <- penalty.factor 662 | if (is.null(lambda.min.ratio)) 663 | lambda.min.ratio <- ifelse(nobs < nvars, 0.01, 1e-04) 664 | if (is.null(weights)) 665 | weights <- rep(1, length(y)) 666 | if (method == "backward") { 667 | restructure <- cr.backward(x = x, y = y, weights = weights) 668 | } 669 | if (method == "forward") { 670 | restructure <- cr.forward(x = x, y = y, weights = weights) 671 | } 672 | if (method == "proportional") { 673 | restructure <- .restructure_propodds(x = x, y = y, weights = weights) 674 | } 675 | glmnet.data <- list(x = restructure[, -c(1, 2)], y = restructure[, 676 | "y"], weights = restructure[, "weights"]) 677 | object <- glmnet(glmnet.data$x, glmnet.data$y, family = "binomial", 678 | weights = glmnet.data$weights, offset = offset, alpha = alpha, 679 | nlambda = nlambda, lambda.min.ratio = lambda.min.ratio, 680 | lambda = lambda, standardize = standardize, thresh = thresh, 681 | exclude = exclude, penalty.factor = c(penalty.factor, rep(0, k - 1)), 682 | maxit = maxit, type.gaussian = ifelse(nvars < 500, "covariance", "naive")) 683 | object$x <- x 684 | object$y <- y 685 | object$method <- method 686 | class(object) <- "glmnetcr" 687 | object 688 | } 689 | 690 | #' @keywords internal 691 | .restructure_propodds <- function(x, y, weights) { 692 | yname = as.character(substitute(y)) 693 | if (!is.factor(y)) { y = factor(y, exclude = NA) } 694 | ylevels = levels(y) 695 | kint = length(ylevels) - 1 696 | y = as.numeric(y) 697 | names = dimnames(x)[[2]] 698 | if (length(names) == 0) { names = paste("V", 1:dim(x)[2], sep = "") } 699 | expand = list() 700 | for (k in 2:(kint + 1)) { 701 | expand[[k - 1]] = cbind(y, weights, x) 702 | expand[[k - 1]][, 1] = ifelse(expand[[k - 1]][, 1] >= k, 1, 0) 703 | cp = matrix( 704 | rep(0, dim(expand[[k - 1]])[1] * kint), 705 | ncol = kint 706 | ) 707 | cp[, k - 1] = 1 708 | dimnames(cp)[[2]] = paste("cp", 1:kint, sep = "") 709 | expand[[k - 1]] = cbind(expand[[k - 1]], cp) 710 | dimnames(expand[[k - 1]])[[2]] = c("y", "weights", names, paste("cp", 1:kint, sep = "")) 711 | } 712 | newx = expand[[1]] 713 | for (k in 2:kint) { newx = rbind(newx, expand[[k]]) } 714 | newx 715 | } 716 | 717 | #' @importFrom stringr str_detect 718 | #' @keywords internal 719 | .predict_glmnetcr_propodds <- function(object, newx=NULL, newy=NULL, ...) { 720 | if (is.null(newx)) { 721 | newx = object$x 722 | y = object$y 723 | } else { 724 | if (is.null(newy)) {stop('please include newy')} 725 | y = newy 726 | } 727 | method = object$method 728 | method = c("backward", "forward", "proportional")[ 729 | charmatch(method, c("backward", "forward", "proportional")) 730 | ] 731 | y_levels = levels(object$y) 732 | k = length(y_levels) 733 | if ( is.numeric(newx) & !is.matrix(newx) ) 734 | newx = matrix(newx, ncol = dim(object$x)[2]) 735 | beta.est = object$beta 736 | 737 | # split betas into cutpoints, gene coefficients 738 | beta_genes = rownames(beta.est) 739 | cut_idx = str_detect(beta_genes, '^cp[0-9]+$') 740 | coeff_cuts = beta.est[cut_idx, ] 741 | coeff_genes = beta.est[!cut_idx, ] 742 | 743 | # restrict to common genes 744 | data_genes = colnames(newx) 745 | beta_genes = rownames(coeff_genes) 746 | missing_g = setdiff(beta_genes, data_genes) 747 | if (length(missing_g)>0) { 748 | # decide which to keep 749 | message(" these genes are missing from the input data and 750 | are not used for projecting:") 751 | message(' ', paste(missing_g, collapse=', '), sep='') 752 | message(" this may affect the projection\n") 753 | both_genes = intersect(beta_genes, data_genes) 754 | 755 | # tweak inputs accordingly 756 | newx = newx[, both_genes] 757 | coeff_genes = coeff_genes[both_genes, ] 758 | beta.est = rbind(coeff_genes, coeff_cuts) 759 | } 760 | stopifnot( (ncol(newx) + sum(cut_idx)) == nrow(beta.est)) 761 | 762 | # carry on 763 | n = dim(newx)[1] 764 | p = dim(newx)[2] 765 | y.mat = matrix(0, nrow = n, ncol = k) 766 | for (i in 1:n) { 767 | y.mat[i, which(y_levels==y[i])] = 1 768 | } 769 | n_lambdas = dim(beta.est)[2] 770 | n_nzero = apply(beta.est, 2, function(x) sum(x != 0)) 771 | glmnet.BIC = glmnet.AIC = numeric() 772 | pi = array(NA, dim=c(n, k, n_lambdas)) 773 | p.class = matrix(NA, nrow=n, ncol=n_lambdas) 774 | LL_mat = matrix(0, nrow=n, ncol=n_lambdas) 775 | LL = rep(NA, length=n_lambdas) 776 | # cycle through each value of lambda 777 | for (i in 1:n_lambdas) { 778 | # get beta estimates 779 | beta = beta.est[, i] 780 | logit = matrix(rep(0, n * (k - 1)), ncol=k - 1) 781 | # project x for each cutpoint 782 | b_by_x = beta[1:p] %*% t(as.matrix(newx)) 783 | for (j in 1:(k - 1)) { 784 | cp = paste("cp", j, sep = "") 785 | logit[, j] = object$a0[i] + beta[names(beta) == cp] + b_by_x 786 | } 787 | # do inverse logit 788 | delta = matrix(rep(0, n * (k - 1)), ncol = k - 1) 789 | for (j in 1:(k - 1)) { 790 | exp_val = exp(logit[, j]) 791 | delta[, j] = exp_val/(1 + exp_val) 792 | # check no infinite values 793 | if ( any(exp_val==Inf) ) { 794 | delta[exp_val==Inf, j] = 1 - 1e-16 795 | } 796 | } 797 | minus.delta = 1 - delta 798 | if (method == "backward") { 799 | for (j in k:2) { 800 | if (j == k) { 801 | pi[, j, i] = delta[, k - 1] 802 | } else if ( class(minus.delta[, j:(k - 1)]) == "numeric" ) { 803 | pi[, j, i] = delta[, j - 1] * minus.delta[, j] 804 | } else if (dim(minus.delta[, j:(k - 1)])[2] >= 2) { 805 | pi[, j, i] = delta[, j - 1] * 806 | apply(minus.delta[, j:(k - 1)], 1, prod) 807 | } 808 | } 809 | if (n == 1) { 810 | pi[, 1, i] = 1 - sum(pi[, 2:k, i]) 811 | } else { 812 | pi[, 1, i] = 1 - apply(pi[, 2:k, i], 1, sum) 813 | } 814 | } 815 | if (method == "forward") { 816 | for (j in 1:(k - 1)) { 817 | if (j == 1) { 818 | pi[, j, i] = delta[, j] 819 | } else if (j == 2) { 820 | pi[, j, i] = delta[, j] * minus.delta[, j - 1] 821 | } else if (j > 2 && j < k) { 822 | pi[, j, i] = delta[, j] * 823 | apply(minus.delta[, 1:(j - 1)], 1, prod) 824 | } 825 | } 826 | if (n == 1) { 827 | pi[, k, i] = 1 - sum(pi[, 1:(k - 1), i]) 828 | } else { 829 | pi[, k, i] = 1 - apply(pi[, 1:(k - 1), i], 1, sum) 830 | } 831 | } 832 | if (method == "proportional") { 833 | for (j in 1:k) { 834 | if (j == 1) { 835 | pi[, j, i] = minus.delta[, j] 836 | } else if (j > 1 && j < k) { 837 | pi[, j, i] = delta[, j - 1] - delta[, j] 838 | } else if (j == k) { 839 | pi[, j, i] = delta[, j-1] 840 | } 841 | } 842 | if (n == 1) { 843 | if ( abs(sum(pi[, , i])-1) > 1e-15 ) { 844 | warning('some probabilities didn\'t sum to one') 845 | # pi[, , i] = pi[, , i]/sum(pi[, , i]) 846 | } 847 | } else { 848 | if ( any(abs( rowSums(pi[, , i]) - 1 ) > 1e-15 ) ) { 849 | warning('some probabilities didn\'t sum to one') 850 | # pi[, , i] = sweep(pi[, , i], 1, rowSums(pi[, , i]), '/') 851 | } 852 | } 853 | } 854 | # calculate log likelihoods 855 | if (method == "backward") { 856 | for (j in 1:(k - 1)) { 857 | if ( is.matrix(y.mat[, 1:j]) ) { 858 | ylth = apply(y.mat[, 1:j], 1, sum)} 859 | else { 860 | ylth = y.mat[, 1] 861 | } 862 | LL_mat[, i] = LL_mat[, i] + log(delta[, j]) * y.mat[, j + 1] + 863 | log(1 - delta[, j]) * ylth 864 | } 865 | } 866 | if (method == "forward") { 867 | for (j in 1:(k - 1)) { 868 | if ( is.matrix(y.mat[, j:k]) ) { 869 | ygeh = apply(y.mat[, j:k], 1, sum) 870 | } else { 871 | ygeh = y.mat[, k] 872 | } 873 | LL_mat[, i] = LL_mat[, i] + log(delta[, j]) * y.mat[, j] + 874 | log(1 - delta[, j]) * ygeh 875 | } 876 | } 877 | if (method == "proportional") { 878 | for (j in 1:(k - 1)) { 879 | if ( is.matrix(y.mat[, j:k]) ) { 880 | ygeh = apply(y.mat[, j:k], 1, sum) 881 | } else { 882 | ygeh = y.mat[, k] 883 | } 884 | LL_mat[, i] = LL_mat[, i] + log(delta[, j]) * y.mat[, j] + 885 | log(1 - delta[, j]) * ygeh 886 | } 887 | } 888 | LL_temp = sum(LL_mat[, i]) 889 | glmnet.BIC[i] = -2 * LL_temp + n_nzero[i] * log(n) 890 | glmnet.AIC[i] = -2 * LL_temp + 2 * n_nzero[i] 891 | if (n == 1) { 892 | p.class[, i] = which.max(pi[, , i]) 893 | } else { 894 | p.class[, i] = apply(pi[, , i], 1, which.max) 895 | } 896 | } 897 | LL = colSums(LL_mat) 898 | class = matrix(y_levels[p.class], ncol = ncol(p.class)) 899 | names(glmnet.BIC) = names(glmnet.AIC) = names(object$a0) 900 | dimnames(p.class)[[2]] = dimnames(pi)[[3]] = names(object$a0) 901 | dimnames(pi)[[2]] = y_levels 902 | 903 | # output 904 | list( 905 | BIC = glmnet.BIC, 906 | AIC = glmnet.AIC, 907 | class = class, 908 | probs = pi, 909 | LL = LL, 910 | LL_mat = LL_mat 911 | ) 912 | } 913 | 914 | #' @importFrom data.table data.table 915 | #' @keywords internal 916 | .calc_scores_for_one_fit <- function(glmnet_fit, x_valid, y_valid) { 917 | # get predictions 918 | predictions = .predict_glmnetcr_propodds(glmnet_fit, x_valid, y_valid) 919 | pred_classes = predictions$class 920 | probs = predictions$probs 921 | lambdas = glmnet_fit$lambda 922 | 923 | class_levels = levels(y_valid) 924 | pred_int = apply(pred_classes, c(1,2), function(ij) which(ij==class_levels)) 925 | n_lambdas = ncol(pred_classes) 926 | 927 | # calculate various accuracy measures 928 | scores_mat = sapply( 929 | 1:n_lambdas, 930 | function(jj) .calc_multiple_scores(pred_classes[,jj], probs[,,jj], y_valid, class_levels) 931 | ) 932 | # store results 933 | scores_wide = data.table( 934 | lambda = lambdas 935 | ,t(scores_mat) 936 | ) 937 | scores_dt = melt(scores_wide, id='lambda', variable.name='score_var', value.name='score_val') 938 | 939 | # put scores in nice order 940 | scores_dt[, score_var := factor(score_var, levels=c('xentropy', 'class_error')) ] 941 | 942 | return(scores_dt) 943 | } 944 | 945 | #' @keywords internal 946 | .calc_multiple_scores <- function(pred_classes, probs, y_valid, class_levels) { 947 | # calculate some intermediate variables 948 | # y_valid_int = as.integer(y_valid) 949 | # pred_int = sapply(pred_classes, function(i) which(i==class_levels)) 950 | # bin_mat = t(sapply(pred_classes, function(i) i==class_levels)) 951 | bin_mat = t(sapply(y_valid, function(i) i==class_levels)) 952 | 953 | # calculate optional scores 954 | class_error = mean(pred_classes!=y_valid) 955 | xentropy = mean(.xentropy_fn(probs, bin_mat)) 956 | 957 | scores_vec = c( 958 | class_error = class_error, 959 | xentropy = xentropy 960 | ) 961 | 962 | return(scores_vec) 963 | } 964 | 965 | #' @keywords internal 966 | .xentropy_fn <- function(p_mat, bin_mat) { 967 | # calculate standard xentropy values 968 | xentropy = -rowSums(bin_mat * log2(p_mat), na.rm=TRUE) 969 | 970 | # deal with any -Inf values 971 | inf_idx = xentropy==Inf 972 | if ( sum(inf_idx) ) { 973 | xentropy[inf_idx] = -log2(1e-16) 974 | } 975 | 976 | return( xentropy ) 977 | } 978 | 979 | #' @keywords internal 980 | .calc_mean_train <- function(scores_train) { 981 | # calculate mean scores 982 | mean_train = scores_train[, 983 | list( 984 | mean = mean(score_val), 985 | se = sd(score_val)/sqrt(.N) 986 | ), 987 | by = list(lambda, score_var) 988 | ] 989 | 990 | # set up levels 991 | mean_train$score_var = factor(mean_train$score_var, levels=levels(scores_train$score_var)) 992 | 993 | return(mean_train) 994 | } 995 | 996 | #' @keywords internal 997 | .calc_best_lambdas <- function(mean_train) { 998 | # 999 | best_dt = mean_train[, 1000 | list( 1001 | best_lambda = .SD[ which.min(mean) ]$lambda, 1002 | next_lambda = max(.SD[ mean < min(mean) + se ]$lambda) 1003 | ), 1004 | by = score_var 1005 | ] 1006 | # get indices for lambdas 1007 | lambdas = rev(sort(unique(mean_train$lambda))) 1008 | best_dt[, best_idx := which(lambdas==best_lambda), by = score_var ] 1009 | best_dt[, next_idx := which(lambdas==next_lambda), by = score_var ] 1010 | 1011 | return(best_dt) 1012 | } 1013 | 1014 | #' @keywords internal 1015 | .get_best_lambdas <- function(best_dt, ps_params) { 1016 | # restrict to selected score, extract values 1017 | sel_score = ps_params$score 1018 | best_lambdas = list( 1019 | best_idx = best_dt[ score_var==sel_score ]$best_idx 1020 | ,next_idx = best_dt[ score_var==sel_score ]$next_idx 1021 | ,best_lambda = best_dt[ score_var==sel_score ]$best_lambda 1022 | ,next_lambda = best_dt[ score_var==sel_score ]$next_lambda 1023 | ) 1024 | if (ps_params$penalization=='1se') { 1025 | best_lambdas$which_idx = best_lambdas$next_idx 1026 | best_lambdas$which_lambda = best_lambdas$next_lambda 1027 | } else if (ps_params$penalization=='best') { 1028 | best_lambdas$which_idx = best_lambdas$best_idx 1029 | best_lambdas$which_lambda = best_lambdas$best_lambda 1030 | } else { 1031 | stop('invalid penalization') 1032 | } 1033 | return(best_lambdas) 1034 | } 1035 | 1036 | #' @keywords internal 1037 | .get_best_fit <- function(x_train, y_train, ps_params) { 1038 | message('fitting best model with all training data') 1039 | glmnet_best = .glmnetcr_propn( 1040 | x_train, y_train 1041 | ,method = ps_params$method 1042 | ,lambda = ps_params$lambdas 1043 | ,maxit = ps_params$max_iters 1044 | ) 1045 | return(glmnet_best) 1046 | } 1047 | 1048 | .make_scores_dt <- function(glmnet_best, x_test, y_test, scores_train) { 1049 | scores_test = .calc_scores_for_one_fit(glmnet_best, x_test, y_test) 1050 | scores_test[, fold := NA] 1051 | scores_test[, data := 'test' ] 1052 | scores_dt = rbind(scores_train, scores_test) 1053 | scores_dt[, data := factor(data, levels=c('train', 'test'))] 1054 | 1055 | return(scores_dt) 1056 | } 1057 | 1058 | #' @importFrom data.table data.table 1059 | #' @importFrom stringr str_detect 1060 | #' @keywords internal 1061 | .calc_proj_dt <- function(glmnet_best, x_data, y_labels, best_lambdas) { 1062 | # unpack 1063 | which_idx = best_lambdas$which_idx 1064 | 1065 | # get best one 1066 | cut_idx = str_detect(rownames(glmnet_best$beta), '^cp[0-9]+$') 1067 | beta_best = glmnet_best$beta[!cut_idx, which_idx] 1068 | 1069 | # remove any missing genes if necessary 1070 | coeff_genes = names(beta_best) 1071 | data_genes = colnames(x_data) 1072 | missing_genes = setdiff(coeff_genes, data_genes) 1073 | n_missing = length(missing_genes) 1074 | if ( n_missing>0 ) { 1075 | message(" these genes are missing from the input data and are not used for projecting:") 1076 | message(" ", paste(missing_genes[1:min(n_missing,20)], collapse=', '), sep='') 1077 | message(" this may affect the projection") 1078 | both_genes = intersect(coeff_genes, data_genes) 1079 | x_data = x_data[, both_genes] 1080 | beta_best = beta_best[both_genes] 1081 | } 1082 | 1083 | # a0_best = glmnet_best$a0[[which_idx]] 1084 | # y_proj = a0_best + x_data %*% matrix(beta_best, ncol=1) 1085 | psuper = x_data %*% matrix(beta_best, ncol=1) 1086 | predictions = .predict_glmnetcr_propodds(glmnet_best, x_data, y_labels) 1087 | pred_classes = factor(predictions$class[, which_idx], levels=levels(glmnet_best$y)) 1088 | 1089 | # put into data.table 1090 | proj_dt = data.table( 1091 | cell_id = rownames(x_data) 1092 | ,psuper = psuper[, 1] 1093 | ,label_input = y_labels 1094 | ,label_psuper = pred_classes 1095 | ) 1096 | 1097 | return(proj_dt) 1098 | } 1099 | 1100 | #' Extracts best coefficients. 1101 | #' 1102 | #' @importFrom data.table data.table 1103 | #' @importFrom data.table setorder 1104 | #' @importFrom stringr str_detect 1105 | #' @return data.table containing learned coefficients for all genes used as input. 1106 | #' @keywords internal 1107 | .make_best_beta <- function(glmnet_best, best_lambdas) { 1108 | cut_idx = str_detect(rownames(glmnet_best$beta), '^cp[0-9]+$') 1109 | best_beta = glmnet_best$beta[!cut_idx, best_lambdas$which_idx] 1110 | beta_dt = data.table( beta=best_beta, symbol=names(best_beta) ) 1111 | beta_dt[, abs_beta := abs(beta) ] 1112 | setorder(beta_dt, -abs_beta) 1113 | beta_dt[, symbol:=factor(symbol, levels=beta_dt$symbol)] 1114 | 1115 | return(beta_dt) 1116 | } 1117 | 1118 | #' @importFrom data.table data.table 1119 | #' @importFrom stringr str_detect 1120 | #' @keywords internal 1121 | .make_psuper_obj <- function(glmnet_best, x_data, y, x_test, y_test, test_idx, fold_list, proj_dt, beta_dt, best_lambdas, best_dt, scores_dt, ps_params) { 1122 | # make cuts_dt 1123 | which_idx = best_lambdas$which_idx 1124 | cut_idx = str_detect(rownames(glmnet_best$beta), '^cp[0-9]+$') 1125 | cuts_dt = data.table( 1126 | psuper = c(NA, -(glmnet_best$beta[ cut_idx, which_idx ] + glmnet_best$a0[[ which_idx ]])) 1127 | ,label_input = factor(levels(proj_dt$label_input), levels=levels(proj_dt$label_input)) 1128 | ) 1129 | 1130 | # what do we want here? 1131 | # for both best, and 1se 1132 | # best betas 1133 | # projection of original data 1134 | # probabilities for each label 1135 | # predicted labels 1136 | # which of best / 1se is in use 1137 | psuper_obj = list( 1138 | ps_params = ps_params 1139 | ,glmnet_best = glmnet_best 1140 | ,x_data = x_data 1141 | ,y = y 1142 | ,x_test = x_test 1143 | ,y_test = y_test 1144 | ,test_idx = test_idx 1145 | ,fold_list = fold_list 1146 | ,proj_dt = proj_dt 1147 | ,cuts_dt = cuts_dt 1148 | ,beta_dt = beta_dt 1149 | ,best_lambdas = best_lambdas 1150 | ,best_dt = best_dt 1151 | ,scores_dt = scores_dt 1152 | ) 1153 | 1154 | # make psupertime object 1155 | class(psuper_obj) = c('psupertime', class(psuper_obj)) 1156 | 1157 | return(psuper_obj) 1158 | } 1159 | 1160 | #' Text to summarize psupertime object 1161 | #' @keywords internal 1162 | .psummarize <- function(psuper_obj) { 1163 | # what trained on 1164 | n_cells = dim(psuper_obj$x_data)[1] 1165 | n_genes = psuper_obj$ps_params$n_genes 1166 | n_sel = dim(psuper_obj$x_data)[2] 1167 | sel_genes = psuper_obj$ps_params$sel_genes 1168 | 1169 | # labels used 1170 | label_order = paste(levels(psuper_obj$y), collapse=', ') 1171 | 1172 | # accuracy + sparsity 1173 | sel_lambda = psuper_obj$best_lambdas$which_lambda 1174 | mean_acc_dt = psuper_obj$scores_dt[ score_var=='class_error', list(mean_acc=mean(score_val)), by=list(lambda, data) ] 1175 | acc_train = 1 - mean_acc_dt[ lambda==sel_lambda & data=='train' ]$mean_acc 1176 | acc_test = 1 - mean_acc_dt[ lambda==sel_lambda & data=='test' ]$mean_acc 1177 | n_nzero = sum(psuper_obj$beta_dt$abs_beta>0) 1178 | sparse_prop = n_nzero / n_sel 1179 | 1180 | # define outputs 1181 | line_1 = sprintf('psupertime object using %d cells * %d genes as input\n', n_cells, n_genes) 1182 | line_2 = sprintf(' label ordering used for training: %s\n', label_order) 1183 | line_3 = sprintf(' genes selected for input: %s\n', sel_genes) 1184 | line_4 = sprintf(' # genes taken forward for training: %d\n', n_sel) 1185 | line_5 = sprintf(' # genes identified as relevant: %d (= %.0f%% of training genes)\n', n_nzero, 100*sparse_prop) 1186 | line_6 = sprintf(' mean training accuracy: %.0f%%\n', 100*acc_train) 1187 | line_7 = sprintf(' mean test accuracy: %.0f%%\n', 100*acc_test) 1188 | 1189 | # join lines together 1190 | psummary = paste(line_1, line_2, line_3, line_4, line_5, line_6, line_7, sep = "") 1191 | return(psummary) 1192 | } 1193 | 1194 | #' @export 1195 | print.psupertime <- function(psuper_obj) { 1196 | psummary = .psummarize(psuper_obj) 1197 | cat(psummary) 1198 | } 1199 | 1200 | #' @importFrom knitr asis_output 1201 | #' @keywords internal 1202 | knit_print.psupertime = function(psuper_obj, ...) { 1203 | psummary = psummarize(psuper_obj) 1204 | asis_output(psummary) 1205 | } 1206 | -------------------------------------------------------------------------------- /R/psupertime_plots.R: -------------------------------------------------------------------------------- 1 | # psupertime_plots.R 2 | 3 | #' Convenience function to do multiple plots 4 | #' 5 | #' @importFrom ggplot2 ggsave 6 | #' @param psuper_obj Psupertime object, output from psupertime 7 | #' @param output_dir Directory to save to 8 | #' @param tag Label for all files 9 | #' @param label_name Description for the ordered labels in the legend (e.g. 'Developmental stage (days)') 10 | #' @param ext Image format for outputs, compatible with ggsave (eps, ps, tex, pdf, jpeg, tiff, png, bmp, svg, wmf) 11 | #' @export 12 | psupertime_plot_all <- function(psuper_obj, output_dir='.', tag='', label_name='Ordered labels', ext='png') { 13 | # validate model 14 | cat('plotting results\n') 15 | g = plot_train_results(psuper_obj) 16 | plot_file = file.path(output_dir, sprintf('%s training results.%s', tag, ext)) 17 | ggsave(plot_file, g, height=6, width=6) 18 | 19 | g = plot_labels_over_psupertime(psuper_obj, label_name) 20 | plot_file = file.path(output_dir, sprintf('%s labels over psupertime.%s', tag, ext)) 21 | ggsave(plot_file, g, height=6, width=12) 22 | 23 | g = plot_identified_gene_coefficients(psuper_obj) 24 | plot_file = file.path(output_dir, sprintf('%s identified genes.%s', tag, ext)) 25 | ggsave(plot_file, g, height=6, width=8) 26 | 27 | g = plot_identified_genes_over_psupertime(psuper_obj, label_name) 28 | plot_file = file.path(output_dir, sprintf('%s identified genes over psupertime.%s', tag, ext)) 29 | ggsave(plot_file, g, height=8, width=12) 30 | 31 | g = plot_predictions_against_classes(psuper_obj) 32 | plot_file = file.path(output_dir, sprintf('%s predictions over psupertime, original data.%s', tag, ext)) 33 | ggsave(plot_file, g, height=6, width=10) 34 | } 35 | 36 | #' Plot results of training 37 | #' 38 | #' @param psuper_obj Psupertime object, output from psupertime 39 | #' @return ggplot2 object showing test and training performance of classifier. 40 | #' @export 41 | #' @importFrom ggplot2 aes 42 | #' @importFrom ggplot2 facet_grid 43 | #' @importFrom ggplot2 geom_line 44 | #' @importFrom ggplot2 geom_point 45 | #' @importFrom ggplot2 geom_linerange 46 | #' @importFrom ggplot2 geom_vline 47 | #' @importFrom ggplot2 ggplot 48 | #' @importFrom ggplot2 guides 49 | #' @importFrom ggplot2 labs 50 | #' @importFrom ggplot2 scale_colour_manual 51 | #' @importFrom ggplot2 scale_fill_brewer 52 | #' @importFrom ggplot2 scale_size_manual 53 | #' @importFrom ggplot2 theme_bw 54 | plot_train_results <- function(psuper_obj) { 55 | # unpack 56 | ps_params = psuper_obj$ps_params 57 | scores_dt = psuper_obj$scores_dt 58 | glmnet_best = psuper_obj$glmnet_best 59 | 60 | # add sparsity to plots 61 | sparse_dt = data.table( 62 | lambda = glmnet_best$lambda, 63 | score_var = 'sparsity', 64 | data = 'train', 65 | mean = apply(abs(glmnet_best$beta)>0, 2, sum), 66 | se = NA 67 | ) 68 | 69 | # calculate mean scores 70 | mean_scores = scores_dt[, 71 | list( 72 | mean = mean(score_val), 73 | se = sd(score_val)/sqrt(.N) 74 | ), 75 | by = list(lambda, score_var, data) 76 | ] 77 | 78 | # where should vertical lines go? 79 | lines_best = copy(psuper_obj$best_dt) 80 | dummy_dt = data.table(score_var=c('sparsity', 'xentropy', 'class_error')) 81 | lines_best = lines_best[ dummy_dt, on='score_var'] 82 | lines_best[, selected := score_var==ps_params$score ] 83 | 84 | # add nice labels for accuracy measures 85 | plot_dt = rbind(mean_scores, sparse_dt) 86 | measures_dt = data.table( 87 | score_var = c('xentropy', 'class_error', 'sparsity'), 88 | nice_score_var = c('Cross entropy', 'Classification error', 'Non-zero genes') 89 | ) 90 | plot_dt = measures_dt[plot_dt, on='score_var'] 91 | lines_best = measures_dt[lines_best, on='score_var'] 92 | 93 | # which measure used for model selection? 94 | nice_sel_var = measures_dt[ score_var==ps_params$score ]$nice_score_var 95 | 96 | # set up 97 | g = ggplot(plot_dt) + 98 | aes( x=log10(lambda), y=mean, colour=data ) 99 | 100 | # # plot each fold 101 | # g = g + geom_point(data=scores_dt, aes(fill=factor(fold), y=score_val), colour='transparent', shape=21 ) + 102 | # scale_fill_brewer( palette='Set1' ) 103 | 104 | # plot test and training data 105 | g = g + geom_linerange(aes(ymin=mean-se, ymax=mean+se) ) + 106 | geom_point() + 107 | geom_line() + 108 | scale_colour_manual( values=c('grey', 'black') ) 109 | 110 | # annotate with best lambdas, tidy up 111 | g = g + geom_vline(data=lines_best, aes(xintercept=log10(best_lambda), size=selected), colour='grey', linetype='solid' ) + 112 | geom_vline(data=lines_best, aes(xintercept=log10(next_lambda), size=selected), colour='grey', linetype='dashed' ) + 113 | scale_size_manual( values = c(0.5, 1) ) + 114 | guides( size=FALSE ) 115 | 116 | # label nicely 117 | g = g + 118 | facet_grid( nice_score_var ~ ., scales='free_y' ) + 119 | theme_bw() + 120 | labs( 121 | x = 'log10( lambda )' 122 | ,y = 'Accuracy measure' 123 | ,colour = 'Data' 124 | # ,fill = 'Fold' 125 | ,title = sprintf('%s used for model selection', nice_sel_var) 126 | ) + 127 | theme( 128 | plot.title = element_text( size=10, hjust=1 ) 129 | ) 130 | 131 | return(g) 132 | } 133 | 134 | #' Define RColorBrewer palette to use; default is RdBu. 135 | #' 136 | #' @importFrom RColorBrewer brewer.pal 137 | #' @importFrom grDevices colorRampPalette 138 | #' @param y_labels List of labels used for training 139 | #' @return Colour values 140 | #' @keywords internal 141 | .make_col_vals <- function(y_labels, palette='RdBu') { 142 | n_labels = length(levels(y_labels)) 143 | max_col = 11 144 | if (n_labels==1) { 145 | col_vals = brewer.pal(3, palette) 146 | col_vals = col_vals[1] 147 | } else if (n_labels==2) { 148 | col_vals = brewer.pal(3, palette) 149 | col_vals = col_vals[-2] 150 | } else if (n_labels<=max_col) { 151 | col_vals = brewer.pal(n_labels, palette) 152 | } else { 153 | col_pal = brewer.pal(max_col, palette) 154 | col_vals = colorRampPalette(col_pal)(n_labels) 155 | } 156 | col_vals = rev(col_vals) 157 | 158 | return(col_vals) 159 | } 160 | 161 | #' Plots labels over their projected values on psupertime. 162 | #' 163 | #' @param psuper_obj Psupertime object, output from psupertime 164 | #' @param label_name Description for the ordered labels in the legend (e.g. 'Developmental stage (days)') 165 | #' @param palette RColorBrewer palette to use 166 | #' @return ggplot2 object 167 | #' @export 168 | #' @importFrom ggplot2 aes 169 | #' @importFrom ggplot2 geom_density 170 | #' @importFrom ggplot2 geom_vline 171 | #' @importFrom ggplot2 ggplot 172 | #' @importFrom ggplot2 guide_legend 173 | #' @importFrom ggplot2 guides 174 | #' @importFrom ggplot2 labs 175 | #' @importFrom ggplot2 scale_colour_manual 176 | #' @importFrom ggplot2 scale_fill_manual 177 | #' @importFrom ggplot2 scale_x_continuous 178 | #' @importFrom scales pretty_breaks 179 | plot_labels_over_psupertime <- function(psuper_obj, label_name='Ordered labels', palette='RdBu') { 180 | # unpack 181 | proj_dt = psuper_obj$proj_dt 182 | cuts_dt = psuper_obj$cuts_dt 183 | 184 | # make nice colours 185 | col_vals = .make_col_vals(proj_dt$label_input, palette) 186 | 187 | # plot 188 | g = ggplot(proj_dt) + 189 | aes( x=psuper, fill=label_input, colour=label_input ) + 190 | geom_density( alpha=0.5 ) + 191 | scale_fill_manual( values=col_vals ) + 192 | geom_vline( data=cuts_dt, aes(xintercept=psuper, colour=label_input) ) + 193 | scale_colour_manual( values=col_vals ) + 194 | guides( 195 | fill = guide_legend(override.aes = list(alpha=1)) 196 | ,colour = FALSE 197 | ) + 198 | scale_x_continuous( breaks=pretty_breaks() ) + 199 | labs( 200 | x = 'psupertime' 201 | ,y = 'Density' 202 | ,fill = label_name 203 | ) + 204 | theme_bw() 205 | 206 | return(g) 207 | } 208 | 209 | #' Plots top coefficients 210 | #' 211 | #' @param psuper_obj Psupertime object, output from psupertime 212 | #' @return ggplot2 object 213 | #' @export 214 | #' @importFrom ggplot2 aes 215 | #' @importFrom ggplot2 element_text 216 | #' @importFrom ggplot2 geom_hline 217 | #' @importFrom ggplot2 geom_segment 218 | #' @importFrom ggplot2 geom_point 219 | #' @importFrom ggplot2 ggplot 220 | #' @importFrom ggplot2 labs 221 | #' @importFrom ggplot2 scale_y_continuous 222 | #' @importFrom ggplot2 theme 223 | #' @importFrom ggplot2 theme_bw 224 | #' @importFrom scales pretty_breaks 225 | plot_identified_gene_coefficients <- function(psuper_obj, n=20, abs_cutoff=0.05) { 226 | # prepare plot 227 | plot_dt = psuper_obj$beta_dt[ abs_beta > abs_cutoff ] 228 | plot_dt = plot_dt[ 1:min(n, nrow(plot_dt)) ] 229 | max_val = ceiling(max(plot_dt$abs_beta)*10)/10 230 | 231 | # plot 232 | g = ggplot(plot_dt) + 233 | aes( x=symbol, xend=symbol, y=beta, yend=0 ) + 234 | geom_segment( colour='black' ) + 235 | geom_point( colour='blue', size=5 ) + 236 | # geom_hline( yintercept=0, colour='grey' ) + 237 | scale_y_continuous( breaks=pretty_breaks(), limits=c(-max_val, max_val) ) + 238 | theme_bw() + 239 | theme( 240 | axis.text.x = element_text( angle=-45, hjust=0 ) 241 | ) + 242 | labs( 243 | x = 'Gene', 244 | y = 'Coefficient value' 245 | ) 246 | return(g) 247 | } 248 | 249 | #' Plots profiles of identified genes against psupertime. 250 | #' 251 | #' @param psuper_obj Psupertime object, output from psupertime 252 | #' @param label_name Description for the ordered labels in the legend (e.g. 'Developmental stage (days)') 253 | #' @param n_to_plot Maximum number of genes to plot (default 20) 254 | #' @param palette RColorBrewer palette to use 255 | #' @param plot_ratio ratio of columns to rows (default is 5:4) 256 | #' @return ggplot2 object 257 | #' @export 258 | #' @importFrom data.table data.table 259 | #' @importFrom data.table melt.data.table 260 | #' @importFrom ggplot2 aes 261 | #' @importFrom ggplot2 element_blank 262 | #' @importFrom ggplot2 facet_wrap 263 | #' @importFrom ggplot2 geom_point 264 | #' @importFrom ggplot2 geom_smooth 265 | #' @importFrom ggplot2 ggplot 266 | #' @importFrom ggplot2 labs 267 | #' @importFrom ggplot2 scale_colour_manual 268 | #' @importFrom ggplot2 scale_shape_manual 269 | #' @importFrom ggplot2 scale_x_continuous 270 | #' @importFrom ggplot2 scale_y_continuous 271 | #' @importFrom ggplot2 theme 272 | #' @importFrom ggplot2 theme_bw 273 | #' @importFrom scales pretty_breaks 274 | plot_identified_genes_over_psupertime <- function(psuper_obj, label_name='Ordered labels', n_to_plot=20, palette='RdBu', plot_ratio=1.25) { 275 | # unpack 276 | proj_dt = psuper_obj$proj_dt 277 | beta_dt = psuper_obj$beta_dt 278 | x_data = psuper_obj$x_data 279 | ps_params = psuper_obj$ps_params 280 | 281 | # aset 282 | beta_nzero = beta_dt[ abs_beta > 0 ] 283 | n_nzero = nrow(beta_nzero) 284 | top_genes = as.character(beta_nzero[1:min(n_to_plot, nrow(beta_nzero))]$symbol) 285 | 286 | # set up data for plotting 287 | plot_wide = cbind(proj_dt, data.table(x_data[, top_genes, drop=FALSE])) 288 | plot_dt = melt.data.table(plot_wide, id=c('cell_id', 'psuper', 'label_input', 'label_psuper'), measure=top_genes, variable.name='symbol') 289 | plot_dt[, symbol := factor(symbol, levels=top_genes)] 290 | 291 | # get colours 292 | col_vals = .make_col_vals(plot_dt$label_input, palette) 293 | n_genes = length(top_genes) 294 | ncol = ceiling(sqrt(n_genes*plot_ratio)) 295 | nrow = ceiling(n_genes/ncol) 296 | 297 | # plot 298 | g = ggplot(plot_dt) + 299 | aes( x=psuper, y=value) + 300 | geom_point( size=1, aes(colour=label_input) ) + 301 | geom_smooth(se=FALSE, colour='black') + 302 | scale_colour_manual( values=col_vals ) + 303 | scale_shape_manual( values=c(1, 16) ) + 304 | scale_x_continuous( breaks=pretty_breaks() ) + 305 | scale_y_continuous( breaks=pretty_breaks() ) + 306 | facet_wrap( ~ symbol, scales='free_y', nrow=nrow, ncol=ncol ) + 307 | theme_bw() + 308 | theme( 309 | axis.text.x = element_blank() 310 | ) + 311 | labs( 312 | x = 'psupertime' 313 | ,y = 'z-scored log2 expression' 314 | ,colour = label_name 315 | ) 316 | return(g) 317 | } 318 | 319 | #' Plots profiles of hand-selected genes against psupertime. 320 | #' 321 | #' @param psuper_obj psupertime object, output from psupertime 322 | #' @param extra_genes List of genes to be plotted (these must be in the set of genes used for calculating psupertime, e.g. highly variable genes) 323 | #' @param label_name Description for the ordered labels in the legend (e.g. 'Developmental stage (days)') 324 | #' @param palette RColorBrewer palette to use 325 | #' @param plot_ratio ratio of columns to rows (default is 5:4) 326 | #' @return ggplot2 object 327 | #' @export 328 | #' @importFrom data.table data.table 329 | #' @importFrom data.table melt.data.table 330 | #' @importFrom ggplot2 aes 331 | #' @importFrom ggplot2 element_blank 332 | #' @importFrom ggplot2 facet_wrap 333 | #' @importFrom ggplot2 geom_point 334 | #' @importFrom ggplot2 geom_smooth 335 | #' @importFrom ggplot2 ggplot 336 | #' @importFrom ggplot2 labs 337 | #' @importFrom ggplot2 scale_colour_manual 338 | #' @importFrom ggplot2 scale_x_continuous 339 | #' @importFrom ggplot2 scale_y_continuous 340 | #' @importFrom ggplot2 theme 341 | #' @importFrom ggplot2 theme_bw 342 | #' @importFrom scales pretty_breaks 343 | plot_specified_genes_over_psupertime <- function(psuper_obj, extra_genes, label_name='Ordered labels', palette='RdBu', plot_ratio=1.25) { 344 | # unpack 345 | proj_dt = psuper_obj$proj_dt 346 | beta_dt = psuper_obj$beta_dt 347 | x_data = psuper_obj$x_data 348 | ps_params = psuper_obj$ps_params 349 | 350 | # restrict to specified genes 351 | extra_genes = intersect(extra_genes, colnames(x_data)) 352 | if (length(extra_genes)==0) { 353 | warning('genes not found; did not plot') 354 | return() 355 | } 356 | 357 | # set up data 358 | plot_wide = cbind(proj_dt, data.table(x_data[, extra_genes, drop=FALSE])) 359 | plot_dt = melt.data.table( 360 | plot_wide, 361 | id = c("psuper", "label_input", "label_psuper"), 362 | measure = extra_genes, 363 | variable.name = "symbol" 364 | ) 365 | plot_dt[, `:=`(symbol, factor(symbol, levels = extra_genes))] 366 | 367 | # set up plot 368 | col_vals = .make_col_vals(plot_dt$label_input, palette) 369 | n_genes = length(extra_genes) 370 | ncol = ceiling(sqrt(n_genes*plot_ratio)) 371 | nrow = ceiling(n_genes/ncol) 372 | 373 | # plot 374 | g = ggplot(plot_dt) + 375 | aes( x=psuper, y=value ) + 376 | geom_point( size=1, aes(colour=label_input) ) + 377 | geom_smooth(se=FALSE, colour='black') + 378 | scale_colour_manual( values=col_vals ) + 379 | scale_x_continuous( breaks=pretty_breaks() ) + 380 | scale_y_continuous( breaks=pretty_breaks() ) + 381 | facet_wrap( ~ symbol, scales='free_y', nrow=nrow, ncol=ncol ) + 382 | theme_bw() + 383 | theme( 384 | axis.text.x = element_blank() 385 | ) + 386 | labs( 387 | x = 'psupertime' 388 | ,y = 'z-scored log2 expression' 389 | ,colour = label_name 390 | ) 391 | return(g) 392 | } 393 | 394 | #' @keywords internal 395 | .process_new_data <- function(psuper_obj, new_x) { 396 | # process new_x 397 | params_copy = psuper_obj$ps_params 398 | params_copy$sel_genes = 'list' 399 | params_copy$gene_list = colnames(psuper_obj$x_data) 400 | params_copy$min_expression = 0 401 | sel_genes = .select_genes(new_x, params_copy) 402 | new_data = .make_x_data(new_x, sel_genes, params_copy) 403 | return(new_data) 404 | } 405 | 406 | #' Gives projection of data onto psupertime (either using original data, or new data) 407 | #' 408 | #' @param psuper_obj Psupertime object, output from psupertime 409 | #' @param new_x, new_y Optional pair of new data and labels 410 | #' @return data.table with projection and labels 411 | #' @export 412 | project_onto_psupertime <- function(psuper_obj, new_x=NULL, new_y=NULL, process=FALSE) { 413 | # unpack 414 | glmnet_best = psuper_obj$glmnet_best 415 | best_lambdas = psuper_obj$best_lambdas 416 | 417 | # project new data 418 | if ( is.null(new_x) & is.null(new_y) ) { 419 | x_in = psuper_obj$x_data 420 | y_in = psuper_obj$y 421 | } else if ( !is.null(new_x) & !is.null(new_y) ) { 422 | if (process==TRUE) { 423 | x_in = .process_new_data(psuper_obj, new_x) 424 | } else { 425 | x_in = new_x 426 | } 427 | if (!is.factor(new_y)) { 428 | new_y = factor(new_y) 429 | message('converting new_y into factor, with the following ordered values:') 430 | message(paste(levels(new_y), ', ')) 431 | message('(define new_y as a factor if you prefer a different ordering)') 432 | } 433 | y_in = factor(new_y) 434 | } else { 435 | stop('either both of new_x and new_y must be given, or neither') 436 | } 437 | 438 | proj_dt = .calc_proj_dt(glmnet_best, x_in, y_in, best_lambdas) 439 | 440 | return(proj_dt) 441 | } 442 | 443 | #' Plots profiles of hand-selected genes against psupertime. 444 | #' 445 | #' @param psuper_obj Psupertime object, output from psupertime 446 | #' @param new_x,new_y Optional data to predict with psuper_obj 447 | #' @param palette RColorBrewer palette to use 448 | #' @return ggplot2 object 449 | #' @export 450 | #' @importFrom cowplot plot_grid 451 | #' @importFrom ggplot2 ggplot 452 | #' @importFrom ggplot2 aes_string 453 | #' @importFrom ggplot2 geom_raster 454 | #' @importFrom ggplot2 scale_fill_distiller 455 | #' @importFrom ggplot2 expand_limits 456 | #' @importFrom ggplot2 labs 457 | #' @importFrom ggplot2 theme_bw 458 | #' @importFrom scales pretty_breaks 459 | plot_new_data_over_psupertime <- function(psuper_obj, new_x, new_y, labels=c('Original', 'New data'), palette='BrBG', process=FALSE) { 460 | # project new data 461 | proj_new = project_onto_psupertime(psuper_obj, new_x, new_y, process) 462 | 463 | # make nice colours 464 | col_vals = .make_col_vals(proj_new$label_input, palette) 465 | 466 | # get cutpoints 467 | cuts_dt = psuper_obj$cuts_dt 468 | 469 | # do plot 470 | x_label = sprintf('psupertime trained on %s', labels[[1]]) 471 | g1 = plot_labels_over_psupertime(psuper_obj, label_name=labels[[1]]) + 472 | xlab( x_label ) 473 | g2 = ggplot(proj_new) + 474 | aes( x=psuper, fill=label_input, colour=label_input) + 475 | geom_density( alpha=0.5 ) + 476 | geom_vline( data=cuts_dt, aes(xintercept=psuper), colour='black' ) + 477 | scale_fill_manual( values=col_vals ) + 478 | scale_colour_manual( values=col_vals ) + 479 | guides( 480 | fill = guide_legend(override.aes = list(alpha=1)) 481 | ,colour = FALSE 482 | ) + 483 | scale_x_continuous( breaks=pretty_breaks() ) + 484 | labs( 485 | x = x_label 486 | ,y = 'Density' 487 | ,fill = labels[[2]] 488 | ) + 489 | theme_bw() 490 | 491 | # give same x range 492 | proj_orig = psuper_obj$proj_dt 493 | x_range = c( 494 | floor(min(quantile(proj_new$psuper, prob=0.01), quantile(proj_orig$psuper, prob=0.01))), 495 | ceiling(max(quantile(proj_new$psuper, 0.99), quantile(proj_orig$psuper, 0.99))) 496 | ) 497 | g1 = g1 + coord_cartesian( xlim=x_range ) 498 | g2 = g2 + coord_cartesian( xlim=x_range ) 499 | 500 | # put into grid 501 | g = plot_grid(plotlist=list(g1, g2), labels=NULL, nrow=2, ncol=1, align='v', axis='lr') 502 | 503 | return(g) 504 | } 505 | 506 | 507 | #' Check variables for confusion matrices 508 | #' 509 | #' @param plot_var Variable to plot: prop_true is proportion of true labels, prop_predict is proportion of predicted labels, N is # of cells 510 | #' @return list with checked plot_var, and nice label 511 | #' @internal 512 | .check_conf_params <- function(plot_var) { 513 | plot_var_list = c('prop_true', 'N', 'prop_predict') 514 | plot_var = match.arg(plot_var, plot_var_list) 515 | labels_list = c(prop_true='Proportion\nof labelled\nclass\n', N='# of cells', prop_predict='Proportion\nof predicted\nclass\n') 516 | plot_label = labels_list[[plot_var]] 517 | 518 | return( list(plot_var=plot_var, plot_label=plot_label) ) 519 | } 520 | 521 | #' Plots confusion matrix of true labels against predicted labels. 522 | #' 523 | #' @param psuper_obj Psupertime object, output from psupertime 524 | #' @param new_x,new_y Optional data to predict with psuper_obj 525 | #' @param plot_var Variable to plot: prop_true is proportion of true labels, prop_predict is proportion of predicted labels, N is # of cells 526 | #' @param palette RColorBrewer palette to use 527 | #' @return ggplot2 object 528 | #' @export 529 | #' @importFrom data.table data.table 530 | #' @importFrom ggplot2 aes 531 | #' @importFrom ggplot2 expand_limits 532 | #' @importFrom ggplot2 geom_text 533 | #' @importFrom ggplot2 geom_raster 534 | #' @importFrom ggplot2 ggplot 535 | #' @importFrom ggplot2 labs 536 | #' @importFrom ggplot2 scale_fill_distiller 537 | #' @importFrom ggplot2 scale_x_discrete 538 | #' @importFrom ggplot2 theme_bw 539 | #' @importFrom scales pretty_breaks 540 | plot_predictions_against_classes <- function(psuper_obj, new_x=NULL, new_y=NULL, process=FALSE, plot_var='prop_true', palette='BuPu') { 541 | # decide what to plot 542 | conf_params = .check_conf_params(plot_var) 543 | plot_var = conf_params$plot_var 544 | plot_label = conf_params$plot_label 545 | 546 | # unpack 547 | which_idx = psuper_obj$best_lambdas$which_idx 548 | glmnet_best = psuper_obj$glmnet_best 549 | 550 | # define fn to handle y 551 | .get_y_in <- function(new_y) { 552 | if (is.null(new_x)) { 553 | if ( length(new_y) != length(psuper_obj$y) ) { 554 | stop('when no new_x given, new_y must be same length as original y') 555 | } 556 | } 557 | if (!is.factor(new_y)) { 558 | new_y = factor(new_y) 559 | message('converting new_y into factor, with the following ordered values:') 560 | message(paste(levels(new_y), ', ')) 561 | message('(define new_y as a factor if you prefer a different ordering)') 562 | } 563 | y_in = factor(new_y) 564 | return(y_in) 565 | } 566 | 567 | # what inputs to use? 568 | if ( is.null(new_x) & is.null(new_y) ) { 569 | x_in = psuper_obj$x_data 570 | y_in = psuper_obj$y 571 | 572 | } else if ( is.null(new_x) & !is.null(new_y) ) { 573 | x_in = psuper_obj$x_data 574 | y_in = .get_y_in(new_y) 575 | 576 | } else if ( !is.null(new_x) & !is.null(new_y) ) { 577 | x_in = .process_new_data(psuper_obj, new_x) 578 | y_in = .get_y_in(new_y) 579 | 580 | } else if ( !is.null(new_x) & is.null(new_y) ) { 581 | stop('to use new_x, new_y must also be given') 582 | 583 | } else { 584 | stop('aargh some unexpected error') 585 | } 586 | 587 | # get predicted classes for each thing 588 | predictions = .predict_glmnetcr_propodds(glmnet_best, x_in, y_in) 589 | pred_classes = factor(predictions$class[, which_idx], levels=levels(psuper_obj$y)) 590 | predict_dt = data.table( predicted=pred_classes, true=y_in ) 591 | 592 | # count and average 593 | counts_dt = predict_dt[, .N, by=list(predicted, true)] 594 | counts_dt[, prop_true := N / sum(N), by=true ] 595 | counts_dt[, prop_predict := N / sum(N), by=predicted ] 596 | 597 | # define where borders should be 598 | borders_dt = counts_dt[as.character(true)==as.character(predicted), list(true, predicted) ] 599 | 600 | # plot grid 601 | g = ggplot(counts_dt) + 602 | aes( y=true, x=predicted ) + 603 | geom_tile( aes_string(fill=plot_var) ) + 604 | geom_tile(data=borders_dt, aes(y=true, x=predicted), fill=NA, colour='black', size=0.5) + 605 | geom_text( aes(label=N) ) + 606 | scale_x_discrete( drop=FALSE ) + 607 | scale_fill_distiller( palette=palette, direction=1, breaks=pretty_breaks() ) 608 | if (plot_var=='N') { 609 | g = g + expand_limits( fill=0 ) 610 | } else { 611 | g = g + expand_limits( fill=c(0,1) ) 612 | } 613 | g = g + labs( 614 | x = 'Predicted class' 615 | ,y = 'Labelled class' 616 | ,fill = plot_label 617 | ) + 618 | theme_bw() 619 | return(g) 620 | } 621 | 622 | #' Projects two different psupertimes onto each other 623 | #' 624 | #' @importFrom forcats fct_drop 625 | #' @param psuper_1, psuper_2 Two previously calculated psupertime objects 626 | #' @param labels Character vector of length two, labelling the psupertime inputs 627 | #' @return data.table containing projections in both directions 628 | #' @export 629 | double_psupertime <- function(psuper_1, psuper_2, run_names=NULL, process=FALSE) { 630 | # check run_names 631 | if ( is.null(run_names) ) { 632 | run_names = c('1','2') 633 | message('using default values for run_names:', paste(run_names, sep=', ')) 634 | } else { 635 | if ( !is.character(run_names) | length(unique(run_names))!=2 ) { 636 | stop('run_names must be character vector of length two with no repeated values') 637 | } 638 | } 639 | 640 | # repack 641 | psuper_list = list(psuper_1, psuper_2) 642 | n_psupers = length(psuper_list) 643 | # names(psuper_list) = run_names 644 | 645 | # loop through projections on both 646 | doubles_dt = data.table() 647 | for (ii in 1:n_psupers) { 648 | # unload 649 | psuper_ii = psuper_list[[ii]] 650 | label_ii = run_names[[ii]] 651 | 652 | for (jj in 1:n_psupers) { 653 | # unload 654 | psuper_jj = psuper_list[[jj]] 655 | label_jj = run_names[[jj]] 656 | 657 | # get appropriate projection 658 | if (ii == jj) { 659 | proj_ii_on_jj = psuper_ii$proj_dt 660 | } else { 661 | proj_ii_on_jj = project_onto_psupertime(psuper_jj, psuper_ii$x_data, psuper_ii$y, process) 662 | } 663 | 664 | # label 665 | proj_ii_on_jj[, input := label_ii ] 666 | proj_ii_on_jj[, projection := label_jj ] 667 | n_digits = ceiling(log10(nrow(psuper_ii$x_data))) 668 | proj_ii_on_jj[, cell_id := sprintf(sprintf('%%s_%%0%dd', n_digits), label_ii, 1:nrow(psuper_ii$x_data)) ] 669 | 670 | # store 671 | doubles_dt = rbind(doubles_dt, proj_ii_on_jj) 672 | } 673 | } 674 | 675 | # sort out levels 676 | lvls_all = c() 677 | for (ii in 1:n_psupers) { 678 | lvls_temp = setdiff(levels(psuper_list[[ii]]$y), lvls_all) 679 | lvls_all = c(lvls_all, lvls_temp) 680 | } 681 | doubles_dt[, label_input := factor(label_input, levels=lvls_all) ] 682 | 683 | # make wide, sort out levels? 684 | doubles_wide = dcast(doubles_dt, input + cell_id + label_input ~ projection, value.var=c('psuper', 'label_psuper')) 685 | for (ii in 1:n_psupers) { 686 | label = run_names[[ii]] 687 | doubles_wide[[ paste0('label_psuper_', label) ]] = fct_drop(doubles_wide[[ paste0('label_psuper_', label) ]]) 688 | # levels(doubles_wide[[ paste0('label_psuper_', label) ]]) = levels(psuper_list[[ii]]$y) 689 | } 690 | 691 | # make lists of levels 692 | levels_list = lapply(psuper_list, function(p) levels(p$y) ) 693 | names(levels_list) = run_names 694 | 695 | # put into list 696 | double_obj = list( 697 | run_names = run_names 698 | ,levels_list = levels_list 699 | ,doubles_dt = doubles_dt 700 | ,doubles_wide = doubles_wide 701 | ) 702 | return(double_obj) 703 | } 704 | 705 | #' Projects two different psupertimes onto each other, using points, side by side 706 | #' 707 | #' To do this, psupertime builds an internal \code{double_psupertime} object containing 708 | #' the projections. Given two psupertime objects \code{psuper_1} and \code{psuper_2}, you can 709 | #' call it in two ways: 710 | #' 711 | #' (1) By specifying the two psupertime objects you want to project: 712 | #' \code{plot_double_psupertime(psuper_1=psuper_1, psuper_2=psuper_2)} 713 | #' 714 | #' (2) Or by first constructing a \code{double_psupertime} object: 715 | #' \code{double_obj = double_psupertime(psuper_1, psuper_2)} 716 | #' \code{plot_double_psupertime(double_obj=double_obj)} 717 | #' 718 | #' For the coefficients of the two objects to be meaningfully applied to each 719 | #' other, the data needs to have been processed in the same way for each. We 720 | #' therefore recommend first preprocessing the data (either via \code{psupertime}'s 721 | #' defaults, or via your preferred method, then running \code{psupertime} with 722 | #' \code{smooth=FALSE} and \code{scale=FALSE}. 723 | #' 724 | #' @param double_obj Result of applying double_psupertime to two previously calculated psupertime objects 725 | #' @param psuper_1, psuper_2 Two previously calculated psupertime objects 726 | #' @param run_names Character vector of length two, labelling the psupertime inputs 727 | #' @return ggplot object plotting the two against each other 728 | #' @export 729 | #' @importFrom ggplot2 aes_string 730 | #' @importFrom ggplot2 facet_grid 731 | #' @importFrom ggplot2 geom_point 732 | #' @importFrom ggplot2 ggplot 733 | #' @importFrom ggplot2 labs 734 | #' @importFrom ggplot2 scale_colour_manual 735 | #' @importFrom ggplot2 theme_bw 736 | plot_double_psupertime <- function(double_obj=NULL, psuper_1=NULL, psuper_2=NULL, run_names=NULL, process=FALSE) { 737 | # check inputs 738 | if (is.null(double_obj)) { 739 | if ( is.null(psuper_1) | is.null(psuper_2) ) { 740 | stop('either a double_obj must be given, or psuper_1 and psuper_2 must both be given') 741 | } else { 742 | double_obj = double_psupertime(psuper_1, psuper_2, run_names, process) 743 | } 744 | } 745 | 746 | # unpack 747 | run_names = double_obj$run_names 748 | label_x = run_names[[1]] 749 | label_y = run_names[[2]] 750 | doubles_wide = double_obj$doubles_wide 751 | 752 | # make colours 753 | col_vals = .make_col_vals(doubles_wide$label_input) 754 | 755 | # add facet labels 756 | plot_dt = copy(doubles_wide) 757 | plot_dt[, input_label := paste0('Input data: ', input) ] 758 | 759 | # do some plotting 760 | g = ggplot(plot_dt) + 761 | aes_string( 762 | x = paste0('psuper_', label_x) 763 | ,y = paste0('psuper_', label_y) 764 | ,colour = paste0('label_input') 765 | ) + 766 | geom_point() + 767 | scale_colour_manual( values=col_vals ) + 768 | facet_grid( . ~ input_label) + 769 | theme_bw() + 770 | labs( 771 | x = paste0('Psupertime trained on ', label_x) 772 | ,y = paste0('Psupertime trained on ', label_y) 773 | ,colour = 'Known\nlabels' 774 | ) 775 | 776 | return(g) 777 | } 778 | 779 | #' Projects two different psupertimes on top of each other 780 | #' 781 | #' See `plot_double_psupertime` for further detail. 782 | #' 783 | #' @param double_obj Result of applying double_psupertime to two previously calculated psupertime objects 784 | #' @param psuper_1, psuper_2 Two previously calculated psupertime objects 785 | #' @param run_names Character vector of length two, labelling the psupertime inputs 786 | #' @return ggplot object plotting the two against each other 787 | #' @export 788 | #' @importFrom ggplot2 aes_string 789 | #' @importFrom ggplot2 geom_density2d 790 | #' @importFrom ggplot2 ggplot 791 | #' @importFrom ggplot2 labs 792 | #' @importFrom ggplot2 scale_colour_brewer 793 | #' @importFrom ggplot2 theme_bw 794 | plot_double_psupertime_contour <- function(double_obj=NULL, psuper_1=NULL, psuper_2=NULL, run_names=NULL) { 795 | # check run_names 796 | if ( is.null(run_names) ) { 797 | run_names = c('1','2') 798 | message('using default values for run_names:', paste(run_names, sep=', ')) 799 | } else { 800 | if ( !is.character(run_names) | length(unique(run_names))!=2 ) { 801 | stop('run_names must be character vector of length two with no repeated values') 802 | } 803 | } 804 | # check inputs 805 | if (is.null(double_obj)) { 806 | if ( is.null(psuper_1) | is.null(psuper_2) ) { 807 | stop('either a double_obj must be given, or psuper_1 and psuper_2 must both be given') 808 | } else { 809 | double_obj = double_psupertime(psuper_1, psuper_2, run_names) 810 | } 811 | } 812 | 813 | # unpack 814 | run_names = double_obj$run_names 815 | label_x = run_names[[1]] 816 | label_y = run_names[[2]] 817 | doubles_wide = double_obj$doubles_wide 818 | 819 | # do some plotting 820 | g = ggplot(doubles_wide) + 821 | aes_string( 822 | x = paste0('psuper_', label_x) 823 | ,y = paste0('psuper_', label_y) 824 | ,colour = 'input' 825 | ) + 826 | geom_density2d() + 827 | scale_colour_brewer( palette='Set1' ) + 828 | theme_bw() + 829 | labs( 830 | x = paste0('Psupertime run on ', label_x) 831 | ,y = paste0('Psupertime run on ', label_y) 832 | ,colour = 'Input\ndata' 833 | ) 834 | 835 | return(g) 836 | } 837 | 838 | #' Compares coefficients for genes learned from different psupertimes 839 | #' 840 | #' @param psuper_1, psuper_2 Two previously calculated psupertime objects 841 | #' @param run_names Character vector of length two, labelling the psupertime inputs 842 | #' @return ggplot object plotting the two sets of coefficients 843 | #' @export 844 | #' @importFrom data.table setnames 845 | #' @importFrom ggplot2 aes 846 | #' @importFrom ggplot2 aes 847 | #' @importFrom ggplot2 geom_point 848 | #' @importFrom ggplot2 ggplot 849 | #' @importFrom ggplot2 labs 850 | #' @importFrom ggplot2 theme_bw 851 | plot_double_psupertime_genes <- function(psuper_1, psuper_2, run_names=NULL) { 852 | # check run_names 853 | if ( is.null(run_names) ) { 854 | run_names = c('1','2') 855 | message('using default values for run_names:', paste(run_names, sep=', ')) 856 | } else { 857 | if ( !is.character(run_names) | length(unique(run_names))!=2 ) { 858 | stop('run_names must be character vector of length two with no repeated values') 859 | } 860 | } 861 | 862 | # get genes from both 863 | old_names = c('beta', 'abs_beta') 864 | genes_1_dt = psuper_1$beta_dt[ abs_beta > 0 ] 865 | setnames(genes_1_dt, old_names, paste0(old_names, '_1')) 866 | genes_2_dt = psuper_2$beta_dt[ abs_beta > 0 ] 867 | setnames(genes_2_dt, old_names, paste0(old_names, '_2')) 868 | 869 | # join together, tidy up 870 | genes_dt = merge(genes_1_dt, genes_2_dt, by='symbol', all=TRUE, ) 871 | genes_dt[ is.na(beta_1), beta_1 := 0 ] 872 | genes_dt[ is.na(abs_beta_1), abs_beta_1 := 0 ] 873 | genes_dt[ is.na(beta_2), beta_2 := 0 ] 874 | genes_dt[ is.na(abs_beta_2), abs_beta_2 := 0 ] 875 | 876 | # plot 877 | g = ggplot(genes_dt) + 878 | aes( x=beta_1, y=beta_2 ) + 879 | geom_point( alpha=0.5 ) + 880 | theme_bw() + 881 | labs( 882 | x = paste0('Coefficient for ', run_names[[1]]) 883 | ,y = paste0('Coefficient for ', run_names[[2]]) 884 | ) 885 | 886 | return(g) 887 | } 888 | 889 | #' Plots the confusion matrices of two psupertime objects against each other 890 | #' 891 | #' See `plot_double_psupertime` for further detail. 892 | #' 893 | #' @param double_obj Result of applying double_psupertime to two previously calculated psupertime objects 894 | #' @param psuper_1, psuper_2 Two previously calculated psupertime objects 895 | #' @param run_names Character vector of length two, labelling the psupertime inputs 896 | #' @param palette RColorBrewer palette to use 897 | #' @return cowplot plot_grid object, showing known and predicted labels for each dataset, and each set of predictions 898 | #' @export 899 | #' @importFrom cowplot plot_grid 900 | #' @importFrom forcats fct_drop 901 | #' @importFrom ggplot2 aes 902 | #' @importFrom ggplot2 aes_string 903 | #' @importFrom ggplot2 expand_limits 904 | #' @importFrom ggplot2 geom_text 905 | #' @importFrom ggplot2 geom_tile 906 | #' @importFrom ggplot2 ggplot 907 | #' @importFrom ggplot2 labs 908 | #' @importFrom ggplot2 scale_fill_distiller 909 | #' @importFrom ggplot2 scale_x_discrete 910 | #' @importFrom ggplot2 theme_bw 911 | #' @importFrom scales pretty_breaks 912 | plot_double_psupertime_confusion <- function(double_obj=NULL, psuper_1=NULL, psuper_2=NULL, run_names=NULL, plot_var='prop_true', palette='BuPu') { 913 | if ( !requireNamespace("cowplot", quietly=TRUE) ) { 914 | message('cowplot not installed; not plotting confusion matrix') 915 | return() 916 | } 917 | 918 | # decide what to plot 919 | conf_params = .check_conf_params(plot_var) 920 | plot_var = conf_params$plot_var 921 | plot_label = conf_params$plot_label 922 | 923 | # check inputs 924 | if (is.null(double_obj)) { 925 | if ( is.null(psuper_1) | is.null(psuper_2) ) { 926 | stop('either a double_obj must be given, or psuper_1 and psuper_2 must both be given') 927 | } else { 928 | double_obj = double_psupertime(psuper_1, psuper_2, run_names) 929 | } 930 | } 931 | 932 | # unpack 933 | run_names = double_obj$run_names 934 | label_x = run_names[[1]] 935 | label_y = run_names[[2]] 936 | doubles_dt = double_obj$doubles_dt 937 | 938 | # set up 939 | input_list = unique(doubles_dt$input) 940 | n_inputs = length(input_list) 941 | proj_list = unique(doubles_dt$projection) 942 | n_projs = length(proj_list) 943 | g_list = list() 944 | 945 | # get factor lists 946 | levels_list = double_obj$levels_list 947 | 948 | # do multiple plots 949 | for (ii in 1:n_inputs) { 950 | for (jj in 1:n_projs) { 951 | # restrict to this combo of inputs/predictions 952 | input_ii = input_list[[ii]] 953 | psuper_jj = proj_list[[jj]] 954 | counts_dt = doubles_dt[ input==input_ii & projection==psuper_jj, .N, by=list(label_input, label_psuper) ] 955 | 956 | # calculate proportions 957 | counts_dt[, prop_true := N / sum(N), by=label_input ] 958 | counts_dt[, prop_predict := N / sum(N), by=label_psuper ] 959 | 960 | # tidy up labels 961 | counts_dt[, label_input := fct_drop(label_input) ] 962 | counts_dt[, label_input := factor(label_input, levels=levels_list[[input_ii]])] 963 | counts_dt[, label_psuper := fct_drop(label_psuper) ] 964 | counts_dt[, label_psuper := factor(label_psuper, levels=levels_list[[psuper_jj]])] 965 | 966 | # define where borders should be 967 | borders_dt = counts_dt[as.character(label_input)==as.character(label_psuper), list(label_input, label_psuper) ] 968 | 969 | # plot grid 970 | g = ggplot(counts_dt) + 971 | aes( y=label_input, x=label_psuper ) + 972 | geom_tile( aes_string(fill=plot_var) ) + 973 | geom_tile(data=borders_dt, aes(y=label_input, x=label_psuper), fill=NA, colour='black', size=0.5) + 974 | geom_text( aes(label=N) ) + 975 | scale_x_discrete( drop=FALSE ) + 976 | scale_fill_distiller( palette=palette, direction=1, breaks=pretty_breaks(), guide=FALSE ) + 977 | theme_bw() 978 | 979 | # colouring for tiles 980 | if (plot_var=='N') { 981 | g = g + expand_limits( fill=0 ) 982 | } else { 983 | g = g + expand_limits( fill=c(0,1) ) 984 | } 985 | 986 | # x, y labels 987 | if ( ii==n_inputs ) { 988 | g = g + labs( x=paste0('Predicted: ', run_names[[jj]]) ) 989 | } else { 990 | g = g + labs( x=NULL ) 991 | } 992 | if ( jj==1 ) { 993 | g = g + labs( y=paste0('Known: ', run_names[[ii]]) ) 994 | } else { 995 | g = g + labs( y=NULL ) 996 | } 997 | 998 | g_list[[ (ii - 1)*n_inputs + jj ]] = g 999 | } 1000 | } 1001 | 1002 | g_grid = plot_grid(plotlist=g_list, labels=NULL, nrow=n_inputs, ncol=n_projs, align='h', axis='b') 1003 | 1004 | return(g_grid) 1005 | } 1006 | 1007 | #' GO enrichment analysis for genes learned from different psupertimes 1008 | #' 1009 | #' @importFrom data.table data.table 1010 | #' @importFrom data.table setnames 1011 | #' @importFrom topGO runTest 1012 | #' @importFrom topGO GenTable 1013 | #' @param psuper_obj A previously calculated psupertime object 1014 | #' @param org_mapping Organism to use for annotations (e.g. 'org.Mm.eg.db', 'org.Hs.eg.db') 1015 | #' @return data.table containing results of GO enrichment analysis 1016 | #' @internal 1017 | psupertime_go_analysis_old <- function(psuper_obj, org_mapping) { 1018 | # can we do this? 1019 | if ( !requireNamespace("topGO", quietly=TRUE) ) { 1020 | message('topGO not installed; not doing GO analysis') 1021 | return() 1022 | } 1023 | library('topGO') 1024 | 1025 | # unpack 1026 | psuper = scale(psuper_obj$proj_dt$psuper) 1027 | n_obs = length(psuper) 1028 | x_data = psuper_obj$x_data 1029 | 1030 | # calculate correlations 1031 | corrs = as.vector(matrix(psuper, nrow=1) %*% x_data) / n_obs 1032 | names(corrs) = colnames(x_data) 1033 | 1034 | # calculate p values for these 1035 | t_stat = (corrs*sqrt(n_obs-2))/sqrt(1-corrs^2) 1036 | p_vals = 2*(1 - pt(abs(t_stat),(n_obs-2))) 1037 | 1038 | # do GO in various ways 1039 | go_dt = data.table() 1040 | for (up_or_down in c('both', 'up', 'down')) { 1041 | # do ranking 1042 | if (up_or_down=='both') { 1043 | scores = abs(corrs) 1044 | 1045 | } else if (up_or_down=='up') { 1046 | scores = corrs 1047 | 1048 | } else if (up_or_down=='down') { 1049 | scores = -corrs 1050 | 1051 | } 1052 | scores[ scores < 0 ] = 0 1053 | scores = sort(scores, decreasing=TRUE) 1054 | if ( sum(scores > 0)==0 ) { 1055 | next 1056 | } 1057 | 1058 | # make topGO object 1059 | topGO_data = new("topGOdata", 1060 | description = up_or_down, 1061 | allGenes = scores, 1062 | geneSel = function(x) {x>0.1}, 1063 | annot = topGO::annFUN.org, 1064 | mapping = org_mapping, 1065 | ontology = 'BP', 1066 | ID = 'symbol' 1067 | ) 1068 | 1069 | # run enrichment tests on these, extract results 1070 | go_weight = runTest(topGO_data, algorithm = "weight01", statistic = "fisher") 1071 | go_temp = data.table(GenTable(topGO_data, 1072 | p_go = go_weight, 1073 | orderBy = 'p_go', 1074 | ranksOf = 'p_go', 1075 | topNodes = 1000 1076 | )) 1077 | setnames(go_temp, 'p_go', 'temp') 1078 | go_temp[, p_go := as.numeric(temp) ] 1079 | go_temp[ temp == '< 1e-30', p_go := 9e-31 ] 1080 | go_temp[, temp := NULL ] 1081 | go_temp[, direction := up_or_down] 1082 | go_temp[, rank := 1:nrow(go_temp)] 1083 | 1084 | # store 1085 | go_dt = rbind(go_dt, go_temp) 1086 | } 1087 | 1088 | # change column order 1089 | setcolorder(go_dt, c('direction', 'rank')) 1090 | # print top terms 1091 | p_cutoff = 5e-2 1092 | n_terms_cutoff = 5 1093 | print_dt = go_dt[ p_go < p_cutoff & Significant>n_terms_cutoff ] 1094 | if (nrow(print_dt)==0) { 1095 | message(sprintf('no GO terms met the cutoffs (p-value < %.1e and at least %d genes significant)', p_cutoff, n_terms_cutoff)) 1096 | } else { 1097 | message('Significant GO terms:') 1098 | print(print_dt) 1099 | } 1100 | 1101 | return(go_dt) 1102 | } 1103 | 1104 | #' GO enrichment analysis for genes learned from different psupertimes 1105 | #' 1106 | #' @importFrom data.table set 1107 | #' @importFrom data.table setorder 1108 | #' @importFrom fastcluster hclust 1109 | #' @param psuper_obj A previously calculated psupertime object 1110 | #' @param org_mapping Organism to use for annotations (e.g. 'org.Mm.eg.db', 'org.Hs.eg.db') 1111 | #' @return data.table containing results of GO enrichment analysis 1112 | #' @export 1113 | psupertime_go_analysis <- function(psuper_obj, org_mapping, k=5, sig_cutoff=5) { 1114 | if ( !requireNamespace("topGO", quietly=TRUE) ) { 1115 | message('topGO not installed; not doing GO analysis') 1116 | return() 1117 | } 1118 | if ( !requireNamespace("fastcluster", quietly=TRUE) ) { 1119 | message('fastcluster not installed; not doing GO analysis') 1120 | return() 1121 | } 1122 | 1123 | # unpack 1124 | glmnet_best = psuper_obj$glmnet_best 1125 | best_lambdas = psuper_obj$best_lambdas 1126 | proj_dt = copy(psuper_obj$proj_dt) 1127 | x_data = copy(psuper_obj$x_data) 1128 | beta_dt = psuper_obj$beta_dt 1129 | cuts_dt = psuper_obj$cuts_dt 1130 | 1131 | # put cells in nice order, label projections 1132 | rownames(x_data) = sprintf('cell_%04d', 1:nrow(x_data)) 1133 | set(proj_dt, i=NULL, 'cell_id', rownames(x_data)) 1134 | setorder(proj_dt, psuper) 1135 | 1136 | # do clustering on symbols 1137 | message('clustering genes') 1138 | hclust_obj = fastcluster::hclust(dist(t(x_data)), method='complete') 1139 | 1140 | # extract clusters from them 1141 | clusters_dt = .calc_clusters_dt(hclust_obj, x_data, proj_dt, k) 1142 | go_results = .do_topgo_for_cluster(clusters_dt, sig_cutoff, org_mapping) 1143 | 1144 | # make plot_dt 1145 | plot_dt = .make_plot_dt(x_data, hclust_obj, proj_dt, clusters_dt) 1146 | 1147 | # assemble outputs 1148 | go_list = list( 1149 | clusters_dt = clusters_dt, 1150 | go_results = go_results, 1151 | plot_dt = plot_dt, 1152 | cuts_dt = copy(psuper_obj$cuts_dt) 1153 | ) 1154 | 1155 | return(go_list) 1156 | } 1157 | 1158 | #' make nice data.table of hierarchical clusters 1159 | #' 1160 | #' @param hclust_obj Result of hclust 1161 | #' @param x_data Data used to calculate psuper_obj 1162 | #' @param proj_dt Projection of cells onto psupertime 1163 | #' @return data.table containing clusters of genes, ordered according to correlation with psupertime 1164 | #' @internal 1165 | .calc_clusters_dt <- function(hclust_obj, x_data, proj_dt, k=5) { 1166 | # make thing 1167 | clusters_dt = data.table( h_clust=cutree(hclust_obj, k=k), symbol=colnames(x_data)) 1168 | # add clustering 1169 | clusters_dt[, N:=.N, by=h_clust ] 1170 | 1171 | # order by correlation with psupertime 1172 | temp_dt = data.table(melt(x_data, varnames=c('cell_id', 'symbol'))) 1173 | temp_dt = clusters_dt[ temp_dt, on='symbol' ] 1174 | means_dt = temp_dt[, list(mean=mean(value)), by=list(cell_id, h_clust) ] 1175 | means_dt = proj_dt[ means_dt, on='cell_id' ] 1176 | corrs_dt = means_dt[, list( cor=cor(mean, psuper) ), by=h_clust] 1177 | setorder(corrs_dt, cor) 1178 | corrs_dt[, clust := 1:.N ] 1179 | corrs_dt[, clust := factor(clust)] 1180 | 1181 | # add clusters ordered by size back in 1182 | clusters_dt = corrs_dt[ clusters_dt, on='h_clust' ] 1183 | clusters_dt[, clust_label := factor(sprintf('%02d (%d genes)', clust, N)) ] 1184 | clusters_dt[, h_clust := NULL ] 1185 | setorder(clusters_dt, clust, symbol) 1186 | 1187 | return(clusters_dt) 1188 | } 1189 | 1190 | #' Calculate GO enrichment for each cluster vs all other genes 1191 | #' 1192 | #' @param clusters_dt 1193 | #' @param sig_cutoff How many genes should be in the cluster for us to consider a GO term? 1194 | #' @return data.table with GO term results 1195 | #' @internal 1196 | .do_topgo_for_cluster <- function(clusters_dt, sig_cutoff, org_mapping) { 1197 | # set up 1198 | all_clusters = unique(clusters_dt[N>=sig_cutoff]$clust) 1199 | go_results = data.table() 1200 | 1201 | # loop through clusters 1202 | message(sprintf('calculating GO enrichments for %d clusters:', length(all_clusters))) 1203 | for (c in all_clusters) { 1204 | message('.', appendLF=FALSE) 1205 | gene_list = factor( as.integer(clusters_dt$clust == c) ) 1206 | names(gene_list) = clusters_dt$symbol 1207 | 1208 | # make topGO object 1209 | suppressMessages({ 1210 | topGO_data = new("topGOdata", 1211 | description = c, 1212 | allGenes = gene_list, 1213 | # geneSelectionFun = function(x) {x==TRUE}, 1214 | annot = annFUN.org, 1215 | mapping = org_mapping, 1216 | ontology = 'BP', 1217 | ID = 'symbol' 1218 | ) 1219 | }) 1220 | # run enrichment tests on these, extract results 1221 | suppressMessages({go_weight = runTest(topGO_data, algorithm = "weight", statistic = "fisher")}) 1222 | n_terms = length(go_weight@score) 1223 | temp_results = data.table(GenTable(topGO_data, 1224 | p_go = go_weight, 1225 | orderBy = 'p_go', 1226 | ranksOf = 'p_go', 1227 | topNodes = n_terms 1228 | )) 1229 | temp_results[ , cluster := c ] 1230 | 1231 | # store 1232 | go_results = rbind(go_results, temp_results) 1233 | } 1234 | message('') 1235 | 1236 | # tidy up 1237 | setnames(go_results, 'p_go', 'tmp') 1238 | go_results[, p_go := as.numeric(tmp) ] 1239 | go_results[ tmp == '< 1e-30', p_go := 9e-31 ] 1240 | go_results[ , tmp := NULL ] 1241 | go_results[ , cluster := factor(cluster, levels=all_clusters) ] 1242 | 1243 | return(go_results) 1244 | } 1245 | 1246 | #' Internal function 1247 | #' 1248 | #' @param x_data 1249 | #' @param hclust_obj 1250 | #' @param proj_dt 1251 | #' @param clusters_dt 1252 | #' @return data.table for plotting 1253 | #' @internal 1254 | .make_plot_dt <- function(x_data, hclust_obj, proj_dt, clusters_dt) { 1255 | # plot 1256 | plot_dt = data.table(melt(x_data, varnames=c('cell_id', 'symbol'))) 1257 | 1258 | # nice ordering 1259 | symbol_order = colnames(x_data)[hclust_obj$order] 1260 | plot_dt[, symbol := factor(symbol, levels=symbol_order)] 1261 | plot_dt[, cell_id := factor(cell_id, levels=proj_dt$cell_id)] 1262 | 1263 | # put this into plotting 1264 | plot_dt = clusters_dt[ plot_dt, on='symbol' ] 1265 | plot_dt = proj_dt[ plot_dt, on='cell_id' ] 1266 | 1267 | return(plot_dt) 1268 | } 1269 | 1270 | #' Plots the significant GO terms for each cluster 1271 | #' 1272 | #' @param go_results Output from GO analysis 1273 | #' @param sig_cutoff What is the minimum number of annotated genes to display a GO term? 1274 | #' @param p_cutoff What is the maximum p-value to display a GO term? 1275 | #' @return bar plot 1276 | #' @export 1277 | #' @importFrom data.table setorder 1278 | #' @importFrom ggplot2 ggplot 1279 | #' @importFrom ggplot2 aes 1280 | #' @importFrom ggplot2 geom_col 1281 | #' @importFrom ggplot2 facet_grid 1282 | #' @importFrom ggplot2 coord_flip 1283 | #' @importFrom ggplot2 scale_y_continuous 1284 | #' @importFrom ggplot2 labs 1285 | #' @importFrom ggplot2 theme_bw 1286 | #' @importFrom scales pretty_breaks 1287 | plot_go_results <- function(go_list, sig_cutoff=5, p_cutoff=0.1) { 1288 | # unpack 1289 | go_results = go_list$go_results 1290 | 1291 | # set up 1292 | plot_dt = go_results[ Significant>=sig_cutoff & p_go 1, term_n := paste0(Term, '_', 1:.N), by=Term ] 1297 | plot_dt[, term_n := factor(term_n, levels=plot_dt$term_n) ] 1298 | 1299 | # plot 1300 | g = ggplot(plot_dt) + 1301 | aes( x=term_n, y=-log10(p_go) ) + 1302 | geom_col() + 1303 | scale_y_continuous( breaks=pretty_breaks() ) + 1304 | facet_grid( cluster ~ ., scales='free_y', space='free_y') + 1305 | coord_flip() + 1306 | labs( 1307 | x = NULL 1308 | ,y = '-log10( p-value )' 1309 | ) + 1310 | theme_bw() 1311 | return(g) 1312 | } 1313 | 1314 | #' Plot heatmap of gene clusters 1315 | #' 1316 | #' @param go_list Output from GO analysis 1317 | #' @return ggplot object 1318 | #' @export 1319 | #' @importFrom ggplot2 ggplot 1320 | #' @importFrom ggplot2 aes 1321 | #' @importFrom ggplot2 geom_tile 1322 | #' @importFrom ggplot2 scale_fill_distiller 1323 | #' @importFrom ggplot2 facet_grid 1324 | #' @importFrom ggplot2 theme 1325 | #' @importFrom ggplot2 element_blank 1326 | #' @importFrom ggplot2 theme_bw 1327 | #' @importFrom ggplot2 labs 1328 | plot_heatmap_of_gene_clusters <- function(go_list) { 1329 | # unpack 1330 | plot_dt = go_list$plot_dt 1331 | 1332 | # plot 1333 | g = ggplot(plot_dt) + 1334 | aes( x=cell_id, y=symbol, fill=value ) + 1335 | geom_tile() + 1336 | scale_fill_distiller( palette='RdBu', limits=c(-3, 3) ) + 1337 | facet_grid( clust_label ~ ., scale='free_y', space='free_y' ) + 1338 | theme_bw() + 1339 | theme( 1340 | axis.text = element_blank() 1341 | ,axis.ticks = element_blank() 1342 | ) + 1343 | labs( 1344 | x = 'Cell' 1345 | ,y = 'Symbol' 1346 | ,fill = 'z-scored gene\nexpression' 1347 | ) 1348 | return(g) 1349 | } 1350 | 1351 | #' Plot heatmap of gene clusters 1352 | #' 1353 | #' @param go_list Output from GO analysis 1354 | #' @param label_name Description for the ordered labels in the legend (e.g. 'Developmental stage (days)') 1355 | #' @param palette RColorBrewer palette to use 1356 | #' @return ggplot object 1357 | #' @export 1358 | #' @importFrom ggplot2 ggplot 1359 | #' @importFrom ggplot2 aes 1360 | #' @importFrom ggplot2 geom_vline 1361 | #' @importFrom ggplot2 scale_colour_manual 1362 | #' @importFrom ggplot2 geom_rug 1363 | #' @importFrom ggplot2 geom_smooth 1364 | #' @importFrom ggplot2 facet_grid 1365 | #' @importFrom ggplot2 theme_bw 1366 | #' @importFrom ggplot2 theme 1367 | #' @importFrom ggplot2 element_blank 1368 | #' @importFrom ggplot2 labs 1369 | plot_profiles_of_gene_clusters <- function(go_list, label_name='Ordered labels', palette='RdBu') { 1370 | # unpack 1371 | plot_dt = go_list$plot_dt 1372 | cuts_dt = go_list$cuts_dt 1373 | 1374 | # set up what to plot 1375 | means_dt = plot_dt[, list(value=mean(value)), by=list(psuper, clust_label)] 1376 | 1377 | # make nice colours 1378 | col_vals = .make_col_vals(cuts_dt$label_input, palette) 1379 | 1380 | # plot 1381 | g = ggplot(means_dt) + 1382 | geom_vline(data=cuts_dt, aes(xintercept=psuper, colour=label_input)) + 1383 | scale_colour_manual( values=col_vals ) + 1384 | geom_smooth( colour='black', span=0.2, method='loess', aes( x=psuper, y=value ) ) 1385 | n_cells = length(unique(plot_dt$cell_id)) 1386 | if ( n_cells<=2000 ) { 1387 | rug_dt = unique(plot_dt[, list(psuper, cell_id)]) 1388 | g = g + geom_rug(data=rug_dt, sides='b', alpha=0.1, aes(x=psuper) ) 1389 | } 1390 | g = g + facet_grid( clust_label ~ ., scales='free_y' ) + 1391 | theme_bw() + 1392 | theme( 1393 | axis.text = element_blank() 1394 | ) + 1395 | labs( 1396 | x = 'psupertime' 1397 | ,y = 'z-scored gene expression' 1398 | ,colour = label_name 1399 | ) 1400 | return(g) 1401 | } 1402 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://travis-ci.org/wmacnair/psupertime.svg?branch=master)](https://travis-ci.org/wmacnair/psupertime) 2 |
3 | 4 | 5 | # psupertime 6 | 7 | :wave: Hello User! :wave: 8 | 9 | `psupertime` is an R package which uses single cell RNAseq data, where the cells have labels following a known sequence (e.g. a time series), to identify a small number of genes which place cells in that known order. It can be used for discovery of relevant genes, for exploration of unlabelled data, and assessment of one dataset with respect to the labels known for another dataset. 10 | 11 | Read the pre-print here: 12 | https://www.biorxiv.org/content/10.1101/622001v1 13 | 14 | ## How to install / use 15 | 16 | To use this development version of the package, run the following lines in R: 17 | ```R 18 | devtools::install_github('wmacnair/psupertime', build_vignettes=TRUE) 19 | library('psupertime') 20 | ``` 21 | (You may need to install the package `remotes`, with `install.packages('remotes')`. Installation took <90s on a Macbook Pro.) 22 | 23 | This should load all of the code and relevant documentation. 24 | 25 | ## Basic analyses 26 | 27 | We have included a small dataset which allows you to use some of the basic functionality in `psupertime`. To do this, have a look at the vignettes: 28 | ```R 29 | browseVignettes(package = 'psupertime') 30 | ``` 31 | `psupertime` is fast: running these analyses took a bit under 1 minute on a Macbook Pro. 32 | The vignette also describes some of the additional functionality you can use, and full details are given in the documentation, via ```?psupertime```. 33 | 34 | 35 | ## Replicating analyses in the manuscript 36 | 37 | To keep this main package light, we have only included a small example dataset. To replicate the figures in the manuscript and provide additional datasets for user experimentation, we have also made a data package, `psupplementary`. If you would like to see in more detail what `psupertime` can do, please go [here](https://github.com/wmacnair/psupplementary). 38 | 39 | 40 | ## Development roadmap 41 | 42 | At the moment, `psupertime` takes a `SingleCellExperiment`/`sce` object as an input, and returns a `psupertime` object. I want to make this a bit smoother for users, by integrating the outputs from `psupertime` into the row and column annotations of the `sce`. So for example, the gene coefficients would be stored in `rowData`, and the latent time estimates would be stored in `colData`. I'll also add some unit tests and submit to `Bioconductor`. 43 | 44 | ## Suggestions 45 | 46 | Please add any issues or requests to the _Issues_ page. All feedback enthusiastically received. 47 | 48 | Cheers 49 | 50 | Will 51 | 52 | 53 | 54 | 55 | ### System requirements 56 | 57 | `psupertime` requires R (>= 3.4.3), and the following dependencies: `ggplot2` 3.1.1, `data.table` 1.12.2, `glmnet` 2.0-16, `scales` 1.0.0, `stringr` 1.4.0, `scran` 1.10.2, `SingleCellExperiment` 1.4.1, `SummarizedExperiment` 1.12.0, `RColorBrewer` 1.1-2. 58 | 59 | -------------------------------------------------------------------------------- /data/acinar_hvg_sce.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/wmacnair/psupertime/73825a28d3bd9bc881c15ee0c4c218eec1c9c207/data/acinar_hvg_sce.rda -------------------------------------------------------------------------------- /data/tf_human.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/wmacnair/psupertime/73825a28d3bd9bc881c15ee0c4c218eec1c9c207/data/tf_human.rda -------------------------------------------------------------------------------- /data/tf_mouse.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/wmacnair/psupertime/73825a28d3bd9bc881c15ee0c4c218eec1c9c207/data/tf_mouse.rda -------------------------------------------------------------------------------- /inst/extdata/psuperlogo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/wmacnair/psupertime/73825a28d3bd9bc881c15ee0c4c218eec1c9c207/inst/extdata/psuperlogo.png -------------------------------------------------------------------------------- /man/dot-calc_clusters_dt.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{.calc_clusters_dt} 4 | \alias{.calc_clusters_dt} 5 | \title{make nice data.table of hierarchical clusters} 6 | \usage{ 7 | .calc_clusters_dt(hclust_obj, x_data, proj_dt, k = 5) 8 | } 9 | \arguments{ 10 | \item{hclust_obj}{Result of hclust} 11 | 12 | \item{x_data}{Data used to calculate psuper_obj} 13 | 14 | \item{proj_dt}{Projection of cells onto psupertime} 15 | } 16 | \value{ 17 | data.table containing clusters of genes, ordered according to correlation with psupertime 18 | } 19 | \description{ 20 | make nice data.table of hierarchical clusters 21 | } 22 | -------------------------------------------------------------------------------- /man/dot-calc_expressed_genes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime.R 3 | \name{.calc_expressed_genes} 4 | \alias{.calc_expressed_genes} 5 | \title{Restrict to genes with minimum proportion of expression defined in ps_params$min_expression} 6 | \usage{ 7 | .calc_expressed_genes(x, ps_params) 8 | } 9 | \arguments{ 10 | \item{x}{SingleCellExperiment class containing all cells and genes required} 11 | 12 | \item{ps_params}{List of all parameters specified.} 13 | } 14 | \description{ 15 | Restrict to genes with minimum proportion of expression defined in ps_params$min_expression 16 | } 17 | \keyword{internal} 18 | -------------------------------------------------------------------------------- /man/dot-calc_hvg_genes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime.R 3 | \name{.calc_hvg_genes} 4 | \alias{.calc_hvg_genes} 5 | \title{Calculates list of highly variable genes (according to approach in scran).} 6 | \usage{ 7 | .calc_hvg_genes(sce, ps_params, do_plot = FALSE) 8 | } 9 | \arguments{ 10 | \item{ps_params}{List of all parameters specified.} 11 | 12 | \item{x}{SingleCellExperiment class or matrix of log counts} 13 | } 14 | \description{ 15 | Calculates list of highly variable genes (according to approach in scran). 16 | } 17 | \keyword{internal} 18 | -------------------------------------------------------------------------------- /man/dot-check_conf_params.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{.check_conf_params} 4 | \alias{.check_conf_params} 5 | \title{Check variables for confusion matrices} 6 | \usage{ 7 | .check_conf_params(plot_var) 8 | } 9 | \arguments{ 10 | \item{plot_var}{Variable to plot: prop_true is proportion of true labels, prop_predict is proportion of predicted labels, N is # of cells} 11 | } 12 | \value{ 13 | list with checked plot_var, and nice label 14 | } 15 | \description{ 16 | Check variables for confusion matrices 17 | } 18 | -------------------------------------------------------------------------------- /man/dot-check_params.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime.R 3 | \name{.check_params} 4 | \alias{.check_params} 5 | \title{check all parameters} 6 | \usage{ 7 | .check_params( 8 | x, 9 | y, 10 | y_labels, 11 | assay_type, 12 | sel_genes, 13 | gene_list, 14 | scale, 15 | smooth, 16 | min_expression, 17 | penalization, 18 | method, 19 | score, 20 | n_folds, 21 | test_propn, 22 | lambdas, 23 | max_iters, 24 | seed 25 | ) 26 | } 27 | \value{ 28 | list of validated parameters 29 | } 30 | \description{ 31 | check all parameters 32 | } 33 | \keyword{internal} 34 | -------------------------------------------------------------------------------- /man/dot-check_x.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime.R 3 | \name{.check_x} 4 | \alias{.check_x} 5 | \title{Checks the gene info} 6 | \usage{ 7 | .check_x(x, y, assay_type) 8 | } 9 | \value{ 10 | list of validated parameters 11 | } 12 | \description{ 13 | Checks the gene info 14 | } 15 | \keyword{internal} 16 | -------------------------------------------------------------------------------- /man/dot-check_y.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime.R 3 | \name{.check_y} 4 | \alias{.check_y} 5 | \title{Checks the labels} 6 | \usage{ 7 | .check_y(y, y_labels) 8 | } 9 | \value{ 10 | checked labels 11 | } 12 | \description{ 13 | Checks the labels 14 | } 15 | \keyword{internal} 16 | -------------------------------------------------------------------------------- /man/dot-do_topgo_for_cluster.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{.do_topgo_for_cluster} 4 | \alias{.do_topgo_for_cluster} 5 | \title{Calculate GO enrichment for each cluster vs all other genes} 6 | \usage{ 7 | .do_topgo_for_cluster(clusters_dt, sig_cutoff, org_mapping) 8 | } 9 | \arguments{ 10 | \item{clusters_dt}{} 11 | 12 | \item{sig_cutoff}{How many genes should be in the cluster for us to consider a GO term?} 13 | } 14 | \value{ 15 | data.table with GO term results 16 | } 17 | \description{ 18 | Calculate GO enrichment for each cluster vs all other genes 19 | } 20 | -------------------------------------------------------------------------------- /man/dot-get_test_idx.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime.R 3 | \name{.get_test_idx} 4 | \alias{.get_test_idx} 5 | \title{Get list of cells to keep aside as test set} 6 | \usage{ 7 | .get_test_idx(y, ps_params) 8 | } 9 | \arguments{ 10 | \item{y}{list of y labels} 11 | } 12 | \value{ 13 | Indices for test set 14 | } 15 | \description{ 16 | Get list of cells to keep aside as test set 17 | } 18 | \keyword{internal} 19 | -------------------------------------------------------------------------------- /man/dot-get_tf_list.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime.R 3 | \name{.get_tf_list} 4 | \alias{.get_tf_list} 5 | \title{Get list of transcription factors} 6 | \usage{ 7 | .get_tf_list(dirs) 8 | } 9 | \value{ 10 | List of all transcription factors specified. 11 | } 12 | \description{ 13 | Get list of transcription factors 14 | } 15 | \keyword{internal} 16 | -------------------------------------------------------------------------------- /man/dot-glmnetcr_propn.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime.R 3 | \name{.glmnetcr_propn} 4 | \alias{.glmnetcr_propn} 5 | \title{This is based on an equivalent function from the package \code{glmnetcr}, 6 | which is sadly no longer on CRAN.} 7 | \usage{ 8 | .glmnetcr_propn( 9 | x, 10 | y, 11 | method = "proportional", 12 | weights = NULL, 13 | offset = NULL, 14 | alpha = 1, 15 | nlambda = 100, 16 | lambda.min.ratio = NULL, 17 | lambda = NULL, 18 | standardize = TRUE, 19 | thresh = 1e-04, 20 | exclude = NULL, 21 | penalty.factor = NULL, 22 | maxit = 100 23 | ) 24 | } 25 | \description{ 26 | This is based on an equivalent function from the package \code{glmnetcr}, 27 | which is sadly no longer on CRAN. 28 | } 29 | \keyword{internal} 30 | -------------------------------------------------------------------------------- /man/dot-make_best_beta.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime.R 3 | \name{.make_best_beta} 4 | \alias{.make_best_beta} 5 | \title{Extracts best coefficients.} 6 | \usage{ 7 | .make_best_beta(glmnet_best, best_lambdas) 8 | } 9 | \value{ 10 | data.table containing learned coefficients for all genes used as input. 11 | } 12 | \description{ 13 | Extracts best coefficients. 14 | } 15 | \keyword{internal} 16 | -------------------------------------------------------------------------------- /man/dot-make_col_vals.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{.make_col_vals} 4 | \alias{.make_col_vals} 5 | \title{Define RColorBrewer palette to use; default is RdBu.} 6 | \usage{ 7 | .make_col_vals(y_labels, palette = "RdBu") 8 | } 9 | \arguments{ 10 | \item{y_labels}{List of labels used for training} 11 | } 12 | \value{ 13 | Colour values 14 | } 15 | \description{ 16 | Define RColorBrewer palette to use; default is RdBu. 17 | } 18 | \keyword{internal} 19 | -------------------------------------------------------------------------------- /man/dot-make_plot_dt.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{.make_plot_dt} 4 | \alias{.make_plot_dt} 5 | \title{Internal function} 6 | \usage{ 7 | .make_plot_dt(x_data, hclust_obj, proj_dt, clusters_dt) 8 | } 9 | \arguments{ 10 | \item{x_data}{} 11 | 12 | \item{hclust_obj}{} 13 | 14 | \item{proj_dt}{} 15 | 16 | \item{clusters_dt}{} 17 | } 18 | \value{ 19 | data.table for plotting 20 | } 21 | \description{ 22 | Internal function 23 | } 24 | -------------------------------------------------------------------------------- /man/dot-make_x_data.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime.R 3 | \name{.make_x_data} 4 | \alias{.make_x_data} 5 | \title{Process input data} 6 | \usage{ 7 | .make_x_data(x, sel_genes, ps_params) 8 | } 9 | \arguments{ 10 | \item{x}{SingleCellExperiment or matrix of log counts} 11 | 12 | \item{sel_genes}{Selected genes} 13 | 14 | \item{ps_params}{Full list of parameters} 15 | } 16 | \value{ 17 | Matrix of dimension # cells by # selected genes 18 | } 19 | \description{ 20 | Note that input is matrix with rows=genes, cols=cells, and that output 21 | has rows=cells, genes=cols 22 | } 23 | \keyword{internal} 24 | -------------------------------------------------------------------------------- /man/dot-psummarize.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime.R 3 | \name{.psummarize} 4 | \alias{.psummarize} 5 | \title{Text to summarize psupertime object} 6 | \usage{ 7 | .psummarize(psuper_obj) 8 | } 9 | \description{ 10 | Text to summarize psupertime object 11 | } 12 | \keyword{internal} 13 | -------------------------------------------------------------------------------- /man/dot-restrict_to_y_labels.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime.R 3 | \name{.restrict_to_y_labels} 4 | \alias{.restrict_to_y_labels} 5 | \title{Use y_labels to define cells to use, and order of labels} 6 | \usage{ 7 | .restrict_to_y_labels(x_data, y, y_labels) 8 | } 9 | \arguments{ 10 | \item{x_data}{matrix output from make_x_data (rows=cells, cols=genes)} 11 | 12 | \item{y}{factor of cell labels} 13 | 14 | \item{y_labels}{list of labels to restrict to, and order to use} 15 | } 16 | \description{ 17 | Use y_labels to define cells to use, and order of labels 18 | } 19 | -------------------------------------------------------------------------------- /man/dot-select_genes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime.R 3 | \name{.select_genes} 4 | \alias{.select_genes} 5 | \title{Select genes for use in regression} 6 | \usage{ 7 | .select_genes(x, ps_params) 8 | } 9 | \arguments{ 10 | \item{x}{SingleCellExperiment class containing all cells and genes required, or matrix of counts} 11 | 12 | \item{ps_params}{List of all parameters specified.} 13 | } 14 | \description{ 15 | Select genes for use in regression 16 | } 17 | \keyword{internal} 18 | -------------------------------------------------------------------------------- /man/double_psupertime.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{double_psupertime} 4 | \alias{double_psupertime} 5 | \title{Projects two different psupertimes onto each other} 6 | \usage{ 7 | double_psupertime(psuper_1, psuper_2, run_names = NULL, process = FALSE) 8 | } 9 | \arguments{ 10 | \item{psuper_1, }{psuper_2 Two previously calculated psupertime objects} 11 | 12 | \item{labels}{Character vector of length two, labelling the psupertime inputs} 13 | } 14 | \value{ 15 | data.table containing projections in both directions 16 | } 17 | \description{ 18 | Projects two different psupertimes onto each other 19 | } 20 | -------------------------------------------------------------------------------- /man/plot_double_psupertime.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{plot_double_psupertime} 4 | \alias{plot_double_psupertime} 5 | \title{Projects two different psupertimes onto each other, using points, side by side} 6 | \usage{ 7 | plot_double_psupertime( 8 | double_obj = NULL, 9 | psuper_1 = NULL, 10 | psuper_2 = NULL, 11 | run_names = NULL, 12 | process = FALSE 13 | ) 14 | } 15 | \arguments{ 16 | \item{double_obj}{Result of applying double_psupertime to two previously calculated psupertime objects} 17 | 18 | \item{psuper_1, }{psuper_2 Two previously calculated psupertime objects} 19 | 20 | \item{run_names}{Character vector of length two, labelling the psupertime inputs} 21 | } 22 | \value{ 23 | ggplot object plotting the two against each other 24 | } 25 | \description{ 26 | To do this, psupertime builds an internal \code{double_psupertime} object containing 27 | the projections. Given two psupertime objects \code{psuper_1} and \code{psuper_2}, you can 28 | call it in two ways: 29 | } 30 | \details{ 31 | (1) By specifying the two psupertime objects you want to project: 32 | \code{plot_double_psupertime(psuper_1=psuper_1, psuper_2=psuper_2)} 33 | 34 | (2) Or by first constructing a \code{double_psupertime} object: 35 | \code{double_obj = double_psupertime(psuper_1, psuper_2)} 36 | \code{plot_double_psupertime(double_obj=double_obj)} 37 | 38 | For the coefficients of the two objects to be meaningfully applied to each 39 | other, the data needs to have been processed in the same way for each. We 40 | therefore recommend first preprocessing the data (either via \code{psupertime}'s 41 | defaults, or via your preferred method, then running \code{psupertime} with 42 | \code{smooth=FALSE} and \code{scale=FALSE}. 43 | } 44 | -------------------------------------------------------------------------------- /man/plot_double_psupertime_confusion.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{plot_double_psupertime_confusion} 4 | \alias{plot_double_psupertime_confusion} 5 | \title{Plots the confusion matrices of two psupertime objects against each other} 6 | \usage{ 7 | plot_double_psupertime_confusion( 8 | double_obj = NULL, 9 | psuper_1 = NULL, 10 | psuper_2 = NULL, 11 | run_names = NULL, 12 | plot_var = "prop_true", 13 | palette = "BuPu" 14 | ) 15 | } 16 | \arguments{ 17 | \item{double_obj}{Result of applying double_psupertime to two previously calculated psupertime objects} 18 | 19 | \item{psuper_1, }{psuper_2 Two previously calculated psupertime objects} 20 | 21 | \item{run_names}{Character vector of length two, labelling the psupertime inputs} 22 | 23 | \item{palette}{RColorBrewer palette to use} 24 | } 25 | \value{ 26 | cowplot plot_grid object, showing known and predicted labels for each dataset, and each set of predictions 27 | } 28 | \description{ 29 | See `plot_double_psupertime` for further detail. 30 | } 31 | -------------------------------------------------------------------------------- /man/plot_double_psupertime_contour.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{plot_double_psupertime_contour} 4 | \alias{plot_double_psupertime_contour} 5 | \title{Projects two different psupertimes on top of each other} 6 | \usage{ 7 | plot_double_psupertime_contour( 8 | double_obj = NULL, 9 | psuper_1 = NULL, 10 | psuper_2 = NULL, 11 | run_names = NULL 12 | ) 13 | } 14 | \arguments{ 15 | \item{double_obj}{Result of applying double_psupertime to two previously calculated psupertime objects} 16 | 17 | \item{psuper_1, }{psuper_2 Two previously calculated psupertime objects} 18 | 19 | \item{run_names}{Character vector of length two, labelling the psupertime inputs} 20 | } 21 | \value{ 22 | ggplot object plotting the two against each other 23 | } 24 | \description{ 25 | See `plot_double_psupertime` for further detail. 26 | } 27 | -------------------------------------------------------------------------------- /man/plot_double_psupertime_genes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{plot_double_psupertime_genes} 4 | \alias{plot_double_psupertime_genes} 5 | \title{Compares coefficients for genes learned from different psupertimes} 6 | \usage{ 7 | plot_double_psupertime_genes(psuper_1, psuper_2, run_names = NULL) 8 | } 9 | \arguments{ 10 | \item{psuper_1, }{psuper_2 Two previously calculated psupertime objects} 11 | 12 | \item{run_names}{Character vector of length two, labelling the psupertime inputs} 13 | } 14 | \value{ 15 | ggplot object plotting the two sets of coefficients 16 | } 17 | \description{ 18 | Compares coefficients for genes learned from different psupertimes 19 | } 20 | -------------------------------------------------------------------------------- /man/plot_go_results.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{plot_go_results} 4 | \alias{plot_go_results} 5 | \title{Plots the significant GO terms for each cluster} 6 | \usage{ 7 | plot_go_results(go_list, sig_cutoff = 5, p_cutoff = 0.1) 8 | } 9 | \arguments{ 10 | \item{sig_cutoff}{What is the minimum number of annotated genes to display a GO term?} 11 | 12 | \item{p_cutoff}{What is the maximum p-value to display a GO term?} 13 | 14 | \item{go_results}{Output from GO analysis} 15 | } 16 | \value{ 17 | bar plot 18 | } 19 | \description{ 20 | Plots the significant GO terms for each cluster 21 | } 22 | -------------------------------------------------------------------------------- /man/plot_heatmap_of_gene_clusters.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{plot_heatmap_of_gene_clusters} 4 | \alias{plot_heatmap_of_gene_clusters} 5 | \title{Plot heatmap of gene clusters} 6 | \usage{ 7 | plot_heatmap_of_gene_clusters(go_list) 8 | } 9 | \arguments{ 10 | \item{go_list}{Output from GO analysis} 11 | } 12 | \value{ 13 | ggplot object 14 | } 15 | \description{ 16 | Plot heatmap of gene clusters 17 | } 18 | -------------------------------------------------------------------------------- /man/plot_identified_gene_coefficients.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{plot_identified_gene_coefficients} 4 | \alias{plot_identified_gene_coefficients} 5 | \title{Plots top coefficients} 6 | \usage{ 7 | plot_identified_gene_coefficients(psuper_obj, n = 20, abs_cutoff = 0.05) 8 | } 9 | \arguments{ 10 | \item{psuper_obj}{Psupertime object, output from psupertime} 11 | } 12 | \value{ 13 | ggplot2 object 14 | } 15 | \description{ 16 | Plots top coefficients 17 | } 18 | -------------------------------------------------------------------------------- /man/plot_identified_genes_over_psupertime.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{plot_identified_genes_over_psupertime} 4 | \alias{plot_identified_genes_over_psupertime} 5 | \title{Plots profiles of identified genes against psupertime.} 6 | \usage{ 7 | plot_identified_genes_over_psupertime( 8 | psuper_obj, 9 | label_name = "Ordered labels", 10 | n_to_plot = 20, 11 | palette = "RdBu", 12 | plot_ratio = 1.25 13 | ) 14 | } 15 | \arguments{ 16 | \item{psuper_obj}{Psupertime object, output from psupertime} 17 | 18 | \item{label_name}{Description for the ordered labels in the legend (e.g. 'Developmental stage (days)')} 19 | 20 | \item{n_to_plot}{Maximum number of genes to plot (default 20)} 21 | 22 | \item{palette}{RColorBrewer palette to use} 23 | 24 | \item{plot_ratio}{ratio of columns to rows (default is 5:4)} 25 | } 26 | \value{ 27 | ggplot2 object 28 | } 29 | \description{ 30 | Plots profiles of identified genes against psupertime. 31 | } 32 | -------------------------------------------------------------------------------- /man/plot_labels_over_psupertime.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{plot_labels_over_psupertime} 4 | \alias{plot_labels_over_psupertime} 5 | \title{Plots labels over their projected values on psupertime.} 6 | \usage{ 7 | plot_labels_over_psupertime( 8 | psuper_obj, 9 | label_name = "Ordered labels", 10 | palette = "RdBu" 11 | ) 12 | } 13 | \arguments{ 14 | \item{psuper_obj}{Psupertime object, output from psupertime} 15 | 16 | \item{label_name}{Description for the ordered labels in the legend (e.g. 'Developmental stage (days)')} 17 | 18 | \item{palette}{RColorBrewer palette to use} 19 | } 20 | \value{ 21 | ggplot2 object 22 | } 23 | \description{ 24 | Plots labels over their projected values on psupertime. 25 | } 26 | -------------------------------------------------------------------------------- /man/plot_new_data_over_psupertime.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{plot_new_data_over_psupertime} 4 | \alias{plot_new_data_over_psupertime} 5 | \title{Plots profiles of hand-selected genes against psupertime.} 6 | \usage{ 7 | plot_new_data_over_psupertime( 8 | psuper_obj, 9 | new_x, 10 | new_y, 11 | labels = c("Original", "New data"), 12 | palette = "BrBG", 13 | process = FALSE 14 | ) 15 | } 16 | \arguments{ 17 | \item{psuper_obj}{Psupertime object, output from psupertime} 18 | 19 | \item{new_x, new_y}{Optional data to predict with psuper_obj} 20 | 21 | \item{palette}{RColorBrewer palette to use} 22 | } 23 | \value{ 24 | ggplot2 object 25 | } 26 | \description{ 27 | Plots profiles of hand-selected genes against psupertime. 28 | } 29 | -------------------------------------------------------------------------------- /man/plot_predictions_against_classes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{plot_predictions_against_classes} 4 | \alias{plot_predictions_against_classes} 5 | \title{Plots confusion matrix of true labels against predicted labels.} 6 | \usage{ 7 | plot_predictions_against_classes( 8 | psuper_obj, 9 | new_x = NULL, 10 | new_y = NULL, 11 | process = FALSE, 12 | plot_var = "prop_true", 13 | palette = "BuPu" 14 | ) 15 | } 16 | \arguments{ 17 | \item{psuper_obj}{Psupertime object, output from psupertime} 18 | 19 | \item{new_x, new_y}{Optional data to predict with psuper_obj} 20 | 21 | \item{plot_var}{Variable to plot: prop_true is proportion of true labels, prop_predict is proportion of predicted labels, N is # of cells} 22 | 23 | \item{palette}{RColorBrewer palette to use} 24 | } 25 | \value{ 26 | ggplot2 object 27 | } 28 | \description{ 29 | Plots confusion matrix of true labels against predicted labels. 30 | } 31 | -------------------------------------------------------------------------------- /man/plot_profiles_of_gene_clusters.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{plot_profiles_of_gene_clusters} 4 | \alias{plot_profiles_of_gene_clusters} 5 | \title{Plot heatmap of gene clusters} 6 | \usage{ 7 | plot_profiles_of_gene_clusters( 8 | go_list, 9 | label_name = "Ordered labels", 10 | palette = "RdBu" 11 | ) 12 | } 13 | \arguments{ 14 | \item{go_list}{Output from GO analysis} 15 | 16 | \item{label_name}{Description for the ordered labels in the legend (e.g. 'Developmental stage (days)')} 17 | 18 | \item{palette}{RColorBrewer palette to use} 19 | } 20 | \value{ 21 | ggplot object 22 | } 23 | \description{ 24 | Plot heatmap of gene clusters 25 | } 26 | -------------------------------------------------------------------------------- /man/plot_specified_genes_over_psupertime.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{plot_specified_genes_over_psupertime} 4 | \alias{plot_specified_genes_over_psupertime} 5 | \title{Plots profiles of hand-selected genes against psupertime.} 6 | \usage{ 7 | plot_specified_genes_over_psupertime( 8 | psuper_obj, 9 | extra_genes, 10 | label_name = "Ordered labels", 11 | palette = "RdBu", 12 | plot_ratio = 1.25 13 | ) 14 | } 15 | \arguments{ 16 | \item{psuper_obj}{psupertime object, output from psupertime} 17 | 18 | \item{extra_genes}{List of genes to be plotted (these must be in the set of genes used for calculating psupertime, e.g. highly variable genes)} 19 | 20 | \item{label_name}{Description for the ordered labels in the legend (e.g. 'Developmental stage (days)')} 21 | 22 | \item{palette}{RColorBrewer palette to use} 23 | 24 | \item{plot_ratio}{ratio of columns to rows (default is 5:4)} 25 | } 26 | \value{ 27 | ggplot2 object 28 | } 29 | \description{ 30 | Plots profiles of hand-selected genes against psupertime. 31 | } 32 | -------------------------------------------------------------------------------- /man/plot_train_results.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{plot_train_results} 4 | \alias{plot_train_results} 5 | \title{Plot results of training} 6 | \usage{ 7 | plot_train_results(psuper_obj) 8 | } 9 | \arguments{ 10 | \item{psuper_obj}{Psupertime object, output from psupertime} 11 | } 12 | \value{ 13 | ggplot2 object showing test and training performance of classifier. 14 | } 15 | \description{ 16 | Plot results of training 17 | } 18 | -------------------------------------------------------------------------------- /man/project_onto_psupertime.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{project_onto_psupertime} 4 | \alias{project_onto_psupertime} 5 | \title{Gives projection of data onto psupertime (either using original data, or new data)} 6 | \usage{ 7 | project_onto_psupertime( 8 | psuper_obj, 9 | new_x = NULL, 10 | new_y = NULL, 11 | process = FALSE 12 | ) 13 | } 14 | \arguments{ 15 | \item{psuper_obj}{Psupertime object, output from psupertime} 16 | 17 | \item{new_x, }{new_y Optional pair of new data and labels} 18 | } 19 | \value{ 20 | data.table with projection and labels 21 | } 22 | \description{ 23 | Gives projection of data onto psupertime (either using original data, or new data) 24 | } 25 | -------------------------------------------------------------------------------- /man/psupertime.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime.R 3 | \name{psupertime} 4 | \alias{psupertime} 5 | \title{Supervised pseudotime} 6 | \usage{ 7 | psupertime( 8 | x, 9 | y, 10 | y_labels = NULL, 11 | assay_type = "logcounts", 12 | sel_genes = "hvg", 13 | gene_list = NULL, 14 | scale = TRUE, 15 | smooth = TRUE, 16 | min_expression = 0.01, 17 | penalization = "1se", 18 | method = "proportional", 19 | score = "xentropy", 20 | n_folds = 5, 21 | test_propn = 0.1, 22 | lambdas = NULL, 23 | max_iters = 1000, 24 | seed = 1234 25 | ) 26 | } 27 | \arguments{ 28 | \item{x}{Either SingleCellExperiment object containing a matrix of genes * cells required, or a matrix of log TPM values (also genes * cells).} 29 | 30 | \item{y}{Vector of labels, which should have same length as number of columns in sce / x. Factor levels will be taken as the intended order for training.} 31 | 32 | \item{y_labels}{Alternative ordering and/or subset of the labels in y. All labels must be present in y. Smoothing and scaling are done on the whole dataset, before any subsetting takes place.} 33 | 34 | \item{assay_type}{If a SingleCellExperiment object is used as input, specifies which assay is to be used.} 35 | 36 | \item{sel_genes}{Method to be used to select interesting genes to be used in psupertime. Must be a string, with permitted values 'hvg', 'all', 'tf_mouse', 'tf_human' and 'list', corresponding to: highly variable genes, all genes, transcription factors in mouse, transcription factors in human, and a user-selected list. If sel_genes='list', then the parameter gene_list must also be specified as input, containing the user-specified list of genes. sel_genes may alternatively be a list, itself, specifying the parameters to be used for selecting highly variable genes via scran, with names 'hvg_cutoff', 'bio_cutoff' (optionally also 'span').} 37 | 38 | \item{gene_list}{If sel_genes is specified as 'list', gene_list specifies the list of user-specified genes.} 39 | 40 | \item{scale}{Should the log expression data for each gene be scaled to have mean zero and SD 1? Having the same scale ensures that L1-penalization functions properly; typically you would only set this to FALSE if you have already done your own scaling.} 41 | 42 | \item{smooth}{Should the data be smoothed over neighbours? This is done to denoise the data; if you already done your own denoising, set this to FALSE.} 43 | 44 | \item{min_expression}{Cutoff for excluding genes based on non-zero expression in only a small proportion of cells; default is 1\% of cells.} 45 | 46 | \item{penalization}{Method of selecting level of L1-penalization. 'best' uses the value of lambda giving the best cross-validation accuracy; '1se' corresponds to largest value of lambda within 1 standard error of the best. This increases sparsity with minimal increased error (and is the default).} 47 | 48 | \item{method}{Statistical model used for ordinal logistic regression, one of 'proportional', 'forward' and 'backward', corresponding to cumulative proportional odds, forward continuation ratio and backward continuation ratio.} 49 | 50 | \item{score}{Cross-validated accuracy to be used to select model. May take values 'x_entropy' (default), or 'class_error', corresponding to cross-entropy and classification error respectively. Cross-entropy is a smooth measure, while classification error is based on discrete labels and tends to be a bit 'lumpy'.} 51 | 52 | \item{n_folds}{Number of folds to use for cross-validation; default is 5.} 53 | 54 | \item{test_propn}{Proportion of data to hold out for testing, separate to the cross-validation; default is 0.1 (10\%).} 55 | 56 | \item{lambdas}{User-specified sequence of lambda values. Should be in decreasing order.} 57 | 58 | \item{max_iters}{Maximum number of iterations to run in glmnet.} 59 | 60 | \item{seed}{Random seed for specifying cross-validation folds and test data} 61 | } 62 | \value{ 63 | psupertime object 64 | } 65 | \description{ 66 | Supervised pseudotime 67 | } 68 | -------------------------------------------------------------------------------- /man/psupertime_go_analysis.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{psupertime_go_analysis} 4 | \alias{psupertime_go_analysis} 5 | \title{GO enrichment analysis for genes learned from different psupertimes} 6 | \usage{ 7 | psupertime_go_analysis(psuper_obj, org_mapping, k = 5, sig_cutoff = 5) 8 | } 9 | \arguments{ 10 | \item{psuper_obj}{A previously calculated psupertime object} 11 | 12 | \item{org_mapping}{Organism to use for annotations (e.g. 'org.Mm.eg.db', 'org.Hs.eg.db')} 13 | } 14 | \value{ 15 | data.table containing results of GO enrichment analysis 16 | } 17 | \description{ 18 | GO enrichment analysis for genes learned from different psupertimes 19 | } 20 | -------------------------------------------------------------------------------- /man/psupertime_go_analysis_old.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{psupertime_go_analysis_old} 4 | \alias{psupertime_go_analysis_old} 5 | \title{GO enrichment analysis for genes learned from different psupertimes} 6 | \usage{ 7 | psupertime_go_analysis_old(psuper_obj, org_mapping) 8 | } 9 | \arguments{ 10 | \item{psuper_obj}{A previously calculated psupertime object} 11 | 12 | \item{org_mapping}{Organism to use for annotations (e.g. 'org.Mm.eg.db', 'org.Hs.eg.db')} 13 | } 14 | \value{ 15 | data.table containing results of GO enrichment analysis 16 | } 17 | \description{ 18 | GO enrichment analysis for genes learned from different psupertimes 19 | } 20 | -------------------------------------------------------------------------------- /man/psupertime_plot_all.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/psupertime_plots.R 3 | \name{psupertime_plot_all} 4 | \alias{psupertime_plot_all} 5 | \title{Convenience function to do multiple plots} 6 | \usage{ 7 | psupertime_plot_all( 8 | psuper_obj, 9 | output_dir = ".", 10 | tag = "", 11 | label_name = "Ordered labels", 12 | ext = "png" 13 | ) 14 | } 15 | \arguments{ 16 | \item{psuper_obj}{Psupertime object, output from psupertime} 17 | 18 | \item{output_dir}{Directory to save to} 19 | 20 | \item{tag}{Label for all files} 21 | 22 | \item{label_name}{Description for the ordered labels in the legend (e.g. 'Developmental stage (days)')} 23 | 24 | \item{ext}{Image format for outputs, compatible with ggsave (eps, ps, tex, pdf, jpeg, tiff, png, bmp, svg, wmf)} 25 | } 26 | \description{ 27 | Convenience function to do multiple plots 28 | } 29 | -------------------------------------------------------------------------------- /man/tf_human.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data.R 3 | \docType{data} 4 | \name{tf_human} 5 | \alias{tf_human} 6 | \title{List of human transcription factors} 7 | \format{ 8 | A character vector of length 795 9 | } 10 | \source{ 11 | \url{https://www.grnpedia.org/trrust/downloadnetwork.php} 12 | } 13 | \usage{ 14 | tf_human 15 | } 16 | \description{ 17 | Derived from the TRRUST project: https://www.grnpedia.org/trrust/ 18 | } 19 | \keyword{datasets} 20 | -------------------------------------------------------------------------------- /man/tf_mouse.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data.R 3 | \docType{data} 4 | \name{tf_mouse} 5 | \alias{tf_mouse} 6 | \title{List of mouse transcription factors} 7 | \format{ 8 | A character vector of length 827 9 | } 10 | \source{ 11 | \url{https://www.grnpedia.org/trrust/downloadnetwork.php} 12 | } 13 | \usage{ 14 | tf_mouse 15 | } 16 | \description{ 17 | Derived from the TRRUST project: https://www.grnpedia.org/trrust/ 18 | } 19 | \keyword{datasets} 20 | -------------------------------------------------------------------------------- /psupertime.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Package 16 | PackageUseDevtools: Yes 17 | PackageInstallArgs: --no-multiarch --with-keep.source 18 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(psupertime) 3 | 4 | test_check("psupertime") 5 | -------------------------------------------------------------------------------- /tests/testthat/test-01_basic_tests.R: -------------------------------------------------------------------------------- 1 | context("Does psupertime work?") 2 | # devtools::document(); devtools::test() 3 | 4 | ################ 5 | # set up 6 | ################ 7 | 8 | suppressPackageStartupMessages({ 9 | library('psupertime') 10 | library('SingleCellExperiment') 11 | }) 12 | seed <- as.numeric(format(Sys.time(), "%s")) 13 | set.seed(seed) 14 | 15 | # load the data 16 | data(acinar_hvg_sce) 17 | 18 | # run psupertime 19 | y = acinar_hvg_sce$donor_age 20 | 21 | 22 | ################ 23 | # tests 24 | ################ 25 | 26 | test_that("do standard calls to psupertime work?", { 27 | # do they work ok? 28 | expect_is(psupertime(acinar_hvg_sce, y, sel_genes='all'), 'list') 29 | expect_is(psupertime(acinar_hvg_sce, y, sel_genes='hvg'), 'list') 30 | expect_is(psupertime(acinar_hvg_sce, y, sel_genes=list(bio_cutoff=0, hvg_cutoff=1)), 'list') 31 | }) 32 | 33 | test_that("do plotting functions work?", { 34 | # run psupertime 35 | psuper_obj = psupertime(acinar_hvg_sce, y, sel_genes='all') 36 | 37 | # check each plotting function 38 | expect_is(plot_identified_gene_coefficients(psuper_obj), 'ggplot') 39 | expect_is(plot_identified_genes_over_psupertime(psuper_obj), 'ggplot') 40 | expect_is(plot_labels_over_psupertime(psuper_obj), 'ggplot') 41 | expect_is(plot_predictions_against_classes(psuper_obj), 'ggplot') 42 | expect_is(plot_train_results(psuper_obj), 'ggplot') 43 | }) 44 | -------------------------------------------------------------------------------- /vignettes/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | *.R 3 | -------------------------------------------------------------------------------- /vignettes/psuper_intro.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Brief introduction to psupertime" 3 | author: "Will Macnair" 4 | date: "`r Sys.Date()`" 5 | output: 6 | BiocStyle::html_document 7 | vignette: > 8 | %\VignetteIndexEntry{Brief introduction to psupertime} 9 | %\VignetteEngine{knitr::rmarkdown} 10 | %\VignetteEncoding{UTF-8} 11 | --- 12 | 13 | ```{r setup, include = FALSE} 14 | knitr::opts_chunk$set( 15 | collapse = TRUE, 16 | comment = "#>", 17 | package.startup.message = FALSE 18 | ) 19 | ``` 20 | 21 | # `psupertime` overview 22 | 23 | `psupertime` is an R package for analysing single cell RNA-seq data where groups of the cells have labels with a known or expected sequence (for example, samples from a time series experiment *day1*, *day2*, ..., *day5*). It uses *ordinal logistic regression* to identify a set of genes which recapitulate the group-level sequence for individual cells. 24 | 25 | In this short vignette, we show a simple example of `psupertime`, corresponding to the data in Figure 1D of the biorxiv manuscript. As single cell RNA-seq datasets are typically large, we have only included one small dataset in the core psupertime package. To allow replication of all the examples in the psupertime paper, we have also made the `psupplementary` package, [here](github.com/wmacnair/psupplementary). 26 | 27 | 28 | # Basic usage 29 | 30 | `psupertime` requires two inputs: 31 | 32 | - `x`, containing single cell log pseudocount data, either as a `SingleCellExperiment` object or a matrix with rows as genes and columns as cells; and 33 | - `y`, a factor with labels for each cell, where the sequence of the factor levels is the required sequential label ordering. 34 | 35 | We demonstrate `psupertime` on a small example dataset, comprising pancreas cells taken from donors of varying ages. The most straightforward way to run `psupertime` is very simple: 36 | ```{r warning=FALSE} 37 | # load psupertime package 38 | suppressPackageStartupMessages({ 39 | library('psupertime') 40 | library('SingleCellExperiment') 41 | }) 42 | 43 | # load the data 44 | data(acinar_hvg_sce) 45 | 46 | # run psupertime 47 | y = acinar_hvg_sce$donor_age 48 | psuper_obj = psupertime(acinar_hvg_sce, y, sel_genes='all') 49 | psuper_obj 50 | ``` 51 | 52 | (Calling `psuper_obj` or `print(psuper_obj)` gives a quick summary of the fitted model.) 53 | 54 | Here, we ran `psupertime` using all genes, by specifying `sel_genes='all'`. Typically we would increase speed by restricting the analysis to only interesting genes, for example the default setting is to restrict to only highly varying genes (HVGs), as described in [`scran`](https://bioconductor.org/packages/release/bioc/html/scran.html). To keep this main package light, we pre-selected the highly variable genes (in `acinar_hvg_sce`). The standard way to call `psupertime`, with a full-size dataset (i.e. without pre-selection of genes) is like this: 55 | 56 | ``` 57 | ## not run 58 | # psuper_obj = psupertime(x, y) 59 | ``` 60 | 61 | # `psupertime` outputs 62 | 63 | Once you have run `psupertime`, you can produce a range of plots to check the outputs, for example: 64 | 65 | - a diagnostic plot of the `psupertime` fitting process, to check how accurately `psupertime` was able to recapitulate the sequence, and the level of regularization selected; 66 | - the distribution of the label sequence along the learned pseudotime; 67 | - the genes with the largest absolute coefficients learned by `psupertime`; and 68 | - the expression profiles over the individual cells for these genes. 69 | 70 | 71 | ## Model diagnostics 72 | 73 | The plot below shows how several measures of performance are affected by the extent of regularization, $\lambda$. The x-axis shows $\lambda$, indicating how strongly the model tries to set coefficients to zero. The optimal value of $\lambda$ is the one which gives the best mean performance over the training data, based on one of two possible measures of performance. 74 | 75 | ```{r, fig.height=8, fig.width=6, fig.cap="Diagnostic plot for checking that training worked well", fig.wide=TRUE} 76 | g = plot_train_results(psuper_obj) 77 | (g) 78 | ``` 79 | 80 | The first row shows classification error, namely the proportion of cells for which `psupertime` predicted the wrong label (equivalent to 1 - accuracy). The second row is cross-entropy, which quantifies how confidently the `psupertime` classifier predicts the correct label (so predicting the correct label with probability $p=0.9$ results in a lower cross-entropy than with probability $p=0.5$). Accuracy is a 'lumpy' measurement of performance (something is either correct or not), whereas cross-entropy is continuous; this means that selecting $\lambda$ on the basis of cross-entropy results in less noisy selection of the $\lambda$ value. 81 | 82 | The third row shows the number of genes with non-zero coefficients, for each given value of $\lambda$ (this is effectively the inverse of sparsity, which is the proportion of zero coefficients). 83 | 84 | The solid vertical grey line shows the value of $\lambda$ resulting in the best performance. The dashed vertical grey line shows the largest value of $\lambda$ with performance within one standard error of this. By default `psupertime` selects this value, giving increased sparsity at a minimal cost to performance. We show lines for selection using both classification error and cross-entropy; the thicker lines indicate which measure was actually used to select $\lambda$. In this case we used the $\lambda$ value within 1 s.e. of the best performance on cross-entropy. Reading down to the plot of non-zero genes, we can see that this resulted in just under 100 genes with non-zero coefficients. 85 | 86 | 87 | ## `psupertime` ordering of cells 88 | 89 | Like other pseudotime methods, one output from `psupertime` is an ordering for the individual cells (shown below). In this case of `psupertime`, this ordering should broadly follow the group-level labels given as inputs. 90 | 91 | The x-axis shows the one-dimensional projection learned by `psupertime`. The different colours are the sequential labels used as input to `psupertime`, with the y-axis showing their densities over the pseudotime. The vertical lines indicate the point with equal probability of prediction between each pair of successive labels. For example, the first vertical line (blue, x=$\sim$-6) shows the value of pseudotime at which `psupertime` predicts the labels 1 year vs {5,6,21,22,38,44,54} years with equal probability. 92 | 93 | ```{r, fig.height=4, fig.width=7, fig.cap="Labels over `psupertime`", fig.wide=TRUE} 94 | g = plot_labels_over_psupertime(psuper_obj, label_name='Donor age') 95 | (g) 96 | ``` 97 | 98 | Interesting things you might observe: 99 | 100 | - Individual cells may have earlier or later values than others with the same label, possibly suggesting interesting subpopulations within a group label. 101 | - The thresholds learned by `psupertime` indicate how easy it is to distinguish between the different labels: where thresholds are close together, these labels are hard to separate, and where they are distant this task is easier. 102 | 103 | ## Genes identified by `psupertime` 104 | 105 | `psupertime` identifies a small set of genes which place the individual cells approximately in the order of the group-level labels. This list can be the most relevant output from `psupertime`. The plot below shows the 20 genes with the largest absolute coefficient values (subject to the absolute value being $>0.05$). Genes with positive coefficients will have expression positively correlated with the group-level labels, and vice versa for negative coefficients. 106 | 107 | 108 | ```{r fig.height=3, fig.width=6} 109 | g = plot_identified_gene_coefficients(psuper_obj) 110 | (g) 111 | ``` 112 | 113 | Another way of examining these genes is to plot their expression values against the learned pseudotime values. The plot below shows the same set of genes, with the (z-scored log) expression values for all individual cells. This can show different profiles of expression, e.g. initially on, then switched off (*ITM2A*); and increasing or decreasing relatively constantly (*CLU*). 114 | 115 | ```{r, fig.height=6, fig.width=9, fig.wide=TRUE} 116 | g = plot_identified_genes_over_psupertime(psuper_obj, label_name='Donor age') 117 | (g) 118 | ``` 119 | 120 | Such gene plots can also potentially identify branching, for example where expression of a given gene is initially unimodal, but later becomes bimodal. 121 | 122 | ## `psupertime` as a classifier 123 | 124 | `psupertime` is a classifier, in the sense that once trained, it can predict a label for any cell given as input. Comparing the predicted classes of cells against their known classes can identify interesting subpopulations of cells. 125 | 126 | In the plot below, the x-axis shows the labels used to train `psupertime`; the y-axis shows the labels of the data used as input for this instance of `psupertime` (which in this case are the same as the predicted labels). The value in each box shows the number of cells with the known label for the row, which were predicted to have the column label. The colour corresponds to the proportions of the known label across the different possible predictions; within each row, the colours 'add up to 1'. 127 | 128 | We can use this to identify groups of cells whose predicted labels differ from their true labels. For example, considering the cells with true label 6 years (third row from the bottom), two thirds have predicted donor age 5, while the remaining third have predicted donor age 21. [For this example dataset, this analysis doesn't seem super interesting, but there are others where it is useful! Look at the vignettes for the [psupplementary](github.com/wmacnair/psupplementary) package for more interesting examples.] 129 | 130 | 131 | ```{r fig.height=4, fig.width=5} 132 | g = plot_predictions_against_classes(psuper_obj) 133 | (g) 134 | ``` 135 | 136 | `psupertime` can also be applied to data with unknown or different labels. In that case, the x-axis would remain the same, with the labels used to train the `psupertime`, but the y-axis would be different. Using it on the data used for training means we can check how accurate its labelling is (when `psupertime` is accurate, all the values should be on the diagonal), and in particular check whether it is less accurate for some labels. 137 | 138 | # Alternative ways to run `psupertime` 139 | 140 | Above, we ran `psupertime` with the default settings. Here are some obvious settings you could consider changing: 141 | 142 | **Selection of genes** The default setting for `psupertime` is to restrict the analysis to highly varying genes, using the method described in `scran` (see [here](https://f1000research.com/articles/5-2122/v2)). Here are some alternative methods for selecting genes for running `psupertime`. 143 | 144 | ``` 145 | # Option 1 (default): Select highly variable genes, using default settings for `scran`. 146 | psuper_hvg = psupertime(acinar_hvg_sce, y) 147 | psuper_hvg = psupertime(acinar_hvg_sce, y, sel_genes='hvg') 148 | 149 | # Option 2: Select highly variable genes, using your own settings. 150 | psuper_hvg_custom1 = psupertime(acinar_hvg_sce, y, sel_genes=list(hvg_cutoff=0.1, bio_cutoff=0.5)) 151 | psuper_hvg_custom2 = psupertime(acinar_hvg_sce, y, sel_genes=list(hvg_cutoff=0.1, bio_cutoff=0.5, span=0.1)) 152 | 153 | # Option 3: Use all genes 154 | psuper_all = psupertime(acinar_hvg_sce, y, sel_genes='all') 155 | 156 | # Option 4: Use transcription factors 157 | psuper_tf = psupertime(acinar_hvg_sce, y, sel_genes='tf_human') 158 | 159 | # Option 5: Use user-defined list of genes 160 | psuper_sel = psupertime( 161 | acinar_hvg_sce, y, 162 | sel_genes='list', 163 | gene_list=c('ITM2A', 'CLU', 'HSPH1', 'ADH1C', 'AMY2B') 164 | ) 165 | ``` 166 | 167 | **Performance characteristics** By default, `psupertime` uses the largest regularization which results in performance within one standard error of the best performance (`penalization='1se'`). You can choose to have the maximum performance (typically resulting in a larger set of non-zero genes), by using `penalization='best'`. You can also change the measure of performance used. 168 | 169 | ```{r} 170 | # run psupertime with different settings 171 | psuper_1se = psupertime(acinar_hvg_sce, y, sel_genes='all', penalization='1se') 172 | psuper_best = psupertime(acinar_hvg_sce, y, sel_genes='all', penalization='best') 173 | psuper_acc = psupertime(acinar_hvg_sce, y, sel_genes='all', score='class_error') 174 | 175 | # display results 176 | psuper_1se 177 | psuper_best 178 | psuper_acc 179 | ``` 180 | 181 | To see the full details of how `psupertime` can be used, read the documentation in the package: 182 | ``` 183 | ?psupertime 184 | ``` 185 | --------------------------------------------------------------------------------