PageRenderTime 72ms CodeModel.GetById 16ms RepoModel.GetById 1ms app.codeStats 0ms

/PhyloSim.R

http://github.com/sbotond/phylosim
R | 6741 lines | 2944 code | 500 blank | 3297 comment | 491 complexity | 599a6b1f6c5fd46221d5d716d177dc82 MD5 | raw file
Possible License(s): GPL-3.0
  1. ##
  2. ## Copyright 2009 Botond Sipos
  3. ## See the package description for licensing information.
  4. ##
  5. ##########################################################################/**
  6. #
  7. # @RdocClass PhyloSim
  8. # \alias{phylosim}
  9. #
  10. # @title "The PhyloSim class"
  11. #
  12. # \description{
  13. #
  14. # PhyloSim is an extensible object-oriented framework for the Monte Carlo simulation
  15. # of sequence evolution written in 100 percent \code{R}.
  16. # It is built on the top of the \code{\link{R.oo}} and \code{\link{ape}} packages and uses
  17. # Gillespie's direct method to simulate substitutions, insertions and deletions.
  18. #
  19. # Key features offered by the framework:
  20. # \itemize{
  21. # \item Simulation of the evolution of a set of discrete characters with arbitrary states evolving
  22. # by a continuous-time Markov process with an arbitrary rate matrix.
  23. # \item Explicit implementations of the most popular substitution models (for nucleotides, amino acids and codons).
  24. # \item Simulation under the popular models of among-sites rate variation, like the gamma (+G) and invariants plus gamma (+I+G) models.
  25. # \item The possibility to simulate with arbitrarily complex patterns of among-sites rate variation by setting the site specific rates according to any \code{R} expression.
  26. # \item Simulation with one or more separate insertion and/or deletion processes acting on the sequences, which sample the insertion/deletion length from an arbitrary discrete distribution or an \code{R} expression (so all the probability distributions implemented in \code{R} are readily available for this purpose).
  27. # \item Simulation of the effects of variable functional constraints over the sites by site-process-specific insertion and deletion tolerance parameters, which determine the rejection probability of a proposed insertion/deletion.
  28. # \item The possibility of having a different set of processes and site-process-specific parameters for every site, which allow for an arbitrary number of partitions in the simulated data.
  29. # \item Simulation of heterotachy and other cases of non-homogeneous evolution by allowing the user to set "node hook" functions altering the site properties at internal nodes of the phylogeny.
  30. # \item The possibility to export the counts of various events ("branch statistics") as phylo objects (see \code{\link{exportStatTree.PhyloSim}}).
  31. # }
  32. #
  33. # General notes:
  34. # \itemize{
  35. # \item The \code{Sequence} objects have no "immortal links". The simulation
  36. # is aborted if the sequence length shrinks to zero. It is up to the user
  37. # to choose sensible indel rates and sequence lengths to prevent that.
  38. # \item The sites near the beginning and end of the sequences have less sites proposing
  39. # insertion and deletion events around the so the insertion and deletion processes
  40. # have an "edge effect". The user can simulate
  41. # realistic flanking sequences to alleviate the edge effect in the simulation settings where
  42. # it may be an issue.
  43. # }
  44. #
  45. # Notes on performance:
  46. # \itemize{
  47. # \item The pure \code{R} implementation offers felxibility, but also comes
  48. # with a slower simulation speed. If the \code{PSIM_FAST} object is present in the environment, a "fast & careless"
  49. # mode is enabled. In this mode most of the error checking is skipped, increasing the speed.
  50. # It is recomended that simulations are only run in fast mode if you are sure that the simulation
  51. # settings are free from errors. It is probably a good practice to set up the simulations in normal mode
  52. # with short sequences and enable fast mode when running the actual simulation with long sequences.
  53. # \item Please note, that no "branch statistics" are saved in fast mode.
  54. # \item Logging also has a negative impact on performance, so it's not a good idea to run
  55. # large simulations with the logging enabled.
  56. # \item The time needed to run a simulation depends not only on the number of the sites,
  57. # but also on the length of the tree.
  58. # \item Constructing \code{Sequence} objects with large number of sites is expensive. Avoid doing
  59. # that inside a cycle.
  60. # \item In the case of \code{Sequence} objects with a large number of sites (more than 10 000) the
  61. # amount of available memory can be limiting as well.
  62. # }
  63. #
  64. # The examples below demonstrate only some more common simulation settings,
  65. # the framework offers much more flexibility. See the package
  66. # vignette (\code{vignette("PhyloSim",package="phylosim")}) and the
  67. # examples directory (\url{http://github.com/sbotond/phylosim/tree/master/examples/})
  68. # for additional examples.
  69. #
  70. # @classhierarchy
  71. # }
  72. #
  73. #
  74. # \references{
  75. # Gillespie, DT (1977) Exact stochastic simulation of coupled chemical reactions -
  76. # J. Phys. Chem. 81 (25):2340-2361 \url{http://dx.doi.org/10.1021/j100540a008}
  77. # }
  78. #
  79. # @synopsis
  80. #
  81. # \arguments{
  82. # \item{phylo}{A rooted phylo object, constructed by the APE package.}
  83. # \item{root.seq}{A valid Sequence object with Process objects attached. Used as the starting sequence during simulation.}
  84. # \item{name}{The name of the object (a character vector of length one).}
  85. # \item{log.file}{Name of the file used for logging.}
  86. # \item{log.level}{An integer specifying the verbosity of logging (see \code{\link{setLogLevel.PhyloSim}}).}
  87. # \item{...}{Not used.}
  88. # }
  89. #
  90. # \section{Fields and Methods}{
  91. # @allmethods
  92. # }
  93. #
  94. # \examples{
  95. # set.seed(1)
  96. # ## The following examples demonstrate
  97. # ## the typical use of the framework.
  98. # ## See the package vignette and
  99. # ## \url{http://github.com/sbotond/phylosim/tree/master/examples/}
  100. #
  101. # ## The ll() method gives information about the methods defined
  102. # ## in the immediate class of an object.
  103. # ## Useful when exploring the framework.
  104. #
  105. # s<-Sequence()
  106. # ll(s)
  107. # ll(PhyloSim())
  108. # ll(GTR())
  109. #
  110. # ## Example 1 - A short simulation:
  111. # ## simulate nucleotide seqeunces and display
  112. # ## the resulting alignment matrix.
  113. #
  114. # Simulate(
  115. # PhyloSim(phy=rcoal(3),
  116. # root=NucleotideSequence(string="ATGC", proc=list(list(JC69())) ) )
  117. # )$alignment
  118. #
  119. # # Construct a phylo object for the following
  120. # # simulations, scale total tree length to 1:
  121. #
  122. # tmp<-PhyloSim(phylo=rcoal(3))
  123. # scaleTree(tmp,1/tmp$treeLength)
  124. # tmp$treeLength
  125. # t<-tmp$phylo
  126. #
  127. # ## Example 3 - simulating rate variation,
  128. # ## insertions and deletions.
  129. # ## See the examples/example_3_clean.R file
  130. # ## in the phylosim GitHub repository.
  131. #
  132. # # construct a GTR process object
  133. # gtr<-GTR(
  134. # name="MyGTR",
  135. # rate.params=list(
  136. # "a"=1, "b"=2, "c"=3,
  137. # "d"=1, "e"=2, "f"=3
  138. # ),
  139. # base.freqs=c(2,2,1,1)/6
  140. # )
  141. # # get object summary
  142. # summary(gtr)
  143. # # display a bubble plot
  144. # plot(gtr)
  145. #
  146. # # construct root sequence object
  147. # s<-NucleotideSequence(length=20)
  148. # # attach process via virtual field
  149. # s$processes<-list(list(gtr))
  150. # # sample states from the equilibrium
  151. # # distribution of the attached processes
  152. # sampleStates(s)
  153. # # create among-site rate variation by sampling
  154. # # the "rate.multiplier" site-process-specific parameter
  155. # # from a discrete gamma distribution (GTR+G).
  156. # plusGamma(s,gtr,shape=0.1)
  157. # # make the range 11:12 invariable
  158. # setRateMultipliers(s,gtr,0,11:12)
  159. # # get the rate multipliers for s and gtr
  160. # getRateMultipliers(s,gtr)
  161. #
  162. # construct a deletion process object
  163. # # proposing lengths in the range 1:3
  164. # d<-DiscreteDeletor(
  165. # rate=0.1,
  166. # name="MyDel",
  167. # sizes=c(1:3),
  168. # probs=c(3/6,2/6,1/6)
  169. # )
  170. # # get object
  171. # summary(d)
  172. # # plot deletion length distribution
  173. # plot(d)
  174. # # attach deletion process d to sequence s
  175. # attachProcess(s,d)
  176. # # create a region rejecting all deletions
  177. # setDeletionTolerance(s,d,0,11:12)
  178. #
  179. # # construct an insertion process object
  180. # # proposing lengths in the range 1:3
  181. # i<-DiscreteInsertor(
  182. # rate=0.1,
  183. # name="MyDel",
  184. # sizes=c(1:2),
  185. # probs=c(1/2,1/2),
  186. # template.seq=NucleotideSequence(length=1,processes=list(list(JC69())))
  187. # )
  188. # # states will be sampled from the JC69 equilibrium distribution
  189. # # get object
  190. # summary(i)
  191. # # plot insertion length distribution
  192. # plot(i)
  193. # # attach insertion process i to sequence s
  194. # attachProcess(s,i)
  195. # # create a region rejecting all insertions
  196. # setInsertionTolerance(s,i,0,11:12)
  197. #
  198. # # plot total site rates
  199. # plot(s)
  200. # # construct simulation object
  201. # sim<-PhyloSim(root.seq=s, phylo=t)
  202. # # get object summary
  203. # summary(sim)
  204. # # plot tree
  205. # plot(sim)
  206. # # run simulation
  207. # Simulate(sim)
  208. # # get the list of recorded per-branch event counts
  209. # getBranchEvents(sim)
  210. # # export the number of substitutions as a phylo object
  211. # subst<-exportStatTree(sim,"substitution")
  212. # # plot the exported phylo object
  213. # plot(subst)
  214. # # plot tree and alignment
  215. # plot(sim)
  216. # # save and display alingment
  217. # file<-paste("PhyloSim_dummy_fasta_",Sys.getpid(),".fas",sep="");
  218. # saveAlignment(sim,file=file);
  219. # # print out the Fasta file
  220. # cat(paste(scan(file=file,what=character(),sep="\n"),collapse="\n"));cat("\n");
  221. # # delete Fasta file
  222. # unlink(file);
  223. #
  224. # # See \url{http://github.com/sbotond/phylosim/tree/master/examples/examples_class.R}
  225. # # for the full list of PhyloSim constructor examples.
  226. #
  227. # ## See the package vignette and
  228. # ## the GitHub repository for even more examples.
  229. # }
  230. #
  231. # @author
  232. #
  233. # \seealso{
  234. # \code{\link{PSRoot} \link{Alphabet} \link{AminoAcidAlphabet}
  235. # \link{AminoAcidSequence} \link{AminoAcidSubst}
  236. # \link{AnyAlphabet} \link{BinaryAlphabet} \link{BinarySequence}
  237. # \link{BinarySubst} \link{BrownianInsertor} \link{CodonAlphabet}
  238. # \link{CodonSequence} \link{CodonUNREST} \link{ContinuousDeletor}
  239. # \link{ContinuousInsertor} \link{cpREV} \link{DiscreteDeletor}
  240. # \link{DiscreteInsertor} \link{Event} \link{F81} \link{F84}
  241. # \link{FastFieldDeletor} \link{GeneralDeletor}
  242. # \link{GeneralInDel} \link{GeneralInsertor} \link{GeneralSubstitution}
  243. # \link{GTR} \link{GY94} \link{HKY} \link{JC69} \link{JTT} \link{JTT.dcmut}
  244. # \link{K80} \link{K81} \link{LG} \link{mtArt} \link{mtMam} \link{mtREV24}
  245. # \link{MtZoa} \link{NucleotideAlphabet} \link{NucleotideSequence} \link{PAM}
  246. # \link{PAM.dcmut} \link{PhyloSim} \link{Process} \link{QMatrix} \link{Sequence}
  247. # \link{Site} \link{T92} \link{TN93} \link{UNREST} \link{WAG}}
  248. # }
  249. #
  250. #*/###########################################################################
  251. setConstructorS3(
  252. "PhyloSim",
  253. function(
  254. phylo=NA,
  255. root.seq=NA,
  256. name=NA,
  257. log.file=NA,
  258. log.level=-1, # no loggin is performed by default
  259. ...
  260. ) {
  261. this<-PSRoot();
  262. this<-extend(this,
  263. "PhyloSim",
  264. .name="Anonymous",
  265. .phylo=NA,
  266. .root.sequence=NA,
  267. .sequences=list(), # references to the sequence objects
  268. .node.hooks=list(), # references to the node hook functions.
  269. .branch.stats=list(), # branch statistics.
  270. .alignment=NA, # the resulting alignment in fasat format.
  271. .log.file=NA, # the name of the log file.
  272. .log.connection=NA, # connection for the log file.
  273. .log.level=NA # log level
  274. );
  275. if(!all(is.na(phylo))){
  276. this$phylo<-phylo;
  277. }
  278. if(!all(is.na(root.seq))){
  279. this$rootSeq<-root.seq;
  280. }
  281. if(!missing(name)){
  282. this$name<-name;
  283. }
  284. if(!missing(log.file)){
  285. this$logFile<-log.file;
  286. } else {
  287. # Setting default log file:
  288. tmp<-this$id;
  289. tmp<-gsub(":","_",tmp);
  290. this$logFile<-paste(tmp,".log",sep="");
  291. }
  292. # Setting log level:
  293. this$logLevel<-log.level;
  294. return(this);
  295. },
  296. enforceRCC=TRUE
  297. );
  298. ##
  299. ## Method: checkConsistency
  300. ##
  301. ###########################################################################/**
  302. #
  303. # @RdocMethod checkConsistency
  304. #
  305. # @title "Check object consistency"
  306. #
  307. # \description{
  308. # @get "title".
  309. # }
  310. #
  311. # @synopsis
  312. #
  313. # \arguments{
  314. # \item{this}{An object.}
  315. # \item{...}{Not used.}
  316. # }
  317. #
  318. #
  319. # \value{
  320. # Returns an invisible TRUE if no inconsistencies found in the object, throws
  321. # an error otherwise.
  322. # }
  323. #
  324. # @author
  325. #
  326. # \seealso{
  327. # @seeclass
  328. # }
  329. #
  330. #*/###########################################################################
  331. setMethodS3(
  332. "checkConsistency",
  333. class="PhyloSim",
  334. function(
  335. this,
  336. ...
  337. ){
  338. may.fail<-function(this) {
  339. # Checking the name:
  340. this$name<-this$name;
  341. # Checking the phylo object:
  342. if (!any(is.na(this$.phylo)) & !is.phylo(this$.phylo) ){
  343. throw("The phylo object is invalid!\n");
  344. }
  345. # Checking the log level:
  346. if(!is.numeric(this$.log.level) | (length(this$.log.level) != 1) ){
  347. throw("The log level must be numeric vector of length 1!\n");
  348. }
  349. # Checking lof file:
  350. if(!is.character(this$.log.file) | (length(this$.log.level) != 1) ){
  351. throw("The log file must be charcter vector of length 1!\n");
  352. }
  353. # Checking the sequences:
  354. for (seq in this$.sequences){
  355. if(is.Sequence(seq)){
  356. checkConsistency(seq);
  357. }
  358. }
  359. # Checking node hooks:
  360. for (hook in this$.node.hooks){
  361. if(!is.null(hook) & !is.function(hook)){
  362. throw("Invalid node hook found!\n");
  363. }
  364. }
  365. # Checking the alignment:
  366. if(!any(is.na(this$.alignment))){
  367. .checkAlignmentConsistency(this, this$.alignment);
  368. }
  369. }
  370. tryCatch(may.fail(this));
  371. return(invisible(TRUE));
  372. },
  373. private=FALSE,
  374. protected=FALSE,
  375. overwrite=FALSE,
  376. conflict="warning",
  377. validators=getOption("R.methodsS3:validators:setMethodS3")
  378. )
  379. ##
  380. ## Method: is.phylo.default
  381. ##
  382. ###########################################################################/**
  383. #
  384. # @RdocDefault is.phylo
  385. #
  386. # @title "Check if an object is an instance of the phylo class"
  387. #
  388. # \description{
  389. # @get "title".
  390. # Phylo objects are created by the \pkg{APE} package. This method just return the value of \code{inherits(this,"phylo")}.
  391. # }
  392. #
  393. # @synopsis
  394. #
  395. # \arguments{
  396. # \item{this}{An object.}
  397. # \item{...}{Not used.}
  398. # }
  399. #
  400. # \value{
  401. # TRUE or FALSE.
  402. # }
  403. #
  404. # \examples{
  405. # # load APE
  406. # library(ape);
  407. # # create some objects
  408. # o1<-Object();
  409. # o2<-rcoal(3);
  410. # # check if they are phylo objects
  411. # is.phylo(o1);
  412. # is.phylo(o2);
  413. #
  414. # }
  415. #
  416. # @author
  417. #
  418. # \seealso{
  419. # The \pkg{ape} package.
  420. # }
  421. #
  422. #*/###########################################################################
  423. setMethodS3(
  424. "is.phylo",
  425. class="default",
  426. function(
  427. this,
  428. ...
  429. ){
  430. inherits(this,"phylo");
  431. },
  432. private=FALSE,
  433. protected=FALSE,
  434. overwrite=FALSE,
  435. conflict="warning",
  436. validators=getOption("R.methodsS3:validators:setMethodS3")
  437. )
  438. ##
  439. ## Method: setPhylo
  440. ##
  441. ###########################################################################/**
  442. #
  443. # @RdocMethod setPhylo
  444. #
  445. # @title "Set the phylo object for a PhyloSim object"
  446. #
  447. # \description{
  448. # @get "title".
  449. #
  450. # The internal structure of the provided phylo object is reordered in a cladeweise fashion.
  451. # }
  452. #
  453. # @synopsis
  454. #
  455. # \arguments{
  456. # \item{this}{A PhyloSim object.}
  457. # \item{value}{A phylo object created by the \pkg{ape} package.}
  458. # \item{...}{Not used.}
  459. # }
  460. #
  461. # \value{
  462. # A phylo object or FALSE.
  463. # }
  464. #
  465. # \examples{
  466. # #create a PhyloSim object
  467. # sim<-PhyloSim();
  468. # # creat a phylo object
  469. # tree<-rcoal(3);
  470. # # get/set phylo object
  471. # setPhylo(sim,tree);
  472. # getPhylo(sim,tree);
  473. # # get/set phylo object via virtual field
  474. # sim$tree<-rcoal(5);
  475. # sim$tree;
  476. # }
  477. #
  478. # @author
  479. #
  480. # \seealso{
  481. # The PhyloSim class, the \pkg{ape} package.
  482. # }
  483. #
  484. #*/###########################################################################
  485. setMethodS3(
  486. "setPhylo",
  487. class="PhyloSim",
  488. function(
  489. this,
  490. value,
  491. ...
  492. ){
  493. if(missing(value)){
  494. throw("No object provided!\n");
  495. }
  496. else if(!is.phylo(value)){
  497. throw("The new value must be a \"phylo\" object!\n");
  498. }
  499. else if(!is.rooted(value)){
  500. throw("The new value must be a rooted \"phylo\" object!\n");
  501. }
  502. else {
  503. .checkTipLabels(value);
  504. this$.phylo<-value;
  505. this$.phylo<-reorder(this$.phylo, order="cladewise");
  506. for (i in this$nodes){
  507. this$.sequences[[i]]<-NA;
  508. }
  509. return(this$.phylo);
  510. }
  511. return(FALSE);
  512. },
  513. private=FALSE,
  514. protected=FALSE,
  515. overwrite=FALSE,
  516. conflict="warning",
  517. validators=getOption("R.methodsS3:validators:setMethodS3")
  518. );
  519. ##
  520. ## Method: .checkTipLabels
  521. ##
  522. setMethodS3(
  523. ".checkTipLabels",
  524. class="phylo",
  525. function(
  526. this,
  527. ...
  528. ){
  529. for(label in this$tip.label){
  530. if(length(grep("^Node \\d+$",label,perl=TRUE,value=FALSE)) > 0){
  531. throw("Sorry, but the node labels matching \"Node \\d+\" are reserved for internal nodes! Blaming label: ",label,".\n");
  532. }
  533. else if(length(grep("^Root node \\d+$",label,perl=TRUE,value=FALSE)) > 0){
  534. throw("Sorry, but the node labels matching \"Root node \\d+\" are reserved for the root node! Blaming label: ",label,".\n");
  535. }
  536. }
  537. },
  538. private=TRUE,
  539. protected=FALSE,
  540. overwrite=FALSE,
  541. conflict="warning",
  542. validators=getOption("R.methodsS3:validators:setMethodS3")
  543. )
  544. ##
  545. ## Method: getPhylo
  546. ##
  547. ###########################################################################/**
  548. #
  549. # @RdocMethod getPhylo
  550. #
  551. # @title "Get the phylo object aggregated in a PhyloSim object"
  552. #
  553. # \description{
  554. # @get "title".
  555. #
  556. # }
  557. #
  558. # @synopsis
  559. #
  560. # \arguments{
  561. # \item{this}{A PhyloSim object.}
  562. # \item{...}{Not used.}
  563. # }
  564. #
  565. # \value{
  566. # A phylo object or NA.
  567. # }
  568. #
  569. # \examples{
  570. # #create a PhyloSim object
  571. # sim<-PhyloSim();
  572. # # creat a phylo object
  573. # tree<-rcoal(3);
  574. # # get/set phylo object
  575. # setPhylo(sim,tree);
  576. # getPhylo(sim,tree);
  577. # # get/set phylo object via virtual field
  578. # sim$tree<-rcoal(5);
  579. # sim$tree;
  580. # }
  581. #
  582. # @author
  583. #
  584. # \seealso{
  585. # The PhyloSim class, the \pkg{ape} package.
  586. # }
  587. #
  588. #*/###########################################################################
  589. setMethodS3(
  590. "getPhylo",
  591. class="PhyloSim",
  592. function(
  593. this,
  594. ...
  595. ){
  596. this$.phylo;
  597. },
  598. private=FALSE,
  599. protected=FALSE,
  600. overwrite=FALSE,
  601. conflict="warning",
  602. validators=getOption("R.methodsS3:validators:setMethodS3")
  603. )
  604. ##
  605. ## Method: setRootSeq
  606. ##
  607. ###########################################################################/**
  608. #
  609. # @RdocMethod setRootSeq
  610. #
  611. # @title "Set the root sequence for a PhyloSim object"
  612. #
  613. # \description{
  614. # @get "title".
  615. #
  616. # The root sequence will be used as a starting point for the simulation. The phylo object must be set before
  617. # trying to set the root sequence object.
  618. # }
  619. #
  620. # @synopsis
  621. #
  622. # \arguments{
  623. # \item{this}{A PhyloSim object.}
  624. # \item{value}{A valid Sequence object.}
  625. # \item{...}{Not used.}
  626. # }
  627. #
  628. # \value{
  629. # The root Sequence object if succesfull, FALSE otherwise.
  630. # }
  631. #
  632. # \examples{
  633. # # create some objects
  634. # sim<-PhyloSim(phylo=rcoal(3));
  635. # seq<-NucleotideSequence(string="ATGCC");
  636. # # set/get root sequence
  637. # setRootSeq(sim, seq);
  638. # getRootSeq(sim, seq);
  639. # # set/get root sequence via virtual field
  640. # sim$rootSeq<-BinarySequence(string="111000111000");
  641. # sim$rootSeq;
  642. #
  643. # }
  644. #
  645. # @author
  646. #
  647. # \seealso{
  648. # @seeclass Sequence Process
  649. # }
  650. #
  651. #*/###########################################################################
  652. setMethodS3(
  653. "setRootSeq",
  654. class="PhyloSim",
  655. function(
  656. this,
  657. value,
  658. ...
  659. ){
  660. if(missing(value)){
  661. throw("No object provided!\n");
  662. }
  663. else if(!is.Sequence(value)){
  664. throw("The new value must be a sequence object!\n");
  665. }
  666. else {
  667. this$.root.sequence<-clone(value);
  668. this$.root.sequence$name<-paste("Root node",this$rootNode);
  669. # Call garbage collection:
  670. gc();
  671. gc();
  672. return(this$.root.sequence);
  673. }
  674. return(FALSE);
  675. },
  676. private=FALSE,
  677. protected=FALSE,
  678. overwrite=FALSE,
  679. conflict="warning",
  680. validators=getOption("R.methodsS3:validators:setMethodS3")
  681. )
  682. ##
  683. ## Method: getRootSeq
  684. ##
  685. ###########################################################################/**
  686. #
  687. # @RdocMethod getRootSeq
  688. #
  689. # @title "Get the root sequence aggregated by a PhyloSim object"
  690. #
  691. # \description{
  692. # @get "title".
  693. #
  694. # }
  695. #
  696. # @synopsis
  697. #
  698. # \arguments{
  699. # \item{this}{A PhyloSim object.}
  700. # \item{...}{Not used.}
  701. # }
  702. #
  703. # \value{
  704. # The root Sequence object or NA.
  705. # }
  706. #
  707. # \examples{
  708. # # create some objects
  709. # sim<-PhyloSim(phylo=rcoal(3));
  710. # seq<-NucleotideSequence(string="ATGCC");
  711. # # set/get root sequence
  712. # setRootSeq(sim, seq);
  713. # getRootSeq(sim, seq);
  714. # # set/get root sequence via virtual field
  715. # sim$rootSeq<-BinarySequence(string="111000111000");
  716. # sim$rootSeq;
  717. #
  718. # }
  719. #
  720. # @author
  721. #
  722. # \seealso{
  723. # @seeclass Sequence Process
  724. # }
  725. #
  726. #*/###########################################################################
  727. setMethodS3(
  728. "getRootSeq",
  729. class="PhyloSim",
  730. function(
  731. this,
  732. ...
  733. ){
  734. this$.root.sequence;
  735. },
  736. private=FALSE,
  737. protected=FALSE,
  738. overwrite=FALSE,
  739. conflict="warning",
  740. validators=getOption("R.methodsS3:validators:setMethodS3")
  741. )
  742. ##
  743. ## Method: as.character.PhyloSim
  744. ##
  745. ###########################################################################/**
  746. #
  747. # @RdocMethod as.character
  748. #
  749. # @title "Return the character representation of a PhyloSim object"
  750. #
  751. # \description{
  752. # @get "title".
  753. #
  754. # The character representation is the identifier of the PhyloSim object as returned by the \code{getId} method.
  755. # }
  756. #
  757. # @synopsis
  758. #
  759. # \arguments{
  760. # \item{x}{A PhyloSim object.}
  761. # \item{...}{Not used.}
  762. # }
  763. #
  764. # \value{
  765. # A character vector of length one.
  766. # }
  767. #
  768. # \examples{
  769. # # create a PhyloSim object
  770. # o<-PhyloSim(name="MySim");
  771. # # get character representation
  772. # as.character(o)
  773. # }
  774. #
  775. # @author
  776. #
  777. # \seealso{
  778. # @seeclass
  779. # }
  780. #
  781. #*/###########################################################################
  782. setMethodS3(
  783. "as.character",
  784. class="PhyloSim",
  785. function(
  786. x,
  787. ...
  788. ){
  789. return(getId(x));
  790. },
  791. private=FALSE,
  792. protected=FALSE,
  793. overwrite=FALSE,
  794. conflict="warning",
  795. validators=getOption("R.methodsS3:validators:setMethodS3")
  796. )
  797. ##
  798. ## Method: getName
  799. ##
  800. ###########################################################################/**
  801. #
  802. # @RdocMethod getName
  803. #
  804. # @title "Get the name of a PhyloSim object"
  805. #
  806. # \description{
  807. # @get "title".
  808. # }
  809. #
  810. # @synopsis
  811. #
  812. # \arguments{
  813. # \item{this}{A PhyloSim object.}
  814. # \item{...}{Not used.}
  815. # }
  816. #
  817. # \value{
  818. # A character vector of length one.
  819. # }
  820. #
  821. # \examples{
  822. # # create a PhyloSim object
  823. # o<-PhyloSim();
  824. # # set/get name
  825. # setName(o,"MySim");
  826. # getName(o,"MySim");
  827. # # set/get name via virtual field
  828. # o$name<-"George";
  829. # o$name
  830. # }
  831. #
  832. # @author
  833. #
  834. # \seealso{
  835. # @seeclass
  836. # }
  837. #
  838. #*/###########################################################################
  839. setMethodS3(
  840. "getName",
  841. class="PhyloSim",
  842. function(
  843. this,
  844. ...
  845. ){
  846. this$.name;
  847. },
  848. private=FALSE,
  849. protected=FALSE,
  850. overwrite=FALSE,
  851. conflict="warning",
  852. validators=getOption("R.methodsS3:validators:setMethodS3")
  853. );
  854. ##
  855. ## Method: setName
  856. ##
  857. ###########################################################################/**
  858. #
  859. # @RdocMethod setName
  860. #
  861. # @title "Set the name of a PhyloSim object"
  862. #
  863. # \description{
  864. # @get "title".
  865. # }
  866. #
  867. # @synopsis
  868. #
  869. # \arguments{
  870. # \item{this}{A PhyloSim object.}
  871. # \item{new.name}{A character vector of length one.}
  872. # \item{...}{Not used.}
  873. # }
  874. #
  875. # \value{
  876. # The new name.
  877. # }
  878. #
  879. # \examples{
  880. # # create a PhyloSim object
  881. # o<-PhyloSim();
  882. # # set/get name
  883. # setName(o,"MySim");
  884. # getName(o,"MySim");
  885. # # set/get name via virtual field
  886. # o$name<-"George";
  887. # o$name
  888. # }
  889. #
  890. # @author
  891. #
  892. # \seealso{
  893. # @seeclass
  894. # }
  895. #
  896. #*/###########################################################################
  897. setMethodS3(
  898. "setName",
  899. class="PhyloSim",
  900. function(
  901. this,
  902. new.name,
  903. ...
  904. ){
  905. this$.name<-as.character(new.name);
  906. },
  907. private=FALSE,
  908. protected=FALSE,
  909. overwrite=FALSE,
  910. conflict="warning",
  911. validators=getOption("R.methodsS3:validators:setMethodS3")
  912. );
  913. ##
  914. ## Method: getId
  915. ##
  916. ###########################################################################/**
  917. #
  918. # @RdocMethod getId
  919. #
  920. # @title "Get the unique identifier of a PhyloSim object"
  921. #
  922. # \description{
  923. # @get "title".
  924. # The unique identifier is the concatenation of the class, the object name as returned by getName() and the object hash
  925. # as returned by hashCode().
  926. # }
  927. #
  928. # @synopsis
  929. #
  930. # \arguments{
  931. # \item{this}{A PhyloSim object.}
  932. # \item{...}{Not used.}
  933. # }
  934. #
  935. # \value{
  936. # A character vector of length one.
  937. # }
  938. #
  939. # \examples{
  940. # # create a PhyloSim object
  941. # o<-PhyloSim(name="MySim");
  942. # # get id
  943. # getId(o);
  944. # # get id via virtual field
  945. # o$id;
  946. # }
  947. #
  948. # @author
  949. #
  950. # \seealso{
  951. # @seeclass
  952. # }
  953. #
  954. #*/###########################################################################
  955. setMethodS3(
  956. "getId",
  957. class="PhyloSim",
  958. function(
  959. this,
  960. ...
  961. ){
  962. this.class<-class(this)[1];
  963. id<-paste(this.class,this$.name,hashCode(this),sep=":");
  964. return(id);
  965. },
  966. private=FALSE,
  967. protected=FALSE,
  968. overwrite=FALSE,
  969. conflict="warning",
  970. validators=getOption("R.methodsS3:validators:setMethodS3")
  971. );
  972. ##
  973. ## Method: setId
  974. ##
  975. ###########################################################################/**
  976. #
  977. # @RdocMethod setId
  978. #
  979. # @title "Forbidden action: setting the unique identifier of a PhyloSim object"
  980. #
  981. # \description{
  982. # @get "title".
  983. #
  984. # }
  985. #
  986. # @synopsis
  987. #
  988. # \arguments{
  989. # \item{this}{An object.}
  990. # \item{value}{Not used.}
  991. # \item{...}{Not used.}
  992. # }
  993. #
  994. # \value{
  995. # Throws an error.
  996. # }
  997. #
  998. # @author
  999. #
  1000. # \seealso{
  1001. # @seeclass
  1002. # }
  1003. #
  1004. #*/###########################################################################
  1005. setMethodS3(
  1006. "setId",
  1007. class="PhyloSim",
  1008. function(
  1009. this,
  1010. value,
  1011. ...
  1012. ){
  1013. throw("Id is generated automatically and it cannot be set!\n");
  1014. },
  1015. private=FALSE,
  1016. protected=FALSE,
  1017. overwrite=FALSE,
  1018. conflict="warning",
  1019. validators=getOption("R.methodsS3:validators:setMethodS3")
  1020. );
  1021. ##
  1022. ## Method: Simulate
  1023. ##
  1024. ###########################################################################/**
  1025. #
  1026. # @RdocMethod Simulate
  1027. #
  1028. # @title "Run a simulation according to a PhyloSim object"
  1029. #
  1030. # \description{
  1031. # @get "title".
  1032. #
  1033. # The phylo object and the root sequence must be set before attempting to run a simulation.
  1034. # Also the bigRate of the root sequence must not be NA or zero, so at least one sane
  1035. # Process object must be attached to the root sequence object.
  1036. # }
  1037. #
  1038. # @synopsis
  1039. #
  1040. # \arguments{
  1041. # \item{this}{A PhyloSim object.}
  1042. # \item{quiet}{TRUE or FALSE (default).}
  1043. # \item{...}{Not used.}
  1044. # }
  1045. #
  1046. # \value{
  1047. # The PhyloSim object (invisible).
  1048. # }
  1049. #
  1050. # \examples{
  1051. # # Create a PhyloSim object.
  1052. # # Provide the phylo object
  1053. # # and the root sequence.
  1054. # sim<-PhyloSim(
  1055. # name="TinySim",
  1056. # phylo=rcoal(3),
  1057. # root.seq=NucleotideSequence(string="ATGC",processes=list(list(JC69())))
  1058. # );
  1059. # # Run the simulation
  1060. # Simulate(sim);
  1061. # # Print the resulting sequences
  1062. # sim$sequences
  1063. # # Print the resulting alignment
  1064. # sim$alignment
  1065. # }
  1066. #
  1067. # @author
  1068. #
  1069. # \seealso{
  1070. # @seeclass
  1071. # }
  1072. #
  1073. #*/###########################################################################
  1074. setMethodS3(
  1075. "Simulate",
  1076. class="PhyloSim",
  1077. function(
  1078. this,
  1079. quiet=FALSE,
  1080. ...
  1081. ){
  1082. if(!is.phylo(this$.phylo)){
  1083. throw("Cannot simulate because the phylo object is not set or it is invalid!\n");
  1084. }
  1085. # Check for the root sequence:
  1086. else if(!is.Sequence(this$.root.sequence)){
  1087. throw("Cannot simulate because the root sequence is not set or it is invalid!\n");
  1088. }
  1089. # Check bigRate validity:
  1090. else if(is.na(this$.root.sequence$bigRate)){
  1091. throw("Cannot simulate because the bigRate of the root sequence is NA!\n");
  1092. }
  1093. else{
  1094. # Warn for zero bigRate:
  1095. if(this$.root.sequence$bigRate == 0){
  1096. warning("The bigRate of the root sequence is zero! You are running a pointless simulation!\n");
  1097. }
  1098. if(exists(x="PSIM_FAST")){
  1099. if(!quiet){
  1100. cat("!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n");
  1101. cat("!! WARNING: fast & careless mode is on, most of the error checking is omitted! !!\n");
  1102. cat("!! Please note that this also disables the saving of branch statistics. !!\n");
  1103. cat("!! You can go back to normal mode by deleting the PSIM_FAST object. !!\n");
  1104. cat("!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n");
  1105. }
  1106. Log(this,"WARNING: fast & careless mode is on, most of the error checking is omitted!");
  1107. }
  1108. # Attach root sequence to root node:
  1109. Log(this,paste("Attaching root sequence ",this$.root.sequence$id,sep=""));
  1110. attachSeqToNode(this, node=getRootNode(this),seq=this$.root.sequence);
  1111. # Write protecting the root sequence:
  1112. Log(this,paste("Write protecting root sequence ",this$.root.sequence$id,sep=""));
  1113. this$.root.sequence$writeProtected<-TRUE;
  1114. # Traverse the tree and simulate:
  1115. Log(this,paste("Starting simulation on the object",this$id));
  1116. edge.counter<-1;
  1117. n.edges<-this$nedges;
  1118. for(edge in 1:n.edges){
  1119. if(!quiet){ cat("Simulating edge",edge,"of", n.edges,"\n");}
  1120. Log(this,paste("Starting to simulate edge",edge,"of",n.edges));
  1121. .simulateEdge(this,number=edge);
  1122. edge.counter<-edge.counter+1;
  1123. }
  1124. }
  1125. Log(this, "Simulation finished, building alignment!\n");
  1126. this$.alignment<-.recoverAlignment(this);
  1127. # Flush the log connection:
  1128. if(!is.na(this$.log.connection)){
  1129. close(this$.log.connection);
  1130. }
  1131. # Call the garbage collector:
  1132. gc();
  1133. gc();
  1134. return(invisible(this));
  1135. },
  1136. private=FALSE,
  1137. protected=FALSE,
  1138. overwrite=FALSE,
  1139. conflict="warning",
  1140. validators=getOption("R.methodsS3:validators:setMethodS3")
  1141. );
  1142. ##
  1143. ## Method: .simulateEdge
  1144. ##
  1145. setMethodS3(
  1146. ".simulateEdge",
  1147. class="PhyloSim",
  1148. function(
  1149. this,
  1150. number=NA,
  1151. ...
  1152. ){
  1153. # Get edge:
  1154. edge<-getEdge(this, number);
  1155. # Get parent node:
  1156. start.seq<-getSeqFromNode(this, edge[[1,"from"]]);
  1157. # Evolve sequence:
  1158. new.seq<-.evolveBranch(this, start.seq=start.seq, branch.length=edge[1,"length"], old.node=edge[[1,"from"]],new.node=edge[[1,"to"]], branch.number=number);
  1159. # Write protect the sequence:
  1160. new.seq$writeProtected<-TRUE;
  1161. # Attach sequence to children node:
  1162. attachSeqToNode(this, node=edge[1,"to"], seq=new.seq);
  1163. },
  1164. private=TRUE,
  1165. protected=FALSE,
  1166. overwrite=FALSE,
  1167. conflict="warning",
  1168. validators=getOption("R.methodsS3:validators:setMethodS3")
  1169. );
  1170. ##
  1171. ## Method: .evolveBranch
  1172. ##
  1173. setMethodS3(
  1174. ".evolveBranch",
  1175. class="PhyloSim",
  1176. function(
  1177. this,
  1178. start.seq=NA,
  1179. branch.length=NA,
  1180. old.node=NA,
  1181. new.node=NA,
  1182. branch.number=NA,
  1183. ...
  1184. ){
  1185. if(!exists(x="PSIM_FAST")){
  1186. if(missing(start.seq)){
  1187. throw("No starting sequence provided!\n");
  1188. }
  1189. else if(missing(branch.length)){
  1190. throw("No branch length provided!\n");
  1191. }
  1192. else if(!is.numeric(branch.length)){
  1193. throw("The branch length must be numeric!\n");
  1194. }
  1195. }
  1196. if(.checkSeq(this, start.seq) ){
  1197. # Cloning the starting sequence:
  1198. seq<-clone(start.seq);
  1199. # Set the name of the sequence object:
  1200. if(is.tip(this, new.node)){
  1201. seq$name<-this$tipLabels[[new.node]];
  1202. }
  1203. else {
  1204. seq$name<-paste("Node",new.node);
  1205. }
  1206. .GillespieDirect(this, seq=seq, branch.length=branch.length, branch.number=branch.number);
  1207. # Call the node hook if exists:
  1208. hook<-this$.node.hooks[[as.character(new.node)]];
  1209. if(!is.null(hook) & is.function(hook)){
  1210. Log(this,paste("Calling node hook for node",new.node));
  1211. seq<-hook(seq=seq);
  1212. if(!is.Sequence(seq)){
  1213. throw("Node hook returned an invalid sequence object!\n");
  1214. }
  1215. else if(is.na(seq$bigRate)){
  1216. throw("Node hook returned sequence with NA bigRate!\n");
  1217. }
  1218. else if(seq$bigRate == 0.0){
  1219. throw("Node hook returned sequence with zero bigRate!\n");
  1220. }
  1221. else{
  1222. checkConsistency(seq, omit.sites=TRUE);
  1223. }
  1224. }
  1225. # Return the resulting sequence object:
  1226. return(seq);
  1227. }
  1228. },
  1229. private=FALSE,
  1230. protected=FALSE,
  1231. overwrite=FALSE,
  1232. conflict="warning",
  1233. validators=getOption("R.methodsS3:validators:setMethodS3")
  1234. );
  1235. ##
  1236. ## Method: .GillespieDirect
  1237. ##
  1238. setMethodS3(
  1239. ".GillespieDirect",
  1240. class="PhyloSim",
  1241. function(
  1242. this,
  1243. seq=NA,
  1244. branch.length=NA,
  1245. branch.number=NA,
  1246. ...
  1247. ){
  1248. Debug(this, paste("Branch length is",branch.length));
  1249. # Initialize time:
  1250. time<-0.0;
  1251. # Sample the next waiting time until
  1252. # the branch length is consumed:
  1253. while( (time<-time + rexp(n=1, rate=(big.rate<-getBigRate(seq)))) <= branch.length){
  1254. # Generate a random number between zero and the bigRate:
  1255. E<-runif(n=1,min=0,max=big.rate);
  1256. # Identify the target site:
  1257. site.number<-which(.getCumulativeRatesFast(seq) >= E)[[1]];
  1258. # Get the events from the target site:
  1259. site<-seq$.sites[[site.number]];
  1260. site$.position<-site.number;
  1261. events<-getEvents(site);
  1262. site$.position<-NULL;
  1263. # Get the rates:
  1264. rates<-double();
  1265. for(e in events){
  1266. rates<-c(rates,e$.rate);
  1267. }
  1268. # Calculate the corresponding cumulative rates:
  1269. if(site.number > 1){
  1270. rates<-cumsum(c(seq$.cumulative.rates[[site.number - 1]], rates));
  1271. }
  1272. else {
  1273. rates<-cumsum(c(0.0, rates));
  1274. }
  1275. # Pick the event:
  1276. event.number<-which(rates >= E)[[1]] - 1;
  1277. event<-events[[event.number]];
  1278. # Log the event:
  1279. Log(this,paste("Performing event [",event$.name,"] at position",event$.position,"generated by the process",event$.process$.id));
  1280. # Perform the event:
  1281. event.details<-Perform(event);
  1282. Debug(this,paste("Remaining branch length is",(branch.length-time) ));
  1283. # Log event details:
  1284. # Log deletion event details:
  1285. if(event$.name == "Deletion"){
  1286. Log(this,paste("The process",event$.process,"proposed to delete range",paste(event.details$range,collapse="--"),". Accepted:",event.details$accepted));
  1287. }
  1288. # Log insertion event details:
  1289. else if(event$.name == "Insertion"){
  1290. message<-paste("The process ",event$.process," proposed insertion at position ",event.details$position,". Accepted: ",event.details$accepted,sep="");
  1291. if(event.details$accepted == TRUE){
  1292. message<-paste(message,"."," Insert length was ",event.details$length,sep="");
  1293. }
  1294. Log(this, message);
  1295. }
  1296. # Update branch statistics if not in fast mode:
  1297. if(!exists(x="PSIM_FAST")){
  1298. .UpdateBranchStats(this,event,event.details, branch.number);
  1299. }
  1300. # Abort if sequence length shrunk to zero:
  1301. if(seq$.length == 0){
  1302. message<-paste("Terminating the simulation because the length of the sequence ",seq$name," shrunk to zero! Please be more careful when tuning the indel rates!\n");
  1303. Log(this, message);
  1304. throw(message);
  1305. }
  1306. } #/while
  1307. # Calling garbage collection:
  1308. gc();
  1309. gc();
  1310. return(seq);
  1311. },
  1312. private=FALSE,
  1313. protected=FALSE,
  1314. overwrite=FALSE,
  1315. conflict="warning",
  1316. validators=getOption("R.methodsS3:validators:setMethodS3")
  1317. );
  1318. ##
  1319. ## Method: attachSeqToNode
  1320. ##
  1321. ###########################################################################/**
  1322. #
  1323. # @RdocMethod attachSeqToNode
  1324. #
  1325. # @title "Assotiate a Sequence object with a given node of a phylo object aggregated by a PhyloSim object"
  1326. #
  1327. # \description{
  1328. # @get "title".
  1329. #
  1330. # This method is mainly used internally.
  1331. #
  1332. # }
  1333. #
  1334. # @synopsis
  1335. #
  1336. # \arguments{
  1337. # \item{this}{A PhyloSim object.}
  1338. # \item{node}{Node identifier.}
  1339. # \item{seq}{A Sequence object.}
  1340. # \item{...}{Not used.}
  1341. # }
  1342. #
  1343. # \value{
  1344. # The PhyloSim object (invisible).
  1345. # }
  1346. #
  1347. #
  1348. # @author
  1349. #
  1350. # \seealso{
  1351. # @seeclass
  1352. # }
  1353. #
  1354. #*/###########################################################################
  1355. setMethodS3(
  1356. "attachSeqToNode",
  1357. class="PhyloSim",
  1358. function(
  1359. this,
  1360. node=NA,
  1361. seq=NA,
  1362. ...
  1363. ){
  1364. if(!is.phylo(this$.phylo)){
  1365. throw("The phylo object is not set, sequence to node is not possible!\n");
  1366. }
  1367. if(missing(node)){
  1368. throw("No node specified!\n");
  1369. }
  1370. else if(missing(seq)){
  1371. throw("No sequence object given");
  1372. }
  1373. else if(.checkNode(this,node) & .checkSeq(this, seq)){
  1374. if(is.Sequence(this$.sequences[[node]])){
  1375. throw("The node has already an attached sequence. Detach that before trying to attach a new one!\n");
  1376. }
  1377. else {
  1378. this$.sequences[[as.numeric(node)]]<-seq;
  1379. return(invisible(this));
  1380. }
  1381. }
  1382. return(invisible(this));
  1383. },
  1384. private=FALSE,
  1385. protected=FALSE,
  1386. overwrite=FALSE,
  1387. conflict="warning",
  1388. validators=getOption("R.methodsS3:validators:setMethodS3")
  1389. );
  1390. ##
  1391. ## Method: attachHookToNode
  1392. ##
  1393. ###########################################################################/**
  1394. #
  1395. # @RdocMethod attachHookToNode
  1396. #
  1397. # @title "Attach a callback function to a given node of a phylo object aggregated by a PhyloSim object"
  1398. #
  1399. # \description{
  1400. # @get "title".
  1401. #
  1402. # A "node hook" is a function which accepts a Sequence object through the named argument "seq" and returns a
  1403. # Sequence object. The node hook function must accept any object which inherits from the \code{Sequence} class!
  1404. #
  1405. # After simulating the branch leading to the node, the resulting Sequence object is passed
  1406. # to the node hook and the returned object is used to simulate the downstream branches.
  1407. #
  1408. # By using node hooks the attached processes can be replaced during simulation, hence enabling the simulation of
  1409. # non-homogeneous sequence evolution.
  1410. # }
  1411. #
  1412. # @synopsis
  1413. #
  1414. # \arguments{
  1415. # \item{this}{A PhyloSim object.}
  1416. # \item{node}{Node identifier.}
  1417. # \item{fun}{A function (see above).}
  1418. # \item{...}{Not used.}
  1419. # }
  1420. #
  1421. # \value{
  1422. # The PhyloSim object (invisible).
  1423. # }
  1424. #
  1425. # \examples{
  1426. # # Create a PhyloSim object.
  1427. # # Provide the phylo object
  1428. # # and the root sequence.
  1429. # sim<-PhyloSim(
  1430. # name="TinySim",
  1431. # phylo=rcoal(3),
  1432. # root.seq=NucleotideSequence(string="ATGC",processes=list(list(JC69())))
  1433. # );
  1434. # # create a node hook function
  1435. # hook<-function(seq=NA){
  1436. # # replace the substitution process with F84
  1437. # if(inherits(seq,"NucleotideSequence")){
  1438. # cat("Replacing JC69 with F84.\n");
  1439. # seq$processes<-list(list(F84(rate.params=list("Kappa" = 2))));
  1440. # }
  1441. # return(seq);
  1442. # }
  1443. # # attach hook function to node 5
  1444. # attachHookToNode(sim,5,hook);
  1445. # # Run the simulation
  1446. # Simulate(sim);
  1447. # # Check if the processes have been truly replaced
  1448. # lapply(sim$sequences, getUniqueProcesses.Sequence)
  1449. # # Print the resulting alignment
  1450. # sim$alignment
  1451. # }
  1452. #
  1453. # @author
  1454. #
  1455. # \seealso{
  1456. # @seeclass
  1457. # }
  1458. #
  1459. #*/###########################################################################
  1460. setMethodS3(
  1461. "attachHookToNode",
  1462. class="PhyloSim",
  1463. function(
  1464. this,
  1465. node=NA,
  1466. fun=NA,
  1467. ...
  1468. ){
  1469. if(!is.phylo(this$.phylo)){
  1470. throw("The phylo object is not set, attaching node hook is not possible!\n");
  1471. }
  1472. if(missing(node)){
  1473. throw("No node specified!\n");
  1474. }
  1475. else if(missing(fun)){
  1476. throw("No function given!");
  1477. }
  1478. else if(!is.function(fun)){
  1479. throw("The argument \"fun\" must be a function!\n");
  1480. }
  1481. else if( length(intersect(names(formals(fun)), "seq")) == 0 ){
  1482. throw("The function argument must have a an argument named \"seq\"");
  1483. }
  1484. else if(!is.Sequence(fun(Sequence(length=1)))){
  1485. throw("The insert hook function must return a Sequence object!\n");
  1486. }
  1487. else if( .checkNode(this,node) ){
  1488. if(is.function(this$.node.hooks[[as.character(node)]])){
  1489. throw("The node has already an attached node hook. Detach that before trying to attach a new one!\n");
  1490. }
  1491. else {
  1492. this$.node.hooks[[as.character(node)]]<-fun;
  1493. return(invisible(this));
  1494. }
  1495. }
  1496. return(invisible(this));
  1497. },
  1498. private=FALSE,
  1499. protected=FALSE,
  1500. overwrite=FALSE,
  1501. conflict="warning",
  1502. validators=getOption("R.methodsS3:validators:setMethodS3")
  1503. );
  1504. ##
  1505. ## Method: .checkNode
  1506. ##
  1507. setMethodS3(
  1508. ".checkNode",
  1509. class="PhyloSim",
  1510. function(
  1511. this,
  1512. node=NA,
  1513. ...
  1514. ){
  1515. if(missing(node)){
  1516. throw("No node specified!\n");
  1517. } else if( length(intersect(node, getNodes(this))) != 1){
  1518. throw("The specified node is invalid!\n");
  1519. }
  1520. else {
  1521. return(TRUE);
  1522. }
  1523. },
  1524. private=FALSE,
  1525. protected=FALSE,
  1526. overwrite=FALSE,
  1527. conflict="warning",
  1528. validators=getOption("R.methodsS3:validators:setMethodS3")
  1529. );
  1530. ##
  1531. ## Method: .checkSeq
  1532. ##
  1533. setMethodS3(
  1534. ".checkSeq",
  1535. class="PhyloSim",
  1536. function(
  1537. this,
  1538. seq=NA,
  1539. ...
  1540. ){
  1541. if(missing(seq)){
  1542. throw("No sequence specified!\n");
  1543. } else if(!is.Sequence(seq)){
  1544. throw("The sequence object is invalid!\n");
  1545. }
  1546. else {
  1547. return(TRUE);
  1548. }
  1549. },
  1550. private=FALSE,
  1551. protected=FALSE,
  1552. overwrite=FALSE,
  1553. conflict="warning",
  1554. validators=getOption("R.methodsS3:validators:setMethodS3")
  1555. );
  1556. ##
  1557. ## Method: detachSeqFromNode
  1558. ##
  1559. ###########################################################################/**
  1560. #
  1561. # @RdocMethod detachSeqFromNode
  1562. #
  1563. # @title "Detach a Sequence object from a given node of a phylo object aggregated by a PhyloSim object"
  1564. #
  1565. # \description{
  1566. # @get "title".
  1567. #
  1568. # This method is mainly used internally.
  1569. #
  1570. # }
  1571. #
  1572. # @synopsis
  1573. #
  1574. # \arguments{
  1575. # \item{this}{A PhyloSim object.}
  1576. # \item{node}{Node identifier.}
  1577. # \item{...}{Not used.}
  1578. # }
  1579. #
  1580. # \value{
  1581. # The PhyloSim object (invisible).
  1582. # }
  1583. #
  1584. # @author
  1585. #
  1586. # \seealso{
  1587. # @seeclass
  1588. # }
  1589. #
  1590. #*/###########################################################################
  1591. setMethodS3(
  1592. "detachSeqFromNode",
  1593. class="PhyloSim",
  1594. function(
  1595. this,
  1596. node=NA,
  1597. ...
  1598. ){
  1599. if(missing(node)){
  1600. throw("No node specified!\n");
  1601. }
  1602. else if( .checkNode(this,node) ){
  1603. this$.sequences[[as.numeric(node)]]<-NA;
  1604. }
  1605. return(invisible(this));
  1606. },
  1607. private=FALSE,
  1608. protected=FALSE,
  1609. overwrite=FALSE,
  1610. conflict="warning",
  1611. validators=getOption("R.methodsS3:validators:setMethodS3")
  1612. );
  1613. ##
  1614. ## Method: detachHookFromNode
  1615. ##
  1616. ###########################################################################/**
  1617. #
  1618. # @RdocMethod detachHookFromNode
  1619. #
  1620. # @title "Detach a node hook function from a given node of a phylo object aggregated by a PhyloSim object"
  1621. #
  1622. # \description{
  1623. # @get "title".
  1624. #
  1625. # }
  1626. #
  1627. # @synopsis
  1628. #
  1629. # \arguments{
  1630. # \item{this}{A PhyloSim object.}
  1631. # \item{node}{Node identifier.}
  1632. # \item{...}{Not used.}
  1633. # }
  1634. #
  1635. # \value{
  1636. # The PhyloSim object (invisible).
  1637. # }
  1638. #
  1639. # \examples{
  1640. # # Create a PhyloSim object.
  1641. # # Provide the phylo object
  1642. # # and the root sequence.
  1643. # sim<-PhyloSim(
  1644. # name="TinySim",
  1645. # phylo=rcoal(3),
  1646. # root.seq=NucleotideSequence(string="ATGC",processes=list(list(JC69())))
  1647. # );
  1648. # # create a node hook function
  1649. # hook<-function(seq=NA){
  1650. # # replace the substitution process with F84
  1651. # if(inherits(seq,"NucleotideSequence")){
  1652. # cat("Replacing JC69 with F84.\n");
  1653. # seq$processes<-list(list(F84(rate.params=list("Kappa" = 2))));
  1654. # }
  1655. # return(seq);
  1656. # }
  1657. # # attach hook function to node 5
  1658. # attachHookToNode(sim,5,hook);
  1659. # # detach hook from node 5
  1660. # detachHookFromNode(sim,5);
  1661. # # Run the simulation again
  1662. # Simulate(sim); # You should not see the message printed out by the "hook" function.
  1663. #
  1664. # }
  1665. #
  1666. # @author
  1667. #
  1668. # \seealso{
  1669. # attachHookToNode PhyloSim Simulate.PhyloSim
  1670. # }
  1671. #
  1672. #*/###########################################################################
  1673. setMethodS3(
  1674. "detachHookFromNode",
  1675. class="PhyloSim",
  1676. function(
  1677. this,
  1678. node=NA,
  1679. ...
  1680. ){
  1681. if(missing(node)){
  1682. throw("No node specified!\n");
  1683. }
  1684. else if( .checkNode(this,node) ){
  1685. this$.node.hooks[[as.character(node)]]<-NA;
  1686. }
  1687. return(invisible(this));
  1688. },
  1689. private=FALSE,
  1690. protected=FALSE,
  1691. overwrite=FALSE,
  1692. conflict="warning",
  1693. validators=getOption("R.methodsS3:validators:setMethodS3")
  1694. );
  1695. ##
  1696. ## Method: getSeqFromNode
  1697. ##
  1698. ###########################################################################/**
  1699. #
  1700. # @RdocMethod getSeqFromNode
  1701. #
  1702. # @title "Get the Sequence object associated with a given node of a phylo object aggregated by a PhyloSim object"
  1703. #
  1704. # \description{
  1705. # @get "title".
  1706. # }
  1707. #
  1708. # @synopsis
  1709. #
  1710. # \arguments{
  1711. # \item{this}{A PhyloSim object.}
  1712. # \item{node}{Node identifier.}
  1713. # \item{...}{Not used.}
  1714. # }
  1715. #
  1716. # \value{
  1717. # A Sequence object.
  1718. # }
  1719. #
  1720. # \examples{
  1721. # # Create a PhyloSim object.
  1722. # # Provide the phylo object
  1723. # # and the root sequence.
  1724. # sim<-PhyloSim(
  1725. # name="TinySim",
  1726. # phylo=rcoal(3),
  1727. # root.seq=NucleotideSequence(string="ATG",processes=list(list(JC69())))
  1728. # );
  1729. # # get the sequence associated with node 5
  1730. # getSeqFromNode(sim,5) # Should be NA
  1731. # # Run the simulation
  1732. # Simulate(sim)
  1733. # # try again
  1734. # getSeqFromNode(sim,5)
  1735. # }
  1736. #
  1737. # @author
  1738. #
  1739. # \seealso{
  1740. # @seeclass
  1741. # }
  1742. #
  1743. #*/###########################################################################
  1744. setMethodS3(
  1745. "getSeqFromNode",
  1746. class="PhyloSim",
  1747. function(
  1748. this,
  1749. node=NA,
  1750. ...
  1751. ){
  1752. if(missing(node)){
  1753. throw("No node specified!\n");
  1754. }
  1755. else if( .checkNode(this,node) ){
  1756. return(this$.sequences[[as.numeric(node)]]);
  1757. }
  1758. },
  1759. private=FALSE,
  1760. protected=FALSE,
  1761. overwrite=FALSE,
  1762. conflict="warning",
  1763. validators=getOption("R.methodsS3:validators:setMethodS3")
  1764. );
  1765. ##
  1766. ## Method: getSequences
  1767. ##
  1768. ###########################################################################/**
  1769. #
  1770. # @RdocMethod getSequences
  1771. #
  1772. # @title "Gets all the Sequence objects associated with the nodes of a phylo object aggregated by a PhyloSim object"
  1773. #
  1774. # \description{
  1775. # @get "title".
  1776. #
  1777. # The order of the Sequence objects in the returned list reflects the identifiers of the associated nodes.
  1778. # }
  1779. #
  1780. # @synopsis
  1781. #
  1782. # \arguments{
  1783. # \item{this}{A PhyloSim object.}
  1784. # \item{...}{Not used.}
  1785. # }
  1786. #
  1787. # \value{
  1788. # A list of sequence objects.
  1789. # }
  1790. #
  1791. # \examples{
  1792. # # Create a PhyloSim object.
  1793. # # Provide the phylo object
  1794. # # and the root sequence.
  1795. # sim<-PhyloSim(
  1796. # name="TinySim",
  1797. # phylo=rcoal(3),
  1798. # root.seq=NucleotideSequence(string="ATG",processes=list(list(JC69())))
  1799. # );
  1800. # # run the simulation
  1801. # Simulate(sim)
  1802. # # get all the associated sequence objects
  1803. # getSequences(sim)
  1804. # # get the sequence associated with node 3
  1805. # # via virtual field
  1806. # sim$sequences[[3]]
  1807. # }
  1808. #
  1809. # @author
  1810. #
  1811. # \seealso{
  1812. # @seeclass
  1813. # }
  1814. #
  1815. #*/###########################################################################
  1816. setMethodS3(
  1817. "getSequences",
  1818. class="PhyloSim",
  1819. function(
  1820. this,
  1821. ...
  1822. ){
  1823. slist<-list();
  1824. for (node in getNodes(this)){
  1825. slist[[node]]<-getSeqFromNode(this, node=node);
  1826. }
  1827. return(slist);
  1828. },
  1829. private=FALSE,
  1830. protected=FALSE,
  1831. overwrite=FALSE,
  1832. conflict="warning",
  1833. validators=getOption("R.methodsS3:validators:setMethodS3")
  1834. );
  1835. ##
  1836. ## Method: setSequences
  1837. ##
  1838. ###########################################################################/**
  1839. #
  1840. # @RdocMethod setSequences
  1841. #
  1842. # @title "Forbidden action: setting the Sequence objects associated with the nodes of a phylo object aggregated by a PhyloSim object"
  1843. #
  1844. # \description{
  1845. # @get "title".
  1846. # }
  1847. #
  1848. # @synopsis
  1849. #
  1850. # \arguments{
  1851. # \item{this}{An object.}
  1852. # \item{value}{Not used.}
  1853. # \item{...}{Not used.}
  1854. # }
  1855. #
  1856. # \value{
  1857. # Throws an error.
  1858. # }
  1859. #
  1860. # @author
  1861. #
  1862. # \seealso{
  1863. # @seeclass
  1864. # }
  1865. #
  1866. #*/###########################################################################
  1867. setMethodS3(
  1868. "setSequences",
  1869. class="PhyloSim",
  1870. function(
  1871. this,
  1872. value,
  1873. ...
  1874. ){
  1875. virtualAssignmentForbidden(this);
  1876. },
  1877. private=FALSE,
  1878. protected=FALSE,
  1879. overwrite=FALSE,
  1880. conflict="warning",
  1881. validators=getOption("R.methodsS3:validators:setMethodS3")
  1882. );
  1883. ##
  1884. ## Method: getAlignment
  1885. ##
  1886. ###########################################################################/**
  1887. #
  1888. # @RdocMethod getAlignment
  1889. #
  1890. # @title "Get the alignment stored in a PhyloSim object"
  1891. #
  1892. # \description{
  1893. # @get "title".
  1894. # }
  1895. #
  1896. # @synopsis
  1897. #
  1898. # \arguments{
  1899. # \item{this}{A PhyloSim object.}
  1900. # \item{...}{Not used.}
  1901. # }
  1902. #
  1903. # \value{
  1904. # The alignment as a matrix. Gap are represented by strings composed of dashes.
  1905. # }
  1906. #
  1907. # \examples{
  1908. # # Create a PhyloSim object.
  1909. # # Provide the phylo object
  1910. # # and the root sequence.
  1911. # sim<-PhyloSim(
  1912. # name="TinySim",
  1913. # phylo=rcoal(3),
  1914. # root.seq=NucleotideSequence(string="ATG",processes=list(list(JC69())))
  1915. # );
  1916. # # run the simulation
  1917. # Simulate(sim)
  1918. # # get the resulting aligment
  1919. # getAlignment(sim)
  1920. # # via virtual fileld:
  1921. # sim$alignment
  1922. # }
  1923. #
  1924. # @author
  1925. #
  1926. # \seealso{
  1927. # @seeclass
  1928. # }
  1929. #
  1930. #*/###########################################################################
  1931. setMethodS3(
  1932. "getAlignment",
  1933. class="PhyloSim",
  1934. function(
  1935. this,
  1936. ...
  1937. ){
  1938. this$.alignment;
  1939. },
  1940. private=FALSE,
  1941. protected=FALSE,
  1942. overwrite=FALSE,
  1943. conflict="warning",
  1944. validators=getOption("R.methodsS3:validators:setMethodS3")
  1945. );
  1946. ##
  1947. ## Method: setAlignment
  1948. ##
  1949. ###########################################################################/**
  1950. #
  1951. # @RdocMethod setAlignment
  1952. #
  1953. # @title "Forbidden action: setting the alignment stored in a PhyloSim object"
  1954. #
  1955. # \description{
  1956. # @get "title".
  1957. # }
  1958. #
  1959. # @synopsis
  1960. #
  1961. # \arguments{
  1962. # \item{this}{An object.}
  1963. # \item{value}{Not used.}
  1964. # \item{...}{Not used.}
  1965. # }
  1966. #
  1967. # \value{
  1968. # Throws an error.
  1969. # }
  1970. #
  1971. # @author
  1972. #
  1973. # \seealso{
  1974. # @seeclass
  1975. # }
  1976. #
  1977. #*/###########################################################################
  1978. setMethodS3(
  1979. "setAlignment",
  1980. class="PhyloSim",
  1981. function(
  1982. this,
  1983. value,
  1984. ...
  1985. ){
  1986. this$alignment <- value;
  1987. },
  1988. private=FALSE,
  1989. protected=FALSE,
  1990. overwrite=FALSE,
  1991. conflict="warning",
  1992. validators=getOption("R.methodsS3:validators:setMethodS3")
  1993. );
  1994. ##
  1995. ## Method: .recoverAlignment
  1996. ##
  1997. setMethodS3(
  1998. ".recoverAlignment",
  1999. class="PhyloSim",
  2000. function(
  2001. this,
  2002. paranoid=FALSE,
  2003. ...
  2004. ){
  2005. # Refuse to build alignment if at least one of the sequences is NA:
  2006. for (seq in this$.sequences){
  2007. if(!is.Sequence(seq)){
  2008. throw("Cannot build alignment because the simulation is incomplete!\n");
  2009. }
  2010. }
  2011. # The list holding all the partial alignment matrices:
  2012. aln.mat<-list();
  2013. # Assigning NA-s here to prevent creation of these variables in the global
  2014. # environment.
  2015. row.names<-NA;
  2016. from.node<-NA;
  2017. to.node<-NA;
  2018. from.seq<-NA;
  2019. to.seq<-NA;
  2020. edge<-NA;
  2021. from.name<-NA;
  2022. to.name<-NA;
  2023. from.mat<-NA;
  2024. to.mat<-NA;
  2025. # Initialize the variables:
  2026. init.vars<-function(){
  2027. # Getting the edge:
  2028. edge<<-getEdge(this, edge.number);
  2029. # Getting the nodes:
  2030. from.node<<-edge[[1,"from"]];
  2031. to.node<<-edge[[1,"to"]];
  2032. # Getting the sequence objects:
  2033. from.seq<<-getSeqFromNode(this, from.node)
  2034. to.seq<<-getSeqFromNode(this, to.node)
  2035. # Getting sequence names:
  2036. from.name<<-from.seq$name;
  2037. to.name<<-to.seq$name;
  2038. }
  2039. # Initialize the aligment matrices:
  2040. init.aln.mats<-function(){
  2041. # Initialize "from" element in aln.mat if necessary:
  2042. if( is.null(aln.mat[[from.name]] )){
  2043. # Create a row of the states:
  2044. tmp<-rbind(as.character(lapply(from.seq$.sites, getState)));
  2045. # Label the columns by the site position:
  2046. colnames(tmp)<-seq(along.with=from.seq$.sites);
  2047. # Label the row with the sequence name:
  2048. rownames(tmp)<-from.name;
  2049. # Set the corresponding list element in aln.mat:
  2050. aln.mat[[ from.name ]]<-tmp;
  2051. }
  2052. # Set from.mat
  2053. from.mat<<-aln.mat[[ from.name ]];
  2054. # Initialize "to" element int aln.mat if necessary
  2055. if( is.null(aln.mat[[to.name]]) ){
  2056. # Create a new entry if we are dealing with a tip:
  2057. if(is.tip(this, to.node)){
  2058. # Create a vector of states:
  2059. tmp<-rbind(as.character(lapply(to.seq$.sites, getState)));
  2060. # Label columns by position:
  2061. colnames(tmp)<-seq(along.with=to.seq$.sites);
  2062. # Label row by sequence name:
  2063. rownames(tmp)<-to.name;
  2064. aln.mat[[ to.name ]]<-tmp;
  2065. }
  2066. else {
  2067. # A "to" element can be null only if its a tip:
  2068. throw("aln.mat inconsistency!\n");
  2069. }
  2070. }
  2071. # Set to.mat:
  2072. to.mat<<-aln.mat[[ to.name ]];
  2073. # Save row names:
  2074. # The order is important! First "from", than "to"!
  2075. row.names<<-c(rownames(from.mat), rownames(to.mat));
  2076. }
  2077. # Get the sequence position of a given alignment column from
  2078. # the column labels:
  2079. get.seq.pos<-function(mat=NA, col=NA){
  2080. # Column number cannot be larger than length:
  2081. if(col > dim(mat)[[2]]){
  2082. throw("Invalid column number!\n");
  2083. }
  2084. # Get the corresponding column name:
  2085. tmp<-colnames(mat)[[col]];
  2086. # Return if NA:
  2087. if(is.na(tmp)){
  2088. return(NA);
  2089. }
  2090. else{
  2091. return(as.numeric(tmp));
  2092. }
  2093. }
  2094. # Check if two positions from the two *sequences* are homologous.
  2095. is.homologous<-function(from.pos=NA, to.pos=NA){
  2096. # Check position validity:
  2097. if(to.pos > to.seq$length){
  2098. throw("to.pos too big ",to.pos);
  2099. }
  2100. if(from.pos > from.seq$length){
  2101. throw("from.pos too big ",from.pos);
  2102. }
  2103. # Check if the ancestral from to.seq/to.pos is from.seq/from.pos:
  2104. return(equals(to.seq$.sites[[ to.pos ]]$.ancestral, from.seq$.sites[[ from.pos ]]));
  2105. }
  2106. # Get the symbol length from "to.seq" at position to.pos:
  2107. get.to.symlen<-function(pos=NA){
  2108. len<-stringLength(to.mat[to.name , pos]);
  2109. if( is.na(len) | (len < 1) ){
  2110. throw("Trouble in getting to.symlen!");
  2111. } else {
  2112. return(len);
  2113. }
  2114. }
  2115. # Get the symbol length from "from.seq" at position from.pos:
  2116. get.from.symlen<-function(pos=NA){
  2117. len<-stringLength(from.mat[from.name , pos]);
  2118. if( is.na(len) | (len < 1) ){
  2119. throw("Trouble in getting from.symlen!");
  2120. } else {
  2121. return(len);
  2122. }
  2123. }
  2124. make.gap.in.from<-function(label=NA,symlen=NA){
  2125. # Create the gap symbol:
  2126. gap<-paste(rep("-",times=symlen),collapse="");
  2127. # Create the vector with gaps:
  2128. gaps<-cbind(rep(gap, times=dim(from.mat)[[1]] ));
  2129. # Label the column:
  2130. colnames(gaps)<-c(label);
  2131. # Bind the gaps with the corresponding column from to.mat,
  2132. # and than bind with res.mat:
  2133. res.mat<<-cbind(res.mat, rbind( gaps, cbind(to.mat[,j]) ) );
  2134. # Restore rownames:
  2135. rownames(res.mat)<<-row.names;
  2136. # Increment counter for to.mat:
  2137. j<<-j+1;
  2138. }
  2139. make.gap.in.to<-function(label=NA,symlen=NA){
  2140. # See above.
  2141. gap<-paste(rep("-",times=symlen),collapse="");
  2142. gaps<-cbind(rep(gap, times=dim(to.mat)[[1]] ));
  2143. colnames(gaps)<-c(label);
  2144. res.mat<<-cbind(res.mat, rbind( cbind(from.mat[,i]), gaps ) );
  2145. rownames(res.mat)<<-row.names;
  2146. i<<-i+1;
  2147. }
  2148. emmit.homologous<-function(){
  2149. # Bind the two columns into one column:
  2150. tmp<-cbind(rbind( cbind(from.mat[,i]), cbind(to.mat[,j]) ) );
  2151. # Label the column by from.pos:
  2152. colnames(tmp)<-c(from.pos);
  2153. # Set res.mat
  2154. res.mat<<-cbind(res.mat, tmp );
  2155. # resotre rownames:
  2156. rownames(res.mat)<<-row.names;
  2157. i<<-i+1;
  2158. j<<-j+1;
  2159. }
  2160. # Iterate over the reverse of the edge matrix:
  2161. for (edge.number in rev(seq(from=1, to=this$nedges))){
  2162. # Call variable initialization:
  2163. init.vars();
  2164. # Initialize partial alignment matrices:
  2165. init.aln.mats();
  2166. # The matrix holding the resulting partial alignment:
  2167. res.mat<-c();
  2168. # Column counter for from.mat:
  2169. i<-1;
  2170. # Column counter for to.mat:
  2171. j<-1;
  2172. while(i <=dim(from.mat)[[2]] | j <=dim(to.mat)[[2]] ){
  2173. # First of all, check for counter overflow:
  2174. if(i > dim(from.mat)[[2]]){
  2175. # If i is greater than the length of from.mat, but we
  2176. # are still iterating, that means that we have parts left from
  2177. # to.mat, so we have to create gaps in from.mat, and increment j.
  2178. make.gap.in.from(symlen=get.to.symlen(pos=j));
  2179. next();
  2180. }
  2181. else if (j > dim(to.mat)[[2]]){
  2182. # If j is greater than the length of to.mat and we still iterating,
  2183. # that means that we have still some columns in from.mat, so we create
  2184. # gaps in to.mat and increment i. We label the new column with from.pos.
  2185. from.pos<-get.seq.pos(mat=from.mat, col=i);
  2186. make.gap.in.to(label=from.pos,get.from.symlen(pos=i));
  2187. next();
  2188. }
  2189. # Now figure out the positions:
  2190. from.pos<-get.seq.pos(mat=from.mat, col=i);
  2191. to.pos<-get.seq.pos(mat=to.mat, col=j);
  2192. # Now check for the gaps wich have been introduced before:
  2193. if(is.na(from.pos)){
  2194. # If we have a gap in from.mat,
  2195. # than emmit the columnt with a gap in "to":
  2196. make.gap.in.to(symlen=get.from.symlen(pos=i));
  2197. next();
  2198. }
  2199. if(is.na(to.pos)){
  2200. # Existent gap in to.mat:
  2201. make.gap.in.from(symlen=get.to.symlen(pos=j));
  2202. next();
  2203. }
  2204. # Now we have some real alignment to do here:
  2205. if(is.homologous(from.pos=from.pos, to.pos=to.pos)){
  2206. # We have to homologous columns, bind them, and emmit:
  2207. emmit.homologous();
  2208. next();
  2209. }
  2210. else if(is.Process(to.seq$.sites[[to.pos]]$.ancestral)){
  2211. # The two columns are not homologous. The column in "to"
  2212. # was inserted by a process. Make gap in from:
  2213. make.gap.in.from(symlen=get.from.symlen(pos=i));
  2214. next();
  2215. }
  2216. else {
  2217. # The only possibility left is a deletion in the child sequence.
  2218. # Make gaps in "to", label new column by from.pos:
  2219. make.gap.in.to(label=from.pos,symlen=get.from.symlen(pos=i));
  2220. next();
  2221. }
  2222. } # while i | j
  2223. # Replace the "from" element in aln.mat with the resulting partial
  2224. # alignment matrix:
  2225. aln.mat [[ from.name ]]<-res.mat;
  2226. } # for edge.number
  2227. alignment <-aln.mat[[ this$rootSeq$name ]];
  2228. # Check the correcteness of the alignment if paranoid:
  2229. if(paranoid){
  2230. .checkAlignmentConsistency(this, alignment);
  2231. }
  2232. # Call garbage collection:
  2233. gc();
  2234. gc();
  2235. # The whole alignment is associated with the root node:
  2236. return(alignment);
  2237. },
  2238. private=FALSE,
  2239. protected=FALSE,
  2240. overwrite=FALSE,
  2241. conflict="warning",
  2242. validators=getOption("R.methodsS3:validators:setMethodS3")
  2243. );
  2244. ##
  2245. ## Method: .checkAlignmentConsistency
  2246. ##
  2247. setMethodS3(
  2248. ".checkAlignmentConsistency",
  2249. class="PhyloSim",
  2250. function(
  2251. this,
  2252. aln,
  2253. ...
  2254. ){
  2255. # First check if the sequences are intact:
  2256. for(node in this$nodes){
  2257. seq.node<-getSeqFromNode(this, node);
  2258. seq.aln<-aln[seq.node$name, ];
  2259. seq.aln<-seq.aln[ grep("^[^-]+$",seq.aln) ];
  2260. seq.aln<-paste(seq.aln, collapse="");
  2261. if(seq.aln != seq.node$string){
  2262. throw("The alignment is inconsistent with the sequence objects!\n Blaming ",seq.node$name, ".\n");
  2263. }
  2264. }
  2265. for(edge.number in rev(seq(from=1, to=this$nedges))){
  2266. # Getting the edge:
  2267. edge<-getEdge(this, edge.number);
  2268. # Getting the nodes:
  2269. from.node<-edge[[1,"from"]];
  2270. to.node<-edge[[1,"to"]];
  2271. # Getting the sequence objects:
  2272. from.seq<-getSeqFromNode(this, from.node)
  2273. to.seq<-getSeqFromNode(this, to.node)
  2274. # Getting sequence names:
  2275. from.name<-from.seq$name;
  2276. to.name<-to.seq$name;
  2277. # Initializing positions:
  2278. from.pos<-1;
  2279. to.pos<-1;
  2280. is.gap<-function(string){
  2281. res<-length(grep("^-+$",string));
  2282. if( res == 1 ){
  2283. return(TRUE);
  2284. }
  2285. else if (res > 1){
  2286. throw("is.gap: argument vector too long!\n");
  2287. }
  2288. else {
  2289. return(FALSE);
  2290. }
  2291. }
  2292. # Iterate over edges:
  2293. for (i in 1:dim(aln)[[2]]){
  2294. # Overflow in "from" counter,
  2295. if(from.pos > from.seq$length){
  2296. to.char<-aln[to.name,i];
  2297. if(!is.gap(to.char)){
  2298. # we have a final insertion:
  2299. if(!is.Process(to.seq$.sites[[to.pos]]$.ancestral)){
  2300. throw("Alignment insertion inconsistency!\n");
  2301. }
  2302. to.pos<-to.pos+1;
  2303. }
  2304. next();
  2305. }
  2306. # Overflow in "to" counter (final deletion):
  2307. if(to.pos > to.seq$length){
  2308. break();
  2309. }
  2310. # Get the symbols from alignment:
  2311. from.char<-aln[from.name,i];
  2312. to.char<-aln[to.name,i];
  2313. is.gap.to<-is.gap(to.char);
  2314. is.gap.from<-is.gap(from.char);
  2315. # Skip if we have to gap symbols:
  2316. if( is.gap.from & is.gap.to ){
  2317. next();
  2318. }
  2319. # Deletion in to.seq:
  2320. else if(is.gap.to & !is.gap.from ){
  2321. from.pos<-(from.pos+1);
  2322. }
  2323. # Insertion in to.seq:
  2324. else if(!is.gap.to & is.gap.from ){
  2325. # Check ancestral pointer for inserted sites:
  2326. if(!is.Process(to.seq$.sites[[to.pos]]$.ancestral)){
  2327. throw("Alignment insertion inconsistency!\n");
  2328. }
  2329. to.pos<-(to.pos+1);
  2330. } else {
  2331. # We must have a homology here:
  2332. if(!equals(to.seq$.sites[[ to.pos ]]$.ancestral, from.seq$.sites[[ from.pos ]])){
  2333. throw("Non-homologous sites aligned! Alignment is inconsistent!\n");
  2334. }
  2335. from.pos<-(from.pos+1);
  2336. to.pos<-(to.pos+1);
  2337. }
  2338. }
  2339. }
  2340. },
  2341. private=FALSE,
  2342. protected=FALSE,
  2343. overwrite=FALSE,
  2344. conflict="warning",
  2345. validators=getOption("R.methodsS3:validators:setMethodS3")
  2346. );
  2347. ##
  2348. ## Method: saveAlignment
  2349. ##
  2350. ###########################################################################/**
  2351. #
  2352. # @RdocMethod saveAlignment
  2353. #
  2354. # @title "Save the alignment stored in a PhyloSim object in a Fasta file"
  2355. #
  2356. # \description{
  2357. # @get "title".
  2358. # }
  2359. #
  2360. # @synopsis
  2361. #
  2362. # \arguments{
  2363. # \item{this}{A PhyloSim object.}
  2364. # \item{file}{The name of the output file.}
  2365. # \item{skip.internal}{Do not save sequences corresponding to internal nodes.}
  2366. # \item{paranoid}{Check the consistency of the alignment.}
  2367. # \item{...}{Not used.}
  2368. # }
  2369. #
  2370. # \value{
  2371. # The PhyloSim object (invisible).
  2372. # }
  2373. #
  2374. # \examples{
  2375. # # Create a PhyloSim object.
  2376. # # Provide the phylo object
  2377. # # and the root sequence.
  2378. # sim<-PhyloSim(
  2379. # name="TinySim",
  2380. # phylo=rcoal(3),
  2381. # root.seq=NucleotideSequence(string="ATG",processes=list(list(JC69())))
  2382. # );
  2383. # # run the simulation
  2384. # Simulate(sim)
  2385. # # save the alignment
  2386. # file<-paste("PhyloSim_dummy_fasta_",Sys.getpid(),".fas",sep="");
  2387. # saveAlignment(sim,file=file,paranoid=TRUE);
  2388. # # print out the Fasta file
  2389. # cat(paste(scan(file=file,what=character(),sep="\n"),collapse="\n"));cat("\n");
  2390. # # delete Fasta file
  2391. # unlink(file);
  2392. # }
  2393. #
  2394. # @author
  2395. #
  2396. # \seealso{
  2397. # @seeclass
  2398. # }
  2399. #
  2400. #*/###########################################################################
  2401. setMethodS3(
  2402. "saveAlignment",
  2403. class="PhyloSim",
  2404. function(
  2405. this,
  2406. file="phylosim.fas",
  2407. skip.internal=FALSE,
  2408. paranoid=FALSE,
  2409. ...
  2410. ){
  2411. if(any(is.na(this$.alignment))){
  2412. warning("Alignment is undefined, nothin to save!\n");
  2413. return();
  2414. }
  2415. else {
  2416. if(paranoid){
  2417. .checkAlignmentConsistency(this, this$.alignment);
  2418. }
  2419. sink(file);
  2420. if(!skip.internal){
  2421. for(i in 1:dim(this$.alignment)[[1]]){
  2422. cat(">",rownames(this$.alignment)[[i]],"\n");
  2423. cat(paste(this$.alignment[i,],collapse=""),"\n");
  2424. }
  2425. } else {
  2426. for(i in 1:dim(this$.alignment)[[1]]){
  2427. name<-rownames(this$.alignment)[[i]];
  2428. if(!any((length(grep("^Node \\d+$",name,perl=TRUE,value=FALSE)) > 0),(length(grep("^Root node \\d+$",name,perl=TRUE,value=FALSE)) > 0))){
  2429. cat(">",name,"\n");
  2430. cat(paste(this$.alignment[i,],collapse=""),"\n");
  2431. }
  2432. }
  2433. }
  2434. sink(NULL);
  2435. }
  2436. return(invisible(this));
  2437. },
  2438. private=FALSE,
  2439. protected=FALSE,
  2440. overwrite=FALSE,
  2441. conflict="warning",
  2442. validators=getOption("R.methodsS3:validators:setMethodS3")
  2443. );
  2444. ##
  2445. ## Method: plot.PhyloSim
  2446. ##
  2447. ###########################################################################/**
  2448. #
  2449. # @RdocMethod plot
  2450. #
  2451. # @title "Plot a PhyloSim object"
  2452. #
  2453. # \description{
  2454. # @get "title".
  2455. #
  2456. # This method plots the aggregated alignment alongside the tree used for simulation. Various options
  2457. # allow for control over the plot style.
  2458. #
  2459. # }
  2460. #
  2461. # @synopsis
  2462. #
  2463. # \arguments{
  2464. # \item{x}{A PhyloSim object.}
  2465. # \item{plot.tree}{Whether to plot the tree alongside the alignment. TRUE or FALSE; defaults to TRUE.}
  2466. # \item{plot.ancestors}{Whether to plot the ancestral sequences. TRUE or FALSE; defaults to TRUE.}
  2467. # \item{plot.chars}{Whether to plot the actual text of the characters.}
  2468. # \item{plot.legend}{Whether to plot the legend showing the character-to-color mapping.}
  2469. # \item{plot.labels}{Whether to plot the sequence labels along the y-axis}
  2470. # \item{aspect.ratio}{(Experimental; when set, this option forces the num.pages value to 1) Constrains the alignment residues to have a certain aspect ratio; values above 1 cause vertically-stretched blocks. FALSE disables aspect ratio control, numerical values set the aspect ratio; defaults to FALSE.}
  2471. # \item{num.pages}{Optionally split the alignment over a number of vertically-stacked pages. This is useful for long alignments. 'auto' chooses a sensible number of pages, numerical values specify a number; defaults to 'auto'.}
  2472. # \item{char.text.size}{Text size for the aligned characters. This may require tweaking depending on the DPI and output format. Defaults to 'auto'.}
  2473. # \item{axis.text.size}{Text size for the sequence labels along the y-axis. This may require tweaking depending on the DPI and output format. Defaults to 'auto'.}
  2474. # \item{color.scheme}{Color scheme to use ("auto", "binary", "dna", "protein", "codon", "combined", "combined_codon"). Defaults to 'auto'. When set to 'auto', the function will choose an appropriate coloring scheme based on the alignment content.}
  2475. # \item{color.branches}{The event count used to color the branches ("substitutions" by default). See \code{\link{getBranchEvents.PhyloSim}}.}
  2476. # \item{tree.xlim}{The x-axis limits of the tree panel.}
  2477. # \item{aln.xlim}{The x-axis limits of the alignment panel (in alignment column coordinates).}
  2478. # \item{tracks}{Tracks to display above or below the alignment as colored blocks.
  2479. #
  2480. # The input format for tracks is a list of data frames with the following possible fields, all of which are optional and can be omitted:
  2481. # \itemize{
  2482. # \item pos - the sequence position (starting with 1) of the feature. Defaults to NULL.
  2483. # \item score - the score (between 0 and 1) of the feature. Scores above 1 or below zero will be truncated.
  2484. # Defaults to 1.
  2485. # \item y_lo - the lower Y offset (between 0 and 1) of the feature. Defaults to 0. Use a y_lo and y_hi
  2486. # value for each row in the track data frame to create a wiggle plot like effect.
  2487. # \item y_hi - the upper Y offset (between 0 and 1) of the feature. Defaults to 1. Use just a y_hi value
  2488. # for each row in the track data frame to create a bar plot like effect.
  2489. # \item [the fields below are considered unique per track; the values from the first row in the track
  2490. # data frame are used.]
  2491. # \item id - the display ID for the track. Defaults to 'Track'.
  2492. # \item layout - set to 'above' to put the track above the alignment, 'below' for below.
  2493. # \item height - the number of alignment rows for the track to span in height. Defaults to 3.
  2494. # \item color.gradient - a comma-separated list of colors to interpolate between when coloring
  2495. # the blocks. Examples: 'white,red' 'blue,gray,red' '#FF00FF,#FFFFFF'. Defaults to 'white,black'.
  2496. # \item color - a single color to use when coloring the blocks. Mutually exclusive with color.gradient,
  2497. # and if a color.gradient value exists then this value will be ignored. Defaults to black.
  2498. # \item background - a color for the background of the track. Defaults to white.
  2499. # }}
  2500. # \item{aln.length.tolerance}{The desired alignment/sequence length ratio (A/S ratio) to trim the alignment to.
  2501. # The A/S ratio is defined as the ratio between the alignment length and the mean ungapped sequence length, and
  2502. # the alignment trimming procedure will remove blocks of indel-containing columns (in a sensible order) until
  2503. # either (a) the desired indel tolerance is reached, or (b) no more columns can be removed without yielding an empty
  2504. # alignment. A track is added below the alignment to indicate how many indels each resulting alignment column used
  2505. # used to harbor, and black squares are overlaid onto the alignment where extant sequence data has been trimmed.
  2506. # Defaults to NULL (no trimming); values in the range of 0.9 to 1.3 tend to work well at improving the
  2507. # legibility of very gappy alignments.}
  2508. # \item{plot.nongap.bl}{If set to TRUE, plots the non-gap branch length (defined as the branch length of the subtree of non-gapped sequences) as a track below the alignment. Defaults to FALSE.}
  2509. # \item{...}{Not used.}
  2510. # }
  2511. #
  2512. # \value{
  2513. # The PhyloSim object (invisible).
  2514. # }
  2515. #
  2516. # \examples{
  2517. # # Create a PhyloSim object.
  2518. # # Provide the phylo object
  2519. # # and the root sequence.
  2520. # sim<-PhyloSim(
  2521. # name="TinySim",
  2522. # phylo=rcoal(3),
  2523. # root.seq=NucleotideSequence(string="ATGCTAGCTAGG",processes=list(list(JC69())))
  2524. # );
  2525. # # plot the aggregated phylo object
  2526. # plot(sim)
  2527. # # run simulation
  2528. # Simulate(sim)
  2529. # # Plot the alignment without the tree or ancestral sequences.
  2530. # plot(sim, plot.ancestors=FALSE, plot.tree=FALSE)
  2531. # # Force a DNA-based color scheme
  2532. # # (default is 'auto' to auto-detect based on the sequence composition)
  2533. # plot(sim, color.scheme='dna', plot.legend=TRUE)
  2534. # }
  2535. #
  2536. # @author
  2537. #
  2538. # \seealso{
  2539. # @seeclass
  2540. # }
  2541. #
  2542. #*/###########################################################################
  2543. setMethodS3(
  2544. "plot",
  2545. class="PhyloSim",
  2546. function(
  2547. x,
  2548. plot.tree,
  2549. plot.ancestors,
  2550. plot.chars,
  2551. plot.legend,
  2552. plot.labels,
  2553. aspect.ratio,
  2554. num.pages,
  2555. char.text.size,
  2556. axis.text.size,
  2557. color.scheme,
  2558. color.branches,
  2559. tree.xlim,
  2560. aln.xlim,
  2561. tracks,
  2562. aln.length.tolerance,
  2563. plot.nongap.bl,
  2564. ...
  2565. ){
  2566. if(missing(char.text.size)){
  2567. char.text.size <- 'auto'
  2568. }
  2569. if(missing(axis.text.size)){
  2570. axis.text.size <- 'auto'
  2571. }
  2572. if(missing(color.scheme)){
  2573. color.scheme <- 'auto'
  2574. }
  2575. if(missing(color.branches)){
  2576. color.branches <- 'substitutions'
  2577. }
  2578. if(missing(plot.tree)){
  2579. plot.tree <- TRUE
  2580. }
  2581. if(missing(plot.ancestors)){
  2582. plot.ancestors <- TRUE
  2583. }
  2584. if(missing(plot.chars)){
  2585. plot.chars <- TRUE
  2586. }
  2587. if(missing(plot.legend)){
  2588. plot.legend <- FALSE
  2589. }
  2590. if(missing(plot.labels)){
  2591. plot.labels <- TRUE
  2592. }
  2593. if(missing(aspect.ratio)){
  2594. aspect.ratio <- FALSE
  2595. }
  2596. if(missing(num.pages)){
  2597. num.pages='auto'
  2598. }
  2599. if(missing(color.scheme)){
  2600. color.scheme='auto'
  2601. }
  2602. if(missing(tree.xlim)){
  2603. tree.xlim=NULL
  2604. }
  2605. if(missing(aln.xlim)){
  2606. aln.xlim=NULL
  2607. }
  2608. if(missing(tracks)){
  2609. tracks=NULL
  2610. }
  2611. if(any(is.na(x$.phylo))) {
  2612. plot.tree <- FALSE
  2613. }
  2614. if(missing(aln.length.tolerance)){
  2615. aln.length.tolerance=NULL
  2616. }
  2617. if(missing(plot.nongap.bl)){
  2618. plot.nongap.bl=FALSE
  2619. }
  2620. if(all(!is.na(x$.alignment), is.matrix(x$.alignment))){
  2621. .plotWithAlignment(x,
  2622. plot.tree=plot.tree,
  2623. plot.ancestors=plot.ancestors,
  2624. plot.chars=plot.chars,
  2625. plot.legend=plot.legend,
  2626. plot.labels=plot.labels,
  2627. aspect.ratio=aspect.ratio,
  2628. num.pages=num.pages,
  2629. char.text.size=char.text.size,
  2630. axis.text.size=axis.text.size,
  2631. color.scheme=color.scheme,
  2632. color.branches=color.branches,
  2633. tree.xlim=tree.xlim,
  2634. aln.xlim=aln.xlim,
  2635. tracks=tracks,
  2636. aln.length.tolerance=aln.length.tolerance,
  2637. plot.nongap.bl=plot.nongap.bl
  2638. );
  2639. return(invisible(x));
  2640. }
  2641. plot(x$.phylo);
  2642. nodelabels();
  2643. return(invisible(x));
  2644. },
  2645. private=FALSE,
  2646. protected=FALSE,
  2647. overwrite=FALSE,
  2648. conflict="warning",
  2649. validators=getOption("R.methodsS3:validators:setMethodS3")
  2650. );
  2651. ##
  2652. ## Method: .plotWithAlignment
  2653. ##
  2654. setMethodS3(
  2655. ".plotWithAlignment",
  2656. class="PhyloSim",
  2657. function(
  2658. x,
  2659. plot.tree,
  2660. plot.ancestors,
  2661. plot.chars,
  2662. plot.legend,
  2663. plot.labels,
  2664. aspect.ratio,
  2665. num.pages,
  2666. char.text.size,
  2667. axis.text.size,
  2668. color.scheme,
  2669. color.branches,
  2670. tree.xlim,
  2671. aln.xlim,
  2672. tracks,
  2673. aln.length.tolerance,
  2674. plot.nongap.bl,
  2675. ...
  2676. ){
  2677. # ugly empirical fix of some R CMD check warnings:
  2678. id <-NA;
  2679. pos <-NA;
  2680. char <-NA;
  2681. xend <-NA;
  2682. yend <-NA;
  2683. y <-NA;
  2684. substitutions<-NA;
  2685. event.count <-NA;
  2686. type <-NA;
  2687. track_index <-NA;
  2688. xx <-NA;
  2689. yy <-NA;
  2690. xmin <-NA;
  2691. xmax <-NA;
  2692. ymin <-NA;
  2693. ymax <-NA;
  2694. ### First, we need to define a bunch of sparsely-documented utility functions. ###
  2695. # Re-orders the alignment rows by matching the tree's tips.
  2696. sort.aln.by.tree = function(aln,tree) {
  2697. names <- dimnames(aln)[[1]]
  2698. if (length(names) > length(tree$tip.label)) {
  2699. return(aln)
  2700. }
  2701. newPositions <- rev(match(tree$tip.label,names))
  2702. aln <- aln[newPositions,]
  2703. dimnames(aln) <- list(names[newPositions])
  2704. return(aln)
  2705. }
  2706. # Extracts a list of child node IDs for the given node. Returns (-1,-1) if the node is a leaf.
  2707. child.nodes <- function(phylo,node) {
  2708. edge.indices <- which(phylo$edge[,1]==node)
  2709. nodes <- phylo$edge[edge.indices,2]
  2710. if (length(nodes)==0) {
  2711. nodes <- list(c(-1,-1))
  2712. } else {
  2713. nodes <- list(nodes)
  2714. }
  2715. return(list(nodes))
  2716. }
  2717. # Extracts the parent node ID for the given node. Returns -1 if the node is root.
  2718. parent.node <- function(phylo,node) {
  2719. edge.index <- which(phylo$edge[,2]==node)
  2720. node <- phylo$edge[edge.index,1]
  2721. if (length(node)==0) {
  2722. node <- -1
  2723. }
  2724. return(node)
  2725. }
  2726. generic.count <- function(sim,node,type) {
  2727. if (type == 'insertions' || type == 'ins') {
  2728. type <- 'insertion'
  2729. }
  2730. if (type == 'deletions' || type == 'del') {
  2731. type <- 'deletion'
  2732. }
  2733. if (type == 'substitutions' || type == 'subst' || type == 'sub') {
  2734. type <- 'substitution'
  2735. }
  2736. if (type == 'syn') {
  2737. type <- 'synonymous'
  2738. }
  2739. if (type == 'nsyn') {
  2740. type <- 'non-synonymous'
  2741. }
  2742. # Default value of 0.
  2743. cnt <- 0
  2744. if(type=='none' || type == '') {
  2745. return(as.numeric(cnt))
  2746. }
  2747. # Find the edge which points to the given node.
  2748. edge.index <- which(phylo$edge[,2]==node)
  2749. if (length(edge.index) > 0) {
  2750. bs <- sim$.branch.stats
  2751. cnt <- bs[[paste(edge.index)]][[type]]
  2752. if (is.null(cnt) || is.na(cnt)) {
  2753. cnt <- 0
  2754. }
  2755. }
  2756. return(as.numeric(cnt))
  2757. }
  2758. subst.count <- function(sim,node) {
  2759. return(generic.count(sim,node,'substitution'))
  2760. }
  2761. ins.count <- function(sim,node) {
  2762. return(generic.count(sim,node,'insertion'))
  2763. }
  2764. del.count <- function(sim,node) {
  2765. return(generic.count(sim,node,'deletion'))
  2766. }
  2767. syn.count <- function(sim,node) {
  2768. return(generic.count(sim,node,'synonymous'))
  2769. }
  2770. nsyn.count <- function(sim,node) {
  2771. return(generic.count(sim,node,'non-synonymous'))
  2772. }
  2773. # Finds the node with a given label.
  2774. node.with.label <- function(tree,label) {
  2775. return(which(tree$tip.label %in% label))
  2776. }
  2777. # Extracts the length of the branch above the given node. Returns 0 if the node is root.
  2778. branch.length <- function(phylo,node) {
  2779. edge.index <- which(phylo$edge[,2]==node)
  2780. bl <- phylo$edge.length[edge.index]
  2781. if (length(bl)==0) {
  2782. bl <- 0
  2783. }
  2784. return(bl)
  2785. }
  2786. # The maximum root-to-tip length in the tree.
  2787. max.length.to.root <- function(phylo) {
  2788. max.length <- 0
  2789. for (i in 1:length(phylo$tip.label)) {
  2790. cur.length <- length.to.root(phylo,i)
  2791. max.length <- max(max.length,cur.length)
  2792. }
  2793. return(max.length)
  2794. }
  2795. # The length from the root to the given node. Can be given either as a node ID or a tip label.
  2796. length.to.root <- function(phylo,node) {
  2797. tip.index <- node
  2798. if (is.character(node)) {
  2799. tip.index <- which(phylo$tip.label==node)
  2800. }
  2801. cur.node.b <- tip.index
  2802. p.edges <- phylo$edge
  2803. p.lengths <- phylo$edge.length
  2804. length <- 0
  2805. while(length(which(p.edges[,2]==cur.node.b)) > 0) {
  2806. cur.edge.index <- which(p.edges[,2]==cur.node.b)
  2807. cur.edge.length <- p.lengths[cur.edge.index]
  2808. length <- length + cur.edge.length
  2809. cur.node.a <- p.edges[cur.edge.index,1]
  2810. cur.node.b <- cur.node.a # Move up to the next edge
  2811. }
  2812. return(length)
  2813. }
  2814. # Returns a data frame defining segments to draw the phylogenetic tree.
  2815. phylo.layout.df <- function(phylo,layout.ancestors=FALSE,align.seq.names=NULL) {
  2816. # Number of nodes and leaves.
  2817. n.nodes <- length(phylo$tip.label)+phylo$Nnode
  2818. n.leaves <- length(phylo$tip.label)
  2819. # Create the skeleton data frame.
  2820. df <- data.frame(
  2821. node=c(1:n.nodes), # Nodes with IDs 1 to N.
  2822. x=0, # These will contain the x and y coordinates after the layout procedure below.
  2823. y=0,
  2824. label=c(phylo$tip.label,((n.leaves+1):n.nodes)), # The first n.leaves nodes are the labeled tips.
  2825. is.leaf=c(rep(TRUE,n.leaves),rep(FALSE,n.nodes-n.leaves)), # Just for convenience, store a boolean whether it's a leaf or not.
  2826. parent=0, # Will contain the ID of the current node's parent
  2827. children=0, # Will contain a list of IDs of the current node's children
  2828. branch.length=0 # Will contain the branch lengths
  2829. )
  2830. # Collect the parents, children, and branch lengths for each node
  2831. parent <- c()
  2832. bl <- list()
  2833. children <- list()
  2834. event.count <- list()
  2835. for (i in 1:nrow(df)) {
  2836. node <- df[i,]$node
  2837. parent <- c(parent,parent.node(phylo,node))
  2838. bl <- c(bl,branch.length(phylo,node))
  2839. children <- c(children,child.nodes(phylo,node))
  2840. event.count <- c(event.count,generic.count(x,node,color.branches))
  2841. }
  2842. df$parent <- parent
  2843. df$children <- children
  2844. df$branch.length <- bl
  2845. df$event.count <- as.numeric(event.count)
  2846. # Start the layout procedure by equally spacing the leaves in the y-dimension.
  2847. df[df$is.leaf==TRUE,]$y = c(1:n.leaves)
  2848. found.any.internal.node.sequences <- FALSE
  2849. # For each leaf: travel up towards the root, laying out each internal node along the way.
  2850. for (i in 1:n.leaves) {
  2851. cur.node <- i
  2852. while (length(cur.node) > 0 && cur.node != -1) {
  2853. # We always use branch lengths: x-position is simply the length to the root.
  2854. df[cur.node,]$x <- length.to.root(phylo,cur.node)
  2855. # The y-position for internal nodes is the mean of the y-position of the two children.
  2856. children <- unlist(df[cur.node,]$children)
  2857. if (length(children) > 0 && children[1] != -1) {
  2858. child.a <- children[1]
  2859. child.b <- children[2]
  2860. child.a.y <- df[child.a,]$y
  2861. child.b.y <- df[child.b,]$y
  2862. df[cur.node,]$y <- (child.a.y+child.b.y)/2
  2863. }
  2864. # Try to find the index of this node in the alignment names.
  2865. if (!is.null(align.seq.names)) {
  2866. lbl <- df[cur.node,]$label
  2867. index.in.names <- which(align.seq.names == lbl | align.seq.names %in% c(paste('Node',lbl),paste('Root node',lbl)))
  2868. if (length(index.in.names)>0) {
  2869. df[cur.node,]$y <- index.in.names
  2870. if (!df[cur.node,]$is.leaf) {
  2871. found.any.internal.node.sequences <- TRUE
  2872. }
  2873. }
  2874. }
  2875. cur.node <- unlist(df[cur.node,]$parent)
  2876. }
  2877. }
  2878. # We have a data frame with each node positioned.
  2879. # Now we go through and make two line segments for each node (for a 'square corner' type tree plot).
  2880. line.df <- data.frame()
  2881. for (i in 1:nrow(df)) {
  2882. row <- df[i,] # Data frame row for the current node.
  2883. if (row$parent == -1) {
  2884. next; # Root node!
  2885. }
  2886. p.row <- df[row$parent,] # Data frame row for the parent node.
  2887. if (layout.ancestors && found.any.internal.node.sequences) {
  2888. horiz.line <- data.frame(
  2889. x=row$x,
  2890. xend=p.row$x,
  2891. y=row$y,
  2892. yend=p.row$y,
  2893. lbl=row$label,
  2894. event.count=row$event.count
  2895. )
  2896. line.df <- rbind(line.df,horiz.line)
  2897. } else {
  2898. horiz.line <- data.frame(
  2899. x=row$x,
  2900. xend=p.row$x,
  2901. y=row$y,
  2902. yend=row$y,
  2903. lbl=row$label,
  2904. event.count=row$event.count
  2905. ) # First a line from row.x to parent.
  2906. vert.line <- data.frame(
  2907. x=p.row$x,
  2908. xend=p.row$x,
  2909. y=row$y,
  2910. yend=p.row$y,
  2911. lbl=row$label,
  2912. event.count=row$event.count
  2913. ) # Now a line from row.y to parent.y
  2914. #horiz.line <- data.frame(x=row$x,xend=(p.row$x+row$x)/2,y=row$y,yend=row$y,lbl=row$label) # First a line from row.x to parent.
  2915. #vert.line <- data.frame(x=(p.row$x+row$x)/2,xend=p.row$x,y=row$y,yend=p.row$y,lbl=row$label) # Now a line from row.y to parent.y
  2916. line.df <- rbind(line.df,horiz.line,vert.line)
  2917. }
  2918. }
  2919. return(line.df)
  2920. }
  2921. # Call this to put a ggplot panel into a specified layout position [for example: print(p,vp=subplot(1,2)) ]
  2922. subplot <- function(x, y) viewport(layout.pos.col=x, layout.pos.row=y)
  2923. # Call this to create a layout with x and y rows and columns, respectively
  2924. vplayout <- function(x, y) {
  2925. grid.newpage()
  2926. pushViewport(viewport(layout=grid.layout(y,x)))
  2927. }
  2928. # Creates a color aesthetic for alignments
  2929. alignment.colors <- function(scheme,darken=F) {
  2930. scheme <- tolower(scheme)
  2931. if (scheme == 'binary') {
  2932. cols <- c(
  2933. '0' = "#000000",
  2934. '1' = '#FFFFFF'
  2935. )
  2936. } else if (scheme == 'dna') {
  2937. cols <- c(
  2938. 'G' = "#FFFF00",
  2939. 'C' = "#00FF00",
  2940. 'T' = "#FF0000",
  2941. 'A' = "#0000FF"
  2942. )
  2943. } else if (scheme == 'numeric') {
  2944. #cols <- heat.colors(10)
  2945. cols <- colorRampPalette(c("red","yellow","green"))(10)
  2946. cols <- c(
  2947. '0' = cols[1],
  2948. '1' = cols[2],
  2949. '2' = cols[3],
  2950. '3' = cols[4],
  2951. '4' = cols[5],
  2952. '5' = cols[6],
  2953. '6' = cols[7],
  2954. '7' = cols[8],
  2955. '8' = cols[9],
  2956. '9' = cols[10]
  2957. )
  2958. } else if (scheme == 'taylor' || scheme == 'protein') {
  2959. cols <- c(
  2960. 'A' = "#CCFF00", 'a' = "#CCFF00",
  2961. 'C' = "#FFFF00", 'c' = "#FFFF00",
  2962. 'D' = "#FF0000", 'd' = "#FF0000",
  2963. 'E' = "#FF0066", 'e' = "#FF0066",
  2964. 'F' = "#00FF66", 'f' = "#00FF66",
  2965. 'G' = "#FF9900", 'g' = "#FF9900",
  2966. 'H' = "#0066FF", 'h' = "#0066FF",
  2967. 'I' = "#66FF00", 'i' = "#66FF00",
  2968. 'K' = "#6600FF", 'k' = "#6600FF",
  2969. 'L' = "#33FF00", 'l' = "#33FF00",
  2970. 'M' = "#00FF00", 'm' = "#00FF00",
  2971. 'N' = "#CC00FF", 'n' = "#CC00FF",
  2972. 'P' = "#FFCC00", 'p' = "#FFCC00",
  2973. 'Q' = "#FF00CC", 'q' = "#FF00CC",
  2974. 'R' = "#0000FF", 'r' = "#0000FF",
  2975. 'S' = "#FF3300", 's' = "#FF3300",
  2976. 'T' = "#FF6600", 't' = "#FF6600",
  2977. 'V' = "#99FF00", 'v' = "#99FF00",
  2978. 'W' = "#00CCFF", 'w' = "#00CCFF",
  2979. 'Y' = "#00FFCC", 'y' = "#00FFCC",
  2980. '2' = "#888888", '2' = "#888888",
  2981. 'O' = "#424242", 'o' = "#424242",
  2982. 'B' = "#7D7D7D", 'b' = "#7D7D7D",
  2983. 'Z' = "#EEEEEE", 'z' = "#EEEEEE",
  2984. 'X' = "#000000", 'x' = "#000000"
  2985. )
  2986. } else if (scheme == 'codon') {
  2987. # Get the protein colors.
  2988. protein.colors <- alignment.colors('protein')
  2989. # Create a list of codons.
  2990. ca <- CodonAlphabet()
  2991. nucs <- c('G','A','C','T')
  2992. codons <- expand.grid(nucs,nucs,nucs,stringsAsFactors=F)
  2993. # For each codon give the protein color.
  2994. codon.colors <- c()
  2995. for (i in 1:nrow(codons)) {
  2996. codon = paste(codons[i,],collapse='')
  2997. aa <- translateCodon(ca,codon)
  2998. codon.colors[codon] = protein.colors[aa]
  2999. }
  3000. cols <- codon.colors
  3001. } else if (scheme == 'combined') {
  3002. dna.colors <- alignment.colors('dna')
  3003. binary.colors <- alignment.colors('binary')
  3004. protein.colors <- alignment.colors('protein')
  3005. cols <- c(dna.colors,protein.colors,binary.colors)
  3006. } else if (scheme == 'combined_codon') {
  3007. dna.colors <- alignment.colors('dna')
  3008. # Make the DNA stand out here by being a little darker
  3009. for (i in 1:length(dna.colors)) {
  3010. color <- dna.colors[i]
  3011. darker.color <- darker(color)
  3012. dna.colors[i] <- darker.color
  3013. }
  3014. binary.colors <- alignment.colors('binary')
  3015. protein.colors <- alignment.colors('protein')
  3016. codon.colors <- alignment.colors('codon')
  3017. # Put them all together. (One remaining issue: the protein G,A,T,C will be colored as DNA!)
  3018. cols <- c(dna.colors,protein.colors,binary.colors,codon.colors)
  3019. }
  3020. if (darken) {
  3021. for (i in 1:length(cols)) {
  3022. color <- cols[i]
  3023. darker.color <- darker(color,0.85)
  3024. cols[i] <- darker.color
  3025. }
  3026. }
  3027. return(cols)
  3028. }
  3029. darker <- function(color,factor=0.7) {
  3030. x <- col2rgb(color)
  3031. x <- round(x * factor)
  3032. y <- rgb(x[1],x[2],x[3],maxColorValue=255)
  3033. return(y)
  3034. }
  3035. lighter <- function(color) {
  3036. x <- col2rgb(color)
  3037. x <- round(x * 1.2)
  3038. y <- rgb(min(x[1],255),min(x[2],255),min(x[3],255),maxColorValue=255)
  3039. return(y)
  3040. }
  3041. # Scores each column according to the branch length of the subtree created by
  3042. # non-gap residues (we use nongap.bl as the var name), and stores the 'nongap.str'
  3043. # which is the pasted list of labels for non-gapped sequences at this site.
  3044. # This information is used by the 'remove.gaps' function to remove columns to
  3045. # reach a certain alignment length threshold.
  3046. score.aln.columns <- function(tree,aln) {
  3047. aln.length <- length(aln[1,])
  3048. score.df <- data.frame()
  3049. for (i in 1:aln.length) {
  3050. aln.column <- aln[,i]
  3051. nongap.seqs <- names(aln.column[aln.column != '-'])
  3052. gap.seqs <- names(aln.column[aln.column == '-'])
  3053. # Get the non-gap branch length.
  3054. if (length(nongap.seqs) == 1) {
  3055. nongap.node <- node.with.label(tree,nongap.seqs[1])
  3056. nongap.bl <- branch.length(tree,nongap.node)
  3057. } else {
  3058. nongap.tree <- drop.tip(tree,gap.seqs)
  3059. nongap.bl <- sum(nongap.tree$edge.length)
  3060. }
  3061. nongap.str <- paste(nongap.seqs,collapse=';')
  3062. cur.df <- data.frame(
  3063. pos=i,
  3064. score=nongap.bl,
  3065. nongap.str=nongap.str,
  3066. stringsAsFactors=F
  3067. )
  3068. score.df <- rbind(score.df,cur.df)
  3069. }
  3070. score.df <- score.df[order(score.df$score,score.df$pos),]
  3071. return(score.df)
  3072. }
  3073. # Goes through the alignment of the sim object and removes columns until either the desired
  3074. # tolerance is reached or there are no more low-scoring columns to remove (whichever comes
  3075. # first). Tolerance is defined as the ratio of the alignment length to the mean sequence
  3076. # length. So, an alignment with no indels at all is exactly 1; an alignment with lots
  3077. # of deletions (but no insertion) is less than 1; an alignment with lots of insertion is
  3078. # greater than 1.
  3079. #
  3080. # Values of 0.9 - 1.3 tend to give good results in a variety of situations.
  3081. #
  3082. remove.gaps <- function(sim,tolerance) {
  3083. aln <- sim$.alignment
  3084. tree <- sim$.phylo
  3085. col.scores <- score.aln.columns(tree,aln)
  3086. # Store the deletion markers in a separate data frame.
  3087. deletion.df <- NULL
  3088. # Get the mean sequence length
  3089. lengths <- apply(aln,1,function(x) {
  3090. x <- x[x != '-']
  3091. return(stringLength(paste(x,collapse='')))
  3092. })
  3093. mean.seq.length <- mean(lengths)
  3094. repeat {
  3095. aln.length <- length(aln[1,])
  3096. ratio <- aln.length / mean.seq.length
  3097. if (ratio < tolerance) {
  3098. break;
  3099. }
  3100. # Take the next site from the sorted scores
  3101. lowest.scores <- col.scores[1,]
  3102. col.scores <- col.scores[-c(1),]
  3103. cur.pos <- lowest.scores$pos # Current position of lowest-scoring column.
  3104. cur.score <- lowest.scores$score # The current column score.
  3105. cur.str <- lowest.scores$nongap.str # The current column's nongap pattern.
  3106. # Grab the entire 'current chunk' of alignment which has the same
  3107. # score and non-gap string.
  3108. repeat {
  3109. first.pos <- col.scores[1,'pos']
  3110. first.score <- col.scores[1,'score']
  3111. first.str <- col.scores[1,'nongap.str']
  3112. if (cur.score == max(col.scores$score)) {
  3113. lowest.scores <- NULL
  3114. cur.ratio <- length(aln[1,]) / mean.seq.length
  3115. print(sprintf("Nothing left to remove at ratio %.2f!",cur.ratio))
  3116. break;
  3117. }
  3118. if (first.pos == cur.pos + 1 && first.score == cur.score && first.str == cur.str) {
  3119. cur.pos <- col.scores[1,]$pos
  3120. lowest.scores <- rbind(lowest.scores,col.scores[1,])
  3121. col.scores <- col.scores[-1,]
  3122. } else {
  3123. #print("Done!")
  3124. break;
  3125. }
  3126. }
  3127. if (is.null(lowest.scores)) {
  3128. break;
  3129. }
  3130. # remove.us should be a contiguous vector of integers,
  3131. # representing the set of columns to remove.
  3132. remove.us <- lowest.scores$pos
  3133. if (any(diff(remove.us) > 1)) {
  3134. print("ERROR: Removing a non-consecutive set of columns!")
  3135. }
  3136. #print(paste("Removing at ",paste(remove.us[1])))
  3137. # Go through columns from right to left, making sure to update
  3138. # the new positions of columns on the right side of the splice.
  3139. rev.pos <- rev(remove.us)
  3140. for (i in 1:length(rev.pos)) {
  3141. cur.pos <- rev.pos[i]
  3142. aln <- splice.column(aln, cur.pos)
  3143. # Update new positions of column scores
  3144. above <- which(col.scores$pos > cur.pos)
  3145. col.scores[above,]$pos <- col.scores[above,]$pos - 1
  3146. # Update new positions of deletion locations.
  3147. if (!is.null(deletion.df) && nrow(deletion.df) > 0) {
  3148. above <- which(deletion.df$pos > cur.pos)
  3149. deletion.df[above,]$pos <- deletion.df[above,]$pos - 1
  3150. }
  3151. }
  3152. # Add a single entry to the data frame of deletions, to be used
  3153. # by the plot function to indicate deletion points.
  3154. cur.deletion <- data.frame(
  3155. pos = cur.pos, # The first position AFTER the deletion splice.
  3156. length = length(rev.pos), # The length of the block removed.
  3157. nongap.str = as.character(cur.str), # nongap sequence IDs for this deletion
  3158. stringsAsFactors=F
  3159. )
  3160. #print(cur.deletion)
  3161. deletion.df <- rbind(deletion.df,cur.deletion)
  3162. }
  3163. # Create a new PhyloSim object, assign the tree & aln, and return.
  3164. sim.temp <- PhyloSim();
  3165. sim.temp$.alignment <- aln
  3166. sim.temp$.phylo <- tree
  3167. sim.temp$.indels <- deletion.df
  3168. return(sim.temp)
  3169. }
  3170. splice.column <- function(aln,pos) {
  3171. return(aln[,-pos])
  3172. }
  3173. ####################################
  3174. ### Let the real plotting begin! ###
  3175. ####################################
  3176. # Apply the deletion tolerance if needed.
  3177. if (!is.null(aln.length.tolerance)) {
  3178. x <- remove.gaps(x, tolerance=aln.length.tolerance)
  3179. indels <- x$.indels
  3180. } else {
  3181. indels <- NULL
  3182. }
  3183. df <- data.frame()
  3184. aln <- x$.alignment
  3185. phylo <- x$.phylo
  3186. # Do some reordering of alignment & tree.
  3187. if (!any(is.na(phylo))) {
  3188. x$.phylo <- reorder(x$.phylo, order="cladewise");
  3189. phylo <- x$.phylo
  3190. aln <- sort.aln.by.tree(aln,phylo)
  3191. }
  3192. names <- dimnames(aln)[[1]]
  3193. #print(paste("Aln length:",length(aln[1,])))
  3194. #print(paste("Num seqs:",length(names)))
  3195. # Create a factor of all the characters in the alignment.
  3196. char.levels <- sort(unique(as.vector(aln)))
  3197. names.levels <- names
  3198. for (i in 1:length(names)) {
  3199. char.list <- aln[i,]
  3200. name <- names[i]
  3201. # Store the indices of where the gaps are -- we won't plot the gaps.
  3202. gaps <- char.list == '-'
  3203. seq.pos <- seq(1,length(char.list))
  3204. # Get the position and character of each non-gap residue.
  3205. pos.nogaps <- seq.pos[gaps==FALSE]
  3206. char.nogaps <- as.character(char.list[gaps==FALSE])
  3207. # Create a data frame with 1 row per residue to plot.
  3208. df <- rbind(df,data.frame(
  3209. id=factor(x=rep(name,length(pos.nogaps)),levels=names.levels), # Sequence ID to which this residue belongs
  3210. seq_index=rep(i,length(pos.nogaps)), # Index of the containing sequence
  3211. pos=pos.nogaps, # Alignment position
  3212. char=factor(x=char.nogaps,levels=char.levels) # Character of the residue
  3213. ))
  3214. }
  3215. # Turn the IDs into a factor to plot along the y axis.
  3216. if (!plot.ancestors) {
  3217. # Remove the ancestral nodes from the plot.
  3218. tip.name.indices <- grep("node",names,ignore.case=TRUE,invert=TRUE)
  3219. names <- names[tip.name.indices]
  3220. df$id <- factor(df$id,levels=names)
  3221. df <- subset(df,id %in% names)
  3222. }
  3223. df$type <- 'aln'
  3224. ### Add indels to the data frame.
  3225. if (!is.null(indels)) {
  3226. # For each non-gap sequence of each chunk deleted, add a row
  3227. # to the data frame.
  3228. del.df <- data.frame()
  3229. # For each position, store the count of indels in a track.
  3230. max.pos <- max(c(df$pos,indels$pos))
  3231. indel.histogram <- data.frame(
  3232. pos=1:max.pos - 0.5,
  3233. count=0,
  3234. length=0
  3235. )
  3236. for (i in 1:nrow(indels)) {
  3237. row <- indels[i,]
  3238. seqs <- strsplit(row$nongap.str,";")[[1]]
  3239. if (length(seqs) == 0) {
  3240. # Edge case: an indel row came from a column with no aligned sequence,
  3241. # so the 'nongap.str' is empty. Just continue on...
  3242. next()
  3243. }
  3244. cur.df <- data.frame(
  3245. id=seqs,
  3246. pos=row$pos,
  3247. length=row$length,
  3248. type='indel'
  3249. )
  3250. del.df <- rbind(del.df,cur.df)
  3251. # Tick up the histogram.
  3252. indel.histogram[row$pos,]$count <- indel.histogram[row$pos,]$count + 1
  3253. indel.histogram[row$pos,]$length <- indel.histogram[row$pos,]$length + row$length
  3254. }
  3255. # Sync the two data frame's columns, fill empty stuff with NAs.
  3256. columns.from.df <- colnames(df)[!(colnames(df) %in% colnames(del.df))]
  3257. columns.from.del <- colnames(del.df)[!(colnames(del.df) %in% colnames(df))]
  3258. del.df[,columns.from.df] <- NA
  3259. df[,columns.from.del] <- NA
  3260. df <- rbind(df,del.df)
  3261. # Transform the histogram and add it to our tracks.
  3262. max.count <- max(indel.histogram$count)
  3263. max.length <- max(indel.histogram$length)
  3264. indel.histogram$y_lo <- 0
  3265. indel.histogram$score <- indel.histogram$count / (max.count+1)
  3266. indel.histogram$y_hi <- indel.histogram$score
  3267. indel.histogram$id <- 'Hidden Indel Count'
  3268. indel.histogram$height <- 5
  3269. indel.histogram$layout <- 'below'
  3270. indel.histogram$color.gradient <- 'darkblue,darkblue'
  3271. indel.histogram$type <- 'track'
  3272. #indel.len <- indel.histogram
  3273. #indel.len$id <- 'Hidden Indel Length'
  3274. #indel.len$score <- indel.len$length / (max.length+1)
  3275. #indel.len$y_hi <- indel.len$score
  3276. #indel.len$color.gradient <- 'darkgreen,darkgreen'
  3277. if (!is.null(tracks)) {
  3278. tracks <- c(tracks,list(indel.histogram))
  3279. } else {
  3280. tracks <- list(indel.histogram)
  3281. }
  3282. }
  3283. if (plot.nongap.bl && is.phylo(phylo)) {
  3284. score.df <- score.aln.columns(phylo,aln)
  3285. max.bl <- max(score.df$score)
  3286. bl.track <- data.frame(
  3287. id = 'Non-gap Branch Length',
  3288. layout = 'below',
  3289. pos = score.df$pos,
  3290. score = score.df$score / max.bl * 0.9,
  3291. y_hi = score.df$score / max.bl * 0.9,
  3292. color.gradient = 'red,black,black'
  3293. )
  3294. if (!is.null(tracks)) {
  3295. tracks <- c(tracks,list(bl.track))
  3296. } else {
  3297. tracks <- list(bl.track)
  3298. }
  3299. }
  3300. # Track input format is a list of data frames with one row per feature to be
  3301. # displayed, with the following columns. The only mandatory column is 'pos';
  3302. # all others have sensible default values.
  3303. # ---
  3304. # [fields below are unique per row]
  3305. # pos: The sequence position (starting with 1) of the feature
  3306. # score: The score (between 0 and 1) of the feature. Scores above 1 or below
  3307. # zero will be truncated.
  3308. # y_lo: The lower Y offset (between 0 and 1) of the feature block.
  3309. # y_hi: The upper Y offset (between 0 and 1) of the feature block. These two
  3310. # values allow bars to be positioned along the y-axis.
  3311. # [fields below are unique per track; the value from the first row is used.]
  3312. # id: The display ID for the track.
  3313. # layout: Set to 'above' to put the track above the alignment, 'below' for below.
  3314. # height: The number of alignment rows for the track to span in height.
  3315. # color.gradient: A comma-separated list of colors to interpolate between when coloring
  3316. # the blocks. Examples: 'white,red' 'blue,gray,red' '#FF00FF,#FFFFFF'
  3317. # color: A single color to use for the track, no matter what the scores. Overridden
  3318. # color.gradient if both exist.
  3319. #
  3320. # ---
  3321. #
  3322. # What we do is add the track data to the alignment data frame (so it gets
  3323. # paged and scaled properly along with the alignment data) and then separate
  3324. # it out before plotting, so it can be plotted separately from the alignment.
  3325. df$track_index <- -1
  3326. if (!is.null(tracks)) {
  3327. df$score <- NA
  3328. i <- 0
  3329. for (track in tracks) {
  3330. i <- i + 1
  3331. track$track_index <- i
  3332. track$type <- 'track'
  3333. # Add default values.
  3334. if (is.null(track$background)) {
  3335. track$background <- 'white'
  3336. }
  3337. if (length(track$pos) == 0) {
  3338. # If no positions are included in the data frame, set the first position
  3339. # to 1 and put the foreground color same as the background.
  3340. # This has the effect of creating a 'spacer' row.
  3341. track$pos <- 1
  3342. track$color <- track[1,]$background
  3343. }
  3344. if (is.null(track$layout)) {
  3345. track$layout <- 'above'
  3346. }
  3347. if (is.null(track$color.gradient)) {
  3348. if (!is.null(track$color)) {
  3349. # No color gradient exists, but we have 'color' instead. Use that.
  3350. track$color.gradient <- paste(track[1,]$color, track[1,]$color, sep=',')
  3351. } else {
  3352. # No color.gradient OR color value exists, so use the default white-to-black.
  3353. track$color.gradient <- 'white,black'
  3354. }
  3355. }
  3356. if (is.null(track$score)) {
  3357. track$score <- 1
  3358. }
  3359. if (is.null(track$y_lo)) {
  3360. track$y_lo = 0
  3361. }
  3362. if (is.null(track$y_hi)) {
  3363. track$y_hi = 1
  3364. }
  3365. if (is.null(track$id)) {
  3366. track$id <- paste('Track',i)
  3367. }
  3368. if (is.null(track$height) || is.na(track$height)) {
  3369. track$height <- 4
  3370. }
  3371. # Ensure that we don't have positions at zero or below.
  3372. track[track$pos <= 0,'pos'] <- 1
  3373. # Limit score range
  3374. track$score <- pmin(track$score,1)
  3375. track$score <- pmax(track$score,0)
  3376. # Sync the two data frame's columns, fill empty stuff with NAs.
  3377. columns.from.aln <- colnames(df)[!(colnames(df) %in% colnames(track))]
  3378. columns.from.track <- colnames(track)[!(colnames(track) %in% colnames(df))]
  3379. track[,columns.from.aln] <- NA
  3380. df[,columns.from.track] <- NA
  3381. track$type <- 'track'
  3382. df <- rbind(df,track)
  3383. }
  3384. }
  3385. if (num.pages != 'auto') {
  3386. num.pages <- as.numeric(num.pages)
  3387. }
  3388. aln.length <- max(df$pos)
  3389. chars.per.page <- aln.length
  3390. num.seqs <- length(names)
  3391. if (tolower(num.pages) == 'auto' || num.pages > 1) {
  3392. # Plotting a multi-page alignment.
  3393. if (tolower(num.pages) == 'auto') {
  3394. # If we have tracks, add the total track height to the 'num.seqs' variable.
  3395. track.rows <- subset(df,type == 'track')
  3396. if (nrow(track.rows) > 0) {
  3397. track.indices <- sort(unique(track.rows$track_index))
  3398. for (track.index in track.indices) {
  3399. sub.track <- subset(track.rows,track_index==track.index)
  3400. if (nrow(sub.track) > 0) {
  3401. num.seqs <- num.seqs + sub.track[1,]$height
  3402. }
  3403. }
  3404. }
  3405. # Formula to get a square-ish total plot.
  3406. num.pages <- sqrt(aln.length/num.seqs)
  3407. num.pages <- ceiling(num.pages)+1
  3408. # One-page rule for short alignments.
  3409. if (aln.length < 30) {num.pages <- 1}
  3410. }
  3411. # Add a 'page' factor to the data frame and use facet_grid.
  3412. chars.per.page <- ceiling(aln.length / num.pages)
  3413. df$page <- floor((df$pos-1) / chars.per.page) + 1
  3414. if (nrow(subset(df,page <= 0)) > 0) {
  3415. df[df$page <= 0,]$page <- 1 # Fix errors where pos=0.5 goes to page 0
  3416. }
  3417. df$pos <- df$pos - (chars.per.page*(df$page-1))
  3418. page.labels <- paste((0:(num.pages-1))*chars.per.page+1,(1:num.pages)*chars.per.page,sep="-")
  3419. page.numbers <- sort(unique(df$page))
  3420. page.labels <- page.labels[page.numbers]
  3421. df$page <- factor(df$page,levels=page.numbers,labels=page.labels)
  3422. num.pages <- length(page.labels)
  3423. #print(paste("Num pages:",num.pages))
  3424. } else {
  3425. # We've only got one page. Create a factor...
  3426. df$page <- 1
  3427. df$page <- factor(df$page,levels=c(1),labels=c('1'))
  3428. # Store some values which will be used later.
  3429. aln.length <- max(df$pos)
  3430. chars.per.page <- aln.length
  3431. }
  3432. if (color.scheme == 'auto') {
  3433. all.chars <- unlist(aln)
  3434. all.chars <- all.chars[all.chars != '-']
  3435. n.chars <- length(unique(toupper(all.chars)))
  3436. dna <- c('a','t','g','c')
  3437. dna <- c(dna,toupper(dna))
  3438. protein <- letters
  3439. protein <- protein[!(protein %in% c('b','j','o','u','x','z'))]
  3440. protein <- c(protein,toupper(protein))
  3441. ca <- CodonAlphabet()
  3442. nucs <- c('G','A','C','T')
  3443. codon.grid <- expand.grid(nucs,nucs,nucs,stringsAsFactors=F)
  3444. codons <- c()
  3445. for (i in 1:nrow(codon.grid)) {
  3446. codons <- c(codons,paste(codon.grid[i,],collapse=''))
  3447. }
  3448. if(any(all.chars %in% codons)) {
  3449. # If we see any codon alphabets, use the combined_codon
  3450. color.scheme <- 'combined_codon'
  3451. } else {
  3452. # Else just use the combined color scheme. It's good enough!
  3453. color.scheme <- 'combined'
  3454. }
  3455. }
  3456. legend.title <- color.scheme
  3457. # Remove any tracks from the main aln data frame.
  3458. tracks <- subset(df,type=='track')
  3459. indels <- subset(df,type=='indel')
  3460. df <- subset(df,type=='aln')
  3461. # Set positional values in the aln data frame.
  3462. df$xx <- df$pos
  3463. df$yy <- as.numeric(df$id)
  3464. df$xmin <- df$xx - .5
  3465. df$xmax <- df$xx + .5
  3466. df$ymin <- df$yy - .5
  3467. df$ymax <- df$yy + .5
  3468. darken.colors <- FALSE
  3469. if (nrow(indels) > 0) {
  3470. darken.colors <- TRUE
  3471. }
  3472. color.map <- alignment.colors(color.scheme,darken=darken.colors)
  3473. df$colors <- color.map[as.character(df$char)]
  3474. # Set the base for y-axis configurations.
  3475. y.lim <- c(0,length(names)+1)
  3476. y.breaks <- 1:length(names)
  3477. y.labels <- names
  3478. # Create the ggplot panel.
  3479. p <- ggplot(df,aes(x=xx,y=yy,xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax))
  3480. p <- p + geom_rect(aes(fill=colors))
  3481. if (!is.null(aln.xlim)) {
  3482. aln.limits <- aln.xlim
  3483. } else {
  3484. aln.limits <- c(0,max(df$pos)+1)
  3485. }
  3486. if (nrow(tracks) > 0) {
  3487. # Handle tracks.
  3488. # These variables hold the current above and below offsets.
  3489. cur.y.above <- length(names) + 1 - .5
  3490. y.lim[2] <- length(names) + 1 - .5
  3491. cur.y.below <- 0.5
  3492. bg.out <- data.frame()
  3493. track.out <- data.frame()
  3494. track.indices <- sort(unique(tracks$track_index))
  3495. for (track.index in track.indices) {
  3496. sub.track <- subset(tracks,track_index==track.index)
  3497. # Collect the track-wide features.
  3498. track.id <- sub.track[1,]$id
  3499. track.height <- sub.track[1,]$height
  3500. track.layout <- sub.track[1,]$layout
  3501. color.gradient <- strsplit(sub.track[1,]$color.gradient,',')[[1]]
  3502. track.bg <- sub.track[1,]$background
  3503. track.ramp <- colorRamp(colors=color.gradient)
  3504. sub.track$colors <- rgb(track.ramp(sub.track$score),maxColorValue=255)
  3505. sub.track$xx <- sub.track$pos
  3506. sub.track$xmin <- sub.track$pos-.5
  3507. sub.track$xmax <- sub.track$pos+.5
  3508. if (track.layout == 'below') {
  3509. sub.track$yy <- cur.y.below
  3510. sub.track$ymin <- cur.y.below - track.height
  3511. sub.track$ymax <- cur.y.below
  3512. y.lim[1] <- cur.y.below - track.height
  3513. y.breaks <- c(y.lim[1] + track.height/2,y.breaks)
  3514. y.labels <- c(as.character(track.id),y.labels)
  3515. # Temporarily store the current min and max for y.
  3516. cur.y.min <- cur.y.below - track.height
  3517. cur.y.max <- cur.y.below
  3518. # Add our track height to the state variable.
  3519. cur.y.below <- cur.y.below - track.height
  3520. } else {
  3521. sub.track$yy <- cur.y.above
  3522. sub.track$ymin <- cur.y.above
  3523. sub.track$ymax <- cur.y.above + track.height
  3524. y.lim[2] <- cur.y.above + track.height
  3525. y.breaks <- c(y.breaks,y.lim[2] - track.height/2)
  3526. y.labels <- c(y.labels,as.character(track.id))
  3527. # Temporarily store the current min and max for y.
  3528. cur.y.min <- cur.y.above
  3529. cur.y.max <- cur.y.above + track.height
  3530. # Add our track height to the state variable.
  3531. cur.y.above <- cur.y.above + track.height
  3532. }
  3533. # Adjust bar position if we have y_lo and y_hi values.
  3534. if(length(sub.track$y_lo) > 0) {
  3535. sub.track$ymin <- cur.y.min + track.height*sub.track$y_lo
  3536. }
  3537. if (length(sub.track$y_hi) > 0) {
  3538. sub.track$ymax <- cur.y.min + track.height*sub.track$y_hi
  3539. }
  3540. track.out <- rbind(track.out,sub.track)
  3541. # Create a background rectangle for each page, to place behind the current track.
  3542. pages <- sort(unique(df$page))
  3543. page.indices <- sort(unique(as.integer(df$page)))
  3544. for (page.index in 1:length(pages)) {
  3545. pg <- pages[page.index]
  3546. current.track.bg <- data.frame(
  3547. page=pg,
  3548. colors=track.bg,
  3549. xx=0.5,
  3550. yy=cur.y.min,
  3551. xmin=0.5,
  3552. xmax=chars.per.page + 0.5,
  3553. ymin=cur.y.min,
  3554. ymax=cur.y.max
  3555. )
  3556. bg.out <- rbind(bg.out,current.track.bg)
  3557. }
  3558. }
  3559. # Add layers for the backgrounds and tracks.
  3560. p <- p + geom_rect(aes(fill=colors),data=bg.out)
  3561. p <- p + geom_rect(aes(fill=colors),data=track.out)
  3562. }
  3563. if (nrow(indels) > 0) {
  3564. # Plot indels as small bars on top of characters.
  3565. indel.width <- 0.25
  3566. indels$pos <- indels$pos - .5 # Position indel on seq boundary.
  3567. indels$xx <- indels$pos
  3568. indels$yy <- as.numeric(indels$id)
  3569. indels$xmin <- indels$xx - indel.width
  3570. indels$xmax <- indels$xx + indel.width
  3571. indels$ymin <- indels$yy - .5
  3572. indels$ymax <- indels$yy + .5
  3573. indels$colors <- 'black'
  3574. p <- p + geom_rect(aes(fill=colors),data=indels)
  3575. }
  3576. #color.map <- alignment.colors(color.scheme)
  3577. p <- p + scale_fill_identity()
  3578. p <- p + scale_x_continuous(limits=aln.limits,expand=c(0,0))
  3579. if (plot.labels) {
  3580. p <- p + scale_y_continuous(limits=y.lim,breaks=y.breaks,labels=y.labels,expand=c(0,0))
  3581. } else {
  3582. p <- p + scale_y_continuous(limits=y.lim,breaks=y.breaks,labels=rep('',length(y.labels)),expand=c(0,0))
  3583. }
  3584. if (aspect.ratio) {
  3585. axis.text.size <- 5
  3586. char.text.size <- 2
  3587. }
  3588. if (num.pages > 1) {
  3589. p <- p + facet_grid(page ~ .)
  3590. }
  3591. if (char.text.size == 'auto') {
  3592. char.text.size <- 125 / (num.pages * (num.seqs+1))
  3593. char.text.size <- min(char.text.size,10)
  3594. char.text.size <- max(char.text.size,1)
  3595. }
  3596. if (plot.chars) {
  3597. p <- p + geom_text(aes(label=char),colour='black',size=char.text.size)
  3598. }
  3599. if (aspect.ratio) {
  3600. p <- p + coord_equal(ratio=aspect.ratio)
  3601. }
  3602. if (axis.text.size == 'auto') {
  3603. axis.text.size <- 500 / (num.pages * (num.seqs+1))
  3604. axis.text.size <- min(axis.text.size,10)
  3605. axis.text.size <- max(axis.text.size,1)
  3606. }
  3607. plot.theme <- theme(
  3608. axis.text.y = element_text(size=axis.text.size,hjust=1),
  3609. axis.title.x = element_blank(),
  3610. axis.title.y = element_blank(),
  3611. axis.ticks = element_blank(),
  3612. panel.grid.minor = element_blank(),
  3613. panel.grid.major = element_blank(),
  3614. plot.margin = unit(c(0,0,0,0),'npc')
  3615. )
  3616. p <- p + plot.theme
  3617. if (!plot.legend) {
  3618. p <- p + theme(legend.position='none')
  3619. }
  3620. if (plot.tree) {
  3621. if (plot.ancestors) {
  3622. tree.df <- phylo.layout.df(phylo,layout.ancestors=TRUE,align.seq.names=names)
  3623. } else {
  3624. tree.df <- phylo.layout.df(phylo,align.seq.names=names)
  3625. }
  3626. if (num.pages > 1) {
  3627. tree.df$page <- 1
  3628. df.copy <- tree.df
  3629. for (i in 2 : num.pages) {
  3630. df.copy$page <- i
  3631. tree.df <- rbind(tree.df,df.copy)
  3632. }
  3633. }
  3634. max.length <- max.length.to.root(phylo)
  3635. aln.length <- length(aln[1,])
  3636. n.leaves <- length(names)
  3637. if (max(tree.df$event.count) > 0) {
  3638. #print(paste("Coloring tree by",color.branches))
  3639. q <- ggplot(tree.df,aes(colour=event.count))
  3640. q <- q + scale_colour_gradient()
  3641. } else {
  3642. q <- ggplot(tree.df)
  3643. }
  3644. q <- q + geom_segment(aes(x=x,y=y,xend=xend,yend=yend))
  3645. if (plot.labels) {
  3646. q <- q + scale_y_continuous(limits=y.lim,breaks=y.breaks,labels=y.labels,expand=c(0,0))
  3647. } else {
  3648. q <- q + scale_y_continuous(limits=y.lim,breaks=y.breaks,labels=rep('',length(y.labels)),expand=c(0,0))
  3649. }
  3650. if (!is.null(tree.xlim)) {
  3651. tree.limits <- tree.xlim
  3652. } else {
  3653. tree.limits <- c(0,max.length)
  3654. }
  3655. q <- q + scale_x_continuous(limits=tree.limits,expand=c(0.05,0))
  3656. q <- q + plot.theme
  3657. # q <- q + theme(plot.margin = unit(c(0,0,0,0),'npc'))
  3658. if (num.pages > 1) {
  3659. q <- q + facet_grid(page ~ .)
  3660. q <- q + theme(strip.text.y=element_blank())
  3661. }
  3662. if (!plot.legend) {
  3663. q <- q + theme(legend.position='none')
  3664. }
  3665. if (aspect.ratio) {
  3666. warning("Aspect ratio set while plotting tree -- the alignment and tree won't line up!")
  3667. }
  3668. vplayout(4,1)
  3669. print(p,vp=subplot(2:4,1))
  3670. print(q,vp=subplot(1,1))
  3671. } else {
  3672. p <- p + plot.theme
  3673. print(p)
  3674. }
  3675. # this method has no meaningful return value
  3676. },
  3677. private=TRUE,
  3678. protected=FALSE,
  3679. overwrite=FALSE,
  3680. conflict="warning",
  3681. validators=getOption("R.methodsS3:validators:setMethodS3")
  3682. );
  3683. ##
  3684. ## Method: summary.PhyloSim
  3685. ##
  3686. ###########################################################################/**
  3687. #
  3688. # @RdocMethod summary
  3689. #
  3690. # @title "Summarize the properties of an object"
  3691. #
  3692. # \description{
  3693. # @get "title".
  3694. # }
  3695. #
  3696. # @synopsis
  3697. #
  3698. # \arguments{
  3699. # \item{object}{An object}
  3700. # \item{...}{Not used.}
  3701. # }
  3702. #
  3703. # \value{
  3704. # Returns a PSRootSummary object.
  3705. # }
  3706. #
  3707. # \examples{
  3708. # # Create a PhyloSim object.
  3709. # # Provide the phylo object
  3710. # # and the root sequence.
  3711. # sim<-PhyloSim(
  3712. # name="TinySim",
  3713. # phylo=rcoal(3),
  3714. # root.seq=NucleotideSequence(string="ATG",processes=list(list(JC69())))
  3715. # );
  3716. # # get a summary
  3717. # summary(sim)
  3718. # }
  3719. #
  3720. # @author
  3721. #
  3722. # \seealso{
  3723. # @seeclass
  3724. # }
  3725. #
  3726. #*/###########################################################################
  3727. setMethodS3(
  3728. "summary",
  3729. class="PhyloSim",
  3730. function(
  3731. object,
  3732. ...
  3733. ){
  3734. this<-object;
  3735. this$.summary$"Name"<-this$name;
  3736. this$.summary$"Id"<-this$id;
  3737. if(is.Sequence(this$rootSeq)){
  3738. root.seq<-this$rootSeq$id;
  3739. } else {
  3740. this$.summary$"Root Sequence"<-"undefined";
  3741. }
  3742. if(is.Sequence(this$rootSeq)){
  3743. this$.summary$"Root Sequence big rate"<-this$rootSeq$bigRate;
  3744. }
  3745. if(is.phylo(this$.phylo)){
  3746. this$.summary$"Tree length"<-this$treeLength;
  3747. phylo.details<-grep(pattern="[[:alnum:]]+",x=capture.output(print(this$.phylo)),perl=TRUE,value=TRUE);
  3748. phylo.details<-paste("\n",phylo.details,collapse="",sep="\t");
  3749. this$.summary$"Phylo object details"<-phylo.details;
  3750. } else {
  3751. this$.summary$"Phylo object details"<-"undefined";
  3752. }
  3753. aln<-"undefined";
  3754. if(is.matrix(this$alignment)){
  3755. aln<-"defined";
  3756. }
  3757. this$.summary$"Alignment"<-aln;
  3758. this$.summary$"Log file"<-this$.log.file;
  3759. this$.summary$"Log level"<-this$.log.level;
  3760. NextMethod();
  3761. },
  3762. private=FALSE,
  3763. protected=FALSE,
  3764. overwrite=FALSE,
  3765. conflict="warning",
  3766. validators=getOption("R.methodsS3:validators:setMethodS3")
  3767. );
  3768. ##### Logging Methods #####
  3769. ##
  3770. ## Method: getLogFile
  3771. ##
  3772. ###########################################################################/**
  3773. #
  3774. # @RdocMethod getLogFile
  3775. #
  3776. # @title "Get the name of the file used for logging"
  3777. #
  3778. # \description{
  3779. # @get "title".
  3780. # }
  3781. #
  3782. # @synopsis
  3783. #
  3784. # \arguments{
  3785. # \item{this}{A PhyloSim object.}
  3786. # \item{...}{Not used.}
  3787. # }
  3788. #
  3789. # \value{
  3790. # A character vector of length one.
  3791. # }
  3792. #
  3793. # \examples{
  3794. # # Create a PhyloSim object
  3795. # sim<-PhyloSim();
  3796. # # get the name of the log file
  3797. # getLogFile(sim)
  3798. # # modify log file name
  3799. # setLogFile(sim,"OldLog.txt")
  3800. # # get/set log file name via virtual field
  3801. # sim$logFile
  3802. # sim$logFile<-"NewLog"
  3803. # sim$logFile
  3804. # }
  3805. #
  3806. # @author
  3807. #
  3808. # \seealso{
  3809. # @seeclass
  3810. # }
  3811. #
  3812. #*/###########################################################################
  3813. setMethodS3(
  3814. "getLogFile",
  3815. class="PhyloSim",
  3816. function(
  3817. this,
  3818. ...
  3819. ){
  3820. this$.log.file;
  3821. },
  3822. private=FALSE,
  3823. protected=FALSE,
  3824. overwrite=FALSE,
  3825. conflict="warning",
  3826. validators=getOption("R.methodsS3:validators:setMethodS3")
  3827. );
  3828. ##
  3829. ## Method: setLogFile
  3830. ##
  3831. ###########################################################################/**
  3832. #
  3833. # @RdocMethod setLogFile
  3834. #
  3835. # @title "Set the name of the file used for logging"
  3836. #
  3837. # \description{
  3838. # @get "title".
  3839. # }
  3840. #
  3841. # @synopsis
  3842. #
  3843. # \arguments{
  3844. # \item{this}{A PhyloSim object.}
  3845. # \item{value}{The name of the file used for logging.}
  3846. # \item{...}{Not used.}
  3847. # }
  3848. #
  3849. # \value{
  3850. # The new logfile.
  3851. # }
  3852. #
  3853. # \examples{
  3854. # # Create a PhyloSim object
  3855. # sim<-PhyloSim();
  3856. # # get the name of the log file
  3857. # getLogFile(sim)
  3858. # # modify log file name
  3859. # setLogFile(sim,"OldLog.txt")
  3860. # # get/set log file name via virtual field
  3861. # sim$logFile
  3862. # sim$logFile<-"NewLog"
  3863. # sim$logFile
  3864. # }
  3865. #
  3866. # @author
  3867. #
  3868. # \seealso{
  3869. # @seeclass
  3870. # }
  3871. #
  3872. #*/###########################################################################
  3873. setMethodS3(
  3874. "setLogFile",
  3875. class="PhyloSim",
  3876. function(
  3877. this,
  3878. value,
  3879. ...
  3880. ){
  3881. if(missing(value)){
  3882. throw("No value provided!\n");
  3883. }
  3884. value<-as.character(value);
  3885. if( length(value) != 1 ){
  3886. throw("The new value must be a character vector of length 1!\n");
  3887. }
  3888. else{
  3889. if( file.access(value,mode=0) == c(0) ){
  3890. warning("The specified file already exists and it will be overwritten during simulation!\n");
  3891. }
  3892. this$.log.file<-value;
  3893. }
  3894. return(this$.log.file);
  3895. },
  3896. private=FALSE,
  3897. protected=FALSE,
  3898. overwrite=FALSE,
  3899. conflict="warning",
  3900. validators=getOption("R.methodsS3:validators:setMethodS3")
  3901. );
  3902. ##
  3903. ## Method: getLogLevel
  3904. ##
  3905. ###########################################################################/**
  3906. #
  3907. # @RdocMethod getLogLevel
  3908. #
  3909. # @title "Get the log level from a PhyloSim object"
  3910. #
  3911. # \description{
  3912. # @get "title".
  3913. # }
  3914. #
  3915. # @synopsis
  3916. #
  3917. # \arguments{
  3918. # \item{this}{A PhyloSim object.}
  3919. # \item{...}{Not used.}
  3920. # }
  3921. #
  3922. # \value{
  3923. # The log level as an integer vector of length one.
  3924. # }
  3925. #
  3926. # \examples{
  3927. # # Create a PhyloSim object
  3928. # sim<-PhyloSim();
  3929. # # get/set log level
  3930. # getLogLevel(sim)
  3931. # setLogLevel(sim,0)
  3932. # # set/get log level via virtual field
  3933. # sim$logLevel<- -1
  3934. # sim$logLevel
  3935. # # clean up
  3936. # unlink(sim$logFile)
  3937. # }
  3938. #
  3939. # @author
  3940. #
  3941. # \seealso{
  3942. # setLogLevel PhyloSim
  3943. # }
  3944. #
  3945. #*/###########################################################################
  3946. setMethodS3(
  3947. "getLogLevel",
  3948. class="PhyloSim",
  3949. function(
  3950. this,
  3951. ...
  3952. ){
  3953. this$.log.level;
  3954. },
  3955. private=FALSE,
  3956. protected=FALSE,
  3957. overwrite=FALSE,
  3958. conflict="warning",
  3959. validators=getOption("R.methodsS3:validators:setMethodS3")
  3960. );
  3961. ##
  3962. ## Method: setLogLevel
  3963. ##
  3964. ###########################################################################/**
  3965. #
  3966. # @RdocMethod setLogLevel
  3967. #
  3968. # @title "Set the log level for a given PhyloSim object"
  3969. #
  3970. # \description{
  3971. # @get "title".
  3972. #
  3973. # No logging is performed if the log level is negative. If the log level is zero, the messages passed to
  3974. # the \code{Log} method will be writen in the log file. If the log level is positive, the messages passed to
  3975. # the \code{Debug} method are saved as well.
  3976. #
  3977. # The default log level is -1. The specified file will be truncated in the case it already exists.
  3978. # }
  3979. #
  3980. # @synopsis
  3981. #
  3982. # \arguments{
  3983. # \item{this}{A PhyloSim object.}
  3984. # \item{value}{The new log level as an integer.}
  3985. # \item{...}{Not used.}
  3986. # }
  3987. #
  3988. # \value{
  3989. # The new level as an integer vector of length one.
  3990. # }
  3991. #
  3992. # \examples{
  3993. # # Create a PhyloSim object
  3994. # sim<-PhyloSim();
  3995. # # get/set log level
  3996. # getLogLevel(sim)
  3997. # setLogLevel(sim,0)
  3998. # # set/get log level via virtual field
  3999. # sim$logLevel<- -1
  4000. # sim$logLevel
  4001. # }
  4002. #
  4003. # @author
  4004. #
  4005. # \seealso{
  4006. # getLogLevel PhyloSim
  4007. # }
  4008. #
  4009. #*/###########################################################################
  4010. setMethodS3(
  4011. "setLogLevel",
  4012. class="PhyloSim",
  4013. function(
  4014. this,
  4015. value,
  4016. ...
  4017. ){
  4018. if(missing(value)){
  4019. throw("No value provided!\n");
  4020. }
  4021. if((!is.numeric(value)) | length(value) != 1 ){
  4022. throw("The new value must be a numeric vector of length 1!\n");
  4023. }
  4024. else{
  4025. # Create/wipe out log file.
  4026. if(value >= 0 ){
  4027. if(file.access(this$.log.file,mode=0) == c(0)){
  4028. warning("The log file already existed and it was wiped out!\n");
  4029. }
  4030. # Creating the associated connection:
  4031. this$.log.connection<-file(paste(this$.log.file),"w+");
  4032. }
  4033. this$.log.level<-value;
  4034. }
  4035. return(this$.log.level);
  4036. },
  4037. private=FALSE,
  4038. protected=FALSE,
  4039. overwrite=FALSE,
  4040. conflict="warning",
  4041. validators=getOption("R.methodsS3:validators:setMethodS3")
  4042. );
  4043. ##
  4044. ## Method: .getMessageTemplate
  4045. ##
  4046. setMethodS3(
  4047. ".getMessageTemplate",
  4048. class="PhyloSim",
  4049. function(
  4050. this,
  4051. ...
  4052. ){
  4053. template<-list(
  4054. time=paste("[",Sys.time(),"]",sep=""),
  4055. level="Info",
  4056. event=""
  4057. );
  4058. return(template);
  4059. },
  4060. private=FALSE,
  4061. protected=FALSE,
  4062. overwrite=FALSE,
  4063. conflict="warning",
  4064. validators=getOption("R.methodsS3:validators:setMethodS3")
  4065. );
  4066. ##
  4067. ## Method: .logMessage
  4068. ##
  4069. setMethodS3(
  4070. ".logMessage",
  4071. class="PhyloSim",
  4072. function(
  4073. this,
  4074. message,
  4075. ...
  4076. ){
  4077. if(missing(message)){
  4078. throw("No message given!\n");
  4079. }
  4080. else if (!is.list(message)){
  4081. throw("The message should be a list");
  4082. }
  4083. else if( length(intersect(names(message),c("time","level","event"))) != 3){
  4084. throw("The \"time\", \"level\" and \"event\" elements are mandatory in the message list!\n");
  4085. }
  4086. else {
  4087. writeLines(paste(message[["time"]]," "),con=this$.log.connection,sep="");
  4088. message[["time"]]<-NULL;
  4089. writeLines(paste(message[["level"]]," "),con=this$.log.connection,sep="");
  4090. message[["level"]]<-NULL;
  4091. writeLines(paste(message[["event"]]," "),con=this$.log.connection,sep="");
  4092. message[["event"]]<-NULL;
  4093. writeLines(paste(message,collapse=", "),con=this$.log.connection,sep="");
  4094. writeLines("\n",con=this$.log.connection,sep="");
  4095. return(TRUE);
  4096. }
  4097. },
  4098. private=FALSE,
  4099. protected=FALSE,
  4100. overwrite=FALSE,
  4101. conflict="warning",
  4102. validators=getOption("R.methodsS3:validators:setMethodS3")
  4103. );
  4104. ##
  4105. ## Method: Log
  4106. ##
  4107. ###########################################################################/**
  4108. #
  4109. # @RdocMethod Log
  4110. #
  4111. # @title "Save a message in the PhyloSim log file"
  4112. #
  4113. # \description{
  4114. # @get "title".
  4115. #
  4116. # The message is written to the log file only if the log level is non-negative. You can use this method for logging
  4117. # in the case you write classes for PhyloSim.
  4118. # }
  4119. #
  4120. # @synopsis
  4121. #
  4122. # \arguments{
  4123. # \item{this}{A PhyloSim object.}
  4124. # \item{message}{A character vector of length one.}
  4125. # \item{...}{Not used.}
  4126. # }
  4127. #
  4128. # \value{
  4129. # The message (invisible).
  4130. # }
  4131. #
  4132. # \examples{
  4133. # # create a PhyloSim object,
  4134. # # with logLevel set to zero
  4135. # sim<-PhyloSim(log.level=0);
  4136. # # log a message
  4137. # Log(sim,"Hiya there!");
  4138. # # close log connection
  4139. # close(sim$.log.connection)
  4140. # # print out the log file
  4141. # cat(paste(scan(file=sim$LogFile,what=character(),sep="\n"),collapse="\n"));cat("\n");
  4142. # # clean up
  4143. # unlink(sim$logFile)
  4144. # }
  4145. #
  4146. # @author
  4147. #
  4148. # \seealso{
  4149. # @seeclass
  4150. # }
  4151. #
  4152. #*/###########################################################################
  4153. setMethodS3(
  4154. "Log",
  4155. class="PhyloSim",
  4156. function(
  4157. this,
  4158. message,
  4159. ...
  4160. ){
  4161. if(this$.log.level < 0){
  4162. return(invisible(FALSE))
  4163. }
  4164. if(missing(message)){
  4165. throw("No message given!\n");
  4166. } else {
  4167. template<-.getMessageTemplate(this);
  4168. template$level<-"Info";
  4169. message<-c(template,as.list(message));
  4170. .logMessage(this, message);
  4171. return(invisible(message));
  4172. }
  4173. },
  4174. private=FALSE,
  4175. protected=FALSE,
  4176. overwrite=FALSE,
  4177. conflict="warning",
  4178. validators=getOption("R.methodsS3:validators:setMethodS3")
  4179. );
  4180. ##
  4181. ## Method: Debug
  4182. ##
  4183. ###########################################################################/**
  4184. #
  4185. # @RdocMethod Debug
  4186. #
  4187. # @title "Save a debug message in the PhyloSim log file"
  4188. #
  4189. # \description{
  4190. # @get "title".
  4191. #
  4192. # The debug message is written to the log file only if the log level is non-negative. You can use this method for logging
  4193. # debug messages in the case you write classes for PhyloSim.
  4194. # }
  4195. #
  4196. # @synopsis
  4197. #
  4198. # \arguments{
  4199. # \item{this}{A PhyloSim object.}
  4200. # \item{message}{A character vector of length one.}
  4201. # \item{...}{Not used.}
  4202. # }
  4203. #
  4204. # \value{
  4205. # The message (invisible).
  4206. # }
  4207. #
  4208. # \examples{
  4209. # # create a PhyloSim object,
  4210. # # with logLevel set to zero
  4211. # sim<-PhyloSim(log.level=0);
  4212. # # log a debug message
  4213. # Debug(sim,"Some useful detail...");
  4214. # # close log connection
  4215. # close(sim$.log.connection)
  4216. # # print out the log file
  4217. # cat(paste(scan(file=sim$LogFile,what=character(),sep="\n"),collapse="\n"));cat("\n");
  4218. # # clean up
  4219. # unlink(sim$logFile)
  4220. # }
  4221. #
  4222. # @author
  4223. #
  4224. # \seealso{
  4225. # @seeclass
  4226. # }
  4227. #
  4228. #*/###########################################################################
  4229. setMethodS3(
  4230. "Debug",
  4231. class="PhyloSim",
  4232. function(
  4233. this,
  4234. message,
  4235. ...
  4236. ){
  4237. if(missing(message)){
  4238. throw("No message given!\n");
  4239. }
  4240. else if( this$.log.level <= 0){
  4241. return(invisible(FALSE))
  4242. }
  4243. else {
  4244. template<-.getMessageTemplate(this);
  4245. template$level<-"DEBUG";
  4246. message<-c(template,as.list(message));
  4247. .logMessage(this, message);
  4248. return(invisible(message));
  4249. }
  4250. },
  4251. private=FALSE,
  4252. protected=FALSE,
  4253. overwrite=FALSE,
  4254. conflict="warning",
  4255. validators=getOption("R.methodsS3:validators:setMethodS3")
  4256. );
  4257. ##
  4258. ## Method: .UpdateBranchStats
  4259. ##
  4260. setMethodS3(
  4261. ".UpdateBranchStats",
  4262. class="PhyloSim",
  4263. function(
  4264. this,
  4265. event,
  4266. details,
  4267. branch.number,
  4268. ...
  4269. ){
  4270. if(details$type == "substitution"){
  4271. if(details$accepted) {
  4272. if(is.null(this$.branch.stats[[as.character(branch.number)]]$substitution)){
  4273. this$.branch.stats[[as.character(branch.number)]]$substitution<-1;
  4274. } else {
  4275. this$.branch.stats[[as.character(branch.number)]]$substitution<-(this$.branch.stats[[as.character(branch.number)]]$substitution + 1);
  4276. }
  4277. name<-event$name;
  4278. if(is.null(this$.branch.stats[[as.character(branch.number)]][[name]])){
  4279. this$.branch.stats[[as.character(branch.number)]][[name]]<-1;
  4280. }
  4281. else {
  4282. this$.branch.stats[[as.character(branch.number)]][[name]]<-(this$.branch.stats[[as.character(branch.number)]][[name]] + 1);
  4283. }
  4284. }
  4285. # Special stuff for the GY94 codon model:
  4286. if(is.GY94(event$.process)){
  4287. # Increment synonymous counter:
  4288. if(event$.type == "synonymous"){
  4289. if(is.null(this$.branch.stats[[as.character(branch.number)]][["nr.syn.subst"]])){
  4290. # First event of this type on this branch, initialize the list element to 1.
  4291. this$.branch.stats[[as.character(branch.number)]][["nr.syn.subst"]]<-1;
  4292. }
  4293. else {
  4294. this$.branch.stats[[as.character(branch.number)]][["nr.syn.subst"]]<-(this$.branch.stats[[as.character(branch.number)]][["nr.syn.subst"]] + 1);
  4295. }
  4296. }
  4297. # Increment non-synonymous counter:
  4298. else if(event$.type == "non-synonymous"){
  4299. if(is.null(this$.branch.stats[[as.character(branch.number)]][["nr.nsyn.subst"]])){
  4300. # First event of this type on this branch, initialize the list element to 1.
  4301. this$.branch.stats[[as.character(branch.number)]][["nr.nsyn.subst"]]<-1;
  4302. }
  4303. else {
  4304. this$.branch.stats[[as.character(branch.number)]][["nr.nsyn.subst"]]<-(this$.branch.stats[[as.character(branch.number)]][["nr.nsyn.subst"]] + 1);
  4305. }
  4306. } else {
  4307. throw("The event generated by the GY94 has no type!\n");
  4308. }
  4309. }
  4310. }
  4311. else if(details$type == "deletion"){
  4312. if(is.null(this$.branch.stats[[as.character(branch.number)]]$deletion)){
  4313. this$.branch.stats[[as.character(branch.number)]]$deletion<-1;
  4314. }
  4315. else {
  4316. this$.branch.stats[[as.character(branch.number)]]$deletion<-(this$.branch.stats[[as.character(branch.number)]]$deletion + 1);
  4317. }
  4318. }
  4319. else if(details$type == "insertion"){
  4320. if(is.null(this$.branch.stats[[as.character(branch.number)]]$insertion)){
  4321. this$.branch.stats[[as.character(branch.number)]]$insertion<-1;
  4322. }
  4323. else {
  4324. this$.branch.stats[[as.character(branch.number)]]$insertion<-(this$.branch.stats[[as.character(branch.number)]]$insertion + 1);
  4325. }
  4326. }
  4327. else {
  4328. throw("Invalid event type!\n");
  4329. }
  4330. },
  4331. private=TRUE,
  4332. protected=FALSE,
  4333. overwrite=FALSE,
  4334. conflict="warning",
  4335. validators=getOption("R.methodsS3:validators:setMethodS3")
  4336. );
  4337. ##
  4338. ## Method: getBranchEvents
  4339. ##
  4340. ###########################################################################/**
  4341. #
  4342. # @RdocMethod getBranchEvents
  4343. #
  4344. # @title "Get the list of events having per-branch statistics recorded"
  4345. #
  4346. # \description{
  4347. # @get "title".
  4348. #
  4349. # During simulation the number of events performed on every branch is recorded. The recorded events can be "basic"
  4350. # events, like "insertion", "deletion" and "A->T" or events which are sums of basic events, like "substituion". The
  4351. # \code{getBranchEvents} method returns a character vector with the names of the events having per-branch
  4352. # statistics recorded. The method should be called after the simulation is finished.
  4353. #
  4354. # The per-branch statistics can be exported as phylo objects by using the \code{exportStatTree} method.
  4355. # The branch lengths of the exported phylo objects are set to the value of the respective per-branch event count.
  4356. # }
  4357. #
  4358. # @synopsis
  4359. #
  4360. # \arguments{
  4361. # \item{this}{A PhyloSim object.}
  4362. # \item{...}{Not used.}
  4363. # }
  4364. #
  4365. # \value{
  4366. # A character vector.
  4367. # }
  4368. #
  4369. # \examples{
  4370. # # Create a PhyloSim object.
  4371. # # Provide the phylo object
  4372. # # and the root sequence.
  4373. #
  4374. # # NOTE: this will be a little bit slow
  4375. # sim<-PhyloSim(
  4376. # phylo=rcoal(3),
  4377. # root.seq=CodonSequence(
  4378. # string="ATGATTATT",
  4379. # processes=list(list(GY94(kappa=2,omega.default=0.5))))
  4380. # );
  4381. # # make the tree longer to have more events
  4382. # scaleTree(sim,5)
  4383. # # plot the tree
  4384. # plot(sim)
  4385. # # run simulation
  4386. # Simulate(sim)
  4387. # # get the list of recorded per-branch event counts
  4388. # getBranchEvents(sim)
  4389. # # export the number of subtitions as a phylo object
  4390. # subst<-exportStatTree(sim,"substitution")
  4391. # # plot the exported phylo object
  4392. # plot(subst)
  4393. # #export the number of synonymous substitutions as a phylo object
  4394. # subst<-exportStatTree(sim,"nr.syn.subst")
  4395. # # plot the exported phylo object
  4396. # plot(subst)
  4397. # }
  4398. #
  4399. # @author
  4400. #
  4401. # \seealso{
  4402. # @seeclass
  4403. # }
  4404. #
  4405. #*/###########################################################################
  4406. setMethodS3(
  4407. "getBranchEvents",
  4408. class="PhyloSim",
  4409. function(
  4410. this,
  4411. ...
  4412. ){
  4413. tmp<-character();
  4414. for(branch in this$.branch.stats){
  4415. tmp<-c(tmp,names(branch));
  4416. }
  4417. return(unique(sort(tmp)));
  4418. },
  4419. private=FALSE,
  4420. protected=FALSE,
  4421. overwrite=FALSE,
  4422. conflict="warning",
  4423. validators=getOption("R.methodsS3:validators:setMethodS3")
  4424. );
  4425. ##
  4426. ## Method: setBranchEvents
  4427. ##
  4428. ###########################################################################/**
  4429. #
  4430. # @RdocMethod setBranchEvents
  4431. #
  4432. # @title "Forbidden action: setting the list of events having per-branch statistics recorded"
  4433. #
  4434. # \description{
  4435. # @get "title".
  4436. # }
  4437. #
  4438. # @synopsis
  4439. #
  4440. # \arguments{
  4441. # \item{this}{An object.}
  4442. # \item{value}{Not used.}
  4443. # \item{...}{Not used.}
  4444. # }
  4445. #
  4446. # \value{
  4447. # Throws an error.
  4448. # }
  4449. #
  4450. # @author
  4451. #
  4452. # \seealso{
  4453. # @seeclass
  4454. # }
  4455. #
  4456. #*/###########################################################################
  4457. setMethodS3(
  4458. "setBranchEvents",
  4459. class="PhyloSim",
  4460. function(
  4461. this,
  4462. value,
  4463. ...
  4464. ){
  4465. virtualAssignmentForbidden(this);
  4466. },
  4467. private=FALSE,
  4468. protected=FALSE,
  4469. overwrite=FALSE,
  4470. conflict="warning",
  4471. validators=getOption("R.methodsS3:validators:setMethodS3")
  4472. );
  4473. ##
  4474. ## Method: exportStatTree
  4475. ##
  4476. ###########################################################################/**
  4477. #
  4478. # @RdocMethod exportStatTree
  4479. #
  4480. # @title "Export the per-branch counts of an event as a phylo object"
  4481. #
  4482. # \description{
  4483. # @get "title".
  4484. #
  4485. # During simulation the number of events performed on every branch is recorded. The recorded events can be "basic"
  4486. # events, like "insertion", "deletion" and "A->T" or events which are sums of basic events, like "substituion". The
  4487. # \code{getBranchEvents} method returns a character vector with the names of the events having per-branch
  4488. # statistics recorded. The method should be called after the simulation is finished.
  4489. #
  4490. # The per-branch statistics can be exported as phylo objects by using the \code{exportStatTree} method.
  4491. # The branch lengths of the exported phylo objects are set to the value of the respective per-branch event count.
  4492. # }
  4493. #
  4494. # @synopsis
  4495. #
  4496. # \arguments{
  4497. # \item{this}{A PhyloSim object.}
  4498. # \item{event}{The name of the event as returned by the \code{getBranchEvents} method.}
  4499. # \item{...}{Not used.}
  4500. # }
  4501. #
  4502. # \value{
  4503. # A phylo object.
  4504. # }
  4505. #
  4506. # \examples{
  4507. # # Create a PhyloSim object.
  4508. # # Provide the phylo object
  4509. # # and the root sequence.
  4510. #
  4511. # # NOTE: this will be a little bit slow
  4512. # sim<-PhyloSim(
  4513. # phylo=rcoal(3),
  4514. # root.seq=CodonSequence(
  4515. # string="ATGATTATT",
  4516. # processes=list(list(GY94(kappa=2,omega.default=0.5)))
  4517. # )
  4518. # );
  4519. # # make the tree longer to have more events
  4520. # scaleTree(sim,5)
  4521. # # plot the tree
  4522. # plot(sim)
  4523. # # run simulation
  4524. # Simulate(sim)
  4525. # # get the list of recorded per-branch event counts
  4526. # getBranchEvents(sim)
  4527. # # export the number of substitutions as a phylo object
  4528. # subst<-exportStatTree(sim,"substitution")
  4529. # # plot the exported phylo object
  4530. # plot(subst)
  4531. # #export the number of synonymous substitutions as a phylo object
  4532. # subst<-exportStatTree(sim,"nr.syn.subst")
  4533. # # plot the exported phylo object
  4534. # plot(subst)
  4535. # }
  4536. #
  4537. # @author
  4538. #
  4539. # \seealso{
  4540. # @seeclass
  4541. # }
  4542. #
  4543. #*/###########################################################################
  4544. setMethodS3(
  4545. "exportStatTree",
  4546. class="PhyloSim",
  4547. function(
  4548. this,
  4549. event,
  4550. ...
  4551. ){
  4552. if(!is.matrix(this$.alignment)){
  4553. throw("Simulation is not complete, cannot export statistics!\n");
  4554. }
  4555. else if(missing(event)){
  4556. throw("No event name specified!\n");
  4557. }
  4558. else if(length(intersect(event, this$branchEvents)) != 1 ){
  4559. throw("Invalid event name!");
  4560. }
  4561. else {
  4562. phylo.copy<-this$phylo;
  4563. phylo.copy$edge.length<-.getStatBrlen(this, event);
  4564. return(phylo.copy);
  4565. }
  4566. },
  4567. private=FALSE,
  4568. protected=FALSE,
  4569. overwrite=FALSE,
  4570. conflict="warning",
  4571. validators=getOption("R.methodsS3:validators:setMethodS3")
  4572. );
  4573. ##
  4574. ## Method: .getStatBrlen
  4575. ##
  4576. setMethodS3(
  4577. ".getStatBrlen",
  4578. class="PhyloSim",
  4579. function(
  4580. this,
  4581. event,
  4582. ...
  4583. ){
  4584. tmp<-numeric();
  4585. for(i in dimnames(this$edges)[[1]]){
  4586. if(is.null(this$.branch.stats[[i]][[event]])){
  4587. tmp[[as.numeric(i)]]<-0;
  4588. }
  4589. else {
  4590. tmp[[as.numeric(i)]]<-this$.branch.stats[[i]][[event]];
  4591. }
  4592. }
  4593. return(tmp);
  4594. },
  4595. private=FALSE,
  4596. protected=FALSE,
  4597. overwrite=FALSE,
  4598. conflict="warning",
  4599. validators=getOption("R.methodsS3:validators:setMethodS3")
  4600. );
  4601. ##### Phylo object interface methods #####
  4602. ##
  4603. ## Method: getEdges
  4604. ##
  4605. ###########################################################################/**
  4606. #
  4607. # @RdocMethod getEdges
  4608. #
  4609. # @title "Get the edge matrix from a phylo object aggregated by a PhyloSim object"
  4610. #
  4611. # \description{
  4612. # @get "title".
  4613. #
  4614. # The rows of the edge matrix contain the nodes connected by the edge and the edge length.
  4615. # }
  4616. #
  4617. # @synopsis
  4618. #
  4619. # \arguments{
  4620. # \item{this}{A PhyloSim object.}
  4621. # \item{...}{Not used.}
  4622. # }
  4623. #
  4624. # \value{
  4625. # A matrix.
  4626. # }
  4627. #
  4628. # \examples{
  4629. # # create a PhyloSim object
  4630. # sim<-PhyloSim(phylo=rcoal(5));
  4631. # # get the edge matrix
  4632. # getEdges(sim)
  4633. # # get the edge matrix via virtual field
  4634. # sim$edges
  4635. # }
  4636. #
  4637. # @author
  4638. #
  4639. # \seealso{
  4640. # @seeclass
  4641. # }
  4642. #
  4643. #*/###########################################################################
  4644. setMethodS3(
  4645. "getEdges",
  4646. class="PhyloSim",
  4647. function(
  4648. this,
  4649. ...
  4650. ){
  4651. if(!all(is.na(this$.phylo))){
  4652. if(is.phylo(this$.phylo)){
  4653. if(length(this$.phylo$edge.length) > 2){
  4654. if(attr(this$.phylo, "order") != "cladewise"){
  4655. throw("The order of the phylo object is not cladewise! Someone must have been messing with that!\n");
  4656. }
  4657. }
  4658. tmp<-cbind(this$.phylo$edge,this$.phylo$edge.length);
  4659. colnames(tmp)<-c("from","to","length");
  4660. rownames(tmp)<-1:dim(tmp)[[1]];
  4661. return(tmp);
  4662. }
  4663. else{
  4664. throw("The phylo object is invalid!\n");
  4665. }
  4666. }
  4667. else{
  4668. throw("The phylo object is not set!\n");
  4669. }
  4670. },
  4671. private=FALSE,
  4672. protected=FALSE,
  4673. overwrite=FALSE,
  4674. conflict="warning",
  4675. validators=getOption("R.methodsS3:validators:setMethodS3")
  4676. );
  4677. ##
  4678. ## Method: setEdges
  4679. ##
  4680. ###########################################################################/**
  4681. #
  4682. # @RdocMethod setEdges
  4683. #
  4684. # @title "Forbidden action: setting the edge matrix for a phylo object aggregated by a PhyloSim object"
  4685. #
  4686. # \description{
  4687. # @get "title".
  4688. # }
  4689. #
  4690. # @synopsis
  4691. #
  4692. # \arguments{
  4693. # \item{this}{An object.}
  4694. # \item{value}{Not used.}
  4695. # \item{...}{Not used.}
  4696. # }
  4697. #
  4698. # \value{
  4699. # Throws an error.
  4700. # }
  4701. #
  4702. # @author
  4703. #
  4704. # \seealso{
  4705. # @seeclass
  4706. # }
  4707. #
  4708. #*/###########################################################################
  4709. setMethodS3(
  4710. "setEdges",
  4711. class="PhyloSim",
  4712. function(
  4713. this,
  4714. value,
  4715. ...
  4716. ){
  4717. virtualAssignmentForbidden(this);
  4718. },
  4719. private=FALSE,
  4720. protected=FALSE,
  4721. overwrite=FALSE,
  4722. conflict="warning",
  4723. validators=getOption("R.methodsS3:validators:setMethodS3")
  4724. );
  4725. ##
  4726. ## Method: getNtips
  4727. ##
  4728. ###########################################################################/**
  4729. #
  4730. # @RdocMethod getNtips
  4731. #
  4732. # @title "Get the number of the tips form a phylo object aggregated by a PhyloSim object"
  4733. #
  4734. # \description{
  4735. # @get "title".
  4736. # }
  4737. #
  4738. # @synopsis
  4739. #
  4740. # \arguments{
  4741. # \item{this}{A PhyloSim object}
  4742. # \item{...}{Not used.}
  4743. # }
  4744. #
  4745. # \value{
  4746. # A numeric vector of length one.
  4747. # }
  4748. #
  4749. # \examples{
  4750. # # create a PhyloSim object
  4751. # sim<-PhyloSim(phylo=rcoal(5));
  4752. # # get the number of tips
  4753. # getNtips(sim)
  4754. # # get the number of tips via virtual field
  4755. # sim$ntips
  4756. # }
  4757. #
  4758. # @author
  4759. #
  4760. # \seealso{
  4761. # @seeclass
  4762. # }
  4763. #
  4764. #*/###########################################################################
  4765. setMethodS3(
  4766. "getNtips",
  4767. class="PhyloSim",
  4768. function(
  4769. this,
  4770. ...
  4771. ){
  4772. if(!all(is.na(this$.phylo))){
  4773. if(is.phylo(this$.phylo)){
  4774. return(length(this$.phylo$tip.label));
  4775. }
  4776. else{
  4777. throw("The phylo object is invalid!\n");
  4778. }
  4779. }
  4780. else{
  4781. throw("The phylo object is not set!\n");
  4782. }
  4783. },
  4784. private=FALSE,
  4785. protected=FALSE,
  4786. overwrite=FALSE,
  4787. conflict="warning",
  4788. validators=getOption("R.methodsS3:validators:setMethodS3")
  4789. );
  4790. ##
  4791. ## Method: setNtips
  4792. ##
  4793. ###########################################################################/**
  4794. #
  4795. # @RdocMethod setNtips
  4796. #
  4797. # @title "Forbidden action: setting the number of the tips for a phylo object aggregated by a PhyloSim object"
  4798. #
  4799. # \description{
  4800. # @get "title".
  4801. # }
  4802. #
  4803. # @synopsis
  4804. #
  4805. # \arguments{
  4806. # \item{this}{An object.}
  4807. # \item{value}{Not used.}
  4808. # \item{...}{Not used.}
  4809. # }
  4810. #
  4811. # \value{
  4812. # Throws an error.
  4813. # }
  4814. #
  4815. # @author
  4816. #
  4817. # \seealso{
  4818. # @seeclass
  4819. # }
  4820. #
  4821. #*/###########################################################################
  4822. setMethodS3(
  4823. "setNtips",
  4824. class="PhyloSim",
  4825. function(
  4826. this,
  4827. value,
  4828. ...
  4829. ){
  4830. virtualAssignmentForbidden(this);
  4831. },
  4832. private=FALSE,
  4833. protected=FALSE,
  4834. overwrite=FALSE,
  4835. conflict="warning",
  4836. validators=getOption("R.methodsS3:validators:setMethodS3")
  4837. );
  4838. ##
  4839. ## Method: getTipLabels
  4840. ##
  4841. ###########################################################################/**
  4842. #
  4843. # @RdocMethod getTipLabels
  4844. #
  4845. # @title "Get the tip labels from a phylo object aggregated by a PhyloSim object"
  4846. #
  4847. # \description{
  4848. # @get "title".
  4849. # }
  4850. #
  4851. # @synopsis
  4852. #
  4853. # \arguments{
  4854. # \item{this}{A PhyloSim object.}
  4855. # \item{...}{Not used.}
  4856. # }
  4857. #
  4858. # \value{
  4859. # A matrix containing the tip labels.
  4860. # }
  4861. #
  4862. # \examples{
  4863. # # create a PhyloSim object
  4864. # sim<-PhyloSim(phylo=rcoal(5));
  4865. # # get the tip labels
  4866. # getTipLabels(sim)
  4867. # # get the tip lables via virtual field
  4868. # sim$tipLabels
  4869. # }
  4870. #
  4871. # @author
  4872. #
  4873. # \seealso{
  4874. # @seeclass
  4875. # }
  4876. #
  4877. #*/###########################################################################
  4878. setMethodS3(
  4879. "getTipLabels",
  4880. class="PhyloSim",
  4881. function(
  4882. this,
  4883. ...
  4884. ){
  4885. if(!all(is.na(this$.phylo))){
  4886. if(is.phylo(this$.phylo)){
  4887. tmp<-rbind(this$.phylo$tip.label);
  4888. rownames(tmp)<-c("Labels:");
  4889. colnames(tmp)<-c(1:length(tmp));
  4890. return(tmp);
  4891. }
  4892. else{
  4893. throw("The phylo object is invalid!\n");
  4894. }
  4895. }
  4896. else{
  4897. throw("The phylo object is not set!\n");
  4898. }
  4899. },
  4900. private=FALSE,
  4901. protected=FALSE,
  4902. overwrite=FALSE,
  4903. conflict="warning",
  4904. validators=getOption("R.methodsS3:validators:setMethodS3")
  4905. );
  4906. ##
  4907. ## Method: setTipLabels
  4908. ##
  4909. ###########################################################################/**
  4910. #
  4911. # @RdocMethod setTipLabels
  4912. #
  4913. # @title "Forbidden action: setting the tip labels for a phylo object aggregated by a PhyloSim object"
  4914. #
  4915. # \description{
  4916. # @get "title".
  4917. # }
  4918. #
  4919. # @synopsis
  4920. #
  4921. # \arguments{
  4922. # \item{this}{An object.}
  4923. # \item{value}{Not used.}
  4924. # \item{...}{Not used.}
  4925. # }
  4926. #
  4927. # \value{
  4928. # Throws an error.
  4929. # }
  4930. #
  4931. # @author
  4932. #
  4933. # \seealso{
  4934. # @seeclass
  4935. # }
  4936. #
  4937. #*/###########################################################################
  4938. setMethodS3(
  4939. "setTipLabels",
  4940. class="PhyloSim",
  4941. function(
  4942. this,
  4943. value,
  4944. ...
  4945. ){
  4946. virtualAssignmentForbidden(this);
  4947. },
  4948. private=FALSE,
  4949. protected=FALSE,
  4950. overwrite=FALSE,
  4951. conflict="warning",
  4952. validators=getOption("R.methodsS3:validators:setMethodS3")
  4953. );
  4954. ##
  4955. ## Method: getNodes
  4956. ##
  4957. ###########################################################################/**
  4958. #
  4959. # @RdocMethod getNodes
  4960. #
  4961. # @title "Get the node identifiers from a PhyloSim object"
  4962. #
  4963. # \description{
  4964. # @get "title".
  4965. # }
  4966. #
  4967. # @synopsis
  4968. #
  4969. # \arguments{
  4970. # \item{this}{A PhyloSim object.}
  4971. # \item{...}{Not used.}
  4972. # }
  4973. #
  4974. # \value{
  4975. # A numeric vector.
  4976. # }
  4977. #
  4978. # \examples{
  4979. # # create a PhyloSim object
  4980. # sim<-PhyloSim(phylo=rcoal(5));
  4981. # # get the node IDs
  4982. # getNodes(sim)
  4983. # # get the node IDs via virtual field
  4984. # sim$nodes
  4985. # }
  4986. #
  4987. # @author
  4988. #
  4989. # \seealso{
  4990. # @seeclass
  4991. # }
  4992. #
  4993. #*/###########################################################################
  4994. setMethodS3(
  4995. "getNodes",
  4996. class="PhyloSim",
  4997. function(
  4998. this,
  4999. ...
  5000. ){
  5001. if(!all(is.na(this$.phylo))){
  5002. if(is.phylo(this$.phylo)){
  5003. # This is dumb but safe:
  5004. return(sort(unique(as.vector(this$.phylo$edge))));
  5005. }
  5006. else{
  5007. throw("The phylo object is invalid!\n");
  5008. }
  5009. }
  5010. else{
  5011. throw("The phylo object is not set!\n");
  5012. }
  5013. },
  5014. private=FALSE,
  5015. protected=FALSE,
  5016. overwrite=FALSE,
  5017. conflict="warning",
  5018. validators=getOption("R.methodsS3:validators:setMethodS3")
  5019. );
  5020. ##
  5021. ## Method: getNedges
  5022. ##
  5023. ###########################################################################/**
  5024. #
  5025. # @RdocMethod getNedges
  5026. #
  5027. # @title "Get the number of edges from phylo object aggregated by a PhyloSim object"
  5028. #
  5029. # \description{
  5030. # @get "title".
  5031. # }
  5032. #
  5033. # @synopsis
  5034. #
  5035. # \arguments{
  5036. # \item{this}{A PhyloSim object.}
  5037. # \item{...}{Not used.}
  5038. # }
  5039. #
  5040. # \value{
  5041. # A numeric vector of length one.
  5042. # }
  5043. #
  5044. # \examples{
  5045. # # create a PhyloSim object
  5046. # sim<-PhyloSim(phylo=rcoal(5));
  5047. # # get the number of the edges
  5048. # getNedges(sim)
  5049. # # get the number of the edges via virtual field
  5050. # sim$nedges
  5051. # }
  5052. #
  5053. # @author
  5054. #
  5055. # \seealso{
  5056. # @seeclass
  5057. # }
  5058. #
  5059. #*/###########################################################################
  5060. setMethodS3(
  5061. "getNedges",
  5062. class="PhyloSim",
  5063. function(
  5064. this,
  5065. ...
  5066. ){
  5067. if(!all(is.na(this$.phylo))){
  5068. if(is.phylo(this$.phylo)){
  5069. return(dim(this$.phylo$edge)[[1]]);
  5070. }
  5071. else{
  5072. throw("The phylo object is invalid!\n");
  5073. }
  5074. }
  5075. else{
  5076. throw("The phylo object is not set!\n");
  5077. }
  5078. },
  5079. private=FALSE,
  5080. protected=FALSE,
  5081. overwrite=FALSE,
  5082. conflict="warning",
  5083. validators=getOption("R.methodsS3:validators:setMethodS3")
  5084. );
  5085. ##
  5086. ## Method: setNedges
  5087. ##
  5088. ###########################################################################/**
  5089. #
  5090. # @RdocMethod setNedges
  5091. #
  5092. # @title "Forbidden action: setting the number of edges for phylo object aggregated by a PhyloSim object"
  5093. #
  5094. # \description{
  5095. # @get "title".
  5096. # }
  5097. #
  5098. # @synopsis
  5099. #
  5100. # \arguments{
  5101. # \item{this}{An object.}
  5102. # \item{value}{Not used.}
  5103. # \item{...}{Not used.}
  5104. # }
  5105. #
  5106. # \value{
  5107. # Throws an error.
  5108. # }
  5109. #
  5110. # @author
  5111. #
  5112. # \seealso{
  5113. # @seeclass
  5114. # }
  5115. #
  5116. #*/###########################################################################
  5117. setMethodS3(
  5118. "setNedges",
  5119. class="PhyloSim",
  5120. function(
  5121. this,
  5122. value,
  5123. ...
  5124. ){
  5125. virtualAssignmentForbidden(this);
  5126. },
  5127. private=FALSE,
  5128. protected=FALSE,
  5129. overwrite=FALSE,
  5130. conflict="warning",
  5131. validators=getOption("R.methodsS3:validators:setMethodS3")
  5132. );
  5133. ##
  5134. ## Method: setNodes
  5135. ##
  5136. ###########################################################################/**
  5137. #
  5138. # @RdocMethod setNodes
  5139. #
  5140. # @title "Forbidden action: setting the node identifiers for a PhyloSim object"
  5141. #
  5142. # \description{
  5143. # @get "title".
  5144. # }
  5145. #
  5146. # @synopsis
  5147. #
  5148. # \arguments{
  5149. # \item{this}{An object.}
  5150. # \item{value}{Not used.}
  5151. # \item{...}{Not used.}
  5152. # }
  5153. #
  5154. # \value{
  5155. # Throws an error.
  5156. # }
  5157. #
  5158. # @author
  5159. #
  5160. # \seealso{
  5161. # @seeclass
  5162. # }
  5163. #
  5164. #*/###########################################################################
  5165. setMethodS3(
  5166. "setNodes",
  5167. class="PhyloSim",
  5168. function(
  5169. this,
  5170. value,
  5171. ...
  5172. ){
  5173. virtualAssignmentForbidden(this);
  5174. },
  5175. private=FALSE,
  5176. protected=FALSE,
  5177. overwrite=FALSE,
  5178. conflict="warning",
  5179. validators=getOption("R.methodsS3:validators:setMethodS3")
  5180. );
  5181. ##
  5182. ## Method: getTips
  5183. ##
  5184. ###########################################################################/**
  5185. #
  5186. # @RdocMethod getTips
  5187. #
  5188. # @title "Get the node identifiers of the tip nodes from a PhyloSim object"
  5189. #
  5190. # \description{
  5191. # @get "title".
  5192. # }
  5193. #
  5194. # @synopsis
  5195. #
  5196. # \arguments{
  5197. # \item{this}{A PhyloSim object}
  5198. # \item{...}{Not used.}
  5199. # }
  5200. #
  5201. # \value{
  5202. # A numeric vector.
  5203. # }
  5204. #
  5205. # \examples{
  5206. # # create a PhyloSim object
  5207. # sim<-PhyloSim(phylo=rcoal(5));
  5208. # # get the tip IDs
  5209. # getTips(sim)
  5210. # # get the tip IDs via virtual field
  5211. # sim$tips
  5212. # }
  5213. #
  5214. # @author
  5215. #
  5216. # \seealso{
  5217. # @seeclass
  5218. # }
  5219. #
  5220. #*/###########################################################################
  5221. setMethodS3(
  5222. "getTips",
  5223. class="PhyloSim",
  5224. function(
  5225. this,
  5226. ...
  5227. ){
  5228. if(!all(is.na(this$.phylo))){
  5229. if(is.phylo(this$.phylo)){
  5230. # This is dumb but safe:
  5231. #return(sort(unique(as.vector(this$.phylo$edge))));
  5232. return(1:(getNtips(this)));
  5233. }
  5234. else{
  5235. throw("The phylo object is invalid!\n");
  5236. }
  5237. }
  5238. else{
  5239. throw("The phylo object is not set!\n");
  5240. }
  5241. },
  5242. private=FALSE,
  5243. protected=FALSE,
  5244. overwrite=FALSE,
  5245. conflict="warning",
  5246. validators=getOption("R.methodsS3:validators:setMethodS3")
  5247. );
  5248. ##
  5249. ## Method: setTips
  5250. ##
  5251. ###########################################################################/**
  5252. #
  5253. # @RdocMethod setTips
  5254. #
  5255. # @title "Forbidden action: setting the node identifiers of the tip nodes for a PhyloSim object"
  5256. #
  5257. # \description{
  5258. # @get "title".
  5259. # }
  5260. #
  5261. # @synopsis
  5262. #
  5263. # \arguments{
  5264. # \item{this}{An object.}
  5265. # \item{value}{Not used.}
  5266. # \item{...}{Not used.}
  5267. # }
  5268. #
  5269. # \value{
  5270. # Throws an error.
  5271. # }
  5272. #
  5273. # @author
  5274. #
  5275. # \seealso{
  5276. # @seeclass
  5277. # }
  5278. #
  5279. #*/###########################################################################
  5280. setMethodS3(
  5281. "setTips",
  5282. class="PhyloSim",
  5283. function(
  5284. this,
  5285. value,
  5286. ...
  5287. ){
  5288. virtualAssignmentForbidden(this);
  5289. },
  5290. private=FALSE,
  5291. protected=FALSE,
  5292. overwrite=FALSE,
  5293. conflict="warning",
  5294. validators=getOption("R.methodsS3:validators:setMethodS3")
  5295. );
  5296. ##
  5297. ## Method: getRootNode
  5298. ##
  5299. ###########################################################################/**
  5300. #
  5301. # @RdocMethod getRootNode
  5302. #
  5303. # @title "Get the identifier of the root node from a PhyloSim object"
  5304. #
  5305. # \description{
  5306. # @get "title".
  5307. # }
  5308. #
  5309. # @synopsis
  5310. #
  5311. # \arguments{
  5312. # \item{this}{A PhyloSim object.}
  5313. # \item{...}{Not used.}
  5314. # }
  5315. #
  5316. # \value{
  5317. # A numeric vector of length one.
  5318. # }
  5319. #
  5320. # \examples{
  5321. # # create a PhyloSim object
  5322. # sim<-PhyloSim(phylo=rcoal(5));
  5323. # # get the root node ID
  5324. # getRootNode(sim)
  5325. # # get the root node ID via virtual field
  5326. # sim$rootNode
  5327. # }
  5328. #
  5329. # @author
  5330. #
  5331. # \seealso{
  5332. # @seeclass
  5333. # }
  5334. #
  5335. #*/###########################################################################
  5336. setMethodS3(
  5337. "getRootNode",
  5338. class="PhyloSim",
  5339. function(
  5340. this,
  5341. ...
  5342. ){
  5343. if(!all(is.na(this$.phylo))){
  5344. if(is.phylo(this$.phylo)){
  5345. # Relying on cladewise order:
  5346. return(this$.phylo$edge[1,1]);
  5347. }
  5348. else{
  5349. throw("The phylo object is invalid!\n");
  5350. }
  5351. }
  5352. else{
  5353. throw("The phylo object is not set!\n");
  5354. }
  5355. },
  5356. private=FALSE,
  5357. protected=FALSE,
  5358. overwrite=FALSE,
  5359. conflict="warning",
  5360. validators=getOption("R.methodsS3:validators:setMethodS3")
  5361. );
  5362. ##
  5363. ## Method: setRootNode
  5364. ##
  5365. ###########################################################################/**
  5366. #
  5367. # @RdocMethod setRootNode
  5368. #
  5369. # @title "Forbidden action: setting the identifier of the root node for a PhyloSim object"
  5370. #
  5371. # \description{
  5372. # @get "title".
  5373. # }
  5374. #
  5375. # @synopsis
  5376. #
  5377. # \arguments{
  5378. # \item{this}{An object.}
  5379. # \item{value}{Not used.}
  5380. # \item{...}{Not used.}
  5381. # }
  5382. #
  5383. # \value{
  5384. # Throws an error.
  5385. # }
  5386. #
  5387. # @author
  5388. #
  5389. # \seealso{
  5390. # @seeclass
  5391. # }
  5392. #
  5393. #*/###########################################################################
  5394. setMethodS3(
  5395. "setRootNode",
  5396. class="PhyloSim",
  5397. function(
  5398. this,
  5399. value,
  5400. ...
  5401. ){
  5402. virtualAssignmentForbidden(this);
  5403. },
  5404. private=FALSE,
  5405. protected=FALSE,
  5406. overwrite=FALSE,
  5407. conflict="warning",
  5408. validators=getOption("R.methodsS3:validators:setMethodS3")
  5409. );
  5410. ##
  5411. ## Method: is.tip
  5412. ##
  5413. ###########################################################################/**
  5414. #
  5415. # @RdocMethod is.tip
  5416. #
  5417. # @title "Check if a node is a tip"
  5418. #
  5419. # \description{
  5420. # @get "title".
  5421. # }
  5422. #
  5423. # @synopsis
  5424. #
  5425. # \arguments{
  5426. # \item{this}{A PhyloSim object.}
  5427. # \item{node}{A node identifier (integer vector of length one).}
  5428. # \item{...}{Not used.}
  5429. # }
  5430. #
  5431. # \value{
  5432. # TRUE or FALSE
  5433. # }
  5434. #
  5435. # \examples{
  5436. # # create a PhyloSim object
  5437. # sim<-PhyloSim(phylo=rcoal(5));
  5438. # # check if node 4 is a tip
  5439. # is.tip(sim,4)
  5440. # # check if node 6 is a tip
  5441. # is.tip(sim,6)
  5442. # }
  5443. #
  5444. # @author
  5445. #
  5446. # \seealso{
  5447. # @seeclass
  5448. # }
  5449. #
  5450. #*/###########################################################################
  5451. setMethodS3(
  5452. "is.tip",
  5453. class="PhyloSim",
  5454. function(
  5455. this,
  5456. node=NA,
  5457. ...
  5458. ){
  5459. if(missing(node)){
  5460. throw("No node number specified!\n");
  5461. }
  5462. else if(!is.numeric(node)){
  5463. throw("The node number must be numeric!\n");
  5464. }
  5465. else {
  5466. return(round(node) <= this$ntips);
  5467. }
  5468. },
  5469. private=FALSE,
  5470. protected=FALSE,
  5471. overwrite=FALSE,
  5472. conflict="warning",
  5473. validators=getOption("R.methodsS3:validators:setMethodS3")
  5474. );
  5475. ##
  5476. ## Method: getEdge
  5477. ##
  5478. ###########################################################################/**
  5479. #
  5480. # @RdocMethod getEdge
  5481. #
  5482. # @title "Get and edge from the edge matrix"
  5483. #
  5484. # \description{
  5485. # @get "title".
  5486. # }
  5487. #
  5488. # @synopsis
  5489. #
  5490. # \arguments{
  5491. # \item{this}{A PhyloSim object.}
  5492. # \item{number}{The edge number.}
  5493. # \item{...}{Not used.}
  5494. # }
  5495. #
  5496. # \value{
  5497. # The edge as a matrix with a single row.
  5498. # }
  5499. #
  5500. # \examples{
  5501. # # create a PhyloSim object
  5502. # sim<-PhyloSim(phylo=rcoal(5));
  5503. # # get edge number 3
  5504. # getEdge(sim,3)
  5505. # }
  5506. #
  5507. # @author
  5508. #
  5509. # \seealso{
  5510. # @seeclass
  5511. # }
  5512. #
  5513. #*/###########################################################################
  5514. setMethodS3(
  5515. "getEdge",
  5516. class="PhyloSim",
  5517. function(
  5518. this,
  5519. number=NA,
  5520. ...
  5521. ){
  5522. if(missing(number)){
  5523. throw("No object provided!\n");
  5524. }
  5525. else if(!is.numeric(number)){
  5526. throw("The edge number must be numeric!\n");
  5527. }
  5528. else {
  5529. number<-round(number);
  5530. tmp<-rbind(c(this$.phylo$edge[number,],this$.phylo$edge.length[number]));
  5531. colnames(tmp)<-c("from","to","length");
  5532. rownames(tmp)<-c("Edge:");
  5533. return(tmp);
  5534. }
  5535. },
  5536. private=FALSE,
  5537. protected=FALSE,
  5538. overwrite=FALSE,
  5539. conflict="warning",
  5540. validators=getOption("R.methodsS3:validators:setMethodS3")
  5541. );
  5542. ##
  5543. ## Method: getTreeLength
  5544. ##
  5545. ###########################################################################/**
  5546. #
  5547. # @RdocMethod getTreeLength
  5548. #
  5549. # @title "Get the tree length from a PhyloSim object"
  5550. #
  5551. # \description{
  5552. # @get "title".
  5553. #
  5554. # This method retruns the sum of the edge lengths stored in the aggregated phylo object.
  5555. # }
  5556. #
  5557. # @synopsis
  5558. #
  5559. # \arguments{
  5560. # \item{this}{A PhyloSim object.}
  5561. # \item{...}{Not used.}
  5562. # }
  5563. #
  5564. # \value{
  5565. # A numeric vector of length one.
  5566. # }
  5567. #
  5568. # \examples{
  5569. # # create a PhyloSim object
  5570. # sim<-PhyloSim(phylo=rcoal(5));
  5571. # # get the tree length
  5572. # getTreeLength(sim)
  5573. # # get tree length via virtual field
  5574. # sim$treeLength
  5575. # }
  5576. #
  5577. # @author
  5578. #
  5579. # \seealso{
  5580. # @seeclass
  5581. # }
  5582. #
  5583. #*/###########################################################################
  5584. setMethodS3(
  5585. "getTreeLength",
  5586. class="PhyloSim",
  5587. function(
  5588. this,
  5589. ...
  5590. ){
  5591. if(!all(is.na(this$.phylo))){
  5592. if(is.phylo(this$.phylo)){
  5593. return(sum(this$.phylo$edge.length));
  5594. }
  5595. else{
  5596. throw("The phylo object is invalid!\n");
  5597. }
  5598. }
  5599. else{
  5600. throw("The phylo object is not set!\n");
  5601. }
  5602. },
  5603. private=FALSE,
  5604. protected=FALSE,
  5605. overwrite=FALSE,
  5606. conflict="warning",
  5607. validators=getOption("R.methodsS3:validators:setMethodS3")
  5608. );
  5609. ##
  5610. ## Method: setTreeLength
  5611. ##
  5612. ###########################################################################/**
  5613. #
  5614. # @RdocMethod setTreeLength
  5615. #
  5616. # @title "Forbidden action: setting the tree length for a PhyloSim object"
  5617. #
  5618. # \description{
  5619. # @get "title".
  5620. # }
  5621. #
  5622. # @synopsis
  5623. #
  5624. # \arguments{
  5625. # \item{this}{An object.}
  5626. # \item{value}{Not used.}
  5627. # \item{...}{Not used.}
  5628. # }
  5629. #
  5630. # \value{
  5631. # Throws an error.
  5632. # }
  5633. #
  5634. # @author
  5635. #
  5636. # \seealso{
  5637. # @seeclass
  5638. # }
  5639. #
  5640. #*/###########################################################################
  5641. setMethodS3(
  5642. "setTreeLength",
  5643. class="PhyloSim",
  5644. function(
  5645. this,
  5646. value,
  5647. ...
  5648. ){
  5649. virtualAssignmentForbidden(this);
  5650. },
  5651. private=FALSE,
  5652. protected=FALSE,
  5653. overwrite=FALSE,
  5654. conflict="warning",
  5655. validators=getOption("R.methodsS3:validators:setMethodS3")
  5656. );
  5657. ##
  5658. ## Method: scaleTree
  5659. ##
  5660. ###########################################################################/**
  5661. #
  5662. # @RdocMethod scaleTree
  5663. #
  5664. # @title "Scale the branch lengths of a phylo object aggragted by a PhyloSim object"
  5665. #
  5666. # \description{
  5667. # @get "title".
  5668. # This method multiples all the edge lengths by the specified factor.
  5669. # }
  5670. #
  5671. # @synopsis
  5672. #
  5673. # \arguments{
  5674. # \item{this}{A PhyloSim object.}
  5675. # \item{factor}{A numeric vector of length one.}
  5676. # \item{...}{Not used.}
  5677. # }
  5678. #
  5679. # \value{
  5680. # The PhyloSim object (invisible).
  5681. # }
  5682. #
  5683. # \examples{
  5684. # # create a PhyloSim object
  5685. # sim<-PhyloSim(phylo=rcoal(5));
  5686. # # get the tree length
  5687. # sim$treeLength
  5688. # # scale tree
  5689. # scaleTree(sim,10)
  5690. # # get the scaled tree length
  5691. # sim$treeLength
  5692. # }
  5693. #
  5694. # @author
  5695. #
  5696. # \seealso{
  5697. # @seeclass
  5698. # }
  5699. #
  5700. #*/###########################################################################
  5701. setMethodS3(
  5702. "scaleTree",
  5703. class="PhyloSim",
  5704. function(
  5705. this,
  5706. factor,
  5707. ...
  5708. ){
  5709. if(missing(factor)){
  5710. throw("No branch length scaling factor specified!\n");
  5711. } else if((!is.numeric(factor)) | (length(factor) != 1)){
  5712. throw("The scaling factor must be a numeric vector of length 1!\n");
  5713. } else if(!is.phylo(this$.phylo)){
  5714. throw("The phylo object is not set or it is invalid!\n");
  5715. } else {
  5716. this$.phylo$edge.length<-(this$.phylo$edge.length * factor);
  5717. return(invisible(this));
  5718. }
  5719. },
  5720. private=FALSE,
  5721. protected=FALSE,
  5722. overwrite=FALSE,
  5723. conflict="warning",
  5724. validators=getOption("R.methodsS3:validators:setMethodS3")
  5725. );
  5726. ###########################################################################/**
  5727. #
  5728. # @RdocMethod readAlignment
  5729. #
  5730. # @title "Read alignment from file"
  5731. #
  5732. # \description{
  5733. # @get "title".
  5734. #
  5735. # This method reads an alignment by using the \code{read.dna} function from the \code{\link{ape}}
  5736. # package and stores in the \code{PhyloSim} object. If a tree is already attached to the \code{PhyloSim}
  5737. # object, the alignment must at least contain the sequences corresponding to tip nodes (but it
  5738. # may also contain additional ancestral sequences).
  5739. # }
  5740. #
  5741. # @synopsis
  5742. #
  5743. # \arguments{
  5744. # \item{this}{A PhyloSim object.}
  5745. # \item{file}{A file name specified by either a variable of mode character, or a double-quoted string.}
  5746. # \item{format}{a character string specifying the format of the DNA sequences. Four choices are possible: "interleaved", "sequential", "clustal", or "fasta", or any unambiguous abbreviation of these.}
  5747. # \item{...}{Not used.}
  5748. # }
  5749. #
  5750. # \value{
  5751. # The PhyloSim object (invisible).
  5752. # }
  5753. #
  5754. # \examples{
  5755. # # get a safe file name
  5756. # fname<-paste("PhyloSim_dummy_fas_",Sys.getpid(),sep="")
  5757. # # write out a fasta alignment
  5758. # cat("> t3\nGTCTTT-CG-\n",file=fname);
  5759. # cat("> t4\nG--TC-TCGG\n",file=fname,append=TRUE);
  5760. # cat("> t2\nG--TC-TCGG\n",file=fname,append=TRUE);
  5761. # cat("> t1\nGTC-G-TCGG",file=fname,append=TRUE);
  5762. # # construct a PhyloSim object,
  5763. # # set the phylo object
  5764. # sim<-PhyloSim(phylo=rcoal(4))
  5765. # # read the alignment
  5766. # readAlignment(sim,fname)
  5767. # # remove alignment file
  5768. # unlink(fname)
  5769. # # plot the tree & alignment
  5770. # plot(sim)
  5771. # }
  5772. #
  5773. # @author
  5774. #
  5775. # \seealso{
  5776. # @seeclass
  5777. # }
  5778. #
  5779. #*/###########################################################################
  5780. setMethodS3(
  5781. "readAlignment",
  5782. class="PhyloSim",
  5783. function(
  5784. this,
  5785. file,
  5786. format="fasta",
  5787. ...
  5788. ){
  5789. aln<-toupper(read.dna(file=file,format=format,as.matrix=TRUE,as.character=TRUE));
  5790. aln.names<-dimnames(aln)[[1]];
  5791. if (!all(is.na(this$.phylo))) {
  5792. tip.labels<-this$tipLabels;
  5793. length.overlap <- length(intersect(tip.labels,aln.names))
  5794. if(length.overlap != length(tip.labels)){
  5795. throw("The alignment must contain all sequences corresponding to tip nodes!");
  5796. }
  5797. if (length(aln.names) > length(tip.labels)) {
  5798. warning("Alignment has more sequences than the tree's leaf count -- either it contains ancestral sequences or something is wrong!")
  5799. }
  5800. }
  5801. this$.alignment<-aln;
  5802. return(invisible(this));
  5803. },
  5804. private=FALSE,
  5805. protected=FALSE,
  5806. overwrite=FALSE,
  5807. conflict="warning",
  5808. validators=getOption("R.methodsS3:validators:setMethodS3")
  5809. );
  5810. ##
  5811. ## Method: getAlignmentLength
  5812. ##
  5813. ###########################################################################/**
  5814. #
  5815. # @RdocMethod getAlignmentLength
  5816. #
  5817. # @title "Get the alignment length from a PhyloSim object"
  5818. #
  5819. # \description{
  5820. # @get "title".
  5821. #
  5822. # This method retruns the number of columns in the alignment stored in the PhyloSim object.
  5823. # }
  5824. #
  5825. # @synopsis
  5826. #
  5827. # \arguments{
  5828. # \item{this}{A PhyloSim object.}
  5829. # \item{...}{Not used.}
  5830. # }
  5831. #
  5832. # \value{
  5833. # A numeric vector of length one.
  5834. # }
  5835. #
  5836. # \examples{
  5837. # # create a PhyloSim object and run a simulation:
  5838. # sim<-Simulate(
  5839. # PhyloSim(phy=rcoal(3),
  5840. # root=NucleotideSequence(string="ATGC", proc=list(list(JC69())) ) )
  5841. # )
  5842. # # get the alignment length
  5843. # getAlignmentLength(sim)
  5844. # }
  5845. #
  5846. # @author
  5847. #
  5848. # \seealso{
  5849. # @seeclass
  5850. # }
  5851. #
  5852. #*/###########################################################################
  5853. setMethodS3(
  5854. "getAlignmentLength",
  5855. class="PhyloSim",
  5856. function(
  5857. this,
  5858. ...
  5859. ){
  5860. if(!all(is.na(this$.alignment))){
  5861. return(dim(this$.alignment)[2]);
  5862. }
  5863. else{
  5864. throw("The alignment object is not set!\n");
  5865. }
  5866. },
  5867. private=FALSE,
  5868. protected=FALSE,
  5869. overwrite=FALSE,
  5870. conflict="warning",
  5871. validators=getOption("R.methodsS3:validators:setMethodS3")
  5872. );
  5873. ###########################################################################/**
  5874. #
  5875. # @RdocMethod readTree
  5876. #
  5877. # @title "Read tree from file"
  5878. #
  5879. # \description{
  5880. # @get "title".
  5881. #
  5882. # This method reads a tree by using the \code{read.tree} function from the \code{\link{ape}}
  5883. # package and stores in the \code{PhyloSim} object. If an alignment is already attached
  5884. # to the \code{PhyloSim} object, it must contain all sequences corresponding to tip nodes.
  5885. # }
  5886. #
  5887. # @synopsis
  5888. #
  5889. # \arguments{
  5890. # \item{this}{A PhyloSim object.}
  5891. # \item{file}{A file name specified by either a variable of mode character, or a double-quoted string.}
  5892. # \item{...}{Not used.}
  5893. # }
  5894. #
  5895. # \value{
  5896. # The PhyloSim object (invisible).
  5897. # }
  5898. #
  5899. # \examples{
  5900. # # get a safe file name
  5901. # fname<-paste("PhyloSim_dummy_fas_",Sys.getpid(),sep="")
  5902. # # write out a fasta alignment
  5903. # cat("(a,(b,c));",file=fname);
  5904. # # construct a PhyloSim object:
  5905. # sim<-PhyloSim()
  5906. # # read the alignment
  5907. # readTree(sim,fname)
  5908. # # remove alignment file
  5909. # unlink(fname)
  5910. # # plot the tree
  5911. # plot(sim)
  5912. # }
  5913. #
  5914. # @author
  5915. #
  5916. # \seealso{
  5917. # @seeclass
  5918. # }
  5919. #
  5920. #*/###########################################################################
  5921. setMethodS3(
  5922. "readTree",
  5923. class="PhyloSim",
  5924. function(
  5925. this,
  5926. file,
  5927. ...
  5928. ){
  5929. tree <- read.tree(file)
  5930. if (!any(is.na(this$.alignment))) {
  5931. # Check for overlap between leaves and seqs.
  5932. aln <- this$.alignment;
  5933. aln.names <- dimnames(aln)[[1]];
  5934. tip.labels <- tree$tip.label;
  5935. aln.tree.overlap <- length(intersect(tip.labels,aln.names))
  5936. if(aln.tree.overlap != length(tip.labels)){
  5937. throw("The alignment must contain all sequences corresponding to tip nodes!");
  5938. }
  5939. if (length(aln.names) > length(tip.labels)) {
  5940. warning("Alignment has more sequences than the tree's leaf count -- either it contains ancestral sequences or something is wrong!")
  5941. }
  5942. }
  5943. this$.phylo <- tree
  5944. return(invisible(this));
  5945. },
  5946. private=FALSE,
  5947. protected=FALSE,
  5948. overwrite=FALSE,
  5949. conflict="warning",
  5950. validators=getOption("R.methodsS3:validators:setMethodS3")
  5951. );
  5952. ###########################################################################/**
  5953. #
  5954. # @RdocMethod Undocumented
  5955. # \alias{Undocumented}
  5956. # \alias{newMatrix}
  5957. # \alias{setEquDist.CodonSubst}
  5958. # \alias{BrownianPath}
  5959. # \alias{buildFromPAML}
  5960. # \alias{checkConsistency}
  5961. # \alias{clearStates}
  5962. # \alias{areSynonymous}
  5963. # \alias{attachHookToNode}
  5964. # \alias{attachProcess}
  5965. # \alias{attachSeqToNode}
  5966. # \alias{copySubSequence}
  5967. # \alias{Debug}
  5968. # \alias{deleteSubSequence}
  5969. # \alias{detachHookFromNode}
  5970. # \alias{detachProcess}
  5971. # \alias{detachSeqFromNode}
  5972. # \alias{enableVirtual}
  5973. # \alias{exportStatTree}
  5974. # \alias{flagTotalRate}
  5975. # \alias{generateInsert}
  5976. # \alias{getAcceptBy}
  5977. # \alias{getAcceptWin}
  5978. # \alias{getAlignment}
  5979. # \alias{getAlphabet}
  5980. # \alias{getAlphabets}
  5981. # \alias{getAlphabet}
  5982. # \alias{getAncestral}
  5983. # \alias{getAncestral}
  5984. # \alias{getBaseFreqs}
  5985. # \alias{getBigRate}
  5986. # \alias{getBranchEvents}
  5987. # \alias{getCodonFreqs}
  5988. # \alias{getComments}
  5989. # \alias{getCumulativeRates}
  5990. # \alias{getCumulativeRatesFromRange}
  5991. # \alias{getDeletionTolerance}
  5992. # \alias{getDist}
  5993. # \alias{getEdge}
  5994. # \alias{getEdges}
  5995. # \alias{getEquDist}
  5996. # \alias{getEventRate}
  5997. # \alias{getEventRateAtSite}
  5998. # \alias{getEvents}
  5999. # \alias{getEventsAtSite}
  6000. # \alias{getGenerateBy}
  6001. # \alias{getHandler}
  6002. # \alias{getId}
  6003. # \alias{getInsertHook}
  6004. # \alias{getInsertionTolerance}
  6005. # \alias{getInsertionTolerance}
  6006. # \alias{getKappa}
  6007. # \alias{getLength}
  6008. # \alias{getLengthParam1}
  6009. # \alias{getLengthParam2}
  6010. # \alias{getLogFile}
  6011. # \alias{getLogLevel}
  6012. # \alias{getMatrix}
  6013. # \alias{getMaxLength}
  6014. # \alias{getMethodsList}
  6015. # \alias{getNedges}
  6016. # \alias{getNodes}
  6017. # \alias{getNtips}
  6018. # \alias{getOmegas}
  6019. # \alias{getParameterAtSite}
  6020. # \alias{getParameterAtSites}
  6021. # \alias{getPhylo}
  6022. # \alias{getProbs}
  6023. # \alias{getProcess}
  6024. # \alias{getProcesses}
  6025. # \alias{getProposeBy}
  6026. # \alias{getQMatrix}
  6027. # \alias{getRate}
  6028. # \alias{getRateList}
  6029. # \alias{getRateMultipliers}
  6030. # \alias{getRateParam}
  6031. # \alias{getRateParamList}
  6032. # \alias{getRootNode}
  6033. # \alias{getRootSeq}
  6034. # \alias{getScale}
  6035. # \alias{getScaledMatrix}
  6036. # \alias{getSeqFromNode}
  6037. # \alias{getSequence}
  6038. # \alias{getSequences}
  6039. # \alias{getSite}
  6040. # \alias{getSites}
  6041. # \alias{getSiteSpecificParamIds}
  6042. # \alias{getSiteSpecificParamList}
  6043. # \alias{getSize}
  6044. # \alias{getSizes}
  6045. # \alias{getState}
  6046. # \alias{getStates}
  6047. # \alias{getString}
  6048. # \alias{getSymbolFreqs}
  6049. # \alias{getSymbolLength}
  6050. # \alias{getSymbols}
  6051. # \alias{getTableId}
  6052. # \alias{getTargetState}
  6053. # \alias{getTemplateSeq}
  6054. # \alias{getTheta}
  6055. # \alias{getTipLabels}
  6056. # \alias{getTips}
  6057. # \alias{getToleranceMargin}
  6058. # \alias{getTotalRate}
  6059. # \alias{getTotalRates}
  6060. # \alias{getTotalRatesFromRange}
  6061. # \alias{getTransTable}
  6062. # \alias{getTreeLength}
  6063. # \alias{getType}
  6064. # \alias{getUniqueAlphabets}
  6065. # \alias{getUniqueProcesses}
  6066. # \alias{getWriteProtected}
  6067. # \alias{globalConsistencyCheck}
  6068. # \alias{hasSiteSpecificParameter}
  6069. # \alias{hasSymbols}
  6070. # \alias{hasUndefinedRate}
  6071. # \alias{insertSequence}
  6072. # \alias{intersect}
  6073. # \alias{list}
  6074. # \alias{isAttached}
  6075. # \alias{isEmpty}
  6076. # \alias{is}
  6077. # \alias{default}
  6078. # \alias{isStartCodon}
  6079. # \alias{isStopCodon}
  6080. # \alias{is}
  6081. # \alias{tip}
  6082. # \alias{Log}
  6083. # \alias{my}
  6084. # \alias{all}
  6085. # \alias{equal}
  6086. # \alias{newAAMatrix}
  6087. # \alias{omegaHist}
  6088. # \alias{omegaVarM0}
  6089. # \alias{omegaVarM1}
  6090. # \alias{omegaVarM10Cont}
  6091. # \alias{omegaVarM10Cont}
  6092. # \alias{omegaVarM2}
  6093. # \alias{omegaVarM3}
  6094. # \alias{omegaVarM4}
  6095. # \alias{Perform}
  6096. # \alias{plotParametersAtSites}
  6097. # \alias{plot}
  6098. # \alias{plusGamma}
  6099. # \alias{plusInvGamma}
  6100. # \alias{proposeLength}
  6101. # \alias{rescaleQMatrix}
  6102. # \alias{sampleState}
  6103. # \alias{sampleStates}
  6104. # \alias{saveAlignment}
  6105. # \alias{Scale}
  6106. # \alias{scaleTree}
  6107. # \alias{setAcceptBy}
  6108. # \alias{setAcceptWin}
  6109. # \alias{setAlignment}
  6110. # \alias{setAlphabet}
  6111. # \alias{setAlphabets}
  6112. # \alias{setAncestral}
  6113. # \alias{setBaseFreqs}
  6114. # \alias{setBigRate}
  6115. # \alias{setBranchEvents}
  6116. # \alias{setCodonFreqs}
  6117. # \alias{setCodonFreqs}
  6118. # \alias{setComments}
  6119. # \alias{setCumulativeRates}
  6120. # \alias{setDeletionTolerance}
  6121. # \alias{setDist}
  6122. # \alias{setEdges}
  6123. # \alias{setEquDist}
  6124. # \alias{setEquDist}
  6125. # \alias{setEvents}
  6126. # \alias{setGenerateBy}
  6127. # \alias{setHandler}
  6128. # \alias{setId}
  6129. # \alias{setInsertHook}
  6130. # \alias{setInsertionTolerance}
  6131. # \alias{setInsertionTolerance}
  6132. # \alias{setKappa}
  6133. # \alias{setKappa}
  6134. # \alias{setLength}
  6135. # \alias{setLengthParam1}
  6136. # \alias{setLengthParam2}
  6137. # \alias{setLogFile}
  6138. # \alias{setLogLevel}
  6139. # \alias{setMatrix}
  6140. # \alias{setMaxLength}
  6141. # \alias{setMethodsList}
  6142. # \alias{setName}
  6143. # \alias{setNedges}
  6144. # \alias{setNodes}
  6145. # \alias{setNtips}
  6146. # \alias{setOmegas}
  6147. # \alias{setParameterAtSite}
  6148. # \alias{setParameterAtSites}
  6149. # \alias{setPhylo}
  6150. # \alias{setPosition}
  6151. # \alias{setProbs}
  6152. # \alias{setProcess}
  6153. # \alias{setProcesses}
  6154. # \alias{setProposeBy}
  6155. # \alias{setQMatrix}
  6156. # \alias{setRate}
  6157. # \alias{setRateList}
  6158. # \alias{setRateMultipliers}
  6159. # \alias{setRateParam}
  6160. # \alias{setRateParamList}
  6161. # \alias{setRootNode}
  6162. # \alias{setRootSeq}
  6163. # \alias{setScale}
  6164. # \alias{setScaledMatrix}
  6165. # \alias{setSequence}
  6166. # \alias{setSequences}
  6167. # \alias{setSite}
  6168. # \alias{setSiteSpecificParamIds}
  6169. # \alias{setSiteSpecificParamList}
  6170. # \alias{setSize}
  6171. # \alias{setSizes}
  6172. # \alias{setState}
  6173. # \alias{setStates}
  6174. # \alias{setString}
  6175. # \alias{setSymbolLength}
  6176. # \alias{setSymbols}
  6177. # \alias{setTableId}
  6178. # \alias{setTargetState}
  6179. # \alias{setTemplateSeq}
  6180. # \alias{setTheta}
  6181. # \alias{setTipLabels}
  6182. # \alias{setTips}
  6183. # \alias{setToleranceMargin}
  6184. # \alias{setTotalRate}
  6185. # \alias{setTotalRates}
  6186. # \alias{setTransTable}
  6187. # \alias{setTreeLength}
  6188. # \alias{setType}
  6189. # \alias{setUniqueAlphabets}
  6190. # \alias{setUniqueProcesses}
  6191. # \alias{setWriteProtected}
  6192. # \alias{Simulate}
  6193. # \alias{Translate}
  6194. # \alias{translateCodon}
  6195. # \alias{virtualAssignmentForbidden}
  6196. # \alias{intersect.list}
  6197. # \alias{is.tip}
  6198. # \alias{my.all.equal}
  6199. # \alias{plot.PSRoot}
  6200. # \alias{revComp}
  6201. # \alias{readAlignment}
  6202. # \alias{readTree}
  6203. # \alias{getOmegaScalingFactor}
  6204. # \alias{saveLoadReference}
  6205. # \alias{getAlignmentLength}
  6206. #
  6207. # @title "Undocumented object (PhyloSim package)"
  6208. #
  6209. # \description{
  6210. # @get "title".
  6211. #
  6212. # See the corresponding specific methods if applicable.
  6213. # }
  6214. #
  6215. # @synopsis
  6216. #
  6217. # \arguments{
  6218. # \item{...}{Not used.}
  6219. # }
  6220. #
  6221. # @author
  6222. #
  6223. # \seealso{
  6224. # @seeclass
  6225. # }
  6226. #
  6227. #*/###########################################################################
  6228. setMethodS3(
  6229. "Undocumented",
  6230. class="PhyloSim",
  6231. function(
  6232. ...
  6233. ){
  6234. cat("This method has no documentation!\n");
  6235. },
  6236. private=FALSE,
  6237. protected=FALSE,
  6238. overwrite=FALSE,
  6239. conflict="warning",
  6240. validators=getOption("R.methodsS3:validators:setMethodS3")
  6241. );