[med-svn] [r-cran-pscbs] 01/03: Imported Upstream version 0.61.0
Michael Crusoe
misterc-guest at moszumanska.debian.org
Sun Jun 26 19:46:21 UTC 2016
This is an automated email from the git hooks/post-receive script.
misterc-guest pushed a commit to branch master
in repository r-cran-pscbs.
commit 1b810ae65a6b1169024d66d827482b821cb55753
Author: Michael R. Crusoe <crusoe at ucdavis.edu>
Date: Sat Jun 25 13:52:33 2016 -0700
Imported Upstream version 0.61.0
---
DESCRIPTION | 39 +
MD5 | 209 +++
NAMESPACE | 358 ++++
NEWS | 1758 ++++++++++++++++++++
R/000.R | 4 +
R/006.fixVarArgs.R | 16 +
R/999.DEPRECATED.R | 44 +
R/999.NonDocumentedObjects.R | 28 +
R/999.package.R | 50 +
R/AbstractCBS.HCLUST.R | 263 +++
R/AbstractCBS.PLOT.R | 63 +
R/AbstractCBS.PRUNE.R | 530 ++++++
R/AbstractCBS.R | 933 +++++++++++
R/AbstractCBS.REPORT.R | 300 ++++
R/AbstractCBS.RESTRUCT.R | 561 +++++++
R/AbstractCBS.clearCalls.R | 30 +
R/CBS.CALL.R | 1454 ++++++++++++++++
R/CBS.EXTS.R | 474 ++++++
R/CBS.IO.R | 261 +++
R/CBS.PLOT,many.R | 268 +++
R/CBS.PLOT.R | 465 ++++++
R/CBS.PRUNE.R | 230 +++
R/CBS.R | 710 ++++++++
R/CBS.RESTRUCT.R | 393 +++++
R/CBS.SMOOTH.R | 71 +
R/CBS.joinSegments.R | 181 ++
R/CBS.updateMeansTogether.R | 100 ++
R/CNA.EXTS.R | 26 +
R/DNAcopy.EXTS.R | 279 ++++
R/NonPairedPSCBS.R | 389 +++++
R/PSCBS.IO.R | 156 ++
R/PSCBS.R | 261 +++
R/PSCBS.RESTRUCT.R | 186 +++
R/PairedPSCBS.BOOT.R | 1055 ++++++++++++
R/PairedPSCBS.BOOT.sets.R | 571 +++++++
R/PairedPSCBS.CALL.R | 159 ++
R/PairedPSCBS.EXTS.R | 547 ++++++
R/PairedPSCBS.EXTS3.R | 169 ++
R/PairedPSCBS.PLOT,many.R | 688 ++++++++
R/PairedPSCBS.PLOT.R | 971 +++++++++++
R/PairedPSCBS.PLOT2.R | 375 +++++
R/PairedPSCBS.PRUNE.R | 11 +
R/PairedPSCBS.R | 240 +++
R/PairedPSCBS.RESTRUCT.R | 390 +++++
R/PairedPSCBS.applyByRegion.R | 307 ++++
R/PairedPSCBS.callAB.R | 280 ++++
R/PairedPSCBS.callCopyNeutral.R | 439 +++++
R/PairedPSCBS.callGNL.R | 307 ++++
R/PairedPSCBS.callLOH.R | 299 ++++
R/PairedPSCBS.callROH.R | 168 ++
R/PairedPSCBS.estimateDeltaAB.R | 672 ++++++++
R/PairedPSCBS.estimateDeltaLOH.R | 258 +++
R/PairedPSCBS.estimateKappa.R | 268 +++
R/PairedPSCBS.extractSegmentDataByLocus.R | 93 ++
R/PairedPSCBS.unTumorBoost.R | 66 +
R/PairedPSCBS.updateMeans.R | 266 +++
R/PairedPSCBS.updateMeansTogether.R | 124 ++
R/callSegmentationOutliers.R | 253 +++
R/drawLevels.DNAcopy.R | 17 +
R/exampleData.R | 51 +
R/findLargeGaps.R | 120 ++
R/findNeutralCopyNumberState.R | 202 +++
R/gapsToSegments.R | 149 ++
R/installDNAcopy.R | 66 +
R/prememoize.R | 45 +
R/randomSeed.R | 122 ++
R/segmentByCBS.R | 1165 +++++++++++++
R/segmentByNonPairedPSCBS.R | 288 ++++
R/segmentByPairedPSCBS.R | 1420 ++++++++++++++++
R/testROH.R | 170 ++
R/weightedQuantile.R | 129 ++
R/writeWIG.R | 143 ++
R/zzz.R | 65 +
build/vignette.rds | Bin 0 -> 307 bytes
inst/CITATION | 53 +
inst/data-ex/PairedPSCBS,exData,chr01.Rbin | Bin 0 -> 2737152 bytes
inst/doc/CBS.R | 94 ++
inst/doc/CBS.pdf | Bin 0 -> 250313 bytes
inst/doc/CBS.tex.rsp | 305 ++++
inst/doc/PairedPSCBS.R | 92 +
inst/doc/PairedPSCBS.pdf | Bin 0 -> 283076 bytes
inst/doc/PairedPSCBS.tex.rsp | 421 +++++
.../sbdry/0109d43cd74c8e7e46db1abde235c808.Rcache | Bin 0 -> 17043 bytes
.../sbdry/2aba5b85ae757609b8b4c9fc60be1156.Rcache | Bin 0 -> 563 bytes
inst/templates/rsp/CBS,report.tex.rsp | 491 ++++++
inst/templates/rsp/NonPairedPSCBS,report.tex.rsp | 269 +++
inst/templates/rsp/PSCBS.bib | 139 ++
inst/templates/rsp/PairedPSCBS,report.tex.rsp | 670 ++++++++
.../templates/rsp/bioinformatics-journals-abbr.bib | 66 +
inst/templates/rsp/includes/levelDensities.tex.rsp | 104 ++
.../rsp/includes/pscnSegmentationTracks.tex.rsp | 47 +
.../includes/pscnSegmentationTransitions.tex.rsp | 51 +
inst/templates/rsp/includes/references.tex.rsp | 6 +
inst/templates/rsp/includes/reportHeader.tex.rsp | 81 +
.../rsp/includes/reportSetupGraphics.tex.rsp | 63 +
.../rsp/includes/reportSetupMacros.tex.rsp | 39 +
inst/templates/rsp/includes/sessionInfo.tex.rsp | 7 +
.../templates/rsp/includes/signalDensities.tex.rsp | 111 ++
.../summaryOfAnnotationAndGenotypeCalls.tex.rsp | 47 +
inst/templates/rsp/natbib.bst | 1288 ++++++++++++++
man/AbstractCBS.Rd | 82 +
man/CBS.Rd | 81 +
man/Non-documented_objects.Rd | 332 ++++
man/NonPairedPSCBS.Rd | 69 +
man/PSCBS-package.Rd | 66 +
man/PSCBS.Rd | 67 +
man/PairedPSCBS.Rd | 87 +
man/Restructuring_AbstractCBS_objects.Rd | 72 +
man/append.AbstractCBS.Rd | 42 +
man/append.CBS.Rd | 42 +
man/append.PSCBS.Rd | 42 +
man/as.CBS.DNAcopy.Rd | 45 +
man/as.DNAcopy.CBS.Rd | 88 +
man/as.data.frame.AbstractCBS.Rd | 40 +
man/as.data.frame.CBS.Rd | 42 +
man/bootstrapTCNandDHByRegion.PairedPSCBS.Rd | 51 +
man/callAB.PairedPSCBS.Rd | 69 +
man/callAllelicBalanceByDH.PairedPSCBS.Rd | 58 +
man/callAmplifications.CBS.Rd | 62 +
man/callCopyNeutral.PairedPSCBS.Rd | 52 +
man/callCopyNeutralByTCNofAB.PairedPSCBS.Rd | 58 +
man/callGNL.PairedPSCBS.Rd | 62 +
man/callGainsAndLosses.CBS.Rd | 108 ++
man/callLOH.PairedPSCBS.Rd | 66 +
man/callOutliers.CBS.Rd | 63 +
man/callROH.PairedPSCBS.Rd | 48 +
man/callSegmentationOutliers.Rd | 69 +
man/dropChangePoints.AbstractCBS.Rd | 46 +
man/dropRegions.AbstractCBS.Rd | 55 +
man/estimateDeltaAB.PairedPSCBS.Rd | 50 +
man/estimateDeltaABBySmallDH.PairedPSCBS.Rd | 65 +
man/estimateDeltaLOH.PairedPSCBS.Rd | 48 +
man/estimateDeltaLOHByMinC1ForNonAB.PairedPSCBS.Rd | 66 +
man/estimateKappa.PairedPSCBS.Rd | 45 +
man/estimateKappaByC1Density.PairedPSCBS.Rd | 95 ++
man/estimateStandardDeviation.CBS.Rd | 50 +
man/exampleData.Rd | 39 +
man/extractMinorMajorCNs.PairedPSCBS.Rd | 44 +
man/extractSegmentMeansByLocus.CBS.Rd | 41 +
man/extractTCNAndDHs.PairedPSCBS.Rd | 40 +
man/findLargeGaps.Rd | 51 +
man/findNeutralCopyNumberState.Rd | 44 +
man/gapsToSegments.data.frame.Rd | 49 +
man/getBootstrapLocusSets.PairedPSCBS.Rd | 53 +
man/getCallStatistics.CBS.Rd | 70 +
man/getChromosomes.AbstractCBS.Rd | 39 +
man/getFractionOfGenomeLost.CBS.Rd | 67 +
man/getLocusData.AbstractCBS.Rd | 46 +
man/getSampleName.AbstractCBS.Rd | 43 +
man/getSegments.AbstractCBS.Rd | 47 +
man/getSegments.PSCBS.Rd | 41 +
man/getSmoothLocusData.CBS.Rd | 46 +
man/hclustCNs.AbstractCBS.Rd | 46 +
man/installDNAcopy.Rd | 44 +
man/joinSegments.CBS.Rd | 49 +
man/load.AbstractCBS.Rd | 46 +
man/mergeNonCalledSegments.CBS.Rd | 42 +
man/mergeThreeSegments.AbstractCBS.Rd | 41 +
man/mergeTwoSegments.AbstractCBS.Rd | 51 +
man/mergeTwoSegments.PairedPSCBS.Rd | 44 +
man/nbrOfChangePoints.AbstractCBS.Rd | 41 +
man/nbrOfChromosomes.AbstractCBS.Rd | 39 +
man/nbrOfLoci.AbstractCBS.Rd | 38 +
man/nbrOfSegments.AbstractCBS.Rd | 40 +
man/ploidy.AbstractCBS.Rd | 60 +
man/plotTracks.AbstractCBS.Rd | 39 +
man/plotTracks.CBS.Rd | 47 +
man/plotTracks.PairedPSCBS.Rd | 76 +
man/pruneByDP.AbstractCBS.Rd | 51 +
man/pruneByHClust.AbstractCBS.Rd | 48 +
man/pruneBySdUndo.CBS.Rd | 91 +
man/randomSeed.Rd | 44 +
man/report.AbstractCBS.Rd | 52 +
man/resetSegments.AbstractCBS.Rd | 43 +
man/save.AbstractCBS.Rd | 40 +
man/segmentByCBS.Rd | 248 +++
man/segmentByNonPairedPSCBS.Rd | 183 ++
man/segmentByPairedPSCBS.Rd | 251 +++
man/setSampleName.AbstractCBS.Rd | 45 +
man/testROH.numeric.Rd | 48 +
man/updateMeans.AbstractCBS.Rd | 40 +
man/updateMeansTogether.AbstractCBS.Rd | 48 +
man/weightedQuantile.Rd | 60 +
man/writeSegments.CBS.Rd | 54 +
man/writeSegments.PSCBS.Rd | 52 +
tests/PairedPSCBS,boot.R | 93 ++
tests/PairedPSCBS,plot.R.HIDE | 31 +
tests/findLargeGaps.R | 68 +
tests/randomSeed.R | 151 ++
tests/segmentByCBS,calls.R | 63 +
tests/segmentByCBS,flavors.R.HIDE | 31 +
tests/segmentByCBS,futures.R | 89 +
tests/segmentByCBS,median.R | 118 ++
tests/segmentByCBS,prune.R | 58 +
tests/segmentByCBS,report.R | 44 +
tests/segmentByCBS,shiftTCN.R | 113 ++
tests/segmentByCBS,weights.R | 165 ++
tests/segmentByCBS.R | 158 ++
tests/segmentByNonPairedPSCBS,medianDH.R | 78 +
tests/segmentByPairedPSCBS,DH.R | 64 +
tests/segmentByPairedPSCBS,calls.R | 124 ++
tests/segmentByPairedPSCBS,futures.R | 88 +
tests/segmentByPairedPSCBS,noNormalBAFs.R | 70 +
tests/segmentByPairedPSCBS,report.R | 41 +
tests/segmentByPairedPSCBS,seqOfSegmentsByDP.R | 61 +
tests/segmentByPairedPSCBS.R | 155 ++
vignettes/CBS.tex.rsp | 305 ++++
vignettes/PSCBS.bib | 77 +
vignettes/PairedPSCBS.tex.rsp | 421 +++++
vignettes/natbib.bst | 1288 ++++++++++++++
210 files changed, 38000 insertions(+)
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..d07507c
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,39 @@
+Package: PSCBS
+Version: 0.61.0
+Depends: R (>= 3.1.2), utils
+Imports: R.methodsS3 (>= 1.7.0), R.oo (>= 1.19.0), R.utils (>= 2.2.0),
+ R.cache (>= 0.12.0), matrixStats (>= 0.50.1), DNAcopy (>=
+ 1.40.0), listenv (>= 0.6.0), future (>= 0.11.0), parallel
+Suggests: Hmisc (>= 3.16-0), R.rsp (>= 0.21.0), R.devices (>= 2.13.2),
+ ggplot2 (>= 1.0.1), aroma.light (>= 2.2.1)
+SuggestsNote: BioC (>= 3.0), Recommended: Hmisc, aroma.light
+VignetteBuilder: R.rsp
+Date: 2016-02-03
+Title: Analysis of Parent-Specific DNA Copy Numbers
+Authors at R: c(
+ person("Henrik", "Bengtsson", role=c("aut", "cre", "cph"),
+ email="henrikb at braju.com"),
+ person("Pierre", "Neuvial", role="aut"),
+ person("Venkatraman E.", "Seshan", role="aut"),
+ person("Adam B.", "Olshen", role="aut"),
+ person("Paul T.", "Spellman", role="aut"),
+ person("Richard A.", "Olshen", role="aut"))
+Description: Segmentation of allele-specific DNA copy number data and detection of regions with abnormal copy number within each parental chromosome. Both tumor-normal paired and tumor-only analyses are supported.
+License: GPL (>= 2)
+LazyLoad: TRUE
+ByteCompile: TRUE
+biocViews: aCGH, CopyNumberVariants, SNP, Microarray, OneChannel,
+ TwoChannel, Genetics
+URL: https://github.com/HenrikBengtsson/PSCBS
+BugReports: https://github.com/HenrikBengtsson/PSCBS/issues
+NeedsCompilation: no
+Packaged: 2016-02-04 00:30:07 UTC; hb
+Author: Henrik Bengtsson [aut, cre, cph],
+ Pierre Neuvial [aut],
+ Venkatraman E. Seshan [aut],
+ Adam B. Olshen [aut],
+ Paul T. Spellman [aut],
+ Richard A. Olshen [aut]
+Maintainer: Henrik Bengtsson <henrikb at braju.com>
+Repository: CRAN
+Date/Publication: 2016-02-04 11:27:36
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..a51a65c
--- /dev/null
+++ b/MD5
@@ -0,0 +1,209 @@
+1c3cb60a72fee9551934991351966569 *DESCRIPTION
+370db02a92db2b1e277e6d65aa92ef8f *NAMESPACE
+9b2d8b534aae419758c34be2915169a2 *NEWS
+5b3e0291bcc049d9ada9005162c5259a *R/000.R
+3e3dabecfb506b75e8e24743c5336630 *R/006.fixVarArgs.R
+93c57de5b16270cd0c7bbbe4de701afc *R/999.DEPRECATED.R
+dcb0e44d79e9859ee6006eb8c70b2837 *R/999.NonDocumentedObjects.R
+b9a22d7a3d629919b925558646512bf1 *R/999.package.R
+7d23ca0a5c853711bc616038cac8c72c *R/AbstractCBS.HCLUST.R
+42b2df2eaa3f0ee53e9107a25f0611df *R/AbstractCBS.PLOT.R
+a915b95818abe4652355c944d6b04963 *R/AbstractCBS.PRUNE.R
+233376f492d5dcdc6c85da87a3f6b7bc *R/AbstractCBS.R
+08250793df9a159d63a1e7adb635fd78 *R/AbstractCBS.REPORT.R
+cfd4ed80039034ecc2af3f1938210e64 *R/AbstractCBS.RESTRUCT.R
+172afe9107992b6a440aff2423dff4f7 *R/AbstractCBS.clearCalls.R
+b4e141bd292d96186c15ab62fccb4c4d *R/CBS.CALL.R
+ca86e31fe1a32e7d30d84d585e4d0160 *R/CBS.EXTS.R
+3c0853753de1a1c3f330d6d587a08c19 *R/CBS.IO.R
+4fa84d97b3568c0b80b39368f1afe730 *R/CBS.PLOT,many.R
+b7d874d9e15ba5cf30764c6a0ececf90 *R/CBS.PLOT.R
+665fd7d0139647f0ba86219ebf4ec694 *R/CBS.PRUNE.R
+06674bc847e8a00addfbfce9141e0f4b *R/CBS.R
+68a889a49937d29e84a7a37da6302daf *R/CBS.RESTRUCT.R
+6cbb38b5afda180074d6e7ae6944f1c2 *R/CBS.SMOOTH.R
+e32f90f662ac61156143354aa1b7ce91 *R/CBS.joinSegments.R
+6c28fb753c160132793c26ae474c36c6 *R/CBS.updateMeansTogether.R
+ed080a928098a7ee721079af992f640c *R/CNA.EXTS.R
+60584ffa1b46f3eb210bc366f802cef9 *R/DNAcopy.EXTS.R
+f69b8289ad106512524734731ed10ef0 *R/NonPairedPSCBS.R
+07f118d9fd7942687f57c76e3c4f78a3 *R/PSCBS.IO.R
+39633082d3a2008d3a425fe542f45b5e *R/PSCBS.R
+094569b0a307b6fee63b8df5859c4823 *R/PSCBS.RESTRUCT.R
+2aee730ac2c4fd29f7da91460874244a *R/PairedPSCBS.BOOT.R
+09218dbad6b5910924ad3adf409b9c92 *R/PairedPSCBS.BOOT.sets.R
+dc3ed47c532e07bb9d6a1735eea17649 *R/PairedPSCBS.CALL.R
+ba9eb33970f87d4b2cad0f8a63477d1c *R/PairedPSCBS.EXTS.R
+32b2f5f0dc98d1499078587125d93677 *R/PairedPSCBS.EXTS3.R
+6148b9f7479104b15576305fb3f79368 *R/PairedPSCBS.PLOT,many.R
+9a978662971fb8540f279f46be0a3fde *R/PairedPSCBS.PLOT.R
+1d77fd8262388a4bc0bb2d91ca80da9f *R/PairedPSCBS.PLOT2.R
+fcc580134d46f0a28634b758cdcc4123 *R/PairedPSCBS.PRUNE.R
+3012ab041d9f32d1ae3e2bac5bd121a2 *R/PairedPSCBS.R
+b7279b6199cf9b15d8376216a6f5be1d *R/PairedPSCBS.RESTRUCT.R
+7f1f261b929a85ea961e410d79cdcf67 *R/PairedPSCBS.applyByRegion.R
+695e0ebc76969b3b2fdbbe659fbb118c *R/PairedPSCBS.callAB.R
+148df4c8641d5b1cc4d678dde265309f *R/PairedPSCBS.callCopyNeutral.R
+43802ae29941da7fca08656bf76da171 *R/PairedPSCBS.callGNL.R
+c85b32a324461b8e96ef01ae33b0b6c1 *R/PairedPSCBS.callLOH.R
+34b3a002ba7c9d82881d7f47eb52bb42 *R/PairedPSCBS.callROH.R
+0b6606842467cd1f6e4b58ade02a9e21 *R/PairedPSCBS.estimateDeltaAB.R
+dc6744d8ae34728ab082853ef9fdaac2 *R/PairedPSCBS.estimateDeltaLOH.R
+444cd179dbe63fad8b592f4bbbde0807 *R/PairedPSCBS.estimateKappa.R
+554526631ab6736c85fe19089a7e86ea *R/PairedPSCBS.extractSegmentDataByLocus.R
+16ff2709a944fcf57934b9f98d6ab39b *R/PairedPSCBS.unTumorBoost.R
+194851b8b34d0355023052ad37603bcb *R/PairedPSCBS.updateMeans.R
+4e7eadf16edd24efbbf3668274a26a6a *R/PairedPSCBS.updateMeansTogether.R
+edadbbad243b8fc4687986417aa6944a *R/callSegmentationOutliers.R
+4d7a3c9ebe2cc59bc8bbdeda9d4c13d0 *R/drawLevels.DNAcopy.R
+0119fe08cdec28314ae4abfa7669dffc *R/exampleData.R
+b8d3de9af9b4ff8bb516c8c430a4b28e *R/findLargeGaps.R
+4e8025349a3933694913a4f784162692 *R/findNeutralCopyNumberState.R
+6668141241a50eb225890ca7cce13a7d *R/gapsToSegments.R
+d48f6ff09d630cac23b3db8d5819e216 *R/installDNAcopy.R
+71483b466dfb355f14ad5d4ce9ed0233 *R/prememoize.R
+9bd61b757a7ce40f2dc5288c91e62a63 *R/randomSeed.R
+23fa04ac04fee4899ed62501caed3422 *R/segmentByCBS.R
+da90c04cddc9f3d4c7253ddadf83d9fc *R/segmentByNonPairedPSCBS.R
+50c70103f3973c210b15c177046a958b *R/segmentByPairedPSCBS.R
+7d1907ae7ab66a48b4eded1d496b277b *R/testROH.R
+acea5de06a39f1fa395f67b8cb4700a3 *R/weightedQuantile.R
+08127f8c76110ee2407c9841533e08db *R/writeWIG.R
+10b3fd7f2f6a84cb0f16a75609f1a5ff *R/zzz.R
+9768f2f0def0fbcf1ca1bd7e7fa693b1 *build/vignette.rds
+a1ff7cb79a888bb3032d330227f179e0 *inst/CITATION
+14659728b7be1bb8e37e953a87060e6c *inst/data-ex/PairedPSCBS,exData,chr01.Rbin
+ee696a0e37a95e63c90f466a0fe7c663 *inst/doc/CBS.R
+533a89cf1fa4fe5ab790e3d423aec031 *inst/doc/CBS.pdf
+fe36d40a38d3201214ce662d4271b9df *inst/doc/CBS.tex.rsp
+6c46948f6e05e07e8f621aff3082fcac *inst/doc/PairedPSCBS.R
+5f5aded9937a1d2d9051daf8836ccf0a *inst/doc/PairedPSCBS.pdf
+4f1745be74ffe7b192c632445b6af5b5 *inst/doc/PairedPSCBS.tex.rsp
+56e6435959f6387651a30e915e54baab *inst/misc/_Rcache/PSCBS/segmentByCBS/sbdry/0109d43cd74c8e7e46db1abde235c808.Rcache
+17a5a6d6c343e587021f5e4c7c3ec97e *inst/misc/_Rcache/PSCBS/segmentByCBS/sbdry/2aba5b85ae757609b8b4c9fc60be1156.Rcache
+2006584e8845904693aed6fa9008235c *inst/templates/rsp/CBS,report.tex.rsp
+f605500742f015ae26c455b37fcc18b8 *inst/templates/rsp/NonPairedPSCBS,report.tex.rsp
+008dcc209acfd836649040fa600adbda *inst/templates/rsp/PSCBS.bib
+5c55c6de78ff35d48049b47a3e8e58f9 *inst/templates/rsp/PairedPSCBS,report.tex.rsp
+f01bbc88ade170e0dcb4c76fac17fe7d *inst/templates/rsp/bioinformatics-journals-abbr.bib
+5146f637b61e03ac550811e9d46de420 *inst/templates/rsp/includes/levelDensities.tex.rsp
+2d2c639e0d72962658f270675cccbf0b *inst/templates/rsp/includes/pscnSegmentationTracks.tex.rsp
+c72a4a967345e999cccdaeb0b072d01d *inst/templates/rsp/includes/pscnSegmentationTransitions.tex.rsp
+860859b29771b6fade80e4d0cebc59d6 *inst/templates/rsp/includes/references.tex.rsp
+7885a06ef57438e704c0d9d35dddc716 *inst/templates/rsp/includes/reportHeader.tex.rsp
+9a68af6ca781e60d82670869008ffe33 *inst/templates/rsp/includes/reportSetupGraphics.tex.rsp
+7615fd0b844f872869b4afb3bbdfd1bb *inst/templates/rsp/includes/reportSetupMacros.tex.rsp
+9b2e313a0483afa2ca60cc616434679f *inst/templates/rsp/includes/sessionInfo.tex.rsp
+9a88214a9db5b94992ea733bb8c6157f *inst/templates/rsp/includes/signalDensities.tex.rsp
+4cb7c97012df4c618f08acd20cf1ca63 *inst/templates/rsp/includes/summaryOfAnnotationAndGenotypeCalls.tex.rsp
+f3907cf5bef1f44c8c15558e94274a18 *inst/templates/rsp/natbib.bst
+95e5d2a8dbcc9288cc9a7f2e7fa99576 *man/AbstractCBS.Rd
+267605563ea772f416f2269b6b5d2223 *man/CBS.Rd
+287ea3c335f3c0f133f4237a6e7945ee *man/Non-documented_objects.Rd
+e12e9370d0c22d5beed4cccbfe646f7d *man/NonPairedPSCBS.Rd
+ab0330aa3eae8000ef333c9e41582efb *man/PSCBS-package.Rd
+a1f2de960f6581ff3558516a3af4da15 *man/PSCBS.Rd
+5939644c31ef19397552defc37b2232e *man/PairedPSCBS.Rd
+59ae340fe4e3a601d59da4702ec144fb *man/Restructuring_AbstractCBS_objects.Rd
+1f0aab8f0fac7a13036fe42b11d647fe *man/append.AbstractCBS.Rd
+0e47e730083c1af44f4378fa3329807d *man/append.CBS.Rd
+e79d626f47c80e89160221840e45b01c *man/append.PSCBS.Rd
+e534107eb35ccbb5e59093d2acf6e32c *man/as.CBS.DNAcopy.Rd
+22ce4b8908c97ccb56a0f134510bffc3 *man/as.DNAcopy.CBS.Rd
+a6cb223758bc39c5d9ca4e7157c410dd *man/as.data.frame.AbstractCBS.Rd
+53f2d1c6fc28166ff5cb62e476fea136 *man/as.data.frame.CBS.Rd
+bd714c1f380fd2889fea937384d961fc *man/bootstrapTCNandDHByRegion.PairedPSCBS.Rd
+6095c6f1db04d7817485853349429489 *man/callAB.PairedPSCBS.Rd
+69c7ae7eccf16bfebf15bada46d6721c *man/callAllelicBalanceByDH.PairedPSCBS.Rd
+8a177a1d31c63dcd3e3cf1aaab45b07b *man/callAmplifications.CBS.Rd
+521539eb523296c1cf58d9364167a161 *man/callCopyNeutral.PairedPSCBS.Rd
+419ed670fb8422053a9e44a41b1eef6f *man/callCopyNeutralByTCNofAB.PairedPSCBS.Rd
+c854e68744cfc82c1fcd8b51ca857fad *man/callGNL.PairedPSCBS.Rd
+9fc634c7d99b5ad734bc1057bfcca1bb *man/callGainsAndLosses.CBS.Rd
+dc41bb1efa305ed8e10dc681bc45aa23 *man/callLOH.PairedPSCBS.Rd
+2dc88b200365c204d975e1809655af6f *man/callOutliers.CBS.Rd
+838dc240a03c12ffe3874864dcf3b22e *man/callROH.PairedPSCBS.Rd
+b347080d29b70bc29aff1ff8934a28b3 *man/callSegmentationOutliers.Rd
+af589aed4e4fcf9e491c25a16a2c5c4e *man/dropChangePoints.AbstractCBS.Rd
+c2717b3db4da9f95dd8822da6bd689d0 *man/dropRegions.AbstractCBS.Rd
+927c0252a746ca7baa3f6e70c94984ac *man/estimateDeltaAB.PairedPSCBS.Rd
+271e67da730c818170d45c7815daa4d4 *man/estimateDeltaABBySmallDH.PairedPSCBS.Rd
+a7a6086b85e2a88daf979a3e75abe993 *man/estimateDeltaLOH.PairedPSCBS.Rd
+bd5b73e4f84a670dce9a9ee060b3bafa *man/estimateDeltaLOHByMinC1ForNonAB.PairedPSCBS.Rd
+722d9be399b053a6aa85908186c66617 *man/estimateKappa.PairedPSCBS.Rd
+e25d09950c2ac2aed8932081db2dc0eb *man/estimateKappaByC1Density.PairedPSCBS.Rd
+bbca3a25a2700e1040065c966c28036c *man/estimateStandardDeviation.CBS.Rd
+a8a1368fb2e836d808ab339eec5c3bf7 *man/exampleData.Rd
+dd702d33c6c9dc7c8a61db7d8e57d7e8 *man/extractMinorMajorCNs.PairedPSCBS.Rd
+2745258268eeffe5d6f8437142a0ca7f *man/extractSegmentMeansByLocus.CBS.Rd
+da4cb348dce202b19542a681c3b0a893 *man/extractTCNAndDHs.PairedPSCBS.Rd
+9dbea07287422753ab5db54fa9b547a4 *man/findLargeGaps.Rd
+aa2f91382cb975e1886c2d0a439aba90 *man/findNeutralCopyNumberState.Rd
+3699de1bee98ca4afbbfa4b93e27175a *man/gapsToSegments.data.frame.Rd
+1bd0c24ae698ca98b9e691a6b9099a73 *man/getBootstrapLocusSets.PairedPSCBS.Rd
+c27859503bff7a18bdccdb9b900a8837 *man/getCallStatistics.CBS.Rd
+01be02b70f50acdf32af74d1095bdee8 *man/getChromosomes.AbstractCBS.Rd
+8add6b64fab13e7805e73d454c2f0226 *man/getFractionOfGenomeLost.CBS.Rd
+0c00f0a1b5c95157e300a92455e38669 *man/getLocusData.AbstractCBS.Rd
+e38e4c27a96ad64c745f9db7cb07faa4 *man/getSampleName.AbstractCBS.Rd
+6f07ef6692ece0549fcabe4e63bc8832 *man/getSegments.AbstractCBS.Rd
+6d48429ce911acae62ce59a708e623ca *man/getSegments.PSCBS.Rd
+2d45f3dfbe49462191da53f7d04341ab *man/getSmoothLocusData.CBS.Rd
+2aa35c71d6043956970e091489a23ce4 *man/hclustCNs.AbstractCBS.Rd
+12d8023e7c2f8ecc5ca76c7b14381a7a *man/installDNAcopy.Rd
+c668b9975804d67f833e671635dab54b *man/joinSegments.CBS.Rd
+280fcc003932b9bc7aea70ef5a61f74f *man/load.AbstractCBS.Rd
+3e24345d7327bf88fea8b824a582e718 *man/mergeNonCalledSegments.CBS.Rd
+cf642a455c7ca06f7072e6ce3ebb1d22 *man/mergeThreeSegments.AbstractCBS.Rd
+c50de0e05e4f82bf2f7522e2f1187aa3 *man/mergeTwoSegments.AbstractCBS.Rd
+8ea75fe5a459f8b6502e75b6f6ee6eb0 *man/mergeTwoSegments.PairedPSCBS.Rd
+8e33b404462d57fa8111ec6c17def975 *man/nbrOfChangePoints.AbstractCBS.Rd
+e1913743bcf8545b5c7f3cf9b206624d *man/nbrOfChromosomes.AbstractCBS.Rd
+b05c91b6528f5dfb200d1493523b3525 *man/nbrOfLoci.AbstractCBS.Rd
+32dc5a786239d886939b19a814ea865c *man/nbrOfSegments.AbstractCBS.Rd
+b1618d544720f032c95f6563a53fc645 *man/ploidy.AbstractCBS.Rd
+285605d73ea6b1ad80d561642b2d5644 *man/plotTracks.AbstractCBS.Rd
+8e407ed8348a1ad6e1276c7c8d9a3c41 *man/plotTracks.CBS.Rd
+17a8ae7c3d0936fdd884c1af40b0c674 *man/plotTracks.PairedPSCBS.Rd
+ae6ca7420cb0fca1837b96e407f6b0d6 *man/pruneByDP.AbstractCBS.Rd
+517f08eb913a6e8c058b0f60780fe1d2 *man/pruneByHClust.AbstractCBS.Rd
+013127e4dfd9584ce18c9b246c713b50 *man/pruneBySdUndo.CBS.Rd
+0cc1a3f744dae1ca53c07f4fb61e91e6 *man/randomSeed.Rd
+6ac688a354724df8e0b3c5110949ca21 *man/report.AbstractCBS.Rd
+88b05c630f8af9a2437df4a846bab343 *man/resetSegments.AbstractCBS.Rd
+c5008992920a8e9f86507297712cdfb1 *man/save.AbstractCBS.Rd
+54783f9dba18d63f9f20a8d717109689 *man/segmentByCBS.Rd
+b3fb1177bdb0fc8680745b9315392ad9 *man/segmentByNonPairedPSCBS.Rd
+92577da258a8b83cb775754eb87db6d7 *man/segmentByPairedPSCBS.Rd
+4c4181efced223c39066439f8741c498 *man/setSampleName.AbstractCBS.Rd
+6e9676b9f9825c488bdf96d410cc9539 *man/testROH.numeric.Rd
+e9dd20a0adf9def1b9523d189a35e4f6 *man/updateMeans.AbstractCBS.Rd
+79aedb4af12fb676dc87911135275281 *man/updateMeansTogether.AbstractCBS.Rd
+a39ac96df7c724ddfa623f152881e647 *man/weightedQuantile.Rd
+63a7356f7ad4433a9361ecee5ae683c2 *man/writeSegments.CBS.Rd
+c17aa26ce4bed7b08417b45882e96276 *man/writeSegments.PSCBS.Rd
+de8847124d8ea6cdaddb1f52269f10b0 *tests/PairedPSCBS,boot.R
+3f71b69684ee05fdadad22ac64da562a *tests/PairedPSCBS,plot.R.HIDE
+a20d5e74b660794a207ebee3b146e571 *tests/findLargeGaps.R
+4f1a9d8d791a7a899eb18e19b56a98ca *tests/randomSeed.R
+41267a6a75014b780037272409dcf4a4 *tests/segmentByCBS,calls.R
+51f25e9c62540c68935272e50cfe34ad *tests/segmentByCBS,flavors.R.HIDE
+c38722b3734551a999899b59af206ca4 *tests/segmentByCBS,futures.R
+f04ed0148cf6f6b62c2af44ccdbdb7e4 *tests/segmentByCBS,median.R
+2237835c4c7d3019d0fb50a86efc5604 *tests/segmentByCBS,prune.R
+31fc411fec814fe4d12ff9b59772c9d0 *tests/segmentByCBS,report.R
+08d09f321e3267db055017c2164d7691 *tests/segmentByCBS,shiftTCN.R
+4770dcbd22a8f1f0aa7ec339059eda83 *tests/segmentByCBS,weights.R
+b6b41f53af25eb3d23d9423b3b18386c *tests/segmentByCBS.R
+065319c9e5582cb4b5c7ea4b9bbbc793 *tests/segmentByNonPairedPSCBS,medianDH.R
+d8cd7bdf20f657bcc393c55c7bce382e *tests/segmentByPairedPSCBS,DH.R
+d03756cf4f3124b51ddc4b1a7ee224ff *tests/segmentByPairedPSCBS,calls.R
+6dab868872280d879b4e27a91c403b10 *tests/segmentByPairedPSCBS,futures.R
+b5297118f74861f14db49b1a53eb4d73 *tests/segmentByPairedPSCBS,noNormalBAFs.R
+f548d6f682c19df3fb6e5872dff37686 *tests/segmentByPairedPSCBS,report.R
+5e2e0e0355667f0e403ae854ed6292b2 *tests/segmentByPairedPSCBS,seqOfSegmentsByDP.R
+f0aeff863889c75b9ffbdcf1fe675724 *tests/segmentByPairedPSCBS.R
+fe36d40a38d3201214ce662d4271b9df *vignettes/CBS.tex.rsp
+9570b3efb4e27043b33dd71622f38ebe *vignettes/PSCBS.bib
+4f1745be74ffe7b192c632445b6af5b5 *vignettes/PairedPSCBS.tex.rsp
+f3907cf5bef1f44c8c15558e94274a18 *vignettes/natbib.bst
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..bd16401
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,358 @@
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# IMPORTS
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+importFrom("R.methodsS3", "setMethodS3")
+importFrom("R.methodsS3", "getMethodS3")
+importFrom("R.oo", "setConstructorS3")
+importFrom("R.methodsS3", "throw")
+importFrom("R.utils", "use")
+
+## Importing Object classes
+importFrom("R.oo", "Package")
+importFrom("R.utils", "Arguments")
+importFrom("R.utils", "GenericSummary")
+
+
+## Importing generics
+importFrom("R.oo", "load") ## Multi-sources: R.oo, base
+importFrom("R.oo", "save") ## Multi-sources: R.oo, base
+
+
+## Importing functions
+importFrom("R.oo",
+ "extend", "attachLocally", "startupMessage")
+
+importFrom("R.cache",
+ "getCachePath", "loadCache", "saveCache")
+
+importFrom("R.utils",
+ "cat", "capitalize", "copyDirectory", "createLink",
+ "enter", "enterf", "exit", "filePath", "getAbsolutePath",
+ "getRelativePath", "hpaste", "insert", "isDirectory",
+ "isFile", "isPackageInstalled", "isZero", "less",
+ "loadObject", "more", "popState", "popTemporaryFile",
+ "printf", "pushState", "pushTemporaryFile", "resample",
+ "saveObject", "stext", "subplots", "toCamelCase", "wrap")
+
+importFrom("matrixStats",
+ "binMeans", "colCumsums", "colDiffs", "colMins", "colMaxs",
+ "rowAlls", "rowAnys", "rowMins", "weightedMedian")
+
+importFrom("DNAcopy",
+ "segments.summary", "smooth.CNA", "CNA", "segment", "getbdry")
+
+importFrom("graphics",
+ "abline", "arrows", "axis", "box", "lines",
+ "mtext", "par", "plot", "points", "rect", "text")
+
+importFrom("grDevices",
+ "col2rgb", "rgb")
+
+importFrom("stats",
+ "cor", "cutree", "density", "end", "mad", "median",
+ "na.omit", "quantile", "sd", "start", "weighted.mean")
+
+importFrom("utils",
+ "capture.output", "file_test", "getFromNamespace",
+ "head", "packageVersion", "str", "tail", "write.table",
+ "packageDescription")
+
+importFrom("listenv", "listenv")
+importFrom("future", "%<=%")
+importFrom("parallel", "nextRNGStream")
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# EXPORTS
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Export all public methods, that is, those without a preceeding dot
+# in their names.
+exportPattern("^[^\\.]")
+
+export("load") # Re-export from R.oo
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# S3 methods
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# From 006.fixVarArgs.R
+S3method("append", "default")
+
+# AbstractCBS
+S3method("adjustPloidyScale", "AbstractCBS")
+S3method("all.equal", "AbstractCBS")
+S3method("append", "AbstractCBS")
+S3method("as.data.frame", "AbstractCBS")
+S3method("clearCalls", "AbstractCBS")
+S3method("drawChangePoints", "AbstractCBS")
+S3method("drawKnownSegments", "AbstractCBS")
+S3method("dropChangePoint", "AbstractCBS")
+S3method("dropChangePoints", "AbstractCBS")
+S3method("dropRegion", "AbstractCBS")
+S3method("dropRegions", "AbstractCBS")
+S3method("extractChromosome", "AbstractCBS")
+S3method("extractChromosomes", "AbstractCBS")
+S3method("extractCNs", "AbstractCBS")
+S3method("extractRegion", "AbstractCBS")
+S3method("extractRegions", "AbstractCBS")
+S3method("extractSegment", "AbstractCBS")
+S3method("extractSegments", "AbstractCBS")
+S3method("getChangePoints", "AbstractCBS")
+S3method("getChromosomeOffsets", "AbstractCBS")
+S3method("getChromosomeRanges", "AbstractCBS")
+S3method("getChromosomes", "AbstractCBS")
+S3method("getLocusData", "AbstractCBS")
+S3method("getLocusSignalNames", "AbstractCBS")
+S3method("getMeanEstimators", "AbstractCBS")
+S3method("getSampleName", "AbstractCBS")
+S3method("getSegments", "AbstractCBS")
+S3method("getSegmentSizes", "AbstractCBS")
+S3method("getSegmentTrackPrefixes", "AbstractCBS")
+S3method("hclustCNs", "AbstractCBS")
+S3method("load", "AbstractCBS")
+S3method("mergeThreeSegments", "AbstractCBS")
+S3method("mergeTwoSegments", "AbstractCBS")
+S3method("nbrOfChangePoints", "AbstractCBS")
+S3method("nbrOfChromosomes", "AbstractCBS")
+S3method("nbrOfLoci", "AbstractCBS")
+S3method("nbrOfSegments", "AbstractCBS")
+S3method("ploidy", "AbstractCBS")
+S3method("ploidy<-", "AbstractCBS")
+S3method("plotTracks", "AbstractCBS")
+S3method("print", "AbstractCBS")
+S3method("pruneByDP", "AbstractCBS")
+S3method("pruneByHClust", "AbstractCBS")
+S3method("renameChromosomes", "AbstractCBS")
+S3method("report", "AbstractCBS")
+S3method("resegment", "AbstractCBS")
+S3method("resetSegments", "AbstractCBS")
+S3method("sampleCNs", "AbstractCBS")
+S3method("sampleName", "AbstractCBS")
+S3method("sampleName<-", "AbstractCBS")
+S3method("save", "AbstractCBS")
+S3method("seqOfSegmentsByDP", "AbstractCBS")
+S3method("setLocusData", "AbstractCBS")
+S3method("setMeanEstimators", "AbstractCBS")
+S3method("setPloidy", "AbstractCBS")
+S3method("setSampleName", "AbstractCBS")
+S3method("setSegments", "AbstractCBS")
+S3method("shiftTCN", "AbstractCBS")
+S3method("tileChromosomes", "AbstractCBS")
+S3method("updateMeans", "AbstractCBS")
+S3method("updateMeansTogether", "AbstractCBS")
+S3method("writeWIG", "AbstractCBS")
+
+
+# CBS
+S3method("all.equal", "CBS")
+S3method("append", "CBS")
+S3method("as.character", "CBS")
+S3method("as.data.frame", "CBS")
+S3method("as.DNAcopy", "CBS")
+S3method("callAmplifications", "CBS")
+S3method("callArms", "CBS")
+S3method("callGainsAndLosses", "CBS")
+S3method("callGLAO", "CBS")
+S3method("callOutliers", "CBS")
+S3method("drawCentromeres", "CBS")
+S3method("drawChromosomes", "CBS")
+S3method("drawLevels", "CBS")
+S3method("estimateDeltaCN", "CBS")
+S3method("estimateStandardDeviation", "CBS")
+S3method("extractCallsByLocus", "CBS")
+S3method("extractChromosomes", "CBS")
+S3method("extractCNs", "CBS")
+S3method("extractSegmentMeansByLocus", "CBS")
+S3method("extractSegments", "CBS")
+S3method("extractTotalCNs", "CBS")
+S3method("extractWIG", "CBS")
+S3method("extractWIG", "AbstractCBS")
+S3method("extractWIG", "PSCBS")
+S3method("getCallStatistics", "CBS")
+S3method("getCallStatisticsByArms", "CBS")
+S3method("getChangePoints", "CBS")
+S3method("getChromosomeRanges", "CBS")
+S3method("getFGA", "CBS")
+S3method("getFGG", "CBS")
+S3method("getFGL", "CBS")
+S3method("getFractionOfGenomeAltered", "CBS")
+S3method("getFractionOfGenomeGained", "CBS")
+S3method("getFractionOfGenomeLost", "CBS")
+S3method("getLocusData", "CBS")
+S3method("getLocusSignalNames", "CBS")
+S3method("getSegments", "CBS")
+S3method("getSegmentTrackPrefixes", "CBS")
+S3method("getSignalType", "CBS")
+S3method("getSmoothLocusData", "CBS")
+S3method("highlightArmCalls", "CBS")
+S3method("highlightCalls", "CBS")
+S3method("highlightLocusCalls", "CBS")
+S3method("isSegmentSplitter", "CBS")
+S3method("isWholeChromosomeGained", "CBS")
+S3method("isWholeChromosomeLost", "CBS")
+S3method("joinSegments", "CBS")
+S3method("mergeNonCalledSegments", "CBS")
+S3method("mergeTwoSegments", "CBS")
+S3method("nbrOfAmplifications", "CBS")
+S3method("nbrOfGains", "CBS")
+S3method("nbrOfLosses", "CBS")
+S3method("plot", "CBS")
+S3method("plotTracks", "CBS")
+S3method("plotTracksManyChromosomes", "CBS")
+S3method("pruneBySdUndo", "CBS")
+S3method("resegment", "CBS")
+S3method("segmentByCBS", "CBS")
+S3method("seqOfSegmentsByDP", "CBS")
+S3method("shiftTCN", "CBS")
+S3method("signalType", "CBS")
+S3method("signalType<-", "CBS")
+S3method("subset", "CBS")
+S3method("tileChromosomes", "CBS")
+S3method("updateBoundaries", "CBS")
+S3method("updateMeans", "CBS")
+S3method("updateMeansTogether", "CBS")
+S3method("writeLocusData", "CBS")
+S3method("writeSegments", "CBS")
+
+# CNA
+S3method("segmentByCBS", "CNA")
+
+# data.frame
+S3method("callSegmentationOutliers", "data.frame")
+S3method("encodeCalls", "data.frame")
+S3method("dropSegmentationOutliers", "data.frame")
+S3method("findLargeGaps", "data.frame")
+S3method("gapsToSegments", "data.frame")
+S3method("segmentByCBS", "data.frame")
+S3method("segmentByNonPairedPSCBS", "data.frame")
+S3method("segmentByPairedPSCBS", "data.frame")
+
+# default
+S3method("append", "default")
+S3method("callAllelicBalance", "default")
+S3method("callSegmentationOutliers", "default")
+S3method("dropSegmentationOutliers", "default")
+S3method("exampleData", "default")
+S3method("findLargeGaps", "default")
+S3method("findNeutralCopyNumberState", "default")
+S3method("installDNAcopy", "default")
+S3method("segmentByCBS", "default")
+S3method("segmentByNonPairedPSCBS", "default")
+S3method("segmentByPairedPSCBS", "default")
+S3method("weightedQuantile", "default")
+
+# DNAcopy
+S3method("as.CBS", "DNAcopy")
+S3method("drawLevels", "DNAcopy")
+S3method("estimateStandardDeviation", "DNAcopy")
+S3method("extractSegmentMeansByLocus", "DNAcopy")
+S3method("getChromosomes", "DNAcopy")
+S3method("getSampleNames", "DNAcopy")
+S3method("nbrOfLoci", "DNAcopy")
+S3method("nbrOfSamples", "DNAcopy")
+S3method("nbrOfSegments", "DNAcopy")
+S3method("writeSegments", "DNAcopy")
+
+# matrix
+S3method("seqOfSegmentsByDP", "matrix")
+
+# NonPairedPSCBS
+S3method("callROH", "NonPairedPSCBS")
+S3method("getLocusData", "NonPairedPSCBS")
+S3method("resegment", "NonPairedPSCBS")
+S3method("updateMeans", "NonPairedPSCBS")
+
+# numeric
+S3method("testROH", "numeric")
+
+# PairedPSCBS
+S3method("adjustPloidyScale", "PairedPSCBS")
+S3method("applyByRegion", "PairedPSCBS")
+S3method("arrowsC1C2", "PairedPSCBS")
+S3method("arrowsDeltaC1C2", "PairedPSCBS")
+S3method("bootstrapCIs", "PairedPSCBS")
+S3method("bootstrapDHByRegion", "PairedPSCBS")
+S3method("bootstrapSegmentsAndChangepoints", "PairedPSCBS")
+S3method("bootstrapTCNandDHByRegion", "PairedPSCBS")
+S3method("calcStatsForCopyNeutralABs", "PairedPSCBS")
+S3method("callAB", "PairedPSCBS")
+S3method("callABandHighAI", "PairedPSCBS")
+S3method("callABandLowC1", "PairedPSCBS")
+S3method("callAllelicBalanceByDH", "PairedPSCBS")
+S3method("callCopyNeutral", "PairedPSCBS")
+S3method("callCopyNeutralByTCNofAB", "PairedPSCBS")
+S3method("callExtremeAllelicImbalanceByDH", "PairedPSCBS")
+S3method("callGainNeutralLoss", "PairedPSCBS")
+S3method("callGNL", "PairedPSCBS")
+S3method("callGNLByTCNofAB", "PairedPSCBS")
+S3method("callGNLByTCNofABv1", "PairedPSCBS")
+S3method("callLOH", "PairedPSCBS")
+S3method("callLowC1ByC1", "PairedPSCBS")
+S3method("callNTCN", "PairedPSCBS")
+S3method("callROH", "PairedPSCBS")
+S3method("callROHOneSegment", "PairedPSCBS")
+S3method("clearBootstrapSummaries", "PairedPSCBS")
+S3method("drawChangePointsC1C2", "PairedPSCBS")
+S3method("drawConfidenceBands", "PairedPSCBS")
+S3method("drawLevels", "PairedPSCBS")
+S3method("estimateDeltaAB", "PairedPSCBS")
+S3method("estimateDeltaABBySmallDH", "PairedPSCBS")
+S3method("estimateDeltaCN", "PairedPSCBS")
+S3method("estimateDeltaLOH", "PairedPSCBS")
+S3method("estimateDeltaLOHByMinC1ForNonAB", "PairedPSCBS")
+S3method("estimateHighDHQuantileAtAB", "PairedPSCBS")
+S3method("estimateKappa", "PairedPSCBS")
+S3method("estimateKappaByC1Density", "PairedPSCBS")
+S3method("estimateMeanForDH", "PairedPSCBS")
+S3method("estimateStdDevForHeterozygousBAF", "PairedPSCBS")
+S3method("extractC1C2", "PairedPSCBS")
+S3method("extractCallsByLocus", "PairedPSCBS")
+S3method("extractCNs", "PairedPSCBS")
+S3method("extractDeltaC1C2", "PairedPSCBS")
+S3method("extractDhSegment", "PairedPSCBS")
+S3method("extractLocusLevelC1C2", "PairedPSCBS")
+S3method("extractLocusLevelTCN", "PairedPSCBS")
+S3method("extractMinorMajorCNs", "PairedPSCBS")
+S3method("extractSegmentDataByLocus", "PairedPSCBS")
+S3method("extractSegments", "PairedPSCBS")
+S3method("extractTCNAndDHs", "PairedPSCBS")
+S3method("findBootstrapSummaries", "PairedPSCBS")
+S3method("getBootstrapLocusSets", "PairedPSCBS")
+S3method("getChromosomeOffsets", "PairedPSCBS")
+S3method("getChromosomeRanges", "PairedPSCBS")
+S3method("getLocusData", "PairedPSCBS")
+S3method("hasBootstrapSummaries", "PairedPSCBS")
+S3method("linesC1C2", "PairedPSCBS")
+S3method("linesDeltaC1C2", "PairedPSCBS")
+S3method("mergeTwoSegments", "PairedPSCBS")
+S3method("plot", "PairedPSCBS")
+S3method("plotC1C2", "PairedPSCBS")
+S3method("plotDeltaC1C2", "PairedPSCBS")
+S3method("plotTracks", "PairedPSCBS")
+S3method("plotTracks1", "PairedPSCBS")
+S3method("plotTracks2", "PairedPSCBS")
+S3method("plotTracksManyChromosomes", "PairedPSCBS")
+S3method("pointsC1C2", "PairedPSCBS")
+S3method("pointsDeltaC1C2", "PairedPSCBS")
+S3method("postsegmentTCN", "PairedPSCBS")
+S3method("resegment", "PairedPSCBS")
+S3method("segmentByNonPairedPSCBS", "PairedPSCBS")
+S3method("segmentByPairedPSCBS", "PairedPSCBS")
+S3method("seqOfSegmentsByDP", "PairedPSCBS")
+S3method("shiftTCN", "PairedPSCBS")
+S3method("tileChromosomes", "PairedPSCBS")
+S3method("unTumorBoost", "PairedPSCBS")
+S3method("updateMeans", "PairedPSCBS")
+S3method("updateMeansC1C2", "PairedPSCBS")
+S3method("updateMeansTogether", "PairedPSCBS")
+
+# PSCBS
+S3method("append", "PSCBS")
+S3method("as.data.frame", "PSCBS")
+S3method("drawChangePoints", "PSCBS")
+S3method("extractChromosomes", "PSCBS")
+S3method("getChangePoints", "PSCBS")
+S3method("getLocusData", "PSCBS")
+S3method("getLocusSignalNames", "PSCBS")
+S3method("getSegments", "PSCBS")
+S3method("getSegmentTrackPrefixes", "PSCBS")
+S3method("isSegmentSplitter", "PSCBS")
+S3method("writeSegments", "PSCBS")
diff --git a/NEWS b/NEWS
new file mode 100644
index 0000000..8b7bf0f
--- /dev/null
+++ b/NEWS
@@ -0,0 +1,1758 @@
+Package: PSCBS
+==============
+
+Version: 0.61.0 [2016-02-03]
+o Package now requires R (>= 3.1.2) released October 2014, because
+ of its dependency on the listenv package.
+o segmentByPairedPSCBS() gained argument 'rho' for paired PSCBS
+ segmentation on total CNs (TCNs) and decrease-of-heterozygosity
+ signals (DHs) as an alternative to for instance TCN and
+ allele B fractions (BAFs).
+o BUG FIX: Segmentation using futures where not fully reproducible
+ when known segments where specified. Fixed by changing how the
+ random number stream is set and used.
+
+
+Version: 0.60.0 [2015-11-17]
+o PARALLEL: Add support for parallel processing via futures by
+ utilizing the future package. Parallel segmentation over multiple
+ chromosomes (or known segments) done by segmentByCBS() and
+ segmentByPairedPSCBS() is enabled by future::plan("multicore").
+o REPRODUCIBILITY: Whenever argument 'seed' is given, the
+ L'Ecuyer-CMRG stream is now used to generate random numbers.
+ For backward compatibility with other types of random number
+ generators, don't specify argument 'seed' but instead use
+ set.seed() to set the seed before calling the method.
+o Bump package dependencies.
+
+
+Version: 0.50.0 [2015-10-14]
+o Now argument 'preserveScale' for segmentByPairedPSCBS() defaults
+ to FALSE. In the past the default has effectively been TRUE, but
+ has given a warning since v0.43.0 (June 2014) that it eventually
+ will be changed to FALSE. Now it will give a warning that it
+ has changed, unless the option is explicitly specified. This
+ new warning will eventually be removed in a future version.
+
+
+Version: 0.45.1 [2015-09-16]
+o More informative error messages when append() for CBS or PSCBS fail.
+o BUG FIX: segmentByCBS(, ..., w, knownSegments) would give internal
+ assertion errors if one of the priorly known segments would have
+ zero data points. Thanks to Kirill Tsukanov (Moscow) and
+ Eric Talevich (UCSF) for reporting on this.
+
+
+Version: 0.45.0 [2015-09-11]
+o segmentByCBS() gained argument 'avg'.
+o Add writeWIG() for CBS objects.
+o pruneByHClust() no longer gives a message about method "ward"
+ is now named "ward.D".
+o Added skip=TRUE to report().
+o ROBUSTNESS: Package test coverage is 62%.
+o ROBUSTNESS: Explicitly importing core R functions.
+o FIX: plotTracks() for CBS ignored arguments 'cex', 'col' and
+ 'meanCol' if two or more chromosomes were plotted.
+o BUG FIX: joinSegments(), resetSegments() and pruneBySdUndo() gave
+ errors for multi-chromosome (>= 2) segmentation results.
+o BUG FIX: segmentByCBS() would ignore argument 'w' (weights) if
+ more than one chromosome was fitted.
+o BUG FIX: tileChromosomes() for CBS returned incorrect locus data.
+o BUG FIX: gapsToSegments(gaps) gave an error if nrow(gaps) == 0
+ or contained no 'chromosome' column.
+o BUG FIX: findLargeGaps() could return NULL. Now it always returns
+ a data.frame.
+o BUG FIX: The report() RSP-embedded TeX templates for CBS and
+ PairedPSCBS data did not escape sample and data set names
+ to LaTeX in all places needed.
+o Package now requires R (>= 3.1.1) released July 2014. This allows
+ us to use BioC (>= 3.0) (October 2014).
+
+
+Version: 0.44.0 [2015-02-22]
+o ROBUSTNESS: Package test coverage is 58%.
+o ROBUSTNESS: Forgot to declare some S3 methods in NAMESPACE.
+o SPEEDUP: Now using more functions of matrixStats.
+o CLEANUP: bootstrapDHByRegion() is defunct (was deprecated since 2013).
+o Package now requires R (>= 3.0.3) and BioC (>= 2.13), which are
+ from March 2014 and are in fact old. It's recommended to use a
+ more recent version of R.
+
+
+Version: 0.43.0 [2014-06-08]
+o Now segmentByPairedPSCBS() gives a warning about future change of the
+ default value of argument 'preserveScale' (from current TRUE to FALSE).
+ The warning only appears if the argument is not specified explicitly.
+o Now using use() of R.utils where possible.
+o Package now requires R (>= 3.0.0) and BioC (>= 2.13), which were
+ released April 2013 and are in fact old and it's recommended to
+ use a more recent version of R.
+o Bumped package dependencies.
+
+
+Version: 0.42.2 [2014-05-24]
+o Bumped package dependencies.
+
+
+Version: 0.42.1 [2014-05-05]
+o BUG FIX: pruneByHClust() for PairedPSCBS would give an error on
+ "unable to find an inherited method for function 'anyMissing' for
+ signature '"PairedPSCNSegments"'", unless the object contained
+ bootstrap statistics. This is no longer needed. Thanks to
+ Junsong Zhao, Los Angeles, CA for reporting on this.
+
+
+Version: 0.42.0 [2014-04-25]
+o SPEEDUP: Minor speedup (a few percents) by now byte compiling the
+ package by default.
+o CLEANUP: Dropped unnecessary usage of '::'.
+o Bumped package dependencies.
+
+
+Version: 0.41.4 [2014-03-30]
+o GENERALIZATION: Now callROH() also works if paired PSCBS was done
+ with only 'muN' available (and not 'betaN'). In that case, it assumes
+ that all genotype confidence scores are equal.
+o Updated the ordering and the defaults of testROH() arguments to make
+ it clear that 'betaN' is optional and only used if 'csN' is not given.
+o As an alternative to argument 'CT', segmentByPairedPSCBS() now accepts
+ arguments 'thetaT' and 'thetaN', in case 'CT' is calculated as
+ CT=2*thetaT/thetaN.
+
+
+Version: 0.41.3 [2014-03-29]
+o Methods no longer generates warnings on "in max(c(NA_integer_,
+ NA_integer_), na.rm = TRUE) : no non-missing arguments to max;
+ returning -Inf".
+o BUG FIX: In rare cases, callROH() could throw "Error in if
+ (is.na(delta)) { : argument is of length zero".
+
+
+Version: 0.41.2 [2014-03-28]
+o Added argument 'preserveScale' to segmentByPairedPSCBS(), which is
+ passed as is to normalizeTumorBoost() with the default being TRUE
+ corresponding to the previous default behavior.
+
+
+Version: 0.41.1 [2014-03-28]
+o Added unTumorBoost() to recalculating the segment means and other
+ statistics for a given PairedPSCBS profile based on non-TumorBoosted
+ tumor BAFs (rather than TumorBoost:ed tumor BAFs).
+
+
+Version: 0.41.0 [2014-03-26]
+o Now estimateKappaByC1Density() give more informative error messages
+ if it failed to identify modes for estimating the parameter.
+o Added argument 'from' to estimateKappaByC1Density().
+o BUG FIX: updateMeansC1C2() for PairedPSCBS did not handle missing
+ values (=splitters) in the 'c1c2Swap' field.
+o BUG FIX: updateMeans() for PairedPSCBS and NonPairedPSCBS returned the
+ incorrect DH segment levels for region in AB if adjustFor="ab" and
+ likewise for segments in LOH if adjustFor="loh". This bug does *not*
+ affect any of PSCBS methods themselves, because none of them utilizes
+ those 'adjustFor' options.
+o Bumped package dependencies.
+
+
+Version: 0.40.4 [2014-02-04]
+o BUG FIX: all.equal() for CBS would pass the first/dispatch argument
+ to NextMethod() as 'target=target' and not as 'object=target', which
+ would result in it being passed it twice both named and non-named
+ where the latter would become argument 'tolerance=target' in an
+ internal call to all.equal() for numerics. In recent R-devel version
+ this would generate "Error in all.equal.numeric(target[[i]],
+ current[[i]], check.attributes = check.attributes, : 'tolerance'
+ should be numeric Calls: stopifnot ... all.equal.default ->
+ all.equal.list -> all.equal -> all.equal.numeric".
+
+
+Version: 0.40.3 [2014-01-29]
+o ROBUSTNESS: Now segmentByPairedPSCBS() asserts that argument 'muN'
+ is not all NAs. Similarily, if 'muN' is called from 'betaN' the
+ same assertion is done after calling.
+
+
+Version: 0.40.2 [2013-12-17]
+o Now estimateDeltaCN() for CBS have the option to estimate the size
+ of a copy-number unit based on the change-point magnitutes, in
+ addition to the estimator based on the density of segment means.
+o BUG FIX: getChangePoints() for CBS returned empty results.
+
+
+Version: 0.40.1 [2013-12-09]
+o DOCUMENTATION: The CBS vignette referred to C1 and C2 in one of
+ the code examples.
+o Bumped package dependencies.
+
+
+Version: 0.40.0 [2013-12-07]
+o CLEANUP: No longer need for an ad hoc NAMESPACE import.
+
+
+Version: 0.39.8 [2013-12-04]
+o DOCUMENTATION: Now the vignette sections on dropping outliers
+ before segmentation explains why outliers are dropped whereas in
+ the original CBS publication they were shrunk ("smoothed").
+ Also, added help for dropSegmentationOutliers().
+
+
+Version: 0.39.7 [2013-11-27]
+o Added callGLAO() for CBS.
+o Added encodeCalls() for 'data.frame' object returned by
+ getLocusData(..., addCalls=TRUE).
+o Bumped package dependencies.
+
+
+Version: 0.39.6 [2013-11-23]
+o Added clearCalls() for AbstractCBS.
+o Added extractSegmentDataByLocus() for PairedPSCBS.
+o BUG FIX: estimateDeltaCN() for CBS assumed aroma.light was attached.
+
+
+Version: 0.39.5 [2013-11-15]
+o Added estimateDeltaCN() for CBS. Added package system test.
+
+
+Version: 0.39.4 [2013-11-14]
+o BUG FIX: callGainsAndLosses() for CBS would not estimate the median
+ median CN level correctly if there were "empty" segments (e.g. gaps).
+ This was/is due to a bug in segments.summary() of the DNAcopy package.
+ Instead, we are now calculating the segment median levels ourselves.
+ Added a system package test for callGainsAndLosses().
+
+
+Version: 0.39.3 [2013-11-05]
+o Added basic implementations of setLocusData() and setSegments()
+ for AbstractCBS.
+
+
+Version: 0.39.2 [2013-10-28]
+o Now plotTracksManyChromosomes() for PairedPSCBS also supports
+ tracks "c1,c2", "c1" and "c2".
+
+
+Version: 0.39.1 [2013-10-25]
+o Now plotTracksManyChromosomes() uses the locus data field 'rho'
+ when plotting DH locus-level data. It only recalculates it from
+ the tumor BAFs if the DH signals are not available - if so a
+ warning is generated.
+o BUG FIX: The 'rho' signals returned by getLocusData(..., fields="full")
+ for PairedPSCBS would have values also for homozygote SNPs.
+
+
+
+Version: 0.39.0 [2013-10-23]
+o Now all warnings generated by DNAcopy::CNA() are suppressed,
+ including the common one on "array has repeated maploc positions".
+o Added getBootstrapLocusSets() for PairedPSCBS. Added a package
+ system test for it.
+o Added argument 'subset' to applyByRegion() for PairedPSCBS.
+o Added clearBootstrapSummaries() for PairedPSCBS.
+o SPEEDUP: Added argument 'cache' to bootstrapSegmentsAndChangepoints(),
+ which caches the results to file if cache=TRUE.
+
+
+Version: 0.38.6 [2013-10-20]
+o Internal restructuring on how bootstrapping of segment means is done.
+o BUG FIX: plotTracks() for PairedPSCBS would use argument 'Clim'
+ for 'Blim' as well, regardless of what argument 'Blim' is. This
+ bug was introduced in v0.38.3.
+
+
+Version: 0.38.5 [2013-10-18]
+o BUG FIX: The CBS and Paired PSCBS report templates assumed that
+ the 'R.utils' package is attached.
+
+
+Version: 0.38.4 [2013-10-15]
+o CLEANUP: Removed a few unnecessary NAMESPACE imports.
+o Bumped package dependencies.
+
+
+Version: 0.38.3 [2013-10-14]
+o Now plotTracks() for CBS and PSCBS gives a more informative error if
+ 'Clim' or 'Blim' is invalid. If using "auto" (only for CBS) and the
+ limits could not be inferred due to an unknown or unset signal type,
+ an informative error message reports on this as well.
+o Now the package vignettes are in vignettes/ and not in inst/doc/,
+ which will not be supported by R (>= 3.1.0).
+o ROBUSTNESS: The overriding of append() to become a generic
+ function does now call base::append() in the default, instead
+ of copy the latter. All this will eventually be removed,
+ when proper support for c, [, [[ etc. has been added everywhere.
+o CLEANUP: Now explicitly importing only what is needed in NAMESPACE.
+
+
+Version: 0.38.2 [2013-10-13]
+o BUG FIX: While attaching the package, it could cause a cyclic
+ loading of namespaces.
+
+
+Version: 0.38.1 [2013-10-08]
+o Now getSmoothLocusData() for CBS also returns column 'count' which
+ specifies the number of (finite) loci averaged over in each bin.
+o DOCUMENTATION: Vignette 'Total copy-number segmentation using CBS'
+ would display the same plot as vignette 'Parent-specific copy-number
+ segmentation using Paired PSCBS'.
+o DOCUMENTATION: Renamed vignette 'Paired PSCBS' to 'Parent-specific
+ copy-number segmentation using Paired PSCBS'.
+o BUG FIX: tileChromosomes() for CBS did not set "tiledChromosomes"
+ attribute due to a typo. This caused plotTracks() for CBS to
+ horizontally misplace the plotted segment levels.
+ Added a system tests for this for CBS and PairedPSCBS objects.
+ Thanks to Ilari Scheinin at VUMC for reporting on this.
+o Bumped package dependencies.
+
+
+Version: 0.38.0 [2013-09-27]
+o SPEEDUP: 'R CMD check' is now significantly faster due to
+ copying of pre-generated calculations ("memoization").
+ For instance, the the same segmentation tests are roughly
+ 40% faster with this version compared to v0.37.2.
+o Now PSCBS imports 'R.cache' (used to only suggest it).
+
+
+Version: 0.37.2 [2013-09-27]
+o SPEEDUP: Now utilizing 'matrixStats' functions in more places.
+o ROBUSTNESS: Further improved how aroma.light is handled for
+ backward compatibility.
+o Bumped package dependencies.
+
+
+Version: 0.37.1 [2013-09-26]
+o CLEANUP: Now package avoids attaching suggested packages such as
+ 'R.cache', 'aroma.light', and 'Hmisc' by only importing the set of
+ functions needed via '::'. This way those packages are only loaded.
+ Packages that still need to be attached are done so "quietly".
+o CLEANUP: Minor adjustments to some of the internal workarounds
+ for older versions of 'matrixStats' and 'aroma.light'.
+o BUG FIX: Forgot to import several functions from 'matrixStats'.
+ These went undetected because 'aroma.light' (<= 1.31.5) attaches
+ the 'matrixStats'.
+o BUG FIX: segmentByPairedPSCBS() assumed 'aroma.light' was attached.
+o BUG FIX: One of the system tests assumed 'R.utils' was attached.
+
+
+Version: 0.37.0 [2013-09-21]
+o CLEANUP: Package no longer attaches 'R.utils', only imports it.
+o BUG FIX/WORKAROUND: For now, package attaches the 'utils' package.
+ This is needed due to what appears to be a bug in how 'R.oo'
+ finalizes Object:s assuming 'utils' is attached, which may not be
+ the case (unless 'R.oo' itself is attached).
+o ROBUSTNESS: Now package imports only what is needed from 'DNAcopy'.
+o BUG FIX: callGNL() for PairedPSCBS used non-defined 'verbose' object.
+
+
+Version: 0.36.2 [2013-09-18]
+o DOCUMENTATION: Added vignette 'Total copy-number segmentation using CBS'.
+o ROBUSTNESS: Now package imports 'matrixStats' (previously suggested).
+o ROBUSTNESS: Now package declares S3 methods in the NAMESPACE.
+o ROBUSTNESS: Package vignettes no longer assumes that the 'R.rsp'
+ package is attached.
+o ROBUSTNESS: Forgot to import R.methodsS3::appendVarArgs().
+o WORKAROUND: For R (< 3.0.0), hclustCNs() for AbstractCBS would generate
+ 'Error in rowAlls(ok) : could not find function "loadMethod"'. This
+ seems to be a bug in R (< 3.0.0), which we can avoid by attaching the
+ 'methods' package in hclustCNs().
+o Bumped package dependencies.
+
+
+Version: 0.36.1 [2013-09-10]
+o CLEANUP: Package no longer utilizes ':::'.
+
+
+Version: 0.36.0 [2013-08-15]
+o Made extractMinorMajorCNs() for PairedPSCBS acknowledge additional
+ fields related to (C1,C2).
+
+
+Version: 0.35.6 [2013-08-01]
+o Updated the vignettes to utilize the new R.rsp features.
+
+
+Version: 0.35.5 [2013-07-19]
+o ROBUSTNESS: Added a sanity check on the estimates of (tauA, tauB)
+ when they are estimated from data in segmentByNonPairedPSCBS().
+
+
+Version: 0.35.4 [2013-07-11]
+o Updated the Makefile for the vignettes and added .Rinstignore such
+ that auxiliary (bib and bst) LaTeX files are not installed but
+ part of the build so they are available to R CMD check, which
+ is recently needed by R devel.
+o Bumped package dependencies.
+
+
+Version: 0.35.3 [2013-05-25]
+o Minor speedup by replacing all rm(x) with x <- NULL, cf. R-devel
+ thread 'Assigning NULL to large variables is much faster than rm() -
+ any reason why I should still use rm()?' on May 25, 2013.
+
+
+Version: 0.35.2 [2013-05-20]
+o CRAN POLICY: Now all Rd \usage{} lines are at most 90 characters long.
+
+
+Version: 0.35.1 [2013-05-07]
+o Now estimateDeltaCN() for PairedPSCBS adjust for the ploidy if set.
+o Added ploidy() and ploidy()<- for AbstractCBS.
+o Now tileChromosomes() no longer gives warnings on "max(i): no
+ non-missing arguments to max; returning -Inf".
+
+
+Version: 0.35.0 [2013-04-23]
+o SPEEDUP: Now bootstrapTCNandDHByRegion() for PairedPSCBS always
+ estimates the default quantiles in addition to any requested ones.
+o SPEEDUP: Made bootstrapTCNandDHByRegion() much faster by adding
+ use.names=FALSE to two internal unlist() statements.
+o BUG FIX: updateMeans() for PairedPSCBS and NonPairedPSCBS could
+ include a signal from a neighboring segment when averaging, iff
+ that signal was located at the exact locus of the change point.
+ Thanks Ingrid L�nnstedt (WEHI) for reporting on this.
+
+
+Version: 0.34.9 [2013-04-22]
+o Utilizing new startupMessage() of R.oo.
+o BUG FIX: updateMeans() would not always preserve the originally
+ specified segment-mean level estimator, if different from a
+ (sample) mean estimator, e.g. avgDH="median". This could result
+ in for instance callAB() failing on internal sanity checks.
+o BUG FIX: Segment levels drawn by plotTracks() would have incorrect
+ genomic locations for chromosome 2 and beyond. This bug was
+ introduced in v0.34.7.
+
+
+Version: 0.34.8 [2013-04-20]
+o CLEANUP: Removed previously deprecated methods for AbstractCBS.
+
+
+Version: 0.34.7 [2013-04-18]
+o Added more arguments to plotTracks().
+o Now drawLevels() and drawConfidenceBands() for CBS and PairedPSCBS
+ also works for multiple chromosomes.
+o One of the system tests for segmentByPairedPSCBS() failed
+ in the case when the data was downsampled (in order to meet
+ the CRAN requirements). The workaround is to use a fix deltaAB
+ parameter in that case.
+o BUG FIX: Internal calcStatsForCopyNeutralABs() would give an
+ error if there was exactly two AB segments.
+
+
+Version: 0.34.6 [2013-04-11]
+o BUG FIX: plotTracks(fit, callLoci=TRUE) would color loci incorrectly
+ if more than one chromosome are plotted.
+
+
+Version: 0.34.5 [2013-04-09]
+o ROBUSTNESS: Now callROH() gives an informative error if called
+ on a NonPairedPSCBS object.
+
+
+Version: 0.34.4 [2013-04-05]
+o Added more end-user control to plotTracks().
+
+
+Version: 0.34.3 [2013-04-04]
+o Now package builds with both R.rsp (< 0.9.1) and R.rsp (>= 0.9.1).
+
+
+Version: 0.34.2 [2013-03-28]
+o Updated callGainNeutralLoss(), which now by default utilizes
+ callCopyNeutral().
+
+
+Version: 0.34.1 [2013-03-21]
+o Updated the report generator and its RSP templates.
+o DOCUMENTATION: Clarified in the PSCBS vignette that the NTCN
+ caller is under development, experimental.
+o SPEEDUP: Made dropChangePoints() faster by only updating the
+ segment statistics/means at the very end.
+
+
+Version: 0.34.0 [2013-03-19]
+o CALLING: Defined a formal hypothesis test for how segments are called
+ copy-neutral in TCN (NTCN), with the null hypothesis being that a
+ segment is NTCN. In order for a segment to not be NTCN, its confidence
+ interval has to be completely outside the null region. This changed
+ how callCopyNeutralByTCNofAB() for PairedPSCBS calls segments; it is
+ now a bit more conservative in rejecting NTCN.
+
+
+Version: 0.33.4 [2013-03-19]
+o ROBUSTNESS: Now calcStatsForCopyNeutralABs() for PairedPSCBS does
+ a better job in identifying the TCN mode of the AB segments.
+o Added argument 'flavor' to findNeutralCopyNumberState() specifying
+ how to identify the main mode of the AB segments.
+o VISUALIZATION: Now plotTracks() for PairedPSCBS displays thresholds
+ for calling AB, LOH and and NTCN.
+
+
+Version: 0.33.3 [2013-03-12]
+o DOCUMENTATION: Documented 'tauA' and 'tauB' in the help for
+ segmentByNonPairedPSCBS().
+
+
+Version: 0.33.2 [2013-03-09]
+o Added getLocusData() for PairedPSCBS and NonPairedPSCBS.
+o Added an Authors at R field to the DESCRIPTION.
+o DOCUMENTATION: Updated the vignettes and the report templates to
+ utilize the new ggplot2 themes - ggplot2 no longer gives a
+ warning on using deprecated functions.
+o Now report() for AbstractCBS also includes files listed in the
+ optional file '.install_extras' of the source RSP template
+ directory. The same filename is used by 'R CMD build/check' for
+ including additional source files needed to build the vignettes.
+
+
+Version: 0.33.1 [2013-03-07]
+o Relaxed the internal precision tests of testROH(). This was done
+ in response to the CRAN farm lowering its precision on some hosts.
+o DOCUMENTATION: Preparing package vignettes for the upcoming
+ R 3.0.0 support for non-Sweave vignettes.
+
+
+Version: 0.33.0 [2013-03-05]
+o Added argument 'typeOfWeights' to estimateKappaByC1Density() for
+ PairedPSCBS, and hence indirectly to estimateKappa(). The default
+ is typeOfWeights="dhNbrOfLoci", which may give too much overall
+ weight to very long segments causing the estimator to fail when
+ there are only a few number of "C1 = 0" segments. An alternative
+ is to use typeOfWeights="sqrt(dhNbrOfLoci)".
+
+
+Version: 0.32.6 [2013-03-04]
+o DOCUMENTATION: Updated the help usage section for all static methods.
+
+
+Version: 0.32.5 [2013-02-09]
+o Added a VignetteBuilder field to DESCRIPTION.
+o BUG FIX: bootstrapTCNandDHByRegion() for PairedPSCBS did not
+ bootstrap from all available loci when calculating total CNs
+ statistics, iff the segment had been called run-of-homozygosity
+ (ROH). Internal validation tests caught this. Thanks to Oscar Rueda
+ at the Cancer Research UK Cambridge Institute for reporting on this.
+
+
+Version: 0.32.4 [2013-02-07]
+o Improved some verbose outputs of bootstrapTCNandDHByRegion().
+
+
+Version: 0.32.3 [2013-02-05]
+o Now pruneByHClust() drops any existing segment calls and quantile
+ mean-level estimates.
+
+
+Version: 0.32.2 [2013-02-01]
+o Added resetSegments() for AbstractCBS, which drops extra segments
+ columns (e.g. bootstrap statistics and calls) except those
+ obtained from the segment algorithm.
+o ROBUSTNESS: Now aroma.light is explicitly required in cases
+ where it is needed.
+o DOCUMENTATION: Added a paragraph on avgDH="median" to the PSCBS
+ vignette's 'Experimental' section.
+
+
+Version: 0.32.1 [2013-02-01]
+o BUG FIX: segmentByPairedPSCBS(..., avgDH="median") only worked for
+ single-chromosome data. Same for avgTCN="median". Thanks Ritu Roy
+ at UCSF for reporting on this.
+
+
+Version: 0.32.0 [2013-01-16]
+o Added arguments 'avgTCN' and 'avgDH' to segmentByPairedPSCBS().
+o Now updateMeans() and updateMeansTogether() methods can estimate
+ the mean levels either by the sample mean or the median.
+
+
+Version: 0.31.0 [2013-01-05]
+o CLEANUP: Now packages R.methodsS3 and R.oo are only imported.
+o CLEANUP: Package no longer explicitly imports digest.
+
+
+Version: 0.30.0 [2012-11-05]
+o GENERALIZATION: Now bootstrapTCNandDHByRegion() works for more
+ "flavors", e.g the default ('tcn') used by segmentByNonPairedPSCBS().
+
+
+Version: 0.29.9 [2012-11-05]
+o DOCUMENTATION FIX: example(segmentByNonPairedPSCBS) was for
+ the paired case.
+o CRAN POLICY: Further speed up of examples such that they run faster
+ with R CMD check.
+
+
+Version: 0.29.8 [2012-11-04]
+o CLEANUP: Replaced all whichVector() with which(), because the
+ latter is now the fastest again.
+
+
+Version: 0.29.7 [2012-11-03]
+o Updated deprecated ggplot2 functions in the RSP reports.
+
+
+Version: 0.29.6 [2012-11-01]
+o Bumped package dependencies.
+o CRAN POLICY: Made the examples run faster for R CMD check.
+
+
+Version: 0.29.5 [2012-10-16]
+o ROBUSTNESS/BUG FIX: No longer passing '...' to NextMethod(), cf.
+ R-devel thread 'Do *not* pass '...' to NextMethod() - it'll do it
+ for you; missing documentation, a bug or just me?' on Oct 16, 2012.
+
+
+Version: 0.29.4 [2012-09-23]
+o Now plotTracks() [and plotTracksManyChromosomes()] draws segment levels
+ such that it is easier to see them even when they are overlapping.
+
+
+Version: 0.29.3 [2012-09-21]
+o SPEEDUP: By default bootstrapTCNandDHByRegion() for PairedPSCBS no
+ longer do sanity checks within the bootstrap loop. This significantly
+ speed up the method. To run checks, use argument .debug=TRUE.
+ In addition, the callNnn() methods that need to call this method,
+ does it by decreasing the amount of verbose output substantially,
+ which in turn speeds up the process a fair bit.
+o Now getSegments(..., splitters=TRUE) for CBS and PSCBS inserts NA
+ rows wherever there is a "gap" between segments. A "gap" is when
+ two segments are not connected (zero distance).
+o ROBUSTNESS: Now append() for CBS and PSCBS drops column 'length'
+ from 'knownSegments', iff it exists.
+o Now nbrOfChangePoints() for AbstractCBS calculates only change points
+ of connected neighboring segments.
+o BUG FIX: seqOfSegmentsByDP() for AbstractCBS would not handle empty
+ segments, which could occur if 'knownSegments' for instance included
+ centromere gaps.
+o BUG FIX: segmentByCBS(... knownSegments) could return segments for
+ chromosome 0 even though it did not exist in the input data.
+
+
+Version: 0.29.2 [2012-09-18]
+o REPORT: Now report() for AbstractCBS looks for the RSP template in
+ templates/, and as a backup in templates,PSCBS/. If the latter does
+ not exist, it is automatically created as a soft link to templates/
+ of the PSCBS package. This allows anyone to create their own
+ customized copy (in templates/) of the default PSCBS RSP report.
+o REPORT: Now report(fit, ..., rspTags) for AbstractCBS looks for the
+ RSP template named <className>(,<rspTags>),report.tex.rsp, where
+ className is class(fit)[1] and argument 'rspTags' is an optional
+ comma-separated character string/vector. This makes it possible
+ to have different types of report for the same class of objects.
+o REPORT: Added argument 'force' to report() for AbstractCBS. This
+ will copy the RSP template files again, although they are already
+ in reports/ output directory.
+
+
+Version: 0.29.1 [2012-09-15]
+o Added argument 'dropMissingCT' to segmentByPairedPSCBS().
+
+
+Version: 0.29.0 [2012-09-14]
+o Added trial version of pruneByDP() for AbstractCBS.
+
+
+Version: 0.28.6 [2012-09-13]
+o Now tileChromosomes() also adjusts 'knownSegments'.
+o Added argument 'dropGaps' to gapsToSegments().
+o Updated all.equal() for AbstractCBS to compare locus-level data,
+ segments, and other fields.
+
+
+Version: 0.28.5 [2012-09-13]
+o SPEEDUP: Now segmentByCBS(..., undo=+Inf) returns much faster, which
+ is possible because there is no need to identify new change points.
+
+
+Version: 0.28.4 [2012-09-13]
+o CONSISTENCY FIX: Changed the behavior of extreme values of argument
+ 'undo' to segmentByCBS() such that 'undo=0' (was 'undo=+Inf') now
+ means that it will not ask DNAcopy::segment() to undo the segmentation,
+ and such that 'undo=+Inf' means that no changepoints will be identified.
+ The latter case allows you to effectively skip the segmentation but
+ still calculate all the CBS statistics across a set of known segments
+ via segmentByCBS(..., undo=+Inf, knownSegments=knownSegments).
+ Arguments 'undoTCN' and 'undoDH' to segmentByPairedPSCBS() are
+ adjusted analogously. Corresponding system tests were added.
+
+
+Version: 0.28.3 [2012-08-30]
+o Updated code and Rd cross reference to use the 'matrixStats'
+ package for weightedMedian(), which used to be in 'aroma.light'.
+
+
+Version: 0.28.2 [2012-08-20]
+o BUG FIX: segmentByNonPairedPSCBS() forgot to specify namespace
+ aroma.light when trying to call findPeaksAndValleys().
+
+
+Version: 0.28.1 [2012-08-15]
+o Minor grammatical corrections of the Paired PSCBS vignette.
+
+
+Version: 0.28.0 [2012-07-22]
+o Added argument 'minLength' to gapsToSegments(). The default is no
+ longer to drop zero-length (minLength == -1L) segments, because
+ if (and only if) such a segment contains a locus, then segmentByNnn()
+ will currently generate an (internal) error.
+o GENERALIZATION/BUG FIX: Now segmentByPairedPSCBS() drops loci for
+ which CT is missing (regardless of betaT). For instance, in rare cases
+ when the reference (e.g. the normal) is missing, then it may be that
+ CT is missing while betaT is not.
+
+
+Version: 0.27.4 [2012-07-22]
+o Now verbose output of segmentByPairedPSCBS() specifies region
+ ranges with greater precision.
+
+
+Version: 0.27.3 [2012-07-10]
+o DOCUMENTATION: Minor updates to the Paired PSCBS vignettes.
+o CLEANUP: One redundancy tests relied on a non-critical function
+ that will be removed in R.utils 1.16.0 (now in R.devices 2.1.1).
+
+
+Version: 0.27.2 [2012-07-08]
+o Updated package dependencies.
+
+
+Version: 0.27.1 [2012-07-02]
+o Now we refer to "copy neutral" segments as "neutral TCN" segments
+ with acronym 'NTCN'. The corresponding column in the segmentation
+ results are labeled correspondingly. The Paired PSCBS vignette
+ was updated accordingly.
+
+
+Version: 0.27.0 [2012-06-24]
+o (An update that should be ignored)
+o DOCUMENTATION: Some grammar corrections of the 'Paired PSCBS' vignette.
+
+
+Version: 0.26.1 [2012-06-05]
+o Now segmentByCBS() for data frame:s does a better job identifying
+ the CN signals.
+
+
+Version: 0.26.0 [2012-06-03]
+o DOCUMENTATION: Added details to the Paired PSCBS vignette on how
+ to call segments that are copy neutral (typically diploid).
+o Now argument 'delta' for callCopyNeutralByTCNofAB() of PairedPSCBS
+ is calculated via estimateDeltaCN(), which estimates the width
+ of the acceptance regions, used for calling copy neutral states,
+ to be a function of the normal contamination.
+
+
+Version: 0.25.3 [2012-06-03]
+o BUG FIX: all.equal(target, current) for CBS objects would give an
+ error if either 'target' or 'current' had zero segments.
+
+
+Version: 0.25.2 [2012-05-30]
+o Added writeSegments() for DNAcopy objects.
+o BUG FIX: as.CNA() for DNAcopy added incorrect chromosome splitters.
+o BUG FIX: as.CNA() for DNAcopy would ignore argument 'sample' and
+ always return the first sample.
+
+
+Version: 0.25.1 [2012-05-30]
+o DOCUMENTATION: Added details to the Paired PSCBS vignette on how
+ to tune the various callers.
+o Now callROH() records parameter 'deltaROH' in the results.
+o BUG FIX: callLOH(..., force=TRUE) would append multiple 'lohCall'
+ columns, if called multiple times.
+
+
+Version: 0.25.0 [2012-04-20]
+o Added a trial (very much true) version of segmentByNonPairedPSCBS().
+
+
+Version: 0.24.0 [2012-04-20]
+o Now it is possible to skip the DH segmentation in Paired PSCBS, i.e.
+ segmentByPairedPSCBS(..., flavor="tcn").
+
+
+Version: 0.23.2 [2012-04-20]
+o BUG FIX: segmentByPairedPSCBS() would throw "error in `$<-.data.frame
+ `(`*tmp*`, "rho" ..." if some loci had unknown genomic positions.
+
+
+Version: 0.23.1 [2012-04-20]
+o Added RSP report for CBS objects (adopted from ditto for PairedPSCBS).
+o DOCUMENTATION: Updated the 'Paired PSCBS' vignette.
+
+
+Version: 0.23.0 [2012-03-20]
+o DOCUMENTATION: Added a package vignette.
+
+
+Version: 0.22.2 [2012-02-29]
+o BUG FIX: plotTracks(..., add=TRUE) for PairedPSCBS would add TCNs
+ when BAFs and DHs were intended.
+
+
+Version: 0.22.1 [2012-02-28]
+o Updated package dependencies to R.rsp (>= 0.7.3) so that
+ report() for PairedPSCBS no longer require non-public packages.
+o Now it is possible to turn off usage of the alpha channel in
+ plots generated by report(), which can be handy on systems where
+ the default PNG device does not support the alpha channel.
+ Example: setOption("PSCBS::report/useAlphaChannel", FALSE).
+
+
+Version: 0.22.0 [2012-02-27]
+o Added report() for PairedPSCBS.
+
+
+Version: 0.21.0 [2012-02-27]
+o Added argument 'fields' to getLocusData() for PairedPSCBS.
+o Added renameChromosomes() to AbstractCBS.
+
+
+Version: 0.20.0 [2012-02-26]
+o Added alpha version of callGainNeutralLoss() for PairedPSCBS,
+ which certainly will be updated in the future. This caller
+ is tested by the system tests.
+o Added dropChangePoints() for AbstractCBS.
+o Added some internal utility functions for PairedPSCBS taken
+ from the aroma.cn package. Some of these may become public
+ later, but for they should be considered internal.
+o ROBUSTNESS: Added more sanity checks validating the correctness
+ of what is returned by extractSegments() for CBS and PairedPSCBS.
+o BUG FIX: extractSegments() for PairedPSCBS would return incorrect
+ row indices, more precisely, overlapping data chunks.
+o BUG FIX: bootstrapTCNandDHByRegion() for PairedPSCBS would resample
+ from a subset of the intended TCNs, iff the DH mean was non-finite
+ while there were still heterozygous SNPs. This introduced a bias in
+ the estimates, which was neglectable for large segments, but for very
+ small segments (a few loci) it could be relatively large.
+
+
+Version: 0.19.8 [2012-02-23]
+o ROBUSTNESS: Package now explicitly depends on 'utils'.
+
+
+Version: 0.19.7 [2012-02-22]
+o BUG FIX: findLargeGaps() did not handle missing values for
+ argument 'chromosome'.
+o BUG FIX: segmentByCBS(..., knownSegments=knownSegments) would
+ incorrectly throw a sanity-check exception if 'knownSegments'
+ contains a segment with 'start' and 'stop' positions being equal.
+o BUG FIX: Argument 'calls' of plotTracks() for PairedPSCBS was ignored
+ if more than one chromosome was plotted.
+
+
+Version: 0.19.6 [2012-01-24]
+o ROBUSTNESS: Now getCallStatistics() for CBS asserts that calls have
+ been made. If not, an exception is thrown.
+
+
+Version: 0.19.5 [2012-01-21]
+o DOCUMENTATION: Added details to the help of callLOH() and callAB() on
+ the difference between (AB,LOH)=(TRUE,FALSE) and (AB,LOH)=(TRUE,NA).
+o Corrected some of verbose messages of estimateDeltaLOHByMinC1ForNonAB()
+ for PairedPSCBS objects.
+
+
+Version: 0.19.4 [2012-01-10]
+o Now example(segmentByPairedPSCBS) and the system tests that are run
+ by R CMD check are tuned to (by default) run much faster by segmenting
+ using fewer data points and bootstrapping using fewer samples. This
+ update was done to meet the new CRAN policy. By setting environment
+ variable _R_CHECK_FULL_ to '1' the full data set is used instead.
+
+
+Version: 0.19.3 [2012-01-09]
+o ROBUSTNESS: Now extractSegments() for PairedPSCBS gives an informative
+ error message that it is not supported if CNs were segmented using
+ flavor "tcn,dh".
+o BUG FIX: postsegmentTCN() for PairedPSCBS could generate an invalid
+ 'tcnSegRows' matrix, where the indices for two consecutive segments
+ would overlap, which is invalid. Thanks to Minya Pu for reporting
+ on failed sanity check related to this.
+
+
+Version: 0.19.2 [2011-12-29]
+o ROBUSTNESS: Explicitly added 'digest' to the list of suggested packages.
+
+
+Version: 0.19.1 [2011-12-13]
+o Added support for callGainsAndLosses(..., method="ucsf-dmad")
+ of CBS objects.
+
+
+Version: 0.19.0 [2011-12-12]
+o Added optional argument 'indices' to getLocusData() to be able
+ to retrieve the locus-level data as indexed by input data.
+o BUG FIX: Now gapsToSegments() gave invalid segments for chromosomes
+ with more than one gap. Now gapsToSegments() validates argument
+ 'gaps' and asserts that it returns non-overlapping segments.
+o DOCUMENTATION: Clarified in help("segmentByCBS") how missing
+ values are dealt with.
+
+
+Version: 0.18.2 [2011-12-07]
+o Now plotTracks() for CBS always returns an invisible object.
+o BUG FIX: pruneBySdUndo() for CBS did not work with more than
+ one array.
+
+
+Version: 0.18.1 [2011-12-03]
+o Added drawChangePoints() for AbstractCBS.
+o Now pruneByHClust() for AbstractCBS updates the segment means.
+o Added writeSegments() for PSCBS object.
+o Now print() for AbstractCBS returns getSegments(..., simplify=TRUE).
+o Added argument 'simplify' to getSegments().
+o Added arguments 'name', 'tags' and 'exts' to writeSegments() and
+ writeLocusData() and dropped 'filename'.
+
+
+Version: 0.18.0 [2011-11-28]
+o Added pruneByHClust() for AbstractCBS, with implementation
+ for CBS and PairedPSCBS.
+o extractCNs() for CBS would not return a matrix but a data.frame.
+o BUG FIX: extractTotalCNs() for CBS would give an error.
+
+
+Version: 0.17.4 [2011-11-26]
+o Added argument 'updateMeans=TRUE' to callROH() for PairedPSCBS.
+o Now bootstrapTCNandDHByRegion() for PairedPSCBS preserves NAs
+ for DH and (C1,C2) quantiles, if the DH mean level is NA, which
+ can happen when a segment is called ROH. This also makes sure
+ that a segment called ROH will not be called AB.
+o An internal sanity check of bootstrapTCNandDHByRegion() for
+ PairedPSCBS would give an error if DH mean levels had been set
+ to NA for segments called ROH.
+
+
+Version: 0.17.3 [2011-11-24]
+o Added callSegmentationOutliers() and dropSegmentationOutliers()
+ for data frames.
+o CLEANUP: Renamed field 'position' of the example data to 'x'.
+ This helps us clean up some of the examples.
+o BUG FIX: bootstrapTCNandDHByRegion() for PairedPSCBS would give
+ an error, if a segment did not have any TCN signals, which can
+ occur when known segments are specified for Paired PSCBS.
+
+
+Version: 0.17.2 [2011-11-22]
+o Added findLargeGaps() and gapsToSegments().
+
+
+Version: 0.17.1 [2011-11-21]
+o BUG FIX: The internal sanity check of testROH() on weights was
+ slightly too conservative (required to high precision) when it
+ came to asserting that the sum of the weights equals one.
+o BUG FIX: resegment() for PairedPSCBS called segmentByCBS()
+ instead of segmentByPairedPSCBS().
+
+
+Version: 0.17.0 [2011-11-19]
+o GENERALIZATION: Now it is possible to run Paired PSCBS (without
+ TumorBoost) when only genotypes but not BAFs are available for the
+ matched normal.
+
+
+Version: 0.16.3 [2011-11-17]
+o Added resegment() for CBS and PairedPSCBS for easy resegmentation.
+o Adjusted segmentByCBS() such that it can handle 'knownSegments'
+ with chromosome boundaries given as -Inf and +Inf.
+o Now argument 'mar' for plotTracks() defaults to NULL.
+o ROBUSTNESS: Added redundancy tests for segmentByCBS() and
+ segmentByPairedPSCBS() with argument 'knownSegments'.
+o ROBUSTNESS: Now segmentByCBS() does more validation of 'knownSegments'.
+o FIX: extractRegions() for AbstractCBS would also show verbose output.
+o BUG FIX: Now argument/parameter 'seed' is correctly preserved by
+ segmentByCBS(). So is 'tbn' for segmentByPairedPSCBS().
+o BUG FIX: segmentByPairedPSCBS() would give an error when trying to
+ segment DH if the TCN segment contains no data points, which could
+ happen if 'knownSegments' specifies an empty segment, e.g. centromere.
+o BUG FIX: extractSegments() for CBS would throw an error when
+ there were multiple chromosomes.
+
+
+Version: 0.16.2 [2011-11-16]
+o Now segmentByCBS(..., w) stores weights 'w', if given, in the
+ locus-level data table of the returned CBS object.
+o Added pruneBySdUndo() for CBS, which does what undo.splits="sdundo"'
+ for DNA::segment(), but on the already segmented results.
+o Now updateMeans() uses locus-specific weights, iff available.
+o Added updateBoundaries() for CBS to update (start,stop) per segment.
+o CORRECTNESS: Now updateMeans() for CBS identifies loci via internal
+ 'segRows' field and no longer by locations of segment boundaries,
+ which gave slightly incorrect estimates for "tied" loci.
+
+
+Version: 0.16.1 [2011-11-15]
+o Now more segmentation parameters are stored in the CBS object.
+o SPEEDUP: Now segmentByCBS() will use memoization to retrieve
+ so called "sequential boundaries for early stopping", iff any of
+ the DNAcopy::segment() arguments 'alpha', 'nperm' and 'eta' are
+ specified. See also DNAcopy::getbdry().
+o Added method="DNAcopy" to estimateStandardDeviation() for CBS, which
+ estimates the std. dev. using DNAcopy:::trimmed.variance().
+o BUG FIX: extractSegments() for CBS would throw an error, because in
+ most cases it would created a corrupt internal 'segRows' field.
+
+
+Version: 0.16.0 [2011-11-12]
+o Added argument 'oma' and 'mar' to plotTracksManyChromosomes() for
+ PairedPSCBS for setting graphical parameters when 'add' == FALSE.
+o Added callROH().
+o Added arguments 'from' and 'adjustFor' to updateMeans().
+
+
+Version: 0.15.5 [2011-11-04]
+o BUG FIX: extractSegment() for AbstractCBS would give an error,
+ because it called itself instead of extractSegments().
+
+
+Version: 0.15.4 [2011-10-30]
+o Added save() and load() methods to AbstractCBS, which are wrappers
+ for saveObject() and loadObject() that assert the correct class
+ structure. Also, the load() method will automatically update the
+ class hierarchy for CBS and PairedPSCBS objects that were saved
+ before adding class AbstractCBS.
+
+
+Version: 0.15.3 [2011-10-23]
+o BUG FIX: callAmplifications() for CBS generated an error, if
+ more than one chromosome were called.
+o BUG FIX: The length of a segment must be defined as 'end-start'
+ and not 'end-start+1' so that the the total length of all segments
+ adds up correctly.
+o BUG FIX: highlightArmCalls() for CBS did not handle empty chromosomes.
+o BUG FIX: getCallStatisticsByArms() for CBS would thrown a error if
+ argument 'genomeData' did not contain exactly the same chromosomes
+ as in the CBS object.
+
+
+Version: 0.15.2 [2011-10-21]
+o Added mergeThreeSegments() to AbstractCBS.
+o BUG FIX: Recent updates caused segmentByPairedPSCBS(data) not to
+ work when 'data' is a data frame.
+
+
+Version: 0.15.1 [2011-10-21]
+o By setting 'start' and 'end' to NAs in 'knownSegments' (chromosome must
+ still be specified), it is possible to insert an empty segment that
+ disconnects the two flanking segments, e.g. centromere and the two arms.
+
+
+Version: 0.15.0 [2011-10-20]
+o Added support for specifying priorly known segments, such as chromosome
+ arms and centromeres, in segmentByCBS() via argument 'knownSegments'.
+o CLEANUP: Dropped a stray debug output message in segmentByPairedPSCBS().
+
+
+Version: 0.14.3 [2011-10-17]
+o Added argument 'asMissing' to dropRegions() for AbstractCBS.
+
+
+Version: 0.14.2 [2011-10-16]
+o Implemented extractCNs() for CBS and PairedPSCBS.
+o Added extractTotalCNs() for CBS.
+
+
+Version: 0.14.1 [2011-10-14]
+o Added implementation of extractRegions() for AbstractCBS, which
+ utilizes extractSegments().
+o Added abstract extractSegments() and extractSegment() for AbstractCBS.
+o Now extractTCNAndDHs() for PairedPSCBS passes '...' to getSegments().
+
+
+Version: 0.14.0 [2011-10-10]
+o CLEANUP: Harmonization of several method names.
+o CLEANUP: Internal restructuring of the source code files.
+
+
+Version: 0.13.5 [2011-10-10]
+o Added dropChangePoint() for AbstractCBS, which is just a
+ "name wrapper" for mergeTwoSegments().
+o Added dropRegion() and dropRegions() for AbstractPSCBS, where
+ the former is a wrapper for the latter dropRegions().
+o Added updateMeans() and mergeTwoSegments() for CBS in addition
+ already available PairedPSCBS versions.
+o Relabeled column 'id' to 'sampleName' returned by getSegments().
+o ROBUSTNESS: Now using getSegments() everywhere possible.
+o BUG FIX: For so called "splitter" rows, not all columns returned
+ by getSegments() of CBS were missing values.
+o BUG FIX: The object returned by as.CBS() of DNAcopy did not have the
+ correct class hierarchy.
+
+
+Version: 0.13.4 [2011-10-08]
+o Added all.equal() for AbstractCBS, which does not compare attributes.
+o Now internal getChromosomeRanges() of CBS returns a data.frame
+ instead of a matrix, and first column is now 'chromosome'.
+o Added optional argument 'regions' to getCallStatistics() of CBS
+ in order to calculate call statistics on subsets of chromosomes,
+ e.g. chromosome arms.
+o Added drawChromosomes() for CBS.
+o Added getCallStatisticsByArms(), callArms() and highlightArmCalls()
+ for CBS objects.
+
+
+Version: 0.13.3 [2011-10-03]
+o GENERALIZATION: Now segmentByCBS() and segmentByPairedPSCBS()
+ also accepts a data.frame of locus-level data with column names
+ matching the locus-level arguments accepted by the corresponding
+ method.
+o GENERALIZATION: Now all segmentation result classes (CBS and PSCBS)
+ inherits from the AbstractCBS class, which provides methods such
+ as getSampleName(), getChromosomes() and getSegments().
+o DOCUMENTATION: Added lots of more help pages.
+o CLEANUP: Dropped empty callSegments() for PairedPSCBS.
+
+
+Version: 0.13.2 [2011-09-30]
+o GENERALIZATION: Now drawLevels() for PairedPSCBS allows for drawing
+ segmentation results in 'betaT' space.
+o BUG FIX: plotTracks2(..., panels="dh") gave an error due to a
+ forgotten assignment.
+
+
+Version: 0.13.1 [2011-09-06]
+o Added formal class CBS, which holds the segmentation results
+ returned by segmentByCBS(). Several methods are available for
+ CBS objects, e.g. nbrOfLoci(), nbrOfSegments(), nbrOfChromosomes(),
+ getChromosomes(), estimateStandardDeviation() etc.
+o Now segmentByCBS() always returns a CBS object. To coerce to a
+ DNAcopy object (as defined in the DNAcopy class) use as.DNAcopy().
+o Added coerce methods as.DNAcopy() for CBS objects and as.CBS()
+ for DNAcopy objects.
+
+
+Version: 0.13.0 [2011-09-01]
+o GENERALIZATION: Now segmentByCBS() can process multiple chromosomes.
+o BUG FIX: Internal methods plotTracksManyChromosomes() and
+ tileChromosomes() for CBS did not work at all and therefore
+ neither plotTracks() for CBS with more than one chromosome.
+o Added append() for CBS objects.
+
+
+Version: 0.12.2 [2011-08-27]
+o CLEANUP: Now R CMD check is no longer giving a note that the
+ package loads package 'DNAcopy' in .onAttach().
+
+
+Version: 0.12.1 [2011-08-08]
+o BUG FIX: If dropSegmentationOutliers() would drop an outlier next to
+ a change point, such that the total copy-number signal becomes NA,
+ then the sanity checks that TCN segments always overlaps DH segments
+ would fail. Now the sanity checks are aware of this special case.
+ These sanity checks were moved from bootstrapTCNandDHByRegion() to
+ segmentByPairedPSCBS(). Thanks Christine To at University of Toronto
+ for reporting on this.
+
+
+Version: 0.12.0 [2011-07-23]
+o Added a namespace to the package, which will be more or less
+ a requirement in the next major release of R.
+o BUG FIX: Recently R devel automatically adds a namespace to
+ a package, if missing. This caused some of the PSCBS examples
+ to throw an exception related to incorrect dispatching of cat().
+
+
+Version: 0.11.7 [2011-07-15]
+o DOCUMENTATION: Added a section to help("segmentByPairedPSCBS") on
+ the importance of doing a whole-genome PSCBS segmentations if
+ calling AB and LOH states afterward.
+o DOCUMENTATION: Made it more clear in help("segmentByPairedPSCBS")
+ that arguments 'betaT', 'betaN' and 'muN' may contain NAs for
+ non-polymorphic loci.
+
+
+Version: 0.11.6 [2011-07-14]
+o BUG FIX/ROBUSTNESS: In some cases, the segmentation table would
+ contain column names with incorrect capitalization, e.g. "tcnnbrOfLoci"
+ instead of "tcnNbrOfLoci". This would cause several downstream
+ methods to give an error. The reason for this is that the Hmisc
+ package, if loaded after R.utils, overrides capitalize() in R.utils
+ with another (buggy?) capitalize() function. To avoid this, we
+ now everywhere specify explicitly that we want the one in R.utils.
+ Thanks Christine To at University of Toronto for reporting on this.
+
+
+Version: 0.11.5 [2011-07-10]
+o ROBUSTNESS: Fixed partial argument matchings in arrowsC1C2() and
+ arrowsDeltaC1C2() for PairedPSCBS.
+o BUG FIX: tileChromosomes() for PairedPSCBS was still assuming the
+ old naming convention of column names. This caused plotTracks()
+ to throw an exception when plotting multiple chromosomes.
+
+
+Version: 0.11.4 [2011-07-07]
+o GENERALIZATION: Now the internal estimator function that
+ estimateDeltaLOH() uses returns -Inf if all segments are called AB,
+ instead of throwing an exception. This will in turn make callLOH()
+ call all segments to be non-LOH.
+o DOCUMENTATION: Removed obsolete references to the R-forge repository.
+o BUG FIX: Consecutive calls to callAB(..., force=TRUE) would append
+ additional 'abCall' columns to the segmentation table instead of
+ replacing existing calls.
+
+
+Version: 0.11.3 [2011-07-06]
+o ROBUSTNESS: Added a sanity check to estimateDeltaLOHByMinC1AtNonAB() for
+ PairedPSCBS object. The test asserts that there exist segments that are
+ not in allelic balance, which are needed in order to estimate DeltaLOH.
+o DOCUMENTATION: The description of argument 'chromosome' for
+ segmentByPairedPSCBS() did not describe how to segment multiple
+ chromosomes in one call.
+
+
+Version: 0.11.2 [2011-07-05]
+o BUG FIX: Output fields 'tcnNbrOfSNPs' and 'tcnNbrOfHets' were
+ mistakenly labeled as 'tcnNbrOr...'. Thanks Christine Ho at
+ UC Berkeley for reporting on this.
+
+
+Version: 0.11.1 [2011-06-28]
+o DOCUMENTATION: Clarified that argument 'CT' should be tumor copy
+ number ratios relative to the normal.
+o DOCUMENTATION: Added Rd help for as.data.frame() of PairedPSCBS.
+
+
+Version: 0.11.0 [2011-06-14]
+o Renamed all column names of returned data frames such that
+ they follow the camelCase naming conventions in addition
+ to be somewhat shorter too.
+o GENERALIZATION: Added argument 'columnNamesFlavor' to segmentByCBS().
+
+
+Version: 0.10.2 [2011-06-07]
+o CLEANUP: Cleaned up the example():s.
+o Added more biocViews categories to DESCRIPTION
+
+
+Version: 0.10.1 [2011-05-31]
+o GENERALIZATION: The package can now be *installed* without the
+ DNAcopy package being installed. If package is loaded without
+ DNAcopy installed, an informative message will explain how to
+ install it.
+o Added installDNAcopy(), which will install DNAcopy from Bioconductor.
+o ROBUSTNESS: Now all DNAcopy functions are called as DNAcopy::nnn().
+
+
+Version: 0.10.0 [2011-05-29]
+o Renamed all arguments, variables, and functions referring to 'tau' to
+ refer to 'delta' reflecting the notation of the Paired PSCBS paper.
+o Renamed options, example code and help pages to reflect new package name.
+o Updated references in help pages.
+o Now the paired PSCBS is formally referred to as 'Paired PSCBS'.
+o Renamed package to PSCBS (from 'psCBS').
+
+
+Version: 0.9.54 [2011-04-27]
+o Added argument 'maxC' to estimateTauLOHByMinC1ForNonAB().
+
+
+Version: 0.9.53 [2011-04-14]
+o Added argument 'max' to estimateTauAB() and estimateTauLOH().
+
+
+Version: 0.9.52 [2011-04-14]
+o BUG FIX: Argument 'minSize' of callAB() and callLOH() had no effect.
+
+
+Version: 0.9.51 [2011-04-12]
+o Added argument 'minSize' to callAB() and callLOH() for PairedPSCBS.
+o Now the a conflicting call in callLOH()/callAB() with
+ argument xorCalls=TRUE is set to NA to contrast it from
+ a FALSE call.
+
+
+Version: 0.9.50 [2011-04-12]
+o Added argument 'xorCalls' to callLOH() and callAB() for
+ PairedPSCBS. When TRUE (the default), a segment that
+ is already called AB will never be called LOH, and vice versa.
+
+
+Version: 0.9.49 [2011-04-11]
+o Updated estimateTauABBySmallDH() for PairedPSCBS to use a
+ "symmetric" quantile estimator.
+o Added argument 'midpoint' to estimateTauLOHByMinC1AtNonAB().
+o BUG FIX: The recent callLOH() would not store the LOH calls.
+
+
+Version: 0.9.48 [2011-04-10]
+o Added callLOH() for PairedPSCBS, which in turn calls
+ auxiliary methods.
+o Added estimateTauLOH() for PairedPSCBS, which in turn calls
+ axillary methods.
+o Now callAB(..., force=FALSE) skips the caller if
+ allelic-balance calls already exist.
+o DOCUMENTATION: Update the example for segmentByPairedPSCBS
+ to reflect the restructured AB and LOH callers.
+
+
+Version: 0.9.47 [2011-04-08]
+o Added estimateTauABBySmallDH()
+o Added internal weightedQuantile().
+o DOCUMENTATION: Added help pages for more methods.
+o CLEANUP: Started to restructure the source code files.
+
+
+Version: 0.9.46 [2011-04-08]
+o BUG FIX: postsegmentTCN() for PairedPSCBS could generate an invalid
+ 'tcnSegRows' matrix, where the indices for two consecutive segments
+ would overlap, which is invalid. This was caught with real data,
+ but it seems to have required a very rare combination of data in
+ order for it to occur.
+
+
+Version: 0.9.45 [2011-04-05]
+o BUG FIX: estimateHighDHQuantileAtAB() for PairedPSCBS would throw
+ an error on an undefined 'trim' if verbose output was used.
+
+
+Version: 0.9.44 [2011-02-18]
+o Added estimateHighDHQuantileAtAB() for PairedPSCBS.
+
+
+Version: 0.9.43 [2011-02-06]
+o BUG FIX: plotTracks2() queried non-existing argument 'tracks'.
+
+
+Version: 0.9.42 [2011-02-03]
+o Added estimateKappa() for estimating the normal contamination.
+
+
+Version: 0.9.41 [2011-02-02]
+o Updated default for 'tauAB' of callABandHighAI() and callABandLowC1()
+ to be estimated from data using estimateTauAB().
+o Added argument 'tauTCN' to estimateTauAB().
+
+
+Version: 0.9.40 [2011-01-27]
+o Added argument 'flavor' to estimateTauAB() for estimating the
+ AB threshold using alternative methods.
+
+
+Version: 0.9.39 [2011-01-19]
+o Added trial version of new plotTracks2(), which will later replace
+ plotTracks(). Currently it only works for single chromosomes.
+o Added support functions, e.g. updateMeans().
+
+
+Version: 0.9.38 [2011-01-18]
+o DOCUMENTATION: Documented more plotTracks() arguments for PairedPSCBS.
+o BUG FIX: Now plotTracks(..., add=TRUE) for PairedPSCBS plots to
+ the current figure/panel.
+o Now plotTracks(..., add=FALSE) for PairedPSCBS only sets up subplots
+ if argument 'tracks' specifies more than one panel.
+o Added arguments 'changepoints' and 'col' to plotTracks() for PairedPSCBS.
+
+
+Version: 0.9.37 [2011-01-18]
+o BUG FIX: 'tcnSegRows' and 'dhSegRows' where not updated by
+ extractByRegions() for PairedPSCBS.
+
+
+Version: 0.9.36 [2011-01-14]
+o Added estimateTauAB() for estimating the tauAB tuning parameter
+ when calling segments in allelic balance. Updated
+ example(segmentByPairedPSCBS) to illustrate how to use it.
+o Added extractByRegions() for PairedPSCBS.
+
+
+Version: 0.9.35 [2011-01-12]
+o Now postsegmentTCN(..., force=TRUE) for PairedPSCBS also updates
+ the TCN estimates even for segments where the DH segmentation did
+ not find any additional change points.
+
+
+Version: 0.9.34 [2010-12-09]
+o BUG FIX: When there were multiple chromosomes processed by
+ segmentByPairedPSCBS(), then the returned data object would
+ contain 'betaT' identical to 'betaTN'.
+
+
+Version: 0.9.33 [2010-12-07]
+o Added callLowC1ByC1() and callABandLowC1().
+
+
+Version: 0.9.32 [2010-12-03]
+o BUG FIX: In rare cases the bootstrap sanity checks can indeed produce
+ an invalid 'range', more precisely where (range[,2] >= range[,1]) is
+ not true. This can happen if there is no variation in the bootstrap
+ estimates. Because of this we allow for some tolerance.
+
+
+Version: 0.9.31 [2010-12-02]
+o Added option "psCBS/sanityChecks/tolerance" for specifying the
+ tolerance of some internal sanity checks.
+
+
+Version: 0.9.30 [2010-12-01]
+o Rewrote all code dealing with the identification of loci belong
+ to segments. The code is now utilizing the 'segRows' element
+ returned by DNAcopy::segment(). Lots of the code was rewritten
+ and therefore completely new bugs may have been introduced.
+
+
+Version: 0.9.25 [2010-11-30]
+o BUG FIX: Argument 'flavor' of segmentByPairedPSCBS() would be ignored
+ if multiple chromosomes were segmented.
+o BUG FIX: extractByChromosome() for PSCBS would call it self instead
+ of extractByChromosomes().
+
+
+Version: 0.9.24 [2010-11-28]
+o BUG FIX: postsegmentTCN() did not handle loci with the same positions
+ and that are split in two different segments. It also did not exclude
+ loci with missing values.
+
+
+Version: 0.9.23 [2010-11-28]
+o BUG FIX: The algorithm in segmentByCBS() that infers which loci (of
+ the ones share the same genomic positions) that should be exclude
+ from each segment did not take missing signals into account.
+o BUG FIX: Iff argument 'chromosome' to segmentByPairedPSCBS() was of
+ length greater than one and specified exactly one unique chromosome,
+ then exception "Number of elements in argument 'chromosome' should
+ be exactly 8712 not 86209 value(s)" would be thrown.
+
+
+Version: 0.9.22 [2010-11-27]
+o BUG FIX: bootstrapTCNandDHByRegion() would incorrectly include
+ non-polymorphic loci in the set of homozygous SNPs during resampling.
+o BUG FIX: segmentByPairedPSCBS() would not accept missing values in
+ argument 'chromosome'.
+
+
+Version: 0.9.21 [2010-11-27]
+o Now arguments '...' of segmentByPairedPSCBS() are passed to
+ the two segmentByCBS() calls.
+o Added callSegmentationOutliers(), which can be used to identify
+ single-locus outliers that have a genomic signal that is clearly
+ outside the expected range. The dropSegmentationOutliers() sets
+ locus outliers detected by this method to missing values.
+ This is useful for excluding total copy-number outliers that
+ otherwise can have a dramatic impact on the non-robust CBS method.
+
+
+Version: 0.9.20 [2010-11-26]
+o Added optional argument 'chromosomes' to plotTracks() to plot a
+ subset of all chromosomes.
+o Added extractByChromosomes() for PSCBS.
+o Now the default confidence intervals for plotTracks() is (0.05,0.95),
+ if existing.
+o Now all call functions estimate symmetric bootstrap quantiles for
+ convenience of plotting confidence intervals.
+o BUG FIX: callABandHighAI() for PairedPSCBS used the old DH-only
+ bootstrap method.
+o BUG FIX: The statistical sanity checks of the bootstrap estimates
+ would give an error when only single-sided bootstrap confidence
+ interval was calculated.
+o BUG FIX: The call functions, for instance callABandHighAI(), would throw
+ 'Error in quantile.default(x, probs = alpha) : missing values and NaN's
+ not allowed if 'na.rm' is FALSE' unless bootstrapTCNandDHByRegion() was
+ run before.
+
+
+Version: 0.9.19 [2010-11-23]
+o ROBUSTNESS: Added more sanity checks to bootstrapTCNandDHByRegion().
+o WORKAROUND: The precision of the mean levels of DNAcopy::segment()
+ is not great enough to always compare it to that of R's estimates.
+o BUG FIX: bootstrapTCNandDHByRegion() would give an error if there was
+ only one segment.
+o BUG FIX: segmentByPairedPSCBS() and bootstrapTCNandDHByRegion()
+ would not subset the correct set of DH signals if there were some
+ missing values in TCN.
+
+
+Version: 0.9.18 [2010-11-22]
+o Added argument 'calls' to plotTracks() for highlighting called regions.
+o Updated callAllelicBalanceByDH() and callExtremeAllelicImbalanceByDH()
+ to utilize bootstrapTCNandDHByRegion().
+o ROBUSTNESS: Now drawConfidenceBands() of PairedPSCBS silently does
+ nothing if the requested bootstrap quantiles are available.
+o BUG FIX: bootstrapTCNandDHByRegion() for PairedPSCBS would not
+ correctly detect if bootstrap results are already available.
+
+
+Version: 0.9.17 [2010-11-21]
+o Now plotTracks() supports tracks "tcn,c1", "tcn,c2" and "c1,c2" too.
+o Added support for flavor "tcn&dh" in segmentByPairedPSCBS(), which
+ contrary to "tcn,dh" enforces TCN and DH to have the same change
+ points. The default flavor is now "tcn&dh".
+o Added argument 'xlim' to plotTracks() making it possible to zoom in.
+
+
+Version: 0.9.16 [2010-11-21]
+o Now joinSegments=TRUE is the default for segmentByCBS() and
+ segmentByPairedPSCBS().
+o Added argument 'quantiles' to plotTracks(), which if specified
+ draws confidence bands previously estimated from bootstrapping.
+o Added drawConfidenceBands() for PairedPSCBS.
+o Added bootstrapTCNandDHByRegion() for PairedPSCBS.
+o Added standalone joinSegments() for CBS results.
+o Now segmentByPairedPSCBS() also returns minor and major
+ copy numbers for each segment.
+
+
+Version: 0.9.15 [2010-11-21]
+o Adjusted postsegmentTCN() such that the updated TCN segment boundaries
+ are the maximum of the DH segment and the support by the loci. This
+ means that postsegmentTCN() will work as expected both when signals
+ where segmented with 'joinSegments' being TRUE or FALSE.
+o Updated plotTracks() for PairedPSCBS such that the TCN segmentation
+ is colored 'purple' and the DH segmentation 'orange' for TCN and DH
+ only tracks.
+
+
+Version: 0.9.14 [2010-11-20]
+o Now it is possible to specify the boundaries of the regions to
+ be segmented as known change points via argument 'knownCPs'.
+o Added argument 'joinSegments' to segmentByCBS() and
+ segmentByPairedPSCBS() in order to specify if neighboring
+ segments should be joined or not.
+o Now segmentByCBS() and segmentByPairedPSCBS() allow for
+ unknown genomic positions as well as missing total CN signals.
+
+
+Version: 0.9.13 [2010-11-19]
+o Added argument 'joinSegments' to segmentByCBS() in order to specify
+ if neighboring segments should be joined or not.
+
+
+Version: 0.9.12 [2010-11-19]
+o Added plotTracks() and drawLevels() etc to CBS results.
+o Now segmentByCBS() allows for unknown genomic positions.
+o Now segmentByCBS() allows for missing signals.
+o Added argument 'preserveOrder' to segmentByCBS(). If TRUE, then
+ the loci in the returned 'data' object are ordered as the input
+ data, otherwise it is ordered along the genome.
+
+
+Version: 0.9.11 [2010-11-16]
+o Now the 'data' object returned by segmentByCBS() contains field
+ 'index' if and only if the loci had to be reorder along the genome.
+o DOCUMENTATION: Added more details, references to papers, and cross
+ links to other functions to the help pages.
+o BUG FIX: In the rare cases where two loci at the same positions are
+ split up into two neighboring segments, then segmentByPairedPSCBS()
+ would fail to infer which they were if and only if the loci were not
+ ordered along the genome. This could happen with for instance
+ Affymetrix GenomeWideSNP_6 data.
+
+
+Version: 0.9.10 [2010-11-09]
+o Added argument 'cex=1' to plotTracks().
+o BUG FIX: It was not possible to plot BAF tracks with plotTracks().
+
+
+Version: 0.9.9 [2010-11-05]
+o BUG FIX: segmentByCBS() tried to pass non-existing argument
+ 'undo.split' to DNAcopy::segment(). It should be 'undo.splits'.
+
+
+Version: 0.9.8 [2010-11-04]
+o BUG FIX: There was a stray/debug stop() statement left in
+ segmentByPairedPSCBS() causing an "error" in the rare case
+ when loci that have the same physical locations are split
+ into two different segments.
+
+
+Version: 0.9.7 [2010-11-03]
+o ROBUSTNESS: Now bootstrapDHByRegion() uses resample() of R.utils.
+o BUG FIX: bootstrapDHByRegion() did not sample from the correct
+ unit(s) when there was only one DH signal.
+
+
+Version: 0.9.6 [2010-11-02]
+o Added arguments 'undoTCN' and 'undoDH' to segmentByPairedPSCBS().
+o Added argument 'undo' to segmentByCBS(), which corresponds to
+ undo.splits="sdundo" and undo.SD=undo, if undo < +Inf.
+o BUG FIX: Arguments 'alphaTCN' and 'alphaDH' of segmentByPairedPSCBS()
+ were not used when more than one chromosome were segmented.
+
+
+Version: 0.9.5 [2010-11-01]
+o Added arguments 'alphaAB' and 'alphaHighAI' to callABandHighAI().
+o BUG FIX: bootstrapDHByRegion() would give an error if only a single
+ quantile was requested.
+o BUG FIX: bootstrapDHByRegion() would give "Error in if (nbrOfUnits
+ > segJJ[, "dh.num.mark"]) { : missing value where TRUE/FALSE needed"
+ when 'dh.num.mark' was NA.
+
+
+Version: 0.9.4 [2010-10-25]
+o Now the default is a 95% confidence interval for calls.
+o Now segmentByCBS() also returns element 'lociNotPartOfSegment',
+ if there are segments that share end points, which can happen if
+ a change point is called in middle of a set of loci that have the
+ same genomic positions. In such cases, 'lociNotPartOfSegment'
+ specifies which loci are *not* part of which segment. Then by
+ identifying the loci that are within a segment by their positions
+ and excluding any of the above, one knows exactly which loci
+ CBS included in each segment.
+o BUG FIX: Now bootstrapDHByRegion() for PairedPSCBS handles the
+ rare case when markers with the same positions are split in
+ two different segments.
+o BUG FIX: Now the correct set of loci are extracted from each TCN
+ segment, in the rare case that two neighboring TCN segments have
+ the same end points.
+
+
+Version: 0.9.3 [2010-10-25]
+o Added argument 'ciRange' to callAllelicBalance() and
+ callExtremeAllelicImbalance().
+o BUG FIX: bootstrapDHByRegion() for PairedPSCBS would bootstrap
+ from the incorrect set of loci when the DH region contained
+ only one locus.
+o BUG FIX: bootstrapDHByRegion() for PairedPSCBS would bootstrap
+ from the incorrect set of loci if more than one chromosome
+ was available.
+
+
+Version: 0.9.2 [2010-10-24]
+o BUG FIX: plotTracks() would give "Error: object 'nbrOfLoci' not found'
+ for whole-genome plots.
+
+
+Version: 0.9.1 [2010-10-20]
+o Now plotTracks() can plot whole-genome data.
+
+
+Version: 0.9.0 [2010-10-18]
+o Added arguments 'alphaTCN' and 'alphaDH' to segmentByPairedPSCBS()
+ with defaults according to the paper.
+
+
+Version: 0.8.3 [2010-10-18]
+o Now segmentByPairedPSCBS() can segment multiple chromosomes.
+
+
+Version: 0.8.2 [2010-10-17]
+o Added argument 'tbn' to segmentByPairedPSCBS() specifying whether
+ TumorBoostNormalization should be applied or not.
+
+
+Version: 0.8.1 [2010-10-10]
+o The default for segmentByPairedPSCBS() is now to segment TCN on
+ the original scale, not the sqrt().
+o Added plotTracks() for PairedPSCBS.
+
+
+Version: 0.8.0 [2010-10-06]
+o CLEAN UP: Removed all old code, native code and help pages.
+
+
+Version: 0.7.8 [2010-10-03]
+o Added optional argument 'chromosome' to segmentByCBS().
+ Note that at this point it is only used for annotating the
+ results; it can not be used to segmented multiple chromosomes
+ at ones.
+
+
+Version: 0.7.7 [2010-09-26]
+o Now subsetBySegments() and postsegmentTCN() for PairedPSCBS
+ handles multiple chromosomes.
+
+
+Version: 0.7.6 [2010-09-24]
+o Added support to annotating and subsetting also by chromosomes,
+ as well as appending segmentation results from different chromosomes
+ together.
+
+
+Version: 0.7.5 [2010-09-21]
+o Added postsegmentTCN() for PairedPSCBS, which updates the
+ TCN segment start and ends, estimates and counts given the
+ DH segments.
+
+
+Version: 0.7.4 [2010-09-18]
+o Added argument 'chromosome' to segmentByPairedPSCBS(), which, if given,
+ adds a chromosome column to the data and segmentation results.
+o BUG FIX: plot() for PairedPSCBS used a non-defined variable.
+
+
+Version: 0.7.3 [2010-09-16]
+o Added callABandHighAI() for calling paired PSCBS segmentation results.
+o Added internal bootstrapping functions.
+
+
+Version: 0.7.2 [2010-09-15]
+o Added more methods for the PSCBS class.
+
+
+Version: 0.7.1 [2010-09-08]
+o Added more methods for the PSCBS class.
+o Now segmentByPairedPSCBS() also returns the TumorBoost normalized data.
+
+
+Version: 0.7.0 [2010-09-04]
+o Updated segmentByPairedPSCBS() to provide two-step segmentation
+ from first segmenting the total copy numbers and then the
+ decrease-of-heterozygosity signals. Added utility functions for
+ plotting the results. The code for calling allelic imbalance
+ and LOH is still to be added.
+
+
+Version: 0.6.3 [2010-09-02]
+o ROBUSTNESS: Now segmentByCBS() also works if there are no data points.
+
+
+Version: 0.6.2 [2010-07-14]
+o CLEAN UP: Added callNaiveHeterzygotes() which is a cleaned up
+ version of findheterozygous(). Added an Rd example that asserts
+ that the two are identical and compares the calls to those of
+ aroma.light::callNaiveGenotypes().
+
+
+Version: 0.6.1 [2010-07-09]
+o Added low-level segmentByPairedPSCBS(), which runs paired PSCBS
+ segmentation on a single sample and a single chromosome.
+ It only segments; it does not call segments. This is only
+ a stub in the sense that it still does not adjust p-values etc.
+o Added low-level segmentByCBS(), which runs CBS segmentation
+ on a single sample and a single chromosome.
+o BACKWARD COMPATIBILITY: Now psCNA() returns a list of length 8.
+o Reverted psSegment() back to v0.5.6.
+
+
+Version: 0.6.0 [2010-07-08]
+o Now psSegmentPaired() returns a data frame (no longer a matrix).
+o CLEANUP: Major cleanup, i.e. renaming variables, reordering etc.
+o CLEANUP: Created psSegmentPaired() from psSegment().
+o ROBUSTNESS: Replaced all 1:n with seq(length=n) to deal with n == 0.
+o ROBUSTNESS: Now all list elements are referenced by name.
+o ROBUSTNESS: Now all iterator variables are written as ii, jj etc.
+o Using setMethodS3() of R.methodsS3 to define S3 method.
+o Dropping NAMESPACE while package is finished. This makes it
+ easier to patch methods etc.
+
+
+Version: 0.5.6 [2010-07-07]
+o Added example(psSegment).
+o BUG FIX: Previous clean up introduced bugs.
+o BUG FIX: The dynamic library for hrmode() was not loaded.
+
+
+Version: 0.5.5 [2010-05-05]
+o CLEAN UP/ROBUSTNESS: Major code clean up.
+
+
+Version: 0.5.4 [2010-04-30]
+o Added internal hrmode().
+o CLEAN UP: Renamed source files to match function names.
+ Only only function per source file.
+
+
+Version: 0.5.3 [2010-04-22]
+o ABO updated the psCBS algorithm.
+
+
+Version: 0.5.2 [2010-0?-??]
+o ???
+
+
+Version: 0.5.1 [2010-03-31]
+o Now psSegment(..., matching.reference=TRUE) does TumorBoost
+ normalization on the allele B fractions before segmentation.
+
+
+Version: 0.5.0 [2010-03-12]
+o Added to R-forge repository.
diff --git a/R/000.R b/R/000.R
new file mode 100644
index 0000000..3e773a2
--- /dev/null
+++ b/R/000.R
@@ -0,0 +1,4 @@
+## Look for existing generic functions also in imported namespaces.
+## This will affect whether setGenericS3() creates a generic function
+## or not.
+options("R.methodsS3:checkImports:setGenericS3"=TRUE)
diff --git a/R/006.fixVarArgs.R b/R/006.fixVarArgs.R
new file mode 100644
index 0000000..4547afb
--- /dev/null
+++ b/R/006.fixVarArgs.R
@@ -0,0 +1,16 @@
+append <- function(...) UseMethod("append");
+setMethodS3("append", "default", function(...) {
+ base::append(...);
+})
+
+
+############################################################################
+# HISTORY:
+# 2013-10-14 [HB]
+# o ROBUSTNESS: The overriding of append() to become a generic
+# function does now call base::append() in the default, instead
+# of copy the latter. All this will eventually be removed,
+# when proper support for c, [, [[ etc. has been added everywhere.
+# 2010-10-02
+# o Created to please R CMD check.
+############################################################################
diff --git a/R/999.DEPRECATED.R b/R/999.DEPRECATED.R
new file mode 100644
index 0000000..18f05d4
--- /dev/null
+++ b/R/999.DEPRECATED.R
@@ -0,0 +1,44 @@
+## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+## DEFUNCT
+## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+## Defunct since v0.41.0 (2015-03-30)
+setMethodS3("bootstrapDHByRegion", "PairedPSCBS", function(fit, B=100, statsFcn=function(x) quantile(x, probs=c(0.025, 0.050, 0.95, 0.975)), by=c("betaTN", "betaT"), ..., force=FALSE, verbose=FALSE) {
+ .Defunct("bootstrapTCNandDHByRegion");
+}, deprecated=TRUE) # bootstrapDHByRegion()
+
+
+
+##############################################################################
+# HISTORY
+# 2015-02-22
+# o CLEANUP: bootstrapDHByRegion() is defunct (was deprecated since 2013).
+# 2013-04-20
+# o CLEANUP: Formally deprecated bootstrapDHByRegion().
+# 2013-01-15
+# o Now bootstrapDHByRegion() uses the params$avgDH estimator, iff given.
+# 2012-02-24
+# o Added argument 'force' to bootstrapDHByRegion().
+# 2011-06-14
+# o Updated code to recognize new column names.
+# 2010-11-22
+# o DEPRECATED: bootstrapDHByRegion() should no longer be used.
+# 2010-11-03 [HB]
+# o ROBUSTNESS: Now bootstrapDHByRegion() uses resample() of R.utils.
+# 2010-11-01 [HB]
+# o Now bootstrapDHByRegion() estimates more quantiles.
+# o BUG FIX: bootstrapDHByRegion() would give an error if only a single
+# quantile was requested.
+# o BUG FIX: bootstrapDHByRegion() would give "Error in if (nbrOfUnits >
+# segJJ[, "dh.num.mark"]) { : missing value where TRUE/FALSE needed" when
+# 'dh.num.mark' was NA.
+# 2010-10-25 [HB]
+# o BUG FIX: Now bootstrapDHByRegion() for PairedPSCBS handles the rare case
+# when markers with the same positions are split in two different segments.
+# o BUG FIX: bootstrapDHByRegion() for PairedPSCBS would bootstrap from the
+# incorrect set of loci when the DH region contained only one locus.
+# o BUG FIX: bootstrapDHByRegion() for PairedPSCBS would bootstrap from the
+# incorrect set of loci if more than one chromosome was available.
+# 2010-09-16 [HB]
+# o Added bootstrapDHByRegion(), which is what is used by paired PSCBS.
+# o Created.
+##############################################################################
diff --git a/R/999.NonDocumentedObjects.R b/R/999.NonDocumentedObjects.R
new file mode 100644
index 0000000..31b33e1
--- /dev/null
+++ b/R/999.NonDocumentedObjects.R
@@ -0,0 +1,28 @@
+###########################################################################/**
+# @RdocDocumentation "Non-documented objects"
+#
+# % Other missing docs
+# @eval "t <- readLines('../incl/999.missingdocs.txt'); t <- trim(unlist(strsplit(t, split=' '))); t <- t[nchar(t) > 0]; t2 <- gsub('\\[', '\\\\[', t); t <- unique(t); t <- sprintf('\\alias{%s}', t); paste(t, collapse='\n')"
+#
+# \description{
+# This page contains aliases for all "non-documented" objects that
+# \code{R CMD check} detects in this package.
+#
+# Almost all of them are \emph{generic} functions that have specific
+# document for the corresponding method coupled to a specific class.
+# Other functions are re-defined by \code{setMethodS3()} to
+# \emph{default} methods. Neither of these two classes are non-documented
+# in reality.
+# The rest are deprecated methods.
+# }
+#
+# @author
+#
+# @keyword internal
+#*/###########################################################################
+
+############################################################################
+# HISTORY:
+# 2005-05-15
+# o Created to please R CMD check.
+############################################################################
diff --git a/R/999.package.R b/R/999.package.R
new file mode 100644
index 0000000..f9e866b
--- /dev/null
+++ b/R/999.package.R
@@ -0,0 +1,50 @@
+#########################################################################/**
+# @RdocPackage "PSCBS"
+# @eval "rd <- gsub('\\alias{PSCBS}', '', rd, fixed=TRUE); ''"
+#
+# \description{
+# @eval "packageDescription('PSCBS')$Description".
+#
+# This package should be considered to be in an alpha or beta phase.
+# You should expect the API to be changing over time.
+# }
+#
+# \section{Installation and updates}{
+# To install this package, use \code{install.packages("PSCBS")}.
+# }
+#
+# \section{To get started}{
+# To get started, see:
+# \enumerate{
+# \item Vignettes '\href{../doc/index.html}{Parent-specific copy-number segmentation using Paired PSCBS}' and '\href{../doc/index.html}{Total copy-number segmentation using CBS}'.
+# \item @see "segmentByCBS" - segments total copy-numbers, or any
+# other unimodal genomic signals, using the CBS method [3,4].
+# \item @see "segmentByPairedPSCBS" - segments allele-specific
+# tumor signal from a tumor \emph{with} a matched normal
+# using the Paired PSCBS method [1,2].
+# \item @see "segmentByNonPairedPSCBS" - segments allele-specific
+# tumor signal from a tumor \emph{without} a matched normal
+# using the Non-Paired PSCBS method adopted from [1,2].
+# }
+# }
+#
+# \section{How to cite}{
+# Please use [1] and [2] to cite when using Paired PSCBS,
+# and [3] and [4] when using CBS.
+# When using Non-Paired PSCBS, please cite [1] and [2] as well.
+# }
+#
+# @author
+#
+# \section{License}{
+# @eval "packageDescription('PSCBS')$License".
+# }
+#
+# \references{
+# [1] @include "../incl/OlshenA_etal_2011.Rd" \cr
+# [2] @include "../incl/BengtssonH_etal_2010.Rd" \cr
+# [3] @include "../incl/OlshenVenkatraman_2004.Rd" \cr
+# [4] @include "../incl/VenkatramanOlshen_2007.Rd" \cr
+# }
+#*/#########################################################################
+
diff --git a/R/AbstractCBS.HCLUST.R b/R/AbstractCBS.HCLUST.R
new file mode 100644
index 0000000..e649004
--- /dev/null
+++ b/R/AbstractCBS.HCLUST.R
@@ -0,0 +1,263 @@
+###########################################################################/**
+# @set "class=AbstractCBS"
+# @RdocMethod updateMeansTogether
+# @alias updateMeansTogether.CBS
+# @alias updateMeansTogether.PairedPSCBS
+#
+# @title "Updates the CN mean levels jointly in sets of segments"
+#
+# \description{
+# @get "title" as if they were one large segment.
+# The locus-level data is not updated/modified.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{idxList}{A @list, where each element is an @integer @vector
+# specifying segment indices of segments for which the mean levels
+# should be calculated jointly.}
+# \item{...}{Not used.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns an object of the same class.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# This method is utilized by @seemethod "pruneByHClust".
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("updateMeansTogether", "AbstractCBS", abstract=TRUE, private=TRUE);
+
+
+###########################################################################/**
+# @set "class=AbstractCBS"
+# @RdocMethod hclustCNs
+#
+# @title "Performs a hierarchical clustering of the CN mean levels"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{size}{Argument passed to @seemethod "sampleCNs".}
+# \item{distMethod, hclustMethod}{Argument \code{method} for
+# @see "stats::dist" and "stats::hclust", respectively.}
+# \item{...}{Not used.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns a \code{hclust} object as returned by @see "stats::hclust".
+# }
+#
+# @author
+#
+# \seealso{
+# This method is utilized by @seemethod "pruneByHClust".
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("hclustCNs", "AbstractCBS", function(fit, size=NULL, distMethod="euclidean", hclustMethod="ward.D", ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Hierarchical clustering of segmented copy numbers");
+ verbose && enter(verbose, "Extracting/sampling CNs");
+ C <- sampleCNs(fit, size=size, splitters=FALSE);
+ verbose && str(verbose, C);
+
+ # Drop also segments with no data points
+ ok <- !is.na(C);
+ ok <- rowAlls(ok);
+ C <- C[ok,,drop=FALSE];
+ verbose && str(verbose, C);
+ verbose && exit(verbose);
+
+ verbose && enter(verbose, "Calculating distance matrix");
+ D <- stats::dist(C, method=distMethod);
+ verbose && str(verbose, D);
+ verbose && exit(verbose);
+
+ verbose && enter(verbose, "Clustering");
+
+ # TODO: Do *weighted* hierarchical clustering
+ tree <- stats::hclust(D, method=hclustMethod);
+ verbose && str(verbose, tree);
+ verbose && exit(verbose);
+
+ verbose && exit(verbose);
+
+ tree;
+}, private=TRUE) # hclustCNs()
+
+
+
+###########################################################################/**
+# @RdocMethod pruneByHClust
+#
+# @title "Prunes the CN profile by pruning and merging through hierarchical clustering"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Arguments passed to @see "stats::cutree",
+# particularly either of thresholds \code{h} or \code{k}.}
+# \item{size, distMethod, hclustMethod}{Arguments (as well as
+# some of \code{...}) passed to @seemethod "hclustCNs".}
+# \item{merge}{If @TRUE, consecutive segments that belong to the
+# same PSCN cluster will be merged into one large segment.}
+# \item{update}{If @TRUE, segment means are updated afterwards, otherwise not.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns a pruned object of the same class.
+# }
+#
+# \examples{\dontrun{
+# fitP <- pruneByHClust(fit, h=0.25);
+# }}
+#
+# @author
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("pruneByHClust", "AbstractCBS", function(fit, ..., size=NULL, distMethod="euclidean", hclustMethod="ward.D", merge=TRUE, update=TRUE, verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Prune segments by hierarchical clustering");
+ verbose && cat(verbose, "Clustering arguments:");
+ verbose && str(verbose, c(list(size=size, distMethod=distMethod, hclustMethod=hclustMethod), list(...)));
+
+ verbose && enter(verbose, "Clustering");
+ tree <- hclustCNs(fit, size=size, distMethod=distMethod,
+ hclustMethod=hclustMethod, ..., verbose=less(verbose,5));
+ verbose && print(verbose, tree);
+ verbose && exit(verbose);
+
+ verbose && enter(verbose, "Cutting tree");
+ verbose && cat(verbose, "Cutting arguments:");
+ verbose && str(verbose, c(list(tree=tree), list(...)));
+ p <- cutree(tree, ...);
+ verbose && str(verbose, p);
+
+ # Group segments
+ idxList <- by(names(p), p, FUN=function(x) {
+ idxs <- as.integer(as.character(x));
+ idxs <- sort(unique(idxs));
+ list(idxs);
+ });
+ verbose && str(verbose, idxList);
+
+ verbose && exit(verbose);
+
+
+ # Dropping previous segment calls and quantile mean-level estimates.
+ fit <- resetSegments(fit);
+
+ verbose && enter(verbose, "Merging mean levels of clustered segments");
+ fit <- updateMeansTogether(fit, idxList=idxList, verbose=less(verbose, 10));
+ verbose && exit(verbose);
+
+ if (merge) {
+ verbose && enter(verbose, "Merging neighboring segments within each cluster");
+ lefts <- c();
+ for (ii in seq(along=idxList)) {
+ verbose && enter(verbose, sprintf("Cluster #%d of %d", ii, length(idxList)));
+ idxs <- idxList[[ii]];
+ verbose && cat(verbose, "Segments in cluster:");
+ verbose && str(verbose, idxs);
+
+ # Indices to segments to merge
+ leftsII <- idxs[which(diff(idxs) == 1L)];
+ verbose && cat(verbose, "Left indices of neighboring segments:");
+ verbose && str(verbose, leftsII);
+
+ lefts <- c(lefts, leftsII);
+ verbose && exit(verbose);
+ } # for (ii ...)
+
+ lefts <- sort(unique(lefts));
+ verbose && cat(verbose, "Left indices of segments to be merged:");
+ verbose && str(verbose, lefts);
+ verbose && exit(verbose);
+
+ verbose && enter(verbose, "Merging segments");
+ lefts <- rev(lefts);
+ for (ii in seq(along=lefts)) {
+ fit <- mergeTwoSegments(fit, left=lefts[ii], update=FALSE);
+ } # for (ii ...)
+ verbose && exit(verbose);
+ } # if (merge)
+
+ if (update) {
+ verbose && enter(verbose, "Updating segment means");
+## fit <- updateBoundaries(fit, verbose=less(verbose, 50));
+ fit <- updateMeans(fit, verbose=less(verbose, 50));
+ verbose && exit(verbose);
+ }
+
+ verbose && exit(verbose);
+
+ fit;
+}, protected=TRUE) # pruneByHClust()
+
+
+############################################################################
+# HISTORY:
+# 2014-01-12
+# o CLEANUP: Renamed variable 'h' to 'tree' in pruneByHClust(), because
+# it could easily be misinterpreted as argument 'h' to cutree().
+# 2013-09-18
+# o WORKAROUND: For R v2.15.3 and before, we need to attach the 'methods'
+# package, otherwise we get 'Error in rowAlls(ok) : could not find
+# function "loadMethod"' below. This seems to be a bug in R.
+# 2013-02-05
+# o Now pruneByHClust() drops any existing segment calls and quantile
+# mean-level estimates.
+# 2011-12-06
+# o Now pruneByHClust(..., update=TRUE) for AbstractCBS updates the
+# mean levels of the merged segments at the end.
+# 2011-11-28
+# o Added abstract updateMeansTogether() for AbstractCBS.
+# o Dropped kmeansCNs() stub.
+# o Added Rdoc comments.
+# o Now hclustCNs() also handles segments with missing (C1,C2) levels,
+# which for instance can happen after calling ROH.
+# 2011-10-14
+# o Implemented hclustCNs() and pruneByHClust() for AbstractCBS.
+# o Implemented extractCNs() for PairedPSCBS.
+# o Created.
+############################################################################
diff --git a/R/AbstractCBS.PLOT.R b/R/AbstractCBS.PLOT.R
new file mode 100644
index 0000000..aa4cb92
--- /dev/null
+++ b/R/AbstractCBS.PLOT.R
@@ -0,0 +1,63 @@
+###########################################################################/**
+# @set "class=AbstractCBS"
+# @RdocMethod plotTracks
+#
+# @title "Plots the segmentation result along the genome"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{...}
+# }
+#
+# \value{
+# Returns nothing.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("plotTracks", "AbstractCBS", abstract=TRUE);
+
+
+setMethodS3("tileChromosomes", "AbstractCBS", abstract=TRUE, protected=TRUE);
+
+
+setMethodS3("drawChangePoints", "AbstractCBS", abstract=TRUE, protected=TRUE);
+
+
+setMethodS3("drawKnownSegments", "AbstractCBS", function(fit, col="#aaaaaa", ..., xScale=1e-6) {
+ segs <- fit$params$knownSegments;
+
+ # Nothing todo?
+ if (is.null(segs)) {
+ return();
+ }
+
+ # Workaround from the fact that extractChromosomes() does not drop
+ # known segments. /HB 2013-03-21
+ chromosome <- NULL; rm(list="chromosome"); # To please R CMD check.
+ segs <- subset(segs, chromosome %in% getChromosomes(fit));
+ xStarts <- segs[,"start"];
+ xEnds <- segs[,"end"];
+ xs <- sort(unique(c(xStarts, xEnds)));
+ abline(v=xScale*xs, col=col, ...);
+}, protected=TRUE)
+
+
+############################################################################
+# HISTORY:
+# 2013-03-21
+# o Added drawKnownSegments().
+# 2011-12-03
+# o Added drawChangePoints().
+# 2011-10-02
+# o Created.
+############################################################################
diff --git a/R/AbstractCBS.PRUNE.R b/R/AbstractCBS.PRUNE.R
new file mode 100644
index 0000000..1e1bd0d
--- /dev/null
+++ b/R/AbstractCBS.PRUNE.R
@@ -0,0 +1,530 @@
+setMethodS3("seqOfSegmentsByDP", "AbstractCBS", function(fit, by, shift=+100, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Local functions
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'by':
+ by <- Arguments$getCharacters(by);
+ data <- getLocusData(fit);
+ fields <- colnames(data);
+ missing <- fields[!is.element(by, fields)];
+ if (length(missing) > 0) {
+ throw("Argument 'by' specifies one or more non-existing locus data fields: ", paste(missing, collapse=", "));
+ }
+
+ # Argument 'shift':
+ shift <- Arguments$getNumeric(shift);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Identifying optimal sets of segments via dynamic programming");
+
+ # Assert that known segments was used
+ knownSegments <- fit$params$knownSegments;
+ if (nrow(knownSegments) == 0L) {
+ chromosome <- getChromosomes(fit);
+ knownSegments <- data.frame(chromosome=chromosome, start=-Inf, end=+Inf);
+ }
+
+ chrOffsets <- getChromosomeOffsets(fit);
+ # Sanity check
+ stopifnot(all(is.finite(chrOffsets)));
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Shift every other non-empty region
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Shifting TCN levels for every second segment");
+
+ segPrefix <- getSegmentTrackPrefixes(fit)[1L];
+ segKeys <- toCamelCase(paste(segPrefix, c("start", "end")));
+ segRowsKey <- toCamelCase(paste(segPrefix, "seg rows"));
+
+ verbose && enter(verbose, "Split up into non-empty independent regions");
+ chromosomes <- getChromosomes(fit);
+
+ fitList <- list();
+ for (jj in seq(along=chromosomes)) {
+ chr <- chromosomes[jj];
+ verbose && enter(verbose, sprintf("Chromosome #%d ('%s') of %d", jj, chr, length(chromosomes)));
+
+ # Subset segmentation results on this chromosome
+ fitJJ <- extractChromosome(fit, chr);
+ verbose && cat(verbose, "Number of loci on chromosome: ", nbrOfLoci(fitJJ));
+
+ # Nothing to do and nothing to add?
+ if (nbrOfLoci(fitJJ) == 0L) {
+ verbose && exit(verbose);
+ next;
+ }
+
+ # Find known segments on this chromosome
+ knownSegmentsJJ <- subset(knownSegments, chromosome == chr);
+ verbose && cat(verbose, "Known segments on chromosome:");
+ verbose && print(verbose, knownSegmentsJJ);
+
+ # Nothing to do?
+ if (nrow(knownSegmentsJJ) == 0L) {
+ fitList <- append(fitList, list(fitJJ));
+ verbose && exit(verbose);
+ next;
+ }
+
+ # Get the segments on this chromosome
+ segsJJ <- getSegments(fitJJ);
+
+ # Extract the individual known segments on this chromosome
+ fitListJJ <- list();
+ for (kk in seq(length=nrow(knownSegmentsJJ))) {
+ verbose && enter(verbose, sprintf("Known segment #%d of %d", kk, nrow(knownSegmentsJJ)));
+ seg <- knownSegmentsJJ[kk,];
+ verbose && print(verbose, seg);
+
+ start <- seg$start;
+ end <- seg$end;
+ idxStart <- min(which(segsJJ[[segKeys[1]]] >= start));
+ idxEnd <- max(which(segsJJ[[segKeys[2]]] <= end));
+ idxs <- idxStart:idxEnd;
+
+ # Extract the particular known segment
+ fitKK <- extractSegments(fitJJ, idxs);
+
+ # Only add if it has loci
+ if (nbrOfLoci(fitKK) > 0L) {
+ fitListJJ <- append(fitListJJ, list(fitKK));
+ }
+
+ fitKK <- NULL; # Not needed anymore
+ verbose && exit(verbose);
+ } # for (kk ...)
+
+ # Append
+ fitList <- append(fitList, fitListJJ);
+ fitListJJ <- NULL; # Not needed anymore
+
+ verbose && exit(verbose);
+ } # for (jj ...)
+
+ nbrOfRegions <- length(fitList);
+ verbose && cat(verbose, "Number of independent non-empty regions: ", nbrOfRegions);
+ verbose && exit(verbose);
+
+ verbose && enter(verbose, "Shift every other region");
+ for (jj in seq(from=1L, to=nbrOfRegions, by=2L)) {
+ fitJJ <- fitList[[jj]];
+ fitJJ <- shiftTCN(fitJJ, shift=shift);
+ fitList[[jj]] <- fitJJ;
+ } # for (jj ...)
+ verbose && exit(verbose);
+
+ verbose && enter(verbose, "Merge");
+ fitT <- Reduce(function(a, b) append(a,b, addSplit=FALSE), fitList);
+ # Sanity check
+## stopifnot(nbrOfSegments(fitT) == nbrOfSegments(fit)); # Not true anymore
+ verbose && exit(verbose);
+ fitList <- NULL; # Not needed anymore
+
+ segsT <- getSegments(fitT);
+ verbose && print(verbose, tail(segsT));
+ verbose && exit(verbose);
+
+ fit <- fitT;
+
+ # Not needed anymore
+ fitT <- knownSegments <- NULL;
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract signals for DP
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Extracting signals for dynamic programming");
+
+ fit <- tileChromosomes(fit);
+
+ # Locus-level signals
+ data <- getLocusData(fit);
+ Y <- as.matrix(data[,by,drop=FALSE]);
+ verbose && print(verbose, summary(Y));
+
+ # "DP" change-point indices (excluding the two outer/boundary ones)
+ segRows <- fit[[segRowsKey]];
+ segIdxs <- seq(length=nrow(segRows)-1L);
+ cpIdxs <- segRows$endRow[segIdxs];
+
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Dynamic-programming segmention pruning
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Dynamic programming");
+
+ verbose && cat(verbose, "Number of \"DP\" change points: ", length(cpIdxs));
+ verbose && str(verbose, cpIdxs);
+
+ res <- seqOfSegmentsByDP(Y, candidatechangepoints=cpIdxs, ...);
+ verbose && str(verbose, res);
+
+ # Sanity checks
+ jumpList <- res$jump;
+ lastJump <- jumpList[[length(jumpList)]];
+ stopifnot(identical(cpIdxs, as.integer(lastJump)));
+
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Adjustments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Excluding cases where known segments no longer correct");
+
+ verbose && cat(verbose, "Number of independent non-empty regions: ", nbrOfRegions);
+
+ # Drop the K first
+ nbrOfCPs <- nbrOfRegions - 1L;
+ if (nbrOfCPs > 0L) {
+ K <- nbrOfCPs - 1L; # Don't count the flat segmentation
+ jumpList <- jumpList[-(1:K)];
+ }
+
+ verbose && str(verbose, jumpList);
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract the possible sets of segments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose <- less(verbose, 20);
+ verbose && enter(verbose, "Converting to physical segments");
+
+ segs <- getSegments(fit, splitters=TRUE, addGaps=FALSE);
+ segs <- segs[,c("chromosome", segKeys)];
+ jumpIdxList <- lapply(jumpList, FUN=function(idxs) {
+ match(idxs, table=cpIdxs);
+ });
+ # Sanity check
+ stopifnot(identical(seq(along=cpIdxs), jumpIdxList[[length(jumpIdxList)]]));
+
+ chrs <- segs$chromosome;
+ starts <- segs[[segKeys[1]]];
+ ends <- segs[[segKeys[2]]];
+ nsegs <- nrow(segs);
+ segList <- vector("list", length=length(jumpIdxList));
+ for (kk in seq(along=segList)) {
+ verbose && enter(verbose, sprintf("Sequence #%d of %d", kk, length(segList)));
+ idxs <- jumpIdxList[[kk]];
+ verbose && cat(verbose, "Change point indices:");
+ verbose && str(verbose, idxs);
+
+ chrsKK <- chrs[idxs];
+ chr <- chrsKK[1];
+# stopifnot(all(chrsKK == chr));
+ chrsKK <- c(chrsKK, chrsKK[length(chrsKK)]);
+ startsKK <- starts[c(1L, idxs+1L)];
+ endsKK <- ends[c(idxs, nsegs)];
+ verbose && cat(verbose, "Chromosomes:");
+ verbose && str(verbose, chrsKK);
+ verbose && cat(verbose, "Starts:");
+ verbose && str(verbose, startsKK);
+ verbose && cat(verbose, "Ends:");
+ verbose && str(verbose, endsKK);
+
+
+ offsetsKK <- chrOffsets[chrsKK];
+ startsKK <- startsKK - offsetsKK;
+ endsKK <- endsKK - offsetsKK;
+ segsKK <- data.frame(chromosome=chrsKK, start=startsKK, end=endsKK);
+ verbose && print(verbose, tail(segsKK));
+ segList[[kk]] <- segsKK;
+
+ verbose && exit(verbose);
+ } # for (kk ...)
+
+ verbose && exit(verbose);
+ verbose <- more(verbose, 20);
+
+
+ # Sanity check
+ lastSegs <- segList[[length(segList)]];
+# stopifnot(identical(lastSegs, segs));
+ verbose && str(verbose, segList);
+
+ nbrOfCPsSeq <- sapply(jumpList, FUN=length);
+ verbose && cat(verbose, "Sequence of number of \"DP\" change points:");
+ verbose && print(verbose, nbrOfCPsSeq);
+
+ nbrOfSegsSeq <- sapply(segList, FUN=nrow);
+ verbose && cat(verbose, "Sequence of number of segments:");
+ verbose && print(verbose, nbrOfSegsSeq);
+
+ nbrOfChangePointsSeq <- nbrOfSegsSeq - nbrOfRegions;
+ verbose && cat(verbose, "Sequence of number of \"discovered\" change points:");
+ verbose && print(verbose, nbrOfChangePointsSeq);
+
+ stopifnot(nbrOfSegsSeq == nbrOfCPsSeq + 1L);
+ stopifnot(nbrOfSegsSeq[1L] == nbrOfRegions);
+
+ segList <- lapply(segList, FUN=function(seg) {
+ attr(seg, "nbrOfChangePoints") <- nrow(seg) - nbrOfRegions;
+ seg;
+ });
+
+ K <- (nbrOfRegions-1L);
+ modelFit <- list(
+ nbrOfSegments=nbrOfSegsSeq,
+ nbrOfChangePoints=nbrOfSegsSeq - nbrOfRegions,
+ nbrOfRegions=nbrOfRegions,
+ idxBest=res$kbest - K + 1L,
+ rse=res$rse[-(1:K)],
+ V=res$V[-(1:K),-(1:K),drop=FALSE],
+ seqOfSegmentsByDP=res
+ );
+ attr(segList, "modelFit") <- modelFit;
+
+ verbose && exit(verbose);
+
+ segList;
+}, protected=TRUE) # seqOfSegmentsByDP()
+
+
+
+setMethodS3("seqOfSegmentsByDP", "matrix", function(
+### Segmentation of a multi-dimensional signal with dynamic programming.
+Y,
+### A n*p signal to be segmented
+candidatechangepoints = c(1:(n-1)),
+### A vector of candidate positions for change-points (default=[1:n-1])
+kmax = n-1,
+### Maximum number of change-points to test (default : n-1)
+threshold = 0.5,
+### Stopping criteria. Typically chosen to be in the interval
+### (0 0.5]. The smaller the threshold, the higher the tendency to keep more
+### changepoints. The criteria is based on the method found in 'Picard et al
+### (2005)', "A statistical approach for array CGH data analysis" (BMC
+### Bioinformatics). Default=0.5
+...
+){
+ n <- dim(Y)[1];
+ p <- dim(Y)[2];
+ kmaxmin <- floor(n/4);
+
+ if (kmax == 0 || kmax > length(candidatechangepoints)) {
+ kmax <- min(length(candidatechangepoints), kmaxmin);
+ }
+
+ if (kmax > kmaxmin) {
+ sprintf('warning : not enough points to optimize the number of the change-points up to %s\n', kmax);
+ kmax <- kmaxmin;
+ sprintf('Set the maximum number of change-points to %s\n', kmax);
+ }
+
+ # Compute boundaries of the smallest intervals considered
+ b <- sort(union(0, union(n, candidatechangepoints)));
+ k <- length(b) - 1; # k is the number of such intervals
+ # Compute the k*k matrix J such that J[i,j] for i<=j is the RSE when intervales i to j are merged
+ J <- matrix(numeric(k*k), ncol=k);
+
+ # How should NAs be handled?!?
+ Yz <- Y;
+ Yz[is.na(Yz)] <- 0;
+ s <- rbind(rep(0, times=p), colCumsums(Yz));
+ v <- c(0, cumsum(rowSums(Y^2, na.rm=TRUE)));
+ for (i in 1:k) {
+ for (j in i:k) {
+ Istart <- b[i] + 1;
+ Iend <- b[j+1];
+ J[i,j] <- v[Iend+1] - v[Istart] - sum((s[Iend+1,]-s[Istart,])^2, na.rm=TRUE)/(Iend-Istart+1);
+ } # for (j ...)
+ } # for (i ...)
+
+ # Dynamic programming
+ V <- matrix(numeric((kmax+1)*k), ncol=k); # V[i,j] is the best RSE for segmenting intervals 1 to j with at most i-1 change points
+ jump <- matrix(numeric(kmax*k), ncol=k);
+ # With no change points, V[i,j] is juste the precomputed RSE for intervals 1 to j
+ V[1,] <- J[1,];
+ # Then we apply the recursive formula
+ for (ki in 1:kmax) {
+ for (j in (ki+1):k) {
+ val <- min(V[ki,ki:(j-1)] + t(J[(ki+1):j, j]));
+ ind <- which.min(V[ki,ki:(j-1)] + t(J[(ki+1):j, j]));
+ V[ki+1,j] <- val;
+ jump[ki,j] <- ind + ki-1;
+ } # for (j ...)
+ } # for (ki ...)
+
+ # Optimal segmentation
+ res.jump <- list();
+ for (ki in 1:kmax) {
+ res.jump[[ki]] <- numeric(ki);
+ res.jump[[ki]][ki] <- jump[ki,k];
+ if (ki != 1) {
+ for (i in seq(from=(ki-1), to=1, by=-1)) {
+ res.jump[[ki]][i] <- jump[i, res.jump[[ki]][i+1]];
+ }
+ }
+ } # for (ki ...)
+
+ # Convert back the index of the interval to the last position before the jump
+ rightlimit <- b[2:length(b)];
+ for (ki in 1:kmax) {
+ res.jump[[ki]] <- rightlimit[res.jump[[ki]]];
+ } # for (ki ...)
+
+ # RSE as a function of number of change-points
+ res.rse <- V[,k];
+ # Optimal number of change points
+ options(warn=-1);
+ J <- log(res.rse);
+ Km <- length(J);
+ Jtild <- (J[Km]-J)/(J[Km]-J[1])*(Km-1)+1; # Normalize
+ res.kbest <- max(which(diff(diff(Jtild)) > threshold)) + 1;
+ #if((res.kbest) == -Inf) { res.kbest <- 1 };
+ return(list(jump=res.jump, rse=res.rse, kbest=res.kbest, V=V));
+### \item{res.jump{i}}{a i*1 vector of change-point positions for the i-th lambda value (i depends on lambda). i varies between 1 and kmax}
+### \item{res.rse}{a (kmax+1)-dimensional vector of residual squared error}
+### \item{res.kbest}{the number of selected change-points}
+}) # seqOfSegmentsByDP()
+
+
+
+###########################################################################/**
+# @set class=AbstractCBS
+# @RdocMethod pruneByDP
+#
+# @title "Prunes the CN profile using dynamical programming"
+#
+# \description{
+# @get "title" by specifying the target number of segments or alternative
+# how of many change points to drop.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{nbrOfSegments}{An @integer specifying the number of segments after
+# pruning. If negative, the it specifies the number of change points
+# to drop.}
+# \item{...}{Optional arguments passed to @seemethod "seqOfSegmentsByDP".}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns a pruned object of the same class.
+# }
+#
+# \examples{\dontrun{
+# # Drop two segments
+# fitP <- pruneByDP(fit, nbrOfSegments=-2);
+# }}
+#
+# @author "HB, PN"
+#
+# \references{
+# [1] ... \cr
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("pruneByDP", "AbstractCBS", function(fit, nbrOfSegments, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Some pre-extraction
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ knownSegments <- fit$params$knownSegments;
+ if (nrow(knownSegments) == 0L) {
+ chromosome <- getChromosomes(fit);
+ knownSegments <- data.frame(chromosome=chromosome, start=-Inf, end=+Inf);
+ }
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'nbrOfSegments':
+ nbrOfSegments <- Arguments$getInteger(nbrOfSegments);
+ # Specifying number of change points *to drop*?
+ if (nbrOfSegments < 0L) {
+ nbrOfCPsToDrop <- -nbrOfSegments;
+ nbrOfSegments <- nbrOfSegments(fit, splitters=FALSE) - nbrOfCPsToDrop;
+ }
+
+ if (nbrOfSegments < nrow(knownSegments)) {
+ throw("Argument 'nbrOfSegments' is less than number of \"known\" segments: ", nbrOfSegments, " < ", nrow(knownSegments));
+ }
+ if (nbrOfSegments > nbrOfSegments(fit, splitters=FALSE)) {
+ throw("Argument 'nbrOfSegments' is greater than the number of \"found\" segments: ", nbrOfSegments, " > ", nbrOfSegments(fit, splitters=FALSE));
+ }
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Prune segments by dynamical programming");
+
+ # Nothing to do?
+ if (nbrOfSegments == nbrOfSegments(fit, splitters=FALSE)) {
+ verbose && cat(verbose, "No need for pruning, because the number of \"target\" segments is the same as the number of \"found\" segments: ", nbrOfSegments, " == ", nbrOfSegments(fit, splitters=FALSE));
+ return(fit);
+ verbose && exit(verbose);
+ }
+
+ verbose && cat(verbose, "Target number of segments: ", nbrOfSegments);
+
+ verbose && enter(verbose, "Dynamic programming");
+ segList <- seqOfSegmentsByDP(fit, ...);
+
+ # Select the one with expected number of segments
+ nbrOfCPs <- sapply(segList, FUN=nrow);
+ verbose && printf(verbose, "Range of number of CPs among solutions: [%d,%d]\n", min(nbrOfCPs), max(nbrOfCPs));
+
+ keep <- which(nbrOfCPs == nbrOfSegments);
+ stopifnot(length(keep) == 1L);
+
+ knownSegments <- segList[[keep]];
+ verbose && printf(verbose, "Solution with %d segments:\n", nbrOfSegments);
+ verbose && print(verbose, knownSegments);
+ verbose && exit(verbose);
+
+ verbose && enter(verbose, "Rebuilding segmentation results");
+ fitDP <- resegment(fit, knownSegments=knownSegments, undoTCN=+Inf, undoDH=+Inf, verbose=less(verbose, 10));
+ verbose && print(verbose, fitDP);
+ verbose && exit(verbose);
+
+ verbose && exit(verbose);
+
+ fitDP;
+}, protected=TRUE) # pruneByDP()
+
+
+
+
+############################################################################
+# HISTORY:
+# 2012-09-21
+# o Now seqOfSegmentsByDP() return a 'modelFit' attribute.
+# 2012-09-20
+# o BUG FIX: seqOfSegmentsByDP() for AbstractCBS would not handle empty
+# segments, which could occur if 'knownSegments' for instance included
+# centromere gaps.
+# 2012-09-14
+# o Added pruneByDP(..., nbrOfSegments) for AbstractCBS.
+# o Added seqOfSegmentsByDP() which is a matrix version of dpseg() from
+# GFLseg v0.1.6 by Morgane Pierre-Jean and Pierre Neuvial, which in turn
+# ported it from the Matlab GPL source code by the original authors ???.
+# o Generalized seqOfSegmentsByDP() to work for AbstractCBS.
+# 2012-09-13
+# o Added seqOfSegmentsByDP() for PairedPSCBS.
+# o Created.
+############################################################################
diff --git a/R/AbstractCBS.R b/R/AbstractCBS.R
new file mode 100644
index 0000000..9a3735d
--- /dev/null
+++ b/R/AbstractCBS.R
@@ -0,0 +1,933 @@
+###########################################################################/**
+# @RdocClass AbstractCBS
+#
+# @title "The AbstractCBS class"
+#
+# \description{
+# @classhierarchy
+#
+# All CBS-style segmentation results extend this class, e.g.
+# @see "CBS" and @see "PairedPSCBS".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{fit}{A @list structure containing the segmentation results.}
+# \item{sampleName}{A @character string.}
+# \item{...}{Not used.}
+# }
+#
+# \section{Fields and Methods}{
+# @allmethods "public"
+# }
+#
+# @author "HB"
+#
+# @keyword internal
+#*/###########################################################################
+setConstructorS3("AbstractCBS", function(fit=list(), sampleName=fit$sampleName, ...) {
+ # Argument 'sampleName':
+ if (!is.null(sampleName)) {
+ sampleName <- Arguments$getCharacter(sampleName);
+ }
+
+ fit$sampleName <- sampleName;
+ extend(fit, "AbstractCBS");
+})
+
+
+setMethodS3("print", "AbstractCBS", function(x, ...) {
+ # To please R CMD check
+ fit <- x;
+
+ segs <- getSegments(fit, simplify=TRUE, ...);
+ print(segs);
+}, protected=TRUE)
+
+
+
+
+setMethodS3("all.equal", "AbstractCBS", function(target, current, check.attributes=FALSE, ...) {
+ # NOTE: Here we cannot trust argument '...', because it may contain
+ # copies of 'target' and 'current'
+ args <- list(...);
+ drop <- integer(0L);
+ for (kk in seq_along(args)) {
+ if (identical(args[[kk]], target)) drop <- c(drop, kk);
+ if (identical(args[[kk]], current)) drop <- c(drop, kk);
+ }
+ if (length(drop) > 0L) {
+ args <- args[-drop];
+ str(args);
+# assign("...", args, inherits=FALSE);
+ }
+ args <- list(...);
+
+ # Compare class attributes
+ res <- all.equal(class(target), class(current));
+ if (!isTRUE(res)) {
+ return(res);
+ }
+
+ # Compare locus-level data
+ dataT <- getLocusData(target);
+ dataC <- getLocusData(current);
+ res <- all.equal(dataT, dataC, check.attributes=check.attributes);
+ if (!isTRUE(res)) {
+ attr(res, "what") <- "getLocusData()";
+ return(res);
+ }
+
+ # Compare segments
+ dataT <- getSegments(target);
+ dataC <- getSegments(current);
+ res <- all.equal(dataT, dataC, check.attributes=check.attributes);
+ if (!isTRUE(res)) {
+ attr(res, "what") <- "getSegments()";
+ return(res);
+ }
+
+ # Compare field names
+ fieldsT <- names(target);
+ fieldsC <- names(current);
+ res <- all.equal(fieldsT, fieldsC, check.attributes=check.attributes);
+ if (!isTRUE(res)) {
+ attr(res, "what") <- "names";
+ return(res);
+ }
+
+ # Compare other fields
+ for (key in fieldsT) {
+ dataT <- target[[key]];
+ dataC <- current[[key]];
+ res <- all.equal(dataT, dataC, check.attributes=check.attributes);
+ if (!isTRUE(res)) {
+ attr(res, "what") <- sprintf("[[\"%s\"]]", key);
+ return(res);
+ }
+ } # for (key ...)
+
+ return(TRUE);
+}, protected=TRUE)
+
+
+
+###########################################################################/**
+# @RdocMethod save
+#
+# @title "Saves an AbstractCBS object to file"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Additional arguments passed to @see "R.utils::saveObject".}
+# }
+#
+# \value{
+# Returns what @see "R.utils::saveObject" returns.
+# }
+#
+# @author
+#
+# \seealso{
+# Internally @see "R.utils::saveObject" is used.
+# To load an object, see @seemethod "load".
+# @seeclass.
+# }
+#*/###########################################################################
+setMethodS3("save", "AbstractCBS", function(this, ...) {
+ saveObject(this, ...);
+})
+
+
+###########################################################################/**
+# @RdocMethod load
+# @alias load
+#
+# @title "Loads an AbstractCBS object from file"
+#
+# \description{
+# @get "title" and assert that it is of the requested class.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Additional arguments passed to @see "R.utils::loadObject".}
+# }
+#
+# \value{
+# Returns the loaded AbstractCBS object.
+# }
+#
+# @author
+#
+# \seealso{
+# Internally @see "R.utils::loadObject" is used.
+# To save an object, see @seemethod "save".
+# @seeclass.
+# }
+#*/###########################################################################
+setMethodS3("load", "AbstractCBS", function(static, ...) {
+ object <- loadObject(...);
+
+ # Patch for changes in class structure in PSCBS v0.13.2 -> v0.13.3.
+ if (!inherits(object, "AbstractCBS")) {
+ if (inherits(object, "CBS")) {
+ class(object) <- c(class(object), "AbstractCBS");
+ warning("Added 'AbstractCBS' to the class hierarchy of the loaded ", class(object)[1], " object.");
+ } else if (inherits(object, "PairedPSCBS")) {
+ class(object) <- c(class(object), "AbstractCBS");
+ warning("Added 'AbstractCBS' to the class hierarchy of the loaded ", class(object)[1], " object.");
+ }
+ }
+
+ # Sanity check
+ if (!inherits(object, class(static)[1])) {
+ throw("Loaded an object from file, but it does not inherit from ",
+ class(static)[1], " as expected: ", hpaste(class(object)));
+ }
+
+ object;
+}, static=TRUE)
+
+
+
+###########################################################################/**
+# @RdocMethod getSampleName
+# @aliasmethod sampleName
+#
+# @title "Gets the name of the sample segmented"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns a @character string.
+# }
+#
+# @author
+#
+# \seealso{
+# @seemethod "setSampleName".
+# @seeclass.
+# }
+#*/###########################################################################
+setMethodS3("getSampleName", "AbstractCBS", function(fit, ...) {
+ name <- fit$sampleName;
+ if (is.null(name)) {
+ name <- as.character(NA);
+ }
+ name;
+}, protected=TRUE)
+
+setMethodS3("sampleName", "AbstractCBS", function(fit, ...) {
+ getSampleName(fit);
+}, protected=TRUE)
+
+
+###########################################################################/**
+# @RdocMethod setSampleName
+# @aliasmethod sampleName<-
+#
+# @title "Sets the name of the sample segmented"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{name}{A @character string.}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns (invisibly) an updated object.
+# }
+#
+# @author
+#
+# \seealso{
+# @seeclass.
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("setSampleName", "AbstractCBS", function(fit, name, ...) {
+ # Argument 'value':
+ name <- Arguments$getCharacter(name);
+
+ fit$sampleName <- name;
+
+ invisible(fit);
+}, protected=TRUE)
+
+
+setMethodS3("sampleName<-", "AbstractCBS", function(x, value) {
+ setSampleName(x, value);
+}, protected=TRUE, addVarArgs=FALSE)
+
+"sampleName<-" <- function(x, value) {
+ UseMethod("sampleName<-");
+}
+
+
+
+###########################################################################/**
+# @RdocMethod getLocusData
+# @aliasmethod setLocusData
+# @alias setLocusData.AbstractCBS
+#
+# @title "Gets the locus-level data"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{splitters}{If @TRUE, "splitters" between chromosomes are
+# preserved, otherwise dropped.}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns a JxL @data.frame, where J in the number of loci,
+# and L is the number of locus-specific fields.
+# }
+#
+# @author
+#
+# \seealso{
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("getLocusData", "AbstractCBS", abstract=TRUE);
+
+setMethodS3("setLocusData", "AbstractCBS", function(fit, loci, ...) {
+ # Argument 'loci':
+ loci <- Arguments$getInstanceOf(loci, "data.frame");
+ nbrOfLoci <- nbrOfLoci(fit);
+ if (nrow(loci) != nbrOfLoci) {
+ throw("Cannot set locus-level data. The number of loci to be set differ from the existing number of loci: ", nrow(loci), " != ", nbrOfLoci);
+ }
+
+ fit$data <- loci;
+
+ invisible(fit);
+}, protected=TRUE)
+
+
+setMethodS3("getLocusSignalNames", "AbstractCBS", abstract=TRUE, protected=TRUE);
+
+setMethodS3("getSegmentTrackPrefixes", "AbstractCBS", abstract=TRUE, protected=TRUE);
+
+
+###########################################################################/**
+# @RdocMethod nbrOfLoci
+#
+# @title "Gets the number of loci"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{splitters, ...}{Arguments passed to @seemethod "getLocusData".}
+# }
+#
+# \value{
+# Returns an @integer.
+# }
+#
+# @author
+#
+# \seealso{
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("nbrOfLoci", "AbstractCBS", function(fit, splitters=FALSE, ...) {
+ data <- getLocusData(fit, splitters=splitters, ...);
+ nrow(data);
+})
+
+
+
+###########################################################################/**
+# @RdocMethod getSegments
+# @aliasmethod setSegments
+# @alias setSegments.AbstractCBS
+#
+# @title "Gets the segments"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{simplify}{If @TRUE, redundant and intermediate information is dropped.}
+# \item{splitters}{If @TRUE, "splitters" between chromosomes are
+# preserved, otherwise dropped.}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns a SxK @data.frame, where S in the number of segments,
+# and K is the number of segment-specific fields.
+# }
+#
+# @author
+#
+# \seealso{
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("getSegments", "AbstractCBS", abstract=TRUE);
+
+
+setMethodS3("setSegments", "AbstractCBS", function(fit, segments, ...) {
+ # Argument 'segments':
+ segments <- Arguments$getInstanceOf(segments, "data.frame")
+ nbrOfSegs <- nbrOfSegments(fit, ...)
+ if (nrow(segments) != nbrOfSegs) {
+ throw("Cannot set segments. The number of segments to be set differ from the existing number of segments: ", nrow(segments), " != ", nbrOfSegs)
+ }
+
+ fit$output <- segments
+
+ invisible(fit)
+}, protected=TRUE)
+
+
+setMethodS3("getChangePoints", "AbstractCBS", abstract=TRUE);
+
+
+
+###########################################################################/**
+# @RdocMethod resetSegments
+#
+# @title "Reset the segments"
+#
+# \description{
+# @get "title". More precisely, it removes columns in the segmentation
+# result table that have been added by methods after the actual
+# segmentation method, e.g. bootstrap estimated mean level quantiles
+# and various calls.
+# It leave the basic segmentation results untouched,
+# i.e. the partitioning and the segment means.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns an object if the same class as the input result.
+# }
+#
+# @author
+#
+# \seealso{
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("resetSegments", "AbstractCBS", function(fit, ...) {
+ segs <- getSegments(fit, splitters=TRUE)
+ names <- colnames(segs);
+
+ excl <- NULL;
+
+ # Drop all quantile mean level estimates (from bootstrapping)
+ idxs <- grep("_[0-9.]*[%]$", names);
+ excl <- c(excl, idxs);
+
+ # Drop all calls
+ idxs <- grep("Call$", names);
+ excl <- c(excl, idxs);
+
+ excl <- unique(excl);
+ if (length(excl) > 0L) {
+ segs <- segs[,-excl];
+ }
+
+ fit <- setSegments(fit, segs, splitters=TRUE)
+ invisible(fit);
+}, protected=TRUE)
+
+
+
+###########################################################################/**
+# @RdocMethod nbrOfSegments
+#
+# @title "Gets the number of segments"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{splitters, ...}{Arguments passed to @seemethod "getSegments".}
+# }
+#
+# \value{
+# Returns an @integer.
+# }
+#
+# @author
+#
+# \seealso{
+# @seemethod "nbrOfChangePoints"
+# @seemethod "nbrOfChromosomes"
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("nbrOfSegments", "AbstractCBS", function(this, splitters=FALSE, ...) {
+ nrow(getSegments(this, splitters=splitters, ...));
+})
+
+
+
+###########################################################################/**
+# @RdocMethod nbrOfChangePoints
+#
+# @title "Gets the number of change points"
+#
+# \description{
+# @get "title", which is defined as the number of segments minus
+# the number of chromosomes.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns an @integer.
+# }
+#
+# @author
+#
+# \seealso{
+# @seemethod "nbrOfSegments"
+# @seemethod "nbrOfChromosomes"
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("nbrOfChangePoints", "AbstractCBS", function(fit, ignoreGaps=FALSE, dropEmptySegments=TRUE, ...) {
+ segs <- getSegments(fit, splitters=TRUE, addGaps=!ignoreGaps);
+ if (dropEmptySegments) {
+ prefix <- getSegmentTrackPrefixes(fit);
+ keys <- sapply(prefix, FUN=function(x) {
+ toCamelCase(paste(c(x, "nbr of loci"), collapse=" "));
+ });
+ counts <- as.matrix(segs[,keys]);
+ counts <- rowSums(counts, na.rm=TRUE);
+ segs$chromosome[counts == 0L] <- NA;
+ }
+ sum(!is.na(diff(segs$chromosome)));
+})
+
+
+
+###########################################################################/**
+# @RdocMethod as.data.frame
+#
+# @title "Gets the table of segments"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns a @data.frame, where each row corresponds to
+# a unique segment.
+# }
+#
+# @author
+#
+# \seealso{
+# Utilizes @seemethod "getSegments".
+# @seeclass.
+# }
+#*/###########################################################################
+setMethodS3("as.data.frame", "AbstractCBS", function(x, ...) {
+ getSegments(x, ...);
+}, protected=TRUE)
+
+
+
+
+###########################################################################/**
+# @RdocMethod getChromosomes
+#
+# @title "Gets the set of chromosomes"
+#
+# \description{
+# @get "title" in the segmentation result.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Arguments passed to @seemethod "getSegments".}
+# }
+#
+# \value{
+# Returns a unique and sorted @vector of chromosomes segmented.
+# }
+#
+# @author
+#
+# \seealso{
+# @seemethod "nbrOfChromosomes".
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("getChromosomes", "AbstractCBS", function(this, ...) {
+ segs <- getSegments(this, ...);
+ chromosomes <- sort(unique(segs$chromosome), na.last=TRUE);
+
+ # Drop NA dividers
+ if (length(chromosomes) > 1) {
+ chromosomes <- chromosomes[!is.na(chromosomes)];
+ }
+
+ chromosomes;
+})
+
+
+###########################################################################/**
+# @RdocMethod nbrOfChromosomes
+#
+# @title "Gets the number of chromosomes"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Arguments passed to @seemethod "getChromosomes".}
+# }
+#
+# \value{
+# Returns an @integer.
+# }
+#
+# @author
+#
+# \seealso{
+# @seemethod "getChromosomes".
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("nbrOfChromosomes", "AbstractCBS", function(this, ...) {
+ length(getChromosomes(this, ...));
+})
+
+
+setMethodS3("getSegmentSizes", "AbstractCBS", function(fit, by=c("length", "count"), ...) {
+ by <- match.arg(by);
+
+ if (by == "length") {
+ prefix <- getSegmentTrackPrefixes(fit)[1];
+ keys <- toCamelCase(paste(prefix, " ", c("start", "end")));
+ } else if (by == "count") {
+ keys <- "nbrOfLoci";
+ }
+ data <- getSegments(fit, ...)[,keys];
+
+ if (by == "length") {
+ res <- data[[2L]]-data[[1L]]+1L;
+ } else if (by == "count") {
+ res <- data[[1L]];
+ }
+ res;
+})
+
+
+setMethodS3("extractCNs", "AbstractCBS", abstract=TRUE);
+
+setMethodS3("sampleCNs", "AbstractCBS", function(fit, size=NULL, ...) {
+ data <- extractCNs(fit, ...);
+
+ if (!is.null(size)) {
+ sizes <- getSegmentSizes(fit, ...);
+ # Sanity check
+ stopifnot(length(sizes) == nrow(data));
+ idxs <- sample(nrow(data), size=size, replace=TRUE, prob=sizes);
+ data <- data[idxs,,drop=FALSE];
+ }
+
+ data;
+})
+
+###########################################################################/**
+# @RdocMethod updateMeans
+# @alias updateMeans.CBS
+# @alias updateMeans.NonPairedPSCBS
+# @alias updateMeans.PairedPSCBS
+#
+# @title "Updates the CN mean levels for each segment independently"
+#
+# \description{
+# @get "title" as if they were one large segment.
+# The locus-level data is not updated/modified.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Arguments specific to the class.}
+# }
+#
+# \value{
+# Returns an object of the same class.
+# }
+#
+# @author
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("updateMeans", "AbstractCBS", abstract=TRUE, protected=TRUE);
+
+
+setMethodS3("getMeanEstimators", "AbstractCBS", function(fit, which=NULL, default=mean, ...) {
+ estList <- fit$params$meanEstimators;
+ if (is.null(estList)) {
+ estList <- list();
+ }
+
+ if (is.null(which)) which <- names(estList);
+
+ for (key in which) {
+ fcn <- estList[[key]];
+ if (is.null(fcn)) {
+ fcn <- default;
+ } else if (is.character(fcn)) {
+ fcn <- get(fcn, mode="function");
+ }
+ estList[[key]] <- fcn;
+ }
+
+ estList;
+}, protected=TRUE)
+
+
+setMethodS3("setMeanEstimators", "AbstractCBS", function(fit, ...) {
+ estList <- fit$params$meanEstimators;
+ if (is.null(estList)) {
+ estList <- list();
+ }
+
+ args <- list(...);
+
+ # Nothing todo?
+ if (length(args) == 0L) {
+ return(invisible(fit));
+ }
+
+ keys <- names(args);
+ if (is.null(keys)) {
+ throw("Estimators arguments must be named.");
+ }
+
+ for (key in keys) {
+ fcn <- args[[key]];
+ if (is.function(fcn)) {
+ } else if (is.character(fcn)) {
+ if (!exists(fcn, mode="function")) {
+ throw(sprintf("No such '%s' estimator function: %s", key, fcn));
+ }
+ } else {
+ throw(sprintf("Estimator argument '%s' must be a function or character string: %s", key, mode(fcn)));
+ }
+ estList[[key]] <- fcn;
+ }
+
+ fit$params$meanEstimators <- estList;
+
+ invisible(fit);
+}, protected=TRUE)
+
+
+setMethodS3("resegment", "AbstractCBS", abstract=TRUE, protected=TRUE);
+
+
+setMethodS3("getChromosomeRanges", "AbstractCBS", abstract=TRUE, protected=TRUE);
+
+setMethodS3("getChromosomeOffsets", "AbstractCBS", function(fit, resolution=1e6, ...) {
+ # Argument 'resolution':
+ if (!is.null(resolution)) {
+ resolution <- Arguments$getDouble(resolution, range=c(1,Inf));
+ }
+
+ data <- getChromosomeRanges(fit, ...);
+ splits <- data[,"start"] + data[,"length"];
+
+ if (!is.null(resolution)) {
+ splits <- ceiling(splits / resolution);
+ splits <- resolution * splits;
+ }
+
+ offsets <- c(0L, cumsum(splits));
+ names(offsets) <- c(rownames(data), NA);
+
+ offsets;
+}, protected=TRUE) # getChromosomeOffsets()
+
+
+
+###########################################################################/**
+# @RdocMethod ploidy
+# @aliasmethod ploidy<-
+# @aliasmethod setPloidy
+# @aliasmethod adjustPloidyScale
+# @alias adjustPloidyScale.PairedPSCBS
+# @alias adjustPloidyScale
+# @alias ploidy
+# @alias ploidy<-
+# @alias setPloidy
+#
+# @title "Gets and sets ploidy"
+#
+# \description{
+# @get "title".
+# }
+#
+# \usage{
+# \method{ploidy}{AbstractCBS}(fit, ...)
+# \method{ploidy}{AbstractCBS}(fit) <- value
+# }
+#
+# \arguments{
+# \item{fit}{An @see "AbstractCBS" object.}
+# \item{value}{An @integer (in \eqn{1,2,\ldots}) specifying the genome ploidy .}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns (invisibly) an updated object.
+# }
+#
+# @author
+#
+# \seealso{
+# @seeclass.
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("ploidy", "AbstractCBS", function(fit, ...) {
+ ploidy <- fit$params$ploidy;
+ if (is.null(ploidy)) ploidy <- 2L;
+ ploidy;
+})
+
+setMethodS3("ploidy<-", "AbstractCBS", function(fit, value) {
+ fit <- setPloidy(fit, ploidy=value, update=TRUE);
+ invisible(fit);
+})
+
+"ploidy<-" <- function(fit, value) {
+ UseMethod("ploidy<-");
+}
+
+setMethodS3("setPloidy", "AbstractCBS", function(fit, ploidy=2L, update=TRUE, ...) {
+ # Argument 'ploidy':
+ ploidy <- Arguments$getInteger(ploidy, range=c(1,Inf));
+
+ if (update) {
+ # Calculate rescaling factor
+ oldPloidy <- ploidy(fit);
+ scale <- ploidy / oldPloidy;
+
+ # Nothing todo?
+ if (scale != 1) {
+ fit <- adjustPloidyScale(fit, scale=scale, ...);
+ }
+ }
+
+ fit$params$ploidy <- ploidy;
+ invisible(fit);
+}, protected=TRUE)
+
+
+setMethodS3("adjustPloidyScale", "AbstractCBS", abstract=TRUE);
+
+
+############################################################################
+# HISTORY:
+# 2013-11-05
+# o Added basic implementations of setLocusData() and setSegments()
+# for AbstractCBS.
+# 2013-10-20
+# o Added abstract getChangePoints().
+# 2013-05-07
+# o Added ploidy() and ploidy()<- for AbstractCBS.
+# 2013-02-01
+# o Added resetSegments() for AbstractCBS, which drops extra segments
+# columns (e.g. bootstrap statisistics and calls) except those
+# obtained from the segment algorithm.
+# 2013-01-15
+# o Added get-/setMeanEstimators() for AbstractCBS.
+# 2012-09-21
+# o Now nbrOfChangePoints() for AbstractCBS calculates only change points
+# of connected neighboring segments.
+# 2012-09-14
+# o GENERALIZATION: Added getSegmentSizes() for AbstractCBS.
+# o GENERALIZATION: Added getChromosomeOffsets() for AbstractCBS.
+# 2012-09-13
+# o Updated all.equal() for AbstractCBS to compare locus-level data,
+# segments, and other fields.
+# 2012-06-03
+# o DOCUMENTATION: Added Rd help for updateMeans().
+# 2011-12-03
+# o Now print() for AbstractCBS returns getSegments(..., simplify=TRUE).
+# 2011-11-17
+# o Added resegment() for AbstractCBS.
+# 2011-10-30
+# o Added save() and load() methods to AbstractCBS.
+# 2011-10-16
+# o Added sampleCNs() for AbstractCBS.
+# o Added abstract getSegmentSizes() for AbstractCBS.
+# o Added abstract extractCNs() for AbstractCBS.
+# 2011-10-08
+# o Added abstract updateMeans() for AbstractCBS.
+# o Added all.equal() for AbstractCBS.
+# o Added nbrOfChangePoints() for AbstractCBS.
+# 2011-10-02
+# o Created.
+############################################################################
diff --git a/R/AbstractCBS.REPORT.R b/R/AbstractCBS.REPORT.R
new file mode 100644
index 0000000..bd6269c
--- /dev/null
+++ b/R/AbstractCBS.REPORT.R
@@ -0,0 +1,300 @@
+###########################################################################/**
+# @set class=AbstractCBS
+# @RdocMethod report
+#
+# @title "Generates a report of the segmentation results"
+#
+# \description{
+# @get "title".
+# Currently reports can be generated for segmentation results of class
+# @see "CBS" and @see "PairedPSCBS".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{fit}{An @see "AbstractCBS" object.}
+# \item{sampleName}{A @character string specifying the name of the
+# sample segmented.}
+# \item{studyName}{A @character string specifying the name of study/project.}
+# \item{...}{Optional arguments passed to the RSP template.}
+# \item{rspTags}{Optional @character @vector of tags for further specifying
+# which RSP report to generate.}
+# \item{rootPath}{The root directory where to write the report.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns the pathname of the generated PDF.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# @seeclass
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("report", "AbstractCBS", function(fit, sampleName=getSampleName(fit), studyName, ..., rspTags=NULL, rootPath="reports/", .filename="*", skip=TRUE, envir=new.env(), verbose=FALSE) {
+ use("R.rsp (>= 0.20.0)");
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'sampleName':
+ sampleName <- Arguments$getCharacter(sampleName);
+ if (is.na(sampleName)) {
+ throw("Cannot generate report. Argument 'sampleName' is non-valid or missing.");
+ }
+
+ # Argument 'studyName':
+ if (missing(studyName)) {
+ throw("Cannot generate report. Argument 'studyName' is missing.");
+ }
+ studyName <- Arguments$getCharacter(studyName);
+ if (is.na(studyName)) {
+ throw("Cannot generate report. Argument 'studyName' is non-valid.");
+ }
+
+ # Argument 'rspTags':
+ if (!is.null(rspTags)) {
+ rspTags <- Arguments$getCharacters(rspTags);
+ rspTags <- unlist(strsplit(rspTags, split=",", fixed=TRUE));
+ rspTags <- rspTags[nchar(rspTags) > 0L];
+ }
+
+ # Argument 'rootPath':
+ rootPath <- Arguments$getWritablePath(rootPath);
+
+ # Argument '.filename':
+ if (!is.null(.filename)) {
+ .filename <- Arguments$getCharacter(.filename, useNames=TRUE);
+ }
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Generating CBS report");
+
+ verbose && cat(verbose, "Sample name: ", sampleName);
+ verbose && cat(verbose, "Number of chromosomes: ", nbrOfChromosomes(fit));
+ verbose && cat(verbose, "Number of segments: ", nbrOfSegments(fit));
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Report template arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Default arguments
+ rspArgs <- list(
+ fit = fit,
+ sampleName = sampleName,
+ studyName = studyName,
+ dataSet = NULL,
+ Clim = c(0,2*ploidy(fit)),
+ Blim = c(0,1),
+ figForce = FALSE
+ );
+
+ # Override with user arguments
+ userArgs <- list(...);
+ for (key in names(userArgs)) {
+ rspArgs[[key]] <- userArgs[[key]];
+ }
+
+ if (is.null(rspArgs$reportPath)) {
+ rspArgs$reportPath <- file.path(rootPath, rspArgs$studyName);
+ }
+ rspArgs$reportPath <- Arguments$getWritablePath(rspArgs$reportPath);
+ verbose && cat(verbose, "Report root path: ", rspArgs$reportPath);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Linking to report files
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Linking to report files");
+
+ # Directory where all report templates lives
+ srcPath <- "templates";
+
+ # If missing, default to one that comes with PSCBS/templates/
+ if (!isDirectory(srcPath)) {
+ srcPath <- system.file("templates", package="PSCBS");
+ }
+ srcPath <- file.path(srcPath, "rsp");
+ srcPath <- Arguments$getReadablePath(srcPath);
+ verbose && cat(verbose, "Source path: ", srcPath);
+
+ filename <- .filename;
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Create file links to the main RSP report template
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Main RSP template");
+
+ # Construct the filename of the main RSP file to compile, iff missing.
+ if (filename == "*") {
+ className <- class(fit)[1];
+ fullname <- paste(c(className, rspTags), collapse=",");
+ filename <- sprintf("%s,report.tex.rsp", fullname);
+ }
+
+ rspPathname <- file.path(srcPath, filename);
+ verbose && cat(verbose, "RSP report template: ", rspPathname);
+ rspPathname <- Arguments$getReadablePathname(rspPathname);
+
+ destFilename <- sprintf("%s,%s", sampleName, filename);
+ destPathname <- filePath(rspArgs$reportPath, destFilename);
+ target <- rspPathname;
+ link <- destPathname;
+ if (!isFile(link)) {
+ verbose && cat(verbose, "Adding link: ", link, " -> ", target);
+ createLink(link=link, target=target);
+ }
+ # Sanity check
+ stopifnot(isFile(link));
+
+ verbose && exit(verbose);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Skip?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (skip) {
+ ## Try to guess report filename
+ filename <- basename(destPathname)
+ filename <- gsub("[.]rsp$", "", filename)
+ ext <- gsub(".*[.]", "", filename)
+ fullname <- gsub(sprintf("[.]%s$", ext), "", filename)
+ ext <- switch(ext, tex="pdf", md="html", ext)
+ filename <- sprintf("%s.%s", fullname, ext)
+ pathname <- file.path(rspArgs$reportPath, filename)
+ pathname <- getAbsolutePath(pathname)
+ verbose && cat(verbose, "Expected output pathname: ", pathname);
+ if (isFile(pathname)) {
+ verbose && cat(verbose, "Already exists: Skipping.")
+ report <- R.rsp::RspFileProduct(pathname)
+ return(report)
+ }
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Create file links to all LaTeX include files
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "All LaTeX files");
+
+ files <- list.files(path=srcPath, pattern="[.](bib|bst|cls|sty|tex)$", full.names=TRUE, recursive=FALSE);
+ files <- files[file_test("-f", files)];
+ if (length(files) > 0L) {
+ verbose && cat(verbose, "Number of such files found: ", length(files));
+ verbose && print(verbose, files);
+
+ for (kk in seq_along(files)) {
+ target <- files[kk];
+ link <- filePath(rspArgs$reportPath, basename(files[kk]));
+ if (!isFile(link)) {
+ verbose && cat(verbose, "Adding link: ", link, " -> ", target);
+ createLink(link=link, target=target);
+ }
+ # Sanity check
+ stopifnot(isFile(link));
+ }
+ } else {
+ verbose && cat(verbose, "No such files found.");
+ }
+
+ verbose && exit(verbose);
+
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Create file links to all 'incl.*' subdirectories
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "All 'incl.*' subdirectories");
+
+ dirs <- list.files(srcPath, pattern="^incl", full.names=TRUE, recursive=FALSE);
+ dirs <- dirs[file_test("-d", dirs)];
+
+ if (length(dirs) > 0L) {
+ verbose && cat(verbose, "Number of such directories found: ", length(dirs));
+ verbose && print(verbose, dirs);
+
+ for (kk in seq_along(dirs)) {
+ target <- dirs[kk];
+ link <- filePath(rspArgs$reportPath, basename(dirs[kk]));
+ if (!isDirectory(link)) {
+ verbose && cat(verbose, "Adding link: ", link, " -> ", target);
+ createLink(link=link, target=target);
+ }
+ # Sanity check
+ stopifnot(isDirectory(link));
+ }
+ } else {
+ verbose && cat(verbose, "No such directories found.");
+ }
+
+ verbose && exit(verbose);
+
+
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Build reports
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Processing RSP template");
+ rspArgs$figPath <- "figures/";
+ args <- c(list(rspArgs=rspArgs), rspArgs);
+ report <- R.rsp::rfile(destPathname, workdir=rspArgs$reportPath, args=args, envir=envir, verbose=verbose);
+ verbose && exit(verbose);
+
+ verbose && cat(verbose, "Final report: ", getRelativePath(report));
+
+ verbose && exit(verbose);
+
+ report;
+}, protected=TRUE)
+
+
+
+############################################################################
+# HISTORY:
+# 2013-03-21
+# o Now report() uses file links instead of copying template files.
+# It also links to all LaTeX related files and all directories
+# named '^incl.*'.
+# 2013-03-09
+# o Now report() also included files listed in the optional file
+# '.install_extras' of the source RSP template directory.
+# The same filename is used by 'R CMD build/check' for including
+# extra vignette source files.
+# 2012-09-18
+# o Added argument 'force' to report() for AbstractCBS. This will
+# copy the RSP template files again, although they are already in
+# reports/ output directory.
+# o Now report(fit, ..., rspTags) for AbstractCBS looks for the RSP
+# template named <className>(,<rspTags>),report.tex.rsp, where
+# className is class(fit)[1] and argument 'rspTags' is an optional
+# comma-separated character string/vector.
+# o Now report() for AbstractCBS looks for the RSP template in templates/,
+# and as a backup in templates,PSCBS/. If the latter does not exist,
+# it is automatically created as a soft link to templates/ of the
+# PSCBS package. This allows anyone to create their own customized
+# copy (in templates/) of the default PSCBS RSP report.
+# 2012-05-30
+# o Now report() gives more a informative error message if arguments
+# 'sampleName' or 'studyName' are non-valid or missing.
+# 2012-04-20
+# o Added argument '.filenames'.
+# o Created from former PairedPSCBS.REPORT.R, which history as below.
+# 2012-02-27
+# o Added Rdoc help.
+# o Added report() for PairedPSCBS.
+# o Created.
+############################################################################
diff --git a/R/AbstractCBS.RESTRUCT.R b/R/AbstractCBS.RESTRUCT.R
new file mode 100644
index 0000000..a56f6b7
--- /dev/null
+++ b/R/AbstractCBS.RESTRUCT.R
@@ -0,0 +1,561 @@
+###########################################################################/**
+# @set "class=AbstractCBS"
+# @RdocDocumentation "Restructuring AbstractCBS objects"
+# @alias RestructPSCBS
+#
+# \description{
+# This page describes available methods for restructuring an
+# @see "AbstractCBS" object.
+#
+# \itemize{
+# \item @seemethod "append"
+# - Appends one @see "AbstractCBS" to another.
+#
+# \item @seemethod "extractChromosomes" /
+# @seemethod "extractChromosome"
+# - Extracts an @see "AbstractCBS" with the specified chromosomes.
+#
+# \item @seemethod "extractSegments" /
+# @seemethod "extractSegment"
+# - Extracts an @see "AbstractCBS" with the specified segments.
+#
+# \item @seemethod "extractRegions" /
+# @seemethod "extractRegion"
+# - Extracts an @see "AbstractCBS" with the specified regions
+# each of a certain size, where a region is defined as a
+# connected set of segments.
+#
+# \item @seemethod "dropRegions" /
+# @seemethod "dropRegion"
+# - Drops specified regions and returns an @see "AbstractCBS"
+# without them.
+#
+# \item @seemethod "dropChangePoint" /
+# @seemethod "mergeTwoSegments"
+# - Drops a change point by merging two neighboring segments
+# and recalculates the statistics for the merged segment
+# before returning an @see "AbstractCBS".
+#
+# \item @seemethod "dropChangePoints"
+# - Drops zero or more change points
+# and recalculates the segment statistics
+# before returning an @see "AbstractCBS".
+#
+# \item @seemethod "mergeThreeSegments"
+# - Merges a segment with its two flanking segments
+# and recalculates the statistics for the merged segment
+# before returning an @see "AbstractCBS".
+# }
+#
+# All of the above methods are implemented for @see "CBS" and
+# @see "PairedPSCBS" objects.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# @seeclass
+# }
+#
+# @keyword internal
+#*/###########################################################################
+
+
+###########################################################################/**
+# @set "class=AbstractCBS"
+# @RdocMethod append
+#
+# @title "Appends one segmentation result to another"
+#
+# \description{
+# @get "title",
+# where both holds segmentation results \emph{of the same sample}.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{x, other}{The two @see "AbstractCBS" objects to be combined.}
+# \item{addSplit}{If @TRUE, a "divider" is added between chromosomes.}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns a object of the same class as argument \code{x}.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("append", "AbstractCBS", abstract=TRUE);
+
+
+
+setMethodS3("renameChromosomes", "AbstractCBS", function(fit, from, to, ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'from' & 'to':
+ from <- Arguments$getIntegers(from, disallow=c("NaN", "Inf"));
+ n <- length(from);
+ to <- Arguments$getIntegers(to, disallow=c("NaN", "Inf"), length=c(n,n));
+
+
+ # Nothing to do?
+ if (n == 0) {
+ return(fit);
+ }
+
+ data <- getLocusData(fit);
+ segs <- getSegments(fit, splitters=TRUE, simplify=FALSE);
+ knownSegments <- fit$params$knownSegments;
+
+ for (cc in seq(length=n)) {
+ chr <- from[cc];
+ chrN <- to[cc];
+ data$chromosome[data$chromosome == chr] <- chrN;
+ segs$chromosome[segs$chromosome == chr] <- chrN;
+ knownSegments$chromosome[knownSegments$chromosome == chr] <- chrN;
+ } # for (cc ...)
+
+ fit <- setLocusData(fit, data);
+ fit <- setSegments(fit, segs);
+ fit$params$knownSegments <- knownSegments;
+
+ fit;
+}, protected=TRUE) # renameChromosomes()
+
+
+setMethodS3("extractChromosomes", "AbstractCBS", abstract=TRUE, protected=TRUE);
+
+
+setMethodS3("extractChromosome", "AbstractCBS", function(x, chromosome, ...) {
+ # To please R CMD check
+ this <- x;
+
+ # Argument 'chromosome':
+ chromosome <- Arguments$getInteger(chromosome, disallow=c("NaN", "Inf"));
+
+ extractChromosomes(this, chromosomes=chromosome, ...);
+}, protected=TRUE)
+
+
+
+setMethodS3("extractSegments", "AbstractCBS", abstract=TRUE, protected=TRUE);
+
+setMethodS3("extractSegment", "AbstractCBS", function(this, idx, ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'region':
+ idx <- Arguments$getIndex(idx, max=nbrOfSegments(this, splitters=TRUE));
+
+ extractSegments(this, idxs=idx, ...);
+}, private=TRUE) # extractSegment()
+
+
+setMethodS3("extractRegions", "AbstractCBS", function(this, regions, H=1, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ nbrOfSegments <- nbrOfSegments(this, splitters=TRUE);
+
+ # Argument 'regions':
+ regions <- Arguments$getIndices(regions, max=nbrOfSegments);
+
+ # Argument 'H':
+ H <- Arguments$getInteger(H, range=c(0,Inf));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Extract regions of a certain length");
+
+ verbose && cat(verbose, "Left-most segments of regions to be extracted:");
+ verbose && str(verbose, regions);
+ verbose && cat(verbose, "Number of segments in each region: ", H);
+
+
+ # Identify segments to keep
+ Hs <- seq(length=H);
+ regions <- regions - 1L;
+ regions <- as.list(regions);
+ segments <- lapply(regions, FUN=function(region) region + Hs);
+ segments <- unlist(segments, use.names=FALSE);
+ segments <- sort(unique(segments));
+ verbose && cat(verbose, "Final set of segments to be extracted:");
+ verbose && str(verbose, segments);
+
+ res <- extractSegments(this, idxs=segments, ...);
+
+ verbose && exit(verbose);
+
+ res;
+}, protected=TRUE) # extractRegions()
+
+
+
+setMethodS3("extractRegion", "AbstractCBS", function(this, region, ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'region':
+ region <- Arguments$getIndex(region, max=nbrOfSegments(this, splitters=TRUE));
+
+ extractRegions(this, regions=region, ...);
+}, private=TRUE) # extractRegion()
+
+
+
+###########################################################################/**
+# @RdocMethod mergeTwoSegments
+# @aliasmethod dropChangePoint
+#
+# @title "Merge two neighboring segments"
+#
+# \description{
+# @get "title" into one segment, which is done by dropping their
+# common change point and recalculating the segment statistics.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{left}{An @integer specifying the segments (left, left+1)
+# to be merged.}
+# \item{update}{If @TRUE, segment statistics are updated.}
+# \item{verbose}{A @logical or a @see "R.utils::Verbose" object.}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns an @see "AbstractCBS" of the same class with one less segment.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# To merge a segment and its two flanking segments, see
+# @seemethod "mergeThreeSegments".
+# To drop regions (a connected set of segments)
+# see @seemethod "dropRegions".
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("mergeTwoSegments", "AbstractCBS", abstract=TRUE, protected=TRUE);
+
+
+setMethodS3("dropChangePoint", "AbstractCBS", function(fit, idx, ...) {
+ # Argument 'idx':
+## max <- nbrOfChangePoints(fit, splitters=TRUE, ...);
+ max <- nbrOfSegments(fit, splitters=TRUE, ...) - 1L;
+ idx <- Arguments$getIndex(idx, max=max);
+
+ mergeTwoSegments(fit, left=idx, ...);
+}, protected=TRUE)
+
+
+
+
+###########################################################################/**
+# @RdocMethod dropChangePoints
+#
+# @title "Drops zero or more change points"
+#
+# \description{
+# @get "title", which is done by dropping one change point at the
+# time using @seemethod "dropChangePoint"
+# and recalculating the segment statistics at the end.
+#
+# \emph{NOTE: This method only works if there is only one chromosome.}
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{idxs}{An @integer @vector specifying the change points to be dropped.}
+# \item{update}{If @TRUE, segment statistics are updated.}
+# \item{...}{Other arguments passed to @seemethod "dropChangePoint"
+# and @seemethod "updateMeans".}
+# }
+#
+# \value{
+# Returns an @see "AbstractCBS" of the same class with
+# \code{length(idxs)} segments.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("dropChangePoints", "AbstractCBS", function(fit, idxs, update=TRUE, ...) {
+ # Assert that there is only one chromosome
+ chrs <- getChromosomes(fit);
+ if (length(chrs) > 1) {
+ throw("dropChangePoints() only support single-chromosome data: ", hpaste(chrs));
+ }
+
+ # Argument 'idxs':
+## max <- nbrOfChangePoints(fit, splitters=TRUE, ...);
+ max <- nbrOfSegments(fit, splitters=TRUE, ...) - 1L;
+ idxs <- Arguments$getIndices(idxs, max=max);
+
+
+ # Drop change points one by one
+ idxs <- unique(idxs);
+ idxs <- sort(idxs, decreasing=TRUE);
+ for (ii in seq_along(idxs)) {
+ idx <- idxs[ii];
+ updateI <- update && (ii == length(idxs));
+ fit <- dropChangePoint(fit, idx=idx, update=updateI, ...);
+ }
+
+ # Update segment statistics?
+ if (update) {
+ fit <- updateMeans(fit, ...);
+ }
+
+ fit;
+}, protected=TRUE)
+
+
+
+###########################################################################/**
+# @RdocMethod mergeThreeSegments
+#
+# @title "Merge a segment and its two flanking segments"
+#
+# \description{
+# @get "title" into one segment, and recalculating the segment statistics.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{middle}{An @integer specifying the three segments
+# (middle-1, middle, middle+1) to be merged.}
+# \item{...}{Additional arguments passed to @seemethod "mergeTwoSegments".}
+# }
+#
+# \value{
+# Returns an @see "AbstractCBS" of the same class with two less segment.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# Internally @seemethod "mergeTwoSegments" is used.
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("mergeThreeSegments", "AbstractCBS", function(fit, middle, ...) {
+ # Argument 'middle':
+ S <- nbrOfSegments(fit, splitters=TRUE);
+ middle <- Arguments$getIndex(middle, range=c(2L, S));
+
+ # Assert that the three segments are on the same chromosome
+ idxs <- middle + c(-1L, 0L, +1L);
+ fitT <- extractSegments(fit, idxs);
+ chrs <- getChromosomes(fitT);
+ if (length(chrs) != 1L) {
+ throw("Argument 'middle' specifies a segment that is at the very end of a chromosome: ", middle);
+ }
+ fitT <- NULL; # Not needed anymore
+
+ fit <- mergeTwoSegments(fit, left=middle, ...);
+ fit <- mergeTwoSegments(fit, left=middle-1L, ...);
+ fit;
+}) # mergeThreeSegments()
+
+
+
+###########################################################################/**
+# @RdocMethod dropRegions
+# @aliasmethod dropRegion
+#
+# @title "Drops chromosomal regions (a connected set of segments)"
+#
+# \description{
+# @get "title" each of a certain size (number of segments).
+# \emph{None of the statistics are recalculated}.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{regions}{An @integer @vector of length R specifying the indices
+# of the left most segment in each of the R regions to be dropped.}
+# \item{H}{A non-negative @integer specifying the size of each region,
+# i.e. the number of segments per region.}
+# \item{...}{Additional arguments passed to @seemethod "extractRegions".}
+# \item{asMissing}{If @TRUE, dropped segments are replaced by missing values,
+# otherwise they are truly dropped.}
+# \item{verbose}{A @logical or a @see "R.utils::Verbose" object.}
+# }
+#
+# \value{
+# Returns an @see "AbstractCBS" object of the same class with (at most)
+# R*H segments dropped.
+# If some regions overlap (share segments), then fewer than R*H segments
+# are dropped.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# Internally @seemethod "extractRegions" is used.
+# See also @seemethod "dropChangePoint" and @seemethod "mergeTwoSegments".
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("dropRegions", "AbstractCBS", function(this, regions, H=1, ..., asMissing=FALSE, verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ nbrOfSegments <- nbrOfSegments(this, splitters=TRUE);
+ # Argument 'regions':
+ regions <- Arguments$getIndices(regions, max=nbrOfSegments);
+
+ # Argument 'H':
+ H <- Arguments$getInteger(H, range=c(0,Inf));
+
+ # Argument 'asMissing':
+ asMissing <- Arguments$getLogical(asMissing);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Dropping regions of a certain length");
+
+ verbose && cat(verbose, "Left-most segments of regions to be dropped:");
+ verbose && str(verbose, regions);
+ verbose && cat(verbose, "Number of segments in each region: ", H);
+
+ # Nothing to do?
+ if (H == 0) {
+ verbose && cat(verbose, "Nothing to do. No segments will be dropped.");
+ verbose && exit(verbose);
+ return(this);
+ }
+
+ # Identify segments to drop
+ Hs <- seq(length=H);
+ regions <- regions - 1L;
+ regions <- as.list(regions);
+ regions <- lapply(regions, FUN=function(region) region + Hs);
+ regions <- unlist(regions, use.names=FALSE);
+ regions <- sort(unique(regions));
+ verbose && cat(verbose, "Final set of segments to be dropped:");
+ verbose && str(verbose, regions);
+
+ # Identify segments to keep
+ allRegions <- seq(length=nbrOfSegments);
+ keepSegments <- setdiff(allRegions, regions);
+ verbose && cat(verbose, "Final set of segments to be kept:");
+ verbose && str(verbose, keepSegments);
+
+ dropped <- extractRegions(this, regions=regions, ...);
+ res <- this;
+ if (length(regions) > 0) {
+ if (asMissing) {
+ segs <- getSegments(res, splitters=TRUE);
+ pattern <- "(chromosome|id|start|end)$";
+
+ # TODO/AD HOC: Should be class specific /HB 2011-10-17
+ pattern <- "(chromosome|id)$";
+ excl <- grep(pattern, colnames(segs), ignore.case=TRUE, invert=TRUE);
+ segs[regions,excl] <- NA;
+ res$output <- segs;
+
+ # TODO/AD HOC: Should be class specific /HB 2011-10-17
+ for (ff in grep("segRows", names(res), ignore.case=TRUE, value=TRUE)) {
+ res[[ff]][regions,] <- NA;
+ }
+ } else {
+ res <- extractRegions(res, regions=keepSegments, ...);
+ }
+ }
+ res$dropped <- dropped;
+
+ # Sanity check
+ if (asMissing) {
+ stopifnot(nbrOfSegments(res, splitters=TRUE) == nbrOfSegments(this, splitters=TRUE));
+ } else {
+ stopifnot(nbrOfSegments(res, splitters=TRUE) + length(regions) == nbrOfSegments(this, splitters=TRUE));
+ }
+
+ verbose && exit(verbose);
+
+ res;
+}, protected=TRUE)
+
+
+setMethodS3("dropRegion", "AbstractCBS", function(fit, region, ...) {
+ # Argument 'region':
+ region <- Arguments$getIndex(region);
+
+ dropRegions(fit, regions=region, ...);
+}, protected=TRUE)
+
+
+setMethodS3("shiftTCN", "AbstractCBS", abstract=TRUE, protected=TRUE);
+
+
+
+
+############################################################################
+# HISTORY:
+# 2013-04-20 [HB]
+# o CLEANUP: Removed previously deprecated methods for AbstractCBS.
+# 2013-03-21 [HB]
+# o SPEEDUP: Made dropChangePoints() faster by only updating the segment
+# statistics/means at the very end.
+# o BUG FIX: dropChangePoint[s]() for AbstractCBS would not allow to
+# drop the change points at the very end, if segmentation where done
+# with known segments/gaps and/or empty segments.
+# 2012-09-13
+# o Now renameChromosomes() also adjusts 'knownSegments'.
+# o Added shiftTCN().
+# 2012-02-27
+# o Added renameChromosomes() to AbstractCBS.
+# 2012-02-25
+# o Added dropChangePoints() for AbstractCBS.
+# 2011-11-17
+# o FIX: extractRegions() for AbstractCBS would also show verbose output.
+# 2011-11-04
+# o BUG FIX: extractSegment() for AbstractCBS would give an error, because
+# it called itself instead of extractSegments().
+# 2011-10-21
+# o Added mergeThreeSegments() to AbstractCBS.
+# 2011-10-17
+# o Added argument 'asMissing' to dropRegions() for AbstractCBS.
+# 2011-10-14
+# o Added implementation of extractRegions() for AbstractCBS, which
+# utilizes extractSegments().
+# o Added abstract extractSegments() and extractSegment() for AbstractCBS.
+# 2011-10-10
+# o Added extractRegion()/dropRegion() and extractRegions()/dropRegions()
+# for AbstractCBS, where former ones are wrappers for the latter ones.
+# o Added dropChangePoint() for AbstractCBS, which is just a
+# "name wrapper" for mergeTwoSegments().
+# 2011-10-08
+# o Added abstract updateMeans() for AbstractCBS.
+# o Added abstract mergeTwoSegments() for AbstractCBS.
+# 2011-10-02
+# o Created.
+############################################################################
diff --git a/R/AbstractCBS.clearCalls.R b/R/AbstractCBS.clearCalls.R
new file mode 100644
index 0000000..a458d24
--- /dev/null
+++ b/R/AbstractCBS.clearCalls.R
@@ -0,0 +1,30 @@
+# Removes all segment calls and corresponding parameter estimates.
+setMethodS3("clearCalls", "AbstractCBS", function(fit, ...) {
+ segs <- fit$output;
+ params <- fit$params;
+
+ # Drop all calls
+ excl <- grep("Call$", colnames(segs));
+ if (length(excl) > 0L) {
+ segs <- segs[,-excl];
+ }
+
+ # Drop all call parameters (AD HOC!)
+ for (ff in c("deltaROH", "deltaAB", "deltaLOH")) {
+ params[[ff]] <- NULL;
+ }
+
+ fit$output <- segs;
+ fit$params <- params;
+
+ invisible(fit);
+}, protected=TRUE)
+
+
+
+##############################################################################
+# HISTORY
+# 2013-10-24
+# o Added clearCalls() for AbstractCBS.
+# o Created.
+##############################################################################
diff --git a/R/CBS.CALL.R b/R/CBS.CALL.R
new file mode 100644
index 0000000..1bb97f8
--- /dev/null
+++ b/R/CBS.CALL.R
@@ -0,0 +1,1454 @@
+###########################################################################/**
+# @set "class=CBS"
+# @RdocMethod callGainsAndLosses
+#
+# @title "Calls gains and losses"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{adjust}{A positive scale factor adjusting the sensitivity of the
+# caller, where a value less (greater) than 1.0 makes the caller
+# less (more) sensitive.}
+# \item{method}{A @character string specifying the calling algorithm to use.}
+# \item{...}{Additional/optional arguments used to override the default
+# parameters used by the caller.}
+# }
+#
+# \value{
+# Returns a @see "PSCBS::CBS" object where @logical columns
+# 'lossCall' and 'gainCall' have been appended to the segmentation table.
+# }
+#
+# \section{The UCSF caller}{
+# If \code{method == "ucsf-mad"}, then segments are called using [1], i.e.
+# a segment is called gained or lost if its segment level is
+# at least two standard deviations away from the median segment level
+# on Chr1-22, where standard deviation is estimated using MAD.
+# Then same is done for \code{method == "ucsf-dmad"} with the difference
+# that the standard deviation is estimated using a robust first order
+# variance estimator.
+# }
+#
+# \examples{
+# @include "../incl/segmentByCBS.Rex"
+# @include "../incl/segmentByCBS,calls.Rex"
+# }
+#
+# @author "HB"
+#
+# \references{
+# [1] Fridlyand et al. \emph{Breast tumor copy number aberration
+# phenotypes and genomic instability}, BMC Cancer, 2006. \cr
+# }
+#
+# \seealso{
+# @seemethod "callAmplifications".
+# @seemethod "callOutliers".
+# @seeclass
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("callGainsAndLosses", "CBS", function(fit, adjust=1.0, method=c("ucsf-mad", "ucsf-dmad"), ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'adjust':
+ adjust <- Arguments$getDouble(adjust, range=c(0, Inf));
+
+ # Argument 'method':
+ method <- match.arg(method);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Calling segments that are gained or lost");
+
+ userArgs <- list(...);
+
+ params <- list();
+
+ # Allocate calls
+ naValue <- as.logical(NA);
+ nbrOfSegments <- nbrOfSegments(fit, splitters=TRUE);
+ segs <- getSegments(fit, splitters=TRUE);
+ nbrOfRows <- nrow(segs);
+ gainCalls <- lossCalls <- rep(naValue, times=nbrOfRows);
+
+ verbose && cat(verbose, "Number of segments to be called: ", nbrOfSegments);
+ verbose && cat(verbose, "Call method: ", method);
+
+ if (is.element(method, c("ucsf-mad", "ucsf-dmad"))) {
+ # Default arguments
+ args <- list(
+ chromosomes = intersect(getChromosomes(fit), c(0L, 1:22)),
+ scale = 2.0
+ );
+
+ # Override by (optional) user-specified arguments
+ for (key in names(userArgs)) {
+ args[[key]] <- userArgs[[key]];
+ }
+
+ # Extract arguments
+ chromosomes <- args$chromosomes;
+ scale <- args$scale;
+
+ # Argument check
+ chromosomes <- Arguments$getVector(chromosomes, lengths=c(1,Inf));
+ scale <- Arguments$getDouble(scale, range=c(0,Inf));
+
+ # Estimate the whole-genome standard deviation of the TCNs
+ if (method == "ucsf-mad") {
+ sigma <- estimateStandardDeviation(fit, chromosomes=chromosomes,
+ method="res", estimator="mad");
+ sigmaKey <- "sigmaMAD";
+ } else if (method == "ucsf-dmad") {
+ sigma <- estimateStandardDeviation(fit, chromosomes=chromosomes,
+ method="diff", estimator="mad");
+ sigmaKey <- "sigmaDelta";
+ } else {
+ throw("INTERNAL ERROR: Unknown method: ", method);
+ }
+
+ # Sanity check
+ sigma <- Arguments$getDouble(sigma, range=c(0,Inf));
+
+ # Calculate the threshold
+ tau <- scale * sigma;
+
+ # Make more or less sensitive
+ tau <- adjust * tau;
+
+ verbose && cat(verbose, "Call parameters:");
+ verbose && str(verbose, list(sigma=sigma, scale=scale, adjust=adjust));
+
+ # Calculate segment levels using the median estimator
+ fitT <- updateMeans(fit, avg="median")
+ segsT <- getSegments(fitT, splitters=TRUE);
+ mu <- segsT$mean;
+ fitT <- segsT <- NULL; # Not needed anymore
+
+ # The median segmented level
+ muR <- median(mu, na.rm=TRUE);
+
+ # The threshold for losses
+ tauLoss <- muR - tau;
+
+ # The threshold for gains
+ tauGain <- muR + tau;
+
+ # Call
+ lossCalls <- (mu <= tauLoss); # Losses
+ gainCalls <- (mu >= tauGain); # Gains
+
+ # Call parameters used
+ params$method <- method;
+ params$adjust <- adjust;
+ params[[sigmaKey]] <- sigma;
+ params$scale <- scale;
+ params$muR <- muR;
+ params$tau <- tau;
+ params$tauLoss <- tauLoss;
+ params$tauGain <- tauGain;
+ }
+
+ verbose && cat(verbose, "Number of called segments: ", length(lossCalls));
+
+
+ # Sanity check
+ stopifnot(length(lossCalls) == nbrOfRows);
+ stopifnot(length(gainCalls) == nbrOfRows);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Update 'DNAcopy' object
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # (a) segmentation table
+ segs <- getSegments(fit, splitters=TRUE);
+ segs$lossCall <- lossCalls;
+ segs$gainCall <- gainCalls;
+ fit$output <- segs;
+
+ # (b) parameters
+ allParams <- fit$params;
+ if (is.null(allParams)) {
+ allParams <- list();
+ }
+ allParams$callGainsAndLosses <- params;
+ fit$params <- allParams;
+
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Return the updated 'CBS' object.
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fit;
+}, private=TRUE) # callGainsAndLosses()
+
+
+
+
+
+###########################################################################/**
+# @RdocMethod callAmplifications
+#
+# @title "Calls (focal) amplifications"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{adjust}{A positive scale factor adjusting the sensitivity of the
+# caller, where a value less (greater) than 1.0 makes the caller
+# less (more) sensitive.}
+# \item{maxLength}{A @double scalar specifying the maximum length of a segment
+# in order for it to be considered a focal amplification.}
+# \item{method}{A @character string specifying the calling algorithm to use.}
+# \item{...}{Additional/optional arguments used to override the default
+# parameters used by the caller.}
+# \item{verbose}{@see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns a @see "PSCBS::CBS" object where @logical column
+# 'amplificationCall' has been appended to the segmentation table.
+# }
+#
+# \section{The UCSF caller}{
+# If \code{method == "ucsf-exp"}, then segments are called using [1], i.e.
+# a segment is called an amplification if ...
+# }
+#
+# @author
+#
+# \references{
+# [1] Fridlyand et al. \emph{Breast tumor copy number aberration
+# phenotypes and genomic instability}, BMC Cancer, 2006. \cr
+# }
+#
+# \seealso{
+# @seemethod "callGainsAndLosses".
+# @seemethod "callOutliers".
+# @seeclass
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("callAmplifications", "CBS", function(fit, adjust=1.0, maxLength=20e6, method=c("ucsf-exp"), ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'adjust':
+ adjust <- Arguments$getDouble(adjust, range=c(0, Inf));
+
+ # Argument 'maxLength':
+ maxLength <- Arguments$getDouble(maxLength, range=c(0, Inf));
+
+ # Argument 'method':
+ method <- match.arg(method);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Calling segments that are amplified");
+
+ userArgs <- list(...);
+
+ params <- list();
+
+ # Allocate calls
+ naValue <- as.logical(NA);
+ nbrOfSegments <- nbrOfSegments(fit, splitters=TRUE);
+ calls <- rep(naValue, times=nbrOfSegments);
+
+ verbose && cat(verbose, "Number of segments to be called: ", nbrOfSegments);
+ verbose && cat(verbose, "Call method: ", method);
+
+ if (method == "ucsf-exp") {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Call arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Default arguments
+ args <- list(
+ minLevel = 0.0,
+ lambda = 1.0,
+ degree = 3
+ );
+
+ # Override by (optional) user-specified arguments
+ for (key in names(userArgs)) {
+ args[[key]] <- userArgs[[key]];
+ }
+
+ # Extract arguments
+ minLevel <- args$minLevel;
+ lambda <- args$lambda;
+ degree <- args$degree;
+
+ # Validate arguments
+ minLevel <- Arguments$getDouble(minLevel, range=c(-Inf, Inf));
+ lambda <- Arguments$getDouble(lambda, range=c(0, Inf));
+ degree <- Arguments$getDouble(degree, range=c(1, Inf));
+
+ verbose && cat(verbose, "Call parameters:");
+ verbose && str(verbose, list(minLevel=minLevel, lambda=lambda,
+ degree=degree));
+
+ segs <- getSegments(fit, splitters=TRUE);
+
+ verbose && cat(verbose, "Segments:");
+ verbose && str(verbose, segs);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Rule #1: Only consider segments that are short enough
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # The lengths (in bp) of the segments
+ start <- segs$start;
+ end <- segs$end;
+ length <- end - start; ## + 1L;
+ keep1 <- (length <= maxLength);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Rule #2: Only consider segments that have a mean level
+ # that is large enough.
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # The mean levels of the segments
+ mu <- segs$mean;
+ keep2 <- (mu >= minLevel);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Rule #3: Only consider segments that have a mean level
+ # that is much larger than either of the
+ # flanking segments.
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # The mean levels of the flanking segments
+ muL <- c(NA, mu[-nbrOfSegments]);
+ muR <- c(mu[-1], NA);
+
+ # The difference in mean levels to the flanking segments
+ deltaL <- mu - muL;
+ deltaR <- mu - muR;
+
+ # The maximum difference to either of the flanking segments
+ delta <- pmax(deltaL, deltaR, na.rm=TRUE);
+
+ # The threshold for calling segments amplified
+ tau <- exp(-lambda * mu^degree);
+
+ # Make more or less sensitive
+ tau <- adjust * tau;
+
+ keep3 <- (delta >= tau);
+
+ # Amplification calls
+ calls <- (keep1 & keep2 & keep3);
+
+ # Call parameters used
+ params$method <- method;
+ params$adjust <- adjust;
+ params$maxLength <- maxLength;
+ params$minLevel <- minLevel;
+ params$lambda <- lambda;
+ params$degree <- degree;
+ params$tau <- tau;
+ }
+
+ verbose && cat(verbose, "Number of called segments: ", length(calls));
+
+ # Sanity check
+ stopifnot(length(calls) == nbrOfSegments);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Update 'DNAcopy' object
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # (a) segmentation table
+ segs <- getSegments(fit, splitters=TRUE);
+ segs$amplificationCall <- calls;
+ fit$output <- segs;
+
+ # (b) parameters
+ allParams <- fit$params;
+ if (is.null(allParams)) {
+ allParams <- list();
+ }
+ allParams$callAmplifications <- params;
+ fit$params <- allParams;
+
+
+ verbose && exit(verbose);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Return the updated 'CBS' object.
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fit;
+}, private=TRUE) # callAmplifications()
+
+
+
+###########################################################################/**
+# @RdocMethod callOutliers
+#
+# @title "Calls outliers"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{adjust}{A positive scale factor adjusting the sensitivity of the
+# caller, where a value less (greater) than 1.0 makes the caller
+# less (more) sensitive.}
+# \item{method}{A @character string specifying the calling algorithm to use.}
+# \item{...}{Additional/optional arguments used to override the default
+# parameters used by the caller.}
+# }
+#
+# \value{
+# Returns a @see "PSCBS::CBS" object where @logical columns
+# 'negOutlierCall' and 'posOutlierCall' have been appended
+# to the segmentation table.
+# }
+#
+# \section{The UCSF caller}{
+# If \code{method == "ucsf-mad"}, then loci are called using [1];
+# "Finally, to identify single technical or biological outliers such
+# as high level amplifications, the presence of the outliers within
+# a segment was allowed by assigning the original observed log2ratio
+# to the clones for which the observed values were more than four
+# tumor-specific MAD away from the smoothed values." [1; Suppl. Mat.]
+# }
+#
+# @author "HB"
+#
+# \references{
+# [1] Fridlyand et al. \emph{Breast tumor copy number aberration
+# phenotypes and genomic instability}, BMC Cancer, 2006. \cr
+# }
+#
+# \seealso{
+# @seemethod "callGainsAndLosses".
+# @seemethod "callAmplifications".
+# @seeclass
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("callOutliers", "CBS", function(fit, adjust=1.0, method=c("ucsf-mad"), ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'adjust':
+ adjust <- Arguments$getDouble(adjust, range=c(0, Inf));
+
+ # Argument 'method':
+ method <- match.arg(method);
+
+
+ userArgs <- list(...);
+
+ params <- list();
+
+ # Allocate calls
+ nbrOfLoci <- nbrOfLoci(fit);
+ naValue <- as.logical(NA);
+ negOutlierCall <- posOutlierCall <- rep(naValue, times=nbrOfLoci);
+
+ if (method == "ucsf-mad") {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Call arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Default arguments
+ args <- list(
+ scale = 4.0
+ );
+
+ # Override by (optional) user-specified arguments
+ for (key in names(userArgs)) {
+ args[[key]] <- userArgs[[key]];
+ }
+
+ # Extract arguments
+ scale <- args$scale;
+
+ # Validate arguments
+ scale <- Arguments$getDouble(scale, range=c(0, Inf));
+
+
+ # Genomic annotations
+ data <- getLocusData(fit);
+ chromosome <- data$chromosome;
+ x <- data$x;
+
+ # CN signals
+ y <- data[,3];
+
+ # Segmented CN signals
+ yS <- extractSegmentMeansByLocus(fit);
+
+ # CN residuals (relative to segment means)
+ dy <- y - yS;
+
+ segs <- getSegments(fit, splitters=TRUE);
+
+ # Allocate per-segment SD estimates
+ nbrOfSegments <- nbrOfSegments(fit);
+ naValue <- NA_real_;
+ sds <- rep(naValue, times=nbrOfSegments);
+
+ naValue <- NA_real_;
+ for (ss in seq(length=nbrOfSegments)) {
+ seg <- segs[ss,];
+
+ # Identify loci in current segment
+ idxs <- which(seg$chromosome == chromosome &
+ seg$start <= x & x <= seg$end);
+
+ # Sanity check
+ idxs <- Arguments$getIndices(idxs, max=nbrOfLoci);
+
+ # Extract CN residuals
+ dySS <- dy[idxs];
+
+ # Calculate MAD for segment
+ sdSS <- mad(dySS, na.rm=TRUE);
+
+ # Threshold for outliers
+ tau <- scale * sdSS;
+
+ # Make more or less sensitive
+ tau <- adjust * tau;
+
+ # Call outliers
+ naValue <- as.logical(NA);
+ callsSS <- rep(naValue, times=length(dySS));
+ callsSS[-tau <= dySS & dySS <= +tau] <- 0L;
+ callsSS[dySS > +tau] <- +1L;
+ callsSS[dySS < -tau] <- -1L;
+
+ # Record
+ negOutlierCall[idxs] <- (callsSS < 0L);
+ posOutlierCall[idxs] <- (callsSS > 0L);
+
+ sds[ss] <- sdSS;
+ } # for (ss ...)
+
+ params$method <- method;
+ params$adjust <- adjust;
+ params$scale <- scale;
+ params$sds <- sds;
+ }
+
+
+ # Sanity check
+ stopifnot(length(negOutlierCall) == nbrOfLoci);
+ stopifnot(length(posOutlierCall) == nbrOfLoci);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Update 'DNAcopy' object
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # (a) segmentation table
+ data <- getLocusData(fit);
+ data$negOutlierCall <- negOutlierCall;
+ data$posOutlierCall <- posOutlierCall;
+ fit$data <- data;
+
+ # (b) parameters
+ allParams <- fit$params;
+ if (is.null(allParams)) {
+ allParams <- list();
+ }
+ allParams$callOutliers <- params;
+ fit$params <- allParams;
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Return the updated 'CBS' object.
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fit;
+}, private=TRUE) # callOutliers()
+
+
+
+setMethodS3("extractCallsByLocus", "CBS", function(fit, ...) {
+ # Extract locus data
+ data <- getLocusData(fit, ...);
+
+ nbrOfLoci <- nrow(data);
+
+ # Extract segment data
+ segs <- getSegments(fit, splitters=TRUE);
+
+ # Identify segment calls
+ callCols <- grep("Call$", colnames(segs));
+ nbrOfCalls <- length(callCols);
+
+
+ chromosome <- data$chromosome;
+ x <- data$x;
+ y <- data[,3];
+
+ # Allocate locus calls
+ naValue <- as.logical(NA);
+ callsL <- matrix(naValue, nrow=nbrOfLoci, ncol=nbrOfCalls);
+ colnames(callsL) <- colnames(segs)[callCols];
+ callsL <- as.data.frame(callsL);
+
+ # For each segment...
+ for (ss in seq(length=nrow(segs))) {
+ seg <- segs[ss,];
+ idxs <- which(chromosome == seg$chromosome &
+ seg$start <= x & x <= seg$end);
+ idxs <- Arguments$getIndices(idxs, max=nbrOfLoci);
+ # Sanity check
+## stopifnot(length(idxs) == seg$nbrOfLoci);
+
+ callsSS <- seg[callCols];
+ for (cc in seq(length=nbrOfCalls)) {
+ callsL[idxs,cc] <- callsSS[,cc];
+ }
+ } # for (ss ...)
+
+ # The calls for loci that have missing annotations or observations,
+ # should also be missing, i.e. NA.
+ nok <- (is.na(chromosome) | is.na(x) | is.na(y));
+ callsL[nok,] <- as.logical(NA);
+
+ # Sanity check
+ stopifnot(nrow(callsL) == nbrOfLoci);
+ stopifnot(ncol(callsL) == nbrOfCalls);
+
+ callsL;
+}, private=TRUE) # extractCallsByLocus()
+
+
+
+###########################################################################/**
+# @RdocMethod getCallStatistics
+#
+# @title "Calculates various call statistics per chromosome"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{regions}{An optional @data.frame with columns "chromosome",
+# "start", and "end" specifying the regions of interest to calculate
+# statistics for. If @NULL, all of the genome is used.}
+# \item{shrinkRegions}{If @TRUE, regions are shrunk to the support of
+# the data.}
+# \item{...}{Not used.}
+# \item{verbose}{@see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns a CxK @data.frame, where C is the number of regions that
+# meet the criteria setup by argument \code{regions}
+# and (K-4)/2 is the number of call types.
+# The first column is the chromosome index, the second and the third
+# are the first and last position, and the fourth the length
+# (=last-first+1) of the chromosome.
+# The following columns contains call summaries per chromosome.
+# For each chromosome and call type, the total length of such calls
+# on that chromosome is reported together how large of a fraction
+# of the chromosome such calls occupy.
+# }
+#
+# \details{
+# The estimators implemented here are based solely on the
+# segmentation results, which is very fast.
+# In the original proposal by Fridlyand et al. [1], the authors
+# estimates the parameters by converting segment-level calls back
+# to locus-level calls and there do the calculations.
+# The difference between the two approaches should be minor,
+# particularly for large density arrays.
+# }
+#
+# @author "HB"
+#
+# \references{
+# [1] Fridlyand et al. \emph{Breast tumor copy number aberration
+# phenotypes and genomic instability}, BMC Cancer, 2006. \cr
+# }
+#
+# \seealso{
+# @seeclass
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("getCallStatistics", "CBS", function(fit, regions=NULL, shrinkRegions=TRUE, ..., verbose=FALSE) {
+ # To please R CMD check, cf. subset()
+ chromosome <- NULL; rm(list="chromosome");
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'regions':
+ if (is.null(regions)) {
+ # Get chromosome lengths
+ regions <- getChromosomeRanges(fit)[,c("chromosome", "start", "end")];
+ }
+ regions <- as.data.frame(regions);
+ stopifnot(all(is.element(c("chromosome", "start", "end"), colnames(regions))));
+ stopifnot(!any(duplicated(regions$chromosome)));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Calculating call statistics");
+ segs <- getSegments(fit, splitters=FALSE);
+ callTypes <- grep("Call$", colnames(segs), value=TRUE);
+ verbose && cat(verbose, "Call types: ", hpaste(callTypes));
+ if (length(callTypes) == 0) {
+ throw("Cannot calculate call statistics. No calls have been made.");
+ }
+
+ verbose && cat(verbose, "Regions of interest:");
+ verbose && str(verbose, regions);
+
+
+ verbose && enter(verbose, "Filtering out segments within the requested regions");
+
+ # Filter out segments within the requested regions
+ segsT <- NULL;
+ verbose && cat(verbose, "Number of segments (before): ", nrow(segs));
+
+ for (rr in seq(length=nrow(regions))) {
+ regionRR <- regions[rr,];
+ chrRR <- regionRR[,"chromosome"];
+ startRR <- regionRR[,"start"];
+ endRR <- regionRR[,"end"];
+ if (is.na(chrRR) || is.na(startRR) || is.na(endRR)) {
+ next;
+ }
+
+ verbose && enter(verbose, sprintf("Region #%d of %d", rr, nrow(regions)));
+
+ # Select regions that (at least) overlapping with the region
+ segsRR <- subset(segs, chromosome == chrRR & start <= endRR & end >= startRR);
+
+ verbose && cat(verbose, "Number of segments within region: ", nrow(segsRR));
+
+ # Special case
+ if (nrow(segsRR) == 0) {
+ segsRR <- segs[1,][NA,];
+ segsRR$chromosome <- chrRR;
+ segsRR$start <- startRR;
+ segsRR$end <- endRR;
+ segsRR$nbrOfLoci <- 0L;
+ }
+
+ if (shrinkRegions) {
+ range <- range(c(segsRR$start, segsRR$end), na.rm=TRUE);
+ startRR <- max(startRR, range[1], na.rm=TRUE);
+ endRR <- min(endRR, range[2], na.rm=TRUE);
+ regions[rr,"end"] <- endRR;
+ regions[rr,"start"] <- startRR;
+ }
+
+ # Adjust ranges
+ segsRR$start[segsRR$start < startRR] <- startRR;
+ segsRR$end[segsRR$end > endRR] <- endRR;
+
+ segsRR$fullLength <- endRR - startRR; ## + 1L;
+
+ segsT <- rbind(segsT, segsRR);
+
+ verbose && exit(verbose);
+ } # for (rr ...)
+
+ segs <- segsT;
+
+ # Order by chromosome
+ o <- order(segs$chromosome);
+ segs <- segs[o,];
+
+ verbose && cat(verbose, "Number of segments (after): ", nrow(segs));
+ verbose && str(verbose, segs);
+
+ verbose && exit(verbose);
+
+
+ verbose && enter(verbose, "Calculating total length per call and chromosome");
+ # Sum length of calls per type and chromosome
+ segs$length <- segs[,"end"] - segs[,"start"]; ## + 1L;
+ res <- lapply(callTypes, FUN=function(type) {
+ coeffs <- as.integer(segs[,type]);
+ lens <- coeffs * segs$length;
+ lens <- by(lens, INDICES=segs$chromosome, FUN=sum, na.rm=TRUE);
+ as.vector(lens);
+ });
+ names(res) <- gsub("Call$", "Length", callTypes);
+ res1 <- as.data.frame(res);
+ verbose && str(verbose, res);
+ verbose && exit(verbose);
+
+ # Extract selected regions
+ idxs <- match(unique(segs$chromosome), regions$chromosome);
+ regionsT <- regions[idxs,];
+
+ # Sanity check
+ stopifnot(nrow(regionsT) == nrow(res1));
+
+
+ verbose && enter(verbose, "Calculating fractions per region");
+ # Calculate lengths
+ regionsT$length <- regionsT[,"end"] - regionsT[,"start"]; ## + 1L;
+ stopifnot(all(regionsT$length >= 0));
+
+ res2 <- res1 / regionsT[,"length"];
+ names(res2) <- gsub("Call$", "Fraction", callTypes);
+ verbose && exit(verbose);
+
+ res3 <- cbind(res1, res2);
+
+ res <- regionsT;
+ if (nrow(res3) > 0) {
+ res <- cbind(res, res3);
+ }
+ rownames(res) <- NULL;
+
+ res <- cbind(label=I(sprintf("chr%d", res[,"chromosome"])), res);
+
+ # Sanity checks
+ resT <- res[,grep("Fraction", colnames(res))];
+ for (key in colnames(resT)) {
+ rho <- resT[,key];
+ stopifnot(all(rho >= 0, na.rm=TRUE));
+ stopifnot(all(rho <= 1, na.rm=TRUE));
+ }
+
+ stopifnot(nrow(res) == nrow(regions));
+
+ verbose && str(verbose, res);
+ verbose && exit(verbose);
+
+ res;
+}, protected=TRUE) # getCallStatistics()
+
+
+
+###########################################################################/**
+# @RdocMethod getFractionOfGenomeLost
+# @aliasmethod getFractionOfGenomeGained
+# @aliasmethod getFractionOfGenomeAltered
+# @aliasmethod getFGL
+# @aliasmethod getFGG
+# @aliasmethod getFGA
+#
+# @title "Calculates the fraction of the genome lost, gained, or aberrant either way"
+#
+# \description{
+# @get "title" (in sense of total copy numbers),
+# using definitions closely related to those presented in [1].
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns a @double in [0,1].
+# }
+#
+# @author "HB"
+#
+# \references{
+# [1] Fridlyand et al. \emph{Breast tumor copy number aberration
+# phenotypes and genomic instability}, BMC Cancer, 2006. \cr
+# }
+#
+# \seealso{
+# Internally, @seemethod "getCallStatistics" is used.
+# @seeclass
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("getFractionOfGenomeLost", "CBS", function(fit, ...) {
+ stats <- getCallStatistics(fit, ...);
+ mean(stats$lossFraction, na.rm=TRUE);
+}, protected=TRUE)
+
+setMethodS3("getFractionOfGenomeGained", "CBS", function(fit, ...) {
+ stats <- getCallStatistics(fit, ...);
+ mean(stats$gainFraction, na.rm=TRUE);
+}, protected=TRUE)
+
+setMethodS3("getFractionOfGenomeAltered", "CBS", function(fit, ...) {
+ getFractionOfGenomeLost(fit, ...) + getFractionOfGenomeGained(fit, ...);
+}, protected=TRUE)
+
+# Shortcuts
+setMethodS3("getFGL", "CBS", function(fit, ...) {
+ getFractionOfGenomeLost(fit, ...);
+}, protected=TRUE)
+
+setMethodS3("getFGG", "CBS", function(fit, ...) {
+ getFractionOfGenomeGained(fit, ...);
+}, protected=TRUE)
+
+setMethodS3("getFGA", "CBS", function(fit, ...) {
+ getFractionOfGenomeAltered(fit, ...);
+}, protected=TRUE)
+
+
+
+
+setMethodS3("isWholeChromosomeGained", "CBS", function(fit, minFraction=0.99, ...) {
+ # Argument 'minFraction':
+ minFraction <- Arguments$getDouble(minFraction, range=c(0,1));
+
+ stats <- getCallStatistics(fit, ...);
+ calls <- stats$gainFraction;
+ if (is.null(calls)) {
+ return(rep(NA, times=nbrOfChromosomes(fit)));
+ }
+
+ res <- (calls >= minFraction);
+ names(res) <- stats$chromosome;
+ attr(res, "minFraction") <- minFraction;
+
+ res;
+}, protected=TRUE) # isWholeChromosomeGained()
+
+
+setMethodS3("isWholeChromosomeLost", "CBS", function(fit, minFraction=0.99, ...) {
+ # Argument 'minFraction':
+ minFraction <- Arguments$getDouble(minFraction, range=c(0,1));
+
+ stats <- getCallStatistics(fit, ...);
+ calls <- stats$lossFraction;
+ if (is.null(calls)) {
+ return(rep(NA, times=nbrOfChromosomes(fit)));
+ }
+
+ res <- (calls >= minFraction);
+ names(res) <- stats$chromosome;
+ attr(res, "minFraction") <- minFraction;
+
+ res;
+}, protected=TRUE) # isWholeChromosomeLost()
+
+
+setMethodS3("nbrOfLosses", "CBS", function(fit, ...) {
+ stats <- getSegments(fit, ...);
+ calls <- stats$lossCall;
+ if (is.null(calls)) {
+ return(NA_integer_);
+ }
+ sum(calls, na.rm=TRUE);
+}, protected=TRUE)
+
+
+setMethodS3("nbrOfGains", "CBS", function(fit, ...) {
+ stats <- getSegments(fit, ...);
+ calls <- stats$gainCall;
+ if (is.null(calls)) {
+ return(NA_integer_);
+ }
+ sum(calls, na.rm=TRUE);
+}, protected=TRUE)
+
+
+setMethodS3("nbrOfAmplifications", "CBS", function(fit, ...) {
+ stats <- getSegments(fit, ...);
+ calls <- stats$amplificationCall;
+ if (is.null(calls)) {
+ return(NA_integer_);
+ }
+ sum(calls, na.rm=TRUE);
+}, protected=TRUE)
+
+
+setMethodS3("getCallStatisticsByArms", "CBS", function(fit, genomeData, ...) {
+ # To please/trick R CMD check
+ chromosome <- x <- NULL; rm(list=c("chromosome", "x"));
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'genomeData':
+ genomeData <- as.data.frame(genomeData);
+
+
+
+ # Subset 'regions' by chromosomes segmented
+ keep <- is.element(genomeData$chromosome, getChromosomes(fit));
+ genomeData <- genomeData[keep,];
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # p-arm
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ regions <- getChromosomeRanges(fit);
+ regions$end <- genomeData$centroStart;
+ regions$start <- pmin(regions$start, regions$end);
+
+ # Shrink regions
+ for (rr in seq(length=nrow(regions))) {
+ chr <- regions[rr,"chromosome"];
+ x0 <- regions[rr,"start"];
+ x1 <- regions[rr,"end"];
+ xs <- subset(fit$data, chromosome == chr & x0 <= x & x <= x1)$x;
+ if (length(xs) > 0) {
+ range <- range(xs, na.rm=TRUE);
+ x0 <- max(c(x0, range[1]), na.rm=TRUE);
+ x1 <- min(c(x1, range[2]), na.rm=TRUE);
+ regions[rr,"start"] <- x0;
+ regions[rr,"end"] <- x1;
+ }
+ } # for (rr ...)
+ regions[,"length"] <- regions[,"end"] - regions[,"start"]; ## + 1L;
+ callStats <- getCallStatistics(fit, regions=regions);
+ callStats$label <- sprintf("%sp", callStats$label);
+ callStatsP <- callStats;
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # q-arm
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ regions <- getChromosomeRanges(fit);
+ regions$start <- genomeData$centroEnd;
+ regions$end <- pmax(regions$end, regions$start);
+
+ # Shrink regions
+ for (rr in seq(length=nrow(regions))) {
+ chr <- regions[rr,"chromosome"];
+ x0 <- regions[rr,"start"];
+ x1 <- regions[rr,"end"];
+ xs <- subset(fit$data, chromosome == chr & x0 <= x & x <= x1)$x;
+ if (length(xs) > 0) {
+ range <- range(xs, na.rm=TRUE);
+ x0 <- max(c(x0, range[1]), na.rm=TRUE);
+ x1 <- min(c(x1, range[2]), na.rm=TRUE);
+ regions[rr,"start"] <- x0;
+ regions[rr,"end"] <- x1;
+ }
+ } # for (rr ...)
+ regions[,"length"] <- regions[,"end"] - regions[,"start"]; ## + 1L;
+
+ callStats <- getCallStatistics(fit, regions=regions);
+ callStats$label <- sprintf("%sq", callStats$label);
+ callStatsQ <- callStats;
+
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Merge
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ callStats <- rbind(callStatsP, callStatsQ);
+
+ # Not needed anymore
+ regions <- callStatsP <- callStatsQ <- NULL;
+
+ # Reorder
+ o <- order(callStats$chromosome, callStats$start);
+ callStats <- callStats[o,];
+
+ callStats;
+}, protected=TRUE); # getCallStatisticsByArms()
+
+
+setMethodS3("callArms", "CBS", function(fit, genomeData, minFraction=0.95, ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'minFraction':
+ minFraction <- Arguments$getDouble(minFraction, range=c(0,1));
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # p-arm
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ callStats <- getCallStatisticsByArms(fit, genomeData=genomeData);
+
+ callTypes <- grep("Fraction", colnames(callStats), value=TRUE);
+ callTypes <- gsub("Fraction", "", callTypes);
+
+ keys <- sprintf("%sFraction", callTypes);
+ rhos <- callStats[,keys];
+ calls <- (rhos >= minFraction);
+ colnames(calls) <- sprintf("%sCall", callTypes);
+
+ callStats <- cbind(callStats, calls);
+
+ callStats;
+}, protected=TRUE); # callArms()
+
+
+
+
+###########################################################################/**
+# @RdocMethod mergeNonCalledSegments
+#
+# @title "Merge neighboring segments that are not called"
+#
+# \description{
+# @get "title"
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Not used.}
+# \item{verbose}{@see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns an object of the same class
+# with the same of fewer number of segments.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# @seeclass
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("mergeNonCalledSegments", "CBS", function(fit, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Merging neighboring segments that are not called");
+
+ # Identify call columns
+ segs <- getSegments(fit, splitters=TRUE);
+ keep <- grep("Call$", colnames(segs));
+ nbrOfCalls <- length(keep);
+
+ # Sanity check
+ stopifnot(nbrOfCalls > 0);
+
+ chromosomes <- getChromosomes(fit);
+ fitList <- list();
+ for (cc in seq(along=chromosomes)) {
+ chromosome <- chromosomes[cc];
+ verbose && enter(verbose, sprintf("Chromosome #%d ('%s') of %d", cc, chromosome, length(chromosomes)));
+
+
+ fitCC <- extractChromosome(fit, chromosome=chromosome);
+ n0 <- nbrOfSegments(fitCC);
+
+ # Until no more neighboring non-called segments exists
+ while (TRUE) {
+ segs <- getSegments(fitCC, splitters=TRUE);
+ calls <- as.matrix(segs[,keep]);
+
+ # Find two neighboring segments that are not called
+ isCalled <- rowAnys(calls, na.rm=TRUE);
+ verbose && printf(verbose, "Number of segments not called: %d of %d\n", sum(!isCalled, na.rm=TRUE), length(isCalled));
+
+ notCalled <- which(!isCalled);
+ delta <- diff(notCalled);
+ left <- notCalled[which(delta == 1)[1]];
+
+ # No more segments to merge?
+ if (is.na(left)) {
+ break;
+ }
+
+ fitCC <- mergeTwoSegments(fitCC, left=left);
+ } # while (...)
+
+ n1 <- nbrOfSegments(fitCC);
+ verbose && printf(verbose, "Number of segments merged: %d of %d\n", n0-n1, n0);
+
+ fitList[[cc]] <- fitCC;
+ verbose && exit(verbose);
+ } # for (cc ...)
+
+ verbose && enter(verbose, "Building result");
+ res <- Reduce(append, fitList);
+ verbose && exit(verbose);
+
+ verbose && exit(verbose);
+
+ res;
+}, protected=TRUE); # mergeNonCalledSegments()
+
+
+setMethodS3("estimateDeltaCN", "CBS", function(fit, flavor=c("density(TCN)", "density(dTCN)", "dTCN"), adjust=0.3, ..., verbose=FALSE) {
+ # This will load the 'aroma.light' namespace, if not already done.
+ findPeaksAndValleys <- .use("findPeaksAndValleys", package="aroma.light");
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'flavor':
+ flavor <- match.arg(flavor);
+
+ # Argument 'adjust':
+ adjust <- Arguments$getDouble(adjust, range=c(0,10));
+
+
+ if (flavor == "density(TCN)") {
+ # Get segment mean levels
+ segs <- getSegments(fit, splitters=FALSE);
+ x <- segs$mean;
+ w <- segs$nbrOfLoci;
+
+ # Drop missing values
+ keep <- is.finite(x) & is.finite(w);
+ x <- x[keep];
+ w <- w[keep];
+ keep <- NULL; # Not needed anymore
+
+ # Normalize weights
+ w <- w / sum(w, na.rm=TRUE);
+
+ # Estimate density
+ d <- density(x, weights=w, adjust=adjust);
+
+ w <- NULL; # Not needed anymore
+
+ # Find peaks
+ pv <- findPeaksAndValleys(d, ...);
+ type <- NULL; rm(list="type"); # To please R CMD check
+ p <- subset(pv, type == "peak");
+ px <- p$x;
+ pw <- p$density;
+
+ # Distance between peaks
+ dx <- diff(px);
+ # Weights "between" peaks (AD HOC: sum up peak weights)
+ dw <- pw[-length(pw)] + pw[-1L];
+
+ deltaCN <- weighted.mean(dx, w=dw);
+ } else if (flavor == "density(dTCN)") {
+ # Get change-point magnitudes
+ x <- getChangePoints(fit)[[1L]];
+ x <- abs(x);
+
+ # Drop missing values
+ keep <- is.finite(x);
+ x <- x[keep];
+ keep <- NULL; # Not needed anymore
+
+
+ # Estimate density
+ d <- density(x, adjust=adjust);
+
+ # Find peaks
+ pv <- findPeaksAndValleys(d, ...);
+ type <- NULL; rm(list="type"); # To please R CMD check
+ p <- subset(pv, type == "peak");
+ px <- p$x;
+ pw <- p$density;
+
+ # Distance between peaks
+ dx <- diff(px);
+ # Weights "between" peaks (AD HOC: sum up peak weights)
+ dw <- pw[-length(pw)] + pw[-1L];
+
+ throw("Still not implemented.");
+ } else if (flavor == "dTCN") {
+ # Get change-point magnitudes
+ x <- getChangePoints(fit)[[1L]];
+ x <- abs(x);
+
+ # Drop missing values
+ keep <- is.finite(x);
+ x <- x[keep];
+ keep <- NULL; # Not needed anymore
+
+ deltaCN <- median(x);
+ }
+
+ # Sanity check
+ deltaCN <- Arguments$getDouble(deltaCN, range=c(0, Inf));
+
+ deltaCN;
+}, protected=TRUE)
+
+
+
+setMethodS3("encodeCalls", "data.frame", function(calls, flavor="UCSF", ...) {
+ # Argument 'calls':
+ stopifnot(all(is.element(c("chromosome", "x"), colnames(calls))));
+ stopifnot(all(is.element(c("lossCall", "gainCall"), colnames(calls))));
+
+ # Argument 'flavor':
+ flavor <- match.arg(flavor);
+
+ calls0 <- calls;
+
+ # Allocate
+ calls <- rep(NA_real_, times=nrow(calls0));
+
+ # Encode loss, neutral and gain (required)
+ calls[!calls0$gainCall & !calls0$lossCall] <- 0;
+ calls[calls0$gainCall] <- +1;
+ calls[calls0$lossCall] <- -1;
+
+ # Encode amplifications, if any/called.
+ idxs <- which(calls0$amplificationCall);
+ calls[idxs] <- +9;
+
+ # Encode negative and positive outliers, if any/called.
+ idxs <- which(calls0$negOutlierCall);
+ calls[idxs] <- calls[idxs] - 0.1;
+
+ idxs <- which(calls0$posOutlierCall);
+ calls[idxs] <- calls[idxs] + 0.1;
+
+ calls;
+}, protected=TRUE) # encodeCalls()
+
+
+setMethodS3("callGLAO", "CBS", function(fit, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Call gains, losses, amplifications and (negative and positive) outliers");
+ verbose && cat(verbose, "Number of segments: ", nbrOfSegments(fit));
+
+ # Call segments
+ fitC <- callGainsAndLosses(fit, ..., verbose=verbose);
+ fitC <- callAmplifications(fitC, ..., verbose=verbose);
+
+ # Call loci, i.e. locus-level negative and positive outliers
+ fitC <- callOutliers(fitC, ..., verbose=verbose);
+ verbose && print(verbose, fitC);
+
+ verbose && exit(verbose);
+
+ fitC;
+}, protected=TRUE) # callGLAO()
+
+
+############################################################################
+# HISTORY:
+# 2013-12-17
+# o Added argument 'flavor' to estimateDeltaCN() for CBS, which specifies
+# the type of estimator to use.
+# 2013-11-27
+# o Added callGLAO() for CBS.
+# o Added encodeCalls() for 'data.frame' object returned by
+# getLocusData(..., addCalls=TRUE).
+# 2013-11-23
+# o BUG FIX: estimateDeltaCN() assumed aroma.light was loaded.
+# 2013-11-14
+# o Added estimateDeltaCN() for CBS.
+# o BUG FIX: callGainsAndLosses() for CBS would not estimate the median
+# median CN level correctly if there were "empty" segments (e.g. gaps).
+# This was/is due to a bug in segments.summary() of the DNAcopy package.
+# Instead, we are now calculating the segment median levels ourselves.
+# 2012-01-24
+# o ROBUSTNESS: Now getCallStatistics() for CBS asserts that calls have
+# been made. If not, an exception is thrown.
+# 2011-12-13
+# o Added "ucsf-dmad" to argument 'method' for callGainsAndLosses() of CBS.
+# 2011-12-12
+# o Now extractCallsByLocus() for CBS passes arguments
+# '...' to getLocusData().
+# 2011-10-23
+# o BUG FIX: getCallStatisticsByArms() for CBS would thrown a error if
+# argument 'genomeData' did not contain exactly the same chromosomes
+# as in the CBS object.
+# o BUG FIX: The length of a segment must be defined as 'end-start' and
+# not 'end-start+1' so that the the total length of all segments
+# adds up correctly.
+# o Added verbose output to callGainsAndLosses() and callAmplifications().
+# o BUG FIX: callAmplifications() for CBS generated an error, if
+# more than one chromosome were called.
+# 2011-10-08
+# o Added mergeNonCalledSegments() for CBS.
+# 2011-10-07
+# o Now getCallStatistics() for CBS always return statistics for
+# all regions requested, even empty ones.
+# o Now getCallStatistics() for CBS also returns a 'label' column.
+# o Added getCallStatisticsByArms() and callArms() for CBS.
+# 2011-10-06
+# o Added optional argument 'regions' to getCallStatistics() for CBS.
+# o Now getCallStatistics() for CBS also returns 'start' and 'end'
+# position of each chromosome.
+# 2011-10-03
+# o DOCUMENTATION: Added more help pages.
+# 2011-10-02
+# o DOCUMENTATION: Added an Rdoc help page for getFractionOfGenomeLost(),
+# getFractionOfGenomeGained(), getFractionOfGenomeAltered(), getFGL(),
+# getFGG() and getFGA().
+# 2011-09-05
+# o Added getCallStatistics() for CBS.
+# 2011-09-04
+# o Added extractCallsByLocus() for CBS.
+# o Adopted the calling methods from ditto of the DNAcopy class.
+# 2011-09-01
+# o Now callGainsAndLosses() returns a DNAcopy where the segmentation
+# table has the new column 'tcnCall'.
+# 2011-08-19
+# o Added argument 'callParams' to plotTracks() for DNAcopy.
+# 2011-07-24
+# o Added callOutliers().
+# 2011-07-21
+# o Now amplified segments are also highlighted.
+# 2011-07-20
+# o Added callAmplifications().
+# 2011-07-20
+# o Now callGainsAndLosses() estimates the noise level on autosomes only.
+# o Now callGainsAndLosses() returns parameters used.
+# o Updated callGainsAndLosses() to estimate the std. dev. as the
+# MAD of the *residuals* (not the absolute) values.
+# o Added support for estimateStandardDeviation(..., method="res").
+# o Added extractSegmentMeansByLocus().
+# o Added drawCentromeres().
+# 2011-07-18
+# o Added getSampleNames().
+# o Added plotTracks() for DNAcopy.
+# o Added callGainsAndLosses() to DNAcopy objects.
+# o Added nbrOfSegments(), nbrOfLoci() and nbrOfSamples().
+# 2011-07-17
+# o Added estimateStandardDeviation() to DNAcopy objects.
+############################################################################
diff --git a/R/CBS.EXTS.R b/R/CBS.EXTS.R
new file mode 100644
index 0000000..49ffa60
--- /dev/null
+++ b/R/CBS.EXTS.R
@@ -0,0 +1,474 @@
+###########################################################################/**
+# @set class=DNAcopy
+# @RdocMethod as.CBS
+#
+# @title "Coerces a DNAcopy object to a CBS object"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{fit}{A @see "DNAcopy" object (of the \pkg{DNAcopy} package.)}
+# \item{sample}{An index specifying which sample to extract,
+# if more than one exists.}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns a @see "CBS" object.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# \code{\link[PSCBS:as.DNAcopy.CBS]{as.DNAcopy()}}.
+# @seeclass
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("as.CBS", "DNAcopy", function(fit, sample=1L, ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- fit$data;
+ sample <- Arguments$getIndex(sample, max=ncol(data)-2L);
+
+ sampleName <- colnames(data)[sample+2L];
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setup the 'data' field
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- fit$data;
+ rownames <- rownames(data);
+
+ data <- data.frame(
+ chromosome = data$chrom,
+ x = data$maploc,
+ y = data[,sample+2L,drop=TRUE],
+ stringsAsFactors=FALSE
+ );
+ rownames(data) <- rownames;
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setup the 'output' field
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ output <- fit$output;
+ ID <- NULL; rm(list="ID"); # To please R CMD check
+ output <- subset(output, ID == sampleName);
+ rownames <- rownames(output);
+
+ output <- data.frame(
+ chromosome = output$chrom,
+ start = output$loc.start,
+ end = output$loc.end,
+ nbrOfLoci = as.integer(output$num.mark),
+ mean = output$seg.mean,
+ stringsAsFactors=FALSE
+ );
+ rownames(output) <- rownames;
+
+ # Add chromosome splitter
+ ats <- which(diff(output$chromosome) != 0) + 1L;
+ if (length(ats) > 0) {
+ idxs <- seq(length=nrow(output));
+ values <- rep(NA_integer_, times=length(ats));
+ expand <- insert(idxs, ats=ats, values=values); # R.utils::insert()
+ output <- output[expand,];
+ rownames(output) <- NULL;
+ }
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setup up 'CBS' object
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (sampleName == "<NA>") sampleName <- as.character(NA);
+ res <- list();
+ res$sampleName <- sampleName;
+ res$data <- data;
+ res$output <- output;
+ res$params <- list();
+ class(res) <- class(CBS());
+
+ res;
+}) # as.CBS()
+
+
+setMethodS3("extractTotalCNs", "CBS", function(fit, ...) {
+ data <- getSegments(fit, ...);
+ data[,c("mean", "nbrOfLoci"), drop=FALSE];
+}, protected=TRUE)
+
+
+setMethodS3("extractCNs", "CBS", function(fit, ...) {
+ data <- extractTotalCNs(fit, ...);
+ data <- data[,c("mean"), drop=FALSE];
+ data <- as.matrix(data);
+ data;
+}, protected=TRUE)
+
+
+
+setMethodS3("extractChromosomes", "CBS", function(x, chromosomes, ...) {
+ # To please R CMD check
+ this <- x;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'chromosomes':
+ disallow <- c("NaN", "Inf");
+ chromosomes <- Arguments$getIntegers(chromosomes, range=c(0,Inf), disallow=disallow);
+ stopifnot(all(is.element(chromosomes, getChromosomes(this))));
+
+ # Always extract in order
+ chromosomes <- unique(chromosomes);
+ chromosomes <- sort(chromosomes);
+
+ # Allocate results
+ res <- this;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Locus data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ chromosome <- NULL; rm(list="chromosome"); # To please R CMD check
+ data <- getLocusData(this);
+ class <- class(data);
+ class(data) <- "data.frame";
+ data <- subset(data, chromosome %in% chromosomes);
+ class(data) <- class;
+ res$data <- data;
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Segmentation data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Identify rows to subset
+ rows <- which(is.element(res$output$chromosome, chromosomes));
+ for (field in c("output", "segRows")) {
+ res[[field]] <- res[[field]][rows,,drop=FALSE];
+ }
+
+ # Identify chromosome offsets
+ data <- getLocusData(this);
+ chrStarts <- match(getChromosomes(this), data$chromosome);
+ chrEnds <- c(chrStarts[-1]-1L, nrow(data));
+ chrLengths <- chrEnds - chrStarts + 1L;
+
+ chrLengthsExcl <- chrLengths;
+
+ keep <- match(chromosomes, getChromosomes(this));
+ chrLengthsExcl[keep] <- 0L;
+ cumChrLengthsExcl <- cumsum(chrLengthsExcl);
+
+ shifts <- cumChrLengthsExcl[keep];
+ stopifnot(all(is.finite(shifts)));
+
+ # Adjust indices
+ for (cc in seq(along=chromosomes)) {
+ chromosome <- chromosomes[cc];
+ shift <- shifts[cc];
+ # Nothing to do?
+ if (shift == 0) next;
+ for (field in c("segRows")) {
+ segRows <- res[[field]];
+ rows <- which(res$output$chromosome == chromosome);
+ segRows[rows,] <- segRows[rows,] - shift;
+ res[[field]] <- segRows;
+ }
+ }
+
+ res;
+}, protected=TRUE)
+
+
+setMethodS3("subset", "CBS", function(x, chromlist=NULL, ...) {
+ extractChromosomes(x, chromosomes=chromlist, ...);
+}, private=TRUE)
+
+
+
+###########################################################################/**
+# @set "class=CBS"
+# @RdocMethod extractSegmentMeansByLocus
+#
+# @title "Extracts segments means at each locus"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Arguments passed to @seemethod "getLocusData".}
+# }
+#
+# \value{
+# Returns a @numeric @vector of length \code{nbrOfLoci()}.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# @seeclass
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("extractSegmentMeansByLocus", "CBS", function(fit, ...) {
+ data <- getLocusData(fit, ...);
+ chromosome <- data$chromosome;
+ x <- data$x;
+ y <- data[,3];
+
+ segs <- getSegments(fit);
+ nbrOfSegments <- nrow(segs);
+ nbrOfLoci <- nrow(data);
+
+ # Get mean estimators
+ estList <- getMeanEstimators(fit, "y");
+ avgY <- estList$y;
+
+ yS <- y;
+ for (ss in seq(length=nbrOfSegments)) {
+ seg <- segs[ss,];
+ idxs <- which(seg$chromosome == chromosome &
+ seg$start <= x & x <= seg$end);
+ idxs <- Arguments$getIndices(idxs, max=nbrOfLoci);
+
+ ySS <- y[idxs];
+ ok <- is.finite(ySS);
+
+ # Sanity check
+ ## stopifnot(sum(ok) == seg$nbrOfLoci); # Not dealing with ties
+
+ mu <- avgY(ySS[ok]);
+ yS[idxs] <- mu;
+ } # for (ss ...)
+
+ yS;
+}, private=TRUE) # extractSegmentMeansByLocus()
+
+
+
+###########################################################################/**
+# @set "class=CBS"
+# @RdocMethod estimateStandardDeviation
+#
+# @title "Estimates the whole-genome standard deviation of the signals"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{chromosomes}{An optional @vector specifying the subset of
+# chromosomes used for the estimate. If @NULL, all chromosomes are used.}
+# \item{method}{A @character string specifying the method used.}
+# \item{estimator}{A @character string or a @function specifying the
+# internal estimator.}
+# \item{na.rm}{If @TRUE, missing values are dropped, otherwise not.}
+# \item{weights}{An optional @double @vector of \code{nbrOfLoci()}
+# non-negative weights.}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns a non-negative @numeric scale.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# @seeclass
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("estimateStandardDeviation", "CBS", function(fit, chromosomes=NULL, method=c("diff", "res", "abs", "DNAcopy"), estimator=c("mad", "sd"), na.rm=TRUE, weights=NULL, ...) {
+ # Local copies of DNAcopy functions
+ DNAcopy_trimmed.variance <- .use("trimmed.variance", package="DNAcopy");
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'chromosomes':
+ if (!is.null(chromosomes)) {
+ }
+
+ # Argument 'method':
+ method <- match.arg(method);
+
+ # Argument 'estimator':
+ estimator <- match.arg(estimator);
+
+
+ # Argument 'weights':
+ if (!is.null(weights)) {
+ nbrOfLoci <- nbrOfLoci(fit);
+ weights <- Arguments$getNumerics(weights, range=c(0,Inf),
+ length=rep(nbrOfLoci, times=2));
+ }
+
+
+ # Get the estimator function
+ if (!is.null(weights)) {
+ estimator <- sprintf("weighted %s", estimator);
+ estimator <- R.utils::toCamelCase(estimator);
+ }
+
+ if (method == "DNAcopy") {
+ estimatorFcn <- function(y, trim=0.025, ...) {
+ sigma2 <- DNAcopy_trimmed.variance(y, trim=trim);
+ sqrt(sigma2);
+ }
+ } else {
+ estimatorFcn <- get(estimator, mode="function");
+ }
+
+
+ # Subset by chromosomes?
+ if (!is.null(chromosomes)) {
+ fit <- extractChromosomes(fit, chromosomes=chromosomes);
+ }
+
+ nbrOfLoci <- nbrOfLoci(fit);
+ # Nothing to do?
+ if (nbrOfLoci <= 1) {
+ sigma <- NA_real_;
+ attr(sigma, "nbrOfLoci") <- nbrOfLoci;
+ attr(sigma, "df") <- NA_integer_;
+ return(sigma);
+ }
+
+ data <- getLocusData(fit);
+ y <- data[,3];
+
+ if (method == "diff") {
+ dy <- diff(y);
+ # Weighted estimator?
+ if (!is.null(weights)) {
+ # Calculate weights per pair
+ weights <- (weights[1:(nbrOfLoci-1)]+weights[2:nbrOfLoci])/2;
+ sigma <- estimatorFcn(dy, w=weights, na.rm=na.rm)/sqrt(2);
+ } else {
+ sigma <- estimatorFcn(dy, na.rm=na.rm)/sqrt(2);
+ }
+ df <- length(dy);
+ } else if (method == "res") {
+ yS <- extractSegmentMeansByLocus(fit);
+ dy <- y - yS;
+ if (!is.null(weights)) {
+ sigma <- estimatorFcn(dy, w=weights, na.rm=na.rm);
+ } else {
+ sigma <- estimatorFcn(dy, na.rm=na.rm);
+ }
+ df <- length(dy);
+ } else if (method == "abs") {
+ if (!is.null(weights)) {
+ sigma <- estimatorFcn(y, w=weights, na.rm=na.rm);
+ } else {
+ sigma <- estimatorFcn(y, na.rm=na.rm);
+ }
+ df <- length(y);
+ } else if (method == "DNAcopy") {
+ if (na.rm) {
+ y <- y[!is.na(y)];
+ }
+ sigma <- estimatorFcn(y, ...);
+ df <- length(y);
+ } else {
+ throw("Method no implemented: ", method);
+ }
+
+ attr(sigma, "nbrOfLoci") <- nbrOfLoci;
+ attr(sigma, "df") <- df;
+
+ sigma;
+}) # estimateStandardDeviation()
+
+
+
+setMethodS3("getChromosomeRanges", "CBS", function(fit, ...) {
+ # To please R CMD check, cf. subset()
+ chromosome <- NULL; rm(list="chromosome");
+
+ segs <- getSegments(fit, splitter=FALSE);
+ chromosomes <- sort(unique(segs$chromosome));
+
+ # Allocate
+ naValue <- NA_real_;
+ res <- matrix(naValue, nrow=length(chromosomes), ncol=3);
+ rownames(res) <- chromosomes;
+ colnames(res) <- c("start", "end", "length");
+
+ # Get start and end of each chromosome.
+ for (ii in seq(length=nrow(res))) {
+ chr <- chromosomes[ii];
+ segsII <- subset(segs, chromosome == chr);
+ res[ii,"start"] <- min(segsII$start, na.rm=TRUE);
+ res[ii,"end"] <- max(segsII$end, na.rm=TRUE);
+ } # for (ii ...)
+
+ res[,"length"] <- res[,"end"] - res[,"start"] + 1L;
+
+ # Sanity check
+ stopifnot(nrow(res) == length(chromosomes));
+
+ res <- as.data.frame(res);
+ res <- cbind(chromosome=chromosomes, res);
+
+ res;
+}, protected=TRUE) # getChromosomeRanges()
+
+
+
+############################################################################
+# HISTORY:
+# 2012-06-03
+# o BUG FIT: The recent updates of as.CBS() for DNAcopy would not work
+# for samples with name '<NA>'.
+# 2012-05-30
+# o BUG FIX: as.CNA() for DNAcopy added incorrect chromosome splitters.
+# o BUG FIX: as.CNA() for DNAcopy would ignore argument 'sample' and
+# always return the first sample.
+# 2011-12-12
+# o Now extractSegmentMeansByLocus() for CBS passes arguments
+# '...' to getLocusData().
+# 2011-11-28
+# o extractCNs() for CBS would not return a matrix but a data.frame.
+# o BUG FIX: extractTotalCNs() for CBS would give an error.
+# 2011-11-15
+# o Added method="DNAcopy" to estimateStandardDeviation() for CBS, which
+# estimates the std. dev. using DNAcopy:::trimmed.variance().
+# 2011-10-16
+# o Added extractTotalCNs() for CBS.
+# o Implemented extractCNs() for CBS.
+# 2011-10-08
+# o BUG FIX: The object returned by as.CBS() of DNAcopy did not have the
+# correct class hierarchy.
+# 2011-10-06
+# o Now getChromosomeRanges() of CBS returns a data.frame instead of
+# a matrix, and first column is now 'chromosome'.
+# 2011-09-05
+# o Added getChromosomeRanges() for CBS.
+# 2011-09-04
+# o Added estimateStandardDeviation() for CBS.
+# o Added extractSegmentMeansByLocus() for CBS.
+# 2011-09-03
+# o Added as.CBS() for DNAcopy to coerce a DNAcopy object to a CBS object.
+# 2011-09-02
+# o Added extractByChromosomes() for CBS.
+# o Added subset() for CBS for backward compatibility.
+# o Added nbrOfLoci(), getChromosomes() and getSampleNames() for CBS.
+# 2010-11-19
+# o Added append() for CBS objects.
+############################################################################
diff --git a/R/CBS.IO.R b/R/CBS.IO.R
new file mode 100644
index 0000000..799e140
--- /dev/null
+++ b/R/CBS.IO.R
@@ -0,0 +1,261 @@
+setMethodS3("writeLocusData", "CBS", function(fit, name=getSampleName(fit), tags=NULL, ext="tsv", path=NULL, sep="\t", nbrOfDecimals=4L, addHeader=TRUE, createdBy=NULL, overwrite=FALSE, skip=FALSE, ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'name' and 'tags':
+ name <- Arguments$getCharacter(name);
+ tags <- Arguments$getCharacters(tags);
+
+ # Argument 'ext':
+ ext <- Arguments$getCharacter(ext);
+
+ # Arguments 'path':
+ path <- Arguments$getWritablePath(path);
+
+ # Argument 'nbrOfDecimals':
+ nbrOfDecimals <- Arguments$getInteger(nbrOfDecimals);
+
+
+
+ fullname <- paste(c(name, tags), collapse=",");
+ filename <- sprintf("%s.%s", fullname, ext);
+ pathname <- Arguments$getWritablePathname(filename, path=path, mustNotExist=(!overwrite && !skip));
+
+ # File already exists?
+ if (isFile(pathname)) {
+ # Skip?
+ if (skip) {
+ return(pathname);
+ }
+
+ # Overwrite!
+ file.remove(pathname);
+ }
+
+ # Write to temporary file
+ pathnameT <- pushTemporaryFile(pathname);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fit, ...);
+
+ # Round of floating points
+ if (!is.null(nbrOfDecimals)) {
+ cols <- colnames(data);
+ for (key in cols) {
+ values <- data[[key]];
+ if (is.double(values)) {
+ values <- round(values, digits=nbrOfDecimals);
+ data[[key]] <- values;
+ }
+ } # for (key ...)
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Build header
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (addHeader) {
+ sigmaDelta <- estimateStandardDeviation(fit, method="diff");
+# sigmaResiduals <- estimateStandardDeviation(fit, method="res");
+
+ createdOn <- format(Sys.time(), format="%Y-%m-%d %H:%M:%S %Z");
+ hdr <- c(
+ name=name,
+ tags=tags,
+ fullname=fullname,
+ segmentationMethod=sprintf("segment() of %s", attr(fit, "pkgDetails")),
+ nbrOfLoci=nbrOfLoci(fit),
+ nbrOfSegments=nbrOfSegments(fit),
+ joinSegments=fit$params$joinSegments,
+ signalType=getSignalType(fit),
+ sigmaDelta=sprintf("%.4f", sigmaDelta),
+# sigmaResiduals=sprintf("%.4f", sigmaResiduals),
+ createdBy=createdBy,
+ createdOn=createdOn,
+ nbrOfDecimals=nbrOfDecimals,
+ nbrOfColumns=ncol(data),
+ columnNames=paste(colnames(data), collapse=", "),
+ columnClasses=paste(sapply(data, FUN=function(x) class(x)[1]), collapse=", ")
+ );
+ bfr <- paste("# ", names(hdr), ": ", hdr, sep="");
+
+ cat(file=pathnameT, bfr, sep="\n");
+ } # if (addHeader)
+
+ write.table(file=pathnameT, data, append=TRUE, quote=FALSE, sep=sep,
+ row.names=FALSE, col.names=TRUE);
+
+ pathname <- popTemporaryFile(pathnameT);
+
+ pathname;
+}, protected=TRUE) # writeLocusData()
+
+
+
+###########################################################################/**
+# @set "class=CBS"
+# @RdocMethod writeSegments
+# @alias writeWIG
+# @alias writeWIG.AbstractCBS
+#
+# @title "Writes the table of segments to file"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{name, tags}{Name and optional tags part of the filename}.
+# \item{path}{The directory where the file will be written.}
+# \item{addHeader}{If @TRUE, header comments are written.}
+# \item{createdBy}{A header comment of whom created the file.}
+# \item{splitters}{If @TRUE, each chromosome is separated by a row
+# of missing values.}
+# \item{overwrite, skip}{If an output file already exists, these
+# arguments specifies what should happen.}
+# \item{...}{Additional arguments pass to \code{getSegments()}.}
+# }
+#
+# \value{
+# Returns the pathname of the the file written.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# Utilizes @seemethod "getSegments".
+# @seeclass.
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("writeSegments", "CBS", function(fit, name=getSampleName(fit), tags=NULL, ext="tsv", path=NULL, addHeader=TRUE, createdBy=NULL, sep="\t", nbrOfDecimals=4L, splitters=FALSE, overwrite=FALSE, skip=FALSE, ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'name' and 'tags':
+ name <- Arguments$getCharacter(name);
+ tags <- Arguments$getCharacters(tags);
+
+ # Argument 'ext':
+ ext <- Arguments$getCharacter(ext);
+
+ # Arguments 'path':
+ path <- Arguments$getWritablePath(path);
+
+ # Argument 'nbrOfDecimals':
+ nbrOfDecimals <- Arguments$getInteger(nbrOfDecimals);
+
+
+
+ fullname <- paste(c(name, tags), collapse=",");
+ filename <- sprintf("%s.%s", fullname, ext);
+ pathname <- Arguments$getWritablePathname(filename, path=path, mustNotExist=(!overwrite && !skip));
+
+ # File already exists?
+ if (isFile(pathname)) {
+ # Skip?
+ if (skip) {
+ return(pathname);
+ }
+
+ # Overwrite!
+ file.remove(pathname);
+ }
+
+ # Write to temporary file
+ pathnameT <- pushTemporaryFile(pathname);
+
+
+ sampleName <- getSampleName(fit);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getSegments(fit, ..., splitters=splitters);
+
+ # Round of floating points
+ if (!is.null(nbrOfDecimals)) {
+ cols <- tolower(colnames(data));
+ isInt <- (regexpr("chromosome|start|end|nbrofloci", cols) != -1);
+ cols <- which(isInt);
+ for (cc in cols) {
+ values <- data[[cc]];
+ if (is.double(values)) {
+ values <- round(values, digits=0);
+ data[[cc]] <- values;
+ }
+ } # for (key ...)
+
+ cols <- tolower(colnames(data));
+ isInt <- (regexpr("chromosome|start|end|nbrofloci", cols) != -1);
+ isLog <- (regexpr("call", cols) != -1);
+ isDbl <- (!isInt & !isLog);
+ cols <- which(isDbl);
+ for (kk in cols) {
+ values <- data[[kk]];
+ if (is.double(values)) {
+ values <- round(values, digits=nbrOfDecimals);
+ data[[kk]] <- values;
+ }
+ } # for (key ...)
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Build header
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (addHeader) {
+ sigmaDelta <- estimateStandardDeviation(fit, method="diff");
+# sigmaResiduals <- estimateStandardDeviation(fit, method="res");
+
+ createdOn <- format(Sys.time(), format="%Y-%m-%d %H:%M:%S %Z");
+ hdr <- c(
+ name=name,
+ tags=tags,
+ fullname=fullname,
+ segmentationMethod=sprintf("segment() of %s", attr(fit, "pkgDetails")),
+ nbrOfLoci=nbrOfLoci(fit),
+ nbrOfSegments=nbrOfSegments(fit),
+ joinSegments=fit$params$joinSegments,
+ signalType=getSignalType(fit),
+ sigmaDelta=sprintf("%.4f", sigmaDelta),
+# sigmaResiduals=sprintf("%.4f", sigmaResiduals),
+ createdBy=createdBy,
+ createdOn=createdOn,
+ nbrOfDecimals=nbrOfDecimals,
+ nbrOfColumns=ncol(data),
+ columnNames=paste(colnames(data), collapse=", "),
+ columnClasses=paste(sapply(data, FUN=function(x) class(x)[1]), collapse=", ")
+ );
+ bfr <- paste("# ", names(hdr), ": ", hdr, sep="");
+
+ cat(file=pathnameT, bfr, sep="\n");
+ } # if (addHeader)
+
+ write.table(file=pathnameT, data, append=TRUE, quote=FALSE, sep=sep,
+ row.names=FALSE, col.names=TRUE);
+
+ pathname <- popTemporaryFile(pathnameT);
+
+ pathname;
+}) # writeSegments()
+
+
+
+
+
+############################################################################
+# HISTORY:
+# 2011-12-03
+# o Added arguments 'name', 'tags' and 'exts' to writeSegments() and
+# writeLocusData() and dropped 'filename'.
+# 2011-09-04
+# o Added writeSegments() for CBS.
+# o Added writeLocusData() for CBS.
+############################################################################
diff --git a/R/CBS.PLOT,many.R b/R/CBS.PLOT,many.R
new file mode 100644
index 0000000..e8f422f
--- /dev/null
+++ b/R/CBS.PLOT,many.R
@@ -0,0 +1,268 @@
+setMethodS3("tileChromosomes", "CBS", function(fit, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ # Nothing to do, i.e. already tiled?
+ if (isTRUE(attr(fit, "tiledChromosomes"))) {
+ return(fit);
+ }
+
+ verbose && enter(verbose, "Tiling chromosomes");
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract data and segments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fit);
+ segs <- getSegments(fit);
+ knownSegments <- fit$params$knownSegments;
+
+ # Identify all chromosome
+ chromosomes <- getChromosomes(fit);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Additional chromosome annotations
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ chrStats <- getChromosomeRanges(fit);
+
+ # Build an "empty" row with start == 1.
+ chrStatsKK <- chrStats[1,,drop=FALSE][NA,,drop=FALSE];
+ chrStatsKK[,"start"] <- 1L;
+
+ # Append empty row
+ chrStats <- rbind(chrStats, chrStatsKK);
+
+ # Offset (start,stop)
+ chrOffsets <- getChromosomeOffsets(fit, ...);
+ chrStats[,"start"] <- chrStats[,"start"] + chrOffsets;
+ chrStats[,"end"] <- chrStats[,"end"] + chrOffsets;
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Offset...
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ segFields <- grep("(start|end)$", colnames(segs), value=TRUE);
+ for (kk in seq(along=chromosomes)) {
+ chromosome <- chromosomes[kk];
+ chrTag <- sprintf("Chr%02d", chromosome);
+ verbose && enter(verbose, sprintf("Chromosome #%d ('%s') of %d",
+ kk, chrTag, length(chromosomes)));
+
+ # Get offset for this chromosome
+ offset <- chrOffsets[kk];
+ verbose && cat(verbose, "Offset: ", offset);
+
+ # Offset data
+ idxs <- which(data$chromosome == chromosome);
+ if (length(idxs) > 0L) {
+ data$x[idxs] <- offset + data$x[idxs];
+ }
+
+ # Offset segmentation
+ idxs <- which(segs$chromosome == chromosome);
+ if (length(idxs) > 0L) {
+ segs[idxs,segFields] <- offset + segs[idxs,segFields];
+ }
+
+ # Offset known segments
+ idxs <- which(knownSegments$chromosome == chromosome);
+ if (length(idxs) > 0L) {
+ knownSegments[idxs,c("start", "end")] <- offset + knownSegments[idxs,c("start", "end")];
+ }
+
+ verbose && exit(verbose);
+ } # for (kk ...)
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Update results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fitT <- fit;
+ fitT$data <- data;
+ fitT$output <- segs;
+ fitT$chromosomeStats <- chrStats;
+ fitT$params$knownSegments <- knownSegments;
+ fitT$params$chrOffsets <- chrOffsets;
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Sanity checks
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ segs <- getSegments(fit);
+ segsT <- getSegments(fitT);
+ segs <- segs[,!is.element(colnames(segs), c("start", "end"))];
+ segsT <- segsT[,!is.element(colnames(segsT), c("start", "end"))];
+ stopifnot(all.equal(segsT, segs));
+
+ data <- getLocusData(fit);
+ dataT <- getLocusData(fitT);
+ data <- data[,!is.element(colnames(data), c("x"))];
+ dataT <- dataT[,!is.element(colnames(dataT), c("x"))];
+ stopifnot(all.equal(dataT, data));
+
+ stopifnot(nbrOfLoci(fitT) == nbrOfLoci(fit));
+ stopifnot(nbrOfSegments(fitT) == nbrOfSegments(fit));
+
+ # Flag object
+ attr(fitT, "tiledChromosomes") <- TRUE;
+
+ verbose && exit(verbose);
+
+ fitT;
+}, protected=TRUE) # tileChromosomes()
+
+
+
+setMethodS3("plotTracksManyChromosomes", "CBS", function(x, scatter=TRUE, pch=20, col="gray", meanCol="purple", Clim=c(0,3*ploidy(x)), xScale=1e-6, xlab="Genomic position", Clab="TCN", ..., boundaries=TRUE, levels=TRUE, subset=NULL, byIndex=FALSE, add=FALSE, onBegin=NULL, onEnd=NULL, mar=NULL, verbose=FALSE) {
+ # To please R CMD check
+ fit <- x;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'fit':
+
+ # Argument 'add':
+ add <- Arguments$getLogical(add);
+
+ # Argument 'Clim':
+ if (!add) {
+ Clim <- Arguments$getNumerics(Clim, length=c(2L,2L),
+ disallow=c("Inf", "NA", "NaN"));
+ }
+
+ # Argument 'xScale':
+ xScale <- Arguments$getNumeric(xScale, range=c(0,Inf));
+
+ # Argument 'subset':
+ if (!is.null(subset)) {
+ subset <- Arguments$getDouble(subset, range=c(0,1));
+ }
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Tile chromosomes
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fitT <- tileChromosomes(fit);
+ verbose && str(verbose, fitT);
+ # Sanity check
+ stopifnot(!is.null(fitT$chromosomeStats));
+
+ # Extract the input data
+ data <- getLocusData(fitT);
+ if (is.null(data)) {
+ throw("Cannot plot segmentation results. No input data available.");
+ }
+
+ # Subset of the loci?
+ if (!is.null(subset) && subset < 1) {
+ n <- nrow(data);
+ keep <- sample(n, size=subset*n);
+ data <- data[keep,];
+ }
+
+ # To please R CMD check
+ CT <- y <- muN <- betaT <- betaN <- betaTN <- NULL;
+ rm(list=c("CT", "muN", "betaT", "betaN", "betaTN"));
+ attachLocally(data);
+ x <- xScale * x;
+ chrStats <- fitT$chromosomeStats;
+ chrStats <- chrStats[-nrow(chrStats),,drop=FALSE];
+ chrRanges <- as.matrix(chrStats[,c("start","end")]);
+ vs <- xScale * chrRanges;
+ mids <- (vs[,1]+vs[,2])/2;
+ CT <- y;
+
+ nbrOfLoci <- length(x);
+ chromosomes <- getChromosomes(fitT);
+ chrLabels <- sprintf("%02d", chromosomes);
+
+ if (byIndex) {
+ xs <- seq(along=x);
+ } else {
+ xs <- x;
+ }
+
+ if (!add && !is.null(mar)) {
+ par(mar=mar);
+ }
+
+ gh <- fitT;
+ gh$xScale <- xScale;
+
+ xlim <- xScale*range(chrRanges, na.rm=TRUE);
+
+ pchT <- if (scatter) { pch } else { NA };
+
+ plot(NA, xlim=xlim, ylim=Clim, xlab=xlab, ylab=Clab, axes=FALSE);
+ if (!is.null(onBegin)) onBegin(gh=gh);
+ points(xs, CT, pch=pchT, col=col, ...);
+ side <- rep(c(1,3), length.out=length(chrLabels));
+ mtext(text=chrLabels, side=side, at=mids, line=0.1, cex=0.7*par("cex"));
+ if (boundaries) {
+ abline(v=vs, lty=3);
+ }
+ axis(side=2);
+ box();
+ if (levels) {
+ drawLevels(fitT, col=meanCol, xScale=xScale, byIndex=byIndex);
+ }
+ if (!is.null(onEnd)) onEnd(gh=gh);
+
+ invisible(gh);
+}, private=TRUE) # plotTracksManyChromosomes()
+
+
+
+############################################################################
+# HISTORY:
+# 2013-10-14
+# o Now plotTracksManyChromosomes() for CBS gives a more informative
+# error if 'Clim' is invalid.
+# 2013-10-09
+# o BUG FIX: tileChromosomes() for CBS did not set "tiledChromosomes"
+# attribute due to a typo.
+# 2013-05-07
+# o Now tileChromosomes() no longer gives warnings on "max(i): no
+# non-missing arguments to max; returning -Inf".
+# 2011-12-06
+# o Now plotTracks() for CBS always returns an invisible object.
+# 2011-12-03
+# o Added drawChangePoints() for CBS.
+# 2011-10-23
+# o BUG FIX: highlightArmCalls() for CBS did not handle empty chromosomes.
+# 2011-10-08
+# o Added drawChromosomes() for CBS.
+# 2011-10-07
+# o Added highlightArmCalls() for CBS.
+# 2011-10-06
+# o Now drawCentromeres() for CBS can also plot start and stop.
+# o ROBUSTNESS: Now plotTracksManyChromosomes() extract (start,end)
+# information by names (no longer assuming certain indices).
+# 2011-09-07
+# o Added highlightLocusCalls().
+# 2011-09-06
+# o Added highlightCalls().
+# o Added getChromosomeOffsets().
+# 2011-09-01
+# o BUG FIX: plotTracksManyChromosomes() for CBS gave an error because
+# internal variable 'CT' was not defined.
+# o BUG FIX: tileChromosomes() for CBS not identify the chromosomes of
+# the loci, and hence generated corrupt/missing values while tiling.
+# 2010-11-19
+# o Created from PairedPSCBS.R.
+############################################################################
diff --git a/R/CBS.PLOT.R b/R/CBS.PLOT.R
new file mode 100644
index 0000000..289c33f
--- /dev/null
+++ b/R/CBS.PLOT.R
@@ -0,0 +1,465 @@
+###########################################################################/**
+# @set "class=CBS"
+# @RdocMethod plotTracks
+#
+# @title "Plots copy numbers along the genome"
+#
+# \description{
+# @get "title" for one or more chromosomes.
+# Each type of track is plotted in its own panel.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{x}{A result object returned by @see "segmentByCBS".}
+# \item{pch}{The type of points to use.}
+# \item{Clim}{The range of copy numbers.}
+# \item{xScale}{The scale factor used for genomic positions.}
+# \item{...}{Not used.}
+# \item{add}{If @TRUE, the panels plotted are added to the existing plot,
+# otherwise a new plot is created.}
+# }
+#
+# \value{
+# Returns nothing.
+# }
+#
+# @author "HB"
+#
+# @keyword IO
+# @keyword internal
+#*/###########################################################################
+setMethodS3("plotTracks", "CBS", function(x, scatter=TRUE, pch=20, col="gray", meanCol="purple", cex=1, grid=FALSE, Clim="auto", xScale=1e-6, Clab="auto", ..., byIndex=FALSE, mar=NULL, add=FALSE) {
+ # To please R CMD check
+ fit <- x;
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'add':
+ add <- Arguments$getLogical(add);
+
+ # Argument 'Clim':
+ if (identical(Clim, "auto")) {
+ signalType <- getSignalType(fit);
+ ploidy <- ploidy(fit);
+ Clim <- switch(signalType,
+ "log2ratio" = c(-2,2) + c(-1,1)*ploidy/2,
+ "ratio" = c(0,3*ploidy),
+ NULL
+ );
+## NOTE: Don't understand why, but with this 'R CMD build' gives:
+## "Error: processing vignette 'CBS.tex.rsp' failed with diagnostics:
+## Failed to infer argument 'Clim' due to an unknown signalType(): NA"
+## /HB 2013-10-14
+## if (!add && is.null(Clim)) {
+## throw("Failed to infer argument 'Clim' due to an unknown signalType(): ", signalType);
+## }
+ } else if (!add) {
+ Clim <- Arguments$getNumerics(Clim, length=c(2L,2L),
+ disallow=c("Inf", "NA", "NaN"));
+ }
+
+ if (identical(Clab, "auto")) {
+ signalType <- getSignalType(fit);
+ Clab <- switch(signalType,
+ "log2ratio" = "log2 CN ratio",
+ "ratio" = "CN ratio",
+ NULL
+ );
+ }
+
+ # Argument 'fit':
+ if (nbrOfChromosomes(fit) > 1L) {
+ res <- plotTracksManyChromosomes(fit, scatter=scatter, pch=pch, col=col, cex=cex, meanCol=meanCol, Clim=Clim, xScale=xScale, Clab=Clab, ..., byIndex=byIndex, mar=mar, add=add);
+ return(invisible(res));
+ }
+
+ # Argument 'xScale':
+ xScale <- Arguments$getNumeric(xScale, range=c(0,Inf));
+
+ # Extract the input data
+ data <- getLocusData(fit);
+ if (is.null(data)) {
+ throw("Cannot plot segmentation results. No input data available.");
+ }
+
+ chromosomes <- getChromosomes(fit);
+ chromosome <- chromosomes[1];
+ x <- data$x;
+ CT <- data[,3];
+ nbrOfLoci <- length(x);
+
+ # Extract the segmentation
+ segs <- getSegments(fit);
+
+
+ if (chromosome != 0) {
+ chrTag <- sprintf("Chr%02d", chromosome);
+ } else {
+ chrTag <- "";
+ }
+
+ if (xScale != 1) {
+ x <- xScale * x;
+ }
+
+ if (!add && !is.null(mar)) {
+ par(mar=mar);
+ }
+
+
+ pchT <- if (scatter) { pch } else { NA };
+
+ plot(x, CT, pch=pchT, cex=cex, col=col, ..., ylim=Clim, ylab=Clab);
+ stext(side=3, pos=1, chrTag);
+ if (grid) {
+ yrange <- par("usr")[3:4];
+ yrange[1] <- floor(yrange[1]);
+ yrange[2] <- ceiling(yrange[2]);
+ abline(h=seq(from=yrange[1], to=yrange[2], by=2), lty=3, col="gray");
+ abline(h=0, lty=1, col="black");
+ }
+ drawLevels(fit, col=meanCol, xScale=xScale);
+
+ invisible();
+}) # plotTracks()
+
+
+setMethodS3("plot", "CBS", function(x, ...) {
+ plotTracks(x, ...);
+}, protected=TRUE)
+
+
+setMethodS3("drawLevels", "CBS", function(fit, col="purple", xScale=1e-6, byIndex=FALSE, ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Tile chromosomes
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fitT <- tileChromosomes(fit);
+
+ # Get segmentation results
+ segs <- as.data.frame(fitT);
+
+ # Extract subset of segments
+ fields <- c("start", "end", "mean");
+ segs <- segs[,fields, drop=FALSE];
+ segs <- unique(segs);
+
+ # Reuse drawLevels() for the DNAcopy class
+ colnames(segs) <- c("loc.start", "loc.end", "seg.mean");
+ dummy <- list(output=segs);
+ class(dummy) <- "DNAcopy";
+ drawLevels(dummy, col=col, xScale=xScale, ...);
+}, protected=TRUE)
+
+
+setMethodS3("highlightCalls", "CBS", function(fit, pch=20, callCols=c(loss="red", gain="green", "amplification"="blue"), lwd=3, meanCol="purple", ..., xScale=1e-6, byIndex=FALSE, verbose=FALSE) {
+ segs <- getSegments(fit, splitter=FALSE);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Identify segment calls
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ callFields <- grep("Call$", colnames(segs));
+ callTypes <- gsub("Call$", "", colnames(segs)[callFields]);
+ nbrOfCalls <- length(callFields);
+
+ # Nothing todo?
+ if (nbrOfCalls == 0L) {
+ return();
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Tile chromosomes
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fitT <- tileChromosomes(fit);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Highlight threshold levels
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ params <- fit$params$callGainsAndLosses;
+ abline(h=params$muR, col="gray", lty=3);
+ abline(h=params$tauLoss, col=callCols["loss"], lty=3);
+ abline(h=params$tauGain, col=callCols["gain"], lty=3);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Highlight gains and losses
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ dataT <- getLocusData(fitT);
+ segsT <- getSegments(fitT, splitter=FALSE);
+ chr <- dataT[,"chromosome"];
+ x <- dataT[,"x"];
+ y <- dataT[,3];
+ nbrOfLoci <- nbrOfLoci(fitT);
+ nbrOfSegments <- nbrOfSegments(fitT);
+ # Not needed anymore
+ dataT <- NULL;
+
+ # For each non-neutral segment
+ for (ss in seq(length=nbrOfSegments)) {
+ seg <- segsT[ss,];
+
+ for (tt in seq(along=callTypes)) {
+ field <- callFields[tt];
+ type <- callTypes[tt];
+
+ # Called?
+ call <- seg[[field]];
+ if (isTRUE(call)) {
+ col <- callCols[type];
+ idxs <- which(chr == seg$chromosome & seg$start <= x & x <= seg$end);
+ idxs <- Arguments$getIndices(idxs, max=nbrOfLoci);
+
+ if (byIndex) {
+ xs <- idxs;
+ } else {
+ xs <- x[idxs] * xScale;
+ }
+ ys <- y[idxs];
+ points(xs, ys, pch=pch, col=col, ...);
+ xx <- range(xs, na.rm=TRUE);
+ yy <- rep(seg$mean, times=2);
+ lines(xx, yy, lwd=lwd, col=meanCol);
+ }
+ } # for (tt ...)
+ } # for (ss ...)
+}, protected=TRUE) # highlightCalls()
+
+
+
+setMethodS3("highlightLocusCalls", "CBS", function(fit, callPchs=c(negOutlier=25, posOutlier=24), callCols=c(negOutlier="blue", posOutlier="blue"), ..., xScale=1e-6, byIndex=FALSE, verbose=FALSE) {
+ data <- getLocusData(fit);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Identify segment calls
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ callFields <- grep("Call$", colnames(data));
+ callTypes <- gsub("Call$", "", colnames(data)[callFields]);
+ nbrOfCalls <- length(callFields);
+
+ # Nothing todo?
+ if (nbrOfCalls == 0) {
+ return();
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Tile chromosomes
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fitT <- tileChromosomes(fit);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Highlight gains and losses
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ dataT <- getLocusData(fitT);
+ chr <- dataT[,"chromosome"];
+ x <- dataT[,"x"];
+ y <- dataT[,3];
+ nbrOfLoci <- nbrOfLoci(fitT);
+
+ # For each non-neutral segment
+ for (tt in seq(along=callTypes)) {
+ field <- callFields[tt];
+ type <- callTypes[tt];
+
+ isCalled <- dataT[[field]];
+ idxs <- which(isCalled);
+
+ if (length(idxs) == 0L) {
+ next;
+ }
+
+ if (byIndex) {
+ xs <- idxs;
+ } else {
+ xs <- x[idxs] * xScale;
+ }
+ ys <- y[idxs];
+ pch <- callPchs[type];
+ col <- callCols[type];
+ points(xs, ys, pch=pch, col=col, ...);
+ } # for (tt ...)
+}, protected=TRUE) # highlightLocusCalls()
+
+
+
+
+setMethodS3("drawChromosomes", "CBS", function(x, lty=3, xScale=1e-6, ..., byIndex=FALSE, verbose=FALSE) {
+ # To please R CMD check
+ fit <- x;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'fit':
+
+ # Argument 'xScale':
+ xScale <- Arguments$getNumeric(xScale, range=c(0,Inf));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Tile chromosomes
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fitT <- tileChromosomes(fit);
+ # Sanity check
+ stopifnot(!is.null(fitT$chromosomeStats));
+
+ chrStats <- fitT$chromosomeStats;
+ chrStats <- chrStats[-nrow(chrStats),,drop=FALSE];
+ chrRanges <- as.matrix(chrStats[,c("start","end")]);
+ vs <- xScale * chrRanges;
+ mids <- (vs[,1]+vs[,2])/2;
+ chromosomes <- getChromosomes(fitT);
+ chrLabels <- sprintf("%02d", chromosomes);
+ side <- rep(c(1,3), length.out=length(chrLabels));
+ mtext(text=chrLabels, side=side, at=mids, line=0.1, cex=0.7*par("cex"));
+ abline(v=vs, lty=lty);
+}, protected=TRUE) # drawChromosomes()
+
+
+
+setMethodS3("drawCentromeres", "CBS", function(fit, genomeData, what=c("start", "end"), xScale=1e-6, col="gray", lty=3, ..., byIndex=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'genomeData':
+ stopifnot(inherits(genomeData, "data.frame"));
+ stopifnot(is.element("chromosome", colnames(genomeData)));
+ stopifnot(is.element("centroStart", colnames(genomeData)));
+ stopifnot(is.element("centroEnd", colnames(genomeData)));
+
+ # Calculate the midpoints of the centromeres
+ colnames(genomeData) <- tolower(gsub("centro", "", colnames(genomeData)));
+ genomeData$mid <- (genomeData$start + genomeData$end) / 2;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Tile chromosomes
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fitT <- tileChromosomes(fit);
+ # Sanity check
+ stopifnot(!is.null(fitT$chromosomeStats));
+
+ chrStats <- fitT$chromosomeStats;
+ offsets <- chrStats[,"start"] - chrStats[1,"start"];
+
+ # Centroid locations in the tiled space
+ offsetsT <- offsets[seq(length=nrow(genomeData))];
+
+ xx <- genomeData[,what,drop=FALSE];
+ xx <- as.matrix(xx);
+ xx <- offsetsT + xx;
+
+ ats <- xScale * xx;
+ for (cc in seq(length=ncol(xx))) {
+ abline(v=ats[,cc], col=col, lty=lty, ...);
+ }
+
+ invisible(ats);
+}, protected=TRUE) # drawCentromeres()
+
+
+setMethodS3("highlightArmCalls", "CBS", function(fit, genomeData, minFraction=0.95, callCols=c("loss"="red", "gain"="green"), xScale=1e-6, ...) {
+ # To please/trick R CMD check
+ chromosome <- x <- NULL; rm(list=c("chromosome", "x"));
+
+ callStats <- callArms(fit, genomeData=genomeData, minFraction=minFraction);
+
+ callTypes <- grep("Fraction", colnames(callStats), value=TRUE);
+ callTypes <- gsub("Fraction", "", callTypes);
+
+ callTypes <- intersect(callTypes, c("loss", "gain"));
+
+ # Adjust (start, end)
+ offsets <- getChromosomeOffsets(fit);
+ offsets <- offsets[callStats[,"chromosome"]];
+ callStats[,c("start","end")] <- offsets + callStats[,c("start","end")];
+
+ nbrOfRegions <- nrow(callStats);
+
+ # Nothing todo?
+ if (nbrOfRegions == 0) {
+ return(invisible(callStats));
+ }
+
+
+ usr <- par("usr");
+ dy <- diff(usr[3:4]);
+ yy <- usr[3]+c(0,0.05*dy);
+ abline(h=usr[3]+0.95*0.05*dy, lty=1, col="gray");
+
+ xx <- callStats[,c("start", "end")];
+ xx <- as.matrix(xx);
+ xx <- xx * xScale;
+
+ for (type in callTypes) {
+ col <- callCols[type];
+ keyA <- sprintf("%sFraction", type);
+ keyB <- sprintf("%sCall", type);
+ for (kk in seq(length=nbrOfRegions)) {
+ xs <- xx[kk,];
+ score <- callStats[kk, keyA];
+ if (is.finite(score) && score > 0) {
+ ys <- rep(yy[1]+callStats[kk, keyA]*0.05*dy, times=2);
+ lines(x=xs, y=ys, col=col);
+ call <- callStats[kk, keyB];
+ if (call) {
+ rect(xs[1], yy[1], xs[2], yy[2], col=col, border=NA);
+ }
+ }
+ }
+ } # for (type ...)
+
+ invisible(callStats);
+}, protected=TRUE); # highlightArmCalls()
+
+
+
+############################################################################
+# HISTORY:
+# 2013-11-23
+# o Added "dummy" 'byIndex' argument to drawLevels() for CBS to avoid
+# that argument being passed down lines().
+# 2013-10-14
+# o Now plotTracks() for CBS gives a more informative error if 'Clim'
+# is invalid or "auto" and could not be inferred due to an unknown
+# or unset signal type.
+# 2013-04-18
+# o Now drawLevels() also works for multiple chromosomes.
+# 2011-12-06
+# o Now plotTracks() for CBS always returns an invisible object.
+# 2011-12-03
+# o Added drawChangePoints() for CBS.
+# 2011-10-23
+# o BUG FIX: highlightArmCalls() for CBS did not handle empty chromosomes.
+# 2011-10-08
+# o Added drawChromosomes() for CBS.
+# 2011-10-07
+# o Added highlightArmCalls() for CBS.
+# 2011-10-06
+# o Now drawCentromeres() for CBS can also plot start and stop.
+# o ROBUSTNESS: Now plotTracksManyChromosomes() extract (start,end)
+# information by names (no longer assuming certain indices).
+# 2011-09-07
+# o Added highlightLocusCalls().
+# 2011-09-06
+# o Added highlightCalls().
+# o Added getChromosomeOffsets().
+# 2011-09-01
+# o BUG FIX: plotTracksManyChromosomes() for CBS gave an error because
+# internal variable 'CT' was not defined.
+# o BUG FIX: tileChromosomes() for CBS not identify the chromosomes of
+# the loci, and hence generated corrupt/missing values while tiling.
+# 2010-11-19
+# o Created from PairedPSCBS.R.
+############################################################################
diff --git a/R/CBS.PRUNE.R b/R/CBS.PRUNE.R
new file mode 100644
index 0000000..8aa45a8
--- /dev/null
+++ b/R/CBS.PRUNE.R
@@ -0,0 +1,230 @@
+###########################################################################/**
+# @set "class=CBS"
+# @RdocMethod pruneBySdUndo
+#
+# @title "Prune the CBS profile by dropping change points that are too small"
+#
+# \description{
+# @get "title", where "too small" means that the amplitude of the
+# change points is less than a multiple of the overall standard deviation
+# of the copy-number signals.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{fit}{A @see "CBS" object.}
+# \item{rho}{A positive @double scalar specifying the number of standard
+# deviations (\code{rho*sigma}) required in order to keep a change point.
+# More change points are dropped the greater this value is.}
+# \item{sigma}{The whole-genome standard deviation of the locus-level
+# copy number signals. The default is to calculate it from the data
+# and as done in the \pkg{DNAcopy} package.}
+# \item{...}{(Optional) Additional arguments passed to the standard
+# deviation estimator function.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns a @see "CBS" object (of the same class as \code{fit}).
+# }
+#
+# \details{
+# This method corresponds to using the \code{undo} argument when calling
+# @see "segmentByCBS", which in turn corresponds to using the
+# \code{undo.splits="sdundo"} and \code{undo.SD} of the underlying
+# @see "DNAcopy::segment" method.
+# }
+#
+# @examples "../incl/segmentByCBS,pruneBySdUndo.Rex"
+#
+# @author "HB, PN"
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("pruneBySdUndo", "CBS", function(fit, rho=3, sigma="DNAcopy", ..., verbose=FALSE) {
+ # Local copies of DNAcopy functions
+ DNAcopy_changepoints.sdundo <- .use("changepoints.sdundo", package="DNAcopy");
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'rho':
+ rho <- Arguments$getDouble(rho, range=c(0,Inf));
+
+ # Argument 'sigma':
+ if (is.character(sigma)) {
+ sigma <- estimateStandardDeviation(fit, method=sigma, ...);
+ }
+ sigma <- Arguments$getDouble(sigma, range=c(0,Inf), disallow=c("NA", "NaN", "Inf"));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Pruning segments by standard deviation");
+
+ # Check if locus weights are available
+ data <- getLocusData(fit);
+ hasWeights <- !is.null(data$w);
+ # Not needed anymore
+ data <- NULL;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Prune chromosome by chromosome
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ chromosomes <- getChromosomes(fit);
+ nbrOfChromosomes <- length(chromosomes);
+
+ fitList <- vector("list", length=nbrOfChromosomes);
+ for (cc in seq(length=nbrOfChromosomes)) {
+ chr <- chromosomes[cc];
+ verbose && enter(verbose, sprintf("Chromosome #%d ('Chr%s') of %d",
+ cc, chr, length(chromosomes)));
+
+ # Extract this chromosome
+ fitT <- extractChromosome(fit, chromosome=chr);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Get segmentation data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fitT);
+ segs <- getSegments(fitT);
+ segRows <- fitT$segRows;
+ nbrOfSegs <- nrow(segRows);
+ verbose && cat(verbose, "Number of segments (before): ", nbrOfSegs);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Drop missing values
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ y <- data$y;
+
+ # Label data points by their segment index
+ segId <- rep(NA_integer_, times=max(segRows[,2], na.rm=TRUE));
+ for (rr in 1:nbrOfSegs) {
+ segRow <- unlist(segRows[rr,], use.names=FALSE);
+ idxs <- segRow[1]:segRow[2];
+ segId[idxs] <- rr;
+ }
+
+ # Drop missing value
+ keep <- !is.na(y);
+ if (hasWeights) {
+ w <- data$w;
+ keep <- keep & !is.na(w);
+ }
+ units <- which(keep);
+ y <- y[units];
+ segId <- segId[units];
+ if (hasWeights) {
+ w <- w[units];
+ }
+
+ # Update 'segRows' accordingly
+ for (rr in 1:nbrOfSegs) {
+ startStop <- range(which(segId == rr));
+ segRows[rr,1] <- startStop[1];
+ segRows[rr,2] <- startStop[2];
+ }
+ # Not needed anymore
+ segId <- startStop <- NULL;
+
+ # Sanity check
+ stopifnot(max(segRows[,2]) <= length(y));
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Prune change points
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ segLengths <- segRows[,2] - segRows[,1] + 1L;
+ segLengthsP <- DNAcopy_changepoints.sdundo(genomdat=y,
+ lseg=segLengths, trimmed.SD=sigma, change.SD=rho);
+ segLengthsP <- as.integer(segLengthsP);
+ nbrOfSegsP <- length(segLengthsP);
+ verbose && cat(verbose, "Number of segments (after): ", nbrOfSegsP);
+
+ nbrOfPrunedSegs <- nbrOfSegs-nbrOfSegsP;
+ verbose && cat(verbose, "Number of segments dropped: ", nbrOfPrunedSegs);
+
+ # No segments pruned?
+ if (nbrOfPrunedSegs == 0) {
+ # Sanity check
+ stopifnot(identical(segLengthsP, segLengths));
+
+ fitList[[cc]] <- fitT;
+ verbose && cat(verbose, "Nothing to changed. Skipping.");
+# verbose && exit(verbose);
+# next;
+ }
+
+ # Setup new 'segRows'
+ endRow <- cumsum(segLengthsP);
+ n <- length(endRow);
+ segRowsP <- data.frame(startRow=c(1L, endRow[-n]+1L), endRow=endRow);
+
+
+ # Expand to units with also missing values
+ segRowsP[,1] <- units[segRowsP[,1]];
+ segRowsP[,2] <- units[segRowsP[,2]];
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Create stub for a segment table
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ idxs <- seq(length=nbrOfSegsP);
+ segsP <- segs[idxs,];
+
+ # Sanity checks
+ if (nbrOfPrunedSegs == 0) {
+ segRows <- fitT$segRows;
+ stopifnot(all.equal(segRowsP, segRows, check.attributes=FALSE));
+ stopifnot(all.equal(segsP, segs, check.attributes=FALSE));
+ }
+
+ fitT$output <- segsP;
+ fitT$segRows <- segRowsP;
+
+ fitList[[cc]] <- fitT;
+
+ verbose && exit(verbose);
+ } # for (cc ...)
+
+ fitP <- Reduce(append, fitList);
+
+ verbose && enter(verbose, "Updating segment means and boundaries");
+ fitP <- updateBoundaries(fitP, verbose=less(verbose, 50));
+ fitP <- updateMeans(fitP, verbose=less(verbose, 50));
+ verbose && exit(verbose);
+
+ nbrOfSegs <- nbrOfSegments(fit);
+ nbrOfSegsP <- nbrOfSegments(fitP);
+ nbrOfPrunedSegs <- nbrOfSegs-nbrOfSegsP;
+ verbose && cat(verbose, "Number of segments (before): ", nbrOfSegs);
+ verbose && cat(verbose, "Number of segments (after): ", nbrOfSegsP);
+ verbose && cat(verbose, "Number of segments dropped: ", nbrOfPrunedSegs);
+
+ verbose && exit(verbose);
+
+ fitP;
+}) # pruneBySdUndo()
+
+
+setMethodS3("seqOfSegmentsByDP", "CBS", function(fit, by=c("y"), ...) {
+ NextMethod("seqOfSegmentsByDP", by=by);
+})
+
+
+############################################################################
+# HISTORY:
+# 2012-09-13
+# o Added seqOfSegmentsByDP() for CBS.
+# 2011-12-06
+# o BUG FIX: pruneBySdUndo() for CBS did not work with more than one array.
+# 2011-11-16
+# o Added Rdoc comments.
+# 2011-11-15
+# o Added pruneBySdUndo() for CBS.
+# o Created.
+############################################################################
diff --git a/R/CBS.R b/R/CBS.R
new file mode 100644
index 0000000..5fc5840
--- /dev/null
+++ b/R/CBS.R
@@ -0,0 +1,710 @@
+###########################################################################/**
+# @RdocClass CBS
+#
+# @title "The CBS class"
+#
+# \description{
+# A CBS object holds results from the
+# Circular Binary Segmentation (CBS) method
+# for \emph{one} sample for one or more chromosomes.
+#
+# @classhierarchy
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Arguments passed to the constructor of @see "AbstractCBS".}
+# }
+#
+# \section{Fields and Methods}{
+# @allmethods "public"
+# }
+#
+# \section{Difference to DNAcopy object}{
+# A CBS object is similar to DNAcopy objects with the major
+# difference that a CBS object holds only one sample, whereas
+# a DNAcopy object can hold more than one sample.
+# }
+#
+# \section{See also}{
+# The @see "segmentByCBS" method returns an object of this class.
+# }
+#
+# @author "HB"
+#*/###########################################################################
+setConstructorS3("CBS", function(...) {
+ extend(AbstractCBS(list(data=NULL, output=NULL), ...), "CBS");
+})
+
+
+setMethodS3("all.equal", "CBS", function(target, current, check.attributes=FALSE, ...) {
+ # Compare class attributes
+ res <- all.equal(class(target), class(current));
+ if (!isTRUE(res)) {
+ return(res);
+ }
+
+ # WORKAROUND: segmentByCBS() return getSegments(fit)$id without NA:s for
+ # splitters, unless append() is used.
+ # TO DO: Fix segmentByCBS() /HB 2011-10-08
+ segs <- getSegments(target);
+ if (nrow(segs) > 0) {
+ isSplitter <- isSegmentSplitter(target);
+ segs[isSplitter, "sampleName"] <- NA;
+ target$output <- segs;
+ }
+
+ segs <- getSegments(current);
+ if (nrow(segs) > 0) {
+ isSplitter <- isSegmentSplitter(current);
+ segs[isSplitter, "sampleName"] <- NA;
+ current$output <- segs;
+ }
+
+ # NOTE: Here arguments 'target' and 'current' are lists and does not
+ # have to be passed explicitly (although they have been modified).
+ # If passed explicity, note that they must be named *and* that the
+ # first/dispatch argument have to be passed as 'object=target'
+ # (and never as 'target=target'). /HB 2014-02-03
+ NextMethod("all.equal", object=target, current=current, check.attributes=check.attributes);
+}, protected=TRUE)
+
+
+
+###########################################################################/**
+# @RdocMethod as.data.frame
+#
+# @title "Gets the table of segments"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns a @data.frame, where each row corresponds to
+# a unique segment.
+# }
+#
+# @author
+#
+# \seealso{
+# Utilizes @seemethod "getSegments".
+# @seeclass.
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("as.character", "CBS", function(x, ...) {
+ # To please R CMD check
+ fit <- x;
+
+ s <- sprintf("%s:", class(fit)[1]);
+
+ s <- c(s, sprintf("Sample name: %s", getSampleName(fit)));
+
+ s <- c(s, sprintf("Signal type: %s", getSignalType(fit)));
+
+ s <- c(s, sprintf("Number of segments: %d", nbrOfSegments(fit)));
+
+ s <- c(s, sprintf("Number of loci: %d", nbrOfLoci(fit)));
+
+ n <- getSegments(fit)$nbrOfLoci;
+ q <- quantile(n, probs=c(0.00, 0.05, 0.25, 0.50, 0.75, 0.95, 1.00), na.rm=TRUE);
+ qs <- sprintf("%g [%s]", q, names(q));
+ s <- c(s, sprintf("Number of loci per segment: %s", paste(qs, collapse=", ")));
+
+ chrs <- getChromosomes(fit);
+ s <- c(s, sprintf("Chromosomes: [%d] %s", length(chrs), hpaste(chrs)));
+
+ s <- c(s, sprintf("Standard deviation: %g", estimateStandardDeviation(fit)));
+
+ tt <- grep("Call$", colnames(getLocusData(fit)), value=TRUE);
+ s <- c(s, sprintf("Locus calls: [%d] %s", length(tt), hpaste(tt)));
+
+ segs <- getSegments(fit);
+ callCols <- grep("Call$", colnames(segs), value=TRUE);
+ callTypes <- gsub("Call$", "", callCols);
+ s <- c(s, sprintf("Types of segment calls: [%d] %s", length(callTypes), hpaste(callTypes)));
+ for (kk in seq(along=callCols)) {
+ key <- callCols[kk];
+ type <- callTypes[kk];
+ n <- sum(segs[,key], na.rm=TRUE);
+ if (type == "loss") {
+ nC <- sum(isWholeChromosomeLost(fit));
+ } else if (type == "gain") {
+ nC <- sum(isWholeChromosomeGained(fit));
+ } else {
+ nC <- NA;
+ }
+ s <- c(s, sprintf("Number of chromosomes (segments) called '%s': %d (%d)", type, nC, n));
+ }
+
+ GenericSummary(s);
+}, protected=TRUE)
+
+
+setMethodS3("as.data.frame", "CBS", function(x, ...) {
+ getSegments(x, splitter=FALSE, ...);
+}, protected=TRUE)
+
+
+setMethodS3("getSignalType", "CBS", function(fit, ...) {
+ type <- fit$signalType;
+ if (is.null(type)) type <- as.character(NA);
+ type;
+}, protected=TRUE)
+
+
+setMethodS3("signalType", "CBS", function(fit, ...) {
+ getSignalType(fit);
+}, protected=TRUE)
+
+
+"signalType<-" <- function(x, value) {
+ UseMethod("signalType<-");
+}
+
+setMethodS3("signalType<-", "CBS", function(x, value) {
+ fit <- x;
+
+ # Argument 'value':
+ value <- Arguments$getCharacter(value);
+
+ fit$signalType <- value;
+ fit;
+}, private=TRUE, addVarArgs=FALSE)
+
+
+
+setMethodS3("getLocusSignalNames", "CBS", function(fit, ...) {
+ data <- fit$data;
+ names <- colnames(data);
+ if (is.element("y", names)) {
+ return("y");
+ } else if (is.element("CT", names)) {
+ return("CT");
+ }
+
+ throw("INTERNAL ERROR: Unknown locus signal names: ", paste(names, collapse=", "));
+}, protected=TRUE)
+
+setMethodS3("getSegmentTrackPrefixes", "CBS", function(fit, ...) {
+ c("");
+}, protected=TRUE)
+
+
+setMethodS3("getLocusData", "CBS", function(fit, indices=NULL, addCalls=NULL, ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'indices':
+ if (!is.null(indices)) {
+ indices <- Arguments$getIndices(indices);
+ }
+
+ # Argument 'addCalls':
+ if (is.logical(addCalls)) {
+ addCalls <- Arguments$getLogical(addCalls);
+ if (!addCalls) {
+ addCalls <- NULL;
+ }
+ } else {
+ addCalls <- Arguments$getCharacters(addCalls);
+ }
+
+ data <- fit$data;
+
+ # Append segment calls?
+ if (length(addCalls) > 0) {
+ callsL <- extractCallsByLocus(fit);
+ if (is.character(addCalls)) {
+ callsL <- callsL[,addCalls];
+ }
+
+ # Sanity check
+ stopifnot(nrow(callsL) == nrow(data));
+
+ data <- cbind(data, callsL);
+ }
+
+ # Return requested indices
+ if (!is.null(indices)) {
+ # Map of final indices to current indices
+ map <- match(indices, data$index);
+
+ # Extract/expand...
+ data <- data[map,];
+ rownames(data) <- NULL;
+
+ # Sanity check
+ stopifnot(nrow(data) == length(indices));
+ }
+
+ data;
+}, private=TRUE) # getLocusData()
+
+
+setMethodS3("isSegmentSplitter", "CBS", function(fit, ...) {
+ segs <- fit$output;
+
+ isSplitter <- lapply(segs[-1], FUN=is.na);
+ isSplitter <- Reduce("&", isSplitter);
+
+ isSplitter;
+}, protected=TRUE)
+
+
+setMethodS3("getSegments", "CBS", function(fit, simplify=FALSE, splitters=TRUE, addGaps=FALSE, ...) {
+ # Argument 'splitters':
+ splitters <- Arguments$getLogical(splitters);
+
+ segs <- fit$output;
+
+ isSplitter <- isSegmentSplitter(fit);
+
+ # Add 'sampleName' column?
+ if (nrow(segs) > 0) {
+ sampleName <- rep(getSampleName(fit), times=nrow(segs));
+ sampleName[isSplitter] <- as.character(NA);
+ if (!is.element("sampleName", colnames(segs))) {
+ segs <- cbind(sampleName=I(sampleName), segs);
+ } else {
+ segs[,"sampleName"] <- sampleName;
+ }
+ }
+
+ # Drop chromosome splitters?
+ if (!splitters) {
+ segs <- segs[!isSplitter,];
+ }
+
+ # Add splitters for "gaps"...
+ if (splitters && addGaps) {
+ # Chromosome gaps
+ n <- nrow(segs);
+ chrs <- segs$chromosome;
+ gapsAfter <- which(diff(chrs) != 0L);
+ gapsAfter <- gapsAfter[!is.na(chrs[gapsAfter])];
+ nGaps <- length(gapsAfter);
+ if (nGaps > 0L) {
+ idxs <- seq(length=n);
+ values <- rep(NA_integer_, times=nGaps);
+ idxs <- insert(idxs, at=gapsAfter+1L, values=values);
+ segs <- segs[idxs,];
+ }
+
+ # Other gaps
+ n <- nrow(segs);
+ chrs <- segs$chromosome;
+ starts <- segs$tcnStart[-1L];
+ ends <- segs$tcnEnd[-n];
+ gapsAfter <- which(starts != ends);
+ onSameChr <- (chrs[gapsAfter+1L] == chrs[gapsAfter] );
+ gapsAfter <- gapsAfter[onSameChr];
+ nGaps <- length(gapsAfter);
+ if (nGaps > 0L) {
+ idxs <- seq(length=n);
+ values <- rep(NA_integer_, times=nGaps);
+ idxs <- insert(idxs, at=gapsAfter+1L, values=values);
+ segs <- segs[idxs,];
+ }
+ }
+
+ segs;
+}, private=TRUE)
+
+
+
+setMethodS3("getChangePoints", "CBS", function(fit, ...) {
+ # Already available?
+ cps <- fit$changepoints;
+ if (!is.null(cps)) return(cps);
+
+ segs <- getSegments(fit, splitters=TRUE);
+ tcn <- segs[["mean"]];
+ n <- length(tcn);
+
+ # Calculate observed (d) data
+ D <- tcn[-n] - tcn[-1L];
+ cps <- data.frame(
+ d = D
+ );
+
+ cps;
+}, private=TRUE) # getChangePoints()
+
+
+
+setMethodS3("updateBoundaries", "CBS", function(fit, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Updating boundaries");
+ verbose && cat(verbose, "Number of segments: ",
+ nbrOfSegments(fit, splitters=FALSE));
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract the data and segmentation results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fit);
+ segs <- getSegments(fit, splitters=TRUE);
+ segRows <- fit$segRows;
+
+ nbrOfSegments <- nrow(segs);
+ chromosome <- data$chromosome;
+ x <- data$x;
+ y <- data$y;
+ w <- data$w;
+ hasWeights <- !is.null(w);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Update segments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ for (ss in seq(length=nbrOfSegments)) {
+ verbose && enter(verbose, sprintf("Segment %d of %d", ss, nbrOfSegments));
+ segRow <- segRows[ss,];
+ seg <- segs[ss,];
+
+ # A splitter - nothing todo?
+ if (is.na(segRow[[1]]) && is.na(segRow[[2]])) {
+ next;
+ }
+
+ # (a) Identify units (loci)
+ units <- segRow[[1]]:segRow[[2]];
+ verbose && cat(verbose, "Loci:");
+ verbose && str(verbose, units);
+
+ # (b) Extract signals
+ ySS <- y[units];
+ xSS <- x[units];
+ cSS <- chromosome[units];
+ if (hasWeights) {
+ wSS <- w[units];
+ }
+
+ # (c) Drop missing values
+ keep <- (!is.na(ySS) & !is.na(xSS) & !is.na(cSS));
+ if (hasWeights) {
+ keep <- keep & (!is.na(wSS) & wSS > 0);
+ }
+ keep <- which(keep);
+ ySS <- ySS[keep];
+ xSS <- xSS[keep];
+ cSS <- cSS[keep];
+ if (hasWeights) {
+ wSS <- wSS[keep];
+ }
+ units <- units[keep];
+ verbose && cat(verbose, "Loci (non-missing):");
+ verbose && str(verbose, units);
+
+ # (d) Identify (chromosome, start, stop)
+ stopifnot(all(cSS == cSS[1]));
+ cSS <- cSS[1];
+ xRange <- range(xSS, na.rm=TRUE);
+ verbose && cat(verbose, "Range:");
+ verbose && print(verbose, xRange);
+
+ # (e) Update segment information
+ seg$chromosome <- cSS;
+ seg$start <- xRange[1];
+ seg$end <- xRange[2];
+
+ segs[ss,] <- seg;
+
+ verbose && exit(verbose);
+ } # for (ss ...)
+
+ # Update results
+ res <- fit;
+ res$output <- segs;
+
+ # Rejoin segments?
+ if (isTRUE(res$params$joinSegments)) {
+ res <- joinSegments(res, verbose=less(verbose,10));
+ }
+
+ verbose && exit(verbose);
+
+ res;
+}, protected=TRUE) # updateBoundaries()
+
+
+
+setMethodS3("updateMeans", "CBS", function(fit, ..., avg=c("asis", "mean", "median"), verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'avg':
+ avg <- match.arg(avg);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Updating mean level estimates");
+ verbose && cat(verbose, "Number of segments: ",
+ nbrOfSegments(fit, splitters=FALSE));
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract the data and segmentation results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fit);
+ segs <- getSegments(fit, splitters=TRUE);
+ segRows <- fit$segRows;
+
+ nbrOfSegments <- nrow(segs);
+ chromosome <- data$chromosome;
+ x <- data$x;
+ y <- data$y;
+ w <- data$w;
+ hasWeights <- !is.null(w);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setting up averaging functions
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (avg == "asis") {
+ est <- fit$params$meanEstimators;
+ avg <- est$y;
+ if (is.null(avg)) avg <- "mean";
+ avg <- match.arg(avg);
+ }
+
+ if (hasWeights) {
+ if(avg == "mean") {
+ avgFUN <- weighted.mean;
+ } else if(avg == "median") {
+ avgFUN <- weightedMedian;
+ } else {
+ throw("Value of argument 'avg' is not supported with weights: ", avg);
+ }
+ } else {
+ avgFUN <- get(avg, mode="function");
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Update segments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ for (ss in seq(length=nbrOfSegments)) {
+ verbose && enter(verbose, sprintf("Segment %d of %d", ss, nbrOfSegments));
+ segRow <- segRows[ss,];
+ seg <- segs[ss,];
+
+ # A splitter - nothing todo?
+ if (!is.finite(segRow[[1]]) || !is.finite(segRow[[2]])) {
+ next;
+ }
+
+ # (a) Identify units (loci)
+ units <- segRow[[1]]:segRow[[2]];
+
+ # (b) Extract signals
+ ySS <- y[units];
+ if (hasWeights) {
+ wSS <- w[units];
+ }
+
+ # (c) Drop missing values
+ keep <- (!is.na(ySS));
+ if (hasWeights) {
+ keep <- keep & (!is.na(wSS) & wSS > 0);
+ }
+ keep <- which(keep);
+ ySS <- ySS[keep];
+ if (hasWeights) {
+ wSS <- wSS[keep];
+ }
+ units <- units[keep];
+ nbrOfLoci <- length(units);
+
+ # (d) Update mean
+ if (hasWeights) {
+ wSS <- wSS / sum(wSS);
+ gamma <- avgFUN(ySS, w=wSS);
+ } else {
+ gamma <- avgFUN(ySS);
+ }
+
+ # Sanity check
+ stopifnot(nbrOfLoci == 0 || !is.na(gamma));
+
+ # (d) Update the segment statistics
+ seg$mean <- gamma;
+ seg$nbrOfLoci <- nbrOfLoci;
+
+ segs[ss,] <- seg;
+
+ verbose && exit(verbose);
+ } # for (ss ...)
+
+ # Return results
+ res <- fit;
+ res$output <- segs;
+ res <- setMeanEstimators(res, y=avg);
+
+ verbose && exit(verbose);
+
+ res;
+}, protected=TRUE) # updateMeans()
+
+
+setMethodS3("resegment", "CBS", function(fit, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Resegmenting a ", class(fit)[1], " object");
+ segFcnName <- "segmentByCBS";
+ segFcn <- getMethodS3(segFcnName, "default");
+
+ # Use the locus-level data of the segmentation object
+ data <- getLocusData(fit);
+ class(data) <- "data.frame";
+ drop <- c("index");
+ keep <- !is.element(colnames(data), drop);
+ data <- data[,keep];
+ verbose && str(verbose, data);
+
+ verbose && cat(verbose, "Number of loci: ", nrow(data));
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setup arguments to be passed
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Overriding default arguments");
+
+ # (a) The default arguments
+ formals <- formals(segFcn);
+
+ formals <- formals[!sapply(formals, FUN=is.language)];
+ formals <- formals[!sapply(formals, FUN=is.name)];
+ drop <- c("chromosome", "x", "y", "w", "...");
+ keep <- !is.element(names(formals), drop);
+ formals <- formals[keep];
+
+ # (b) The arguments used in previous fit
+ params <- fit$params;
+ keep <- is.element(names(params), names(formals));
+ params <- params[keep];
+
+ # (c) The arguments in '...'
+ userArgs <- list(..., verbose=verbose);
+
+ # (d) Merge
+ args <- formals;
+ args2 <- append(params, userArgs);
+ for (kk in seq(along=args2)) {
+ value <- args2[[kk]];
+ if (!is.null(value)) {
+ key <- names(args2)[kk];
+ if (!is.null(key)) {
+ args[[key]] <- value;
+ } else {
+ args <- append(args, list(value));
+ }
+ }
+ } # for (key ...)
+ verbose && str(verbose, args[names(args) != "verbose"]);
+
+ args <- append(list(data), args);
+ verbose && cat(verbose, "Arguments with data:");
+ verbose && str(verbose, args[names(args) != "verbose"]);
+ verbose && exit(verbose);
+
+ verbose && enter(verbose, sprintf("Calling %s()", segFcnName));
+ fit <- do.call(segFcnName, args);
+ verbose && exit(verbose);
+
+ verbose && exit(verbose);
+
+ fit;
+}, protected=TRUE) # resegment()
+
+
+############################################################################
+# HISTORY:
+# 2014-02-03
+# o BUG FIX: all.equal() for CBS would pass the first/dispatch argument
+# to NextMethod() as 'target=target' and not as 'object=target', which
+# would result in it being passed it twice both named and non-named
+# where the latter would become argument 'tolerance=target' in an
+# internal call to all.equal() for numerics. In recent R-devel version
+# this would generate "Error in all.equal.numeric(target[[i]],
+# current[[i]], check.attributes = check.attributes, : 'tolerance'
+# should be numeric Calls: stopifnot ... all.equal.default ->
+# all.equal.list -> all.equal -> all.equal.numeric".
+# 2013-12-17
+# o BUG FIX: getChangePoints() for CBS returned empty results.
+# 2013-10-20
+# o Added getChangePoints() for CBS.
+# 2012-09-21
+# o Now getSegments(..., splitters=TRUE) for CBS and PSCBS inserts NA
+# rows whereever there is a "gap" between segments. A "gap" is when
+# two segments are not connected (zero distance).
+# 2012-06-03
+# o BUG FIX: all.equal(target, current) for CBS objects would give an
+# error if either 'target' or 'current' had zero segments.
+# 2011-12-12
+# o Added optional argument 'indices' to getLocusData() to be able
+# to retrieve the locus-level data as indexed by input data.
+# 2011-11-17
+# o Added resegment() for CBS for easy resegmentation.
+# 2011-11-15
+# o Now updateMeans() uses locus-specific weights, iff available.
+# o Added updateBoundaries() for CBS to update (start,stop) per segment.
+# o CORRECTNESS: Now updateMeans() for CBS identify loci by the internal
+# 'segRows' field and no longer by locations of segment boundaries,
+# which gave slightly incorrect estimates for "tied" loci.
+# 2011-10-16
+# o Added isSegmentSplitter().
+# 2011-10-08
+# o Relabelled column 'id' to 'sampleName' returned by getSegments().
+# o BUG FIX: getSegments() for CBS would not set 'id' for "splitter" rows.
+# o Added mergeTwoSegments() for CBS.
+# o Added updateMeans() for CBS.
+# o Added all.equal() for CBS.
+# 2011-10-02
+# o CLEANUP: Moved getChromosomes(), nbrOfChromosomes(), nbrOfSegments(),
+# nbrOfLoci() and print() to AbstractCBS.
+# o Now the CBS class extends the AbstractCBS class.
+# 2011-09-04
+# o Added getSignalType() for CBS.
+# o Added argument 'addCalls' to getLocusData().
+# o Added getSampleName() for CBS.
+# 2011-09-03
+# o Added print() and as.character() for CBS.
+# o Added CBS() constructor. Although it rairly will be used
+# it we be a place holder for the documentation.
+# 2011-09-02
+# o Added nbrOfLoci(), nbrOfSegments(), nbrOfChromosomes() and
+# getChromosomes() for CBS.
+# 2010-11-19
+# o Added append() for CBS objects.
+############################################################################
diff --git a/R/CBS.RESTRUCT.R b/R/CBS.RESTRUCT.R
new file mode 100644
index 0000000..c894aa5
--- /dev/null
+++ b/R/CBS.RESTRUCT.R
@@ -0,0 +1,393 @@
+setMethodS3("shiftTCN", "CBS", function(fit, shift, update=TRUE, ...) {
+ # Argument 'shift':
+ shift <- Arguments$getDouble(shift, disallow=c("NA", "NaN", "Inf"));
+
+ data <- getLocusData(fit);
+ data$y <- data$y + shift;
+ fit$data <- data;
+ # Not needed anymore
+ data <- NULL;
+
+ if (update) {
+ fit <- updateMeans(fit, ...);
+ }
+
+ fit;
+}, protected=TRUE)
+
+
+###########################################################################/**
+# @set "class=CBS"
+# @RdocMethod append
+#
+# @title "Appends one segmentation result to another"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{x, other}{The two @see "CBS" objects to be combined.}
+# \item{other}{A @see "PSCBS" object.}
+# \item{addSplit}{If @TRUE, a "divider" is added between chromosomes.}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns a @see "CBS" object of the same class as argument \code{x}.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("append", "CBS", function(x, other, addSplit=TRUE, ...) {
+ # To please R CMD check
+ this <- x;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'other':
+ other <- Arguments$getInstanceOf(other, class(this)[1]);
+ for (field in c("data", "output")) {
+ dataA <- this[[field]]
+ dataB <- other[[field]]
+ namesA <- colnames(dataA)
+ namesB <- colnames(dataB)
+ if (!all(namesA == namesB)) {
+ throw(sprintf("Cannot merge %s objects. Arguments 'other' and 'this' has different sets of columns in field '%s': {%s} [n=%d] != {%s} [n=%d]", class(this)[1], field, paste(namesA, collapse=", "), length(namesA), paste(namesB, collapse=", "), length(namesB)))
+ }
+ }
+
+ # Argument 'addSplit':
+ addSplit <- Arguments$getLogical(addSplit);
+
+
+ # Allocate results
+ res <- this;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Locus data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(this);
+ res$data <- rbind(data, getLocusData(other));
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Segmentation data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ indexOffset <- nrow(data);
+ fields <- c("output", "segRows");
+ for (field in fields[-1]) {
+ other[[field]] <- other[[field]] + indexOffset;
+ }
+
+ splitter <- if (addSplit) NA else NULL;
+ for (field in fields) {
+ res[[field]] <- rbind(this[[field]], splitter, other[[field]]);
+ rownames(res[[field]]) <- NULL;
+ }
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Parameters
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ksT <- this$params$knownSegments;
+ ksT$length <- NULL; # In case it's been added
+ ksO <- other$params$knownSegments;
+ ksO$length <- NULL; # In case it's been added
+ res$params$knownSegments <- rbind(ksT, ksO);
+
+
+ # Sanity check
+ ns <- sapply(res[fields], FUN=nrow);
+ stopifnot(all(ns == ns[1]));
+
+ res;
+}) # append()
+
+
+
+setMethodS3("extractSegments", "CBS", function(this, idxs, ..., verbose=FALSE) {
+ fit <- this;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Local functions
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ updateSegRows <- function(segRows, idxs=NULL) {
+ verbose && str(verbose, segRows);
+ if (!is.null(idxs)) {
+ segRows <- segRows[idxs,,drop=FALSE];
+ }
+# verbose && cat(verbose, "Number of segments: ", nrow(segRows));
+# verbose && str(verbose, segRows);
+
+ # Treat splitters separately
+ isSplitter <- (is.na(segRows[,1]) & is.na(segRows[,2]));
+
+ ns <- segRows[,2] - segRows[,1] + 1L;
+# verbose && cat(verbose, "Number of loci per segment:");
+# verbose && str(verbose, ns);
+
+ ns <- ns[!isSplitter];
+ from <- c(1L, cumsum(ns)[-length(ns)]+1L);
+ to <- from + (ns - 1L);
+ segRows[!isSplitter,1] <- from;
+ segRows[!isSplitter,2] <- to;
+ verbose && str(verbose, segRows);
+
+ # Sanity check
+ ns2 <- segRows[,2] - segRows[,1] + 1L;
+ ns2 <- ns2[!isSplitter];
+ stopifnot(all(ns2 == ns));
+
+ segRows;
+ } # updateSegRows()
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'idxs':
+ idxs <- Arguments$getIndices(idxs, max=nbrOfSegments(fit, splitters=TRUE));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Extracting subset of segments");
+
+ verbose && cat(verbose, "Number of segments: ", length(idxs));
+ verbose && str(verbose, idxs);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract data and estimates
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fit);
+ segRows <- fit$segRows;
+ segs <- getSegments(fit);
+ params <- fit$params;
+
+ # Sanity checks
+ stopifnot(all(!is.na(data$chromosome) & !is.na(data$x)));
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Subset segments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Update table of segments");
+ segsT <- segs[idxs,,drop=FALSE];
+ verbose && str(verbose, segsT);
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Subset data accordingly
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Update locus data");
+
+ segRowsT <- segRows[idxs,,drop=FALSE];
+ from <- segRowsT[[1]];
+ to <- segRowsT[[2]];
+ ok <- (!is.na(from) & !is.na(to));
+ from <- from[ok];
+ to <- to[ok];
+ keep <- logical(nrow(data));
+ for (rr in seq(along=from)) {
+ keep[from[rr]:to[rr]] <- TRUE;
+ }
+ keep <- which(keep);
+ verbose && printf(verbose, "Identified %d (%.2f%%) of %d data rows:\n", length(keep), 100*length(keep)/nrow(data), nrow(data));
+ verbose && str(verbose, keep);
+
+ dataT <- data[keep,,drop=FALSE];
+ verbose && str(verbose, dataT);
+
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Update 'segRows'
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Update 'segRows'");
+ segRowsT <- updateSegRows(segRowsT);
+ d <- segRows[idxs,] - segRowsT;
+
+ # Sanity check
+ stopifnot(identical(d[,1], d[,2]));
+ d <- d[,1];
+ verbose && cat(verbose, "Row deltas:");
+ verbose && str(verbose, d);
+
+ segRows <- segRows[idxs,,drop=FALSE] - d;
+ verbose && str(verbose, segRows);
+ # Sanity checks
+ stopifnot(suppressWarnings(max(segRows, na.rm=TRUE)) <= nrow(dataT));
+ drow <- segRows[-1,1] - segRows[-nrow(segRows),2];
+ stopifnot(all(is.na(drow) | (drow > 0)));
+ if (!all(is.na(drow) | (drow > 0))) {
+ print(segRows);
+ throw("INTERNAL ERROR: Generated 'segRows' is invalid, because it contains overlapping data chunks.");
+ }
+
+ verbose && exit(verbose);
+
+
+ # Create new object
+ res <- fit;
+ res$data <- dataT;
+ res$output <- segsT;
+ res$segRows <- segRows;
+
+ verbose && exit(verbose);
+
+ res;
+}, protected=TRUE) # extractSegments()
+
+
+
+setMethodS3("mergeTwoSegments", "CBS", function(this, left, update=TRUE, verbose=FALSE, ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ nbrOfSegments <- nbrOfSegments(this, splitters=TRUE);
+ # Argument 'left':
+ left <- Arguments$getIndex(left, max=nbrOfSegments-1L);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Merging two segments");
+ verbose && printf(verbose, "Segments to be merged: %s & %s\n", left, left+1);
+ verbose && cat(verbose, "Number of segments before merging: ", nbrOfSegments);
+ verbose && cat(verbose, "Number of segments after merging: ", nbrOfSegments-1L);
+
+ segs <- getSegments(this);
+ segRows <- this$segRows;
+
+ rows <- c(left,left+1);
+ segsT <- segs[rows,,drop=FALSE];
+
+ # Sanity check
+ chrs <- segsT[["chromosome"]];
+ if (chrs[1] != chrs[2]) {
+ throw("Cannot merge segments that are on different chromosomes: ", chrs[1], " != ", chrs[2]);
+ }
+
+ # Merge segments
+ segT <- segsT[1,];
+ fields <- colnames(segsT);
+ idxsUsed <- c();
+
+ # (id) [as in label]
+ idxs <- grep("(I|i)d$", fields);
+ idxsUsed <- c(idxsUsed, idxs);
+
+ # (chromosome)
+ idxs <- grep("chromosome$", fields);
+ idxsUsed <- c(idxsUsed, idxs);
+
+ # Starts
+ idxs <- grep("(S|s)tart$", fields);
+ T <- as.matrix(segsT[,idxs,drop=FALSE]);
+ segT[,idxs] <- colMins(T, na.rm=TRUE);
+ idxsUsed <- c(idxsUsed, idxs);
+
+ # Ends
+ idxs <- grep("(E|e)nd$", fields);
+ T <- as.matrix(segsT[,idxs,drop=FALSE]);
+ segT[,idxs] <- colMaxs(T, na.rm=TRUE);
+ idxsUsed <- c(idxsUsed, idxs);
+
+ # Counts
+ idxs <- grep("(N|n)brOf", fields);
+ segT[,idxs] <- colSums(segsT[,idxs,drop=FALSE]);
+ idxsUsed <- c(idxsUsed, idxs);
+
+ # "Invalidate" remaining entries
+ idxsTodo <- setdiff(seq(along=fields), idxsUsed);
+ segT[,idxsTodo] <- NA;
+
+ # Update segment table
+ segs[rows[1],] <- segT;
+ segs <- segs[-rows[2],];
+
+ # Update 'segRows' tables
+ segRows[rows[1],2] <- segRows[rows[2],2];
+ segRows <- segRows[-rows[2],];
+
+ # Create results object
+ res <- this;
+ res$output <- segs;
+ res$segRows <- segRows;
+
+ # Update the segment statistics?
+ if (update) {
+ res <- updateMeans(res);
+ }
+
+ verbose && exit(verbose);
+
+ res;
+}, protected=TRUE) # mergeTwoSegments()
+
+
+
+############################################################################
+# HISTORY:
+# 2012-09-13
+# o Added shiftTCN() for CBS.
+# 2012-02-24
+# o ROBUSTNESS: Added more sanity checks validating the correctness of
+# what is returned by extractSegments() for CBS.
+# 2011-11-17
+# o BUG FIX: extractSegments() for CBS would throw an error when
+# there were multiple chromosomes.
+# 2011-11-15
+# o BUG FIX: extractSegments() for CBS would throw an error, because in
+# most cases it would created a corrupt internal 'segRows' field.
+# 2011-10-20
+# o Now append() for CBS also appends '...$params$knownSegments'.
+# 2011-10-16
+# o Added argument 'update' to mergeTwoSegments().
+# 2011-10-10
+# o Replaced extractRegions() with extractSegments() for CBS.
+# o Added extractRegions() for CBS.
+# 2011-10-08
+# o Relabelled column 'id' to 'sampleName' returned by getSegments().
+# o BUG FIX: getSegments() for CBS would not set 'id' for "splitter" rows.
+# o Added mergeTwoSegments() for CBS.
+# o Added updateMeans() for CBS.
+# o Added all.equal() for CBS.
+# 2011-10-02
+# o CLEANUP: Moved getChromosomes(), nbrOfChromosomes(), nbrOfSegments(),
+# nbrOfLoci() and print() to AbstractCBS.
+# o Now the CBS class extends the AbstractCBS class.
+# 2011-09-04
+# o Added writeSegments() for CBS.
+# o Added writeLocusData() for CBS.
+# o Added getSignalType() for CBS.
+# o Added argument 'addCalls' to getLocusData().
+# o Added getSampleName() for CBS.
+# 2011-09-03
+# o Added print() and as.character() for CBS.
+# o Added CBS() constructor. Although it rairly will be used
+# it we be a place holder for the documentation.
+# 2011-09-02
+# o Added nbrOfLoci(), nbrOfSegments(), nbrOfChromosomes() and
+# getChromosomes() for CBS.
+# 2010-11-19
+# o Added append() for CBS objects.
+############################################################################
diff --git a/R/CBS.SMOOTH.R b/R/CBS.SMOOTH.R
new file mode 100644
index 0000000..7b9c475
--- /dev/null
+++ b/R/CBS.SMOOTH.R
@@ -0,0 +1,71 @@
+###########################################################################/**
+# @set class=CBS
+# @RdocMethod getSmoothLocusData
+#
+# @title "Gets smoothed locus-level data"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{fit}{An @see "CBS" object.}
+# \item{by}{A @numeric scalar specifying the bin size.}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns a @data.frame where the
+# first three columns are 'chromosome', 'x' (position),
+# and 'count' (number of loci average over for the given bin),
+# and the remaining ones are the smoothed locus-level data.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# @seeclass
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("getSmoothLocusData", "CBS", function(fit, by, ...) {
+ # Argument 'by':
+ by <- Arguments$getNumeric(by, range=c(0,Inf));
+
+ chromosomes <- getChromosomes(fit);
+ data <- getLocusData(fit);
+
+ chromosome <- NULL; rm(list="chromosome"); # To please R CMD check
+
+ dataS <- NULL;
+ for (kk in seq_along(chromosomes)) {
+ chr <- chromosomes[kk];
+ dataT <- subset(data, chromosome == chr);
+ x <- dataT$x;
+ y <- dataT$y;
+ rx <- range(x, na.rm=TRUE);
+ bx <- seq(from=rx[1], to=rx[2], by=by);
+ xS <- bx[-1] - by/2;
+ yS <- binMeans(y=y, x=x, bx=bx);
+ count <- attr(yS, "count");
+ yS[count == 0L] <- NA_real_;
+ attr(yS, "count") <- NULL;
+ dataTS <- data.frame(chromosome=chr, x=xS, count=count, y=yS);
+ dataS <- rbind(dataS, dataTS);
+ } # for (kk ...)
+
+ dataS;
+}, protected=TRUE) # getSmoothLocusData()
+
+
+############################################################################
+# HISTORY:
+# 2013-10-09
+# o Now getSmoothLocusData() for CBS also returns column 'count'.
+# 2013-04-18
+# o Added getSmoothLocusData() for CBS.
+# o Created.
+############################################################################
diff --git a/R/CBS.joinSegments.R b/R/CBS.joinSegments.R
new file mode 100644
index 0000000..9a60024
--- /dev/null
+++ b/R/CBS.joinSegments.R
@@ -0,0 +1,181 @@
+###########################################################################/**
+# @set "class=CBS"
+# @RdocMethod joinSegments
+#
+# @title "Joins neighboring segments such that there is no gap in between them"
+#
+# \description{
+# @get "title".
+# For instance, consider two neighboring segments [x1,x2] and [x3,x4]
+# with x1 < x2 < x3 < x4. After join the segments, they are
+# [x1,x23] and [x23,x4] where x23 = (x2 + x3)/2.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{range}{(optional) A @numeric @vector of length two.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns an updated @see "CBS" object.
+# }
+#
+# \details{
+# This function assumes only chromosome exists.
+# If more, an error will be thrown.
+# }
+#
+# @author "HB"
+#
+# @keyword IO
+# @keyword internal
+#*/###########################################################################
+setMethodS3("joinSegments", "CBS", function(fit, range=NULL, verbose=FALSE, ...) {
+ R_SANITY_CHECK <- TRUE;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ chromosomes <- getChromosomes(fit)
+ nbrOfChrs <- length(chromosomes)
+
+ # Argument 'range':
+ if (!is.null(range)) {
+ if (nbrOfChrs > 1L) {
+ throw("Argument 'range' cannot be given when 'fit' contains multiple chromosomes.")
+ }
+ range <- Arguments$getDoubles(range, length=c(2,2));
+ stopifnot(range[2] >= range[1]);
+ }
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Joining segments");
+ segs <- getSegments(fit, splitters=TRUE);
+ verbose && cat(verbose, "Segments:");
+ verbose && print(verbose, segs);
+ verbose && cat(verbose, "Chromosomes:")
+ verbose && print(verbose, chromosomes)
+ verbose && cat(verbose, "Range:");
+ verbose && print(verbose, range);
+
+ nbrOfSegs <- nrow(segs);
+ if (nbrOfSegs > 1) {
+ verbose && enter(verbose, "Centering change points");
+ prevSeg <- segs[1L,];
+ for (ss in 2:nbrOfSegs) {
+ currSeg <- segs[ss,];
+
+ ## New chromosome?
+ if (!identical(currSeg$chromosome, prevSeg$chromosome)) {
+ ## Skip splitters
+ if (is.na(currSeg$chromosome)) next
+ prevSeg <- currSeg
+ next
+ }
+
+ currStart <- currSeg[,"start"];
+ prevEnd <- prevSeg[,"end"];
+
+ # Sanity check (will give an error if more than one chromosome)
+ if (R_SANITY_CHECK) {
+ stopifnot(all(currStart >= prevEnd, na.rm=TRUE));
+ }
+
+ # Center CP
+ xMid <- (prevEnd + currStart) / 2;
+
+ # Move previous end and current start to this centered CP
+ segs[ss,"start"] <- xMid;
+ segs[ss-1L,"end"] <- xMid;
+
+ prevSeg <- currSeg;
+ } # for (ss ...)
+ verbose && exit(verbose);
+
+ # Sanity checks
+ if (R_SANITY_CHECK) {
+ stopifnot(all(segs$start[-1] >= segs$end[-nbrOfSegs], na.rm=TRUE));
+ stopifnot(all(diff(segs$start) >= 0, na.rm=TRUE)); ## FIXME: > 0
+ stopifnot(all(diff(segs$end) >= 0, na.rm=TRUE)); ## FIXME: > 0
+ } # if (R_SANITY_CHECK)
+
+ if (nbrOfSegs > 6) {
+ verbose && print(verbose, head(segs));
+ verbose && print(verbose, tail(segs));
+ } else {
+ verbose && print(verbose, segs);
+ }
+ } # if (nbrOfSegs > 1)
+
+
+ if (!is.null(range)) {
+ verbose && enter(verbose, "Adjust for 'range'");
+ verbose && cat(verbose, "Range:");
+ verbose && print(verbose, range);
+ xMin <- min(range, na.rm=TRUE);
+ xMax <- max(range, na.rm=TRUE);
+ if (nbrOfSegs > 0) {
+ # Sanity checks
+ if (R_SANITY_CHECK) {
+ stopifnot(xMin <= segs[1L,"start"]);
+ stopifnot(segs[1L,"end"] <= xMax);
+ }
+ segs[1L,"start"] <- xMin;
+ segs[nbrOfSegs,"end"] <- xMax;
+
+ # Sanity checks
+ if (R_SANITY_CHECK) {
+ stopifnot(all(segs$start[-1] >= segs$end[-nbrOfSegs], na.rm=TRUE));
+ stopifnot(all(diff(segs$start) >= 0, na.rm=TRUE)); ## FIXME: > 0
+ stopifnot(all(diff(segs$end) >= 0, na.rm=TRUE)); ## FIXME: > 0
+ }
+
+ if (nbrOfSegs > 6) {
+ verbose && print(verbose, head(segs));
+ verbose && print(verbose, tail(segs));
+ } else {
+ verbose && print(verbose, segs);
+ }
+ } # if (nbrOfSegs > 0)
+ verbose && exit(verbose);
+ } # if (!is.null(range))
+
+ fit <- setSegments(fit, segs, splitters=TRUE);
+
+ segs <- getSegments(fit, splitters=FALSE);
+ if (nbrOfSegs > 6) {
+ verbose && print(verbose, head(segs));
+ verbose && print(verbose, tail(segs));
+ } else {
+ verbose && print(verbose, segs);
+ }
+ verbose && exit(verbose);
+
+ fit;
+}, private=TRUE) # joinSegments()
+
+
+############################################################################
+# HISTORY:
+# 2013-11-14
+# o DOCUMENTATION: Added Rd help for joinSegments().
+# o CLEANUP: Removed stray variables.
+# 2011-11-17
+# o Added more sanity checks to joinSegments().
+# 2011-09-04
+# o Updated joinSegments() to be aware of new column names in CBS.
+# 2011-06-14
+# o Updated code to recognize new column names.
+# 2010-11-21
+# o Extracted from segmentByPairedPSCBS.R
+############################################################################
diff --git a/R/CBS.updateMeansTogether.R b/R/CBS.updateMeansTogether.R
new file mode 100644
index 0000000..2a5c378
--- /dev/null
+++ b/R/CBS.updateMeansTogether.R
@@ -0,0 +1,100 @@
+setMethodS3("updateMeansTogether", "CBS", function(fit, idxList, ..., avg=c("mean", "median"), verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ nbrOfSegments <- nbrOfSegments(fit, splitters=TRUE);
+
+ # Argument 'idxList':
+ if (!is.list(idxList)) {
+ idxList <- list(idxList);
+ }
+ idxList <- lapply(idxList, FUN=function(idxs) {
+ idxs <- Arguments$getIndices(idxs, max=nbrOfSegments);
+ sort(unique(idxs));
+ });
+
+ # Argument 'avg':
+ avg <- match.arg(avg);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Updating mean level estimates of multiple segments");
+
+ verbose && cat(verbose, "Segments:");
+ verbose && str(verbose, idxList);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setting up averaging functions
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ avgFUN <- get(avg, mode="function");
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract the data and segmentation results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fit);
+
+ segs <- getSegments(fit, splitters=TRUE);
+
+ nbrOfSegments <- nrow(segs);
+ verbose && cat(verbose, "Total number of segments: ", nbrOfSegments);
+
+ for (ss in seq(along=idxList)) {
+ idxs <- idxList[[ss]];
+
+ fitT <- extractSegments(fit, idxs);
+ verbose && cat(verbose, "Number of segments: ", nbrOfSegments(fitT));
+
+ dataT <- getLocusData(fitT);
+ segsT <- getSegments(fitT);
+
+ y <- dataT$y;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Update the TCN segments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Recalculate TCN means");
+
+ # (c) Adjust for missing values
+ keep <- which(!is.na(y));
+
+ # (d) Update mean
+ gamma <- avgFUN(y[keep]);
+
+ # Sanity check
+ stopifnot(length(gamma) == 0 || !is.na(gamma));
+
+ mus <- c(mean=gamma);
+
+ verbose && print(verbose, mus);
+ verbose && exit(verbose);
+
+ for (key in names(mus)) {
+ segs[idxs,key] <- mus[key];
+ }
+ } # for (ss ...)
+
+ # Return results
+ res <- fit;
+ res$output <- segs;
+ res <- setMeanEstimators(res, y=avg);
+
+ verbose && exit(verbose);
+
+ res;
+}, private=TRUE) # updateMeansTogether()
+
+
+
+############################################################################
+# HISTORY:
+# 2011-11-28
+# o Added updateMeansTogether() for CBS.
+# o Created from PairedPSCBS.updateMeansTogether.R.
+############################################################################
diff --git a/R/CNA.EXTS.R b/R/CNA.EXTS.R
new file mode 100644
index 0000000..11da494
--- /dev/null
+++ b/R/CNA.EXTS.R
@@ -0,0 +1,26 @@
+setMethodS3("segmentByCBS", "CNA", function(y, ...) {
+ # To please R CMD check
+ cnData <- y;
+
+ # Extract signals of interest
+ chromosome <- cnData$chrom;
+ x <- cnData$maploc;
+ y <- cnData[,3];
+ signalType <- attr(cnData, "data.type");
+ sampleName <- colnames(cnData)[3];
+
+# str(list(y=y, chromosome=chromosome, x=x));
+
+ fit <- segmentByCBS(y=y, chromosome=chromosome, x=x, ...);
+ sampleName(fit) <- sampleName;
+
+ fit;
+}) # segmentByCBS()
+
+
+#############################################################################
+# HISTORY:
+# 2011-09-04
+# o Added segmentByCBS for CNA objects.
+# o Created.
+#############################################################################
diff --git a/R/DNAcopy.EXTS.R b/R/DNAcopy.EXTS.R
new file mode 100644
index 0000000..da7a724
--- /dev/null
+++ b/R/DNAcopy.EXTS.R
@@ -0,0 +1,279 @@
+###########################################################################/**
+# @set class=CBS
+# @RdocMethod as.DNAcopy
+#
+# @title "Coerces a CBS object to a DNAcopy object"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{fit}{A @see "CBS" object."}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns a @see "DNAcopy" object (of the \pkg{DNAcopy} package).
+# }
+#
+# \examples{
+# @include "../incl/segmentByCBS.Rex"
+# @include "../incl/as.DNAcopy.Rex"
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# \code{\link[PSCBS:as.CBS.DNAcopy]{as.CBS()}}.
+# @seeclass
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("as.DNAcopy", "CBS", function(fit, ...) {
+ sampleName <- getSampleName(fit);
+ if (is.na(sampleName)) sampleName <- "<NA>";
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setup the 'data' field
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fit);
+
+ # Keep only certain columns
+ keep <- match(c("chromosome", "x"), colnames(data));
+ keep <- c(keep, 3L);
+ data <- data[,keep,drop=FALSE];
+
+ # Sanity check
+ stopifnot(ncol(data) == 3);
+
+ # Rename column names
+ colnames(data) <- c("chrom", "maploc", sampleName);
+
+ class(data) <- c("CNA", "data.frame");
+ attr(data, "data.type") <- "logratio";
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setup the 'output' field
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ output <- getSegments(fit, splitter=FALSE);
+ rownames <- rownames(output);
+
+ output <- data.frame(
+ ID = sampleName,
+ chrom = output$chromosome,
+ loc.start = output$start,
+ loc.end = output$end,
+ num.mark = output$nbrOfLoci,
+ seg.mean = output$mean,
+ stringsAsFactors=FALSE
+ );
+ rownames(output) <- rownames;
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setup up 'DNAcopy' object
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ res <- list();
+ res$data <- data;
+ res$output <- output;
+ res$call <- NA;
+ class(res) <- "DNAcopy";
+
+ res;
+}, protected=TRUE) # as.DNAcopy()
+
+
+
+setMethodS3("nbrOfSegments", "DNAcopy", function(fit, ...) {
+ segs <- fit$output;
+ nrow(segs);
+})
+
+setMethodS3("nbrOfLoci", "DNAcopy", function(fit, ...) {
+ nrow(fit$data);
+})
+
+setMethodS3("nbrOfSamples", "DNAcopy", function(fit, ...) {
+ length(getSampleNames(fit, ...));
+})
+
+setMethodS3("getSampleNames", "DNAcopy", function(fit, ...) {
+ names <- colnames(fit$data);
+ names <- setdiff(names, c("chrom", "maploc"));
+ names;
+})
+
+setMethodS3("getChromosomes", "DNAcopy", function(fit, ...) {
+ chromosomes <- fit$data$chrom;
+ sort(unique(chromosomes));
+})
+
+
+setMethodS3("estimateStandardDeviation", "DNAcopy", function(fit, sample=1L, method=c("diff", "abs", "res"), estimator=c("mad", "sd"), na.rm=TRUE, weights=NULL, ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'sample':
+ sample <- Arguments$getIndex(sample, max=nbrOfSamples(fit));
+
+ # Argument 'method':
+ method <- match.arg(method);
+
+ # Argument 'estimator':
+ estimator <- match.arg(estimator);
+
+
+
+ nbrOfLoci <- nbrOfLoci(fit);
+
+ # Argument 'weights':
+ if (!is.null(weights)) {
+ weights <- Arguments$getNumerics(weights, range=c(0,Inf), length=rep(nbrOfLoci, times=2));
+ }
+
+
+ # Nothing to do?
+ if (nbrOfLoci <= 1) {
+ return(NA_real_);
+ }
+
+ # Get the estimator function
+ if (!is.null(weights)) {
+ estimator <- sprintf("weighted %s", estimator);
+ estimator <- R.utils::toCamelCase(estimator);
+ }
+ estimatorFcn <- get(estimator, mode="function");
+
+
+ # Extract sample of interest
+ fit <- subset(fit, samplelist=sample);
+
+ y <- fit$data[,3L];
+
+ if (method == "diff") {
+ y <- diff(y);
+
+ # Weighted estimator?
+ if (!is.null(weights)) {
+ # Calculate weights per pair
+ weights <- (weights[1:(nbrOfLoci-1)]+weights[2:nbrOfLoci])/2;
+ sigma <- estimatorFcn(y, w=weights, na.rm=na.rm)/sqrt(2);
+ } else {
+ sigma <- estimatorFcn(y, na.rm=na.rm)/sqrt(2);
+ }
+ } else if (method == "abs") {
+ if (!is.null(weights)) {
+ sigma <- estimatorFcn(y, w=weights, na.rm=na.rm);
+ } else {
+ sigma <- estimatorFcn(y, na.rm=na.rm);
+ }
+ } else if (method == "res") {
+ yS <- extractSegmentMeansByLocus(fit);
+ dy <- y - yS;
+ if (!is.null(weights)) {
+ sigma <- estimatorFcn(dy, w=weights, na.rm=na.rm);
+ } else {
+ sigma <- estimatorFcn(dy, na.rm=na.rm);
+ }
+ } else {
+ throw("Method no implemented: ", method);
+ }
+
+ sigma;
+}) # estimateStandardDeviation()
+
+
+setMethodS3("extractSegmentMeansByLocus", "DNAcopy", function(fit, sample=1L, ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'FUN':
+ FUN <- match.arg(FUN);
+ FUN <- get(FUN, mode="function");
+
+ # Argument 'sample':
+ sample <- Arguments$getIndex(sample, max=nbrOfSamples(fit));
+
+ # Extract sample of interest
+ fit <- subset(fit, samplelist=sample);
+
+ data <- fit$data;
+ chr <- data$chrom;
+ x <- data$maploc;
+ y <- data[,sample,drop=TRUE];
+
+ segs <- fit$output;
+ nbrOfSegments <- nrow(segs);
+ nbrOfLoci <- nbrOfLoci(fit);
+
+ # Get mean estimators
+ estList <- getMeanEstimators(fit, "y");
+ avgY <- estList$y;
+
+ yS <- y;
+ for (ss in seq(length=nbrOfSegments)) {
+ seg <- segs[ss,];
+ idxs <- which(seg$chrom == chr & seg$loc.start <= x & x <= seg$loc.end);
+ idxs <- Arguments$getIndices(idxs, max=nbrOfLoci);
+
+ ySS <- y[idxs];
+ ok <- is.finite(ySS);
+ # Sanity check
+ ## stopifnot(sum(ok) == seg$num.mark); # Not dealing with ties
+ mu <- avgY(ySS[ok]);
+ yS[idxs] <- mu;
+ } # for (ss ...)
+
+ yS;
+}, private=TRUE) # extractSegmentMeansByLocus()
+
+
+
+setMethodS3("writeSegments", "DNAcopy", function(fit, samples=seq(length=nbrOfSamples(fit)), ...) {
+ # Argument 'samples':
+ samples <- Arguments$getIndices(samples, max=nbrOfSamples(fit));
+
+ pathnames <- c();
+ for (ii in samples) {
+ fitII <- as.CBS(fit, sample=ii);
+ pathnameII <- writeSegments(fitII, ...);
+ pathnames <- c(pathnames, pathnameII);
+ } # for (ii ...)
+
+ pathnames;
+}) # writeSegments()
+
+
+############################################################################
+# HISTORY:
+# 2012-05-30
+# o Added writeSegments() for DNAcopy objects.
+# 2011-09-04
+# o as.DNAcopy() did not drop "splitters" for the segment table.
+# 2011-09-03
+# o Added as.DNAcopy() for CBS to coerce a CBS object to a DNAcopy object.
+# 2011-09-02
+# o Added internal extractSegmentMeansByLocus() for DNAcopy, which is
+# used by estimateStandardDeviation(..., method="res").
+# o Added estimateStandardDeviation() for DNAcopy.
+# o ROBUSTNESS: Now getSampleNames() drops columns 'chrom' and 'maploc',
+# instead of assuming their positions.
+# o ROBUSTNESS: Now nbrOfSamples() utilizes getSampleNames().
+# o Added nbrOfSegments(), nbrOfLoci(), nbrOfSamples(), getSampleNames()
+# and getChromosomes() for DNAcopy.
+# HISTORY FROM PRIVATE SCRIPTS:
+# 2011-07-20
+# o Added support for estimateStandardDeviation(..., method="res").
+# o Added extractSegmentMeansByLocus().
+# 2011-07-18
+# o Added getSampleNames().
+# o Added plotTracks() for DNAcopy.
+# o Added nbrOfSegments(), nbrOfLoci() and nbrOfSamples().
+# 2011-07-17
+# o Added estimateStandardDeviation() to DNAcopy objects.
+############################################################################
diff --git a/R/NonPairedPSCBS.R b/R/NonPairedPSCBS.R
new file mode 100644
index 0000000..0c865c7
--- /dev/null
+++ b/R/NonPairedPSCBS.R
@@ -0,0 +1,389 @@
+###########################################################################/**
+# @RdocClass NonPairedPSCBS
+#
+# @title "The NonPairedPSCBS class"
+#
+# \description{
+# @classhierarchy
+#
+# A NonPairedPSCBS is an object containing the results from the
+# Non-paired PSCBS method.
+# }
+#
+# \usage{NonPairedPSCBS(fit=list(), ...)}
+#
+# \arguments{
+# \item{fit}{A @list structure containing the Non-paired PSCBS results.}
+# \item{...}{Not used.}
+# }
+#
+# \section{Fields and Methods}{
+# @allmethods "public"
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# The @see "segmentByNonPairedPSCBS" method returns an object of this class.
+# }
+#*/###########################################################################
+setConstructorS3("NonPairedPSCBS", function(fit=list(), ...) {
+ # Argument 'fit':
+ if (!is.list(fit)) {
+ throw("Argument 'fit' is not a list: ", class(fit)[1]);
+ }
+
+ extend(PSCBS(fit=fit, ...), "NonPairedPSCBS");
+})
+
+
+setMethodS3("getLocusData", "NonPairedPSCBS", function(fit, ..., fields=c("asis", "full")) {
+ # Argument 'fields':
+ fields <- match.arg(fields);
+
+
+ data <- NextMethod("getLocusData", fields="asis");
+
+
+ if (fields == "full") {
+ names <- colnames(data);
+
+ data$isHet <- (data$muN == 1/2);
+
+ # BACKWARD COMPATIBILITY: If 'rho' does not exists, calculate
+ # it on the fly from 'betaT'.
+ # NOTE: This should give an error in the future. /HB 2013-10-25
+ if (is.null(data$rho)) {
+ data$rho <- 2*abs(data$betaT-1/2);
+ data$rho[!data$isHet] <- NA_real_;
+ warning("Locus-level DH signals ('rho') did not exist and were calculated from tumor BAFs ('betaT')");
+ }
+
+ data$c1 <- 1/2*(1-data$rho)*data$CT;
+ data$c2 <- data$CT - data$c1;
+
+ data$isSNP <- (!is.na(data$betaT) | !is.na(data$muN));
+ data$type <- ifelse(data$isSNP, "SNP", "non-polymorphic locus");
+
+ # Labels
+ data$muNx <- c("AA", "AB", "BB")[2*data$muN + 1L];
+ data$isHetx <- c("AA|BB", "AB")[data$isHet + 1L];
+ }
+
+ data;
+}, protected=TRUE) # getLocusData()
+
+
+setMethodS3("callROH", "NonPairedPSCBS", function(fit, ...) {
+ throw(sprintf("Cannot call ROH from '%s' data.", class(fit)[1L]));
+}, private=TRUE) # callROH()
+
+
+setMethodS3("updateMeans", "NonPairedPSCBS", function(fit, from=c("loci", "segments"), adjustFor=NULL, ..., avgTCN=c("asis", "mean", "median"), avgDH=c("asis", "mean", "median"), verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'from':
+ from <- match.arg(from);
+
+ # Argument 'adjustFor':
+ if (!is.null(adjustFor)) {
+ adjustFor <- Arguments$getCharacters(adjustFor);
+ adjustFor <- tolower(adjustFor);
+ knownValues <- c("ab", "loh", "roh");
+ adjustFor <- match.arg(adjustFor, choices=knownValues, several.ok=TRUE);
+ }
+
+ # Argument 'avgTCN' & 'avgDH':
+ avgTCN <- match.arg(avgTCN);
+ avgDH <- match.arg(avgDH);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Updating mean level estimates");
+ verbose && cat(verbose, "Adjusting for:");
+ verbose && print(verbose, adjustFor);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setting up averaging functions
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (avgTCN == "asis" || avgDH == "asis") {
+ est <- fit$params$meanEstimators;
+ if (avgTCN == "asis") {
+ avgTCN <- est$tcn;
+ if (is.null(avgTCN)) avgTCN <- "mean";
+ avgTCN <- match.arg(avgTCN);
+ }
+ if (avgDH == "asis") {
+ avgDH <- est$dh;
+ if (is.null(avgDH)) avgDH <- "mean";
+ avgDH <- match.arg(avgDH);
+ }
+ }
+
+ avgList <- list(
+ tcn = get(avgTCN, mode="function"),
+ dh = get(avgDH, mode="function")
+ );
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract the segmentation results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ segs <- getSegments(fit, splitters=TRUE);
+ segRows <- list(tcn=fit$tcnSegRows, dh=fit$dhSegRows);
+ nbrOfSegments <- nrow(segs);
+ verbose && cat(verbose, "Number of segments: ", nbrOfSegments);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Assert that adjustments can be made
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (is.element("ab", adjustFor)) {
+ if (!is.element("abCall", names(segs))) {
+ adjustFor <- setdiff(adjustFor, "ab");
+ throw("Cannot adjust for AB, because they haven't been called.");
+ }
+ }
+
+ if (is.element("loh", adjustFor)) {
+ if (!is.element("lohCall", names(segs))) {
+ adjustFor <- setdiff(adjustFor, "loh");
+ throw("Cannot adjust for LOH, because they haven't been called.");
+ }
+ }
+
+ if (is.element("roh", adjustFor)) {
+ if (!is.element("rohCall", names(segs))) {
+ adjustFor <- setdiff(adjustFor, "roh");
+ throw("Cannot adjust for ROH, because they haven't been called.");
+ }
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Update the (TCN,DH) mean levels from locus-level data?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (from == "loci") {
+ data <- getLocusData(fit);
+ chromosome <- data$chromosome;
+ x <- data$x;
+ CT <- data$CT;
+ rho <- data$rho;
+
+ isSplitter <- isSegmentSplitter(fit);
+ for (ss in seq(length=nbrOfSegments)[!isSplitter]) {
+ verbose && enter(verbose, sprintf("Segment %d of %d", ss, nbrOfSegments));
+ seg <- segs[ss,];
+ verbose && print(verbose, seg);
+
+ chr <- seg[["chromosome"]];
+ chrTag <- sprintf("chr%02d", chr);
+
+ for (what in c("tcn", "dh")) {
+ segRow <- segRows[[what]][ss,];
+
+ # (a) A splitter - nothing todo?
+ if (!is.finite(segRow[[1]]) || !is.finite(segRow[[2]])) {
+ next;
+ }
+
+ # (b) Identify units (loci)
+ units <- segRow[[1]]:segRow[[2]];
+
+ # (c) Adjust for missing values
+ if (what == "tcn") {
+ value <- CT;
+ } else if (what == "dh") {
+ value <- rho;
+ }
+ keep <- which(!is.na(value[units]));
+ units <- units[keep];
+
+ # (d) Update mean
+ avgFUN <- avgList[[what]];
+ gamma <- avgFUN(value[units]);
+
+ # Sanity check
+ stopifnot(length(units) == 0 || !is.na(gamma));
+
+ # Update the segment boundaries, estimates and counts
+ key <- paste(what, "Mean", sep="");
+ seg[[key]] <- gamma;
+ }
+
+ verbose && print(verbose, seg);
+
+ segs[ss,] <- seg;
+
+ verbose && exit(verbose);
+ } # for (ss ...)
+ } # if (from ...)
+
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Adjust segment means from various types of calls
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (length(adjustFor) > 0) {
+ verbose && enter(verbose, "Adjusting segment means");
+ verbose && cat(verbose, "Adjusting for:");
+ verbose && print(verbose, adjustFor);
+
+ if (is.element("ab", adjustFor)) {
+ verbose && enter(verbose, "Adjusting for AB");
+ calls <- segs$abCall;
+ segs$dhMean[calls] <- 1/2;
+ verbose && exit(verbose);
+ }
+
+ if (is.element("loh", adjustFor)) {
+ verbose && enter(verbose, "Adjusting for LOH");
+ calls <- segs$lohCall;
+ segs$dhMean[calls] <- 0;
+ verbose && exit(verbose);
+ }
+
+ if (is.element("roh", adjustFor)) {
+ verbose && enter(verbose, "Adjusting for ROH");
+ calls <- segs$rohCall;
+ segs$dhMean[calls] <- NA_real_;
+ verbose && exit(verbose);
+ }
+
+ verbose && exit(verbose);
+ } # if (length(adjustFor) > 0)
+
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Update (C1,C2) mean levels
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Update (C1,C2) per segment");
+ # Append (C1,C2) estimates
+ tcn <- segs$tcnMean;
+ dh <- segs$dhMean;
+ C1 <- 1/2*(1-dh)*tcn;
+ C2 <- tcn - C1;
+ segs$c1Mean <- C1;
+ segs$c2Mean <- C2;
+ verbose && exit(verbose);
+
+
+ # Return results
+ res <- fit;
+ res$output <- segs;
+ res <- setMeanEstimators(res, tcn=avgTCN, dh=avgDH);
+
+ verbose && exit(verbose);
+
+ res;
+}, private=TRUE) # updateMeans()
+
+
+
+setMethodS3("resegment", "NonPairedPSCBS", function(fit, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Resegmenting a ", class(fit)[1], " object");
+
+ # Use the locus-level data of the PairedPSCBS object
+ data <- getLocusData(fit);
+ class(data) <- "data.frame";
+ drop <- c("rho", "betaTN", "index");
+ keep <- !is.element(colnames(data), drop);
+ data <- data[,keep];
+ verbose && str(verbose, data);
+
+ verbose && cat(verbose, "Number of loci: ", nrow(data));
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setup arguments to be passed
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Overriding default arguments");
+ segFcnName <- "segmentByPairedNonPSCBS";
+ segFcn <- getMethodS3(segFcnName, "default");
+
+ # (a) The default arguments
+ formals <- formals(segFcn);
+
+ formals <- formals[!sapply(formals, FUN=is.language)];
+ formals <- formals[!sapply(formals, FUN=is.name)];
+ drop <- c("chromosome", "x", "w", "CT", "betaT", "betaN", "muN", "...");
+ keep <- !is.element(names(formals), drop);
+ formals <- formals[keep];
+
+ # (b) The arguments used in previous fit
+ params <- fit$params;
+ keep <- is.element(names(params), names(formals));
+ params <- params[keep];
+ # Don't trust 'tbn'! TODO. /HB 20111117
+ params$tbn <- NULL;
+
+ # (c) The arguments in '...'
+ userArgs <- list(..., verbose=verbose);
+
+ # (d) Merge
+ args <- formals;
+ args2 <- append(params, userArgs);
+ for (kk in seq(along=args2)) {
+ value <- args2[[kk]];
+ if (!is.null(value)) {
+ key <- names(args2)[kk];
+ if (!is.null(key)) {
+ args[[key]] <- value;
+ } else {
+ args <- append(args, list(value));
+ }
+ }
+ } # for (key ...)
+ verbose && str(verbose, args[names(args) != "verbose"]);
+
+ verbose && enter(verbose, sprintf("Calling %s()", segFcnName));
+ args <- append(list(data), args);
+ verbose && cat(verbose, "Arguments:");
+ verbose && str(verbose, args[names(args) != "verbose"]);
+ verbose && exit(verbose);
+
+ fit <- do.call(segFcnName, args);
+ verbose && exit(verbose);
+
+ verbose && exit(verbose);
+
+ fit;
+}, protected=TRUE) # resegment()
+
+
+
+##############################################################################
+# HISTORY
+# 2013-04-23
+# o BUG FIX: updateMeans() for PairedPSCBS and NonPairedPSCBS could
+# include a signal from a neighboring segment when averaging, iff
+# that signal was located at the exact locus of the change point.
+# 2013-04-09
+# o Added callROH() for NonPairedPSCBS that throws an exception.
+# 2013-03-08
+# o Added getLocusData() for NonPairedPSCBS.
+# 2013-01-15
+# o regsegment() was defined for PairedPSCBS instead of NonPairedPSCBS.
+# 2012-04-21
+# o Created from PairedPSCBS.R.
+##############################################################################
diff --git a/R/PSCBS.IO.R b/R/PSCBS.IO.R
new file mode 100644
index 0000000..8a2186c
--- /dev/null
+++ b/R/PSCBS.IO.R
@@ -0,0 +1,156 @@
+###########################################################################/**
+# @set "class=PSCBS"
+# @RdocMethod writeSegments
+#
+# @title "Writes the table of segments to file"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{name, tags}{Name and optional tags part of the filename}.
+# \item{path}{The directory where the file will be written.}
+# \item{addHeader}{If @TRUE, header comments are written.}
+# \item{createdBy}{A header comment of whom created the file.}
+# \item{splitters}{If @TRUE, each chromosome is separated by a row
+# of missing values.}
+# \item{overwrite, skip}{If an output file already exists, these
+# arguments specifies what should happen.}
+# \item{...}{Additional arguments pass to \code{getSegments()}.}
+# }
+#
+# \value{
+# Returns the pathname of the the file written.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# Utilizes @seemethod "getSegments".
+# @seeclass.
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("writeSegments", "PSCBS", function(fit, name=getSampleName(fit), tags=NULL, ext="tsv", path=NULL, addHeader=TRUE, createdBy=NULL, sep="\t", nbrOfDecimals=4L, splitters=FALSE, overwrite=FALSE, skip=FALSE, ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'name' and 'tags':
+ name <- Arguments$getCharacter(name);
+ tags <- Arguments$getCharacters(tags);
+
+ # Argument 'ext':
+ ext <- Arguments$getCharacter(ext);
+
+ # Arguments 'path':
+ path <- Arguments$getWritablePath(path);
+
+ # Argument 'nbrOfDecimals':
+ nbrOfDecimals <- Arguments$getInteger(nbrOfDecimals);
+
+
+ fullname <- paste(c(name, tags), collapse=",");
+ filename <- sprintf("%s.%s", fullname, ext);
+ pathname <- Arguments$getWritablePathname(filename, path=path, mustNotExist=(!overwrite && !skip));
+
+ # File already exists?
+ if (isFile(pathname)) {
+ # Skip?
+ if (skip) {
+ return(pathname);
+ }
+
+ # Overwrite!
+ file.remove(pathname);
+ }
+
+ # Write to temporary file
+ pathnameT <- pushTemporaryFile(pathname);
+
+
+ sampleName <- getSampleName(fit);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getSegments(fit, ..., splitters=splitters);
+
+ # Round of floating points
+ if (!is.null(nbrOfDecimals)) {
+ cols <- tolower(colnames(data));
+ isInt <- (regexpr("chromosome|start|end|nbrofloci", cols) != -1);
+ cols <- which(isInt);
+ for (cc in cols) {
+ values <- data[[cc]];
+ if (is.double(values)) {
+ values <- round(values, digits=0);
+ data[[cc]] <- values;
+ }
+ } # for (key ...)
+
+ cols <- tolower(colnames(data));
+ isInt <- (regexpr("chromosome|start|end|nbrofloci", cols) != -1);
+ isLog <- (regexpr("call", cols) != -1);
+ isDbl <- (!isInt & !isLog);
+ cols <- which(isDbl);
+ for (kk in cols) {
+ values <- data[[kk]];
+ if (is.double(values)) {
+ values <- round(values, digits=nbrOfDecimals);
+ data[[kk]] <- values;
+ }
+ } # for (key ...)
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Build header
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (addHeader) {
+# sigmaDelta <- estimateStandardDeviation(fit, method="diff");
+ sigmaDelta <- NA;
+# sigmaResiduals <- estimateStandardDeviation(fit, method="res");
+
+ createdOn <- format(Sys.time(), format="%Y-%m-%d %H:%M:%S %Z");
+ hdr <- c(
+ name=name,
+ tags=tags,
+ fullname=fullname,
+ segmentationMethod=sprintf("segment() of %s", attr(fit, "pkgDetails")),
+ nbrOfLoci=nbrOfLoci(fit),
+ nbrOfSegments=nbrOfSegments(fit),
+ joinSegments=fit$params$joinSegments,
+# signalType=getSignalType(fit),
+ sigmaDelta=sprintf("%.4f", sigmaDelta),
+# sigmaResiduals=sprintf("%.4f", sigmaResiduals),
+ createdBy=createdBy,
+ createdOn=createdOn,
+ nbrOfDecimals=nbrOfDecimals,
+ nbrOfColumns=ncol(data),
+ columnNames=paste(colnames(data), collapse=", "),
+ columnClasses=paste(sapply(data, FUN=function(x) class(x)[1]), collapse=", ")
+ );
+ bfr <- paste("# ", names(hdr), ": ", hdr, sep="");
+
+ cat(file=pathnameT, bfr, sep="\n");
+ } # if (addHeader)
+
+ write.table(file=pathnameT, data, append=TRUE, quote=FALSE, sep=sep,
+ row.names=FALSE, col.names=TRUE);
+
+ pathname <- popTemporaryFile(pathnameT);
+
+ pathname;
+}) # writeSegments()
+
+
+
+############################################################################
+# HISTORY:
+# 2011-12-03
+# o Added writeSegments() for PSCBS.
+############################################################################
diff --git a/R/PSCBS.R b/R/PSCBS.R
new file mode 100644
index 0000000..9e27296
--- /dev/null
+++ b/R/PSCBS.R
@@ -0,0 +1,261 @@
+###########################################################################/**
+# @RdocClass PSCBS
+#
+# @title "The PSCBS class"
+#
+# \description{
+# @classhierarchy
+#
+# A PSCBS is an object containing results from parent-specific copy-number
+# (PSCN) segmentation.
+# }
+#
+# \usage{PSCBS(fit=list(), ...)}
+#
+# \arguments{
+# \item{fit}{A @list structure containing the PSCN segmentation results.}
+# \item{...}{Not used.}
+# }
+#
+# \section{Fields and Methods}{
+# @allmethods "public"
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# @see "PairedPSCBS".
+# }
+#*/###########################################################################
+setConstructorS3("PSCBS", function(fit=list(), ...) {
+ # Argument 'fit':
+ if (!is.list(fit)) {
+ throw("Argument 'fit' is not a list: ", class(fit)[1]);
+ }
+
+ extend(AbstractCBS(fit, ...), "PSCBS");
+})
+
+
+setMethodS3("as.data.frame", "PSCBS", function(x, ...) {
+ getSegments(x, splitter=TRUE, ...);
+}, protected=TRUE)
+
+
+setMethodS3("getLocusSignalNames", "PSCBS", function(fit, ...) {
+ c("CT", "rho");
+}, protected=TRUE)
+
+setMethodS3("getSegmentTrackPrefixes", "PSCBS", function(fit, ...) {
+ c("tcn", "dh");
+}, protected=TRUE)
+
+
+setMethodS3("getLocusData", "PSCBS", function(fit, indices=NULL, fields=c("asis"), ...) {
+ # Argument 'indices':
+ if (!is.null(indices)) {
+ indices <- Arguments$getIndices(indices);
+ }
+
+ # Argument 'fields':
+ fields <- match.arg(fields);
+
+ data <- fit$data;
+
+ # Return requested indices
+ if (!is.null(indices)) {
+ # Map of final indices to current indices
+ map <- match(indices, data$index);
+
+ # Extract/expand...
+ data <- data[map,];
+
+ # Sanity check
+ stopifnot(nrow(data) == length(indices));
+ }
+
+ data;
+}, protected=TRUE) # getLocusData()
+
+
+
+setMethodS3("isSegmentSplitter", "PSCBS", function(fit, ...) {
+ segs <- fit$output;
+
+ isSplitter <- lapply(segs[-1], FUN=is.na);
+ isSplitter <- Reduce("&", isSplitter);
+
+ isSplitter;
+}, protected=TRUE)
+
+
+###########################################################################/**
+# @RdocMethod getSegments
+#
+# @title "Gets the segments"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{simplify}{If @TRUE, redundant and intermediate information is dropped.}# \item{splitters}{If @TRUE, "splitters" between chromosomes are
+# preserved, otherwise dropped.}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns a SxK @data.frame, where S in the number of segments,
+# and K is the number of segment-specific fields.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("getSegments", "PSCBS", function(fit, simplify=FALSE, splitters=TRUE, addGaps=FALSE, ...) {
+ # Argument 'splitters':
+ splitters <- Arguments$getLogical(splitters);
+
+ segs <- fit$output;
+
+ # Drop chromosome splitters?
+ if (!splitters) {
+ isSplitter <- isSegmentSplitter(fit);
+ segs <- segs[!isSplitter,];
+ }
+
+ # Add splitters for "gaps"...
+ if (splitters && addGaps) {
+ # Chromosome gaps
+ n <- nrow(segs);
+ chrs <- segs$chromosome;
+ gapsAfter <- which(diff(chrs) != 0L);
+ gapsAfter <- gapsAfter[!is.na(chrs[gapsAfter])];
+ nGaps <- length(gapsAfter);
+ if (nGaps > 0L) {
+ idxs <- seq(length=n);
+ values <- rep(NA_integer_, times=nGaps);
+ idxs <- insert(idxs, at=gapsAfter+1L, values=values);
+ segs <- segs[idxs,];
+ }
+
+ # Other gaps
+ n <- nrow(segs);
+ chrs <- segs$chromosome;
+ starts <- segs$tcnStart[-1L];
+ ends <- segs$tcnEnd[-n];
+ gapsAfter <- which(starts != ends);
+ onSameChr <- (chrs[gapsAfter+1L] == chrs[gapsAfter] );
+ gapsAfter <- gapsAfter[onSameChr];
+ nGaps <- length(gapsAfter);
+ if (nGaps > 0L) {
+ idxs <- seq(length=n);
+ values <- rep(NA_integer_, times=nGaps);
+ idxs <- insert(idxs, at=gapsAfter+1L, values=values);
+ segs <- segs[idxs,];
+ }
+ }
+
+## if (nrow(segs) > 0) {
+## segs$id <- getSampleName(fit);
+## }
+
+ if (simplify) {
+ # If joinSegments was used (i.e. (start,end) are equal for TCN and DH)...
+ if (fit$params$joinSegments) {
+ # Sanity check
+ stopifnot(all(segs$tcnStart == segs$dhStart, na.rm=TRUE));
+ stopifnot(all(segs$tcnEnd == segs$dhEnd, na.rm=TRUE));
+
+ names <- colnames(segs);
+ keep <- !is.element(names, c("dhStart", "dhEnd"));
+ segs <- segs[,keep];
+ names <- colnames(segs);
+ names[names == "tcnStart"] <- "start";
+ names[names == "tcnEnd"] <- "end";
+ colnames(segs) <- names;
+ }
+
+ # Drop bootstrap columns, if any
+ names <- colnames(segs);
+ keep <- (regexpr("_[0-9]+(|[.][0-9]+)%$", names) == -1);
+ segs <- segs[,keep];
+ }
+
+ segs;
+}, private=TRUE)
+
+
+
+setMethodS3("getChangePoints", "PSCBS", function(fit, ...) {
+ # Already available?
+ cps <- fit$changepoints;
+ if (!is.null(cps)) return(cps);
+
+ segs <- getSegments(fit, splitters=TRUE);
+ tcn <- segs[["tcnMean"]];
+ dh <- segs[["dhMean"]];
+ C1 <- (1-dh) * tcn / 2;
+ C2 <- tcn - C1;
+ n <- length(tcn);
+
+ # Calculate observed (alpha, radius, manhattan, dc1, dc2) data
+ D1 <- C1[-n] - C1[-1L];
+ D2 <- C2[-n] - C2[-1L];
+ cps <- data.frame(
+ alpha = atan2(D2, D1), # Changepoint angles in (0,2*pi)
+ radius = sqrt(D2^2 + D1^2),
+ manhattan = abs(D2) + abs(D1),
+ d1 = D1,
+ d2 = D2
+ );
+
+ cps;
+}, private=TRUE) # getChangePoints()
+
+
+
+############################################################################
+# HISTORY:
+# 2013-10-20
+# o Added getChangePoints() for PSCBS.
+# 2012-09-21
+# o Now getSegments(..., splitters=TRUE) for CBS and PSCBS inserts NA
+# rows whereever there is a "gap" between segments. A "gap" is when
+# two segments are not connected (zero distance).
+# 2012-04-21
+# o CLEANUP: Moved getSegmentSizes() from PSCBS to AbstractCBS.
+# 2012-04-21
+# o CLEANUP: Moved getSegmentSizes() from PairedPSCBS to PSCBS.
+# 2012-02-27
+# o Added argument 'fields' to getLocusData() for PairedPSCBS.
+# 2011-12-12
+# o Added optional argument 'indices' to getLocusData() to be able
+# to retrieve the locus-level data as indexed by input data.
+# 2011-12-03
+# o Added argument 'simplify' to getSegments().
+# 2011-10-16
+# o Added isSegmentSplitter().
+# 2011-10-02
+# o Now the CBS class extends the AbstractCBS class.
+# o Added print() and as.data.frame() to PSCBS.
+# o Added getSegments() to PSCBS.
+# o DOCUMENTATION: Added Rdoc for several PSCBS methods.
+# o Added a PSCBS constructor with documentation.
+# 2010-12-01
+# o Now also extractByChromosomes() and append() for PSCBS recognizes
+# fields 'tcnLociToExclude' and 'dhLociToExclude'.
+# o BUG FIX: extractByChromosome() for PSCBS would call it self instead
+# of extractByChromosomes().
+# 2010-11-26
+# o Added extractByChromosomes() for PSCBS.
+# 2010-09-26
+# o getChromosomes() no longer returns NA divers.
+# 2010-09-24
+# o Added append() and more for PSCBS objects.
+############################################################################
diff --git a/R/PSCBS.RESTRUCT.R b/R/PSCBS.RESTRUCT.R
new file mode 100644
index 0000000..2ddddd6
--- /dev/null
+++ b/R/PSCBS.RESTRUCT.R
@@ -0,0 +1,186 @@
+###########################################################################/**
+# @set "class=PSCBS"
+# @RdocMethod append
+#
+# @title "Appends one segmentation result to another"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{x, other}{The two @see "PSCBS" objects to be combined.}
+# \item{other}{A @see "PSCBS" object.}
+# \item{addSplit}{If @TRUE, a "divider" is added between chromosomes.}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns a @see "PSCBS" object of the same class as argument \code{x}.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("append", "PSCBS", function(x, other, addSplit=TRUE, ...) {
+ # To please R CMD check
+ this <- x;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'other':
+ other <- Arguments$getInstanceOf(other, "PSCBS");
+ for (field in c("data", "output")) {
+ dataA <- this[[field]]
+ dataB <- other[[field]]
+ namesA <- colnames(dataA)
+ namesB <- colnames(dataB)
+ if (!all(namesA == namesB)) {
+ throw(sprintf("Cannot merge %s objects. Arguments 'other' and 'this' has different sets of columns in field '%s': {%s} [n=%d] != {%s} [n=%d]", class(this)[1], field, paste(namesA, collapse=", "), length(namesA), paste(namesB, collapse=", "), length(namesB)))
+ }
+ }
+
+ # Argument 'addSplit':
+ addSplit <- Arguments$getLogical(addSplit);
+
+
+ # Allocate results
+ res <- this;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Locus data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ res$data <- rbind(this$data, other$data);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Segmentation data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ indexOffset <- nrow(this$data);
+ fields <- c("output", "tcnSegRows", "dhSegRows");
+ for (field in fields[-1]) {
+ other[[field]] <- other[[field]] + indexOffset;
+ }
+
+ splitter <- if (addSplit) NA else NULL;
+ for (field in fields) {
+ res[[field]] <- rbind(this[[field]], splitter, other[[field]]);
+ rownames(res[[field]]) <- NULL;
+ }
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Parameters
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ksT <- this$params$knownSegments;
+ ksT$length <- NULL; # In case it's been added
+ ksO <- other$params$knownSegments;
+ ksO$length <- NULL; # In case it's been added
+ res$params$knownSegments <- rbind(ksT, ksO);
+
+ # Sanity check
+ ns <- sapply(res[fields], FUN=nrow);
+ stopifnot(all(ns == ns[1]));
+
+ res;
+}) # append()
+
+
+setMethodS3("extractChromosomes", "PSCBS", function(x, chromosomes, ...) {
+ # To please R CMD check
+ this <- x;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'chromosomes':
+ disallow <- c("NaN", "Inf");
+ chromosomes <- Arguments$getIntegers(chromosomes, range=c(0,Inf), disallow=disallow);
+ stopifnot(all(is.element(chromosomes, getChromosomes(this))));
+
+ # Always extract in order
+ chromosomes <- unique(chromosomes);
+ chromosomes <- sort(chromosomes);
+
+ # Allocate results
+ res <- this;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Locus data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ chromosome <- NULL; rm(list="chromosome"); # To please R CMD check
+ res$data <- subset(res$data, chromosome %in% chromosomes);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Segmentation data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Identify rows to subset
+ rows <- which(is.element(res$output$chromosome, chromosomes));
+ for (field in c("output", "tcnSegRows", "dhSegRows")) {
+ res[[field]] <- res[[field]][rows,,drop=FALSE];
+ }
+
+ # Identify chromosome offsets
+ chrStarts <- match(getChromosomes(this), this$data$chromosome);
+ chrEnds <- c(chrStarts[-1]-1L, nrow(this$data));
+ chrLengths <- chrEnds - chrStarts + 1L;
+
+ chrLengthsExcl <- chrLengths;
+
+ keep <- match(chromosomes, getChromosomes(this));
+ chrLengthsExcl[keep] <- 0L;
+ cumChrLengthsExcl <- cumsum(chrLengthsExcl);
+
+ shifts <- cumChrLengthsExcl[keep];
+ stopifnot(all(is.finite(shifts)));
+
+ # Adjust indices
+ for (cc in seq(along=chromosomes)) {
+ chromosome <- chromosomes[cc];
+ shift <- shifts[cc];
+ # Nothing to do?
+ if (shift == 0) next;
+ for (field in c("tcnSegRows", "dhSegRows")) {
+ segRows <- res[[field]];
+ rows <- which(res$output$chromosome == chromosome);
+ segRows[rows,] <- segRows[rows,] - shift;
+ res[[field]] <- segRows;
+ }
+ }
+
+ res;
+}, protected=TRUE)
+
+
+
+############################################################################
+# HISTORY:
+# 2012-09-21
+# o ROBUSTNESS: Now append() for CBS and PSCBS drops column 'length'
+# from 'knownSegments', iff it exists.
+# 2011-10-20
+# o Now append() for PSCBS also appends '...$params$knownSegments'.
+# 2011-10-02
+# o Now the CBS class extends the AbstractCBS class.
+# o Added print() and as.data.frame() to PSCBS.
+# o Added getSegments() to PSCBS.
+# o DOCUMENTATION: Added Rdoc for several PSCBS methods.
+# o Added a PSCBS constructor with documentation.
+# 2010-12-01
+# o Now also extractByChromosomes() and append() for PSCBS recognizes
+# fields 'tcnLociToExclude' and 'dhLociToExclude'.
+# o BUG FIX: extractByChromosome() for PSCBS would call it self instead
+# of extractByChromosomes().
+# 2010-11-26
+# o Added extractByChromosomes() for PSCBS.
+# 2010-09-26
+# o getChromosomes() no longer returns NA divers.
+# 2010-09-24
+# o Added append() and more for PSCBS objects.
+############################################################################
diff --git a/R/PairedPSCBS.BOOT.R b/R/PairedPSCBS.BOOT.R
new file mode 100644
index 0000000..054d156
--- /dev/null
+++ b/R/PairedPSCBS.BOOT.R
@@ -0,0 +1,1055 @@
+###########################################################################/**
+# @set class=PairedPSCBS
+# @RdocMethod bootstrapTCNandDHByRegion
+#
+# @title "Estimate confidence intervals of TCN and DH segment levels"
+#
+# \description{
+# @get "title" using bootstrap.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{B}{A postive @integer specifying the number of bootstrap samples.}
+# \item{boot}{Alternatively, to generating \code{B} bootstrap samples,
+# this specifies a pre-generated set of bootstrap samples as
+# returned by \code{bootstrapSegmentsAndChangepoints()}.}
+# \item{...}{Additional arguments passed to \code{bootstrapSegmentsAndChangepoints()}.}
+# \item{probs}{The default quantiles to be estimated.}
+# \item{statsFcn}{A (optional) @function that estimates confidence
+# intervals given locus-level data.
+# If @NULL, the @see "stats::quantile" function is used.}
+# \item{what}{A @character @vector specifying what to bootstrap.}
+# \item{force}{If @TRUE, already existing estimates are ignored,
+# otherwise not.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# \item{.debug}{(internal) If @TRUE, additional sanity checks are
+# performed internally.}
+# }
+#
+# \value{
+# Returns a @see "PairedPSCBS" object.
+# }
+#
+# @author "HB"
+#*/###########################################################################
+setMethodS3("bootstrapTCNandDHByRegion", "PairedPSCBS", function(fit, B=1000L, boot=NULL, ..., probs=c(0.025, 0.050, 0.95, 0.975), statsFcn=NULL, what=c("segment", "changepoint"), force=FALSE, verbose=FALSE, .debug=FALSE) {
+ # Settings for sanity checks
+ tol <- getOption("PSCBS/sanityChecks/tolerance", 0.0005);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Local functions
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ summarizeSamples <- function(X, statsFcn, stats=NULL, what=c("segment", "changepoint"), ..., verbose=FALSE) {
+ # Argument 'X':
+ stopifnot(is.array(X));
+ dim <- dim(X);
+ stopifnot(length(dim) == 3L);
+
+ # Argument 'statsFcn':
+ stopifnot(is.function(statsFcn));
+ statsT <- statsFcn(1);
+ stopifnot(!is.null(names(statsT)));
+ nbrOfStats <- length(statsT);
+ statsNames <- names(statsT);
+ statsT <- NULL; # Not needed anymore
+
+ # Argument 'stats':
+ if (!is.null(stats)) {
+ stopifnot(is.data.frame(stats));
+ }
+
+ # Argument 'what':
+ what <- match.arg(what);
+ whatC <- capitalize(what);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ dimnames <- dimnames(X);
+ fields <- dimnames[[3L]];
+
+ verbose && enter(verbose, sprintf("Summarizing bootstrapped %s (%s) data", what, paste(sQuote(fields), collapse=", ")));
+
+ # Allocate JxQxF matrix S
+ dim[2L] <- nbrOfStats;
+ dimnames[[2L]] <- statsNames;
+ S <- array(NA_real_, dim=dim, dimnames=dimnames);
+ verbose && str(verbose, S);
+
+ for (kk in seq(along=fields)) {
+ field <- fields[kk];
+ verbose && enter(verbose, sprintf("Field #%d ('%s') of %d", kk, field, length(fields)));
+
+ Xkk <- X[,,kk,drop=FALSE]; # An JxB matrix
+ dim(Xkk) <- dim(Xkk)[-3L];
+ # Sanity check
+ stopifnot(is.matrix(Xkk));
+ stopifnot(nrow(Xkk) == dim(X)[1L]);
+ stopifnot(ncol(Xkk) == B);
+
+ for (jj in seq(length=dim(X)[1L])) {
+ verbose && enter(verbose, sprintf("%s #%d of %d", whatC, jj, dim(X)[1L]));
+ Xkkjj <- Xkk[jj,,drop=TRUE]; # A vector of length B
+ S[jj,,kk] <- statsFcn(Xkkjj);
+ verbose && exit(verbose);
+ } # for (jj ...)
+
+ Xkk <- NULL; # Not needed anymore
+
+ verbose && exit(verbose);
+ } # for (jj ...)
+
+ # Not needed anymore
+ X <- NULL;
+
+ verbose && cat(verbose, "Bootstrap statistics");
+ verbose && str(verbose, S);
+
+ # Reshape JxQx4 array to Jx(4*Q) matrix
+ T <- wrap(S, map=list(1,NA), sep="_");
+ colnames(T) <- gsub("(.*)_(.*)", "\\2_\\1", colnames(T));
+
+ # Append as new columns to the summary table
+ stats <- cbind(stats, T);
+
+ # Drop previously estimated values
+ dups <- duplicated(colnames(stats), fromLast=TRUE);
+ if (any(dups)) {
+ stats <- stats[,!dups, drop=FALSE];
+ }
+
+ # Not needed anymore
+ T <- dups <- NULL;
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Statistical sanity checks
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (what == "segment" && B >= 100L) {
+ verbose && enter(verbose, "Statistical sanity checks (iff B >= 100)");
+
+ stopifnot(is.array(S));
+
+ # Find extreme quantiles
+ probs <- dimnames(S)[[2L]];
+ verbose && printf(verbose, "Available summaries: %s\n", paste(probs, collapse=", "));
+ probs <- grep("%", probs, fixed=TRUE, value=TRUE);
+ S <- S[,probs,,drop=FALSE];
+ probs <- gsub("%", "", probs, fixed=TRUE);
+ probs <- as.double(probs) / 100;
+ verbose && printf(verbose, "Available quantiles: %s\n", paste(probs, collapse=", "));
+ verbose && str(verbose, S);
+ # Sanity check
+ stopifnot(all(is.finite(probs)));
+
+ # Is it possible to check?
+ if (any(probs < 0.10) && any(probs > 0.90)) {
+ tryCatch({
+ fields <- dimnames(S)[[3L]];
+ for (kk in seq(along=fields)) {
+ field <- fields[kk];
+ verbose && enter(verbose, sprintf("Field #%d ('%s') of %d", kk, field, length(fields)));
+
+ # Bootstrap statistics
+ Skk <- S[,,kk, drop=FALSE];
+ dim(Skk) <- dim(Skk)[-3L];
+
+ # Sanity checks
+ stopifnot(is.matrix(Skk));
+
+ range <- Skk[,c(1L,ncol(Skk)),drop=FALSE];
+
+ # Segmentation means
+ key <- sprintf("%sMean", field);
+ segMean <- segs[[key]];
+
+ # Segmentation counts
+ cfield <- sprintf("%sNbrOfLoci", ifelse(field == "tcn", "tcn", "dh"));
+ counts <- segs[,cfield,drop=TRUE];
+
+ if (verbose) {
+ for (rr in seq_len(length(segMean))) {
+ printf(verbose, "Seg %3d. mean=%g, range=[%g,%g], n=%d\n", rr, segMean[rr], range[rr,1L], range[rr,2L], counts[rr]);
+ } # for (rr ...)
+ }
+
+ # Compare only segments with enough data points
+ keep <- (counts > 1L);
+ range <- range[keep,,drop=FALSE];
+ segMean <- segMean[keep];
+
+ # Sanity checks
+ stopifnot(all(range[,2L] + tol >= range[,1L], na.rm=TRUE));
+ stopifnot(all(segMean + tol >= range[,1L], na.rm=TRUE));
+ stopifnot(all(segMean - tol <= range[,2L], na.rm=TRUE));
+
+ verbose && exit(verbose);
+ } # for (kk ...)
+ }, error = function(ex) {
+ # If an error, display the data, then throw the exception
+ verbose && cat(verbose, "Tolerance (option 'PSCBS/sanityChecks/tolerance'): ", tol);
+ verbose && print(verbose, segs);
+ throw(ex);
+ })
+ } else {
+ verbose && cat(verbose, "Skipping. Not enough quantiles: ",
+ paste(dimnames(S)[[2L]], collapse=", "));
+ }
+
+ verbose && exit(verbose);
+ } # if (B >= 100L)
+
+
+ verbose && exit(verbose);
+
+ stats;
+ } # summarizeSamples()
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'B':
+ B <- Arguments$getInteger(B, range=c(1,Inf));
+
+ # Argument 'probs':
+ probs <- Arguments$getNumerics(probs, range=c(0,1));
+ # Always estimate the default quantiles
+ probs0 <- eval(formals(bootstrapTCNandDHByRegion.PairedPSCBS)$probs);
+ probs <- unique(sort(c(probs, probs0)));
+
+ # Argument 'statsFcn':
+ if (is.null(statsFcn)) {
+ statsFcn <- function(x) quantile(x, probs=probs, na.rm=TRUE);
+ }
+
+ # Argument 'what':
+ what <- unique(match.arg(what, several.ok=TRUE));
+
+ # Argument 'force':
+ force <- Arguments$getLogical(force);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ # Argument '.debug':
+ .debug <- Arguments$getLogical(.debug);
+
+
+
+ verbose && enter(verbose, "Resample (TCN,DH) signals and re-estimate summaries for ", paste(what, collapse=" & "));
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract existing estimates
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (is.element("segment", what)) {
+ segs <- getSegments(fit);
+ }
+ if (is.element("changepoint", what)) {
+ cps <- getChangePoints(fit);
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Already done?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ stats <- statsFcn(1);
+ stopifnot(!is.null(names(stats)));
+ nbrOfStats <- length(stats);
+ statsNames <- names(stats);
+
+ if (is.element("segment", what)) {
+ tcnStatsNames <- sprintf("tcn_%s", names(stats));
+ dhStatsNames <- sprintf("dh_%s", names(stats));
+ c1StatsNames <- sprintf("c1_%s", names(stats));
+ c2StatsNames <- sprintf("c2_%s", names(stats));
+ allStatsNames <- c(tcnStatsNames, dhStatsNames, c1StatsNames, c2StatsNames);
+ isDone <- is.element(allStatsNames, names(segs));
+ names(isDone) <- allStatsNames;
+ verbose && cat(verbose, "Already done?");
+ verbose && print(verbose, isDone);
+
+ # Not needed anymore
+ allStatsNames <- tcnStatsNames <- dhStatsNames <-
+ c1StatsNames <- c2StatsNames <- NULL;
+
+ if (!force && all(isDone)) {
+ verbose && cat(verbose, "Already done. Skipping.");
+ verbose && exit(verbose);
+ return(fit);
+ }
+ }
+
+
+ # The object to be returned
+ fitB <- fit;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Bootstrap (TCN,DH,C1,C2) segment mean levels
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (is.null(boot)) {
+ boot <- bootstrapSegmentsAndChangepoints(fit, B=B, ...,
+ force=force, .debug=.debug, verbose=verbose);
+ } else {
+ B <- dim(boot$segments)[2L];
+ }
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Summarizing segment (TCN,DH,C1,C2) mean levels
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (is.element("segment", what)) {
+ segs <- summarizeSamples(boot$segments, statsFcn=statsFcn, stats=segs, what="segment", verbose=verbose);
+ # Record statistics
+ fitB$output <- segs;
+ segs <- NULL; # Not needed anymore
+ }
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Summarizing change point (alpha, radius, manhattan, d1, d2) data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (is.element("changepoint", what)) {
+ cps <- summarizeSamples(boot$changepoints, statsFcn=statsFcn, stats=cps, what="changepoint", verbose=verbose);
+ # Record statistics
+ fitB$changepoints <- cps;
+ cps <- NULL; # Not needed anymore
+ }
+
+ # Not needed anymore
+ fit <- boot <- NULL;
+
+ verbose && exit(verbose);
+
+ fitB;
+}, private=TRUE) # bootstrapTCNandDHByRegion()
+
+
+
+
+
+# \item{by}{A @character specifying whether DH should be calculated from
+# normalized ('betaTN') or non-normalized ('betaT') tumor BAFs.}
+# \item{seed}{(optional) A random seed.}
+#
+#
+# \value{
+# Returns a named @list containing two @arrays of bootstrap samples.
+# These arrays also contains the original observation as the first
+# element before the actual bootstrap samples.
+# }
+setMethodS3("bootstrapSegmentsAndChangepoints", "PairedPSCBS", function(fit, B=1000L, by=c("betaTN", "betaT"), seed=NULL, force=FALSE, cache=FALSE, verbose=FALSE, .debug=FALSE, ...) {
+ # Settings for sanity checks
+ tol <- getOption("PSCBS/sanityChecks/tolerance", 0.0005);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'B':
+ B <- Arguments$getInteger(B, range=c(1,Inf));
+
+ # Argument 'by':
+ by <- match.arg(by);
+
+ # Argument 'seed':
+ if (!is.null(seed)) {
+ seed <- Arguments$getInteger(seed);
+ }
+
+ # Argument '.cache':
+ cache <- Arguments$getLogical(cache);
+
+ # Argument 'force':
+ force <- Arguments$getLogical(force);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ # Argument '.debug':
+ .debug <- Arguments$getLogical(.debug);
+
+
+
+ verbose && enter(verbose, "Bootstrapping (TCN,DH,C1,C2) segment mean levels");
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Check for cached results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ key <- list(method="bootstrapSegmentsAndChangepoints", class=class(fit)[1L],
+ fit=fit, B=B, by=by, seed=seed);
+ dirs <- c("PSCBS", "bootstrap");
+ boot <- loadCache(key=key, dirs=dirs);
+ if (!force && !is.null(boot)) {
+ verbose && cat(verbose, "Found cached results. Skipping.");
+ verbose && exit(verbose);
+ return(boot);
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Set the random seed
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (!is.null(seed)) {
+ randomSeed("set", seed=seed, kind="L'Ecuyer-CMRG")
+ on.exit(randomSeed("reset"), add=TRUE)
+ verbose && printf(verbose, "Random seed temporarily set (seed=%d)\n", seed)
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract data and estimates
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fit);
+ tcnSegRows <- fit$tcnSegRows;
+ dhSegRows <- fit$dhSegRows;
+ segs <- getSegments(fit);
+ params <- fit$params;
+
+ # Sanity checks
+ stopifnot(all(!is.na(data$chromosome) & !is.na(data$x)));
+
+ # Sanity checks
+ if (!params$joinSegments) {
+ throw("Cannot bootstrap TCN and DH by segments unless PSCNs are segmented using joinSegments=TRUE.");
+ }
+ if (regexpr(",", params$flavor, fixed=TRUE) != -1L) {
+ throw(sprintf("Cannot bootstrap TCN and DH by segments if PSCNs are segmented using flavor=\"%s\".", params$flavor));
+ }
+ # Sanity check (same as above, but just in case)
+ stopifnot(all(segs$tcnStart == segs$dhStart, na.rm=TRUE));
+ stopifnot(all(segs$tcnEnd == segs$dhEnd, na.rm=TRUE));
+
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Find estimators
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Get mean estimators used
+ estList <- getMeanEstimators(fit, c("tcn", "dh"));
+ avgTCN <- estList$tcn;
+ avgDH <- estList$dh;
+ estList <- NULL; # Not needed anymore
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Get signals
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Get (x,TCN,BAF) data
+ chromosome <- data$chromosome;
+ x <- data$x;
+ CT <- data$CT;
+ betaT <- data[[by]];
+ muN <- data$muN;
+ rho <- data$rho;
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Classify each locus as (i) heterozygous SNP, (ii) homozygous SNP,
+ # or (iii) non-polymorphic loci
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Identifying heterozygous & homozygous SNPs and non-polymorphic loci");
+ nbrOfLoci <- length(CT);
+ verbose && cat(verbose, "Number of loci: ", nbrOfLoci);
+
+ # Identify SNPs
+ hasDH <- !is.null(rho)
+ if (hasDH) {
+ isHet <- !is.na(rho)
+ isSnp <- isHet
+ } else {
+ isSnp <- (!is.na(muN) & !is.na(betaT))
+ isHet <- (isSnp & (muN == 1/2))
+ }
+
+ snps <- which(isSnp);
+ nonSNPs <- which(!isSnp);
+ nbrOfSNPs <- sum(isSnp);
+ nbrOfNonSNPs <- sum(!isSnp);
+ verbose && cat(verbose, "Number of SNPs: ", nbrOfSNPs);
+ verbose && cat(verbose, "Number of non-SNPs: ", nbrOfNonSNPs);
+
+ # Sanity checks
+ stopifnot(length(intersect(snps, nonSNPs)) == 0L);
+
+ # Heterozygous SNPs
+ hets <- which(isSnp & isHet)
+ homs <- which(isSnp & !isHet);
+ nbrOfHets <- length(hets);
+ nbrOfHoms <- length(homs);
+
+ if (!hasDH) {
+ verbose && printf(verbose, "Number of heterozygous SNPs: %d (%.2f%%)\n",
+ nbrOfHets, 100*nbrOfHets/nbrOfSNPs);
+ verbose && printf(verbose, "Number of homozygous SNPs: %d (%.2f%%)\n",
+ nbrOfHoms, 100*nbrOfHoms/nbrOfSNPs);
+ }
+
+ # Sanity checks
+ stopifnot(length(intersect(hets, homs)) == 0L);
+ stopifnot(nbrOfHets + nbrOfHoms == nbrOfSNPs);
+
+ # Sanity checks
+ stopifnot(length(isSnp) == nbrOfLoci);
+ stopifnot(length(isHet) == nbrOfLoci);
+
+ # Not needed anymore
+ muN <- isSnp <- NULL
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Precalculate DH signals
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (is.null(rho)) {
+ # Calculate DHs for heterozygous SNPs
+ rho <- 2*abs(betaT - 1/2);
+
+ # DH is by definition only defined for heterozygous SNPs.
+ # For simplicity, we set it to be NA for non-heterozygous loci.
+ rho[!isHet] <- NA_real_;
+
+ data$rho <- rho;
+ }
+
+ # Not needed anymore
+ betaT <- isHet <- NULL;
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Resample (TCN,DH) within each segments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ nbrOfSegments <- nrow(segs);
+
+ # Allocate JxBx4 matrix M of bootstrap means
+ dim <- c(nbrOfSegments, B, 4L);
+ dimnames <- list(NULL, NULL, c("tcn", "dh", "c1", "c2"));
+ M <- array(NA_real_, dim=dim, dimnames=dimnames);
+ verbose && str(verbose, M);
+
+ # Identify all loci with non-missing signals
+ idxsCT <- which(!is.na(CT));
+ idxsRho <- which(!is.na(rho));
+
+ # Vectorized pre-adjustments
+ for (field in c("tcnNbrOfLoci", "dhNbrOfLoci")) {
+ counts <- segs[[field]];
+ counts[is.na(counts)] <- 0L;
+ segs[[field]] <- counts;
+ }
+
+ hasTcnLoci <- (is.finite(tcnSegRows[,1L]) & is.finite(tcnSegRows[,2L]));
+ hasDhLoci <- (is.finite(dhSegRows[,1L]) & is.finite(dhSegRows[,2L]));
+
+ # Identify "splitter" segments which have no data
+ chrs <- segs[["chromosome"]];
+ tcnIds <- segs[["tcnId"]];
+ dhIds <- segs[["dhId"]];
+ tcnMeans <- segs[["tcnMean"]];
+ dhMeans <- segs[["dhMean"]];
+ isSplitter <- (is.na(chrs) & is.na(tcnIds) & is.na(dhIds));
+
+ # Get all segment indices except for "splitters"
+ jjs <- seq(length=nbrOfSegments);
+ jjs <- jjs[!isSplitter];
+
+ for (jj in jjs) {
+ chr <- chrs[jj];
+ tcnId <- tcnIds[jj];
+ dhId <- dhIds[jj];
+
+ verbose && enter(verbose, sprintf("Segment #%d (chr %d, tcnId=%d, dhId=%d) of %d", jj, chr, tcnId, dhId, nbrOfSegments));
+
+ # Sanity check
+ if (.debug) stopifnot(!is.na(chr) && !is.na(tcnId) && !is.na(dhId));
+
+ # Get the segment data
+ segJJ <- segs[jj,,drop=FALSE];
+ verbose && print(verbose, segJJ);
+
+ nbrOfTCNs <- segJJ[,"tcnNbrOfLoci"];
+ nbrOfDHs <- segJJ[,"dhNbrOfLoci"];
+ verbose && cat(verbose, "Number of TCNs: ", nbrOfTCNs);
+ verbose && cat(verbose, "Number of DHs: ", nbrOfDHs);
+ if (.debug) {
+ stopifnot(!is.na(nbrOfTCNs));
+ stopifnot(!is.na(nbrOfDHs));
+ }
+
+ tcnSegRowJJ <- unlist(tcnSegRows[jj,], use.names=FALSE);
+ dhSegRowJJ <- unlist(dhSegRows[jj,], use.names=FALSE);
+
+ # Indices of all loci
+ if (hasTcnLoci[jj]) {
+ idxsAll <- tcnSegRowJJ[1L]:tcnSegRowJJ[2L];
+ } else {
+ idxsAll <- 0L;
+ }
+
+ verbose && str(verbose, idxsAll);
+ verbose && print(verbose, hpaste(idxsAll), level=-120);
+ verbose && str(verbose, idxsCT);
+ verbose && print(verbose, hpaste(idxsCT), level=-120);
+
+ # Keep only loci with finite TCNs
+ idxsAll <- intersect(idxsAll, idxsCT);
+ verbose && str(verbose, idxsAll);
+ verbose && print(verbose, hpaste(idxsAll), level=-120);
+
+ # Sanity check
+ if (length(idxsAll) != nbrOfTCNs) {
+ verbose && str(verbose, setdiff(idxsCT, idxsAll));
+ throw("INTERNAL ERROR: length(idxsAll) != nbrOfTCNs: ", length(idxsAll), " != ", nbrOfTCNs);
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Identify loci used to calculate DH means
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Identify loci used to bootstrap DH means");
+
+ if (hasDhLoci[jj]) {
+ idxsDH <- dhSegRowJJ[1L]:dhSegRowJJ[2L];
+ idxsDH <- intersect(idxsDH, hets);
+ # Drop missing values
+ idxsDH <- intersect(idxsDH, idxsRho);
+ } else {
+ idxsDH <- 0L;
+ }
+
+ verbose && cat(verbose, "Heterozygous SNPs to resample for DH:");
+ verbose && str(verbose, idxsDH);
+
+ # Sanity check
+ if (.debug) stopifnot(length(idxsDH) == nbrOfDHs);
+
+ verbose && exit(verbose);
+
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Identify loci used to calculate TCN means
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Identify loci used to bootstrap TCN means");
+
+ # Identify SNPs and non-SNPs
+ idxsSNP <- intersect(snps, idxsAll);
+ idxsNonSNP <- setdiff(idxsAll, idxsSNP);
+ verbose && cat(verbose, "SNPs:");
+ verbose && str(verbose, idxsSNP);
+ verbose && cat(verbose, "Non-polymorphic loci:");
+ verbose && str(verbose, idxsNonSNP);
+ # Sanity check
+ if (.debug) stopifnot(length(idxsSNP) + length(idxsNonSNP) == length(idxsAll));
+
+ # Identify heterozygous and homozygous SNPs
+ idxsHet <- intersect(idxsSNP, hets);
+ if (nbrOfHoms > 0) {
+ idxsHom <- intersect(idxsSNP, homs)
+ } else {
+ ## Happens when only DH is available
+ idxsHom <- integer(0L)
+ }
+
+ # Drop missing values
+ idxsNonSNP <- intersect(idxsNonSNP, idxsCT);
+ idxsHet <- intersect(idxsHet, idxsCT);
+ idxsHom <- intersect(idxsHom, idxsCT);
+ idxsHetNonDH <- setdiff(idxsHet, idxsDH);
+
+ verbose && cat(verbose, "Heterozygous SNPs to resample for TCN:");
+ verbose && str(verbose, idxsHet);
+ verbose && cat(verbose, "Homozygous SNPs to resample for TCN:");
+ verbose && str(verbose, idxsHom);
+ verbose && cat(verbose, "Non-polymorphic loci to resample for TCN:");
+ verbose && str(verbose, idxsNonSNP);
+ verbose && cat(verbose, "Heterozygous SNPs with non-DH to resample for TCN:");
+ verbose && str(verbose, idxsHetNonDH);
+ # Note that length(idxsHetNonDH) may differ from zero in case CT is non-missing
+ # but rho is missing, e.g. CT = sum(c(thetaA,thetaB), na.rm=TRUE) and
+ # thetaB is missing. /HB 2010-12-01
+
+ idxsTCN <- sort(unique(c(idxsHet, idxsHom, idxsNonSNP)));
+ verbose && cat(verbose, "Loci to resample for TCN:");
+ verbose && str(verbose, idxsTCN);
+
+ # Sanity check
+ if (.debug) {
+ stopifnot(length(idxsHet) + length(idxsHom) + length(idxsNonSNP) == nbrOfTCNs);
+ stopifnot(length(intersect(idxsDH, idxsHetNonDH)) == 0L);
+ stopifnot(length(idxsTCN) == nbrOfTCNs);
+ }
+
+ verbose && exit(verbose);
+
+
+ # These numbers should be preserved when the resampling
+ verbose && printf(verbose, "Number of (#hets, #homs, #nonSNPs): (%d,%d,%d)\n",
+ length(idxsHet), length(idxsHom), length(idxsNonSNP));
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Sanity checks
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (nbrOfTCNs > 0L) {
+ # Sanity check
+ ys <- CT[idxsTCN];
+ mu <- avgTCN(ys, na.rm=TRUE);
+ dMu <- (mu - tcnMeans[jj]);
+ if (abs(dMu) > tol) {
+ str(list(nbrOfTCNs=nbrOfTCNs, tcnNbrOfLoci=segJJ$tcnNbrOfLoci, mu=mu, tcnMean=tcnMeans[jj], dMu=dMu, "abs(dMu)"=abs(dMu), "range(x[units])"=range(x[idxsTCN])));
+ throw(sprintf("INTERNAL ERROR: Incorrectly recalculated TCN mean for Segment #%d (chr %d, tcnId=%d, dhId=%d): %g != %g", jj, chr, tcnId, dhId, mu, tcnMeans[jj]));
+ }
+ }
+
+ shouldHaveDHs <- (nbrOfDHs > 0L && !is.na(dhMeans[jj]));
+ if (shouldHaveDHs) {
+ # Sanity check
+ ys <- rho[idxsDH];
+ mu <- avgDH(ys, na.rm=TRUE);
+ dMu <- (mu - dhMeans[jj]);
+ if (abs(dMu) > tol) {
+ str(list(nbrOfDHs=nbrOfDHs, dhNbrOfLoci=segJJ$dhNbrOfLoci, mu=mu, dhMean=dhMeans[jj], dMu=dMu, "abs(dMu)"=abs(dMu), "range(x[units])"=range(x[idxsDH])));
+ throw(sprintf("INTERNAL ERROR: Incorrectly recalculated DH mean for Segment #%d (chr %d, tcnId=%d, dhId=%d): %g != %g", jj, chr, tcnId, dhId, mu, dhMeans[jj]));
+ }
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Bootstrap while preserving (#hets, #homs, #nonSNPs)
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Bootstrapping while preserving (#hets, #homs, #nonSNPs)");
+ verbose && cat(verbose, "Number of bootstrap samples: ", B);
+
+ if (!shouldHaveDHs) {
+ idxsHetNonDH <- idxsDH;
+ }
+
+ nHoms <- length(idxsHom);
+ nNonSNPs <- length(idxsNonSNP);
+ nHetNonDHs <- length(idxsHetNonDH);
+
+ # Defaults
+ idxsDHBB <- NULL;
+
+ # Bootstrap B times
+ for (bb in seq(length=B)) {
+ # (1) Bootstrap DHs
+ if (shouldHaveDHs) {
+ # (a) Resample heterozygous SNPs (=> resampled DH units)
+ idxsDHBB <- resample(idxsDH, size=nbrOfDHs, replace=TRUE);
+
+ # Extract signals
+ rhoBB <- rho[idxsDHBB];
+
+ # Calculate bootstrap mean
+ M[jj,bb,"dh"] <- avgDH(rhoBB, na.rm=TRUE);
+ } # if (shouldHaveDHs)
+
+ # (2) Bootstrap TCNs
+ if (nbrOfTCNs > 0L) {
+ # (a) Resample non-DH hets SNPs
+ idxsHetNonDHBB <- resample(idxsHetNonDH, size=nHetNonDHs, replace=TRUE);
+ idxsHetBB <- c(idxsDHBB, idxsHetNonDHBB);
+
+ # (a) Resample homozygous SNPs
+ if (nbrOfHoms > 0) {
+ idxsHomBB <- resample(idxsHom, size=nHoms, replace=TRUE)
+ } else {
+ idxsHomBB <- integer(0L)
+ }
+
+ # (b) Resample non-SNPs
+ idxsNonSNPBB <- resample(idxsNonSNP, size=nNonSNPs, replace=TRUE);
+
+ # (c) Resampled TCN units
+ idxsTCNBB <- c(idxsHetBB, idxsHomBB, idxsNonSNPBB);
+
+ # Sanity check
+ if (.debug) {
+ stopifnot(length(intersect(idxsDHBB, idxsHetNonDHBB)) == 0L);
+ stopifnot(length(intersect(idxsHetBB, idxsHomBB)) == 0L);
+ stopifnot(length(intersect(idxsHetBB, idxsNonSNPBB)) == 0L);
+ stopifnot(length(intersect(idxsHomBB, idxsNonSNPBB)) == 0L);
+ }
+
+ # Extract signals
+ CTBB <- CT[idxsTCNBB];
+
+ # Calculate bootstrap mean
+ M[jj,bb,"tcn"] <- avgTCN(CTBB, na.rm=TRUE);
+ } # if (nbrOfTCNs > 0L)
+ } # (for bb ...)
+ verbose && exit(verbose);
+
+ verbose && exit(verbose);
+ } # for (jj ...)
+
+ verbose && cat(verbose, "Bootstrapped segment mean levels");
+ verbose && str(verbose, M);
+
+ # Sanity check
+ stopifnot(all(!is.nan(M)));
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Add (C1,C2) bootstrap mean levels
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Calculating (C1,C2) mean levels from (TCN,DH) mean levels");
+ C1 <- (1-M[,,"dh", drop=FALSE]) * M[,,"tcn", drop=FALSE] / 2;
+ C2 <- M[,,"tcn", drop=FALSE] - C1;
+ M[,,"c1"] <- C1;
+ M[,,"c2"] <- C2;
+ verbose && str(verbose, M);
+ # Sanity check
+ stopifnot(dim(M)[1L] == nbrOfSegments);
+ stopifnot(all(!is.nan(M)));
+ # Not needed anymore
+ C1 <- C2 <- NULL;
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Bootstrap polar (alpha,radius,manhattan) for change points
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Calculating polar (alpha,radius,manhattan) for change points");
+ C <- M[,,c("c1","c2"), drop=FALSE];
+
+ # Calculate difference
+ # (will be empty if nbrOfSegments == 1, but that's ok/intended)
+ D <- C[-nbrOfSegments,,, drop=FALSE] - C[-1L,,, drop=FALSE];
+ # Sanity check
+ stopifnot(dim(D)[1L] == nbrOfSegments-1L);
+ stopifnot(all(!is.nan(D)));
+ C <- NULL; # Not needed anymore
+
+ # Allocate array
+ dimnames <- dimnames(D);
+ dimnames[[3L]] <- c("alpha", "radius", "manhattan", "d1", "d2");
+ dim <- dim(D);
+ dim[3L] <- length(dimnames[[3L]]);
+ P <- array(NA_real_, dim=dim, dimnames=dimnames);
+ stopifnot(dim(P)[1L] == nbrOfSegments-1L);
+
+ if (nbrOfSegments >= 2L) {
+ verbose && str(verbose, D);
+ P[,,"alpha"] <- atan2(D[,,2], D[,,1]); # Changepoint angles in (0,2*pi)
+ P[,,"radius"] <- sqrt(D[,,2]^2 + D[,,1]^2);
+ P[,,"manhattan"] <- abs(D[,,2]) + abs(D[,,1]);
+ P[,,"d1"] <- D[,,1];
+ P[,,"d2"] <- D[,,2];
+ }
+ alpha <- D <- NULL; # Not needed anymore
+ verbose && cat(verbose, "Bootstrapped change points");
+ verbose && str(verbose, P);
+
+ # Sanity check
+ stopifnot(dim(P)[1L] == nbrOfSegments-1L);
+ stopifnot(all(!is.nan(P)));
+ verbose && exit(verbose);
+
+ boot <- list(segments=M, changepoints=P);
+
+ # Cache?
+ if (cache) {
+ saveCache(boot, key=key, dirs=dirs);
+ verbose && cat(verbose, "Saved results to cache.");
+ }
+
+ verbose && exit(verbose);
+
+ boot;
+}, private=TRUE) # bootstrapSegmentsAndChangepoints()
+
+
+
+setMethodS3("findBootstrapSummaries", "PairedPSCBS", function(fit, what=c("segment", "changepoint"), ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'what':
+ what <- match.arg(what);
+
+ if (what == "segment") {
+ data <- getSegments(fit);
+ } else if (what == "changepoint") {
+ data <- getChangePoints(fit);
+ }
+
+ grep("^[^_]+_[^_]+$", colnames(data), value=TRUE);
+}, protected=TRUE) # findBootstrapSummaries()
+
+
+setMethodS3("hasBootstrapSummaries", "PairedPSCBS", function(fit, ...) {
+ fields <- findBootstrapSummaries(fit, ...);
+ (length(fields) > 0L);
+})
+
+setMethodS3("clearBootstrapSummaries", "PairedPSCBS", function(fit, what=c("segment", "changepoint"), ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'what':
+ what <- unique(match.arg(what, several.ok=TRUE));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Clearing bootstrap summaries");
+
+ whats <- what;
+ for (what in whats) {
+ verbose && enter(verbose, sprintf("Clearing %ss", what));
+
+ fields <- findBootstrapSummaries(fit, what=what, ...);
+ if (what == "segment") {
+ data <- getSegments(fit);
+ data <- data[,!is.element(colnames(data), fields)];
+ fit$output <- data;
+ } else if (what == "changepoint") {
+ data <- getChangePoints(fit);
+ data <- data[,!is.element(colnames(data), fields)];
+ fit$changepoints <- data;
+ }
+ # Sanity check
+ fields <- findBootstrapSummaries(fit, what=what, ...);
+ stopifnot(length(fields) == 0L);
+
+ data <- fields <- NULL; # Not needed anymoew
+
+ verbose && exit(verbose);
+ } # for (what ...)
+
+ verbose && exit(verbose);
+
+ fit;
+}, protected=TRUE) # clearBootstrapSummaries()
+
+
+##############################################################################
+# HISTORY
+# 2013-10-22
+# o SPEEDUP: Added argument 'cache' to bootstrapSegmentsAndChangepoints(),
+# which caches the results to file if cache=TRUE.
+# 2013-10-21
+# o Added find-, has- and clearBootstrapSummaries().
+# o Added argument 'what' to bootstrapTCNandDHByRegion().
+# o BUG FIX: The new bootstrapSegmentsAndChangepoints() would give
+# "Error in D[, , 2] : incorrect number of dimensions" if bootstrapping
+# was done on a single change point (==two segments).
+# 2013-10-20
+# o Now utilizing new getChangePoints().
+# o Now calculating change-point angles in (0,2*pi) using atan2().
+# o Added bootstrapSegmentsAndChangepoints(), which was extract from
+# internal code of bootstrapTCNandDHByRegion(). The latter now
+# utilizes the former.
+# o BUG FIX: bootstrapTCNandDHByRegion() did not identify segment
+# "splitters" as intended. This has had no impact on the results.
+# 2013-04-23
+# o SPEEDUP: Made bootstrapTCNandDHByRegion() much faster by adding
+# use.names=FALSE to two internal unlist() statements.
+# 2013-04-22
+# o Added argument 'probs' to bootstrapTCNandDHByRegion().
+# 2013-04-09
+# o Added Rdoc comments.
+# 2013-02-09
+# o BUG FIX: bootstrapTCNandDHByRegion() for PairedPSCBS did not bootstrap
+# for all available loci when calculating total CNs statistics, iff
+# the segment had been called run-of-homozygosity (ROH).
+# Thanks to Oscar Rueda at the Cancer Research UK Cambridge Institute
+# for reporting on this.
+# 2013-02-07
+# o Improved some verbose outputs of bootstrapTCNandDHByRegion().
+# 2013-01-15
+# o Now bootstrapTCNandDHByRegion() uses the params$avgTCN and params$avgDH
+# estimators, iff given.
+# 2012-11-05
+# o GENERALIZATION: Now bootstrapTCNandDHByRegion() works for more "flavors",
+# including the default ('tcn') used by segmentByNonPairedPSCBS().
+# 2012-09-20
+# o SPEEDUP: By default bootstrapTCNandDHByRegion() for PairedPSCBS no
+# longer do sanity checks within the bootstrap loop. This significantly
+# speed up the method. To run checks, use argument .debug=TRUE.
+# 2012-02-26
+# o BUG FIX: bootstrapTCNandDHByRegion() for PairedPSCBS would resample
+# from a subset of the intended TCNs, iff the DH mean was non-finite
+# while there were still heterozygous SNPs. This introduced a bias in
+# the estimates, which was neglectable for large segments, but for very
+# small segments (a few loci) it could be relatively large.
+# 2012-02-24
+# o BUG FIX: bootstrapTCNandDHByRegion(..., force=TRUE) for PairedPSCBS
+# would give an error iff previous bootstrap estimates already existed.
+# o Added argument 'force' to bootstrapTCNandDHByRegion().
+# 2011-11-26
+# o Now bootstrapTCNandDHByRegion() for PairedPSCBS preserves NAs for DH
+# and (C1,C2) quantiles, if the DH mean level is NA, which can happen
+# when a segment is called ROH.
+# o An internal sanity check of bootstrapTCNandDHByRegion() for PairedPSCBS
+# would give an error if DH mean levels had been set to NA for segments
+# called ROH.
+# 2011-11-24
+# o BUG FIX: bootstrapTCNandDHByRegion() for PairedPSCBS would give
+# an error, if a segment did not have any TCN signals, which can
+# occur when known segments are specified for Paired PSCBS.
+# 2011-08-08
+# o Moved the sanity checks that tests the TCN and DH "segRows" from the
+# bootstrapTCNandDHByRegion() to segmentByPairedPSCBS(). This is the
+# first step to fix a failure in the sanity checks that could happend
+# iff one first run dropSegmentationOutliers().
+# 2011-06-14
+# o Updated code to recognize new column names.
+# 2011-05-29
+# o Renamed options to reflect new package name.
+# 2010-12-03
+# o BUG FIX: In rare cases the bootstrap sanity checks can indeed produce
+# an invalid 'range', more precisely where (range[,2] >= range[,1]) is
+# not true. This can happen if there is no variation in the bootstrap
+# estimates. Beause of this we allow for some tolerance.
+# 2010-12-02
+# o Now bootstrapTCNandDHByRegion() uses option
+# "psCBS/sanityChecks/tolerance".
+# 2010-12-01
+# o BUG FIX: bootstrapTCNandDHByRegion() did not always exclude the correct
+# loci.
+# 2010-11-27
+# o BUG FIX: bootstrapTCNandDHByRegion() would incorrectly include
+# non-polymorphic loci in the set of homozygous SNPs during resampling.
+# 2010-11-26
+# o BUG FIX: The statistical sanity checks of the bootstrap estimates would
+# give an error when only single-sided bootstrap confidence interval was
+# calculated.
+# 2010-11-23
+# o ROBUSTNESS: Added more sanity checks to bootstrapTCNandDHByRegion().
+# o WORKAROUND: The precision of the mean levels of DNAcopy::segment()
+# is not great enough to always compare it to that of R's estimates.
+# o BUG FIX: bootstrapTCNandDHByRegion() would give an error if there was
+# only one segment.
+# 2010-11-22
+# o BUG FIX: The DH segmentation and bootstrap incorrectly included
+# missing values, when subseting.
+# o BUG FIX: Some sanity checks were incorrect.
+# o BUG FIX: bootstrapTCNandDHByRegion() for PairedPSCBS would not correctly
+# detect if bootstrap results are already available.
+# 2010-11-21
+# o Added argument 'seed'.
+# o Added bootstrapTCNandDHByRegion() for PairedPSCBS.
+# o Created from PairedPSCBS.BOOT.R.
+##############################################################################
diff --git a/R/PairedPSCBS.BOOT.sets.R b/R/PairedPSCBS.BOOT.sets.R
new file mode 100644
index 0000000..196096a
--- /dev/null
+++ b/R/PairedPSCBS.BOOT.sets.R
@@ -0,0 +1,571 @@
+###########################################################################/**
+# @set class=PairedPSCBS
+# @RdocMethod getBootstrapLocusSets
+# @alias getBootstrapLocusSets
+#
+# @title "Generates original and bootstrapped segment-specific index sets"
+#
+# \description{
+# @get "title", which can be used to calculate various bootstrap summaries,
+# e.g. segment mean levels.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{B}{A non-negative @integer specifying the number of bootstrap samples.}
+# \item{by}{Should \code{betaTN} or \code{betaT} be used?}
+# \item{seed}{An (optional) @integer specifying the random seed to be
+# set before sampling indices. The random seed is set to its original
+# state when exiting. If @NULL, it is not set.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# \item{.validate}{If @TRUE, additional sanity checks are performed
+# to validate the correctness. This is only needed for troubleshooting
+# if it is suspected there is a bug.}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns a @list.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# This is used internally by various bootstrap methods.
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("getBootstrapLocusSets", "PairedPSCBS", function(fit, B=1000L, by=c("betaTN", "betaT"), seed=NULL, verbose=FALSE, .validate=FALSE, ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'B':
+ B <- Arguments$getInteger(B, range=c(0,Inf));
+
+ # Argument 'by':
+ by <- match.arg(by);
+
+ # Argument 'seed':
+ if (!is.null(seed)) {
+ seed <- Arguments$getInteger(seed);
+ }
+
+ # Argument '.validate':
+ .validate <- Arguments$getLogical(.validate);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+
+ verbose && enter(verbose, "Bootstrapping (TCN,DH,C1,C2) segment mean levels");
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Set the random seed
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (!is.null(seed)) {
+ randomSeed("set", seed=seed, kind="L'Ecuyer-CMRG")
+ on.exit(randomSeed("reset"), add=TRUE)
+ verbose && printf(verbose, "Random seed temporarily set (seed=%d)\n", seed)
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract data and estimates
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fit);
+ tcnSegRows <- fit$tcnSegRows;
+ dhSegRows <- fit$dhSegRows;
+ segs <- getSegments(fit);
+ params <- fit$params;
+
+ # Sanity checks
+ if (!params$joinSegments) {
+ throw("Cannot bootstrap TCN and DH by segments unless PSCNs are segmented using joinSegments=TRUE.");
+ }
+ if (regexpr(",", params$flavor, fixed=TRUE) != -1L) {
+ throw(sprintf("Cannot bootstrap TCN and DH by segments if PSCNs are segmented using flavor=\"%s\".", params$flavor));
+ }
+ # Sanity check (same as above, but just in case)
+ stopifnot(all(segs$tcnStart == segs$dhStart, na.rm=TRUE));
+ stopifnot(all(segs$tcnEnd == segs$dhEnd, na.rm=TRUE));
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Get signals
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Get (x,TCN,BAF) data
+ chromosome <- data$chromosome;
+ x <- data$x;
+ CT <- data$CT;
+ betaT <- data[[by]];
+ muN <- data$muN;
+ rho <- data$rho
+ hasDH <- !is.null(rho)
+
+ # Not needed anymore
+ data <- NULL;
+
+ # Sanity checks
+ stopifnot(all(!is.na(chromosome) & !is.na(x)));
+
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Classify each locus as (i) heterozygous SNP, (ii) homozygous SNP,
+ # or (iii) non-polymorphic loci
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Identifying heterozygous & homozygous SNPs and non-polymorphic loci");
+ nbrOfLoci <- length(x);
+ verbose && cat(verbose, "Number of loci: ", nbrOfLoci);
+
+ # SNPs are identifies as those loci that have non-missing 'muN' (& betaTN')
+ if (hasDH) {
+ isHet <- !is.na(rho)
+ isSnp <- isHet
+ } else {
+ isSnp <- (!is.na(muN) & !is.na(betaT))
+ isHet <- isSnp & (muN == 1/2)
+ }
+ snps <- which(isSnp);
+ nonSNPs <- which(!isSnp);
+ nbrOfSNPs <- sum(isSnp);
+ nbrOfNonSNPs <- sum(!isSnp);
+ verbose && cat(verbose, "Number of SNPs: ", nbrOfSNPs);
+ verbose && cat(verbose, "Number of non-SNPs: ", nbrOfNonSNPs);
+
+ # Sanity checks
+ stopifnot(length(intersect(snps, nonSNPs)) == 0L);
+
+ # Heterozygous SNPs
+ hets <- which(isSnp & isHet);
+ homs <- which(isSnp & !isHet);
+ nbrOfHets <- length(hets);
+ nbrOfHoms <- length(homs);
+ if (!hasDH) {
+ verbose && printf(verbose, "Number of heterozygous SNPs: %d (%.2f%%)\n",
+ nbrOfHets, 100*nbrOfHets/nbrOfSNPs);
+ verbose && printf(verbose, "Number of homozygous SNPs: %d (%.2f%%)\n",
+ nbrOfHoms, 100*nbrOfHoms/nbrOfSNPs);
+ }
+
+ # Sanity checks
+ stopifnot(length(intersect(hets, homs)) == 0L);
+ stopifnot(nbrOfHets + nbrOfHoms == nbrOfSNPs);
+
+ # Sanity checks
+ stopifnot(length(isSnp) == nbrOfLoci);
+ stopifnot(length(isHet) == nbrOfLoci);
+
+ # Not needed anymore
+ muN <- isSnp <- NULL;
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Precalculate DH signals
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (!hasDH) {
+ # Calculate DHs for heterozygous SNPs
+ rho <- 2*abs(betaT - 1/2);
+
+ # DH is by definition only defined for heterozygous SNPs.
+ # For simplicity, we set it to be NA for non-heterozygous loci.
+ rho[!isHet] <- NA;
+ }
+
+ # Not needed anymore
+ betaT <- isHet <- NULL;
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Resample (TCN,DH) within each segments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ nbrOfSegments <- nrow(segs);
+
+ # Allocate JxBx4 matrix M of bootstrap means
+ dim <- c(nbrOfSegments, B, 4L);
+ dimnames <- list(NULL, NULL, c("tcn", "dh", "c1", "c2"));
+
+ # Identify all loci with non-missing signals
+ idxsCT <- which(!is.na(CT));
+ idxsRho <- which(!is.na(rho));
+
+ # Not needed anymore
+ CT <- rho <- NULL;
+
+
+ # Vectorized pre-adjustments
+ for (key in c("tcnNbrOfLoci", "dhNbrOfLoci")) {
+ counts <- segs[[key]];
+ counts[is.na(counts)] <- 0L;
+ segs[[key]] <- counts;
+ counts <- NULL; # Not needed anymore
+ }
+
+ hasTcnLoci <- (is.finite(tcnSegRows[,1L]) & is.finite(tcnSegRows[,2L]));
+ hasDhLoci <- (is.finite(dhSegRows[,1L]) & is.finite(dhSegRows[,2L]));
+
+ # Identify "splitter" segments which have no data
+ chrs <- segs[["chromosome"]];
+ tcnIds <- segs[["tcnId"]];
+ dhIds <- segs[["dhId"]];
+ dhMeans <- segs[["dhMean"]];
+ isSplitter <- (is.na(chrs) & is.na(tcnIds) & is.na(dhIds));
+
+ # Get all segment indices except for "splitters"
+ jjs <- seq(length=nbrOfSegments);
+ jjs <- jjs[!isSplitter];
+
+
+ # Allocate list to hold the results
+ res <- list(
+ nbrOfSegments = nbrOfSegments,
+ segments = jjs,
+ nbrOfLoci = nbrOfLoci,
+ loci = list(
+ all = seq_len(nbrOfLoci),
+ tcn = idxsCT,
+ dh = idxsRho
+ ),
+ by = by,
+ seed = seed
+ );
+ locusSet <- vector("list", length=nbrOfSegments);
+
+
+ # For each segment jj = 1, 2, ..., S
+ for (jj in jjs) {
+ chr <- chrs[jj];
+ tcnId <- tcnIds[jj];
+ dhId <- dhIds[jj];
+
+ verbose && enter(verbose, sprintf("Segment #%d (chr %d, tcnId=%d, dhId=%d) of %d", jj, chr, tcnId, dhId, nbrOfSegments));
+
+ # Sanity check
+ if (.validate) {
+ stopifnot(!is.na(chr) && !is.na(tcnId) && !is.na(dhId));
+ }
+
+ # Get the segment data
+ segJJ <- segs[jj,,drop=FALSE];
+ nbrOfTCNs <- segJJ[,"tcnNbrOfLoci"];
+ nbrOfDHs <- segJJ[,"dhNbrOfLoci"];
+
+ if (verbose) {
+ print(verbose, segJJ);
+ cat(verbose, "Number of TCNs: ", nbrOfTCNs);
+ cat(verbose, "Number of DHs: ", nbrOfDHs);
+ }
+ if (.validate) {
+ stopifnot(!is.na(nbrOfTCNs));
+ stopifnot(!is.na(nbrOfDHs));
+ }
+
+ tcnSegRowJJ <- unlist(tcnSegRows[jj,], use.names=FALSE);
+ dhSegRowJJ <- unlist(dhSegRows[jj,], use.names=FALSE);
+
+ # Indices of all loci
+ if (hasTcnLoci[jj]) {
+ idxsAll <- tcnSegRowJJ[1L]:tcnSegRowJJ[2L];
+ } else {
+ idxsAll <- integer(0L);
+ }
+
+ if (verbose) {
+ str(verbose, idxsAll);
+ print(verbose, hpaste(idxsAll), level=-120);
+ str(verbose, idxsCT);
+ print(verbose, hpaste(idxsCT), level=-120);
+ }
+
+ # Keep only loci with finite TCNs
+ idxsAll <- intersect(idxsAll, idxsCT);
+ if (verbose) {
+ str(verbose, idxsAll);
+ print(verbose, hpaste(idxsAll), level=-120);
+ }
+
+ # Sanity check
+ if (length(idxsAll) != nbrOfTCNs) {
+ verbose && str(verbose, setdiff(idxsCT, idxsAll));
+ throw("INTERNAL ERROR: length(idxsAll) != nbrOfTCNs: ", length(idxsAll), " != ", nbrOfTCNs);
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Identify loci used to calculate DH means
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Identify loci used to bootstrap DH means");
+
+ if (hasDhLoci[jj]) {
+ idxsDH <- dhSegRowJJ[1L]:dhSegRowJJ[2L];
+ idxsDH <- intersect(idxsDH, hets);
+ # Drop missing values
+ idxsDH <- intersect(idxsDH, idxsRho);
+ } else {
+ idxsDH <- integer(0L);
+ }
+
+ verbose && cat(verbose, "Heterozygous SNPs to resample for DH:");
+ verbose && str(verbose, idxsDH);
+
+ # Sanity check
+ if (.validate) stopifnot(length(idxsDH) == nbrOfDHs);
+
+ verbose && exit(verbose);
+
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Identify loci used to calculate TCN means
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Identify loci used to bootstrap TCN means");
+
+ # Identify SNPs and non-SNPs
+ idxsSNP <- intersect(snps, idxsAll);
+ idxsNonSNP <- setdiff(idxsAll, idxsSNP);
+ if (verbose) {
+ cat(verbose, "SNPs:");
+ str(verbose, idxsSNP);
+ cat(verbose, "Non-polymorphic loci:");
+ str(verbose, idxsNonSNP);
+ }
+ # Sanity check
+ if (.validate) stopifnot(length(idxsSNP) + length(idxsNonSNP) == length(idxsAll));
+
+ # Identify heterozygous and homozygous SNPs
+ idxsHet <- intersect(idxsSNP, hets);
+ if (nbrOfHoms > 0) {
+ idxsHom <- intersect(idxsSNP, homs);
+ } else {
+ idxsHom <- integer(0L)
+ }
+
+ # Drop missing values
+ idxsNonSNP <- intersect(idxsNonSNP, idxsCT);
+ idxsHet <- intersect(idxsHet, idxsCT);
+ if (nbrOfHoms > 0) {
+ idxsHom <- intersect(idxsHom, idxsCT)
+ }
+ idxsHetNonDH <- setdiff(idxsHet, idxsDH);
+
+ if (verbose) {
+ cat(verbose, "Heterozygous SNPs to resample for TCN:");
+ str(verbose, idxsHet);
+ cat(verbose, "Homozygous SNPs to resample for TCN:");
+ str(verbose, idxsHom);
+ cat(verbose, "Non-polymorphic loci to resample for TCN:");
+ str(verbose, idxsNonSNP);
+ cat(verbose, "Heterozygous SNPs with non-DH to resample for TCN:");
+ str(verbose, idxsHetNonDH);
+ }
+ # Note that length(idxsHetNonDH) may differ from zero in case CT is non-missing
+ # but rho is missing, e.g. CT = sum(c(thetaA,thetaB), na.rm=TRUE) and
+ # thetaB is missing. /HB 2010-12-01
+
+ idxsTCN <- sort(unique(c(idxsHet, idxsHom, idxsNonSNP)));
+ if (verbose) {
+ cat(verbose, "Loci to resample for TCN:");
+ str(verbose, idxsTCN);
+ }
+
+ # Sanity check
+ if (.validate) {
+ stopifnot(length(idxsHet) + length(idxsHom) + length(idxsNonSNP) == nbrOfTCNs);
+ stopifnot(length(intersect(idxsDH, idxsHetNonDH)) == 0L);
+ stopifnot(length(idxsTCN) == nbrOfTCNs);
+ }
+
+ verbose && exit(verbose);
+
+
+ # These numbers should be preserved when the resampling
+ verbose && printf(verbose, "Number of (#hets, #homs, #nonSNPs): (%d,%d,%d)\n",
+ length(idxsHet), length(idxsHom), length(idxsNonSNP));
+
+ # Workaround: ... Why? /HB 2013-10-22
+ shouldHaveDHs <- (nbrOfDHs > 0L && !is.na(dhMeans[jj]));
+ if (!shouldHaveDHs) {
+ idxsHetNonDH <- idxsDH;
+ stopifnot(all(idxsHetNonDH > 0L));
+ }
+ shouldHaveDHs <- NULL; # Not needed anymore
+
+ nHoms <- length(idxsHom);
+ nNonSNPs <- length(idxsNonSNP);
+ nHetNonDHs <- length(idxsHetNonDH);
+
+ locusSetJJ <- list(
+ segment = segJJ,
+ loci = list(
+ all = idxsAll,
+ snp = idxsSNP,
+ tcn = idxsTCN,
+ dh = idxsDH,
+ nonSnp = idxsNonSNP,
+ het = idxsHet,
+ hom = idxsHom,
+ hetNonDh = idxsHetNonDH
+ )
+ );
+
+ # Sanity checks
+ if (.validate) {
+ loci <- locusSetJJ$loci;
+ for (key in names(loci)) {
+ idxs <- loci[[key]];
+ # Assert positive indices
+ stopifnot(all(idxs > 0L));
+ # Assert a unique set of indices
+ stopifnot(!any(duplicated(idxs)));
+ }
+ # Assert non-overlapping sets
+ with(loci, {
+ stopifnot(length(intersect(dh, hetNonDh)) == 0L);
+ stopifnot(length(intersect(het, hom)) == 0L);
+ stopifnot(length(intersect(het, nonSnp)) == 0L);
+ stopifnot(length(intersect(hom, nonSnp)) == 0L);
+ });
+ loci <- NULL; # Not needed anymore
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Identify bootstrap locus sets preserving (#hets, #homs, #nonSNPs)
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Identifying bootstrap locus sets that preservs (#hets, #homs, #nonSNPs)");
+ verbose && cat(verbose, "Number of bootstrap samples: ", B);
+
+ nbrOfTCNs <- nbrOfDHs+nHoms+nNonSNPs;
+ nbrOfHets <- nbrOfDHs+nHetNonDHs;
+
+ # Allocate index matrices
+ tcn <- matrix(NA_integer_, nrow=nbrOfTCNs, ncol=B);
+ dh <- matrix(NA_integer_, nrow=nbrOfDHs, ncol=B);
+ nonSnp <- matrix(NA_integer_, nrow=nNonSNPs, ncol=B);
+ het <- matrix(NA_integer_, nrow=nbrOfHets, ncol=B);
+ hom <- matrix(NA_integer_, nrow=nHoms, ncol=B);
+ hetNonDh <- matrix(NA_integer_, nrow=nHetNonDHs, ncol=B);
+
+## resample <- function(x, size, ...) {
+## stopifnot(size == length(x));
+## x;
+## } # resample()
+
+ # (1) Bootstrap DH loci
+ if (nbrOfDHs > 0L) {
+ # (a) Resample heterozygous SNPs (=> resampled DH units)
+ for (bb in seq_len(B)) {
+ dh[,bb] <- resample(idxsDH, size=nbrOfDHs, replace=TRUE);
+ }
+ }
+
+ # (2) Bootstrap other loci
+ # (a) Resample non-DH hets SNPs
+ if (nHetNonDHs > 0L) {
+ for (bb in seq_len(B)) {
+ idxsHetNonDHBB <- resample(idxsHetNonDH, size=nHetNonDHs, replace=TRUE);
+ hetNonDh[,bb] <- idxsHetNonDHBB;
+ }
+ }
+
+ # (b) Resample homozygous SNPs
+ if (nHoms > 0L) {
+ for (bb in seq_len(B)) {
+ idxsHomBB <- resample(idxsHom, size=nHoms, replace=TRUE);
+ hom[,bb] <- idxsHomBB;
+ }
+ }
+
+ # (c) Resample non-SNPs
+ if (nNonSNPs > 0L) {
+ for (bb in seq_len(B)) {
+ idxsNonSNPBB <- resample(idxsNonSNP, size=nNonSNPs, replace=TRUE);
+ nonSnp[,bb] <- idxsNonSNPBB;
+ }
+ }
+
+ # (d) Resampled hets
+ if (nbrOfHets > 0L) {
+ for (bb in seq_len(B)) {
+ idxsDHBB <- dh[,bb];
+ idxsHetNonDHBB <- hetNonDh[,bb];
+ idxsHetBB <- c(idxsDHBB, idxsHetNonDHBB);
+# idxsHetBB <- sort(idxsHetBB);
+ het[,bb] <- idxsHetBB;
+ }
+ }
+
+ # (e) Update TCN loci
+ if (nbrOfTCNs > 0L) {
+ for (bb in seq_len(B)) {
+ idxsHetBB <- het[,bb];
+ idxsHomBB <- hom[,bb];
+ idxsNonSNPBB <- nonSnp[,bb];
+ idxsTCNBB <- c(idxsHetBB, idxsHomBB, idxsNonSNPBB);
+# idxsTCNBB <- sort(idxsTCNBB);
+ tcn[,bb] <- idxsTCNBB;
+ }
+ }
+
+ # Record
+ locusSetJJ$bootstrap <- list(
+ B = B,
+ loci = list(
+ tcn = tcn,
+ dh = dh,
+ nonSnp = nonSnp,
+ het = het,
+ hom = hom,
+ hetNonDh = hetNonDh
+ )
+ );
+
+ # Sanity check
+ if (.validate) {
+ loci <- locusSetJJ$loci;
+ lociB <- locusSetJJ$bootstrap$loci;
+ for (key in names(lociB)) {
+ idxs <- loci[[key]];
+ idxsB <- lociB[[key]];
+ idxsB <- unique(sort(idxsB));
+ stopifnot(all(is.element(idxsB, idxs)));
+ }
+ loci <- lociB <- NULL; # Not needed anymore
+ }
+
+ verbose && exit(verbose);
+
+ # Record
+ locusSet[[jj]] <- locusSetJJ;
+
+ # Not needed anymore
+ locusSetJJ <- NULL;
+ verbose && exit(verbose);
+ } # for (jj ...)
+
+ # Sanity checks
+ stopifnot(is.list(locusSet));
+ stopifnot(length(locusSet) == nbrOfSegments);
+
+ verbose && exit(verbose);
+
+ res$locusSet <- locusSet;
+
+ res;
+}, protected=TRUE) # getBootstrapLocusSets()
+
+
+##############################################################################
+# HISTORY
+# 2013-10-22
+# o Added Rdoc comments.
+# o Added getBootstrapLocusSets() for PairedPSCBS.
+##############################################################################
diff --git a/R/PairedPSCBS.CALL.R b/R/PairedPSCBS.CALL.R
new file mode 100644
index 0000000..6c5b9f4
--- /dev/null
+++ b/R/PairedPSCBS.CALL.R
@@ -0,0 +1,159 @@
+setMethodS3("callABandHighAI", "PairedPSCBS", function(fit, deltaAB=estimateDeltaAB(fit), alphaAB=0.05, deltaHighAI=0.60, alphaHighAI=0.05, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Calling segments to be in allelic balance (AB) or extreme allelic imbalance (AI)");
+
+ # Calculate DH confidence intervals, if not already done
+ probs <- sort(unique(c(alphaAB, alphaHighAI)));
+ probs <- sort(unique(c(probs, 1-probs)));
+ fit <- bootstrapTCNandDHByRegion(fit, probs=probs, ..., verbose=less(verbose, 50));
+
+ # Call allelic balance
+ fit <- callAllelicBalanceByDH(fit, delta=deltaAB, alpha=alphaAB, ..., verbose=less(verbose, 1));
+
+ # Call high allelic imbalance
+ fit <- callExtremeAllelicImbalanceByDH(fit, delta=deltaHighAI, alpha=alphaHighAI, ..., verbose=less(verbose, 1));
+
+ verbose && exit(verbose);
+
+ fit;
+}, private=TRUE) # callABandHighAI()
+
+
+setMethodS3("callABandLowC1", "PairedPSCBS", function(fit, deltaAB=estimateDeltaAB(fit), alphaAB=0.05, deltaLowC1=0.50, alphaLowC1=0.05, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Calling segments to be in allelic balance (AB) or low minor copy number (low C1)");
+
+ # Calculate DH confidence intervals, if not already done
+ probs <- sort(unique(c(alphaAB, alphaLowC1)));
+ probs <- sort(unique(c(probs, 1-probs)));
+ fit <- bootstrapTCNandDHByRegion(fit, probs=probs, ..., verbose=less(verbose, 50));
+
+ # Call allelic balance
+ fit <- callAllelicBalanceByDH(fit, delta=deltaAB, alpha=alphaAB, ..., verbose=less(verbose, 1));
+
+ # Call high allelic imbalance
+ fit <- callLowC1ByC1(fit, delta=deltaLowC1, alpha=alphaLowC1, ..., verbose=less(verbose, 1));
+
+ verbose && exit(verbose);
+
+ fit;
+}, private=TRUE) # callABandLowC1()
+
+
+
+setMethodS3("extractCallsByLocus", "PairedPSCBS", function(fit, ...) {
+ # Extract locus data
+ data <- getLocusData(fit, ...);
+
+ nbrOfLoci <- nrow(data);
+
+ # Extract segment data
+ segs <- getSegments(fit, splitters=TRUE);
+
+ # Identify segment calls
+ callCols <- grep("Call$", colnames(segs));
+ nbrOfCalls <- length(callCols);
+
+
+ chromosome <- data$chromosome;
+ x <- data$x;
+ y <- data[,3];
+
+ # Allocate locus calls
+ naValue <- as.logical(NA);
+ callsL <- matrix(naValue, nrow=nbrOfLoci, ncol=nbrOfCalls);
+ colnames(callsL) <- colnames(segs)[callCols];
+ callsL <- as.data.frame(callsL);
+
+ # For each segment...
+ for (ss in seq(length=nrow(segs))) {
+ seg <- segs[ss,];
+ idxs <- which(chromosome == seg$chromosome &
+ seg$tcnStart <= x & x <= seg$tcnEnd);
+ idxs <- Arguments$getIndices(idxs, max=nbrOfLoci);
+ # Sanity check
+## stopifnot(length(idxs) == seg$tcnNbrOfLoci);
+
+ callsSS <- seg[callCols];
+ for (cc in seq(length=nbrOfCalls)) {
+ callsL[idxs,cc] <- callsSS[,cc];
+ }
+ } # for (ss ...)
+
+ # The calls for loci that have missing annotations or observations,
+ # should also be missing, i.e. NA.
+ nok <- (is.na(chromosome) | is.na(x) | is.na(y));
+ callsL[nok,] <- as.logical(NA);
+
+ # Sanity check
+ stopifnot(nrow(callsL) == nbrOfLoci);
+ stopifnot(ncol(callsL) == nbrOfCalls);
+
+ callsL;
+}, private=TRUE) # extractCallsByLocus()
+
+
+
+##############################################################################
+# HISTORY
+# 2013-03-22
+# o Added extractCallsByLocus() for PairedPSCBS.
+# 2011-06-14
+# o Updated code to recognize new column names.
+# 2011-05-29
+# o Renamed all arguments, variables, function named 'tau' to 'delta'.
+# 2011-02-03
+# o Updated default for 'tauAB' of callABandHighAI() and callABandLowC1()
+# to be estimated from data using estimateTauAB().
+# 2010-12-07
+# o Added callLowC1ByC1() and callABandLowC1().
+# 2010-11-27
+# o Corrected verbose output to call results.
+# 2010-11-26 [HB]
+# o Now all call functions estimate symmetric bootstrap quantiles for
+# convenince of plotting confidence intervals.
+# o BUG FIX: callABandHighAI() for PairedPSCBS used the old DH-only
+# bootstrap method.
+# o BUG FIX: The call functions, for instance callABandHighAI(), would throw
+# 'Error in quantile.default(x, probs = alpha) : missing values and NaN's
+# not allowed if 'na.rm' is FALSE' unless bootstrapTCNandDHByRegion() was
+# run before.
+# 2010-11-22 [HB]
+# o Added more verbose output to callABandHighAI().
+# o Updated callAllelicBalanceByDH() and callExtremeAllelicImbalanceByDH()
+# to utilize bootstrapTCNandDHByRegion().
+# 2010-10-25 [HB]
+# o Relaced argument 'ciRange' with 'alpha' for callAllelicBalanceByDH() and
+# callExtremeAllelicImbalanceByDH().
+# o Renamed callAllelicBalance() to callAllelicBalanceByDH() and
+# callExtremeAllelicImbalanceByDH() to callExtremeAllelicImbalance().
+# o Added arguments 'alphaAB' and 'alphaHighAI' to callABandHighAI().
+# o Added sanity checks to the call methods.
+# o Now arguments '...' to callABandHighAI() are passed down.
+# o Now also arguments '...' to callAllelicBalance() and
+# callExtremeAllelicImbalance() are passed to bootstrapDHByRegion().
+# o Added argument 'ciRange' to callAllelicBalance() and
+# callExtremeAllelicImbalance().
+# 2010-09-16 [HB]
+# o Added callABandHighAI().
+# o Added callAllelicBalance() and callExtremeAllelicImbalance().
+# o Created.
+##############################################################################
diff --git a/R/PairedPSCBS.EXTS.R b/R/PairedPSCBS.EXTS.R
new file mode 100644
index 0000000..1d7aaf9
--- /dev/null
+++ b/R/PairedPSCBS.EXTS.R
@@ -0,0 +1,547 @@
+setMethodS3("shiftTCN", "PairedPSCBS", function(fit, shift, update=TRUE, ...) {
+ # Argument 'shift':
+ shift <- Arguments$getDouble(shift, disallow=c("NA", "NaN", "Inf"));
+
+ data <- getLocusData(fit);
+ data$CT <- data$CT + shift;
+ fit$data <- data;
+ # Not needed anymore
+ data <- NULL;
+
+ if (update) {
+ fit <- updateMeans(fit, ...);
+ }
+
+ fit;
+}, protected=TRUE)
+
+
+setMethodS3("bootstrapCIs", "PairedPSCBS", function(fit, ...) {
+ # ...
+}, private=TRUE)
+
+
+###########################################################################/**
+# @set "class=PairedPSCBS"
+# @RdocMethod extractTCNAndDHs
+#
+# @title "Extract TCN and DH mean levels per segment"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Arguments passed to \code{getSegments()}.}
+# }
+#
+# \value{
+# Returns a @data.frame.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# @seemethod "extractMinorMajorCNs".
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("extractTCNAndDHs", "PairedPSCBS", function(fit, ...) {
+ segs <- getSegments(fit, ...);
+ stopifnot(!is.null(segs));
+
+ data <- segs[,c("tcnMean", "dhMean", "tcnNbrOfLoci", "dhNbrOfLoci"), drop=FALSE];
+ data;
+}, protected=TRUE)
+
+
+
+###########################################################################/**
+# @set "class=PairedPSCBS"
+# @RdocMethod extractMinorMajorCNs
+# @aliasmethod extractC1C2
+#
+# @title "Extract minor and major copy-number mean levels per segment"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns a @data.frame.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# @seemethod "extractTCNAndDHs"
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("extractMinorMajorCNs", "PairedPSCBS", function(fit, ...) {
+ data <- extractTCNAndDHs(fit, ...);
+
+ gamma <- data[,1L];
+ rho <- data[,2L];
+ C1 <- 1/2*(1-rho)*gamma;
+ C2 <- gamma - C1;
+
+ data[,1L] <- C1;
+ data[,2L] <- C2;
+ colnames(data)[1:2] <- c("C1", "C2");
+
+ # Swap (C1,C2)?
+ segs <- getSegments(fit, ...);
+ flipped <- segs$c1c2Swap;
+ if (!is.null(flipped)) {
+ idxs <- which(flipped);
+ if (length(idxs) > 0L) {
+ data[idxs,1:2] <- data[idxs,2:1];
+ }
+ }
+
+ data;
+}, protected=TRUE)
+
+
+setMethodS3("extractC1C2", "PairedPSCBS", function(...) {
+ extractMinorMajorCNs(...);
+}, protected=TRUE)
+
+
+setMethodS3("extractCNs", "PairedPSCBS", function(fit, splitters=TRUE, ...) {
+ data <- extractC1C2(fit, splitters=splitters, ...);
+ data[,c("C1", "C2"), drop=FALSE];
+})
+
+
+setMethodS3("extractDeltaC1C2", "PairedPSCBS", function(...) {
+ xy <- extractC1C2(..., splitters=TRUE, addGaps=TRUE);
+ X <- xy[,1:2,drop=FALSE];
+ dX <- colDiffs(X);
+ dX;
+}, protected=TRUE)
+
+
+
+setMethodS3("postsegmentTCN", "PairedPSCBS", function(fit, ..., force=FALSE, verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Post-segmenting TCNs");
+
+ flavor <- fit$params$flavor;
+ if (!force && regexpr("&", flavor, fixed=TRUE) != -1) {
+ verbose && cat(verbose, "Nothing to do. Already postsegmentTCN:ed: ", flavor);
+ verbose && exit(verbose);
+ return(fit);
+ }
+
+ joinSegments <- fit$params$joinSegments;
+ if (!joinSegments) {
+ throw("Postsegmentation of TCNs is only implemented for the case when joinSegments=TRUE: ", joinSegments);
+ }
+
+
+ # Get mean estimators
+ estList <- getMeanEstimators(fit, "tcn");
+ avgTCN <- estList$tcn;
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract the data and segmentation results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fit);
+
+ segs <- getSegments(fit);
+ keep <- is.finite(segs$chromosome);
+ segs <- segs[keep,,drop=FALSE];
+ tcnSegRows <- fit$tcnSegRows[keep,,drop=FALSE];
+ dhSegRows <- fit$dhSegRows[keep,,drop=FALSE];
+
+ # Sanity check
+ stopifnot(nrow(dhSegRows) == nrow(tcnSegRows));
+ stopifnot(all(tcnSegRows[,1] <= tcnSegRows[,2], na.rm=TRUE));
+# stopifnot(all(tcnSegRows[-nrow(tcnSegRows),2] < tcnSegRows[-1,1], na.rm=TRUE));
+ stopifnot(all(dhSegRows[,1] <= dhSegRows[,2], na.rm=TRUE));
+ stopifnot(all(dhSegRows[-nrow(dhSegRows),2] < dhSegRows[-1,1], na.rm=TRUE));
+
+
+ nbrOfSegments <- nrow(segs);
+ verbose && cat(verbose, "Number of segments: ", nbrOfSegments);
+
+ chromosome <- data$chromosome;
+ x <- data$x;
+ CT <- data$CT;
+ muN <- data$muN;
+ rho <- data$rho;
+ hasDH <- !is.null(rho)
+ if (hasDH) {
+ isHet <- !is.na(rho)
+ isSnp <- isHet
+ } else {
+ isSnp <- !is.na(muN)
+ isHet <- (isSnp & (muN == 1/2))
+ }
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Update the TCN segments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ chromosomes <- getChromosomes(fit);
+ nbrOfChromosomes <- length(chromosomes);
+ verbose && cat(verbose, "Number of chromosomes: ", nbrOfChromosomes);
+ verbose && print(verbose, chromosomes);
+
+ for (cc in seq(length=nbrOfChromosomes)) {
+ chr <- chromosomes[cc];
+ chrTag <- sprintf("chr%02d", chr);
+ verbose && enter(verbose, sprintf("Chromosome %d ('%s') of %d", cc, chrTag, nbrOfChromosomes));
+ rows <- which(is.element(segs[["chromosome"]], chr));
+ verbose && cat(verbose, "Rows:");
+ verbose && print(verbose, rows);
+
+ segsCC <- segs[rows,,drop=FALSE];
+ tcnSegRowsCC <- tcnSegRows[rows,,drop=FALSE];
+ dhSegRowsCC <- dhSegRows[rows,,drop=FALSE];
+ nbrOfSegmentsCC <- nrow(segsCC);
+ verbose && cat(verbose, "Number of segments: ", nbrOfSegmentsCC);
+
+ tcnIds <- sort(unique(segsCC[["tcnId"]]));
+ I <- length(tcnIds);
+ for (ii in seq(length=I)) {
+ tcnId <- tcnIds[ii];
+ verbose && enter(verbose, sprintf("TCN segment #%d ('%s') of %d", ii, tcnId, I));
+
+ rowsII <- which(segsCC[["tcnId"]] == tcnId);
+ J <- length(rowsII);
+ # Nothing todo?
+ if (!force && J == 1) {
+ verbose && cat(verbose, "Nothing todo. Only one DH segmentation. Skipping.");
+ verbose && exit(verbose);
+ next;
+ }
+
+ verbose && cat(verbose, "Rows:");
+ verbose && print(verbose, rowsII);
+ segsII <- segsCC[rowsII,,drop=FALSE];
+
+ tcnSegRowsII <- tcnSegRowsCC[rowsII,,drop=FALSE];
+ dhSegRowsII <- dhSegRowsCC[rowsII,,drop=FALSE];
+
+ verbose && cat(verbose, "TCN & DH segRows before:");
+ verbose && print(verbose, cbind(tcn=tcnSegRowsII, dh=dhSegRowsII));
+
+ segRowsRange <- range(c(tcnSegRowsII, dhSegRowsII), na.rm=TRUE);
+ verbose && printf(verbose, "Range [%d,%d]\n",
+ segRowsRange[1], segRowsRange[2]);
+
+ tcnSegRowsIIBefore <- tcnSegRowsII;
+ nbrOfTCNsBefore <- segsII[1,"tcnNbrOfLoci"];
+ # Sanity check
+ stopifnot(diff(segRowsRange)+1L == nbrOfTCNsBefore);
+
+ for (jj in seq(length=J)) {
+ verbose && enter(verbose, sprintf("DH segment #%d of %d", jj, J));
+ seg <- segsII[jj,,drop=FALSE];
+ tcnSegRow <- unlist(tcnSegRowsII[jj,,drop=FALSE], use.names=FALSE);
+ dhSegRow <- unlist(dhSegRowsII[jj,,drop=FALSE], use.names=FALSE);
+ # Sanity check
+ stopifnot(all(is.na(tcnSegRow)) || (tcnSegRow[1] <= tcnSegRow[2]));
+ stopifnot(all(is.na(dhSegRow)) || (dhSegRow[1] <= dhSegRow[2]));
+
+ # Sanity check
+ idxsTCN <- tcnSegRow[1]:tcnSegRow[2];
+ nbrOfTCNs <- sum(!is.na(CT[idxsTCN]));
+ stopifnot(nbrOfTCNs == nbrOfTCNsBefore);
+
+ if (joinSegments) {
+ # (a) The TCN segment should have identical (start,end) boundaries as the DH region
+ xStart <- seg[["dhStart"]];
+ xEnd <- seg[["dhEnd"]];
+ verbose && printf(verbose, "[xStart,xEnd] = [%.0f,%.0f]\n", xStart, xEnd);
+ stopifnot(xStart <= xEnd);
+
+ # (b) Identify units
+ units <- which(chromosome == chr & xStart <= x & x <= xEnd);
+
+ # (c) Drop units that are outside both the TCN and DH segments
+ keep <- (segRowsRange[1] <= units & units <= segRowsRange[2]);
+ units <- units[keep];
+
+ tcnSegRow <- range(units);
+ verbose && printf(verbose, "[idxStart,idxEnd] = [%d,%d]\n", tcnSegRow[1], tcnSegRow[2]);
+ verbose && cat(verbose, "Number of TCN loci: ", length(units));
+
+ # (c) Adjust for missing values
+ keep <- which(!is.na(CT[units]));
+ units <- units[keep];
+
+ # (d) Adjust for DH boundaries
+ if (jj > 1L) {
+ minIdx <- tcnSegRowsII[jj-1L,2L, drop=TRUE];
+ units <- units[units > minIdx];
+ }
+ if (jj < J) {
+ maxIdx <- dhSegRowsII[jj+1L,1L, drop=TRUE];
+ units <- units[units < maxIdx];
+ }
+
+ if (jj == J) {
+# maxIdx <- dhSegRowsII[jj+1L,1L, drop=TRUE];
+# units <- units[units < maxIdx];
+ }
+
+ tcnSegRow <- range(units);
+ verbose && printf(verbose, "[idxStart,idxEnd] = [%d,%d]\n", tcnSegRow[1], tcnSegRow[2]);
+ verbose && cat(verbose, "Number of non-missing TCN loci: ", length(units));
+ } else {
+ throw("Not implemented yet.") # /HB 2010-12-02
+ } # if (joinSegments)
+
+ gamma <- avgTCN(CT[units]);
+ # Sanity check
+ stopifnot(length(units) == 0 || !is.na(gamma));
+
+ # Update the segment boundaries, estimates and counts
+ seg[["tcnStart"]] <- xStart;
+ seg[["tcnEnd"]] <- xEnd;
+ seg[["tcnMean"]] <- gamma;
+ seg[["tcnNbrOfLoci"]] <- length(units);
+ seg[["tcnNbrOfSNPs"]] <- sum(isSnp[units]);
+ seg[["tcnNbrOfHets"]] <- sum(isHet[units]);
+
+ # Sanity check
+ stopifnot(nrow(seg) == length(jj));
+
+ segsII[jj,] <- seg;
+ tcnSegRowsII[jj,] <- tcnSegRow;
+
+ verbose && exit(verbose);
+ } # for (jj ...)
+
+ # Sanity check
+ stopifnot(nrow(segsII) == length(rowsII));
+
+ verbose && cat(verbose, "TCN & DH segRows afterward:");
+ verbose && print(verbose, cbind(tcn=tcnSegRowsII, dh=dhSegRowsII));
+
+##print(segsII);
+
+ # Sanity check
+ nbrOfTCNsAfter <- sum(segsII[,"tcnNbrOfLoci"], na.rm=TRUE);
+ verbose && cat(verbose, "Number of TCNs before: ", nbrOfTCNsBefore);
+ verbose && cat(verbose, "Number of TCNs after: ", nbrOfTCNsAfter);
+ stopifnot(nbrOfTCNsAfter >= nbrOfTCNsBefore);
+
+ # Sanity check
+ stopifnot(nrow(dhSegRowsII) == nrow(tcnSegRowsII));
+ stopifnot(all(tcnSegRowsII[,1] <= tcnSegRowsII[,2], na.rm=TRUE));
+ stopifnot(all(tcnSegRowsII[-nrow(tcnSegRowsII),2] < tcnSegRowsII[-1,1], na.rm=TRUE));
+ stopifnot(all(dhSegRowsII[,1] <= dhSegRowsII[,2], na.rm=TRUE));
+ stopifnot(all(dhSegRowsII[-nrow(dhSegRowsII),2] < dhSegRowsII[-1,1], na.rm=TRUE));
+
+ segsCC[rowsII,] <- segsII;
+ tcnSegRowsCC[rowsII,] <- tcnSegRowsII;
+
+ # Not needed anymore
+ rowsII <- segsII <- NULL;
+ verbose && exit(verbose);
+ } # for (ii ...)
+
+ # Sanity check
+ stopifnot(nrow(segsCC) == length(rows));
+
+ # Sanity check
+ stopifnot(nrow(dhSegRowsCC) == nrow(tcnSegRowsCC));
+ stopifnot(all(tcnSegRowsCC[,1] <= tcnSegRowsCC[,2], na.rm=TRUE));
+####################
+if (!all(tcnSegRowsCC[-nrow(tcnSegRowsCC),2] < tcnSegRowsCC[-1,1], na.rm=TRUE)) {
+
+ aa <- tcnSegRowsCC[-nrow(tcnSegRowsCC),2];
+ bb <- tcnSegRowsCC[-1,1];
+ delta <- bb - aa;
+ dd <- cbind(aa, bb, delta=delta);
+ print(dd);
+ dd <- subset(dd, delta == 0);
+ print(dd);
+ row <- dd[,1L,drop=TRUE];
+ print(row);
+ rr <- row + -10:10;
+ dd <- data[rr,];
+ rownames(dd) <- rr;
+ print(dd);
+print(tcnSegRowsII);
+}
+####################
+
+ stopifnot(all(tcnSegRowsCC[-nrow(tcnSegRowsCC),2] < tcnSegRowsCC[-1,1], na.rm=TRUE));
+ stopifnot(all(dhSegRowsCC[,1] <= dhSegRowsCC[,2], na.rm=TRUE));
+ stopifnot(all(dhSegRowsCC[-nrow(dhSegRowsCC),2] < dhSegRowsCC[-1,1], na.rm=TRUE));
+
+ segs[rows,] <- segsCC;
+ tcnSegRows[rows,] <- tcnSegRowsCC;
+
+ # Not needed anymore
+ rows <- segsCC <- NULL;
+ verbose && exit(verbose);
+ } # for (cc ...)
+
+ # Sanity check
+ stopifnot(nrow(dhSegRows) == nrow(tcnSegRows));
+ stopifnot(all(tcnSegRows[,1] <= tcnSegRows[,2], na.rm=TRUE));
+ stopifnot(all(tcnSegRows[-nrow(tcnSegRows),2] < tcnSegRows[-1,1], na.rm=TRUE));
+ stopifnot(all(dhSegRows[,1] <= dhSegRows[,2], na.rm=TRUE));
+ stopifnot(all(dhSegRows[-nrow(dhSegRows),2] < dhSegRows[-1,1], na.rm=TRUE));
+
+ verbose && enter(verbose, "Update (C1,C2) per segment");
+ # Append (C1,C2) estimates
+ tcn <- segs$tcnMean;
+ dh <- segs$dhMean;
+ C1 <- 1/2*(1-dh)*tcn;
+ C2 <- tcn - C1;
+ segs$c1Mean <- C1;
+ segs$c2Mean <- C2;
+ verbose && exit(verbose);
+
+ # Return results
+ keep <- which(is.finite(fit$output$chromosome));
+ fitS <- fit;
+ fitS$data <- data;
+ fitS$output[keep,] <- segs;
+ fitS$tcnSegRows[keep,] <- tcnSegRows;
+
+ # Sanity check
+ tcnSegRows <- fitS$tcnSegRows;
+ dhSegRows <- fitS$dhSegRows;
+ stopifnot(nrow(dhSegRows) == nrow(tcnSegRows));
+ stopifnot(all(tcnSegRows[,1] <= tcnSegRows[,2], na.rm=TRUE));
+ stopifnot(all(tcnSegRows[-nrow(tcnSegRows),2] < tcnSegRows[-1,1], na.rm=TRUE));
+ stopifnot(all(dhSegRows[,1] <= dhSegRows[,2], na.rm=TRUE));
+ stopifnot(all(dhSegRows[-nrow(dhSegRows),2] < dhSegRows[-1,1], na.rm=TRUE));
+
+ # Update 'flavor'
+ fitS$params$flavor <- gsub(",", "&", flavor, fixed=TRUE);
+
+ verbose && exit(verbose);
+
+ fitS;
+}, protected=TRUE) # postsegmentTCN()
+
+
+
+
+############################################################################
+# HISTORY:
+# 2013-08-15
+# o Made extractMinorMajorCNs() for PairedPSCBS acknowledge the
+# 'c1c2Swap' field.
+# 2013-01-15
+# o Now postsegmentTCN() uses the params$avgTCN estimator, iff given.
+# 2012-09-21
+# o ROBUSTNESS: Now extractDeltaC1C2() for PairedPSCBS makes sure to
+# retrieve segments with NA splitters between chromosomes and gaps.
+# 2012-09-13
+# o Added shiftTCN() for PairedPSCBS.
+# 2012-01-21
+# o CLEANUP: Removed left-over debug output in postsegmentTCN().
+# 2012-01-09
+# o Minor correction of a verbose message in postsegmentTCN().
+# 2011-10-16
+# o Added extractCNs().
+# 2011-10-14
+# o Now extractTCNAndDHs() passes '...' to getSegments().
+# 2011-10-02
+# o CLEANUP: Dropped empty callSegments() for PairedPSCBS.
+# 2011-06-14
+# o Updated code to recognize new column names.
+# 2011-04-08
+# o BUG FIX: postsegmentTCN() for PairedPSCBS could generate an invalid
+# 'tcnSegRows' matrix, where the indices for two consecutive segments
+# would overlap, which is invalid.
+# 2011-04-05
+# o BUG FIX: estimateHighDHQuantileAtAB() for PairedPSCBS would throw
+# an error on an undefined 'trim' if verbose output was used.
+# 2011-02-17
+# o Added arguments 'robust' and 'trim' to estimateMeanForDH().
+# 2011-02-03
+# o Added argument 'tauTCN' to estimateMeanForDH().
+# 2011-01-27
+# o Added flavor="DHskew" to estimateTauAB().
+# o Added flavor="DH" to estimateTauAB() to estimate from DH instead
+# of hBAF. As argued by the equations in the comments, these two
+# approaches gives virtually the same results. The advantage with the
+# DH approach is that it requires one less degree of freedom.
+# o Added estimateMeanForDH().
+# 2011-01-18
+# o BUG FIX: 'tcnSegRows' and 'dhSegRows' where not updated by
+# extractByRegions() for PairedPSCBS.
+# 2011-01-14
+# o Added estimateTauAB() for estimating the DeltaAB parameter.
+# o Added estimateStdDevForHeterozygousBAF() for PairedPSCBS.
+# o BUG FIX: extractByRegions() did not handle the case where multiple loci
+# at the same position are split up in two different segments.
+# 2011-01-12
+# o Added extractByRegions() and extractByRegion() for PairedPSCBS.
+# o Now postsegmentTCN(..., force=TRUE) for PairedPSCBS also updates
+# the TCN estimates even for segments where the DH segmentation did
+# not find any additional change points.
+# 2010-12-02
+# o Now postsegmentTCN() assert that total number of TCN loci before
+# and after is the same.
+# o Now postsegmentTCN() assert that joinSegment is TRUE.
+# 2010-12-01
+# o Now postsegmentTCN() checks if it is already postsegmented.
+# 2010-11-30
+# o TODO: postsegmentTCN() does not make sure of 'dhLociToExclude'. Why?
+# o Now postsegmentTCN() recognizes the new 'tcnLociToExclude'.
+# 2010-11-28
+# o BUG FIX: postsegmentTCN() did not handle loci with the same positions
+# and that are split in two different segments. It also did not exclude
+# loci with missing values.
+# 2010-11-21
+# o Adjusted postsegmentTCN() such that the updated TCN segment boundaries
+# are the maximum of the DH segment and the support by the loci. This
+# means that postsegmentTCN() will work as expected both when signals
+# where segmented with 'joinSegments' being TRUE or FALSE.
+# 2010-10-25
+# o Now subsetByDhSegments() for PairedPSCBS handles the rare case when
+# markers with the same positions are split in two different segments.
+# o Renamed subsetBySegments() for PairedPSCBS to subsetByDhSegments().
+# 2010-09-26
+# o Now subsetBySegments() for PairedPSCBS handles multiple chromosomes.
+# o Now postsegmentTCN() PairedPSCBS handles multiple chromosomes.
+# 2010-09-21
+# o Added postsegmentTCN() for PairedPSCBS.
+# 2010-09-19
+# o BUG FIX: plot() used non-defined nbrOfLoci; now length(x).
+# 2010-09-15
+# o Added subsetBySegments().
+# o Added linesC1C2() and arrowsC1C2().
+# o Now the default 'cex' for pointsC1C2() corresponds to 'dh.num.mark'.
+# o Now extractTotalAndDH() also returns 'dh.num.mark'.
+# 2010-09-08
+# o Added argument 'add=FALSE' to plot().
+# o Added plotC1C2().
+# o Added extractTotalAndDH() and extractMinorMajorCNs().
+# 2010-09-04
+# o Added drawLevels() for PairedPSCBS.
+# o Added as.data.frame() and print() for PairedPSCBS.
+# 2010-09-03
+# o Added plot() for PairedPSCBS.
+# o Created.
+############################################################################
diff --git a/R/PairedPSCBS.EXTS3.R b/R/PairedPSCBS.EXTS3.R
new file mode 100644
index 0000000..fec6b49
--- /dev/null
+++ b/R/PairedPSCBS.EXTS3.R
@@ -0,0 +1,169 @@
+setMethodS3("extractLocusLevelC1C2", "PairedPSCBS", function(fit, ...) {
+ data <- getLocusData(fit);
+ C <- data$CT;
+ rho <- data$rho;
+ C1 <- 1/2*(1-rho)*C;
+ C2 <- C-C1;
+ data.frame(C1=C1, C2=C2);
+}, private=TRUE) # extractLocusLevelC1C2()
+
+
+setMethodS3("extractLocusLevelTCN", "PairedPSCBS", function(fit, ...) {
+ data <- getLocusData(fit);
+ C <- data$CT;
+}, private=TRUE) # extractLocusLevelTCN()
+
+
+
+setMethodS3("extractDhSegment", "PairedPSCBS", function(fit, idx, what=c("hets", "SNPs", "all"), ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'what':
+ what <- match.arg(what);
+
+
+ segs <- getSegments(fit, splitters=TRUE);
+ stopifnot(!is.null(segs));
+ nbrOfSegments <- nrow(segs);
+
+ # Argument 'idx':
+ idx <- Arguments$getIndex(idx, max=nbrOfSegments);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+
+ verbose && enter(verbose, "Extracting a specific DH segment");
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract the data and segmentation results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fit);
+ stopifnot(!is.null(data));
+
+ segs <- getSegments(fit, splitters=TRUE);
+ stopifnot(!is.null(segs));
+
+ verbose && enter(verbose, "Subsetting segment");
+ # Subset the region-level data
+ seg <- segs[idx,,drop=FALSE];
+
+ isDivider <- all(is.na(seg));
+ if (isDivider) {
+ verbose && cat("Cannot extract DH segment. Not a valid segment: ", idx);
+ verbose && exit(verbose);
+ return(NULL);
+ }
+
+ verbose && print(verbose, seg);
+ verbose && cat(verbose, "Number of TCN markers: ", sum(seg[["tcnNbrOfLoci"]], na.rm=TRUE));
+ verbose && exit(verbose);
+
+ verbose && enter(verbose, "Subsetting data");
+ units <- seq(length=nrow(data));
+
+ # Keep only chromosome of interest
+ chr <- as.numeric(seg[,"chromosome"]);
+ if (!is.na(chr)) {
+ keep <- which(data$chromosome == chr);
+ units <- units[keep];
+ data <- data[keep,];
+ }
+
+ # Keep only loci within the segment
+ xRange <- as.numeric(seg[,c("dhStart", "dhEnd")]);
+ keep <- which(xRange[1] <= data$x & data$x <= xRange[2]);
+ units <- units[keep];
+ data <- data[keep,];
+
+ muN <- data$muN;
+ isSnp <- is.finite(muN);
+
+ # Keep only SNPs?
+ if (is.element(what, c("SNPs", "hets"))) {
+ keep <- which(isSnp);
+ units <- units[keep];
+ data <- data[keep,];
+ }
+
+ # Keep only heterozygous SNPs?
+ if (what == "hets") {
+ isHet <- (muN == 1/2);
+ keep <- which(isHet);
+ units <- units[keep];
+ data <- data[keep,];
+ }
+ verbose && exit(verbose);
+
+ n <- nrow(data);
+ verbose && cat(verbose, "Number of loci in DH segment: ", n);
+
+ # Special case?
+ listOfDhLociNotPartOfSegment <- fit$listOfDhLociNotPartOfSegment;
+ if (!is.null(listOfDhLociNotPartOfSegment)) {
+ tcnId <- seg[,"tcnId"];
+ dhId <- seg[,"dhId"];
+ dhLociNotPartOfSegment <- listOfDhLociNotPartOfSegment[[tcnId]];
+ if (!is.null(dhLociNotPartOfSegment)) {
+ lociToExclude <- dhLociNotPartOfSegment[[dhId]];
+ verbose && cat(verbose, "Excluding loci that belongs to a flanking segment: ", length(lociToExclude));
+ drop <- match(lociToExclude, units);
+ units <- units[-drop];
+ data <- data[-drop,];
+ n <- nrow(data);
+ }
+ }
+
+ verbose && cat(verbose, "Number of units: ", n);
+ verbose && cat(verbose, "Number of TCN markers: ", seg[,"tcnNbrOfLoci"]);
+
+ # Sanity check
+ if (what == "hets" && n > 0) stopifnot(n == seg[,"dhNbrOfLoci"]);
+
+ fitS <- fit;
+ fitS$data <- data;
+ fitS$output <- seg;
+
+ verbose && exit(verbose);
+
+ fitS;
+}, protected=TRUE) # extractDhSegment()
+
+
+############################################################################
+# HISTORY:
+# 2012-02-24
+# o Added extractDhSegment() for PairedPSCBS, which was copied "as is"
+# from the aroma.cn package. The below history has been updated to
+# document changes in this method too.
+# 2012-02-23
+# o Made extractDhSegment() protected.
+# 2011-10-08
+# o ROBUSTIFICATION: Uses drop=FALSE in mergeTwoSegments() for PairedPSCBS.
+# 2010-10-26 [HB]
+# o Added extractDhSegment() for PairedPSCBS.
+# 2011-10-02
+# o DOCUMENTATION: Added Rdoc help to mergeTwoSegments() & dropByRegions().
+# o Added verbose statements to the above to functions.
+# 2011-06-14
+# o Updated code to recognize new column names.
+# 2011-01-18
+# o BUG FIX: Fields 'tcnSegRows' and 'dhSegRows' were not updated by
+# mergeTwoSegments() for PairedPSCBS.
+# 2011-01-14
+# o Moved extractByRegions() and estimateStdDevForHeterozygousBAF() to
+# psCBS v0.9.36.
+# o Now extractByRegions() utilizes the 'segRows' field.
+# o Added estimateStdDevForHeterozygousBAF().
+# 2011-01-12
+# o Added updateMeans() for PairedPSCBS.
+# o Added dropByRegions().
+# o Added extractByRegions() and extractByRegion().
+# o Created.
+############################################################################
diff --git a/R/PairedPSCBS.PLOT,many.R b/R/PairedPSCBS.PLOT,many.R
new file mode 100644
index 0000000..0902b7f
--- /dev/null
+++ b/R/PairedPSCBS.PLOT,many.R
@@ -0,0 +1,688 @@
+# \item{chromosomes}{An optional @numeric @vector specifying which
+# chromosomes to plot.}
+#
+# \item{seed}{An (optional) @integer specifying the random seed to be
+# set before subsampling. The random seed is
+# set to its original state when exiting. If @NULL, it is not set.}
+#
+# \item{verbose}{See @see "R.utils::Verbose".}
+#
+setMethodS3("plotTracksManyChromosomes", "PairedPSCBS", function(fit, chromosomes=getChromosomes(fit), tracks=NULL, scatter="*", calls=if (callLoci || length(chromosomes) == 1L) ".*" else NULL, callLoci=FALSE, callThresholds=TRUE, boundaries=TRUE, knownSegments=FALSE, quantiles=c(0.05,0.95), seed=0xBEEF, pch=".", Clim=c(0,3*ploidy(fit)), Blim=c(0,1), xScale=1e-6, xlabTicks=if (length(chromosomes) == 1L) "[pos]" else "[chr]", ..., subset=if (length(chromosomes) > 1L) 0.1 else NULL, add=FA [...]
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Local functions
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ attachGH <- function(gh, envir=parent.frame()) {
+ if (!is.list(gh)) return();
+ if (is.null(gh$track)) return();
+ if (!is.null(value <- gh$track)) assign("track", value, envir=envir);
+ if (!is.null(value <- gh$subtracks)) assign("trackT", value, envir=envir);
+ if (!is.null(value <- gh$scatter$col)) assign("colS", value, envir=envir);
+ if (!is.null(value <- gh$scatter$pch)) assign("pchT", value, envir=envir);
+ if (!is.null(value <- gh$level$col)) assign("colL", value, envir=envir);
+ if (!is.null(value <- gh$cis$col)) assign("colC", value, envir=envir);
+ } # attachGH()
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Graphical styles
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ opts <- list(
+ scatter = list(pch=".", col=c("#aaaaaa")),
+ callScatter = list(col=c("#aaaaaa", LOSS="blue", GAIN="red", LOH="purple")),
+ smoothScatter = list(pch=".", col=c("#666666")),
+ level = list(lty=1L, col=c("black", tcn="purple", c1="blue", c2="red", dh="orange")),
+ callLevel = list(lty=1L, col=c("#666666")),
+ knownSegment = list(lty=1L, col=c("#aaaaaa"))
+ );
+
+ getOptionValue <- function(option, what, track, ...) {
+ values <- opts[[option]][[what]];
+ value <- values[track];
+ if (is.na(value)) value <- values[1L];
+ unname(value);
+ } # getOptionValue()
+
+ getScatterColor <- function(track, ...) {
+ getOptionValue("scatter", "col", track, ...);
+ } # getScatterColor()
+
+ getLevelColor <- function(track, ...) {
+ getOptionValue("level", "col", track, ...);
+ } # getLevelColor()
+
+ getCallScatterColor <- function(track, ...) {
+ getOptionValue("callScatter", "col", track, ...);
+ } # getCallScatterColor()
+
+ getCallLevelColor <- function(track, ...) {
+ getOptionValue("callLevel", "col", track, ...);
+ } # getCallLevelColor()
+
+ getCallLevelLty <- function(track, ...) {
+ getOptionValue("callLevel", "lty", track, ...);
+ } # getCallLevelColor()
+
+ getCIColor <- function(track, ...) {
+ getLevelColor(track, ...);
+ } # getLevelColor()
+
+ getKnownSegmentColor <- function(track, ...) {
+ getOptionValue("knownSegment", "col", track, ...);
+ } # getKnownSegmentColor()
+
+ getKnownSegmentLty <- function(track, ...) {
+ getOptionValue("knownSegment", "lty", track, ...);
+ } # getKnownSegmentColor()
+
+ drawXLabelTicks <- function() {
+ if (identical(xlabTicks, "[chr]")) {
+ mtext(text=chrTags, side=rep(c(1,3), length.out=length(chrTags)), at=mids, line=0.1, cex=0.7);
+ } else if (identical(xlabTicks, "[pos]")) {
+ axis(side=1L);
+ }
+ }
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'fit':
+
+ # Argument 'chromosomes':
+ if (!is.null(chromosomes)) {
+ disallow <- c("NaN", "Inf");
+ chromosomes <- Arguments$getIntegers(chromosomes, range=c(0,Inf), disallow=disallow);
+ stopifnot(is.element(chromosomes, getChromosomes(fit)));
+ }
+
+ # Argument 'tracks':
+ knownTracks <- c("tcn", "dh", "tcn,c1,c2", "c1,c2", "c1", "c2",
+ "betaN", "betaT", "betaTN");
+ defaultTracks <- knownTracks[1:3];
+ if (is.null(tracks)) {
+ tracks <- defaultTracks;
+ } else {
+ tracks <- match.arg(tracks, choices=knownTracks, several.ok=TRUE);
+ tracks <- unique(tracks);
+ }
+
+ # Argument 'scatter':
+ if (!is.null(scatter)) {
+ scatter <- Arguments$getCharacter(scatter);
+ if (scatter == "*") {
+ scatter <- tracks;
+ } else {
+ scatterT <- strsplit(scatter, split=",", fixed=TRUE);
+ tracksT <- strsplit(tracks, split=",", fixed=TRUE);
+ stopifnot(all(is.element(scatterT, tracksT)));
+ # Not needed anymore
+ scatterT <- tracksT <- NULL;
+ }
+ }
+
+ # Argument 'calls':
+ if (!is.null(calls)) {
+ calls <- sapply(calls, FUN=Arguments$getRegularExpression);
+ }
+
+ # Argument 'callLoci':
+ callLoci <- Arguments$getLogical(callLoci);
+
+ # Argument 'callThresholds':
+ callThresholds <- Arguments$getLogical(callThresholds);
+
+ # Argument 'boundaries':
+ boundaries <- Arguments$getLogical(boundaries);
+
+ # Argument 'knownSegments':
+ knownSegments <- Arguments$getLogical(knownSegments);
+
+ # Argument 'add':
+ add <- Arguments$getLogical(add);
+
+ # Argument 'Clim' & 'Blim':
+ if (!add) {
+ Clim <- Arguments$getNumerics(Clim, length=c(2L,2L),
+ disallow=c("Inf", "NA", "NaN"));
+ Blim <- Arguments$getNumerics(Blim, length=c(2L,2L),
+ disallow=c("Inf", "NA", "NaN"));
+ }
+
+ # Argument 'xScale':
+ xScale <- Arguments$getNumeric(xScale, range=c(0,Inf));
+
+ # Argument 'xlabTicks':
+ if (!is.null(xlabTicks)) {
+ xlabTicks <- Arguments$getCharacter(xlabTicks);
+ }
+
+ # Argument 'subset':
+ if (!is.null(subset)) {
+ subset <- Arguments$getDouble(subset);
+ }
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Plotting PSCN tracks");
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Subset by chromosomes
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (!is.null(chromosomes)) {
+ verbose && enter(verbose, "Plotting a subset of the chromosomes");
+ fit <- extractChromosomes(fit, chromosomes=chromosomes, verbose=verbose);
+ verbose && exit(verbose);
+ }
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Tile chromosomes
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fit <- tileChromosomes(fit, verbose=verbose);
+ verbose && str(verbose, fit);
+
+ # Extract the input data
+ data <- getLocusData(fit);
+ if (is.null(data)) {
+ throw("Cannot plot segmentation results. No input data available.");
+ }
+
+ # Extract the segmentation
+ segs <- as.data.frame(fit);
+
+ # Identify available calls
+ callData <- NULL;
+ if (!is.null(calls) || callThresholds) {
+ verbose && enter(verbose, "Identifying calls");
+
+ pattern <- "Call$";
+ allCallColumns <- grep(pattern, colnames(segs), value=TRUE);
+ allCallLabels <- toupper(gsub(pattern, "", allCallColumns));
+ verbose && cat(verbose, "Call columns:");
+ verbose && print(verbose, allCallColumns);
+
+ if (!is.null(calls)) {
+ callColumns <- allCallColumns;
+ if (length(callColumns) > 0L) {
+ keep <- sapply(calls, FUN=function(pattern) {
+ (regexpr(pattern, callColumns) != -1L);
+ });
+ if (is.matrix(keep)) {
+ keep <- rowAnys(keep);
+ }
+ callColumns <- callColumns[keep];
+ callLabels <- allCallLabels[keep];
+
+ # Annotate individual loci by calls?
+ if (callLoci) {
+ callData <- extractCallsByLocus(fit, verbose=less(verbose,5));
+ }
+ }
+ verbose && cat(verbose, "Call to be annotated:");
+ verbose && print(verbose, callColumns);
+ }
+
+ verbose && exit(verbose);
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Subset of the loci?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (!is.null(subset)) {
+ # (a) Set and unset the random seed
+ if (!is.null(seed)) {
+ randomSeed("set", seed=seed, kind="L'Ecuyer-CMRG")
+ on.exit(randomSeed("reset"), add=TRUE)
+ verbose && printf(verbose, "Random seed temporarily set (seed=%d)\n", seed)
+ }
+
+ # (b) Subset
+ n <- nrow(data);
+ keep <- sample(n, size=subset*n);
+ data <- data[keep,];
+ if (!is.null(callData)) {
+ callData <- callData[keep,];
+ }
+ }
+
+ # To please R CMD check
+ CT <- rho <- muN <- betaT <- betaN <- betaTN <- rho <- NULL;
+ rm(list=c("CT", "rho", "muN", "betaT", "betaN", "betaTN"));
+ attachLocally(data);
+ # Calculate (C1,C2)
+ C1 <- 1/2*(1-rho)*CT;
+ C2 <- CT - C1;
+
+ # BACKWARD COMPATIBILITY:
+ # If 'rho' is not available, recalculate it from tumor BAFs.
+ # NOTE: This should throw an error in the future. /HB 2013-10-25
+ if (is.null(data$rho)) {
+ isSnp <- (!is.na(betaTN) & !is.na(muN));
+ isHet <- isSnp & (muN == 1/2);
+ rho <- rep(NA_real_, length=nbrOfLoci);
+ rho[isHet] <- 2*abs(betaTN[isHet]-1/2);
+ warning(sprintf("Locus-level DH signals ('rho') were not available in the %s object and therefore recalculated from the TumorBoost-normalized tumor BAFs ('betaTN').", class(fit)[1L]));
+ }
+
+ x <- xScale * x;
+ vs <- xScale * fit$chromosomeStats[,1:2,drop=FALSE];
+ mids <- (vs[,1]+vs[,2])/2;
+
+ nbrOfLoci <- length(x);
+ chrTags <- sprintf("Chr%02d", chromosomes);
+
+ if (subplots) {
+ subplots(length(tracks), ncol=1L);
+ par(oma=oma, mar=mar);
+ }
+
+ pchT <- if (!is.null(scatter)) { pch } else { NA };
+ xlim <- range(x, na.rm=TRUE);
+ xlab <- "Genomic position";
+
+ # Graphical handle
+ gh <- list(fit=fit);
+ gh$xScale <- xScale;
+ gh$xlim <- xlim;
+ gh$xlab <- xlab;
+ if (!is.null(callData)) {
+ gh$callsByLocus <- callData;
+ }
+
+ for (tt in seq(along=tracks)) {
+ track <- tracks[tt];
+ verbose && enter(verbose, sprintf("Track #%d ('%s') of %d",
+ tt, track, length(tracks)));
+
+ # Get graphical style parameters.
+ tracksT <- unlist(strsplit(track, split=",", fixed=TRUE));
+ colS <- sapply(tracksT, FUN=getScatterColor);
+ colL <- sapply(tracksT, FUN=getLevelColor);
+ colC <- sapply(tracksT, FUN=getCIColor);
+
+ # Color scatter plot according to calls?
+ if (!is.null(calls) && callLoci && length(callColumns) > 0L) {
+ colsT <- rep(colS[1L], times=nrow(callData));
+ for (cc in seq(along=callColumns)) {
+ callColumn <- callColumns[cc];
+ callLabel <- callLabels[cc];
+ verbose && enter(verbose, sprintf("Call #%d ('%s') of %d",
+ cc, callLabel, length(callColumns)));
+
+ verbose && cat(verbose, "Column: ", callColumn);
+
+ skip <- TRUE;
+ if (regexpr("tcn", track) != -1L) {
+ skip <- !is.element(callLabel, c("LOSS", "NTCN", "GAIN", "LOH"));
+ } else if (track == "dh") {
+ skip <- !is.element(callLabel, c("AB", "LOH"));
+ }
+ if (skip) {
+ verbose && exit(verbose);
+ next;
+ }
+
+ callsCC <- callData[[callColumn]];
+ idxs <- which(callsCC);
+ # Nothing to do?
+ if (length(idxs) == 0L) {
+ verbose && exit(verbose);
+ next;
+ }
+
+ callCol <- getCallScatterColor(callLabel);
+
+ colsT[idxs] <- callCol;
+ } # for (cc in ...)
+
+ colS <- colsT;
+ } # if (!is.null(calls))
+
+
+ # Assign graphical-handle parameters
+ gh$track <- track;
+ gh$subtracks <- tracksT;
+ gh$scatter <- list(col=colS, pch=pchT);
+ gh$level <- list(col=colL);
+ gh$cis <- list(col=colC);
+
+
+ if (track == "tcn") {
+ plot(NA, xlim=xlim, ylim=Clim, xlab=xlab, ylab="TCN", axes=FALSE);
+ if (!is.null(onBegin)) attachGH(onBegin(gh=gh));
+ if (!is.na(pchT)) {
+ points(x, CT, pch=pchT, col=colS);
+ }
+ drawConfidenceBands(fit, what="tcn", quantiles=quantiles, col=colC["tcn"], xScale=xScale);
+ drawLevels(fit, what="tcn", col=colL, xScale=xScale);
+ }
+
+ if (is.element(track, c("tcn,c1,c2", "c1,c2", "c1", "c2"))) {
+ tracksT <- unlist(strsplit(track, split=",", fixed=TRUE));
+ plot(NA, xlim=xlim, ylim=Clim, xlab=xlab, ylab="C1, C2, TCN", axes=FALSE);
+ if (!is.null(onBegin)) attachGH(onBegin(gh=gh));
+
+ # Draw scatter for TCN or C1 and C2.
+ if (!is.na(pchT)) {
+ if (is.element("tcn", tracksT)) {
+ points(x, CT, pch=pchT, col=colS);
+ } else {
+ if (is.element("c1", tracksT)) {
+ points(x, C1, pch=pchT, col=colS);
+ }
+ if (is.element("c2", tracksT)) {
+ points(x, C2, pch=pchT, col=colS);
+ }
+ }
+ }
+
+ # Draw confidence bands for TCN, C1, C2.
+ if (is.element("tcn", tracksT)) {
+ drawConfidenceBands(fit, what="tcn", quantiles=quantiles, col=colC["tcn"], xScale=xScale);
+ }
+ if (is.element("c2", tracksT)) {
+ drawConfidenceBands(fit, what="c2", quantiles=quantiles, col=colC["c2"], xScale=xScale);
+ }
+ if (is.element("c1", tracksT)) {
+ drawConfidenceBands(fit, what="c1", quantiles=quantiles, col=colC["c1"], xScale=xScale);
+ }
+
+ # Draw segment means for TCN, C1, C2.
+ if (is.element("tcn", tracksT)) {
+ drawLevels(fit, what="tcn", col=colL["tcn"], xScale=xScale);
+ }
+ if (is.element("c2", tracksT)) {
+ drawLevels(fit, what="c2", col=colL["c2"], xScale=xScale);
+ }
+ if (is.element("tcn", tracksT)) {
+ # In case C2 overlaps with TCN
+ drawLevels(fit, what="tcn", col=colL["tcn"], lty="22", xScale=xScale);
+ }
+ # In case C1 overlaps with C2
+ if (is.element("c1", tracksT)) {
+ drawLevels(fit, what="c1", col=colL["c1"], xScale=xScale);
+ if (is.element("c2", tracksT)) {
+ drawLevels(fit, what="c2", col=colL["c2"], lty="22", xScale=xScale);
+ }
+ if (is.element("tcn", tracksT)) {
+ drawLevels(fit, what="tcn", col=colL["tcn"], lty="22", xScale=xScale);
+ }
+ }
+ }
+
+ if (track == "betaN") {
+ plot(NA, xlim=xlim, ylim=Blim, xlab=xlab, ylab="BAF_N", axes=FALSE);
+ if (!is.null(onBegin)) attachGH(onBegin(gh=gh));
+ if (!is.na(pchT)) {
+ points(x, betaN, pch=pchT, col=colS);
+ }
+ }
+
+ if (track == "betaT") {
+ plot(NA, xlim=xlim, ylim=Blim, xlab=xlab, ylab="BAF_T", axes=FALSE);
+ if (!is.null(onBegin)) attachGH(onBegin(gh=gh));
+ if (!is.na(pchT)) {
+ points(x, betaT, pch=pchT, col=colS);
+ }
+ }
+
+ if (track == "betaTN") {
+ plot(NA, xlim=xlim, ylim=Blim, xlab=xlab, ylab="BAF_TN", axes=FALSE);
+ if (!is.null(onBegin)) attachGH(onBegin(gh=gh));
+ if (!is.na(pchT)) {
+ points(x, betaTN, pch=pchT, col=colS);
+ }
+ }
+
+ if (track == "dh") {
+ plot(NA, xlim=xlim, ylim=Blim, xlab=xlab, ylab="DH", axes=FALSE);
+ if (!is.null(onBegin)) attachGH(onBegin(gh=gh));
+ if (!is.na(pchT)) {
+ points(x, rho, pch=pchT, col=colS);
+ }
+ drawConfidenceBands(fit, what="dh", quantiles=quantiles, col=colC["dh"], xScale=xScale);
+ drawLevels(fit, what="dh", col=colL["dh"], xScale=xScale);
+ }
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # For each panel of tracks, annotate segments with calls?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (!is.null(calls) && !callLoci && length(callColumns) > 0L) {
+ for (cc in seq(along=callColumns)) {
+ callColumn <- callColumns[cc];
+ callLabel <- callLabels[cc];
+ verbose && enter(verbose, sprintf("Call #%d ('%s') of %d",
+ cc, callLabel, length(callColumns)));
+
+ verbose && cat(verbose, "Column: ", callColumn);
+
+ segsT <- segs[,c("dhStart", "dhEnd", callColumn)];
+ isCalled <- which(segsT[[callColumn]]);
+ segsT <- segsT[isCalled,1:2,drop=FALSE];
+ verbose && printf(verbose, "Number of segments called %s: %d\n",
+ callLabel, nrow(segsT));
+ segsT <- xScale * segsT;
+
+ verbose && str(verbose, segsT);
+
+ side <- 2*((cc+1) %% 2) + 1;
+ # For each segment called...
+ for (ss in seq(length=nrow(segsT))) {
+ x0 <- segsT[ss,1,drop=TRUE];
+ x1 <- segsT[ss,2,drop=TRUE];
+ abline(v=c(x0,x1), lty=3, col="gray");
+ xMid <- (x0+x1)/2;
+ mtext(side=side, at=xMid, line=-1, cex=0.7, col="#666666", callLabel);
+ } # for (ss in ...)
+ verbose && exit(verbose);
+ } # for (cc in ...)
+ } # if (!is.null(calls))
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # For each panel of tracks, annotate with call thresholds?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (callThresholds) {
+ # Add call parameter estimates, e.g. deltaAB
+ colCL <- sapply(tracksT, FUN=getCallLevelColor);
+ ltyCL <- sapply(tracksT, FUN=getCallLevelLty);
+
+ trackT <- track;
+ for (cc in seq(along=allCallColumns)) {
+ callColumn <- allCallColumns[cc];
+ callLabel <- allCallLabels[cc];
+
+ h <- NULL;
+ if (callLabel == "AB") {
+ if (track == "dh") {
+ h <- fit$params$deltaAB;
+ label <- expression(Delta[AB]);
+ }
+ } else if (callLabel == "LOH") {
+ if (regexpr("c1", track) != -1L) {
+ h <- fit$params$deltaLowC1;
+ label <- expression(Delta[LOH]);
+ trackT <- "c1";
+ }
+ } else if (callLabel == "NTCN") {
+ if (track == "tcn") {
+ h <- fit$params$ntcnRange;
+ label <- c(expression(Delta[-NTCN]), expression(Delta[+NTCN]));
+ }
+ }
+
+ if (!is.null(h)) {
+ abline(h=h, lty=ltyCL[trackT], lwd=2, col=colCL[trackT]);
+ for (ss in 1:2) {
+ side <- c(2,4)[ss];
+ adj <- c(1.2,-0.2)[ss];
+ mtext(side=side, at=h, label, adj=adj, las=2, xpd=TRUE);
+ }
+ }
+ } # for (cc in ...)
+ } # if (callThresholds)
+
+ drawXLabelTicks();
+ if (boundaries) {
+ abline(v=vs, lty=1, lwd=2);
+ }
+ if (knownSegments) {
+ colT <- getKnownSegmentColor();
+ ltyT <- getKnownSegmentLty();
+ drawKnownSegments(fit, col=colT, lty=ltyT);
+ }
+ axis(side=2); box();
+ if (!is.null(onEnd)) onEnd(gh=gh);
+
+ verbose && exit(verbose);
+ } # for (tt ...)
+
+ verbose && exit(verbose);
+
+ invisible(gh);
+}, private=TRUE) # plotTracksManyChromosomes()
+
+
+
+############################################################################
+# HISTORY:
+# 2013-10-28
+# o Now plotTracksManyChromosomes() also supports
+# tracks=c("c1,c2", "c1", "c2").
+# 2013-10-25
+# o Now plotTracksManyChromosomes() uses the locus data field 'rho'
+# when plotting DH locus-level data. It only recalculates it from
+# the tumor BAFs if the DH signals are not available - if so a
+# warning is generated.
+# 2013-10-20
+# o BUG FIX: plotTracksManyChromosomes() for PairedPSCBS would use
+# Blim=Clim, regardless of what argument 'Blim' was.
+# 2013-04-13
+# o Added argument 'boundaries' to plotTracksManyChromosomes().
+# 2013-04-11
+# o BUG FIX: plotTracksManyChromosomes(..., callLoci=TRUE) would color
+# loci incorrectly if more than one chromosome are plotted.
+# 2013-04-05
+# o Now plotTracks() passes more information to onBegin(gh)/onEnd(gh)
+# hooks via the graphical handle object, cf. str(gh).
+# 2013-03-21
+# o Added argument 'knownSegments' to plotTracksManyChromosomes().
+# o Generalized plotTracksManyChromosomes() a bit such that it can be
+# used for a single chromosome as well. All col and lty annotations
+# are now specified at the very top of the function.
+# 2013-03-18
+# o Now plotTracksManyChromosomes() draws AB and LOH call thresholds.
+# 2012-09-23
+# o Now plotTracks() [and plotTracksManyChromosomes()] draws segment levels
+# in TCN-C2-C1 order, and then goes back and draws C2 and TCN with dashed
+# lines, just in case C1 is overlapping C2 and C2 is overlapping TCN.
+# 2012-09-21
+# o ROBUSTNESS: Now drawChangePointsC1C2() and arrowsC1C2() for PairedPSCBS
+# makes sure to retrieve segments with NA splitters between chromosomes
+# and gaps.
+# 2012-02-29
+# o BUG FIX: plotTracks(..., add=TRUE) for PairedPSCBS would add TCNs
+# when BAFs and DHs where intended.
+# 2012-02-22
+# o BUG FIX: Argument 'calls' of plotTracks() for PairedPSCBS was ignored
+# if more than one chromosome was plotted.
+# 2011-12-03
+# o Added drawChangePointsC1C2() for PairedPSCBS.
+# o Added drawChangePoints() for PairedPSCBS.
+# 2011-11-12
+# o Added argument col="#00000033" to plotC1C2() and linesC1C2().
+# o Added argument 'oma' and 'mar' to plotTracksManyChromosomes() for
+# PairedPSCBS for setting graphical parameters when 'add' == FALSE.
+# 2011-09-30
+# o GENERALIZATION: Now drawLevels() for PairedPSCBS allows for drawing
+# segmentation results in 'betaT' space.
+# 2011-07-10
+# o BUG FIX: tileChromosomes() for PairedPSCBS was still assuming the
+# old naming convention of column names.
+# o ROBUSTNESS: Fixed partial argument matchings in arrowsC1C2() and
+# arrowsDeltaC1C2() for PairedPSCBS.
+# 2011-06-14
+# o Updated code to recognize new column names.
+# 2011-01-19
+# o Added argument 'subplots'.
+# 2011-01-18
+# o DOCUMENTATION: Documented more plotTracks() arguments for PairedPSCBS.
+# o Now plotTracks(..., add=TRUE) for PairedPSCBS plots to the current
+# figure/panel.
+# o Now plotTracks(..., add=FALSE) for PairedPSCBS only sets up subplots
+# if argument 'tracks' specifies more than one panel.
+# o Added argument 'col' to plotTracks() for PairedPSCBS.
+# 2011-01-12
+# o Added argument 'changepoints' to plotTracks() for PairedPSCBS for
+# highlightning change-point locations as vertical lines.
+# 2010-12-01
+# o Now using a default 'seed' for plotTracksManyChromosomes() such
+# that the scatter data in the plots are reproducible by default.
+# 2010-11-27
+# o BUG FIX: plotTracksManyChromosomes() would annotate called regions
+# incorrectly.
+# o Added more verbouse output to plotTracksManyChromosomes().
+# o Added missing argument 'verbose' to plotTracksManyChromosomes().
+# o plotTracksManyChromosomes() gained argument 'scatter'.
+# o REPRODUCIBILITY: plotTracksManyChromosomes() for PairedPSCBS gained
+# argument 'seed', because if 'subset' is specified then a random
+# subset of the data points are displayed.
+# 2010-11-26
+# o Added optional argument 'chromosomes' to plotTracks() to plot a
+# subset of all chromosomes.
+# o Now the default confidence intervals for plotTracks() is (0.05,0.95),
+# if existing.
+# 2010-11-22
+# o ROBUSTNESS: Now drawConfidenceBands() of PairedPSCBS silently does
+# nothing if the requested bootstrap quantiles are available.
+# o Added argument 'calls' to plotTracks() and plotTracksManyChromosomes()
+# for highlighing called regions.
+# 2010-11-21
+# o Now plotTracks() supports tracks "tcn,c1", "tcn,c2" and "c1,c2" too.
+# o Added argument 'xlim' to plotTracks() making it possible to zoom in.
+# o Now plotTracks() and plotTracksManyChromosomes() draws confidence
+# bands, iff argument quantiles is given.
+# o Added drawConfidenceBands() for PairedPSCBS.
+# 2010-11-09
+# o Added argument 'cex=1' to plotTracks().
+# o BUG FIX: It was not possible to plot BAF tracks with plotTracks().
+# 2010-10-20
+# o Added arguments 'onBegin' and 'onEnd' to plotTracksManyChromosomes().
+# 2010-10-18
+# o Now plotTracks() can plot whole-genome data.
+# o Now plotTracks() utilized plotTracksManyChromosomes() if there is
+# more than one chromosome.
+# o Added internal plotTracksManyChromosomes().
+# o Added internal tileChromosomes().
+# 2010-10-03
+# o Now the default is that plotTracks() for PairedPSCBS generated three
+# panels: (1) TCN, (2) DH, and (3) C1+C2+TCN.
+# o Added plotTracks() to be more explicit than just plot().
+# o Added argument 'xScale' to plot() for PairedPSCBS.
+# o Now plot() for PairedPSCBS adds a chromosome tag.
+# 2010-09-21
+# o Added argument 'what' to plot() for PairedPSCBS.
+# o Added postsegmentTCN() for PairedPSCBS.
+# 2010-09-19
+# o BUG FIX: plot() used non-defined nbrOfLoci; now length(x).
+# 2010-09-15
+# o Added subsetBySegments().
+# o Added linesC1C2() and arrowsC1C2().
+# o Now the default 'cex' for pointsC1C2() corresponds to 'dh.num.mark'.
+# o Now extractTotalAndDH() also returns 'dh.num.mark'.
+# 2010-09-08
+# o Added argument 'add=FALSE' to plot().
+# o Added plotC1C2().
+# o Added extractTotalAndDH() and extractMinorMajorCNs().
+# 2010-09-04
+# o Added drawLevels() for PairedPSCBS.
+# o Added as.data.frame() and print() for PairedPSCBS.
+# 2010-09-03
+# o Added plot() for PairedPSCBS.
+# o Created.
+############################################################################
diff --git a/R/PairedPSCBS.PLOT.R b/R/PairedPSCBS.PLOT.R
new file mode 100644
index 0000000..2199e99
--- /dev/null
+++ b/R/PairedPSCBS.PLOT.R
@@ -0,0 +1,971 @@
+###########################################################################/**
+# @set "class=PairedPSCBS"
+# @RdocMethod plotTracks
+# @aliasmethod plotTracks1
+# @aliasmethod plotTracks2
+# @aliasmethod plotTracksManyChromosomes
+# @alias plot
+#
+# @title "Plots parental specific copy numbers along the genome"
+#
+# \description{
+# @get "title" for one or more chromosomes.
+# It is possible to specify what type of tracks to plot.
+# Each type of track is plotted in its own panel.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{x}{A result object returned by @see "segmentByPairedPSCBS".}
+# \item{tracks}{A @character @vector specifying what types of tracks to plot.}
+# \item{scatter}{A @character @vector specifying which of the tracks should
+# have scatter plot.}
+# \item{calls}{A @character @vector of regular expression identifying
+# call labels to be highlighted in the panels.}
+# \item{pch}{The type of the scatter points, if any.}
+# \item{col}{The color of the scatter points, if any.}
+# \item{cex}{The size of the scatter points, if any.}
+# \item{changepoints}{If @TRUE, changepoints are drawn as vertical lines.}
+# \item{grid}{If @TRUE, horizontal lines are displayed.}
+# \item{quantiles}{A @numeric @vector in [0,1] specifying the quantiles
+# of the confidence bands to be drawn, if any.}
+# \item{xlim}{(Optional) The genomic range to plot.}
+# \item{Clim}{The range of copy numbers.}
+# \item{Blim}{The range of allele B fractions (BAFs) and
+# decrease of heterozygosity (DHs).}
+# \item{xScale}{The scale factor used for genomic positions.}
+# \item{...}{Not used.}
+# \item{add}{If @TRUE, the panels plotted are added to the existing plot,
+# otherwise a new plot is created.}
+# \item{subplots}{If @TRUE, then subplots are automatically setup.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns nothing.
+# }
+#
+# @author "HB"
+#
+# @keyword IO
+# @keyword internal
+#*/###########################################################################
+setMethodS3("plotTracks1", "PairedPSCBS", function(x, tracks=c("tcn", "dh", "tcn,c1,c2", "tcn,c1", "tcn,c2", "c1,c2", "betaN", "betaT", "betaTN")[1:3], scatter="*", calls=".*", pch=".", col=NULL, cex=1, changepoints=FALSE, grid=FALSE, quantiles=c(0.05,0.95), xlim=NULL, Clim=c(0,3*ploidy(x)), Blim=c(0,1), xScale=1e-6, ..., add=FALSE, subplots=!add && (length(tracks) > 1), verbose=FALSE) {
+
+ # To please R CMD check
+ fit <- x;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'add':
+ add <- Arguments$getLogical(add);
+
+ # Argument 'Clim' & 'Blim':
+ if (!add) {
+ Clim <- Arguments$getNumerics(Clim, length=c(2L,2L),
+ disallow=c("Inf", "NA", "NaN"));
+ Blim <- Arguments$getNumerics(Blim, length=c(2L,2L),
+ disallow=c("Inf", "NA", "NaN"));
+ }
+
+ # Argument 'fit':
+ if (nbrOfChromosomes(fit) >= 1L) {
+ return(plotTracksManyChromosomes(fit, tracks=tracks, scatter=scatter, calls=calls, pch=pch, quantiles=quantiles, Clim=Clim, Blim=Blim, xScale=xScale, ..., add=add, subplots=subplots, verbose=verbose));
+ }
+
+ # Argument 'tracks':
+ knownTracks <- c("tcn", "dh", "tcn,c1,c2", "tcn,c1", "tcn,c2", "c1,c2", "betaN", "betaT", "betaTN");
+ tracks <- match.arg(tracks, choices=knownTracks, several.ok=TRUE);
+ tracks <- unique(tracks);
+
+ # Argument 'scatter':
+ if (!is.null(scatter)) {
+ scatter <- Arguments$getCharacter(scatter);
+ if (scatter == "*") {
+ scatter <- tracks;
+ } else {
+ scatterT <- strsplit(scatter, split=",", fixed=TRUE);
+ tracksT <- strsplit(tracks, split=",", fixed=TRUE);
+ stopifnot(all(is.element(scatterT, tracksT)));
+ # Not needed anymore
+ scatterT <- tracksT <- NULL;
+ }
+ }
+
+ # Argument 'calls':
+ if (!is.null(calls)) {
+ calls <- sapply(calls, FUN=Arguments$getRegularExpression);
+ }
+
+ # Argument 'changepoints':
+ changepoints <- Arguments$getLogical(changepoints);
+
+ # Argument 'grid':
+ grid <- Arguments$getLogical(grid);
+
+ # Argument 'xlim':
+ if (!is.null(xlim)) {
+ xlim <- Arguments$getNumerics(xlim, length=c(2,2));
+ }
+
+ # Argument 'xScale':
+ xScale <- Arguments$getNumeric(xScale, range=c(0,Inf));
+
+ # Argument 'subplots':
+ subplots <- Arguments$getLogical(subplots);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Plotting PSCN tracks");
+
+ # Extract the input data
+ data <- getLocusData(fit);
+ if (is.null(data)) {
+ throw("Cannot plot segmentation results. No input data available.");
+ }
+
+ chromosomes <- getChromosomes(fit);
+ chromosome <- chromosomes[1];
+ x <- data$x;
+ CT <- data$CT;
+ rho <- data$rho;
+ betaT <- data$betaT;
+ betaN <- data$betaN;
+ betaTN <- data$betaTN;
+ muN <- data$muN;
+ rho <- data$rho
+ hasDH <- !is.null(rho)
+ if (hasDH) {
+ isHet <- !is.na(rho)
+ isSnp <- isHet
+ } else {
+ isSnp <- (!is.na(betaTN) & !is.na(muN))
+ isHet <- isSnp & (muN == 1/2)
+ }
+ nbrOfLoci <- length(x)
+
+ # BACKWARD COMPATIBILITY:
+ # If 'rho' is not available, recalculate it from tumor BAFs.
+ # NOTE: This should throw an error in the future. /HB 2013-10-25
+ if (!hasDH) {
+ rho <- rep(NA_real_, length=nbrOfLoci);
+ rho[isHet] <- 2*abs(betaTN[isHet]-1/2);
+ warning(sprintf("Locus-level DH signals ('rho') were not available in the %s object and therefore recalculated from the TumorBoost-normalized tumor BAFs ('betaTN').", class(fit)[1L]));
+ }
+
+ # Extract the segmentation
+ segs <- as.data.frame(fit);
+
+ # Identify available calls
+ if (!is.null(calls)) {
+ verbose && enter(verbose, "Identifying calls");
+
+ pattern <- "Call$";
+ callColumns <- grep(pattern, colnames(segs), value=TRUE);
+ if (length(callColumns) > 0) {
+ keep <- sapply(calls, FUN=function(pattern) {
+ (regexpr(pattern, callColumns) != -1);
+ });
+ if (is.matrix(keep)) {
+ keep <- rowAnys(keep);
+ }
+ callColumns <- callColumns[keep];
+ callLabels <- gsub(pattern, "", callColumns);
+ callLabels <- toupper(callLabels);
+ }
+ verbose && cat(verbose, "Call columns:");
+ verbose && print(verbose, callColumns);
+
+ verbose && exit(verbose);
+ } else {
+ callColumns <- NULL;
+ }
+
+ if (chromosome != 0) {
+ chrTag <- sprintf("Chr%02d", chromosome);
+ } else {
+ chrTag <- "";
+ }
+
+ if (xScale != 1) {
+ x <- xScale * x;
+ if (!is.null(xlim)) {
+ xlim <- xScale * xlim;
+ }
+ }
+
+ if (subplots) {
+ subplots(length(tracks), ncol=1);
+ par(mar=c(1,4,1,2)+1);
+ }
+
+ # Color loci by heterozygous vs homozygous
+ if (hasDH) {
+ colMu <- c("gray", "black")[!is.na(rho) + 1]
+ } else {
+ colMu <- c("gray", "black")[(muN == 1/2) + 1]
+ }
+
+ for (tt in seq(along=tracks)) {
+ track <- tracks[tt];
+ verbose && enter(verbose, sprintf("Track #%d ('%s') of %d",
+ tt, track, length(tracks)));
+
+ if (!is.null(scatter)) {
+ pchT <- pch;
+ colT <- col;
+ } else {
+ pchT <- NA;
+ colT <- NA;
+ }
+
+ if (track == "tcn") {
+ colT <- ifelse(is.null(colT), "black", colT);
+ if (add) {
+ points(x, CT, pch=pchT, col=colT, cex=cex);
+ } else {
+ plot(x, CT, pch=pchT, col=colT, cex=cex, xlim=xlim, ylim=Clim, ylab="TCN");
+ stext(side=3, pos=1, chrTag);
+ if (grid) {
+ abline(h=seq(from=0, to=Clim[2], by=2), lty=3, col="gray");
+ abline(h=0, lty=1, col="black");
+ }
+ drawConfidenceBands(fit, what="tcn", quantiles=quantiles, col="purple", xScale=xScale);
+ drawLevels(fit, what="tcn", col="purple", xScale=xScale);
+ }
+ }
+
+ if (is.element(track, c("tcn,c1,c2", "tcn,c1", "tcn,c2", "c1,c2"))) {
+ colT <- ifelse(is.null(colT), "black", colT);
+ subtracks <- strsplit(track, split=",", fixed=TRUE)[[1]];
+ ylab <- paste(toupper(subtracks), collapse=", ");
+ if (add) {
+ points(x, CT, pch=pchT, cex=cex, col=colT);
+ } else {
+ plot(x, CT, pch=pchT, cex=cex, col=colT, xlim=xlim, ylim=Clim, ylab=ylab);
+ stext(side=3, pos=1, chrTag);
+ if (grid) {
+ abline(h=seq(from=0, to=Clim[2], by=2), lty=3, col="gray");
+ abline(h=0, lty=1, col="black");
+ }
+ if (is.element("tcn", subtracks)) {
+ drawConfidenceBands(fit, what="tcn", quantiles=quantiles, col="purple", xScale=xScale);
+ }
+ if (is.element("c2", subtracks)) {
+ drawConfidenceBands(fit, what="c2", quantiles=quantiles, col="red", xScale=xScale);
+ }
+ if (is.element("c1", subtracks)) {
+ drawConfidenceBands(fit, what="c1", quantiles=quantiles, col="blue", xScale=xScale);
+ }
+ if (is.element("tcn", subtracks)) {
+ drawLevels(fit, what="tcn", col="purple", xScale=xScale);
+ }
+ if (is.element("c2", subtracks)) {
+ drawLevels(fit, what="c2", col="red", xScale=xScale);
+ # In case C2 overlaps with TCN
+ if (is.element("tcn", subtracks)) {
+ drawLevels(fit, what="tcn", col="purple", lty="22", xScale=xScale);
+ }
+ }
+ if (is.element("c1", subtracks)) {
+ drawLevels(fit, what="c1", col="blue", xScale=xScale);
+ # In case C1 overlaps with C1
+ if (is.element("c2", subtracks)) {
+ drawLevels(fit, what="c2", col="red", lty="22", xScale=xScale);
+ if (is.element("tcn", subtracks)) {
+ drawLevels(fit, what="tcn", col="purple", lty="22", xScale=xScale);
+ }
+ }
+ }
+ }
+ }
+
+ if (track == "betaN") {
+ colT <- ifelse(is.null(colT), colMu, colT);
+ if (add) {
+ points(x, betaN, pch=pchT, cex=cex, col="black");
+ } else {
+ plot(x, betaN, pch=pchT, cex=cex, col=colT, xlim=xlim, ylim=Blim, ylab=expression(BAF[N]));
+ stext(side=3, pos=1, chrTag);
+ }
+ }
+
+ if (track == "betaT") {
+ colT <- ifelse(is.null(colT), colMu, colT);
+ if (add) {
+ points(x, betaT, pch=pchT, cex=cex, col="black");
+ } else {
+ plot(x, betaT, pch=pchT, cex=cex, col=colT, xlim=xlim, ylim=Blim, ylab=expression(BAF[T]));
+ stext(side=3, pos=1, chrTag);
+ }
+ }
+
+ if (track == "betaTN") {
+ colT <- ifelse(is.null(colT), colMu, colT);
+ if (add) {
+ points(x, betaTN, pch=pchT, cex=cex, col="black");
+ } else {
+ plot(x, betaTN, pch=pchT, cex=cex, col=colT, xlim=xlim, ylim=Blim, ylab=expression(BAF[T]^"*"));
+ stext(side=3, pos=1, chrTag);
+ }
+ }
+
+ if (track == "dh") {
+ colT <- ifelse(is.null(colT), colMu[isHet], colT);
+ if (add) {
+ points(x, rho, pch=pchT, cex=cex, col="black");
+ } else {
+ plot(x, rho, pch=pchT, cex=cex, col=colT, xlim=xlim, ylim=Blim, ylab="DH");
+ stext(side=3, pos=1, chrTag);
+ drawConfidenceBands(fit, what="dh", quantiles=quantiles, col="orange", xScale=xScale);
+ drawLevels(fit, what="dh", col="orange", xScale=xScale);
+ }
+ }
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Draw change points?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (changepoints) {
+ drawChangePoints(fit, col="#666666", xScale=xScale);
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # For each panel of tracks, annotate with calls?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (length(callColumns) > 0) {
+ for (cc in seq(along=callColumns)) {
+ callColumn <- callColumns[cc];
+ callLabel <- callLabels[cc];
+ verbose && enter(verbose, sprintf("Call #%d ('%s') of %d",
+ cc, callLabel, length(callColumns)));
+
+ verbose && cat(verbose, "Column: ", callColumn);
+
+ segsT <- segs[,c("dhStart", "dhEnd", callColumn)];
+ isCalled <- which(segsT[[callColumn]]);
+ segsT <- segsT[isCalled,1:2,drop=FALSE];
+ verbose && printf(verbose, "Number of segments called %s: %d\n",
+ callLabel, nrow(segsT));
+ segsT <- xScale * segsT;
+
+ verbose && str(verbose, segsT);
+
+ side <- 2*((cc+1) %% 2) + 1;
+ # For each segment called...
+ for (ss in seq(length=nrow(segsT))) {
+ x0 <- segsT[ss,1,drop=TRUE];
+ x1 <- segsT[ss,2,drop=TRUE];
+ abline(v=c(x0,x1), lty=3, col="gray");
+ xMid <- (x0+x1)/2;
+ mtext(side=side, at=xMid, line=-1, cex=0.7, col="#666666", callLabel);
+ } # for (ss in ...)
+ verbose && exit(verbose);
+ } # for (cc in ...)
+
+ # Add call parameter estimates, e.g. deltaAB
+ for (cc in seq(along=callColumns)) {
+ callColumn <- callColumns[cc];
+ callLabel <- callLabels[cc];
+ h <- NULL;
+ if (callLabel == "AB") {
+ if (track == "dh") {
+ h <- fit$params$deltaAB;
+ label <- expression(Delta[AB]);
+ colT <- "orange";
+ }
+ } else if (callLabel == "LOH") {
+ if (regexpr("c1", track) != -1L) {
+ h <- fit$params$deltaLowC1;
+ label <- expression(Delta[LOH]);
+ colT <- "blue";
+ }
+ } else if (callLabel == "NTCN") {
+ if (track == "tcn") {
+ h <- fit$params$ntcnRange;
+ label <- c(expression(Delta[-NTCN]), expression(Delta[+NTCN]));
+ colT <- "purple";
+ }
+ }
+
+ if (!is.null(h)) {
+ abline(h=h, lty=4, lwd=2, col=colT);
+ for (ss in 1:2) {
+ side <- c(2,4)[ss];
+ adj <- c(1.2,-0.2)[ss];
+ mtext(side=side, at=h, label, adj=adj, las=2, xpd=TRUE);
+ }
+ }
+ } # for (cc in ...)
+ } # if (length(callColumns) > 0)
+
+ verbose && exit(verbose);
+ } # for (tt ...)
+
+ verbose && exit(verbose);
+
+ invisible();
+}, private=TRUE) # plotTracks1()
+
+
+setMethodS3("plotTracks", "PairedPSCBS", function(fit, ...) {
+ plotTracksManyChromosomes(fit, ...);
+})
+
+setMethodS3("plot", "PairedPSCBS", function(x, ...) {
+ plotTracks(x, ...);
+}, private=TRUE)
+
+
+setMethodS3("drawLevels", "PairedPSCBS", function(fit, what=c("tcn", "betaTN", "dh", "c1", "c2"), lend=1L, xScale=1e-6, ...) {
+ # WORKAROUND: If Hmisc is loaded after R.utils, it provides a buggy
+ # capitalize() that overrides the one we want to use. Until PSCBS
+ # gets a namespace, we do the following workaround. /HB 2011-07-14
+ capitalize <- R.utils::capitalize;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'what':
+ what <- match.arg(what);
+
+ # Argument 'xScale':
+ xScale <- Arguments$getNumeric(xScale, range=c(0,Inf));
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Tile chromosomes
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fitT <- tileChromosomes(fit);
+
+ # Get segmentation results
+ segs <- as.data.frame(fitT);
+
+ if (what == "betaTN") {
+ whatT <- "dh";
+ } else {
+ whatT <- what;
+ }
+
+ # Extract subset of segments
+ fields <- c("start", "end");
+ fields <- sprintf("%s%s", ifelse(what == "tcn", what, "dh"), capitalize(fields));
+ fields <- c(fields, sprintf("%sMean", whatT));
+ segsT <- segs[,fields, drop=FALSE];
+ segsT <- unique(segsT);
+
+ if (what == "betaTN") {
+ dh <- segsT[,"dhMean"];
+ bafU <- (1 + dh)/2;
+ bafL <- (1 - dh)/2;
+ segsT[,3] <- bafU;
+ segsT[,4] <- bafL;
+ }
+
+ # Reuse drawLevels() for the DNAcopy class
+ for (cc in seq(from=3, to=ncol(segsT))) {
+ segsTT <- segsT[,c(1:2,cc)];
+ colnames(segsTT) <- c("loc.start", "loc.end", "seg.mean");
+ dummy <- list(output=segsTT);
+ class(dummy) <- "DNAcopy";
+ drawLevels(dummy, lend=lend, xScale=xScale, ...);
+ } # for (cc ...)
+}, private=TRUE)
+
+
+setMethodS3("drawConfidenceBands", "PairedPSCBS", function(fit, what=c("tcn", "dh", "c1", "c2"), quantiles=c(0.05,0.95), col=col, alpha=0.4, xScale=1e-6, ...) {
+ # WORKAROUND: If Hmisc is loaded after R.utils, it provides a buggy
+ # capitalize() that overrides the one we want to use. Until PSCBS
+ # gets a namespace, we do the following workaround. /HB 2011-07-14
+ capitalize <- R.utils::capitalize;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'what':
+ what <- match.arg(what);
+
+ # Argument 'quantiles':
+ if (!is.null(quantiles)) {
+ quantiles <- Arguments$getNumerics(quantiles, range=c(0,1), length=c(2,2));
+ }
+
+ # Argument 'xScale':
+ xScale <- Arguments$getNumeric(xScale, range=c(0,Inf));
+
+
+ # Nothing todo?
+ if (is.null(quantiles)) {
+ return();
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Tile chromosomes
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fitT <- tileChromosomes(fit);
+
+ # Get segmentation results
+ segs <- as.data.frame(fitT);
+
+ # Extract subset of segments
+ fields <- c("start", "end");
+ fields <- sprintf("%s%s", ifelse(what == "tcn", what, "dh"), capitalize(fields));
+
+ tags <- sprintf("%g%%", 100*quantiles);
+ qFields <- sprintf("%s_%s", what, tags);
+
+ # Nothing todo?
+ if (!all(is.element(qFields, colnames(segs)))) {
+ return();
+ }
+
+ fields <- c(fields, qFields);
+
+ segsT <- segs[,fields, drop=FALSE];
+ segsT <- unique(segsT);
+
+ # Rescale x-axis
+ segsT[,1:2] <- xScale * segsT[,1:2];
+
+ colQ <- col2rgb(col, alpha=TRUE);
+ colQ["alpha",] <- alpha*colQ["alpha",];
+ colQ <- rgb(red=colQ["red",], green=colQ["green",], blue=colQ["blue",], alpha=colQ["alpha",], maxColorValue=255);
+
+ for (kk in seq(length=nrow(segsT))) {
+ rect(xleft=segsT[kk,1], xright=segsT[kk,2], ybottom=segsT[kk,3], ytop=segsT[kk,4], col=colQ, border=FALSE);
+ }
+}, private=TRUE)
+
+
+
+setMethodS3("plotC1C2", "PairedPSCBS", function(fit, ..., xlab=expression(C[1]), ylab=expression(C[2]), Clim=c(0,2*ploidy(fit))) {
+ # Argument 'Clim':
+ Clim <- Arguments$getNumerics(Clim, length=c(2L,2L),
+ disallow=c("Inf", "NA", "NaN"));
+
+ plot(NA, xlim=Clim, ylim=Clim, xlab=xlab, ylab=ylab);
+ abline(a=0, b=1, lty=3);
+ pointsC1C2(fit, ...);
+}, private=TRUE)
+
+
+setMethodS3("pointsC1C2", "PairedPSCBS", function(fit, cex=NULL, col="#00000033", ...) {
+ data <- extractC1C2(fit);
+ X <- data[,1:2,drop=FALSE];
+ n <- data[,4,drop=TRUE];
+ n <- sqrt(n);
+ w <- n / sum(n, na.rm=TRUE);
+
+ if (is.null(cex)) {
+ cex <- w;
+ cex <- cex / mean(cex, na.rm=TRUE);
+ cex <- cex + 1/2;
+ }
+
+ points(X, cex=cex, col=col, ...);
+}, private=TRUE)
+
+
+setMethodS3("linesC1C2", "PairedPSCBS", function(fit, ...) {
+ drawChangePointsC1C2(fit, ...);
+}, private=TRUE)
+
+
+setMethodS3("drawChangePointsC1C2", "PairedPSCBS", function(fit, col="#00000033", labels=FALSE, lcol="#333333", cex=0.7, adj=c(+1.5,+0.5), ...) {
+ xy <- extractMinorMajorCNs(fit, splitters=TRUE, addGaps=TRUE);
+ xy <- xy[,1:2,drop=FALSE];
+ res <- lines(xy, col=col, ...);
+
+ if (labels) {
+ n <- nrow(xy);
+ dxy <- (xy[-1,] - xy[-n,]) / 2;
+ xyMids <- xy[-n,] + dxy;
+ labels <- rownames(xy);
+ labels <- sprintf("%s-%s", labels[-n], labels[-1]);
+ text(xyMids, labels, cex=cex, col=lcol, adj=adj, ...);
+ }
+
+ invisible(res);
+}, private=TRUE)
+
+
+
+
+setMethodS3("plotDeltaC1C2", "PairedPSCBS", function(fit, ..., xlab=expression(Delta*C[1]), ylab=expression(Delta*C[2]), Clim=c(-1,1)*ploidy(fit)) {
+ # Argument 'Clim':
+ Clim <- Arguments$getNumerics(Clim, length=c(2L,2L),
+ disallow=c("Inf", "NA", "NaN"));
+
+ plot(NA, xlim=Clim, ylim=Clim, xlab=xlab, ylab=ylab);
+ abline(h=0, lty=3);
+ abline(v=0, lty=3);
+ pointsDeltaC1C2(fit, ...);
+}, private=TRUE)
+
+
+setMethodS3("pointsDeltaC1C2", "PairedPSCBS", function(fit, ...) {
+ data <- extractDeltaC1C2(fit);
+ X <- data[,1:2,drop=FALSE];
+ points(X, ...);
+}, private=TRUE)
+
+
+setMethodS3("linesDeltaC1C2", "PairedPSCBS", function(fit, ...) {
+ xy <- extractDeltaC1C2(fit);
+ xy <- xy[,1:2,drop=FALSE];
+ lines(xy, ...);
+}, private=TRUE)
+
+
+
+setMethodS3("arrowsC1C2", "PairedPSCBS", function(fit, length=0.05, ...) {
+ xy <- extractMinorMajorCNs(fit, splitters=TRUE, addGaps=TRUE);
+ xy <- xy[,1:2,drop=FALSE];
+ x <- xy[,1,drop=TRUE];
+ y <- xy[,2,drop=TRUE];
+ s <- seq(length=length(x)-1);
+ arrows(x0=x[s],y0=y[s], x1=x[s+1],y1=y[s+1], code=2, length=length, ...);
+}, private=TRUE)
+
+
+setMethodS3("arrowsDeltaC1C2", "PairedPSCBS", function(fit, length=0.05, ...) {
+ xy <- extractDeltaC1C2(fit);
+ xy <- xy[,1:2,drop=FALSE];
+ x <- xy[,1,drop=TRUE];
+ y <- xy[,2,drop=TRUE];
+ s <- seq(length=length(x)-1);
+ arrows(x0=x[s],y0=y[s], x1=x[s+1],y1=y[s+1], code=2, length=length, ...);
+}, private=TRUE)
+
+
+
+
+setMethodS3("tileChromosomes", "PairedPSCBS", function(fit, chrStarts=NULL, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'chrStarts':
+ if (!is.null(chrStarts)) {
+ chrStarts <- Arguments$getDoubles(chrStarts);
+ }
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ # Nothing to do, i.e. already tiled?
+ if (isTRUE(attr(fit, "tiledChromosomes"))) {
+ return(fit);
+ }
+
+
+ verbose && enter(verbose, "Tile chromosomes");
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract data and segments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fit);
+ segs <- getSegments(fit);
+ knownSegments <- fit$params$knownSegments;
+
+ # Identify all chromosome
+ chromosomes <- getChromosomes(fit);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Additional chromosome annotations
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (is.null(chrStarts)) {
+ xRange <- matrix(0, nrow=length(chromosomes), ncol=2);
+ for (kk in seq(along=chromosomes)) {
+ chromosome <- chromosomes[kk];
+ idxs <- which(data$chromosome == chromosome);
+ x <- data$x[idxs];
+ r <- range(x, na.rm=TRUE);
+ r <- r / 1e6;
+ r[1] <- floor(r[1]);
+ r[2] <- ceiling(r[2]);
+ r <- 1e6 * r;
+ xRange[kk,] <- r;
+ } # for (kk ...)
+
+ chrLength <- xRange[,2];
+ chrStarts <- c(0, cumsum(chrLength)[-length(chrLength)]);
+ chrEnds <- chrStarts + chrLength;
+
+ # Not needed anymore
+ x <- idxs <- NULL;
+ } # if (is.null(chrStarts))
+
+ verbose && cat(verbose, "Chromosome starts:");
+ chromosomeStats <- cbind(start=chrStarts, end=chrEnds, length=chrEnds-chrStarts);
+ verbose && print(chromosomeStats);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Offset...
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ segFields <- grep("(Start|End)$", colnames(segs), value=TRUE);
+ # Sanity check
+ stopifnot(length(segFields) > 0);
+
+ for (kk in seq(along=chromosomes)) {
+ chromosome <- chromosomes[kk];
+ chrTag <- sprintf("Chr%02d", chromosome);
+ verbose && enter(verbose, sprintf("Chromosome #%d ('%s') of %d",
+ kk, chrTag, length(chromosomes)));
+
+ # Get offset for this chromosome
+ offset <- chrStarts[kk];
+ verbose && cat(verbose, "Offset: ", offset);
+
+ # Offset data
+ idxs <- which(data$chromosome == chromosome);
+ if (length(idxs) > 0L) {
+ data$x[idxs] <- offset + data$x[idxs];
+ }
+
+ # Offset segmentation
+ idxs <- which(segs$chromosome == chromosome);
+ if (length(idxs) > 0L) {
+ segs[idxs,segFields] <- offset + segs[idxs,segFields];
+ }
+
+ # Offset known segments
+ idxs <- which(knownSegments$chromosome == chromosome);
+ if (length(idxs) > 0L) {
+ knownSegments[idxs,c("start", "end")] <- offset + knownSegments[idxs,c("start", "end")];
+ }
+
+ verbose && exit(verbose);
+ } # for (kk ...)
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Update results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fit$data <- data;
+ fit$output <- segs;
+ fit$chromosomeStats <- chromosomeStats;
+ fit$params$knownSegments <- knownSegments;
+# fitT$params$chrOffsets <- chrOffsets;
+
+ # Flag object
+ attr(fit, "tiledChromosomes") <- TRUE;
+
+ verbose && exit(verbose);
+
+ fit;
+}, private=TRUE) # tileChromosomes()
+
+
+
+setMethodS3("drawChangePoints", "PSCBS", function(fit, labels=FALSE, col="#666666", cex=0.5, xScale=1e-6, side=3, line=-1, xpd=TRUE, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Tile chromosomes
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fitT <- tileChromosomes(fit);
+ verbose && str(verbose, fitT);
+
+ segs <- getSegments(fitT, splitters=FALSE);
+ xStarts <- segs[,"tcnStart"];
+ xEnds <- segs[,"tcnEnd"];
+
+ xs <- sort(unique(c(xStarts, xEnds)));
+ abline(v=xScale*xs, lty=1, col=col);
+
+ if (labels) {
+ xMids <- xScale * (xEnds + xStarts) / 2;
+ labels <- rownames(segs);
+ mtext(side=side, at=xMids, labels, line=line, cex=cex, col=col, xpd=xpd, ...);
+ }
+}, protected=TRUE)
+
+
+
+setMethodS3("getChromosomeRanges", "PairedPSCBS", function(fit, ...) {
+ # To please R CMD check, cf. subset()
+ chromosome <- NULL; rm(list="chromosome");
+
+ segs <- getSegments(fit, splitter=FALSE);
+ chromosomes <- sort(unique(segs$chromosome));
+
+ # Allocate
+ naValue <- NA_real_;
+ res <- matrix(naValue, nrow=length(chromosomes), ncol=3);
+ rownames(res) <- chromosomes;
+ colnames(res) <- c("start", "end", "length");
+
+ # Get start and end of each chromosome.
+ for (ii in seq(length=nrow(res))) {
+ chr <- chromosomes[ii];
+ segsII <- subset(segs, chromosome == chr);
+ res[ii,"start"] <- min(segsII$tcnStart, na.rm=TRUE);
+ res[ii,"end"] <- max(segsII$tcnEnd, na.rm=TRUE);
+ } # for (ii ...)
+
+ res[,"length"] <- res[,"end"] - res[,"start"] + 1L;
+
+ # Sanity check
+ stopifnot(nrow(res) == length(chromosomes));
+
+ res <- as.data.frame(res);
+ res <- cbind(chromosome=chromosomes, res);
+
+ res;
+}, protected=TRUE) # getChromosomeRanges()
+
+
+setMethodS3("getChromosomeOffsets", "PairedPSCBS", function(fit, resolution=1e6, ...) {
+ # Argument 'resolution':
+ if (!is.null(resolution)) {
+ resolution <- Arguments$getDouble(resolution, range=c(1,Inf));
+ }
+
+ data <- getChromosomeRanges(fit, ...);
+ splits <- data[,"start"] + data[,"length"];
+
+ if (!is.null(resolution)) {
+ splits <- ceiling(splits / resolution);
+ splits <- resolution * splits;
+ }
+
+ offsets <- c(0L, cumsum(splits));
+ names(offsets) <- c(rownames(data), NA);
+
+ offsets;
+}, protected=TRUE) # getChromosomeOffsets()
+
+
+
+############################################################################
+# HISTORY:
+# 2013-05-07
+# o Now tileChromosomes() no longer gives warnings on "max(i): no
+# non-missing arguments to max; returning -Inf".
+# 2013-04-18
+# o Now drawLevels() and drawConfidenceBands() also works for
+# multiple chromosomes.
+# 2013-03-18
+# o Now plotTracksManyChromosomes() draws AB and LOH call thresholds.
+# 2012-09-23
+# o Now plotTracks() [and plotTracksManyChromosomes()] draws segment levels
+# in TCN-C2-C1 order, and then goes back and draws C2 and TCN with dashed
+# lines, just in case C1 is overlapping C2 and C2 is overlapping TCN.
+# 2012-09-21
+# o ROBUSTNESS: Now drawChangePointsC1C2() and arrowsC1C2() for PairedPSCBS
+# makes sure to retrieve segments with NA splitters between chromosomes
+# and gaps.
+# 2012-02-29
+# o BUG FIX: plotTracks(..., add=TRUE) for PairedPSCBS would add TCNs
+# when BAFs and DHs where intended.
+# 2012-02-22
+# o BUG FIX: Argument 'calls' of plotTracks() for PairedPSCBS was ignored
+# if more than one chromosome was plotted.
+# 2011-12-03
+# o Added drawChangePointsC1C2() for PairedPSCBS.
+# o Added drawChangePoints() for PairedPSCBS.
+# 2011-11-12
+# o Added argument col="#00000033" to plotC1C2() and linesC1C2().
+# o Added argument 'oma' and 'mar' to plotTracksManyChromosomes() for
+# PairedPSCBS for setting graphical parameters when 'add' == FALSE.
+# 2011-09-30
+# o GENERALIZATION: Now drawLevels() for PairedPSCBS allows for drawing
+# segmentation results in 'betaT' space.
+# 2011-07-10
+# o BUG FIX: tileChromosomes() for PairedPSCBS was still assuming the
+# old naming convention of column names.
+# o ROBUSTNESS: Fixed partial argument matchings in arrowsC1C2() and
+# arrowsDeltaC1C2() for PairedPSCBS.
+# 2011-06-14
+# o Updated code to recognize new column names.
+# 2011-01-19
+# o Added argument 'subplots'.
+# 2011-01-18
+# o DOCUMENTATION: Documented more plotTracks() arguments for PairedPSCBS.
+# o Now plotTracks(..., add=TRUE) for PairedPSCBS plots to the current
+# figure/panel.
+# o Now plotTracks(..., add=FALSE) for PairedPSCBS only sets up subplots
+# if argument 'tracks' specifies more than one panel.
+# o Added argument 'col' to plotTracks() for PairedPSCBS.
+# 2011-01-12
+# o Added argument 'changepoints' to plotTracks() for PairedPSCBS for
+# highlightning change-point locations as vertical lines.
+# 2010-12-01
+# o Now using a default 'seed' for plotTracksManyChromosomes() such
+# that the scatter data in the plots are reproducible by default.
+# 2010-11-27
+# o BUG FIX: plotTracksManyChromosomes() would annotate called regions
+# incorrectly.
+# o Added more verbouse output to plotTracksManyChromosomes().
+# o Added missing argument 'verbose' to plotTracksManyChromosomes().
+# o plotTracksManyChromosomes() gained argument 'scatter'.
+# o REPRODUCIBILITY: plotTracksManyChromosomes() for PairedPSCBS gained
+# argument 'seed', because if 'subset' is specified then a random
+# subset of the data points are displayed.
+# 2010-11-26
+# o Added optional argument 'chromosomes' to plotTracks() to plot a
+# subset of all chromosomes.
+# o Now the default confidence intervals for plotTracks() is (0.05,0.95),
+# if existing.
+# 2010-11-22
+# o ROBUSTNESS: Now drawConfidenceBands() of PairedPSCBS silently does
+# nothing if the requested bootstrap quantiles are available.
+# o Added argument 'calls' to plotTracks() and plotTracksManyChromosomes()
+# for highlighing called regions.
+# 2010-11-21
+# o Now plotTracks() supports tracks "tcn,c1", "tcn,c2" and "c1,c2" too.
+# o Added argument 'xlim' to plotTracks() making it possible to zoom in.
+# o Now plotTracks() and plotTracksManyChromosomes() draws confidence
+# bands, iff argument quantiles is given.
+# o Added drawConfidenceBands() for PairedPSCBS.
+# 2010-11-09
+# o Added argument 'cex=1' to plotTracks().
+# o BUG FIX: It was not possible to plot BAF tracks with plotTracks().
+# 2010-10-20
+# o Added arguments 'onBegin' and 'onEnd' to plotTracksManyChromosomes().
+# 2010-10-18
+# o Now plotTracks() can plot whole-genome data.
+# o Now plotTracks() utilized plotTracksManyChromosomes() if there is
+# more than one chromosome.
+# o Added internal plotTracksManyChromosomes().
+# o Added internal tileChromosomes().
+# 2010-10-03
+# o Now the default is that plotTracks() for PairedPSCBS generated three
+# panels: (1) TCN, (2) DH, and (3) C1+C2+TCN.
+# o Added plotTracks() to be more explicit than just plot().
+# o Added argument 'xScale' to plot() for PairedPSCBS.
+# o Now plot() for PairedPSCBS adds a chromosome tag.
+# 2010-09-21
+# o Added argument 'what' to plot() for PairedPSCBS.
+# o Added postsegmentTCN() for PairedPSCBS.
+# 2010-09-19
+# o BUG FIX: plot() used non-defined nbrOfLoci; now length(x).
+# 2010-09-15
+# o Added subsetBySegments().
+# o Added linesC1C2() and arrowsC1C2().
+# o Now the default 'cex' for pointsC1C2() corresponds to 'dh.num.mark'.
+# o Now extractTotalAndDH() also returns 'dh.num.mark'.
+# 2010-09-08
+# o Added argument 'add=FALSE' to plot().
+# o Added plotC1C2().
+# o Added extractTotalAndDH() and extractMinorMajorCNs().
+# 2010-09-04
+# o Added drawLevels() for PairedPSCBS.
+# o Added as.data.frame() and print() for PairedPSCBS.
+# 2010-09-03
+# o Added plot() for PairedPSCBS.
+# o Created.
+############################################################################
diff --git a/R/PairedPSCBS.PLOT2.R b/R/PairedPSCBS.PLOT2.R
new file mode 100644
index 0000000..fcce49e
--- /dev/null
+++ b/R/PairedPSCBS.PLOT2.R
@@ -0,0 +1,375 @@
+setMethodS3("plotTracks2", "PairedPSCBS", function(x, panels=NULL, calls=".*", pch=".", col=NULL, cex=1, lwd=2, changepoints=FALSE, grid=FALSE, quantiles=c(0.05,0.95), xlim=NULL, Clim=c(0,3*ploidy(x)), Blim=c(0,1), xScale=1e-6, ..., add=FALSE, subplots=!add && (length(panels) > 1), verbose=FALSE) {
+
+ # To please R CMD check
+ fit <- x;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'fit':
+ if (nbrOfChromosomes(fit) > 1) {
+ throw("Multiple chromosomes detected. Not yet implemented.");
+ }
+
+ # Argument 'panels':
+ panels <- unique(panels);
+ panelsOrg <- panels;
+ panels <- gsub("[-*]", "", panelsOrg);
+ knownPanels <- c("tcn", "tcn,c1,c2", "tcn,c1", "tcn,c2", "c1,c2", "c1", "c2", "dh", "betaN", "betaT", "betaTN");
+ panels <- match.arg(panels, choices=knownPanels, several.ok=TRUE);
+ panels <- panelsOrg;
+
+ # Argument 'calls':
+ if (!is.null(calls)) {
+ calls <- sapply(calls, FUN=Arguments$getRegularExpression);
+ }
+
+ # Argument 'changepoints':
+ changepoints <- Arguments$getLogical(changepoints);
+
+ # Argument 'grid':
+ grid <- Arguments$getLogical(grid);
+
+ # Argument 'xlim':
+ if (!is.null(xlim)) {
+ xlim <- Arguments$getNumerics(xlim, length=c(2,2));
+ }
+
+ # Argument 'xScale':
+ xScale <- Arguments$getNumeric(xScale, range=c(0,Inf));
+
+ # Argument 'add':
+ add <- Arguments$getLogical(add);
+
+ # Argument 'Clim':
+ if (!add) {
+ Clim <- Arguments$getNumerics(Clim, length=c(2L,2L),
+ disallow=c("Inf", "NA", "NaN"));
+ }
+
+ # Argument 'subplots':
+ subplots <- Arguments$getLogical(subplots);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Plotting PSCN panels");
+
+ # Extract the input data
+ data <- getLocusData(fit);
+ if (is.null(data)) {
+ throw("Cannot plot segmentation results. No input data available.");
+ }
+
+ chromosomes <- getChromosomes(fit);
+ chromosome <- chromosomes[1];
+ x <- data$x;
+ CT <- data$CT;
+ rho <- data$rho;
+ betaT <- data$betaT;
+ betaN <- data$betaN;
+ betaTN <- data$betaTN;
+ muN <- data$muN;
+ rho <- data$rho
+ hasDH <- !is.null(rho)
+ if (hasDH) {
+ isHet <- !is.na(rho)
+ isSnp <- isHet
+ } else {
+ isSnp <- (!is.na(betaTN) & !is.na(muN))
+ isHet <- isSnp & (muN == 1/2)
+ }
+ nbrOfLoci <- length(x)
+
+ # BACKWARD COMPATIBILITY:
+ # If 'rho' is not available, recalculate it from tumor BAFs.
+ # NOTE: This should throw an error in the future. /HB 2013-10-25
+ if (!hasDH) {
+ rho <- rep(NA_real_, length=nbrOfLoci);
+ rho[isHet] <- 2*abs(betaTN[isHet]-1/2);
+ warning(sprintf("Locus-level DH signals ('rho') were not available in the %s object and therefore recalculated from the TumorBoost-normalized tumor BAFs ('betaTN').", class(fit)[1L]));
+ }
+
+ # Extract the segmentation
+ segs <- as.data.frame(fit);
+
+ # Identify available calls
+ if (!is.null(calls)) {
+ verbose && enter(verbose, "Identifying calls");
+
+ pattern <- "Call$";
+ callColumns <- grep(pattern, colnames(segs), value=TRUE);
+ if (length(callColumns) > 0) {
+ keep <- sapply(calls, FUN=function(pattern) {
+ (regexpr(pattern, callColumns) != -1);
+ });
+ if (is.matrix(keep)) {
+ keep <- rowAnys(keep);
+ }
+ callColumns <- callColumns[keep];
+ callLabels <- gsub(pattern, "", callColumns);
+ callLabels <- toupper(callLabels);
+ }
+ verbose && cat(verbose, "Call columns:");
+ verbose && print(verbose, callColumns);
+
+ verbose && exit(verbose);
+ } else {
+ callColumns <- NULL;
+ }
+
+ if (chromosome != 0) {
+ chrTag <- sprintf("Chr%02d", chromosome);
+ } else {
+ chrTag <- "";
+ }
+
+ if (xScale != 1) {
+ x <- xScale * x;
+ if (is.null(xlim)) {
+ xlim <- range(x, na.rm=TRUE);
+ } else {
+ xlim <- xScale * xlim;
+ }
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Number of panels?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ nbrOfPanels <- length(panels);
+ if (subplots) {
+ subplots(nbrOfPanels, ncol=1);
+ par(mar=c(1,4,1,2)+1);
+ }
+
+ # Color loci by genotype
+ if (hasDH) {
+ colMu <- c("gray", "black")[!is.na(rho) + 1]
+ } else {
+ colMu <- c("gray", "black")[(muN == 1/2) + 1]
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # For each panel...
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ for (pp in seq(length=nbrOfPanels)) {
+ panel <- panels[pp];
+ verbose && enter(verbose, sprintf("Panel #%d ('%s') of %d",
+ pp, panel, length(panels)));
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setup empty plot
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (!add) {
+ verbose && enter(verbose, "Creating empty plot");
+
+ tracks <- strsplit(panel, split=",", fixed=TRUE)[[1]];
+ tracks <- gsub("[-*]", "", tracks);
+
+ # Defaults
+ ylim <- Clim;
+ ylab <- paste(toupper(tracks), collapse=", ");
+
+ if (any(is.element(c("betaN", "betaT", "betaTN", "dh"), tracks))) {
+ ylim <- Blim;
+ }
+
+ verbose && cat(verbose, "ylim:");
+ verbose && print(verbose, ylim);
+
+ plot(NA, xlim=xlim, ylim=ylim, ylab=ylab);
+
+ # Geometrical annotations
+ stext(side=3, pos=1, chrTag);
+ if (grid) {
+ abline(h=seq(from=0, to=ylim[2], by=2), lty=3, col="gray");
+ abline(h=0, lty=1, col="black");
+ }
+
+ verbose && exit(verbose);
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Scatter tracks
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ tracks <- strsplit(panel, split=",", fixed=TRUE)[[1]];
+ keep <- grep("-", tracks, fixed=TRUE, invert=TRUE);
+ tracks <- tracks[keep];
+
+ verbose && cat(verbose, "Number tracks with scatter: ", length(tracks));
+ verbose && cat(verbose, "Tracks with scatter:");
+ verbose && print(verbose, tracks);
+ nbrOfTracks <- length(tracks);
+
+ for (tt in seq(length=nbrOfTracks)) {
+ track <- tracks[tt];
+ verbose && enter(verbose, sprintf("Scatter track #%d ('%s') of %d",
+ tt, track, nbrOfTracks));
+ track <- gsub("[-*]", "", track);
+
+ # Defaults
+ colT <- if (is.null(col)) "black" else col;
+
+ if (track == "tcn") {
+ y <- CT;
+ } else if (track == "c1") {
+ y <- 1/2*(1-rho)*CT;
+ } else if (track == "c2") {
+ y <- 1/2*(1+rho)*CT;
+ } else if (track == "betaN") {
+ y <- betaN;
+ colT <- if (is.null(col)) colMu else col;
+ ylab <- expression(BAF[N]);
+ ylim <- Blim;
+ } else if (track == "betaT") {
+ y <- betaT;
+ colT <- if (is.null(col)) colMu else col;
+ ylab <- expression(BAF[T]);
+ ylim <- Blim;
+ } else if (track == "betaTN") {
+ y <- betaTN;
+ colT <- if (is.null(col)) colMu else col;
+ ylab <- expression(BAF[T]^"*");
+ ylim <- Blim;
+ } else if (track == "dh") {
+ y <- rho;
+ colT <- if (is.null(col)) colMu[isHet] else col;
+ ylab <- "DH";
+ ylim <- Blim;
+ } else {
+ y <- NULL;
+ }
+
+ # Nothing to do?
+ if (!is.null(y)) {
+ points(x, y, pch=pch, cex=cex, col=colT);
+ }
+
+ verbose && exit(verbose);
+ } # for (tt ...)
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Segment tracks
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ tracks <- strsplit(panel, split=",", fixed=TRUE)[[1]];
+ keep <- grep("*", tracks, fixed=TRUE);
+ tracks <- gsub("[-*]", "", tracks[keep]);
+
+ # Keep only supported tracks
+ tracksWithLevels <- c("tcn", "betaTN", "c1", "c2", "dh");
+ stopifnot(all(is.element(tracks, tracksWithLevels)));
+ tracks <- intersect(tracks, tracksWithLevels);
+
+ verbose && cat(verbose, "Number tracks with levels: ", length(tracks));
+ verbose && cat(verbose, "Tracks with levels:");
+ verbose && print(verbose, tracks);
+ nbrOfTracks <- length(tracks);
+
+ for (tt in seq(length=nbrOfTracks)) {
+ track <- tracks[tt];
+ verbose && enter(verbose, sprintf("Level track #%d ('%s') of %d",
+ tt, track, nbrOfTracks));
+
+ if (track == "tcn") {
+ colT <- "purple";
+ } else if (track == "c1") {
+ colT <- "blue";
+ } else if (track == "c2") {
+ colT <- "red";
+ } else if (track == "betaTN") {
+ colT <- "orange";
+ } else if (track == "dh") {
+ colT <- "orange";
+ } else {
+ colT <- if (is.null(col)) "black" else col;
+ }
+
+ # Nothing to do?
+ if (track != "betaTN") {
+ drawConfidenceBands(fit, what=track, quantiles=quantiles,
+
+ col=colT, xScale=xScale);
+ }
+ drawLevels(fit, what=track, col=colT, lwd=lwd, xScale=xScale);
+
+ verbose && exit(verbose);
+ } # for (tt ...)
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Draw change points?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (changepoints) {
+ segs <- as.data.frame(fit);
+ xStarts <- segs[,"tcnStart"];
+ xEnds <- segs[,"tcnEnd"];
+ xs <- sort(unique(c(xStarts, xEnds)));
+ abline(v=xScale*xs, lty=1, col="gray");
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # For each panel of tracks, annotate with calls?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (length(callColumns) > 0) {
+ for (cc in seq(along=callColumns)) {
+ callColumn <- callColumns[cc];
+ callLabel <- callLabels[cc];
+ verbose && enter(verbose, sprintf("Call #%d ('%s') of %d",
+ cc, callLabel, length(callColumns)));
+
+ verbose && cat(verbose, "Column: ", callColumn);
+
+ segsT <- segs[,c("dhStart", "dhEnd", callColumn)];
+ isCalled <- which(segsT[[callColumn]]);
+ segsT <- segsT[isCalled,1:2,drop=FALSE];
+ verbose && printf(verbose, "Number of segments called %s: %d\n",
+ callLabel, nrow(segsT));
+ segsT <- xScale * segsT;
+
+ verbose && str(verbose, segsT);
+
+ side <- 2*((cc+1) %% 2) + 1;
+ # For each segment called...
+ for (ss in seq(length=nrow(segsT))) {
+ x0 <- segsT[ss,1,drop=TRUE];
+ x1 <- segsT[ss,2,drop=TRUE];
+ abline(v=c(x0,x1), lty=3, col="gray");
+ xMid <- (x0+x1)/2;
+ mtext(side=side, at=xMid, line=-1, cex=0.7, col="#666666", callLabel);
+ } # for (ss in ...)
+ verbose && exit(verbose);
+ } # for (cc in ...)
+ } # if (length(callColumns) > 0)
+
+ verbose && exit(verbose);
+ } # for (pp ...)
+
+ verbose && exit(verbose);
+
+ invisible();
+}, protected=TRUE) # plotTracks2()
+
+
+
+############################################################################
+# HISTORY:
+# 2011-09-30
+# o BUG FIX: plotTracks2(..., panels="dh") gave an error due to a
+# forgotten assigment.
+# 2011-06-14
+# o Updated code to recognize new column names.
+# 2011-01-19
+# o Added plotTracks2(). Completely rewritten plotTracks().
+# o Created.
+############################################################################
diff --git a/R/PairedPSCBS.PRUNE.R b/R/PairedPSCBS.PRUNE.R
new file mode 100644
index 0000000..506965f
--- /dev/null
+++ b/R/PairedPSCBS.PRUNE.R
@@ -0,0 +1,11 @@
+setMethodS3("seqOfSegmentsByDP", "PairedPSCBS", function(fit, by=c("CT", "rho"), ...) {
+ NextMethod("seqOfSegmentsByDP", by=by);
+})
+
+
+############################################################################
+# HISTORY:
+# 2012-09-13
+# o Added seqOfSegmentsByDP() for PairedPSCBS.
+# o Created.
+############################################################################
diff --git a/R/PairedPSCBS.R b/R/PairedPSCBS.R
new file mode 100644
index 0000000..5acd558
--- /dev/null
+++ b/R/PairedPSCBS.R
@@ -0,0 +1,240 @@
+###########################################################################/**
+# @RdocClass PairedPSCBS
+#
+# @title "The PairedPSCBS class"
+#
+# \description{
+# @classhierarchy
+#
+# A PairedPSCBS is an object containing the results from the
+# Paired PSCBS method.
+# }
+#
+# \usage{PairedPSCBS(fit=list(), ...)}
+#
+# \arguments{
+# \item{fit}{A @list structure containing the Paired PSCBS results.}
+# \item{...}{Not used.}
+# }
+#
+# \section{Fields and Methods}{
+# @allmethods "public"
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# The @see "segmentByPairedPSCBS" method returns an object of this class.
+# }
+#*/###########################################################################
+setConstructorS3("PairedPSCBS", function(fit=list(), ...) {
+ # Argument 'fit':
+ if (!is.list(fit)) {
+ throw("Argument 'fit' is not a list: ", class(fit)[1]);
+ }
+
+ extend(PSCBS(fit=fit, ...), "PairedPSCBS");
+})
+
+setMethodS3("getLocusData", "PairedPSCBS", function(fit, ..., fields=c("asis", "full")) {
+ # Argument 'fields':
+ fields <- match.arg(fields);
+
+
+ data <- NextMethod("getLocusData", fields="asis");
+
+
+ if (fields == "full") {
+ names <- colnames(data);
+
+ # Genotype calls
+ if (!is.element("muN", names)) {
+ callNaiveGenotypes <- .use("callNaiveGenotypes", package="aroma.light");
+ data$muN <- callNaiveGenotypes(data$betaN);
+ }
+ data$isHet <- (data$muN == 1/2);
+ # BACKWARD COMPATIBILITY: If 'rho' does not exists, calculate
+ # it on the fly from 'betaT'.
+ # NOTE: This should give an error in the future. /HB 2013-10-25
+ if (is.null(data$rho)) {
+ data$rho <- 2*abs(data$betaT-1/2);
+ data$rho[!data$isHet] <- NA_real_;
+ warning("Locus-level DH signals ('rho') did not exist and were calculated from tumor BAFs ('betaT')");
+ }
+ data$c1 <- 1/2*(1-data$rho)*data$CT;
+ data$c2 <- data$CT - data$c1;
+
+ # TumorBoost BAFs
+ if (!is.element("betaTN", names)) {
+ normalizeTumorBoost <- .use("normalizeTumorBoost", package="aroma.light");
+ data$betaTN <- normalizeTumorBoost(betaN=data$betaN, betaT=data$betaT, muN=data$muN);
+ }
+ data$rhoN <- 2*abs(data$betaTN-1/2);
+ data$rhoN[!data$isHet] <- NA_real_;
+ data$c1N <- 1/2*(1-data$rhoN)*data$CT;
+ data$c2N <- data$CT - data$c1N;
+
+ data$isSNP <- (!is.na(data$betaT) | !is.na(data$betaN));
+ data$type <- ifelse(data$isSNP, "SNP", "non-polymorphic locus");
+
+ # Labels
+ data$muNx <- c("AA", "AB", "BB")[2*data$muN + 1L];
+ data$isHetx <- c("AA|BB", "AB")[data$isHet + 1L];
+ }
+
+ data;
+}, protected=TRUE) # getLocusData()
+
+
+
+setMethodS3("resegment", "PairedPSCBS", function(fit, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Resegmenting a ", class(fit)[1], " object");
+
+ # Use the locus-level data of the PairedPSCBS object
+ data <- getLocusData(fit);
+ class(data) <- "data.frame";
+ drop <- c("rho", "betaTN", "index");
+ keep <- !is.element(colnames(data), drop);
+ data <- data[,keep];
+ verbose && str(verbose, data);
+
+ verbose && cat(verbose, "Number of loci: ", nrow(data));
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setup arguments to be passed
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Overriding default arguments");
+ segFcnName <- "segmentByPairedPSCBS";
+ segFcn <- getMethodS3(segFcnName, "default");
+
+ # (a) The default arguments
+ formals <- formals(segFcn);
+
+ formals <- formals[!sapply(formals, FUN=is.language)];
+ formals <- formals[!sapply(formals, FUN=is.name)];
+ drop <- c("chromosome", "x", "w", "CT", "thetaT", "thetaN", "betaT", "betaN", "muN", "rho", "...");
+ keep <- !is.element(names(formals), drop);
+ formals <- formals[keep];
+
+ # (b) The arguments used in previous fit
+ params <- fit$params;
+ keep <- is.element(names(params), names(formals));
+ params <- params[keep];
+ # Don't trust 'tbn'! TODO. /HB 20111117
+ params$tbn <- NULL;
+
+ # (c) The arguments in '...'
+ userArgs <- list(..., verbose=verbose);
+
+ # (d) Merge
+ args <- formals;
+ args2 <- append(params, userArgs);
+ for (kk in seq(along=args2)) {
+ value <- args2[[kk]];
+ if (!is.null(value)) {
+ key <- names(args2)[kk];
+ if (!is.null(key)) {
+ args[[key]] <- value;
+ } else {
+ args <- append(args, list(value));
+ }
+ }
+ } # for (key ...)
+ verbose && str(verbose, args[names(args) != "verbose"]);
+
+ verbose && enter(verbose, sprintf("Calling %s()", segFcnName));
+ args <- append(list(data), args);
+ verbose && cat(verbose, "Arguments:");
+ verbose && str(verbose, args[names(args) != "verbose"]);
+ verbose && exit(verbose);
+
+ fit <- do.call(segFcnName, args);
+ verbose && exit(verbose);
+
+ verbose && exit(verbose);
+
+ fit;
+}, protected=TRUE) # resegment()
+
+
+setMethodS3("adjustPloidyScale", "PairedPSCBS", function(fit, scale, ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # (a) Update locus-level data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fit);
+ names <- c("CT");
+ for (ff in names) {
+ data[[ff]] <- scale * data[[ff]];
+ }
+ fit$data <- data; ## fit <- setLocusData(fit, data);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # (b) Update segment-level data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ segs <- getSegments(fit);
+
+ # Adjust segment levels
+ names <- grep("^(tcn|c1|c2)(Mean|_.*%)$", names(segs), value=TRUE);
+ for (ff in names) {
+ segs[[ff]] <- scale * segs[[ff]];
+ }
+
+ # Clear segment calls
+ names <- c("lohCall", "ntcnCall");
+ for (ff in names) {
+ segs[[ff]] <- NULL;
+ }
+ fit$output <- segs; ## fit <- setSegments(fit, sets);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # (c) Update parameter estimates
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ params <- fit$params;
+ fields <- c("copyNeutralStats", "deltaCN", "ntcnRange", "deltaLowC1");
+ params[fields] <- NULL;
+ fit$params <- params;
+
+ fit;
+}, protected=TRUE) # adjustPloidyScale()
+
+
+##############################################################################
+# HISTORY
+# 2014-03-30
+# o Update resegment() for PairedPSCBS to handle 'thetaT' and 'thetaN'.
+# 2013-10-25
+# o BUG FIX: The 'rho' signals returned by getLocusData(..., fields="full")
+# for PairedPSCBS would have values also for homozygote SNPs.
+# 2013-03-08
+# o Added getLocusData() for PairedPSCBS.
+# 2012-04-21
+# o CLEANUP: Moved getSegmentSizes() from PairedPSCBS to PSCBS.
+# 2011-11-21
+# o BUG FIX: resegment() was trying to call segmentByCBS() instead
+# of segmentByPairedPSCBS().
+# 2011-11-17
+# o Added resegment() for PairedPSCBS for easy resegmentation.
+# 2011-10-02
+# o CLEANUP: Moved print() and as.data.frame() to PSCBS.
+# o Added Rdoc help.
+# o Now the constructor of PairedPSCBS calls that of PSCBS.
+# 2011-06-28
+# o DOCUMENTATION: Added Rd help for as.data.frame() of PairedPSCBS.
+# 2011-04-08
+# o Added formal constructor for the PairedPSCBS class.
+# o Created.
+##############################################################################
diff --git a/R/PairedPSCBS.RESTRUCT.R b/R/PairedPSCBS.RESTRUCT.R
new file mode 100644
index 0000000..c135f30
--- /dev/null
+++ b/R/PairedPSCBS.RESTRUCT.R
@@ -0,0 +1,390 @@
+setMethodS3("extractSegments", "PairedPSCBS", function(this, idxs, ..., verbose=FALSE) {
+ fit <- this;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Local functions
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ updateSegRows <- function(segRows, idxs=NULL) {
+ verbose && str(verbose, segRows);
+ if (!is.null(idxs)) {
+ segRows <- segRows[idxs,,drop=FALSE];
+ }
+# verbose && cat(verbose, "Number of segments: ", nrow(segRows));
+# verbose && str(verbose, segRows);
+
+ # Treat splitters separately
+ isSplitter <- (is.na(segRows[,1]) & is.na(segRows[,2]));
+
+ ns <- segRows[,2] - segRows[,1] + 1L;
+# verbose && cat(verbose, "Number of loci per segment:");
+# verbose && str(verbose, ns);
+
+ ns <- ns[!isSplitter];
+ from <- c(1L, cumsum(ns)[-length(ns)]+1L);
+ to <- from + (ns - 1L);
+ segRows[!isSplitter,1] <- from;
+ segRows[!isSplitter,2] <- to;
+ verbose && str(verbose, segRows);
+
+ # Sanity check
+ ns2 <- segRows[,2] - segRows[,1] + 1L;
+ ns2 <- ns2[!isSplitter];
+ stopifnot(all(ns2 == ns));
+
+ segRows;
+ } # updateSegRows()
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'idxs':
+ idxs <- Arguments$getIndices(idxs, max=nbrOfSegments(fit, splitters=TRUE));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Extracting subset of segments");
+
+ verbose && cat(verbose, "Number of segments: ", length(idxs));
+ verbose && str(verbose, idxs);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract data and estimates
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fit);
+ tcnSegRows <- fit$tcnSegRows;
+ dhSegRows <- fit$dhSegRows;
+ segs <- getSegments(fit);
+ params <- fit$params;
+
+ # Sanity checks
+ stopifnot(all(!is.na(data$chromosome) & !is.na(data$x)));
+ stopifnot(length(tcnSegRows) == length(dhSegRows));
+
+ # Sanity checks
+ if (!params$joinSegments) {
+ throw("Cannot extract subset of segments unless CNs are segmented using joinSegments=TRUE.");
+ }
+
+ if (params$flavor == "tcn,dh") {
+ throw("NOT IMPLEMENTED: Extracting a subset of segments is not supported for flavor '", params$flavor, "'.");
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Subset segments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Update table of segments");
+ segsT <- segs[idxs,,drop=FALSE];
+ verbose && str(verbose, segsT);
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Subset data accordingly
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Update locus data");
+
+ segRows <- tcnSegRows;
+ segRows <- segRows[idxs,,drop=FALSE];
+ from <- segRows[[1]];
+ to <- segRows[[2]];
+ ok <- (!is.na(from) & !is.na(to));
+ from <- from[ok];
+ to <- to[ok];
+ keep <- logical(nrow(data));
+ for (rr in seq(along=from)) {
+ keep[from[rr]:to[rr]] <- TRUE;
+ }
+ keep <- which(keep);
+ verbose && printf(verbose, "Identified %d (%.2f%%) of %d data rows:\n", length(keep), 100*length(keep)/nrow(data), nrow(data));
+ verbose && str(verbose, keep);
+
+ dataT <- data[keep,,drop=FALSE];
+ verbose && str(verbose, dataT);
+
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Update 'segRows'
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Update 'segRows'");
+
+ segRows <- updateSegRows(tcnSegRows, idxs=idxs);
+ d <- tcnSegRows[idxs,] - segRows;
+ # Sanity check
+ stopifnot(identical(d[,1], d[,2]));
+ d <- d[,1];
+ verbose && cat(verbose, "Row deltas:");
+ verbose && str(verbose, d);
+
+ tcnSegRows <- tcnSegRows[idxs,,drop=FALSE] - d;
+ verbose && str(verbose, tcnSegRows);
+ # Sanity checks
+ segRows <- tcnSegRows;
+ stopifnot(suppressWarnings(max(segRows, na.rm=TRUE)) <= nrow(dataT));
+ drow <- segRows[-1,1] - segRows[-nrow(segRows),2];
+ if (!all(is.na(drow) | (drow > 0))) {
+ print(segRows);
+ throw("INTERNAL ERROR: Generated 'tcnSegRows' is invalid, because it contains overlapping data chunks.");
+ }
+
+ dhSegRows <- dhSegRows[idxs,,drop=FALSE] - d;
+ verbose && str(verbose, dhSegRows);
+ # Sanity checks
+ segRows <- dhSegRows;
+ stopifnot(suppressWarnings(max(segRows, na.rm=TRUE)) <= nrow(dataT));
+ drow <- segRows[-1,1] - segRows[-nrow(segRows),2];
+ stopifnot(all(is.na(drow) | (drow > 0)));
+ if (!all(is.na(drow) | (drow > 0))) {
+ print(segRows);
+ throw("INTERNAL ERROR: Generated 'dhSegRows' is invalid, because it contains overlapping data chunks.");
+ }
+
+ verbose && exit(verbose);
+
+
+ # Create new object
+ res <- fit;
+ res$data <- dataT;
+ res$output <- segsT;
+ res$tcnSegRows <- tcnSegRows;
+ res$dhSegRows <- dhSegRows;
+
+ verbose && exit(verbose);
+
+ res;
+}, protected=TRUE) # extractSegments()
+
+
+
+###########################################################################/**
+# @set "class=PairedPSCBS"
+# @RdocMethod mergeTwoSegments
+#
+# @title "Merge two neighboring segments"
+#
+# \description{
+# @get "title" by recalculating segment statistics.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{left}{An @integer specifying the segments (left, left+1)
+# to be merged.}
+# \item{update}{If @TRUE, segment statistics are updated.}
+# \item{verbose}{A @logical or a @see "R.utils::Verbose" object.}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns a @see "PairedPSCBS" with one less segment.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# To drop regions (a connected set of segments) see \code{dropRegions()}.
+# @seeclass
+# }
+#*/###########################################################################
+setMethodS3("mergeTwoSegments", "PairedPSCBS", function(this, left, update=TRUE, verbose=FALSE, ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ nbrOfSegments <- nbrOfSegments(this, splitters=TRUE);
+ # Argument 'left':
+ left <- Arguments$getIndex(left, max=nbrOfSegments-1L);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Merging two segments");
+ verbose && printf(verbose, "Segments to be merged: %s & %s\n", left, left+1);
+ verbose && cat(verbose, "Number of segments before merging: ", nbrOfSegments);
+ verbose && cat(verbose, "Number of segments after merging: ", nbrOfSegments-1L);
+
+ segs <- getSegments(this, splitters=TRUE);
+ tcnSegRows <- this$tcnSegRows;
+ dhSegRows <- this$dhSegRows;
+
+ rows <- c(left,left+1);
+ segsT <- segs[rows,,drop=FALSE];
+
+ # Sanity check
+ chrs <- segsT[["chromosome"]];
+ if (chrs[1] != chrs[2]) {
+ throw("Cannot merge segments that are on different chromosomes: ", chrs[1], " != ", chrs[2]);
+ }
+
+ # Merge segments
+ segT <- segsT[1,];
+ fields <- colnames(segsT);
+
+ # (chromosome, tcnId, dhId)
+ idxsUsed <- 1:3;
+
+ # Starts
+ idxs <- grep("Start$", fields);
+ T <- as.matrix(segsT[,idxs,drop=FALSE]);
+ segT[,idxs] <- colMins(T, na.rm=TRUE);
+ idxsUsed <- c(idxsUsed, idxs);
+
+ # Ends
+ idxs <- grep("End$", fields);
+ T <- as.matrix(segsT[,idxs,drop=FALSE]);
+ segT[,idxs] <- colMaxs(T, na.rm=TRUE);
+ idxsUsed <- c(idxsUsed, idxs);
+
+ # Counts
+ idxs <- grep("NbrOf", fields);
+ segT[,idxs] <- colSums(segsT[,idxs,drop=FALSE]);
+ idxsUsed <- c(idxsUsed, idxs);
+
+ # "Invalidate" remaining entries
+ if (update) {
+ idxsTodo <- setdiff(seq(along=fields), idxsUsed);
+ segT[,idxsTodo] <- NA;
+ }
+
+ # Update segment table
+ segs[rows[1],] <- segT;
+ segs <- segs[-rows[2],];
+
+ # Update 'segRows' tables
+ segRows <- tcnSegRows;
+ segRows[rows[1],2] <- segRows[rows[2],2];
+ segRows <- segRows[-rows[2],];
+ tcnSegRows <- segRows;
+
+ segRows <- dhSegRows;
+ segRows[rows[1],2] <- segRows[rows[2],2];
+ segRows <- segRows[-rows[2],];
+ dhSegRows <- segRows;
+
+ # Create results object
+ res <- this;
+ res$output <- segs;
+ res$tcnSegRows <- tcnSegRows;
+ res$dhSegRows <- dhSegRows;
+
+ # Update the segment statistics?
+ if (update) {
+ res <- updateMeans(res);
+ }
+
+ verbose && exit(verbose);
+
+ res;
+}, private=TRUE)
+
+
+
+############################################################################
+# HISTORY:
+# 2012-02-24
+# o BUG FIX: The local updateSegRows() function inside extractSegments()
+# for PairedPSCBS would return incorrect and invalid row indices.
+# Copied ditto for CBS, which seems to work.
+# o ROBUSTNESS: Added more sanity checks validating the correctness of
+# what is returned by extractSegments() for PairedPSCBS.
+# 2012-01-09
+# o ROBUSTNESS: Now extractSegments() for PairedPSCBS gives an informative
+# error message that it is not supported if CNs were segmented using
+# flavor "tcn,dh".
+# 2011-10-16
+# o Added argument 'update' to mergeTwoSegments().
+# 2011-10-02
+# o CLEANUP: Dropped empty callSegments() for PairedPSCBS.
+# 2011-06-14
+# o Updated code to recognize new column names.
+# 2011-04-08
+# o BUG FIX: postsegmentTCN() for PairedPSCBS could generate an invalid
+# 'tcnSegRows' matrix, where the indices for two consecutive segments
+# would overlap, which is invalid.
+# 2011-04-05
+# o BUG FIX: estimateHighDHQuantileAtAB() for PairedPSCBS would throw
+# an error on an undefined 'trim' if verbose output was used.
+# 2011-02-17
+# o Added arguments 'robust' and 'trim' to estimateMeanForDH().
+# 2011-02-03
+# o Added argument 'tauTCN' to estimateMeanForDH().
+# 2011-01-27
+# o Added flavor="DHskew" to estimateTauAB().
+# o Added flavor="DH" to estimateTauAB() to estimate from DH instead
+# of hBAF. As argued by the equations in the comments, these two
+# approaches gives virtually the same results. The advantage with the
+# DH approach is that it requires one less degree of freedom.
+# o Added estimateMeanForDH().
+# 2011-01-18
+# o BUG FIX: 'tcnSegRows' and 'dhSegRows' where not updated by
+# extractByRegions() for PairedPSCBS.
+# 2011-01-14
+# o Added estimateTauAB() for estimating the DeltaAB parameter.
+# o Added estimateStdDevForHeterozygousBAF() for PairedPSCBS.
+# o BUG FIX: extractByRegions() did not handle the case where multiple loci
+# at the same position are split up in two different segments.
+# 2011-01-12
+# o Added extractByRegions() and extractByRegion() for PairedPSCBS.
+# o Now postsegmentTCN(..., force=TRUE) for PairedPSCBS also updates
+# the TCN estimates even for segments where the DH segmentation did
+# not find any additional change points.
+# 2010-12-02
+# o Now postsegmentTCN() assert that total number of TCN loci before
+# and after is the same.
+# o Now postsegmentTCN() assert that joinSegment is TRUE.
+# 2010-12-01
+# o Now postsegmentTCN() checks if it is already postsegmented.
+# 2010-11-30
+# o TODO: postsegmentTCN() does not make sure of 'dhLociToExclude'. Why?
+# o Now postsegmentTCN() recognizes the new 'tcnLociToExclude'.
+# 2010-11-28
+# o BUG FIX: postsegmentTCN() did not handle loci with the same positions
+# and that are split in two different segments. It also did not exclude
+# loci with missing values.
+# 2010-11-21
+# o Adjusted postsegmentTCN() such that the updated TCN segment boundaries
+# are the maximum of the DH segment and the support by the loci. This
+# means that postsegmentTCN() will work as expected both when signals
+# where segmented with 'joinSegments' being TRUE or FALSE.
+# 2010-10-25
+# o Now subsetByDhSegments() for PairedPSCBS handles the rare case when
+# markers with the same positions are split in two different segments.
+# o Renamed subsetBySegments() for PairedPSCBS to subsetByDhSegments().
+# 2010-09-26
+# o Now subsetBySegments() for PairedPSCBS handles multiple chromosomes.
+# o Now postsegmentTCN() PairedPSCBS handles multiple chromosomes.
+# 2010-09-21
+# o Added postsegmentTCN() for PairedPSCBS.
+# 2010-09-19
+# o BUG FIX: plot() used non-defined nbrOfLoci; now length(x).
+# 2010-09-15
+# o Added subsetBySegments().
+# o Added linesC1C2() and arrowsC1C2().
+# o Now the default 'cex' for pointsC1C2() corresponds to 'dh.num.mark'.
+# o Now extractTotalAndDH() also returns 'dh.num.mark'.
+# 2010-09-08
+# o Added argument 'add=FALSE' to plot().
+# o Added plotC1C2().
+# o Added extractTotalAndDH() and extractMinorMajorCNs().
+# 2010-09-04
+# o Added drawLevels() for PairedPSCBS.
+# o Added as.data.frame() and print() for PairedPSCBS.
+# 2010-09-03
+# o Added plot() for PairedPSCBS.
+# o Created.
+############################################################################
diff --git a/R/PairedPSCBS.applyByRegion.R b/R/PairedPSCBS.applyByRegion.R
new file mode 100644
index 0000000..9d7cd6d
--- /dev/null
+++ b/R/PairedPSCBS.applyByRegion.R
@@ -0,0 +1,307 @@
+setMethodS3("applyByRegion", "PairedPSCBS", function(fit, FUN, ..., subset=NULL, append=FALSE, verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'FUN':
+ stopifnot(is.function(FUN));
+
+ # Argument 'subset':
+ if (!is.null(subset)) {
+ subset <- Arguments$getIndices(subset, range=c(1, nbrOfSegments(fit)));
+ }
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Apply function region by region");
+ verbose && cat(verbose, "Segments:");
+ verbose && str(verbose, subset);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract data and estimates
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fit);
+ segs <- getSegments(fit);
+ tcnSegRows <- fit$tcnSegRows;
+ dhSegRows <- fit$dhSegRows;
+ params <- fit$params;
+
+ # Sanity checks
+ if (!params$joinSegments) {
+ throw("Cannot applyByRegion() unless PSCNs are segmented using joinSegments=TRUE.");
+ }
+ dataRows <- tcnSegRows;
+
+ # Sanity checks
+ stopifnot(all(!is.na(data$chromosome) & !is.na(data$x)));
+ stopifnot(length(tcnSegRows) == length(dhSegRows));
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # For each segment...
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ nbrOfSegments <- nrow(segs);
+ verbose && cat(verbose, "Number of segments: ", nbrOfSegments);
+
+ # Allocate result objects?
+ if (append) {
+ dataN <- outputN <- dataRowsN <- NULL;
+ }
+
+ if (is.null(subset)) {
+ subset <- seq_len(nbrOfSegments);
+ }
+
+ for (rr in subset) {
+ verbose && enter(verbose, sprintf("Segment #%d of %d", rr, nbrOfSegments));
+
+ # Extract segment
+ segRR <- segs[rr,,drop=FALSE];
+
+ # Nothing todo?
+ if (is.na(segRR[["tcnId"]]) && is.na(segRR[["dhId"]])) {
+ verbose && cat(verbose, "A divider. Nothing to do.");
+ outputN <- rbind(outputN, NA);
+ dataRowsN <- rbind(dataRowsN, NA);
+ verbose && exit(verbose);
+ next;
+ }
+
+ verbose && str(verbose, segRR, level=-20);
+
+ # Extract data
+ dataRowsRR <- dataRows[rr,,drop=FALSE];
+ from <- dataRowsRR[[1]];
+ to <- dataRowsRR[[2]];
+ ok <- (!is.na(from) & !is.na(to));
+ from <- from[ok];
+ to <- to[ok];
+ keep <- logical(nrow(data));
+ for (kk in seq(along=from)) {
+ keep[from[kk]:to[kk]] <- TRUE;
+ }
+ dataRowsRR <- which(keep);
+ verbose && printf(verbose, "Identified %d (%.2f%%) of %d data rows:\n", length(dataRowsRR), 100*length(dataRowsRR)/nrow(data), nrow(data));
+ verbose && str(verbose, dataRowsRR);
+ dataRR <- data[dataRowsRR,,drop=FALSE];
+ verbose && str(verbose, dataRR, level=-20);
+
+ verbose && enter(verbose, "Applying function 'FUN' to segment");
+ resRR <- FUN(rr, segRR, dataRR, ...);
+ verbose && cat(verbose, "Returned result:");
+ verbose && str(verbose, resRR, level=-20);
+ verbose && exit(verbose);
+
+ # Nothing to update/store?
+ if (!is.list(resRR)) {
+ verbose && cat(verbose, "Nothing more to do for this segment since nothing was returned: ", rr);
+ verbose && exit(verbose);
+ next;
+ }
+
+ # Extract return data
+ dataRRN <- resRR$data;
+ segRRN <- resRR$output;
+ # Sanity check
+ stopifnot(!is.null(dataRRN));
+ stopifnot(is.data.frame(dataRRN));
+ stopifnot(!is.null(segRRN));
+ stopifnot(is.data.frame(segRRN));
+
+ if (append) {
+ # Modified locus-level data
+ dataRowsRRN <- c(1L, nrow(dataRRN));
+ if (!is.null(dataN)) {
+ dataRowsRRN <- dataRowsRRN + nrow(dataN);
+ }
+ dataN <- rbind(dataN, dataRRN);
+ # Sanity checks
+ stopifnot(nrow(dataN) == max(dataRowsN, na.rm=TRUE));
+
+ # Update segment table?
+ outputN <- rbind(outputN, segRRN);
+ dataRowsN <- rbind(dataRowsN, dataRowsRRN);
+ # Sanity check
+ stopifnot(nrow(outputN) == nrow(dataRowsN));
+ # Sanity checks
+ stopifnot(nrow(dataN) == max(dataRowsN, na.rm=TRUE));
+ } else {
+ # Modified locus-level data
+ verbose && enter(verbose, "Updating locus-level data");
+ # Sanity check
+ stopifnot(dim(dataRRN) == dim(dataRR));
+ stopifnot(length(dataRowsRR) == nrow(dataRRN));
+ data[dataRowsRR,] <- dataRRN;
+ str(data[dataRowsRR,]);
+ verbose && exit(verbose);
+
+ # Modified segment data
+ verbose && enter(verbose, "Updating segment data");
+ # Sanity check
+ stopifnot(dim(segRRN) == dim(segRR));
+ segs[rr,] <- segRRN;
+ verbose && exit(verbose);
+ }
+
+ # Not needed anymore
+ dataRRN <- segRRN <- NULL;
+ dataRR <- segRR <- NULL;
+ resRR <- NULL;
+
+ verbose && exit(verbose);
+ } # for (rr ...)
+
+ if (append) {
+ if (!is.null(dataRowsN)) {
+ rownames(dataRowsN) <- NULL;
+ colnames(dataRowsN) <- colnames(dataRows);
+ dataRowsN <- as.data.frame(dataRowsN);
+ # Sanity checks
+ stopifnot(!is.null(dataN));
+ stopifnot(!is.null(outputN));
+ stopifnot(!is.null(dataRowsN));
+
+ data <- dataN;
+ segs <- outputN;
+
+ # Not needed anymore
+ dataN <- outputN <- NULL;
+ }
+ }
+
+ # Return result
+ res <- fit; # "clone"
+ res$data <- data;
+ res$output <- segs;
+
+ # Not needed anymore
+ data <- segs <- NULL;
+
+ # Update segment-to-locus index tables
+ if (append && !is.null(dataRowsN)) {
+ res$tcnSegRows <- dataRowsN;
+ res$dhSegRows <- dataRowsN; # Is this really the case? /HB 2011-01-17
+ }
+
+ verbose && exit(verbose);
+
+ res;
+}, private=TRUE)
+
+
+.addC1C2WithStatitics <- function(rr, output, data, robust=TRUE, ...) {
+ # Calculate locus-level (C1,C2)
+ C <- data$CT;
+ rho <- data$rho;
+ C1 <- 1/2 * (1 - rho) * C;
+ C2 <- C - C1;
+ CC <- data.frame(C1=C1, C2=C2);
+
+ if (robust) {
+ meanFcn <- function(x, ...) median(x, na.rm=TRUE);
+ sdFcn <- function(x, ...) mad(x, na.rm=TRUE);
+ } else {
+ meanFcn <- function(x, ...) mean(x, na.rm=TRUE);
+ sdFcn <- function(x, ...) sd(x, na.rm=TRUE);
+ }
+
+ # Calculate region-level (C1,C2) means and std devs.
+ muCC <- apply(CC, MARGIN=2, FUN=meanFcn);
+ sigmaCC <- apply(CC, MARGIN=2, FUN=sdFcn);
+ rhoCC <- cor(CC[,1], CC[,2], use="pairwise.complete.obs");
+
+ names(muCC) <- c("c1Avg", "c2Avg");
+ names(sigmaCC) <- c("c1Sd", "c2Sd");
+
+ # Update data
+ data <- cbind(data, CC);
+
+
+ # Update segment table
+ outputT <- c(muCC, sigmaCC, c1c2.cor=rhoCC);
+ outputT <- as.list(outputT);
+ outputT <- as.data.frame(outputT);
+
+ output <- cbind(output, outputT);
+
+ list(data=data, output=output);
+} # .addC1C2WithStatitics()
+
+
+.addCACBWithStatitics <- function(rr, output, data, beta=c("betaTN", "betaT"), stratifyBy=c("all", "hets", "homs"), robust=TRUE, ...) {
+ # Argument 'beta':
+ beta <- match.arg(beta);
+
+ # Argument 'stratifyBy':
+ stratifyBy <- match.arg(stratifyBy);
+
+ # Calculate locus-level (CA,CB)
+ C <- data$CT;
+ beta <- data[[beta]];
+ CB <- beta * C;
+ CA <- C - CB;
+ CC <- data.frame(CA=CA, CB=CB);
+
+ # Update data
+ data <- cbind(data, CC);
+
+
+ if (robust) {
+ meanFcn <- function(x, ...) median(x, na.rm=TRUE);
+ sdFcn <- function(x, ...) mad(x, na.rm=TRUE);
+ } else {
+ meanFcn <- function(x, ...) mean(x, na.rm=TRUE);
+ sdFcn <- function(x, ...) sd(x, na.rm=TRUE);
+ }
+
+ if (stratifyBy == "hets") {
+ muN <- data$muN;
+ keep <- (muN == 1/2);
+ CC <- CC[keep,,drop=FALSE];
+ } else if (stratifyBy == "homs") {
+ muN <- data$muN;
+ keep <- (muN == 0 | muN == 1);
+ CC <- CC[keep,,drop=FALSE];
+ }
+
+ # Calculate region-level (CA,CB) means and std devs.
+ muCC <- apply(CC, MARGIN=2, FUN=meanFcn);
+ sigmaCC <- apply(CC, MARGIN=2, FUN=sdFcn);
+ if (nrow(CC) < 3) {
+ rhoCC <- NA_real_;
+ } else {
+ rhoCC <- cor(CC[,1], CC[,2], use="pairwise.complete.obs");
+ }
+ names(muCC) <- c("caAvg", "cbAvg");
+ names(sigmaCC) <- c("caSd", "cbSd");
+
+ # Update segment table
+ outputT <- c(muCC, sigmaCC, cacbCor=rhoCC);
+ outputT <- as.list(outputT);
+ outputT <- as.data.frame(outputT);
+
+ output <- cbind(output, outputT);
+
+ list(data=data, output=output);
+} # .addCACBWithStatitics()
+
+
+
+#############################################################################
+# HISTORY:
+# 2013-10-21
+# o Added argument 'subset' to applyByRegion() for PairedPSCBS.
+# 2011-06-14
+# o Updated code to recognize new column names.
+# 2011-01-27
+# o Added .addCACBWithStatitics().
+# o Added .addC1C2WithStatitics().
+# o Added applyByRegion().
+# o Created.
+#############################################################################
diff --git a/R/PairedPSCBS.callAB.R b/R/PairedPSCBS.callAB.R
new file mode 100644
index 0000000..8b4a417
--- /dev/null
+++ b/R/PairedPSCBS.callAB.R
@@ -0,0 +1,280 @@
+###########################################################################/**
+# @set class=PairedPSCBS
+# @RdocMethod callAB
+# @aliasmethod callAllelicBalance
+#
+# @title "Calls segments that are in allelic balance"
+#
+# \description{
+# @get "title", i.e. that have equal minor and major copy numbers.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{flavor}{A @character string specifying which type of
+# call to use.}
+# \item{...}{Additional arguments passed to the caller.}
+# \item{minSize}{An optional @integer specifying the minimum number
+# of data points in order to call a segments. If fewer data points,
+# then the call is set to @NA regardless.}
+# \item{xorCalls}{If @TRUE, a region already called LOH, will
+# for consistency never be called AB, resulting in either an AB
+# call set to @FALSE or @NA (as explained below).}
+# \item{force}{If @FALSE, and allelic-balance calls already exits,
+# then nothing is done, otherwise the calls are done.}
+# }
+#
+# \value{
+# Returns a @see "PairedPSCBS" object with allelic-balance calls.
+# }
+#
+# \section{AB and LOH consistency}{
+# Biologically, a segment can not be both in allelic balance (AB) and
+# in loss-of-heterozygosity (LOH) at the same time.
+# To avoid reporting such inconsistencies, the LOH caller will,
+# if argument \code{xorCalls=TRUE}, never report a segment to be in
+# LOH if it is already called to be in AB.
+# However, regardless of of the AB call, a segment is still always
+# tested for LOH, to check weather the LOH caller is consistent with the
+# AB caller or not. Thus, in order to distinguish the case where
+# the AB caller and LOH caller agree from when they disagree,
+# we report either (AB,LOH)=(TRUE,FALSE) or (TRUE,NA). The former is
+# reported when they are consistent, and the latter when they are not,
+# or when the AB caller could not call it.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# Internally, one of the following methods are used:
+# @seemethod "callAllelicBalanceByDH".
+# }
+#
+#*/###########################################################################
+setMethodS3("callAB", "PairedPSCBS", function(fit, flavor=c("DeltaAB*"), ..., minSize=1, xorCalls=TRUE, force=FALSE) {
+ # Argument 'flavor':
+ flavor <- match.arg(flavor);
+
+ # Argument 'minSize':
+ minSize <- Arguments$getDouble(minSize, range=c(1,Inf));
+
+ # Argument 'xorCalls':
+ xorCalls <- Arguments$getLogical(xorCalls);
+
+
+ # Already done?
+ segs <- as.data.frame(fit);
+ calls <- segs$abCall;
+ if (!force && !is.null(calls)) {
+ return(invisible(fit));
+ }
+
+ if (flavor == "DeltaAB*") {
+ fit <- callAllelicBalanceByDH(fit, ...);
+ } else {
+ throw("Cannot call allelic balance. Unsupported flavor: ", flavor);
+ }
+
+ # Don't call segments with too few data points?
+ if (minSize > 1) {
+ segs <- as.data.frame(fit);
+ ns <- segs$dhNbrOfLoci;
+ calls <- segs$abCall;
+ calls[ns < minSize] <- NA;
+ segs$abCall <- calls;
+ fit$output <- segs;
+ # Not needed anymore
+ segs <- calls <- NULL;
+ }
+
+ # Don't call a segment AB if it already called LOH?
+ if (xorCalls) {
+ segs <- as.data.frame(fit);
+ if (is.element("lohCall", names(segs))) {
+ calls <- segs$abCall;
+ otherCalls <- segs$lohCall;
+ # If called (TRUE) and already called (TRUE)
+ # by the other caller, call it as NA.
+ calls[calls & otherCalls] <- NA;
+ segs$abCall <- calls;
+ fit$output <- segs;
+ }
+ }
+
+ return(invisible(fit));
+})
+
+setMethodS3("callAllelicBalance", "default", function(...) {
+ callAB(...);
+})
+
+
+
+###########################################################################/**
+# @set class=PairedPSCBS
+# @RdocMethod callAllelicBalanceByDH
+#
+# @title "Calls segments that are in allelic balance"
+#
+# \description{
+# @get "title" by thresholding on DH using a predetermined threshold.
+# The variability of the DH mean levels is taken into account via a
+# bootstrap estimator.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{flavor}{A @character string specifying which type of
+# call to use.}
+# \item{delta}{(Tuning parameter) A non-negative @numeric threshold.}
+# \item{alpha}{A @numeric in [0,1] specifying the upper and lower
+# quantiles calculated by the bootstrap estimator.}
+# \item{...}{Additional arguments passed to the bootstrap estimator
+# @seemethod "bootstrapTCNandDHByRegion".}
+# }
+#
+# \value{
+# Returns a @see "PairedPSCBS" object with allelic-balance calls.
+# }
+#
+# @author "HB"
+#
+# \section{Algorithm}{
+# \itemize{
+# \item Foo
+# \item Bar
+# }
+# }
+#
+# \seealso{
+# Instead of calling this method explicitly, it is recommended
+# to use the @seemethod "callAllelicBalance" method.
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("callAllelicBalanceByDH", "PairedPSCBS", function(fit, delta=estimateDeltaAB(fit, flavor="qq(DH)"), alpha=0.05, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'delta':
+ delta <- Arguments$getDouble(delta, range=c(0,Inf));
+
+ # Argument 'alpha':
+ alpha <- Arguments$getDouble(alpha, range=c(0,1));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Calling segments of allelic balance from one-sided DH bootstrap confidence intervals");
+ verbose && cat(verbose, "delta (offset adjusting for bias in DH): ", delta);
+ verbose && cat(verbose, "alpha (CI quantile; significance level): ", alpha);
+
+ # Calculate DH confidence intervals, if not already done
+ probs <- c(alpha, 1-alpha);
+ fit <- bootstrapTCNandDHByRegion(fit, probs=probs, ..., verbose=less(verbose, 50));
+
+ segs <- as.data.frame(fit);
+
+ # Extract confidence interval
+ alphaTag <- sprintf("%g%%", 100*alpha);
+ column <- sprintf("dh_%s", alphaTag);
+ # Sanity checks
+ stopifnot(is.element(column, colnames(segs)));
+
+ # One-sided test
+ verbose && enter(verbose, "Calling segments");
+ value <- segs[,column, drop=TRUE];
+ call <- (value < delta);
+ nbrOfCalls <- sum(call, na.rm=TRUE);
+ verbose && printf(verbose, "Number of segments called allelic balance (AB): %d (%.2f%%) of %d\n", nbrOfCalls, 100*nbrOfCalls/nrow(segs), nrow(segs));
+ verbose && exit(verbose);
+
+ segs$abCall <- call;
+ fit$output <- segs;
+
+ # Append 'delta' and 'alpha' to parameters
+ params <- fit$params;
+ params$deltaAB <- delta;
+ params$alphaAB <- alpha;
+ fit$params <- params;
+
+ verbose && exit(verbose);
+
+ fit;
+}, protected=TRUE) # callAllelicBalanceByDH()
+
+
+
+
+
+
+##############################################################################
+# HISTORY
+# 2012-01-15
+# o DOCUMENTATION: Added details to the help of callLOH() and callAB() on
+# the difference between (AB,LOH)=(TRUE,FALSE) and (AB,LOH)=(TRUE,NA).
+# 2011-07-07
+# o BUG FIX: Consecutive calls to callAB(..., force=TRUE) would append
+# additional 'abCall' columns to the segmentation table instead of
+# replacing existing calls.
+# 2011-06-14
+# o Updated code to recognize new column names.
+# 2011-05-29
+# o Renamed all arguments, variables, function named 'tau' to 'delta'.
+# 2011-04-14
+# o BUG FIX: Argument 'minSize' of callAB() and callLOH() had no effect.
+# 2011-04-12
+# o Added argument 'minSize' to callAB() for PairedPSCBS.
+# o Added argument 'xorCalls' to callAB() for PairedPSCBS.
+# 2011-04-10
+# o callAllelicBalance() calls callAB().
+# 2011-04-09
+# o Now callAllelicBalance(..., force=FALSE) skips the caller if allelic-
+# balance calls already exist.
+# 2011-04-08
+# o Added Rdoc for callAllelicBalance() and callAllelicBalanceByDH().
+# o Extracted from PairedPSCBS.CALL.R.
+# 2011-02-03
+# o Updated default for 'tauAB' of callABandHighAI() and callABandLowC1()
+# to be estimated from data using estimateTauAB().
+# 2010-12-07
+# o Added callLowC1ByC1() and callABandLowC1().
+# 2010-11-27
+# o Corrected verbose output to call results.
+# 2010-11-26 [HB]
+# o Now all call functions estimate symmetric bootstrap quantiles for
+# convenince of plotting confidence intervals.
+# o BUG FIX: callABandHighAI() for PairedPSCBS used the old DH-only
+# bootstrap method.
+# o BUG FIX: The call functions, for instance callABandHighAI(), would throw
+# 'Error in quantile.default(x, probs = alpha) : missing values and NaN's
+# not allowed if 'na.rm' is FALSE' unless bootstrapTCNandDHByRegion() was
+# run before.
+# 2010-11-22 [HB]
+# o Added more verbose output to callABandHighAI().
+# o Updated callAllelicBalanceByDH() and callExtremeAllelicImbalanceByDH()
+# to utilize bootstrapTCNandDHByRegion().
+# 2010-10-25 [HB]
+# o Relaced argument 'ciRange' with 'alpha' for callAllelicBalanceByDH() and
+# callExtremeAllelicImbalanceByDH().
+# o Renamed callAllelicBalance() to callAllelicBalanceByDH() and
+# callExtremeAllelicImbalanceByDH() to callExtremeAllelicImbalance().
+# o Added arguments 'alphaAB' and 'alphaHighAI' to callABandHighAI().
+# o Added sanity checks to the call methods.
+# o Now arguments '...' to callABandHighAI() are passed down.
+# o Now also arguments '...' to callAllelicBalance() and
+# callExtremeAllelicImbalance() are passed to bootstrapDHByRegion().
+# o Added argument 'ciRange' to callAllelicBalance() and
+# callExtremeAllelicImbalance().
+# 2010-09-16 [HB]
+# o Added callABandHighAI().
+# o Added callAllelicBalance() and callExtremeAllelicImbalance().
+# o Created.
+##############################################################################
diff --git a/R/PairedPSCBS.callCopyNeutral.R b/R/PairedPSCBS.callCopyNeutral.R
new file mode 100644
index 0000000..f4f9dcf
--- /dev/null
+++ b/R/PairedPSCBS.callCopyNeutral.R
@@ -0,0 +1,439 @@
+###########################################################################/**
+# @set class=PairedPSCBS
+# @RdocMethod callCopyNeutral
+# @aliasmethod callNTCN
+#
+# @title "Calls segments that have a neutral total copy number"
+#
+# \description{
+# @get "title" (NTCN),
+# i.e. that have a TCN that corresponds to the ploidy of the genome.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{flavor}{A @character string specifying which type of
+# call to use.}
+# \item{...}{Additional arguments passed to the caller.}
+# \item{minSize}{An optional @integer specifying the minimum number
+# of data points in order to call a segments. If fewer data points,
+# then the call is set to @NA regardless.}
+# \item{force}{If @FALSE, and copy-neutral calls already exits,
+# then nothing is done, otherwise the calls are done.}
+# }
+#
+# \value{
+# Returns a @see "PairedPSCBS" object with copy-neutral calls.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# Internally, one of the following methods are used:
+# @seemethod "callCopyNeutralByTCNofAB".
+# }
+#
+#*/###########################################################################
+setMethodS3("callCopyNeutral", "PairedPSCBS", function(fit, flavor=c("TCN|AB"), ..., minSize=1, force=FALSE) {
+ # Argument 'flavor':
+ flavor <- match.arg(flavor);
+
+ # Argument 'minSize':
+ minSize <- Arguments$getDouble(minSize, range=c(1,Inf));
+
+
+ # Already done?
+ segs <- as.data.frame(fit);
+ calls <- segs$ntcnCall;
+ if (!force && !is.null(calls)) {
+ return(invisible(fit));
+ }
+
+ if (flavor == "TCN|AB") {
+ fit <- callCopyNeutralByTCNofAB(fit, ..., force=force);
+ } else {
+ throw("Cannot call copy-neutral states. Unsupported flavor: ", flavor);
+ }
+
+ # Don't call segments with too few data points?
+ if (minSize > 1) {
+ segs <- as.data.frame(fit);
+ ns <- segs$dhNbrOfLoci;
+ calls <- segs$ntcnCall;
+ calls[ns < minSize] <- NA;
+ segs$ntcnCall <- calls;
+ fit$output <- segs;
+ # Not needed anymore
+ segs <- calls <- NULL;
+ }
+
+ return(invisible(fit));
+})
+
+setMethodS3("callNTCN", "PairedPSCBS", function(...) {
+ callCopyNeutral(...);
+})
+
+
+
+
+setMethodS3("calcStatsForCopyNeutralABs", "PairedPSCBS", function(fit, ..., force=FALSE, verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'force':
+ force <- Arguments$getLogical(force);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "calcStatsForCopyNeutralABs");
+
+ segsNTCN <- fit$params$copyNeutralStats;
+ if (!force && !is.null(segsNTCN)) {
+ verbose && exit(verbose);
+ return(fit);
+ }
+
+ verbose && enter(verbose, "Identifying copy neutral AB segments");
+
+ # Getting AB calls
+ segs <- getSegments(fit, splitters=TRUE);
+ isAB <- segs$abCall;
+ if (is.null(isAB)) {
+ throw("Cannot call copy-neutral states, because allelic-balance calls have not been made yet.");
+ }
+
+ nABs <- sum(isAB, na.rm=TRUE);
+ verbose && cat(verbose, "Number of AB segments: ", nABs);
+ if (nABs == 0L) {
+ throw("Cannot call copy-neutral states, because none of the segments are in allelic balance.");
+ }
+
+ C <- segs[,"tcnMean", drop=TRUE];
+ isAB <- segs[,"abCall", drop=TRUE];
+ n <- segs[,"tcnNbrOfSNPs", drop=TRUE]; # "tcnNbrOfLoci"? /HB 2010-09-09
+
+ # Give more weight to longer regions
+ weights <- n;
+
+ # Identify copy neutral AB segments
+ isNeutralAB <- findNeutralCopyNumberState(C=C, isAI=!isAB, weights=weights,
+ ..., flavor="maxPeak", verbose=verbose);
+ nAB <- sum(isNeutralAB, na.rm=TRUE);
+ verbose && cat(verbose, "Number of copy-neutral AB segments: ", nAB);
+ if (nAB == 0L) {
+ throw("Cannot call copy-neutral states, because none of the segments in allelic-balance are copy neutral.");
+ }
+
+ verbose && enter(verbose, "Extracting all copy neutral AB segments across all chromosomes into one big segment");
+
+ # (a) Extract those
+ fitNTCN <- extractSegments(fit, isNeutralAB);
+ verbose && print(verbose, fitNTCN);
+ verbose && exit(verbose);
+
+ # (b) Turn into a single-chromosome data set
+ fitNTCN <- extractSegments(fitNTCN, !isSegmentSplitter(fitNTCN));
+ isSplitter <- is.na(fitNTCN$output$chromosome);
+ fitNTCN$data$chromosome <- 0L;
+ fitNTCN$output$chromosome <- 0L;
+ fitNTCN$output$chromosome[isSplitter] <- NA;
+
+
+ # (c) Turn into one big segment by dropping all change points
+## nCPs <- nbrOfChangePoints(fitNTCN, ignoreGaps=TRUE);
+ nCPs <- nbrOfSegments(fitNTCN, splitters=TRUE) - 1L;
+ if (nCPs >= 1L) {
+ verbose && enter(verbose, "Dropping all change points");
+ fitNTCN <- dropChangePoints(fitNTCN, idxs=nCPs:1, ignoreGaps=TRUE, update=TRUE, verbose=less(verbose, 5));
+ verbose && exit(verbose);
+ }
+ # Sanity check
+ stopifnot(nbrOfSegments(fitNTCN) == 1L);
+ verbose && exit(verbose);
+
+ verbose && enter(verbose, "Bootstrap the identified copy-neutral states");
+ fitNTCN <- bootstrapTCNandDHByRegion(fitNTCN, what="segment", force=TRUE,
+ ..., verbose=less(verbose, 50));
+ segsNTCN <- getSegments(fitNTCN, simplified=FALSE);
+ names <- colnames(segsNTCN);
+ excl <- grep("(^chromosome|Id|Start|End|Call)$", names);
+ segsNTCN <- segsNTCN[,-excl,drop=FALSE];
+ # Sanity check
+ stopifnot(ncol(segsNTCN) > 0L);
+ verbose && exit(verbose);
+
+ verbose && print(verbose, segsNTCN);
+ verbose && exit(verbose);
+
+ fit$params$copyNeutralStats <- segsNTCN;
+
+ invisible(fit);
+}, protected=TRUE) # calcStatsForCopyNeutralABs()
+
+
+setMethodS3("estimateDeltaCN", "PairedPSCBS", function(fit, scale=1, kappa=estimateKappa(fit), ...) {
+ # Argument 'scale':
+ disallow <- c("NA", "NaN", "Inf");
+ scale <- Arguments$getDouble(scale, range=c(0,Inf), disallow=disallow);
+
+ # Argument 'kappa':
+ disallow <- c("NA", "NaN", "Inf");
+ kappa <- Arguments$getDouble(kappa, range=c(0,1), disallow=disallow);
+
+ # Half a TCN unit length
+ delta <- (1-kappa)/2;
+
+ # Rescale
+ delta <- scale * delta;
+
+ delta;
+}, protected=TRUE) # estimateDeltaCN()
+
+
+
+###########################################################################/**
+# @set class=PairedPSCBS
+# @RdocMethod callCopyNeutralByTCNofAB
+#
+# @title "Calls regions that are copy neutral"
+#
+# \description{
+# @get "title" from the total copy numbers (TCNs) of segments
+# in allelic balance (AB).
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{fit}{A PairedPSCBS fit object as returned by
+# @see "PSCBS::segmentByPairedPSCBS".}
+# \item{delta}{A non-negative @double specifying the width of the
+# "acceptance" region.
+# Defaults to half of the distance between two integer TCN states,
+# i.e. 1/2. This argument should be shrunken as a function of
+# the amount of the normal contamination and other background signals.}
+# \item{alpha}{A @double in [0,0.5] specifying the significance level
+# of the confidence intervals used.}
+# \item{...}{Additional arguments passed to
+# @seemethod "calcStatsForCopyNeutralABs".}
+# \item{force}{If @TRUE, an already called object is skipped, otherwise not.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns a @see "PairedPSCBS" fit object where a column
+# with the copy-neutral call.
+# }
+#
+# \details{
+# ...
+# }
+#
+# %% examples "../incl/callCopyNeutralByTCNofAB.PairedPSCBS.Rex"
+#
+# @author "HB"
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("callCopyNeutralByTCNofAB", "PairedPSCBS", function(fit, delta=estimateDeltaCN(fit), alpha=0.05, ..., force=FALSE, verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'delta':
+ disallow <- c("NA", "NaN", "Inf");
+ delta <- Arguments$getDouble(delta, range=c(0,Inf), disallow=disallow);
+
+ # Argument 'alpha':
+ disallow <- c("NA", "NaN", "Inf");
+ alpha <- Arguments$getDouble(alpha, range=c(0,0.5), disallow=disallow);
+
+ # Argument 'force':
+ force <- Arguments$getLogical(force);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "callCopyNeutralByTCNofAB");
+ verbose && cat(verbose, "Alpha: ", alpha);
+ verbose && cat(verbose, "Delta CN: ", delta);
+
+ segs <- getSegments(fit, splitters=TRUE, simplify=FALSE);
+
+ # Nothing to do?
+ if (!force && !is.null(segs$ntcnCall)) {
+ # Copy neutral segments are already called
+ verbose && cat(verbose, "Already called. Skipping.");
+ verbose && exit(verbose);
+ return(fit);
+ }
+
+ verbose && enter(verbose, "Calling copy-neutral segments");
+
+ verbose && enter(verbose, "Retrieve TCN confidence intervals for all segments");
+
+ # Calculate TCN bootstrap estimates, if missing
+ probs <- c(alpha/2, 1-alpha/2);
+
+ verbose && printf(verbose, "Interval: [%g,%g]\n", probs[1], probs[2]);
+
+ keys <- sprintf("tcn_%g%%", 100*c(probs[1], probs[2]));
+ missing <- keys[!is.element(keys, colnames(segs))];
+ if (length(missing) > 0) {
+ fit <- bootstrapTCNandDHByRegion(fit, probs=probs, ..., verbose=less(verbose, 50));
+ segs <- getSegments(fit, splitters=TRUE, simplify=FALSE);
+
+ # Assert that they exists
+ missing <- keys[!is.element(keys, colnames(segs))];
+ if (length(missing) > 0) {
+ throw("INTERNAL ERROR: No such statistics: ", hpaste(missing));
+ }
+ }
+
+ verbose && exit(verbose);
+
+
+ verbose && enter(verbose, "Estimating TCN confidence interval of copy-neutral AB segments");
+
+ fit <- calcStatsForCopyNeutralABs(fit, ..., verbose=less(verbose, 5));
+ stats <- fit$params$copyNeutralStats;
+ verbose && cat(verbose, "Bootstrap statistics for copy-neutral AB segments:");
+ verbose && print(verbose, stats);
+
+ # Extract TCN stats
+ cols <- grep("^(tcn_|tcnMean)", colnames(stats));
+ tcnStats <- stats[,cols,drop=FALSE];
+ tcnStats <- unlist(tcnStats, use.names=TRUE);
+ verbose && print(verbose, "TCN statistics:");
+ verbose && print(verbose, tcnStats);
+
+ # Assert confidence interval of interest
+ missing <- keys[!is.element(keys, names(tcnStats))];
+ if (length(missing) > 0) {
+ throw("INTERNAL ERROR: No such statistics: ", hpaste(missing));
+ }
+ mean <- tcnStats["tcnMean"];
+ ci <- tcnStats[keys];
+ verbose && printf(verbose, "%g%%-confidence interval of TCN mean for the copy-neutral state: [%g,%g] (mean=%g)\n", 100*(1-alpha), ci[1], ci[2], mean);
+
+ verbose && exit(verbose);
+
+
+ verbose && enter(verbose, "Identify all copy-neutral segments");;
+ verbose && printf(verbose, "DeltaCN: +/-%g\n", delta);
+ range <- ci + delta*c(-1,+1);
+ verbose && printf(verbose, "Call (\"acceptance\") region: [%g,%g]\n", range[1], range[2]);
+
+ # Get TCN confidence intervals for all segments
+ ci <- segs[,keys];
+ ci <- as.matrix(ci);
+
+ ## WAS: If a confidence interval is completely within the
+ ## calling region, call it
+ ## isNTCN <- (range[1] <= ci[,1] & ci[,2] <= range[2]);
+
+ # If a segments confidence interval is completely outside the
+ # copy-neutral region ("H_0"), that is, it is completely within
+ # the rejection region ("H_1"), then the H_0 hypothesis that the
+ # segment is copy-neutral in TCN is rejected.
+ isLoss <- (ci[,2] < range[1]); # (a) completely below, or
+ isGain <- (ci[,1] > range[2]); # (b) completely above.
+ isNTCN <- (!isLoss & !isGain); # => completely inside => not rejected.
+
+ nbrOfSegs <- nrow(segs);
+ nbrOfABs <- sum(segs$abCall, na.rm=TRUE);
+ nbrOfCNs <- sum(isNTCN, na.rm=TRUE);
+ verbose && cat(verbose, "Total number of segments: ", nbrOfSegs);
+ verbose && cat(verbose, "Number of segments called allelic balance: ", nbrOfABs);
+ verbose && cat(verbose, "Number of segments called copy neutral: ", nbrOfCNs);
+
+ nbrOfCNABs <- sum(isNTCN & segs$abCall, na.rm=TRUE);
+ verbose && cat(verbose, "Number of AB segments called copy neutral: ", nbrOfCNABs);
+ nbrOfCNNonABs <- sum(isNTCN & !segs$abCall, na.rm=TRUE);
+ verbose && cat(verbose, "Number of non-AB segments called copy neutral: ", nbrOfCNNonABs);
+
+ verbose && exit(verbose);
+
+
+ # Sanity check
+# # All previously called AB regions should remain called here as well
+# stopifnot(all(isNTCN[isNeutralAB], na.rm=TRUE));
+
+ segs$ntcnCall <- isNTCN;
+
+ params <- fit$params;
+ params$deltaCN <- delta;
+ params$ntcnRange <- range;
+
+ fitC <- fit;
+ fitC$output <- segs;
+ fitC$params <- params;
+
+ verbose && exit(verbose);
+
+ fitC;
+}, protected=TRUE) # callCopyNeutralByTCNofAB()
+
+
+
+##############################################################################
+# HISTORY
+# 2013-10-21 [HB]
+# o ROBUSTNESS: Now calcStatsForCopyNeutralABs() only bootstraps the
+# segments of the subsetted copy-neutral segments.
+# 2013-04-17 [HB]
+# o BUG FIX: Internal calcStatsForCopyNeutralABs() would give an error
+# if there was exactly two AH segments.
+# 2013-03-19 [HB]
+# o CALLING: Defined a formal hypthesis test for how segments are called
+# copy-neutral in TCN (NTCN), with the null hypothesis being that a
+# segment is NTCN. In order for a segment to not be NTCN, its confidence
+# interval has to be completely outside the null region. This changed
+# how callCopyNeutralByTCNofAB() for PairedPSCBS calls segments; it is
+# now a bit more conservative in rejecting NTCN.
+# o ROBUSTNESS: Now calcStatsForCopyNeutralABs() for PairedPSCBS does
+# a better job in identifying the TCN mode of the AB segments.
+# o Now callCopyNeutralByTCNofAB() records parameters 'deltaCN' and
+# 'ntcnRange'.
+# 2012-09-21 [HB]
+# o BUG FIX: Recent updates in how nbrOfChangePoints() is calculated,
+# caused callGNL() to throw an exception. Added argument 'ignoreGaps'
+# to nbrOfChangePoints().
+# 2012-07-02 [HB]
+# o Renamed callTCNN() to callNTCN().
+# 2012-06-24 [HB]
+# o Renamed callCN() to callTCNN() in order not to confuse it with
+# copy numbers in general.
+# 2012-06-03 [HB]
+# o Added estimateDeltaCN() for PairedPSCBS, which is calculated as a
+# function of the amount of normal contamination as currently estimated
+# by estimateKappa().
+# o Now callCopyNeutralByTCNofAB() runs bootstrapping if quantiles are
+# missing.
+# 2012-02-25 [HB]
+# o Added internal calcStatsForCopyNeutralABs() for PairedPSCBS.
+# 2012-02-24 [HB]
+# o Now callCopyNeutralByTCNofAB() calls all segements, not just those in AB.
+# o Now the copy-neutral calls are named 'cnCall' (not 'neutralCall').
+# o Added callCN()/callCopyNeutral().
+# o Added callCopyNeutralByTCNofAB() for PairedPSCBS. The method was
+# adopted from callCopyNeutralRegions() in aroma.cn, whose history has
+# been incorporated below.
+# o Created.
+# 2010-09-15* [HB]
+# o Added Rdocs for callCopyNeutralRegions().
+# 2010-09-09* [HB]
+# o Added callCopyNeutralRegions() for PairedPSCBS.
+##############################################################################
diff --git a/R/PairedPSCBS.callGNL.R b/R/PairedPSCBS.callGNL.R
new file mode 100644
index 0000000..4af27c0
--- /dev/null
+++ b/R/PairedPSCBS.callGNL.R
@@ -0,0 +1,307 @@
+###########################################################################/**
+# @set class=PairedPSCBS
+# @RdocMethod callGNL
+# @aliasmethod callGainNeutralLoss
+# @alias callGNLByTCNofAB
+# @aliasmethod callGNLByTCNofAB
+# @alias callGNLByTCNofABv1
+# @aliasmethod callGNLByTCNofABv1
+#
+# @title "Calls segments that are gained, copy neutral, or lost"
+#
+# \description{
+# @get "title", where copy neutral means having a total copy number
+# that corresponds to the ploidy of the genome.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{flavor}{A @character string specifying which type of
+# call to use.}
+# \item{...}{Additional arguments passed to the caller.}
+# \item{minSize}{An optional @integer specifying the minimum number
+# of data points in order to call a segments. If fewer data points,
+# then the call is set to @NA regardless.}
+# \item{force}{If @FALSE, and copy-neutral calls already exits,
+# then nothing is done, otherwise the calls are done.}
+# }
+#
+# \value{
+# Returns a @see "PairedPSCBS" object with added calls.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# Internally, one of the following methods are used:
+# \code{callGNLByTCNofAB()}.
+# }
+#
+#*/###########################################################################
+setMethodS3("callGNL", "PairedPSCBS", function(fit, flavor=c("TCN|AB"), ..., minSize=1, force=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'flavor':
+ flavor <- match.arg(flavor);
+
+ # Argument 'minSize':
+ minSize <- Arguments$getDouble(minSize, range=c(1,Inf));
+
+
+ # Already done?
+ segs <- as.data.frame(fit);
+ if (!force && all(is.element(c("gainCall", "ntcnCall", "lossCall"), names(segs)))) {
+ # Segments are already called
+ return(invisible(fit));
+ }
+
+ if (flavor == "TCN|AB") {
+ fit <- callGNLByTCNofAB(fit, ..., force=force);
+ } else {
+ throw("Cannot call allelic balance. Unsupported flavor: ", flavor);
+ }
+
+ # Don't call segments with too few data points?
+ if (minSize > 1) {
+ segs <- as.data.frame(fit);
+ ns <- segs$dhNbrOfLoci;
+ calls <- segs$ntcnCall;
+ calls[ns < minSize] <- NA;
+ segs$ntcnCall <- calls;
+ fit$output <- segs;
+ # Not needed anymore
+ segs <- calls <- NULL;
+ }
+
+ return(invisible(fit));
+}) # callGNL()
+
+setMethodS3("callGainNeutralLoss", "PairedPSCBS", function(...) {
+ callGNL(...);
+})
+
+
+setMethodS3("callGNLByTCNofAB", "PairedPSCBS", function(fit, ..., minSize=1L, force=FALSE, verbose=FALSE) {
+ # Argument 'minSize':
+ minSize <- Arguments$getDouble(minSize, range=c(1,Inf));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Calling gain, neutral, and loss based TCNs of AB segments");
+
+ # Already done?
+ segs <- as.data.frame(fit);
+ called <- all(is.element(c("gainCall", "ntcnCall", "lossCall"), names(segs)));
+ if (!force && called) {
+ return(invisible(fit));
+ }
+
+ verbose && enter(verbose, "Calling neutral TCNs");
+ fit <- callCopyNeutralByTCNofAB(fit, ..., verbose=verbose);
+ verbose && exit(verbose);
+
+ # The segment data
+ segs <- as.data.frame(fit);
+ tcnMean <- segs$tcnMean;
+ nbrOfSegs <- nrow(segs);
+
+ # The call thresholds and the NTCN calls
+ ntcnCall <- call <- segs$ntcnCall;
+ verbose && printf(verbose, "Number of NTCN calls: %d (%.2f%%) of %d\n", sum(call, na.rm=TRUE), 100*sum(call, na.rm=TRUE)/nbrOfSegs, nbrOfSegs);
+
+ params <- fit$params;
+
+ deltaCN <- params$deltaCN;
+ stopifnot(!is.null(deltaCN));
+ ntcnRange <- params$ntcnRange;
+ stopifnot(!is.null(ntcnRange));
+
+ # Confidence interval of the TCN|AB segments
+ range <- ntcnRange + c(+1,-1)*deltaCN;
+
+ # Mean of the TCN|AB segments
+ mu <- mean(range, na.rm=TRUE);
+
+ verbose && printf(verbose, "Mean TCN of AB segments: %g\n", mu);
+
+ verbose && enter(verbose, "Calling loss");
+ call <- !ntcnCall & (tcnMean < mu);
+ segs$lossCall <- call;
+ verbose && printf(verbose, "Number of loss calls: %d (%.2f%%) of %d\n", sum(call, na.rm=TRUE), 100*sum(call, na.rm=TRUE)/nbrOfSegs, nbrOfSegs);
+ verbose && exit(verbose);
+
+ verbose && enter(verbose, "Calling gain");
+ call <- !ntcnCall & (tcnMean > mu);
+ segs$gainCall <- call;
+ verbose && printf(verbose, "Number of loss calls: %d (%.2f%%) of %d\n", sum(call, na.rm=TRUE), 100*sum(call, na.rm=TRUE)/nbrOfSegs, nbrOfSegs);
+ verbose && exit(verbose);
+
+ # Recording
+ fit$output <- segs;
+
+ verbose && exit(verbose);
+
+ fit;
+}) # callGNLByTCNofAB()
+
+
+
+setMethodS3("callGNLByTCNofABv1", "PairedPSCBS", function(fit, deltaLoss=-0.5, deltaGain=+0.5, alpha=0.05, ..., force=FALSE, verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'alpha':
+ disallow <- c("NA", "NaN", "Inf");
+ alpha <- Arguments$getDouble(alpha, range=c(0,0.5), disallow=disallow);
+
+ # Argument 'deltaLoss' & 'deltaGain':
+ disallow <- c("NA", "NaN", "Inf");
+ deltaLoss <- Arguments$getDouble(deltaLoss, range=c(-Inf,0), disallow=disallow);
+ deltaGain <- Arguments$getDouble(deltaGain, range=c(0,+Inf), disallow=disallow);
+
+ # Argument 'force':
+ force <- Arguments$getLogical(force);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "callGNLByTCNofAB");
+ verbose && cat(verbose, "Alpha: ", alpha);
+ verbose && cat(verbose, "Delta loss: ", deltaLoss);
+ verbose && cat(verbose, "Delta gain: ", deltaGain);
+
+ segs <- getSegments(fit, splitters=TRUE, simplify=FALSE);
+
+ # Already done?
+ if (!force && all(is.element(c("gainCall", "ntcnCall", "lossCall"), names(segs)))) {
+ # Segments are already called
+ verbose && cat(verbose, "Already called. Skipping.");
+ verbose && exit(verbose);
+ return(invisible(fit));
+ }
+
+ # Check that bootstrap estimates exists
+ keys <- sprintf("tcn_%g%%", 100*c(alpha/2, 1-alpha/2));
+ missing <- keys[!is.element(keys, colnames(segs))];
+ if (length(missing) > 0) {
+ throw("No such statistics: ", hpaste(missing));
+ }
+
+ verbose && enter(verbose, "Calling segments");
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Confidence interval of copy-neutral AB segments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Estimating TCN confidence interval of copy-neutral AB segments");
+
+ fit <- calcStatsForCopyNeutralABs(fit, ..., verbose=less(verbose, 5));
+ stats <- fit$params$copyNeutralStats;
+ verbose && cat(verbose, "Bootstrap statistics for copy-neutral AB segments:");
+ verbose && print(verbose, stats);
+
+ # Extract TCN stats
+ cols <- grep("^(tcn_|tcnMean)", colnames(stats));
+ tcnStats <- stats[,cols,drop=FALSE];
+ tcnStats <- unlist(tcnStats, use.names=TRUE);
+ verbose && print(verbose, "TCN statistics:");
+ verbose && print(verbose, tcnStats);
+
+ # Extract confidence interval of interest
+ keys <- sprintf("tcn_%g%%", 100*c(alpha/2, 1-alpha/2));
+ missing <- keys[!is.element(keys, names(tcnStats))];
+ if (length(missing) > 0) {
+ throw("No such statistics: ", hpaste(missing));
+ }
+ mean <- tcnStats["tcnMean"];
+ ci <- tcnStats[keys];
+ verbose && printf(verbose, "%g%%-confidence interval of TCN mean for the copy-neutral state: [%g,%g] (mean=%g)\n", 100*(1-alpha), ci[1], ci[2], mean);
+
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Get call regions
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ naValue <- NA_real_;
+ callRegions <- matrix(c(
+ Inf, 1,
+ 1, 1,
+ 1, Inf
+ ), nrow=3, ncol=2, byrow=TRUE);
+ rownames(callRegions) <- c("loss", "ntcn", "gain");
+ colnames(callRegions) <- c("lower", "upper");
+ callRegions["loss",] <- ci[1]+callRegions["loss",]*deltaLoss;
+ callRegions["ntcn",] <- ci +callRegions["ntcn",]*c(deltaLoss, deltaGain);
+ callRegions["gain",] <- ci[2]+callRegions["gain",]*deltaGain;
+
+ verbose && cat(verbose, "Call (\"acceptance\") regions:");
+ verbose && print(verbose, callRegions);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Get statistics for all segments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ nbrOfSegs <- nrow(segs);
+ verbose && cat(verbose, "Number of segments: ", nbrOfSegs);
+ nbrOfABs <- sum(segs$abCall, na.rm=TRUE);
+ verbose && cat(verbose, "Number of AB segments: ", nbrOfABs);
+ verbose && cat(verbose, "Number of non-AB segments: ", nbrOfSegs-nbrOfABs);
+
+ # Get TCN confidence intervals for all segments
+ keys <- sprintf("tcn_%g%%", 100*c(alpha/2, 1-alpha/2));
+ ci <- segs[,keys];
+
+ # Call states
+ for (rr in seq(length=nrow(callRegions))) {
+ state <- rownames(callRegions)[rr];
+ verbose && enter(verbose, "Identify all '", state, "' segments");;
+ range <- callRegions[rr,];
+ verbose && printf(verbose, "Call (\"acceptance\") region: [%g,%g]\n", range[1], range[2]);
+
+ # If a confidence interval is completely within the
+ # calling region, call it
+ isCalled <- (range[1] <= ci[,1] & ci[,2] < range[2]);
+
+ nbrOfCalled <- sum(isCalled, na.rm=TRUE);
+ verbose && cat(verbose, "Number of segments called '", state, "': ", nbrOfCalled);
+## verbose && cat(verbose, "Number of non-AB segments called '", state, "': ", (nbrOfSegs-nbrOfABs)-nbrOfCalled);
+
+ key <- sprintf("%sCall", state);
+ segs[[key]] <- isCalled;
+ verbose && exit(verbose);
+ } # for (rr ...)
+
+ fitC <- fit;
+ fitC$output <- segs;
+
+ verbose && exit(verbose);
+
+ fitC;
+}, protected=TRUE) # callGNLByTCNofABv1()
+
+
+
+##############################################################################
+# HISTORY
+# 2013-09-20 [HB]
+# o BUG FIX: callGNL() for PairedPSCBS used non-defined 'verbose' object.
+# 2012-03-22 [HB]
+# o Renamed 'cnCall' to 'ntcnCall' for callGNLByTCNofAB().
+# 2012-02-26 [HB]
+# o Added internal callGNLByTCNofAB().
+# o Added callGNL().
+##############################################################################
diff --git a/R/PairedPSCBS.callLOH.R b/R/PairedPSCBS.callLOH.R
new file mode 100644
index 0000000..d977e6a
--- /dev/null
+++ b/R/PairedPSCBS.callLOH.R
@@ -0,0 +1,299 @@
+##########################################################################/**
+# @set class=PairedPSCBS
+# @RdocMethod callLOH
+#
+# @title "Calls segments that are in LOH"
+#
+# \description{
+# @get "title", i.e. that have "zero" minor copy number.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{flavor}{A @character string specifying which type of
+# call to use.}
+# \item{...}{Additional arguments passed to the caller.}
+# \item{minSize}{An optional @integer specifying the minimum number
+# of data points in order to call a segments. If fewer data points,
+# then the call is set to @NA regardless.}
+# \item{xorCalls}{If @TRUE, a region already called AB, will
+# for consistency never be called LOH, resulting in either an LOH
+# call set to @FALSE or @NA (as explained below).}
+# \item{force}{If @FALSE, and allelic-balance calls already exits,
+# then nothing is done, otherwise the calls are done.}
+# }
+#
+# \value{
+# Returns a @see "PairedPSCBS" object with LOH calls.
+# }
+#
+# \section{AB and LOH consistency}{
+# Biologically, a segment can not be both in allelic balance (AB) and
+# in loss-of-heterozygosity (LOH) at the same time.
+# To avoid reporting such inconsistencies, the LOH caller will,
+# if argument \code{xorCalls=TRUE}, never report a segment to be in
+# LOH if it is already called to be in AB.
+# However, regardless of of the AB call, a segment is still always
+# tested for LOH, to check weather the LOH caller is consistent with the
+# AB caller or not. Thus, in order to distinguish the case where
+# the AB caller and LOH caller agree from when they disagree,
+# we report either (AB,LOH)=(TRUE,FALSE) or (TRUE,NA). The former is
+# reported when they are consistent, and the latter when they are not,
+# or when the LOH caller could not call it.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# Internally, one of the following methods are used:
+# @seemethod "callLowC1ByC1",
+# @seemethod "callExtremeAllelicImbalanceByDH".
+# }
+#
+#*/###########################################################################
+setMethodS3("callLOH", "PairedPSCBS", function(fit, flavor=c("SmallC1", "LargeDH"), ..., minSize=1, xorCalls=TRUE, force=FALSE) {
+ # Argument 'flavor':
+ flavor <- match.arg(flavor);
+
+ # Argument 'minSize':
+ minSize <- Arguments$getDouble(minSize, range=c(1,Inf));
+
+ # Argument 'xorCalls':
+ xorCalls <- Arguments$getLogical(xorCalls);
+
+
+ # Already done?
+ segs <- as.data.frame(fit);
+ calls <- segs$lohCall;
+ if (!force && !is.null(calls)) {
+ return(invisible(fit));
+ }
+
+
+ if (flavor == "SmallC1") {
+ fit <- callLowC1ByC1(fit, ..., callName="loh");
+ } else if (flavor == "LargeDH") {
+ fit <- callExtremeAllelicImbalanceByDH(fit, ..., callName="loh");
+ } else {
+ throw("Cannot call LOH. Unsupported flavor: ", flavor);
+ }
+
+ # Don't call segments with too few data points?
+ if (minSize > 1) {
+ segs <- as.data.frame(fit);
+ ns <- segs$dhNbrOfLoci;
+ calls <- segs$lohCall;
+ calls[ns < minSize] <- NA;
+ segs$lohCall <- calls;
+ fit$output <- segs;
+ # Not needed anymore
+ segs <- calls <- NULL;
+ }
+
+ # Don't call a segment LOH if it already called AB?
+ if (xorCalls) {
+ segs <- as.data.frame(fit);
+ if (is.element("abCall", names(segs))) {
+ calls <- segs$lohCall;
+ otherCalls <- segs$abCall;
+ # If called (TRUE) and already called (TRUE)
+ # by the other caller, call it as NA.
+ calls[calls & otherCalls] <- NA;
+ segs$lohCall <- calls;
+ fit$output <- segs;
+ }
+ }
+
+
+ return(invisible(fit));
+})
+
+
+
+setMethodS3("callLowC1ByC1", "PairedPSCBS", function(fit, delta=estimateDeltaLOH(fit, flavor="minC1|nonAB"), alpha=0.05, ..., callName="lowc1", verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'delta':
+ if (delta != -Inf) {
+ delta <- Arguments$getDouble(delta, range=c(0,Inf));
+ }
+
+ # Argument 'alpha':
+ alpha <- Arguments$getDouble(alpha, range=c(0,1));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Calling segments of allelic balance from one-sided DH bootstrap confidence intervals");
+
+ verbose && cat(verbose, "delta (offset adjusting for bias in C1): ", delta);
+ verbose && cat(verbose, "alpha (CI quantile; significance level): ", alpha);
+
+ # Calculate C1 confidence intervals, if not already done
+ probs <- c(alpha, 1-alpha);
+ fit <- bootstrapTCNandDHByRegion(fit, probs=probs, ..., verbose=less(verbose, 50));
+
+ segs <- as.data.frame(fit);
+
+ # Extract confidence interval
+ alphaTag <- sprintf("%g%%", 100*alpha);
+ column <- sprintf("c1_%s", alphaTag);
+ # Sanity checks
+ stopifnot(is.element(column, colnames(segs)));
+
+ # One-sided test
+ verbose && enter(verbose, "Calling segments");
+ value <- segs[,column, drop=TRUE];
+ call <- (value < delta);
+ nbrOfCalls <- sum(call, na.rm=TRUE);
+ verbose && printf(verbose, "Number of segments called low C1 (LowC1, \"LOH_C1\"): %d (%.2f%%) of %d\n", nbrOfCalls, 100*nbrOfCalls/nrow(segs), nrow(segs));
+ verbose && exit(verbose);
+
+ key <- sprintf("%sCall", callName);
+# calls <- data.frame(lowc1Call=call);
+# colnames(calls) <- key;
+# segs <- cbind(segs, calls);
+ segs[[key]] <- call;
+ fit$output <- segs;
+
+ # Append 'delta' and 'alpha' to parameters
+ params <- fit$params;
+ params$deltaLowC1 <- delta;
+ params$alphaLowC1 <- alpha;
+ fit$params <- params;
+
+ verbose && exit(verbose);
+
+ fit;
+}, private=TRUE) # callLowC1ByC1()
+
+
+
+
+setMethodS3("callExtremeAllelicImbalanceByDH", "PairedPSCBS", function(fit, delta=0.60, alpha=0.05, ..., callName="aiHigh", verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'delta':
+ delta <- Arguments$getDouble(delta, range=c(0,Inf));
+
+ # Argument 'alpha':
+ alpha <- Arguments$getDouble(alpha, range=c(0,1));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Calling segments of extreme allelic imbalance (AI) from one-sided DH bootstrap confidence intervals");
+
+ verbose && cat(verbose, "delta (offset adjusting for normal contamination and other biases): ", delta);
+ verbose && cat(verbose, "alpha (CI quantile; significance level): ", alpha);
+
+
+ # Calculate DH confidence intervalls, if not already done
+ probs <- c(alpha, 1-alpha);
+ fit <- bootstrapTCNandDHByRegion(fit, probs=probs, ..., verbose=less(verbose, 50));
+
+ segs <- as.data.frame(fit);
+
+ # Extract confidence interval
+ alphaTag <- sprintf("%g%%", 100*alpha);
+ column <- sprintf("dh_%s", alphaTag);
+ # Sanity checks
+ stopifnot(is.element(column, colnames(segs)));
+
+ # One-sided test
+ verbose && enter(verbose, "Calling segments");
+ value <- segs[,column, drop=TRUE];
+ call <- (value >= delta);
+ nbrOfCalls <- sum(call, na.rm=TRUE);
+ verbose && printf(verbose, "Number of segments called high allelic imbalance (AI/\"LOH_AI\"): %d (%.2f%%) of %d\n", nbrOfCalls, 100*nbrOfCalls/nrow(segs), nrow(segs));
+ verbose && exit(verbose);
+
+ key <- sprintf("%sCall", callName);
+# calls <- data.frame(aiHighCall=call);
+# colnames(calls) <- key;
+# segs <- cbind(segs, calls);
+ segs[[key]] <- call;
+ fit$output <- segs;
+
+ # Append 'delta' and 'alpha' to parameters
+ params <- fit$params;
+ params$deltaExtremeDH <- delta;
+ params$alphaExtremeDH <- alpha;
+ fit$params <- params;
+
+ verbose && exit(verbose);
+
+ fit;
+}, private=TRUE) # callExtremeAllelicImbalanceByDH()
+
+
+
+##############################################################################
+# HISTORY
+# 2012-05-30
+# o BUG FIX: callLOH(..., force=TRUE) would append multiple 'lohCall'
+# columns, if called multiple times.
+# o BUG FIX: callLowC1ByC1() and callExtremeAllelicImbalanceByDH() would
+# append multiple call columns with the same name if called multiple times.
+# 2012-01-15
+# o DOCUMENTATION: Added details to the help of callLOH() and callAB() on
+# the difference between (AB,LOH)=(TRUE,FALSE) and (AB,LOH)=(TRUE,NA).
+# 2011-06-14
+# o Updated code to recognize new column names.
+# 2011-05-29
+# o Renamed all arguments, variables, function named 'tau' to 'delta'.
+# 2011-04-14
+# o BUG FIX: Argument 'minSize' of callAB() and callLOH() had no effect.
+# 2011-04-12
+# o Added argument 'minSize' to callLOH() for PairedPSCBS.
+# o Added argument 'xorCalls' to callLOH() for PairedPSCBS.
+# 2011-04-11
+# o Added argument 'callName' to callExtremeAllelicImbalanceByDH() and
+# callLowC1ByC1().
+# 2011-04-10
+# o Added callLOH().
+# 2010-12-07
+# o Added callLowC1ByC1() and callABandLowC1().
+# 2010-11-27
+# o Corrected verbose output to call results.
+# 2010-11-26 [HB]
+# o Now all call functions estimate symmetric bootstrap quantiles for
+# convenince of plotting confidence intervals.
+# o BUG FIX: callABandHighAI() for PairedPSCBS used the old DH-only
+# bootstrap method.
+# o BUG FIX: The call functions, for instance callABandHighAI(), would throw
+# 'Error in quantile.default(x, probs = alpha) : missing values and NaN's
+# not allowed if 'na.rm' is FALSE' unless bootstrapTCNandDHByRegion() was
+# run before.
+# 2010-11-22 [HB]
+# o Added more verbose output to callABandHighAI().
+# o Updated callAllelicBalanceByDH() and callExtremeAllelicImbalanceByDH()
+# to utilize bootstrapTCNandDHByRegion().
+# 2010-10-25 [HB]
+# o Relaced argument 'ciRange' with 'alpha' for callAllelicBalanceByDH() and
+# callExtremeAllelicImbalanceByDH().
+# o Renamed callAllelicBalance() to callAllelicBalanceByDH() and
+# callExtremeAllelicImbalanceByDH() to callExtremeAllelicImbalance().
+# o Added arguments 'alphaAB' and 'alphaHighAI' to callABandHighAI().
+# o Added sanity checks to the call methods.
+# o Now arguments '...' to callABandHighAI() are passed down.
+# o Now also arguments '...' to callAllelicBalance() and
+# callExtremeAllelicImbalance() are passed to bootstrapDHByRegion().
+# o Added argument 'ciRange' to callAllelicBalance() and
+# callExtremeAllelicImbalance().
+# 2010-09-16 [HB]
+# o Added callABandHighAI().
+# o Added callAllelicBalance() and callExtremeAllelicImbalance().
+# o Created.
+##############################################################################
diff --git a/R/PairedPSCBS.callROH.R b/R/PairedPSCBS.callROH.R
new file mode 100644
index 0000000..d857b65
--- /dev/null
+++ b/R/PairedPSCBS.callROH.R
@@ -0,0 +1,168 @@
+##########################################################################/**
+# @set class=PairedPSCBS
+# @RdocMethod callROH
+# @alias callROH.NonPairedPSCBS
+#
+# @title "Calls segments that are in ROH"
+#
+# \description{
+# @get "title", i.e. that have no (true) heterozygous genotypes.
+# Run of homozygosity (ROH) is a property of the normal (germline) sample.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{...}{Additional arguments passed to @see "testROH".}
+# \item{updateMeans}{If @TRUE, DH and (C1,C2) mean levels are set
+# to @NA for segments called ROH, otherwise not.}
+# \item{force}{If @FALSE, and ROH calls already exits,
+# then nothing is done, otherwise the calls are done.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns a @see "PairedPSCBS" object with ROH calls.
+# }
+#
+# @author "PN, HB"
+#
+# \seealso{
+# Internally, @see "testROH" is used.
+# To call allelic balance (AB) see @seemethod "callAB".
+# To call loss of heterozygosity (LOH) see @seemethod "callLOH".
+# }
+#*/###########################################################################
+setMethodS3("callROH", "PairedPSCBS", function(fit, ..., updateMeans=TRUE, force=FALSE, verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Calling ROH");
+
+ # Already done?
+ segs <- getSegments(fit);
+ calls <- segs$rohCall;
+ if (!force && !is.null(calls)) {
+ return(invisible(fit));
+ }
+
+ nbrOfSegments <- nrow(segs);
+ calls <- rep(NA, times=nbrOfSegments);
+ if (is.null(calls)) {
+ segs <- cbind(segs, rohCall=calls);
+ }
+ delta <- NA_real_;
+
+ # For each segment...
+ for (ss in seq(length=nbrOfSegments)) {
+ verbose && enter(verbose, sprintf("Segment #%d of %d", ss, nbrOfSegments));
+
+ fitT <- extractSegment(fit, ss);
+
+ # Call only "non-splitter" segments
+ if (nbrOfSegments(fitT) > 0L) {
+ callSS <- callROHOneSegment(fitT, ..., verbose=less(verbose, 1));
+ calls[ss] <- callSS;
+ if (is.na(delta) && !is.na(callSS)) {
+ delta <- attr(callSS, "delta");
+ }
+ }
+
+ verbose && exit(verbose);
+ } # for (ss ...)
+
+ verbose && cat(verbose, "ROH calls:");
+ verbose && str(verbose, calls);
+ verbose && print(verbose, summary(calls));
+
+ segs$rohCall <- calls;
+
+ fit$output <- segs;
+
+ # Append parameters
+ params <- fit$params;
+ params$deltaROH <- delta;
+ fit$params <- params;
+
+ # Set DH and (C1,C2) mean levels to NA?
+ if (updateMeans) {
+ fit <- updateMeans(fit, from="segments", adjustFor="roh",
+ verbose=less(verbose, 20));
+ }
+
+ verbose && exit(verbose);
+
+ invisible(fit);
+}) # callROH()
+
+
+# This method calls ROH for a single-segment PairedPSCBS object
+setMethodS3("callROHOneSegment", "PairedPSCBS", function(fit, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Calling ROH for a single segment");
+
+ # Make sure that there is only a single segment in this object
+ stopifnot(nbrOfSegments(fit, splitters=TRUE) == 1L);
+
+
+ # Extract the locus-level data for the segment tested
+ data <- getLocusData(fit);
+
+
+ # Keep only SNPs:
+ # SNPs are identifies as those loci that have non-missing
+ # 'betaTN' & 'muN', cf. segmentByPairedPSCBS().
+ isSnp <- (!is.na(data$betaTN) & !is.na(data$muN));
+ nbrOfSnps <- sum(isSnp);
+ verbose && cat(verbose, "Number of SNPs: ", nbrOfSnps);
+ data <- data[isSnp,];
+
+ # Extract that SNP signals used for calling ROH
+ betaN <- data$betaN;
+ muN <- data$muN;
+ csN <- data$csN; # Genotyping confidence scores, if available
+
+ # Test for ROH
+ fit <- testROH(muN=muN, csN=csN, betaN=betaN, ..., verbose=less(verbose, 10));
+
+ # Get the ROH call (TRUE, FALSE, or NA)
+ call <- fit;
+
+ verbose && exit(verbose);
+
+ call;
+}, private=TRUE)
+
+
+##############################################################################
+# HISTORY
+# 2014-03-29 [HB]
+# o BUG FIX: In rare cases, callROH() could throw "Error in if (is.na(delta))
+# { : argument is of length zero".
+# 2012-05-30 [HB]
+# o Now callROH() records paramter 'deltaROH' in the results.
+# 2011-11-26 [HB]
+# o Added argument 'updateMeans=TRUE' to callROH() for PairedPSCBS.
+# 2011-11-12 [HB]
+# o BUG FIX: ROH calls should be stored in column 'rohCall' (not 'rohCalls').
+# 2011-11-04 [HB]
+# o Added callROH() for PairedPSCBS.
+# o Created.
+##############################################################################
diff --git a/R/PairedPSCBS.estimateDeltaAB.R b/R/PairedPSCBS.estimateDeltaAB.R
new file mode 100644
index 0000000..dc22fd2
--- /dev/null
+++ b/R/PairedPSCBS.estimateDeltaAB.R
@@ -0,0 +1,672 @@
+###########################################################################/**
+# @set class=PairedPSCBS
+# @RdocMethod estimateDeltaAB
+#
+# @title "Estimate a threshold for calling allelic balance from DH"
+#
+# \description{
+# @get "title" to be used by the @seemethod "callAB" method.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{scale}{An optional @numeric scale factor.}
+# \item{flavor}{A @character string specifying which type of
+# estimator to use.}
+# \item{...}{Additional arguments passed to the estimator.}
+# \item{max}{(Optional) The maxium estimate allowed. If greater than
+# this value, the estimate will be truncated.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns the threshold estimate as a @numeric scalar.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# Internally, one of the following methods are used:
+# @seemethod "estimateDeltaABBySmallDH",
+# @seemethod "estimateStdDevForHeterozygousBAF",
+# @seemethod "estimateMeanForDH", and
+# @seemethod "estimateHighDHQuantileAtAB".
+# }
+#
+#*/###########################################################################
+setMethodS3("estimateDeltaAB", "PairedPSCBS", function(this, scale=NULL, flavor=c("qq(DH)", "q(DH)", "mad(hBAF)", "median(DH)"), ..., max=Inf, verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'flavor':
+ flavor <- match.arg(flavor);
+
+ # Argument 'max':
+ max <- Arguments$getDouble(max, range=c(0,Inf));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Estimating DH threshold for calling allelic imbalances");
+ verbose && cat(verbose, "flavor: ", flavor);
+
+ if (flavor == "mad(hBAF)") {
+ if (is.null(scale)) scale <- 3;
+ verbose && cat(verbose, "scale: ", scale);
+ # sigma = mad(hBAF) = 1.4826*median(|hBAF-m|),
+ # where m = median(hBAF) ~= 1/2
+ sd <- estimateStdDevForHeterozygousBAF(this, ..., verbose=verbose);
+ verbose && printf(verbose, "sd: %.3g\n", sd);
+ delta <- scale * sd;
+ } else if (flavor == "median(DH)") {
+ if (is.null(scale)) scale <- 3;
+ verbose && cat(verbose, "scale: ", scale);
+ # sigma = 1/2*1.4826*median(|hBAF-1/2|),
+ # because DH = 2*|hBAF-1/2|
+ mu <- estimateMeanForDH(this, ..., verbose=verbose);
+ verbose && printf(verbose, "mu: %.3g\n", mu);
+ sd <- 1/2 * 1.4826 * mu;
+ verbose && printf(verbose, "sd: %.3g\n", sd);
+ delta <- scale * sd;
+ } else if (flavor == "q(DH)") {
+ if (is.null(scale)) scale <- 1;
+ verbose && cat(verbose, "scale: ", scale);
+ delta <- estimateHighDHQuantileAtAB(this, scale=scale, ..., verbose=verbose);
+ } else if (flavor == "qq(DH)") {
+ if (is.null(scale)) scale <- 1;
+ verbose && cat(verbose, "scale: ", scale);
+ delta <- estimateDeltaABBySmallDH(this, ..., verbose=verbose);
+ delta <- scale * delta;
+ } else {
+ throw("Unkown flavor: ", flavor);
+ }
+
+## } else if (flavor == "DHskew") {
+## fit <- this;
+## if (is.null(fit$output$dhSkew)) {
+## verbose && enter(verbose, "Estimating DH skewness for each segment");
+## fit <- applyByRegion(fit, FUN=.addTcnDhStatitics, verbose=less(verbose, 5));
+## verbose && exit(verbose);
+## }
+## mu <- fit$output$dhMean;
+## skew <- fit$output$dhSkew;
+##
+## deltaSkew <- -0.55;
+## keep <- which(skew < deltaSkew);
+## verbose && printf(verbose, "Number of segments heavily skewed (< %.3f): %d\n", deltaSkew, length(keep));
+## # Sanity check
+## if (length(keep) == 0) {
+## throw("Cannot estimate DH threshold for AB. No segments with strong skewness exists.");
+## }
+## deltaDH <- median(mu[keep], na.rm=TRUE);
+## verbose && printf(verbose, "deltaDH: %.3g\n", deltaDH);
+## deltaDH <- 1.10*deltaDH;
+## verbose && printf(verbose, "Adjusted +10%% deltaDH: %.3g\n", deltaDH);
+##
+## # sigma = 1/2*1.4826*median(|hBAF-1/2|),
+## # because DH = 2*|hBAF-1/2|
+## mu <- estimateMeanForDH(this, delta=deltaDH, ...);
+## verbose && printf(verbose, "mu: %.3g\n", mu);
+## sd <- 1/2 * 1.4826 * mu;
+## verbose && printf(verbose, "sd: %.3g\n", sd);
+## }
+
+ verbose && printf(verbose, "Estimated delta: %.3g\n", delta);
+
+ # Truncate estimate?
+ if (delta > max) {
+ warning("Estimated delta (%.3g) was greater than the maximum allowed value (%.3g). The latter will be used instead.", delta, max);
+ delta <- max;
+ verbose && printf(verbose, "Max delta: %.3g\n", max);
+ verbose && printf(verbose, "Truncated delta: %.3g\n", delta);
+ }
+
+ verbose && exit(verbose);
+
+ delta;
+}) # estimateDeltaAB()
+
+
+
+setMethodS3("estimateStdDevForHeterozygousBAF", "PairedPSCBS", function(this, deltaDH=0.20, deltaTCN=5, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'deltaDH':
+ deltaDH <- Arguments$getDouble(deltaDH, range=c(0,1));
+
+ # Argument 'deltaTCN':
+ deltaTCN <- Arguments$getDouble(deltaTCN, range=c(0,Inf));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Estimating standard deviation of tumor BAFs for heterozygous SNPs");
+ verbose && cat(verbose, "DH threshold: ", deltaDH);
+ verbose && cat(verbose, "TCN threshold: ", deltaTCN);
+
+ segs <- as.data.frame(this);
+
+ verbose && cat(verbose, "Number of segments: ", nrow(segs));
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Find segments to be used for the estimation
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Find segments that have low DHs
+ idxsDH <- which(segs$dhMean <= deltaDH);
+ verbose && cat(verbose, "Identified segments with small DH levels: ", length(idxsDH));
+ verbose && str(verbose, idxsDH);
+
+ # Sanity check
+ if (length(idxsDH) == 0) {
+ throw("Cannot estimate standard deviation. There exist no segments with DH less or equal to the given threshold: ", deltaDH);
+ }
+
+ # Find segments that have low TCNs
+ idxsTCN <- which(segs$tcnMean <= deltaTCN);
+ verbose && cat(verbose, "Identified segments with small TCN levels: ", length(idxsTCN));
+ verbose && str(verbose, idxsTCN);
+
+ # Sanity check
+ if (length(idxsTCN) == 0) {
+ throw("Cannot estimate standard deviation. There exist no segments with TCN less or equal to the given threshold: ", deltaTCN);
+ }
+
+ # Segments with small DH and small TCN
+ idxs <- intersect(idxsDH, idxsTCN);
+ verbose && cat(verbose, "Identified segments with small DH and small TCN levels: ", length(idxs));
+ verbose && str(verbose, idxs);
+
+ # Sanity check
+ if (length(idxs) == 0) {
+ throw("Cannot estimate standard deviation. There exist no segments with small DH and small TCN.");
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract data and estimate parameters
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract those segments
+ verbose && enter(verbose, "Extracting identified segments");
+ fitT <- extractRegions(this, idxs);
+ verbose && exit(verbose);
+
+ # Get the tumor BAFs for the heterozygous SNPs
+ verbose && enter(verbose, "Extracting BAFs for the heterozygous SNPs");
+ beta <- with(fitT$data, betaTN[muN == 1/2]);
+ verbose && str(verbose, beta);
+ verbose && exit(verbose);
+
+ # Estimate the standard deviation for those
+ sd <- mad(beta, na.rm=TRUE);
+ verbose && cat(verbose, "Estimated standard deviation: ", sd);
+
+
+ verbose && exit(verbose);
+
+ sd;
+}, private=TRUE) # estimateStdDevForHeterozygousBAF()
+
+
+
+
+setMethodS3("estimateMeanForDH", "PairedPSCBS", function(this, deltaDH=0.20, deltaTCN=5, robust=TRUE, trim=0.05, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'deltaDH':
+ deltaDH <- Arguments$getDouble(deltaDH, range=c(0,1));
+
+ # Argument 'deltaTCN':
+ deltaTCN <- Arguments$getDouble(deltaTCN, range=c(0,Inf));
+
+ # Argument 'robust':
+ robust <- Arguments$getLogical(robust);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Estimating mean of tumor DHs for heterozygous SNPs");
+ verbose && cat(verbose, "DH threshold: ", deltaDH);
+ verbose && cat(verbose, "TCN threshold: ", deltaTCN);
+ verbose && cat(verbose, "Robust estimator: ", robust);
+ verbose && cat(verbose, "Trim: ", trim);
+
+ segs <- as.data.frame(this);
+
+ verbose && cat(verbose, "Number of segments: ", nrow(segs));
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Find segments to be used for the estimation
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Find segments that have low DHs
+ idxsDH <- which(segs$dhMean <= deltaDH);
+ verbose && cat(verbose, "Identified segments with small DH levels: ", length(idxsDH));
+ verbose && str(verbose, idxsDH);
+
+ # Sanity check
+ if (length(idxsDH) == 0) {
+ throw("Cannot estimate standard deviation. There exist no segments with DH less or equal to the given threshold: ", deltaDH);
+ }
+
+ # Find segments that have low TCNs
+ idxsTCN <- which(segs$tcnMean <= deltaTCN);
+ verbose && cat(verbose, "Identified segments with small TCN levels: ", length(idxsTCN));
+ verbose && str(verbose, idxsTCN);
+
+ # Sanity check
+ if (length(idxsTCN) == 0) {
+ throw("Cannot estimate standard deviation. There exist no segments with TCN less or equal to the given threshold: ", deltaTCN);
+ }
+
+ # Segments with small DH and small TCN
+ idxs <- intersect(idxsDH, idxsTCN);
+ verbose && cat(verbose, "Identified segments with small DH and small TCN levels: ", length(idxs));
+ verbose && str(verbose, idxs);
+
+ # Sanity check
+ if (length(idxs) == 0) {
+ throw("Cannot estimate standard deviation. There exist no segments with small DH and small TCN.");
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract data and estimate parameters
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract those segments
+ verbose && enter(verbose, "Extracting identified segments");
+ fitT <- extractRegions(this, idxs);
+ verbose && exit(verbose);
+
+ # Get the tumor DHs for the heterozygous SNPs
+ verbose && enter(verbose, "Extracting DHs for the heterozygous SNPs");
+ rho <- with(fitT$data, rho[muN == 1/2]);
+ verbose && str(verbose, rho);
+ verbose && exit(verbose);
+
+ # Estimate the average for those
+ rho <- rho[is.finite(rho)];
+ if (robust) {
+ mu <- median(rho, na.rm=FALSE);
+ qlow <- quantile(rho, probs=0.05, na.rm=FALSE);
+ delta <- mu-qlow;
+ print(list(qlow=qlow, mu=mu, delta=delta, "mu+delta"=mu+delta));
+ } else {
+ mu <- mean(rho, trim=trim, na.rm=FALSE);
+ }
+ verbose && cat(verbose, "Estimated mean: ", mu);
+
+
+ verbose && exit(verbose);
+
+ mu;
+}, private=TRUE) # estimateMeanForDH()
+
+
+
+setMethodS3("estimateHighDHQuantileAtAB", "PairedPSCBS", function(this, quantile=0.99, scale=1, deltaDH=0.20, deltaTCN=5, robust=TRUE, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'quantile':
+ quantile <- Arguments$getDouble(quantile, range=c(0.5,1));
+
+ # Argument 'scale':
+ scale <- Arguments$getDouble(scale, range=c(0,Inf));
+
+ # Argument 'deltaDH':
+ deltaDH <- Arguments$getDouble(deltaDH, range=c(0,1));
+
+ # Argument 'deltaTCN':
+ deltaTCN <- Arguments$getDouble(deltaTCN, range=c(0,Inf));
+
+ # Argument 'robust':
+ robust <- Arguments$getLogical(robust);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Estimating DH quantile of tumor DHs for heterozygous SNPs");
+ verbose && cat(verbose, "DH threshold: ", deltaDH);
+ verbose && cat(verbose, "TCN threshold: ", deltaTCN);
+ verbose && cat(verbose, "Robust estimator: ", robust);
+ verbose && cat(verbose, "Scale factor: ", scale);
+
+ segs <- as.data.frame(this);
+
+ verbose && cat(verbose, "Number of segments: ", nrow(segs));
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Find segments to be used for the estimation
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Finding some segments that are likely to in allelic balance (AB)");
+
+ # Find some segments that have low DHs
+ idxsDH <- which(segs$dhMean <= deltaDH);
+ verbose && cat(verbose, "Identified segments with small DH levels: ", length(idxsDH));
+ verbose && str(verbose, idxsDH);
+
+ # Sanity check
+ if (length(idxsDH) == 0) {
+ throw("Cannot estimate standard deviation. There exist no segments with DH less or equal to the given threshold: ", deltaDH);
+ }
+
+ # Find segments that have low TCNs
+ idxsTCN <- which(segs$tcnMean <= deltaTCN);
+ verbose && cat(verbose, "Identified segments with small TCN levels: ", length(idxsTCN));
+ verbose && str(verbose, idxsTCN);
+
+ # Sanity check
+ if (length(idxsTCN) == 0) {
+ throw("Cannot estimate standard deviation. There exist no segments with TCN less or equal to the given threshold: ", deltaTCN);
+ }
+
+ # Segments with small DH and small TCN
+ idxs <- intersect(idxsDH, idxsTCN);
+ verbose && cat(verbose, "Identified segments with small DH and small TCN levels: ", length(idxs));
+ verbose && str(verbose, idxs);
+
+ # Sanity check
+ if (length(idxs) == 0) {
+ throw("Cannot estimate standard deviation. There exist no segments with small DH and small TCN.");
+ }
+
+ # Extract those segments
+ verbose && enter(verbose, "Extracting identified segments");
+ fitT <- extractRegions(this, idxs);
+ verbose && exit(verbose);
+
+ verbose && exit(verbose);
+
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract data and estimate parameters
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Get the tumor DHs for the heterozygous SNPs
+ verbose && enter(verbose, "Extracting DHs for the heterozygous SNPs");
+ rho <- with(fitT$data, rho[muN == 1/2]);
+ verbose && str(verbose, rho);
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Estimating the DH quantile
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Estimating the quantile of interest");
+ verbose && cat(verbose, "Quantile: ", quantile);
+
+ # Drop missing values
+ rho <- rho[is.finite(rho)];
+
+ if (robust) {
+ lq <- quantile(rho, probs=1-quantile, na.rm=FALSE);
+ verbose && printf(verbose, "Estimated lower quantile (%.3f): %f\n", 1-quantile, lq);
+ mu <- median(rho, na.rm=FALSE);
+ verbose && cat(verbose, "Estimated median: ", mu);
+ delta <- mu-lq;
+ verbose && printf(verbose, "Estimated \"spread\": %f\n", delta);
+ uq <- mu + scale*delta;
+ verbose && printf(verbose, "Scale parameter: %f\n", scale);
+ qs <- c(lq, mu, mu+delta, uq);
+ names(qs) <- sprintf("%.1f%%", 100*c(1-quantile, 0.5, quantile, 0.5+scale*(quantile-0.5)));
+ names(qs)[3:4] <- sprintf("%s*", names(qs)[3:4]);
+ attr(uq, "quantiles") <- qs;
+ } else {
+ uq <- quantile(rho, probs=quantile, na.rm=FALSE);
+ }
+
+ names(uq) <- uq;
+ verbose && printf(verbose, "Estimated upper quantile (%.3f): %f\n", quantile, uq);
+
+ verbose && exit(verbose);
+
+ verbose && exit(verbose);
+
+ uq;
+}, private=TRUE) # estimateHighDHQuantileAtAB()
+
+
+
+
+###########################################################################/**
+# @set class=PairedPSCBS
+# @RdocMethod estimateDeltaABBySmallDH
+#
+# @title "Estimate a threshold for calling allelic balance from DH"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{q1}{A @numeric value specifying the weighted quantile of the
+# segment-level DHs used to identify segments with small DH means.}
+# \item{q2}{A @numeric value specifying the quantile of the locus-level
+# DH signals for those segments with small DH mean levels.}
+# \item{...}{Not used.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns the threshold estimate as a @numeric scalar.
+# }
+#
+# \section{Algorithm}{
+# \itemize{
+# \item Grabs the segment-level DH estimates.
+# \item Calculate segment weights proportional to the number
+# of heterozygous SNPs.
+# \item Calculate \eqn{\Delta} as the 5\% quantile of the weighted DH means.
+# \item Choose the segments with means less than \eqn{\Delta}.
+# \item Calculate threshold \eqn{\Delta_{AB}} as the 90\% "symmetric" quantile
+# of the observed locus-level DHs from the selected segments
+# in Step 4.
+# The q:th "symmetric" quantile is estimated by estimating
+# the ((1-q), 50\%) quantiles, calculating their distance as
+# "50\%-(1-q)" and add to the median (50\%), i.e.
+# "median + (median-(1-q))" = "2*median-1 + q", which should
+# equal q if the distribution is symmetric.
+# }
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# Instead of calling this method explicitly, it is recommended
+# to use the @seemethod "estimateDeltaAB" method.
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("estimateDeltaABBySmallDH", "PairedPSCBS", function(fit, q1=0.05, q2=0.90, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'q1' & 'q2':
+ q1 <- Arguments$getDouble(q1, range=c(0,1));
+ q2 <- Arguments$getDouble(q2, range=c(0,1));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Estimating DH threshold for AB caller");
+ verbose && cat(verbose, "quantile #1: ", q1);
+ verbose && cat(verbose, "Symmetric quantile #2: ", q2);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract the region-level estimates
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ segs <- getSegments(fit);
+ dh <- segs$dhMean;
+ stopifnot(!is.null(dh));
+ n <- segs$dhNbrOfLoci;
+
+ # Drop missing values
+ keep <- (!is.na(dh) & !is.na(n));
+ idxs <- which(keep);
+ dh <- dh[idxs];
+ n <- n[idxs];
+ verbose && cat(verbose, "Number of segments: ", length(idxs));
+ # Sanity check
+ stopifnot(length(idxs) > 0);
+
+ # Calculated weighted quantile
+ weights <- n / sum(n);
+ deltaDH <- weightedQuantile(dh, w=weights, probs=q1);
+ verbose && printf(verbose, "Weighted %g%% quantile of DH: %f\n", 100*q1, deltaDH);
+
+ # Identify segments with DH this small
+ keep <- (dh <= deltaDH);
+ idxs <- idxs[keep];
+ verbose && cat(verbose, "Number of segments with small DH: ", length(idxs));
+ # Sanity check
+ stopifnot(length(idxs) > 0);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract the locus-level estimates
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract the regions of interest
+ fitT <- extractRegions(fit, idxs);
+
+ # Extract the data
+ data <- fitT$data;
+ rho <- data$rho;
+ stopifnot(!is.null(rho));
+
+ verbose && cat(verbose, "Number of data points: ", length(rho));
+
+ # Drop missing values
+ rho <- rho[is.finite(rho)];
+ verbose && cat(verbose, "Number of finite data points: ", length(rho));
+
+ qs <- quantile(rho, probs=c(1-q2, 1/2), na.rm=FALSE, names=FALSE);
+ verbose && printf(verbose, "Estimate of (1-%.3g):th and 50%% quantiles: (%g,%g)\n", q2, qs[1], qs[2]);
+ deltaAB <- qs[2] + (qs[2]-qs[1]);
+ verbose && printf(verbose, "Estimate of %.3g:th \"symmetric\" quantile: %g\n", q2, deltaAB);
+
+
+ # Sanity check
+ deltaAB <- Arguments$getDouble(deltaAB);
+
+ deltaAB;
+}, protected=TRUE) # estimateDeltaABBySmallDH()
+
+
+############################################################################
+# HISTORY:
+# 2011-06-14
+# o Updated code to recognize new column names.
+# 2011-05-29
+# o Renamed all arguments, variables, function named 'tau' to 'delta'.
+# 2011-04-11
+# o Updated estimateTauABBySmallDH() for PairedPSCBS to use a "symmetric"
+# quantile estimator.
+# 2011-04-08
+# o Added estimateTauABBySmallDH() for PairedPSCBS.
+# o Added Rdoc help to estimateTauAB() for PairedPSCBS.
+# o Extracted from PairedPSCBS.EXTS.R.
+# o BUG FIX: postsegmentTCN() for PairedPSCBS could generate an invalid
+# 'tcnSegRows' matrix, where the indices for two consecutive segments
+# would overlap, which is invalid.
+# 2011-04-05
+# o BUG FIX: estimateHighDHQuantileAtAB() for PairedPSCBS would throw
+# an error on an undefined 'trim' if verbose output was used.
+# 2011-02-17
+# o Added arguments 'robust' and 'trim' to estimateMeanForDH().
+# 2011-02-03
+# o Added argument 'tauTCN' to estimateMeanForDH().
+# 2011-01-27
+# o Added flavor="DHskew" to estimateTauAB().
+# o Added flavor="DH" to estimateTauAB() to estimate from DH instead
+# of hBAF. As argued by the equations in the comments, these two
+# approaches gives virtually the same results. The advantage with the
+# DH approach is that it requires one less degree of freedom.
+# o Added estimateMeanForDH().
+# 2011-01-18
+# o BUG FIX: 'tcnSegRows' and 'dhSegRows' where not updated by
+# extractByRegions() for PairedPSCBS.
+# 2011-01-14
+# o Added estimateTauAB() for estimating the DeltaAB parameter.
+# o Added estimateStdDevForHeterozygousBAF() for PairedPSCBS.
+# o BUG FIX: extractByRegions() did not handle the case where multiple loci
+# at the same position are split up in two different segments.
+# 2011-01-12
+# o Added extractByRegions() and extractByRegion() for PairedPSCBS.
+# o Now postsegmentTCN(..., force=TRUE) for PairedPSCBS also updates
+# the TCN estimates even for segments where the DH segmentation did
+# not find any additional change points.
+# 2010-12-02
+# o Now postsegmentTCN() assert that total number of TCN loci before
+# and after is the same.
+# o Now postsegmentTCN() assert that joinSegment is TRUE.
+# 2010-12-01
+# o Now postsegmentTCN() checks if it is already postsegmented.
+# 2010-11-30
+# o TODO: postsegmentTCN() does not make sure of 'dhLociToExclude'. Why?
+# o Now postsegmentTCN() recognizes the new 'tcnLociToExclude'.
+# 2010-11-28
+# o BUG FIX: postsegmentTCN() did not handle loci with the same positions
+# and that are split in two different segments. It also did not exclude
+# loci with missing values.
+# 2010-11-21
+# o Adjusted postsegmentTCN() such that the updated TCN segment boundaries
+# are the maximum of the DH segment and the support by the loci. This
+# means that postsegmentTCN() will work as expected both when signals
+# where segmented with 'joinSegments' being TRUE or FALSE.
+# 2010-10-25
+# o Now subsetByDhSegments() for PairedPSCBS handles the rare case when
+# markers with the same positions are split in two different segments.
+# o Renamed subsetBySegments() for PairedPSCBS to subsetByDhSegments().
+# 2010-09-26
+# o Now subsetBySegments() for PairedPSCBS handles multiple chromosomes.
+# o Now postsegmentTCN() PairedPSCBS handles multiple chromosomes.
+# 2010-09-21
+# o Added postsegmentTCN() for PairedPSCBS.
+# 2010-09-19
+# o BUG FIX: plot() used non-defined nbrOfLoci; now length(x).
+# 2010-09-15
+# o Added subsetBySegments().
+# o Added linesC1C2() and arrowsC1C2().
+# o Now the default 'cex' for pointsC1C2() corresponds to 'dh.num.mark'.
+# o Now extractTotalAndDH() also returns 'dh.num.mark'.
+# 2010-09-08
+# o Added argument 'add=FALSE' to plot().
+# o Added plotC1C2().
+# o Added extractTotalAndDH() and extractMinorMajorCNs().
+# 2010-09-04
+# o Added drawLevels() for PairedPSCBS.
+# o Added as.data.frame() and print() for PairedPSCBS.
+# 2010-09-03
+# o Added plot() for PairedPSCBS.
+# o Created.
+############################################################################
diff --git a/R/PairedPSCBS.estimateDeltaLOH.R b/R/PairedPSCBS.estimateDeltaLOH.R
new file mode 100644
index 0000000..6ee7d75
--- /dev/null
+++ b/R/PairedPSCBS.estimateDeltaLOH.R
@@ -0,0 +1,258 @@
+###########################################################################/**
+# @set class=PairedPSCBS
+# @RdocMethod estimateDeltaLOH
+#
+# @title "Estimate a threshold for calling LOH from DH"
+#
+# \description{
+# @get "title" to be used by the @seemethod "callLOH" method.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{scale}{An optional @numeric scale factor.}
+# \item{flavor}{A @character string specifying which type of
+# estimator to use.}
+# \item{...}{Additional arguments passed to the estimator.}
+# \item{max}{(Optional) The maxium estimate allowed. If greater than
+# this value, the estimate will be truncated.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns the threshold estimate as a @numeric scalar or - at Inf.
+# In case it is not possible to estimate the LOH threshold, then
+# - at Inf is returned.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# Internally, one of the following methods are used:
+# @seemethod "estimateDeltaLOHByMinC1ForNonAB".
+# }
+#
+#*/###########################################################################
+setMethodS3("estimateDeltaLOH", "PairedPSCBS", function(this, flavor=c("minC1|nonAB"), ..., max=Inf, verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'flavor':
+ flavor <- match.arg(flavor);
+
+ # Argument 'max':
+ max <- Arguments$getDouble(max, range=c(0,Inf));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Estimating DH threshold for calling LOH");
+ verbose && cat(verbose, "flavor: ", flavor);
+
+ if (flavor == "minC1|nonAB") {
+ delta <- estimateDeltaLOHByMinC1ForNonAB(this, ..., verbose=verbose);
+ } else {
+ throw("Unkown flavor: ", flavor);
+ }
+
+ verbose && printf(verbose, "delta: %.3g\n", delta);
+
+ # Truncate estimate?
+ if (delta > max) {
+ warning("Estimated delta (%.3g) was greater than the maximum allowed value (%.3g). The latter will be used instead.", delta, max);
+ delta <- max;
+ verbose && printf(verbose, "Max delta: %.3g\n", max);
+ verbose && printf(verbose, "Truncated delta: %.3g\n", delta);
+ }
+
+ verbose && exit(verbose);
+
+ delta;
+}) # estimateDeltaLOH()
+
+
+
+###########################################################################/**
+# @set class=PairedPSCBS
+# @RdocMethod estimateDeltaLOHByMinC1ForNonAB
+#
+# @title "Estimate a threshold for calling LOH from DH"
+#
+# \description{
+# @get "title" based on the location of guessed C1=0 and C1=1 peaks.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{midpoint}{A @numeric scalar in [0,1] specifying the relative
+# position of the midpoint between the estimated locations of
+# C1=0 and C1=1 mean parameters.}
+# \item{maxC}{Maximum total copy number of a segment in order to
+# be included in the initial set of segments.}
+# \item{...}{Not used.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns the estimated LOH treshold as a @numeric scalar or - at Inf.
+# In case it is not possible to estimate the LOH threshold, then
+# - at Inf is returned.
+# }
+#
+# \details{
+# This method requires that calls for allelic balances already have
+# been me made, cf. @seemethod "callAllelicBalance".
+# }
+#
+# \section{Algorithm}{
+# \itemize{
+# \item Grabs the segment-level C1 estimates.
+# \item Calculate segment weights proportional to the number of heterozygous SNPs.
+# \item Estimate the C1=1 location as the weighted median C1 for segments that have been called to be in allelic balance.
+# \item Estimate the C1=0 location as the smallest C1 among segments that are not in allelic balance.
+# \item Let the LOH threshold be the midpoint of the estimates C1=0 and C1=1 locations.
+# }
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# Instead of calling this method explicitly, it is recommended
+# to use the @seemethod "estimateDeltaLOH" method.
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("estimateDeltaLOHByMinC1ForNonAB", "PairedPSCBS", function(this, midpoint=1/2, maxC=3*(ploidy(this)/2), ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'midpoint':
+ midpoint <- Arguments$getDouble(midpoint, range=c(0,1));
+
+ # Argument 'maxC':
+ maxC <- Arguments$getDouble(maxC, range=c(0,Inf));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Estimating DH threshold for calling LOH as the midpoint between guessed C1=0 and C1=1");
+ segs <- getSegments(this, splitters=FALSE);
+ nbrOfSegments <- nrow(segs);
+
+ verbose && printf(verbose, "Argument 'midpoint': %.3g\n", midpoint);
+ verbose && cat(verbose, "Number of segments: ", nbrOfSegments);
+
+ # Getting AB calls
+ isAB <- segs$abCall;
+ if (is.null(isAB)) {
+ throw("Cannot estimate delta_LOH because allelic-balance calls have not been made yet.");
+ }
+
+ nbrOfAB <- sum(isAB, na.rm=TRUE);
+ verbose && printf(verbose, "Number of segments in allelic balance: %d (%.1f%%) of %d\n", nbrOfAB, 100*nbrOfAB/nbrOfSegments, nbrOfSegments);
+
+ # Sanity check
+ if (nbrOfAB == 0) {
+ throw("There are no segments in allelic balance.");
+ }
+
+ nbrOfNonAB <- sum(!isAB, na.rm=TRUE);
+ verbose && printf(verbose, "Number of segments not in allelic balance: %d (%.1f%%) of %d\n", nbrOfNonAB, 100*nbrOfNonAB/nbrOfSegments, nbrOfSegments);
+ segsNonAB <- segs[which(!isAB),,drop=FALSE];
+
+ # Sanity check
+ if (nbrOfNonAB == 0) {
+ msg <- sprintf("All %d segments are in allelic balance. Cannot estimate DeltaLOH, which requires that at least one segment must be in allelic imbalance. Returning -Inf instead.", nbrOfSegments);
+ warning(msg);
+ return(-Inf);
+ }
+
+
+ # Identify segments in AB and with small enough TCNs
+ C <- segs$tcnMean;
+ keep <- which(isAB & C <= maxC);
+ verbose && printf(verbose, "Number of segments in allelic balance and TCN <= %.2f: %d (%.1f%%) of %d\n", maxC, length(keep), 100*length(keep)/nbrOfSegments, nbrOfSegments);
+
+ # Sanity check
+ if (length(keep) == 0) {
+ throw("There are no segments in allelic balance with small enough total CN.");
+ }
+
+ # (a) Estimate mean C1 level of AB segments
+ segsT <- segs[keep,,drop=FALSE];
+ C <- segsT$tcnMean;
+ n <- segsT$dhNbrOfLoci;
+ w <- n/sum(n);
+ C1 <- C/2; # Called AB!
+ verbose && printf(verbose, "C: %s\n", hpaste(sprintf("%.3g", C)));
+ verbose && printf(verbose, "Corrected C1 (=C/2): %s\n", hpaste(sprintf("%.3g", C1)));
+ verbose && printf(verbose, "Number of DHs: %s\n", hpaste(n));
+ verbose && printf(verbose, "Weights: %s\n", hpaste(sprintf("%.3g", w)));
+ muC1atAB <- weightedMedian(C1, w=w, na.rm=TRUE);
+ verbose && printf(verbose, "Weighted median of (corrected) C1 in allelic balance: %.3f\n", muC1atAB);
+
+
+ # (b) Estimate mean C1 level of non-AB segments
+ C1 <- segsNonAB$c1Mean;
+ muC1atNonAB <- min(C1, na.rm=TRUE);
+ idxs <- which(C1 <= muC1atNonAB);
+ n <- segsNonAB$dhNbrOfLoci[idxs];
+ verbose && printf(verbose, "Smallest C1 among segments not in allelic balance: %.3g\n", muC1atNonAB);
+ verbose && printf(verbose, "There are %d segments with in total %d heterozygous SNPs with this level.\n", length(idxs), n);
+
+ # Sanity check
+ stopifnot(muC1atNonAB < muC1atAB);
+
+ delta <- midpoint * (muC1atAB + muC1atNonAB);
+ verbose && printf(verbose, "Midpoint between the two: %.3g\n", delta);
+
+ verbose && exit(verbose);
+
+ delta;
+}, private=TRUE) # estimateDeltaLOHByMinC1AtNonAB()
+
+
+
+############################################################################
+# HISTORY:
+# 2012-08-30
+# o Now estimateKappaByC1Density() relies on matrixStats (and no longer
+# aroma.light) to implement weightedMedian().
+# 2012-01-13
+# o Corrected some of verbose messages of estimateDeltaLOHByMinC1ForNonAB()
+# for PairedPSCBS objects.
+# 2011-07-07
+# o GENERALIZATION: Now estimateDeltaLOHByMinC1ForNonAB() returns -Inf
+# if all segments are called AB.
+# 2011-07-06
+# o ROBUSTNESS: Added a sanity check to estimateDeltaLOHByMinC1AtNonAB()
+# asserting that there exist segments that are not in allelic balance,
+# which are needed for estimating $\mu_0$.
+# 2011-06-14
+# o Updated code to recognize new column names.
+# 2011-05-29
+# o Renamed all arguments, variables, function named 'tau' to 'delta'.
+# 2011-04-27
+# o Added argument 'maxC' to estimateTauLOHByMinC1ForNonAB().
+# 2011-04-14
+# o Added argument 'max' to estimateTauAB() and estimateTauLOH().
+# 2011-04-11
+# o Added argument 'midpoint' to estimateTauLOHByMinC1AtNonAB().
+# o Dropped argument 'tauMax'; it was a misunderstanding.
+# 2011-04-09
+# o Added estimateTauLOHByMinC1AtNonAB().
+# o Added estimateTauLOH().
+# o Created.
+############################################################################
diff --git a/R/PairedPSCBS.estimateKappa.R b/R/PairedPSCBS.estimateKappa.R
new file mode 100644
index 0000000..fab4877
--- /dev/null
+++ b/R/PairedPSCBS.estimateKappa.R
@@ -0,0 +1,268 @@
+###########################################################################/**
+# @set class=PairedPSCBS
+# @RdocMethod estimateKappa
+#
+# @title "Estimate global background in segmented copy numbers"
+#
+# \description{
+# @get "title".
+# The global background, here called \eqn{\kappa},
+# may have multiple origins where normal contamination is one,
+# but not necessarily the only one.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{flavor}{A @character string specifying which type of
+# estimator to use.}
+# \item{...}{Additional arguments passed to the estimator.}
+# }
+#
+# \value{
+# Returns the background estimate as a @numeric scalar.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# Internally, one of the following methods are used:
+# @seemethod "estimateKappaByC1Density".
+# }
+#
+#*/###########################################################################
+setMethodS3("estimateKappa", "PairedPSCBS", function(this, flavor=c("density(C1)"), ...) {
+ # Argument 'flavor':
+ flavor <- match.arg(flavor);
+
+ if (flavor == "density(C1)") {
+ estimateKappaByC1Density(this, ...);
+ } else {
+ throw("Cannot estimate background. Unsupported flavor: ", flavor);
+ }
+})
+
+
+
+###########################################################################/**
+# @set class=PairedPSCBS
+# @RdocMethod estimateKappaByC1Density
+#
+# @title "Estimate global background in segmented copy numbers"
+#
+# \description{
+# @get "title" based on the location of peaks in a weighted
+# density estimator of the minor copy number mean levels.
+#
+# The global background, here called \eqn{\kappa},
+# may have multiple origins where normal contamination is one,
+# but not necessarily the only one.
+#
+# \emph{Assumptions:} This estimator assumes that there are segments
+# with C1=0 and C1=1, i.e. some deletions and, typically, some normal
+# segements.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{typeOfWeights}{A @character string specifying how weights
+# are calculated.}
+# \item{adjust}{A @numeric scale factor specifying the size of
+# the bandwidth parameter used by the density estimator.}
+# \item{from}{A @numeric scalar specifying the lower bound for the
+# support of the estimated density.}
+# \item{minDensity}{A non-negative @numeric threshold specifying
+# the minimum density a peak should have in order to consider
+# it a peak.}
+# \item{...}{Not used.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns the background estimate as a @numeric scalar.
+# }
+#
+# \section{Algorithm}{
+# \itemize{
+# \item Retrieve segment-level minor copy numbers and corresponding weights:
+# \enumerate{
+# \item Grabs the segment-level C1 estimates.
+# \item Calculate segment weights.
+# The default (\code{typeOfWeights="dhNbrOfLoci"}) is to use
+# weights proportional to the number of heterozygous SNPs.
+# An alternative (\code{typeOfWeights="sqrt(dhNbrOfLoci)"}) is
+# to use the square root of those counts.
+# }
+#
+# \item Identify subset of regions with C1=0:
+# \enumerate{
+# \item Estimates the weighted empirical density function
+# (truncated at zero below). Tuning parameter 'adjust'.
+# \item Find the first two peaks
+# (with a density greater than tuning parameter 'minDensity').
+# \item Assumes that the two peaks corresponds to C1=0 and C1=1.
+# \item Defines threshold Delta0.5 as the center location between
+# these two peaks.
+# }
+#
+# \item Estimate the global background signal:
+# \enumerate{
+# \item For all segments with C1 < Delta0.5, calculate the weighted
+# median of their C1:s.
+# \item Let kappa be the above weighted median.
+# This is the estimated background.
+# }
+# }
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# Instead of calling this method explicitly, it is recommended
+# to use the @seemethod "estimateKappa" method.
+# }
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("estimateKappaByC1Density", "PairedPSCBS", function(this, typeOfWeights=c("dhNbrOfLoci", "sqrt(dhNbrOfLoci)"), adjust=1, from=0, minDensity=0.2, ..., verbose=FALSE) {
+ findPeaksAndValleys <- .use("findPeaksAndValleys", package="aroma.light");
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'typeOfWeights':
+ typeOfWeights <- match.arg(typeOfWeights);
+
+ # Argument 'adjust':
+ adjust <- Arguments$getDouble(adjust, range=c(0,Inf));
+
+ # Argument 'minDensity':
+ minDensity <- Arguments$getDouble(minDensity, range=c(0,Inf));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Estimate global background (including normal contamination and more)");
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract the region-level estimates
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ segs <- this$output;
+ c1 <- segs$c1Mean;
+ stopifnot(!is.null(c1));
+ n <- segs$dhNbrOfLoci;
+
+ # Drop missing values
+ keep <- (!is.na(c1) & !is.na(n));
+ c1 <- c1[keep];
+ n <- n[keep];
+
+ verbose && cat(verbose, "Number of segments: ", length(c1));
+
+ # Calculate region weights
+ if (typeOfWeights == "dhNbrOfLoci") {
+ w <- n;
+ } else if (typeOfWeights == "sqrt(dhNbrOfLoci)") {
+ w <- sqrt(n);
+ }
+
+ # Standardize weights to sum to one
+ weights <- w / sum(w);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Identify subset of regions with C1=0 and C1=1
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Estimating threshold Delta0.5 from the empirical density of C1:s");
+ verbose && cat(verbose, "adjust: ", adjust);
+ verbose && cat(verbose, "minDensity: ", minDensity);
+ ploidy <- ploidy(this);
+ verbose && cat(verbose, "ploidy: ", ploidy);
+ if (ploidy != 2) {
+ minDensity <- (2/ploidy)*minDensity;
+ verbose && cat(verbose, "minDensity (adjusted for ploidy): ", minDensity);
+ }
+
+ d <- density(c1, weights=weights, adjust=adjust, from=from, na.rm=FALSE);
+ fit <- findPeaksAndValleys(d);
+
+ type <- NULL; rm(list="type"); # To please R CMD check
+ fit <- subset(fit, type == "peak");
+ if (nrow(fit) < 2L) {
+ throw(sprintf("Less that two modes were found in the empirical density of C1: %d", nrow(fit)));
+ }
+ nModes <- nrow(fit);
+
+ fit <- subset(fit, density >= minDensity);
+ if (nrow(fit) < 2L) {
+ throw(sprintf("Less that two modes were found in the empirical density of C1 after removing %d modes that are too weak (density < %g): %d", nModes - nrow(fit), minDensity, nrow(fit)));
+ }
+ nModes <- nrow(fit);
+ verbose && cat(verbose, "All peaks:");
+ verbose && print(verbose, fit);
+
+ # Keep the first two peaks
+ fit <- fit[1:2,,drop=FALSE];
+ verbose && cat(verbose, "C1=0 and C1=1 peaks:");
+ verbose && print(verbose, fit);
+
+ peaks <- fit$x;
+ Delta0.5 <- mean(peaks);
+ verbose && cat(verbose, "Estimate of Delta0.5: ", Delta0.5);
+
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Estimate kappa
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ keep <- which(c1 < Delta0.5);
+ verbose && cat(verbose, "Number of segments with C1 < Delta0.5: ", length(keep));
+ kappa <- weightedMedian(c1[keep], w=weights[keep]);
+
+ # Adjust for ploidy
+ kappa <- (2/ploidy)*kappa;
+ verbose && cat(verbose, "Estimate of kappa: ", kappa);
+
+ verbose && exit(verbose);
+
+ kappa;
+}, protected=TRUE) # estimateKappaByC1Density()
+
+
+
+
+#############################################################################
+# HISTORY:
+# 2014-03-26
+# o Now estimateKappaByC1Density() give more informative error messages
+# if it failed to identify modes for estimating the parameter.
+# o Added argument 'from' to estimateKappaByC1Density().
+# 2013-09-26
+# o CLEANUP: Now estimateKappaByC1Density() no longer attached
+# 'aroma.light', but only loads its namespace.
+# 2013-05-07
+# o Now estimateKappaByC1Density() adjusts for ploidy, iff set.
+# 2013-03-05
+# o Added argument 'typeOfWeights' to estimateKappaByC1Density() for
+# PairedPSCBS, making it possible to specify what type of weights the
+# density estimate should use.
+# 2012-08-30
+# o ROBUSTNESS: estimateKappaByC1Density() did not make sure that
+# weightedMedian() was actually available. Now it requires matrixStats.
+# 2011-06-14
+# o Updated code to recognize new column names.
+# 2011-04-08
+# o Added Rdoc for estimateKappaByC1Density().
+# 2011-02-03
+# o Added estimateKappa().
+# o Added estimateKappaByC1Density().
+# o Created.
+#############################################################################
diff --git a/R/PairedPSCBS.extractSegmentDataByLocus.R b/R/PairedPSCBS.extractSegmentDataByLocus.R
new file mode 100644
index 0000000..9c45908
--- /dev/null
+++ b/R/PairedPSCBS.extractSegmentDataByLocus.R
@@ -0,0 +1,93 @@
+setMethodS3("extractSegmentDataByLocus", "PairedPSCBS", function(fit, fields=NULL, ..., verbose=FALSE) {
+ # Extract data
+ segs <- getSegments(fit, splitters=TRUE);
+ data <- getLocusData(fit, ...);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'fields':
+ if (!is.null(fields)) {
+ fields <- Arguments$getCharacters(fields);
+ unknown <- fields[!is.element(fields, colnames(segs))];
+ if (length(unknown) > 0L) {
+ throw("Unknown segment fields: ", paste(sQuote(unknown), collapse=", "));
+ }
+ } else {
+ fields <- colnames(segs);
+ }
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Extracting segment data by locus");
+
+ # Extract segment fields
+ chromosome <- data$chromosome;
+ x <- data$x;
+ y <- data[,3L];
+ segs <- segs[,fields];
+ nbrOfLoci <- nrow(data);
+
+ verbose && printf(verbose, "Segment fields: [%d] %s\n", length(fields), paste(sQuote(fields), collapse=", "));
+ verbose && cat(verbose, "Number of loci: ", nbrOfLoci);
+
+ # Allocate segment fields at the locus level
+ dataL <- matrix(NA, nrow=nbrOfLoci, ncol=length(fields));
+ colnames(dataL) <- fields;
+ dataL <- as.data.frame(dataL);
+
+ verbose && cat(verbose, "Allocated results:");
+ verbose && str(verbose, dataL);
+
+ verbose && enter(verbose, "Extracting segment by segment");
+
+ # For each segment...
+ for (ss in seq(length=nrow(segs))) {
+ verbose && enter(verbose, sprintf("Segment %d of %d", ss, nrow(segs)));
+ seg <- segs[ss,];
+ idxs <- which(chromosome == seg$chromosome &
+ seg$tcnStart <= x & x <= seg$tcnEnd);
+ idxs <- Arguments$getIndices(idxs, max=nbrOfLoci);
+ verbose && cat(verbose, "Number of loci in segment: ", length(idxs));
+ # Sanity check
+## stopifnot(length(idxs) == seg$tcnNbrOfLoci);
+
+ segsSS <- seg[fields];
+ verbose && cat(verbose, "Segment data extracted:");
+ verbose && print(verbose, segsSS);
+
+ for (field in fields) {
+ dataL[idxs,field] <- segsSS[[field]];
+ }
+ verbose && exit(verbose);
+ } # for (ss ...)
+ verbose && exit(verbose);
+
+ # The calls for loci that have missing annotations or observations,
+ # should also be missing, i.e. NA.
+ nok <- (is.na(chromosome) | is.na(x) | is.na(y));
+ dataL[nok,] <- NA;
+
+ # Sanity check
+ stopifnot(nrow(dataL) == nbrOfLoci);
+ stopifnot(ncol(dataL) == length(fields));
+
+ verbose && exit(verbose);
+
+ dataL;
+}, protected=TRUE) # extractSegmentDataByLocus()
+
+
+
+##############################################################################
+# HISTORY
+# 2013-10-27
+# o Added extractSegmentDataByLocus() for PairedPSCBS adopted from
+# extractCallsByLocus() of 'PSCBS'.
+##############################################################################
diff --git a/R/PairedPSCBS.unTumorBoost.R b/R/PairedPSCBS.unTumorBoost.R
new file mode 100644
index 0000000..a41a2dc
--- /dev/null
+++ b/R/PairedPSCBS.unTumorBoost.R
@@ -0,0 +1,66 @@
+# @title "Re-calculates the segmented profile using non-TumorBoost BAFs"
+setMethodS3("unTumorBoost", "PairedPSCBS", function(fit, ..., verbose=FALSE) {
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enterf(verbose, "Relcalculating %s profile without TumorBoost", class(fit)[1L]);
+
+ # Nothing to do?
+ if (!fit$params$tbn) {
+ verbose && cat(verbose, "Profile is not from TumorBoost signals. Skipping.");
+ verbose && exit(verbose);
+ return(fit);
+ }
+
+ verbose && enter(verbose, "Updating locus-level data");
+ data <- getLocusData(fit);
+ data$betaTN <- data$betaT;
+ isHet <- !is.na(data$rho);
+ data$rho[isHet] <- 2*abs(data$betaTN[isHet]-1/2);
+ fit$data <- data;
+ verbose && exit(verbose);
+
+ verbose && enter(verbose, "Updating segments");
+ segs <- getSegments(fit);
+ segs$abCall <- NULL;
+ segs$lohCall <- NULL;
+ fit$output <- segs;
+ verbose && exit(verbose);
+
+ verbose && enter(verbose, "Updating parameters");
+ params <- fit$params;
+ params$tbn <- FALSE;
+ params$deltaAB <- params$alphaAB <- NULL;
+ params$deltaLowC1 <- params$alphaLowC1 <- NULL;
+ fit$params <- params;
+ verbose && exit(verbose);
+
+ verbose && enter(verbose, "Resetting miscellaneous parameters and estimates");
+ fit$changepoints <- NULL;
+ fit$deshearC1C2 <- NULL;
+ fit$cScaled <- NULL;
+ fit$kappa <- NULL;
+ fit$scale <- NULL;
+ fit <- clearBootstrapSummaries(fit, verbose=less(verbose, 50));
+ verbose && exit(verbose);
+
+ verbose && enter(verbose, "Update segment levels");
+ fit <- updateMeans(fit, verbose=less(verbose, 50));
+ verbose && exit(verbose);
+
+ verbose && exit(verbose);
+
+ fit;
+}, protected=TRUE) # unTumorBoost()
+
+
+##############################################################################
+# HISTORY
+# 2014-03-28
+# o Added unTumorBoost() for PairedPSCBS.
+##############################################################################
diff --git a/R/PairedPSCBS.updateMeans.R b/R/PairedPSCBS.updateMeans.R
new file mode 100644
index 0000000..5737ff6
--- /dev/null
+++ b/R/PairedPSCBS.updateMeans.R
@@ -0,0 +1,266 @@
+setMethodS3("updateMeans", "PairedPSCBS", function(fit, from=c("loci", "segments"), adjustFor=NULL, ..., avgTCN=c("asis", "mean", "median"), avgDH=c("asis", "mean", "median"), clear=FALSE, verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'from':
+ from <- match.arg(from);
+
+ # Argument 'adjustFor':
+ if (!is.null(adjustFor)) {
+ adjustFor <- Arguments$getCharacters(adjustFor);
+ adjustFor <- tolower(adjustFor);
+ knownValues <- c("ab", "loh", "roh");
+ adjustFor <- match.arg(adjustFor, choices=knownValues, several.ok=TRUE);
+ }
+
+ # Argument 'avgTCN' & 'avgDH':
+ avgTCN <- match.arg(avgTCN);
+ avgDH <- match.arg(avgDH);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Updating mean level estimates");
+ verbose && cat(verbose, "Adjusting for:");
+ verbose && print(verbose, adjustFor);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setting up averaging functions
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (avgTCN == "asis" || avgDH == "asis") {
+ est <- fit$params$meanEstimators;
+ if (avgTCN == "asis") {
+ avgTCN <- est$tcn;
+ if (is.null(avgTCN)) avgTCN <- "mean";
+ avgTCN <- match.arg(avgTCN);
+ }
+ if (avgDH == "asis") {
+ avgDH <- est$dh;
+ if (is.null(avgDH)) avgDH <- "mean";
+ avgDH <- match.arg(avgDH);
+ }
+ }
+
+ avgList <- list(
+ tcn = get(avgTCN, mode="function"),
+ dh = get(avgDH, mode="function")
+ );
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract the segmentation results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ segs <- getSegments(fit, splitters=TRUE);
+ segRows <- list(tcn=fit$tcnSegRows, dh=fit$dhSegRows);
+ nbrOfSegments <- nrow(segs);
+ verbose && cat(verbose, "Number of segments: ", nbrOfSegments);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Assert that adjustments can be made
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (is.element("ab", adjustFor)) {
+ if (!is.element("abCall", names(segs))) {
+ adjustFor <- setdiff(adjustFor, "ab");
+ throw("Cannot adjust for AB, because they haven't been called.");
+ }
+ }
+
+ if (is.element("loh", adjustFor)) {
+ if (!is.element("lohCall", names(segs))) {
+ adjustFor <- setdiff(adjustFor, "loh");
+ throw("Cannot adjust for LOH, because they haven't been called.");
+ }
+ }
+
+ if (is.element("roh", adjustFor)) {
+ if (!is.element("rohCall", names(segs))) {
+ adjustFor <- setdiff(adjustFor, "roh");
+ throw("Cannot adjust for ROH, because they haven't been called.");
+ }
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Update the (TCN,DH) mean levels from locus-level data?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (from == "loci") {
+ data <- getLocusData(fit);
+ chromosome <- data$chromosome;
+ x <- data$x;
+ CT <- data$CT;
+ rho <- data$rho;
+
+ isSplitter <- isSegmentSplitter(fit);
+ for (ss in seq(length=nbrOfSegments)[!isSplitter]) {
+ verbose && enter(verbose, sprintf("Segment %d of %d", ss, nbrOfSegments));
+ seg <- segs[ss,];
+ verbose && print(verbose, seg);
+
+ chr <- seg[["chromosome"]];
+ chrTag <- sprintf("chr%02d", chr);
+
+ for (what in c("tcn", "dh")) {
+ segRow <- segRows[[what]][ss,];
+
+ # (a) A splitter - nothing todo?
+ if (!is.finite(segRow[[1]]) || !is.finite(segRow[[2]])) {
+ next;
+ }
+
+ # (b) Identify units (loci)
+ units <- segRow[[1]]:segRow[[2]];
+
+ # (c) Adjust for missing values
+ if (what == "tcn") {
+ value <- CT;
+ } else if (what == "dh") {
+ value <- rho;
+ }
+ keep <- which(!is.na(value[units]));
+ units <- units[keep];
+
+ # (d) Update mean
+ avgFUN <- avgList[[what]];
+ gamma <- avgFUN(value[units]);
+
+ # Sanity check
+ stopifnot(length(units) == 0 || !is.na(gamma));
+
+ # Update the segment boundaries, estimates and counts
+ key <- paste(what, "Mean", sep="");
+ seg[[key]] <- gamma;
+ }
+
+ verbose && print(verbose, seg);
+
+ segs[ss,] <- seg;
+
+ verbose && exit(verbose);
+ } # for (ss ...)
+ } # if (from ...)
+
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Adjust segment means from various types of calls
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (length(adjustFor) > 0) {
+ verbose && enter(verbose, "Adjusting segment means");
+ verbose && cat(verbose, "Adjusting for:");
+ verbose && print(verbose, adjustFor);
+
+ if (is.element("ab", adjustFor)) {
+ verbose && enter(verbose, "Adjusting for AB");
+ calls <- segs$abCall;
+ segs$dhMean[calls] <- 0;
+ verbose && exit(verbose);
+ }
+
+ if (is.element("loh", adjustFor)) {
+ verbose && enter(verbose, "Adjusting for LOH");
+ calls <- segs$lohCall;
+ segs$dhMean[calls] <- 1;
+ verbose && exit(verbose);
+ }
+
+ if (is.element("roh", adjustFor)) {
+ verbose && enter(verbose, "Adjusting for ROH");
+ calls <- segs$rohCall;
+ segs$dhMean[calls] <- NA_real_;
+ verbose && exit(verbose);
+ }
+
+ verbose && exit(verbose);
+ } # if (length(adjustFor) > 0)
+
+
+ # Update
+ fit$output <- segs;
+ fit <- setMeanEstimators(fit, tcn=avgTCN, dh=avgDH);
+ if (clear) {
+ fit <- clearBootstrapSummaries(fit);
+ }
+
+ # Update (C1,C2) mean levels
+ fit <- updateMeansC1C2(fit, verbose=verbose);
+
+ verbose && exit(verbose);
+
+ fit;
+}, private=TRUE) # updateMeans()
+
+
+setMethodS3("updateMeansC1C2", "PairedPSCBS", function(fit, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Updating (C1,C2) segment mean levels");
+ segs <- getSegments(fit);
+
+ if (nrow(segs) > 0L) {
+ tcn <- segs$tcnMean;
+ dh <- segs$dhMean;
+
+ C1 <- 1/2*(1-dh)*tcn;
+ C2 <- tcn - C1;
+
+ segs$c1Mean <- C1;
+ segs$c2Mean <- C2;
+
+ # Preserve (C1,C2) swaps / change-point flips?
+ swap <- segs$c1c2Swap;
+ if (!is.null(swap)) {
+ swap <- which(swap);
+ if (length(swap) > 0L) {
+ segs[swap, c("c1Mean","c2Mean")] <- segs[swap, c("c2Mean","c1Mean")];
+ }
+ }
+
+ fit$output <- segs;
+ }
+
+ verbose && exit(verbose);
+
+ fit;
+}, protected=TRUE) # updateMeansC1C2()
+
+
+
+##############################################################################
+# HISTORY
+# 2014-03-26
+# o BUG FIX: updateMeansC1C2() for PairedPSCBS did not handle missing
+# values (=splitters) in the 'c1c2Swap' field.
+# 2014-03-25
+# o BUG FIX: updateMeans() for PairedPSCBS and NonPairedPSCBS returned the
+# incorrect DH segment levels for region in AB if adjustFor="ab" and
+# likewise for segments in LOH if adjustFor="loh".
+# 2013-11-23
+# o Now updateMeans(..., clear=TRUE) clears bootstrap summaries, otherwise
+# not.
+# 2013-10-26
+# o Now updateMeans() for PairedPSCBS always clears the bootstrap summaries.
+# o Added updateMeansC1C2().
+# o updateMeans() for PairedPSCBS did not preserve the (C1,C2) swaps.
+# 2012-04-21
+# o CLEANUP: Removed unused objects in updateMeans().
+# 2011-11-12
+# o Added arguments 'from' and 'adjustFor' to updateMeans().
+# 2011-01-16
+# o BUG FIX: updateMeans() save to the incorrect column names.
+# 2011-01-12
+# o Added updateMeans() for PairedPSCBS.
+##############################################################################
diff --git a/R/PairedPSCBS.updateMeansTogether.R b/R/PairedPSCBS.updateMeansTogether.R
new file mode 100644
index 0000000..6c29e20
--- /dev/null
+++ b/R/PairedPSCBS.updateMeansTogether.R
@@ -0,0 +1,124 @@
+setMethodS3("updateMeansTogether", "PairedPSCBS", function(fit, idxList, ..., avgTCN=c("mean", "median"), avgDH=c("mean", "median"), verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ nbrOfSegments <- nbrOfSegments(fit, splitters=TRUE);
+
+ # Argument 'idxList':
+ if (!is.list(idxList)) {
+ idxList <- list(idxList);
+ }
+ idxList <- lapply(idxList, FUN=function(idxs) {
+ idxs <- Arguments$getIndices(idxs, max=nbrOfSegments);
+ sort(unique(idxs));
+ });
+
+ # Argument 'avgTCN' & 'avgDH':
+ avgTCN <- match.arg(avgTCN);
+ avgDH <- match.arg(avgDH);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+ verbose && enter(verbose, "Updating mean level estimates of multiple segments");
+
+ verbose && cat(verbose, "Segments:");
+ verbose && str(verbose, idxList);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setting up averaging functions
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ avgList <- list(
+ tcn = get(avgTCN, mode="function"),
+ dh = get(avgDH, mode="function")
+ );
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Extract the data and segmentation results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fit);
+
+ segs <- getSegments(fit, splitters=TRUE);
+
+ nbrOfSegments <- nrow(segs);
+ verbose && cat(verbose, "Total number of segments: ", nbrOfSegments);
+
+ for (ss in seq(along=idxList)) {
+ idxs <- idxList[[ss]];
+
+ fitT <- extractSegments(fit, idxs);
+ verbose && cat(verbose, "Number of segments: ", nbrOfSegments(fitT));
+
+ dataT <- getLocusData(fitT);
+ segsT <- getSegments(fitT);
+
+ CT <- dataT$CT;
+ rho <- dataT$rho;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Update the TCN segments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Recalculate (TCN,DH,C1,C2) means");
+ naValue <- NA_real_;
+ mus <- c(tcn=naValue, dh=naValue, c1=naValue, c2=naValue);
+ for (key in c("tcn", "dh")) {
+ avgFUN <- avgList[[key]];
+
+ # (c) Adjust for missing values
+ if (key == "tcn") {
+ value <- CT;
+ } else if (key == "dh") {
+ value <- rho;
+ }
+ keep <- which(!is.na(value));
+
+ # (d) Update mean
+ gamma <- avgFUN(value[keep]);
+
+ # Sanity check
+ stopifnot(length(gamma) == 0 || !is.na(gamma));
+
+ mus[key] <- gamma;
+ } # for (what ...)
+
+ mus["c1"] <- 1/2*(1-mus["dh"])*mus["tcn"];
+ mus["c2"] <- mus["tcn"] - mus["c1"];
+ names(mus) <- sprintf("%sMean", names(mus));
+ verbose && print(verbose, mus);
+ verbose && exit(verbose);
+
+ for (key in names(mus)) {
+ segs[idxs,key] <- mus[key];
+ }
+ } # for (ss ...)
+
+ # Return results
+ res <- fit;
+ res$output <- segs;
+ res <- setMeanEstimators(res, tcn=avgTCN, dh=avgDH);
+
+ verbose && exit(verbose);
+
+ res;
+}, private=TRUE) # updateMeansTogether()
+
+
+
+############################################################################
+# HISTORY:
+# 2011-11-28
+# o Dropped kmeansCNs() stub.
+# o Added Rdoc comments.
+# o Now hclustCNs() also handles segments with missing (C1,C2) levels,
+# which for instance can happen after calling ROH.
+# 2011-10-14
+# o Implemented hclustCNs() and pruneByHClust() for AbstractCBS.
+# o Implemented extractCNs() for PairedPSCBS.
+# o Created.
+############################################################################
diff --git a/R/callSegmentationOutliers.R b/R/callSegmentationOutliers.R
new file mode 100644
index 0000000..3e4ccd5
--- /dev/null
+++ b/R/callSegmentationOutliers.R
@@ -0,0 +1,253 @@
+###########################################################################/**
+# @RdocGeneric callSegmentationOutliers
+# @alias callSegmentationOutliers.default
+# @alias callSegmentationOutliers.data.frame
+# @alias dropSegmentationOutliers
+# @alias dropSegmentationOutliers.default
+# @alias dropSegmentationOutliers.data.frame
+#
+# @title "Calls/drops single-locus outliers along the genome"
+#
+# \description{
+# @get "title" that have a signal that differ significantly from the
+# neighboring loci.
+# }
+#
+# \usage{
+# @usage callSegmentationOutliers,default
+# @usage callSegmentationOutliers,data.frame
+# @usage dropSegmentationOutliers,default
+# @usage dropSegmentationOutliers,data.frame
+# }
+#
+# \arguments{
+# \item{y}{A @numeric @vector of J genomic signals to be segmented.}
+# \item{chromosome}{(Optional) An @integer scalar
+# (or a @vector of length J contain a unique value).
+# Only used for annotation purposes.}
+# \item{x}{Optional @numeric @vector of J genomic locations.
+# If @NULL, index locations \code{1:J} are used.}
+# \item{method}{A @character string specifying the method
+# used for calling outliers.}
+# \item{...}{Additional arguments passed to internal outlier
+# detection method.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# \code{callSegmentationOutliers()} returns a @logical @vector of length J.
+# \code{dropSegmentationOutliers()} returns an object of the same type
+# as argument \code{y}, where the signals for which outliers were called
+# have been set to @NA.
+# }
+#
+# \section{Missing and non-finite values}{
+# Signals as well as genomic positions may contain missing
+# values, i.e. @NAs or @NaNs. By definition, these cannot
+# be outliers.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# Internally @see "DNAcopy::smooth.CNA" is utilized to identify
+# the outliers.
+# }
+#
+# @keyword IO
+#*/###########################################################################
+setMethodS3("callSegmentationOutliers", "default", function(y, chromosome=0, x=NULL, method="DNAcopy::smooth.CNA", ..., verbose=FALSE) {
+ # Local copies of DNAcopy functions
+ CNA <- .use("CNA", package="DNAcopy");
+ smooth.CNA <- .use("smooth.CNA", package="DNAcopy");
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'y':
+ disallow <- c("Inf");
+ y <- Arguments$getDoubles(y, disallow=disallow);
+ nbrOfLoci <- length(y);
+
+ length2 <- rep(nbrOfLoci, times=2L);
+
+ # Argument 'chromosome':
+ disallow <- c("NaN", "Inf");
+ chromosome <- Arguments$getIntegers(chromosome, range=c(0,Inf), disallow=disallow);
+ if (length(chromosome) == 1L) {
+ chromosome <- rep(chromosome, times=nbrOfLoci);
+ } else {
+ chromosome <- Arguments$getVector(chromosome, length=length2);
+ }
+
+ # Argument 'x':
+ if (!is.null(x)) {
+ disallow <- c("Inf");
+ x <- Arguments$getDoubles(x, length=length2, disallow=disallow);
+ }
+
+ # Argument 'method':
+ method <- match.arg(method);
+
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+
+
+ verbose && enter(verbose, "Identifying outliers");
+ uChromosomes <- sort(unique(chromosome));
+ nbrOfChromosomes <- length(uChromosomes);
+ verbose && cat(verbose, "Number of chromosomes: ", nbrOfChromosomes);
+ verbose && cat(verbose, "Number of loci: ", nbrOfLoci);
+ verbose && cat(verbose, "Detection method: ", method);
+
+ # Allocate result vector
+ isOutlier <- logical(nbrOfLoci);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Filter missing data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Identifying loci with non-missing data");
+ keep <- (!is.na(x) & !is.na(y));
+ if (!is.null(chromosome)) {
+ keep <- (keep & !is.na(chromosome));
+ }
+ keep <- which(keep);
+ chromosome <- chromosome[keep];
+ x <- x[keep];
+ y <- y[keep];
+ nbrOfLoci <- length(x);
+ verbose && cat(verbose, "Number of loci with non-missing data: ", nbrOfLoci);
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # For each chromosome
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ isOutlierT <- logical(nbrOfLoci);
+ for (kk in seq(along=uChromosomes)) {
+ chr <- uChromosomes[kk];
+ verbose && enter(verbose, sprintf("Chromosome #%d ('Chr%02d') of %d", kk, chr, length(uChromosomes)));
+ keepKK <- which(chromosome == chr);
+ nbrOfLociKK <- length(keepKK);
+ verbose && cat(verbose, "Number of loci on chromosome: ", nbrOfLociKK);
+
+ # Extract data
+ yKK <- y[keepKK];
+ xKK <- x[keepKK];
+ chromosomeKK <- chromosome[keepKK];
+
+ # Order loci along chromosome
+ o <- order(xKK);
+ xKK <- xKK[o];
+ yKK <- yKK[o];
+ chromosomeKK <- chromosomeKK[o];
+ keepKK <- keepKK[o];
+ o <- NULL; # Not needed anymore
+
+ # Supress all warnings, in order to avoid warnings by DNAcopy::CNA()
+ # on "array has repeated maploc positions". Ideally we should filter
+ # just those out. /HB 2013-10-22
+ suppressWarnings({
+ dataKK <- CNA(genomdat=yKK, chrom=chromosomeKK, maploc=xKK, sampleid="y", presorted=TRUE);
+ });
+ chromosomeKK <- xKK <- NULL; # Not needed anymore
+
+ yKKs <- smooth.CNA(dataKK, ...)$y;
+ dataKK <- NULL; # Not needed anymore
+
+ # Sanity check
+ stopifnot(length(yKKs) == nbrOfLociKK);
+ outliersKK <- which(yKKs != yKK);
+ yKKs <- yKK <- NULL; # Not needed anymore
+
+ nbrOfOutliers <- length(outliersKK);
+ verbose && cat(verbose, "Number of outliers: ", nbrOfOutliers);
+
+ outliers <- keepKK[outliersKK];
+ keepKK <- outliersKK <- NULL; # Not needed anymore
+
+ isOutlierT[outliers] <- TRUE;
+ outliers <- NULL; # Not needed anymore
+
+ verbose && exit(verbose);
+ } # for (kk ...)
+ chromosome <- x <- y <- NULL; # Not needed anymore
+
+ isOutlier[keep] <- isOutlierT;
+ isOutlierT <- keep <- NULL; # Not needed anymore
+
+ nbrOfOutliers <- sum(isOutlier, na.rm=TRUE);
+ verbose && cat(verbose, "Total number of outliers: ", nbrOfOutliers);
+
+ verbose && exit(verbose);
+
+ isOutlier;
+}) # callSegmentationOutliers()
+
+
+setMethodS3("callSegmentationOutliers", "data.frame", function(y, ...) {
+ data <- y;
+
+ # Get either CBS or PSCBS total CN signals.
+ y <- data$y;
+ if (is.null(y)) {
+ y <- data$CT;
+ }
+
+ callSegmentationOutliers(y=y, chromosome=data$chromosome, x=data$x, ...);
+}) # callSegmentationOutliers()
+
+
+setMethodS3("dropSegmentationOutliers", "default", function(y, ...) {
+ isOutlier <- callSegmentationOutliers(y, ...);
+ y[isOutlier] <- NA_real_;
+ isOutlier <- NULL; # Not needed anymore
+ y;
+})
+
+
+setMethodS3("dropSegmentationOutliers", "data.frame", function(y, ...) {
+ data <- y;
+
+ isOutlier <- callSegmentationOutliers(data, ...);
+
+ # Update either CBS or PSCBS total CN signals.
+ key <- "CT";
+ if (!is.element(key, colnames(data))) {
+ key <- "y";
+ }
+
+ data[[key]][isOutlier] <- NA_real_;
+
+ isOutlier <- NULL; # Not needed anymore
+
+ data;
+})
+
+
+############################################################################
+# HISTORY:
+# 2014-02-04
+# o Now retrieving local copies on DNAcopy functions up front.
+# 2013-12-04
+# o DOCUMENTATION: Now {call|drop}SegmentationOutliers() are documented
+# as generic functions.
+# o Now {call|drop}SegmentationOutliers() drops allocated memory faster.
+# o Added Rdoc for dropSegmentationOutliers().
+# 2011-11-23
+# o Added callSegmentationOutliers() and dropSegmentationOutliers()
+# for data frames.
+# 2011-05-31
+# o Now explicitly using DNAcopy::nnn() to call DNAcopy functions.
+# 2010-11-27
+# o Added dropSegmentationOutliers() which sets outliers to missing values.
+# o Added callSegmentationOutliers(), which utilizes the detection method
+# of DNAcopy::smooth.CNA() as suggested by ABO.
+# o Created.
+############################################################################
diff --git a/R/drawLevels.DNAcopy.R b/R/drawLevels.DNAcopy.R
new file mode 100644
index 0000000..af4fb24
--- /dev/null
+++ b/R/drawLevels.DNAcopy.R
@@ -0,0 +1,17 @@
+setMethodS3("drawLevels", "DNAcopy", function(fit, field=c("seg.mean", "tcn.mean", "dh.mean"), xScale=1, col="red", lwd=3, ...) {
+ field <- match.arg(field);
+ segments <- fit$output[,c("loc.start", "loc.end", field)];
+ apply(segments, MARGIN=1, FUN=function(seg) {
+ x <- c(seg[["loc.start"]], seg[["loc.end"]]);
+ y <- rep(seg[[field]], times=2);
+ lines(x=xScale*x, y=y, col=col, lwd=lwd, ...);
+ });
+})
+
+
+
+############################################################################
+# HISTORY:
+# 2010-07-09
+# o Created from drawLevels() for CopyNumberRegions in aroma.core.
+############################################################################
diff --git a/R/exampleData.R b/R/exampleData.R
new file mode 100644
index 0000000..78fee99
--- /dev/null
+++ b/R/exampleData.R
@@ -0,0 +1,51 @@
+###########################################################################/**
+# @RdocDefault exampleData
+#
+# @title "Gets an example data set"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{name}{A @character string specifying the name of the data set.}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns @data.frame.
+# }
+#
+# @author "HB"
+#
+# @keyword IO
+# @keyword data
+# @keyword internal
+#*/###########################################################################
+setMethodS3("exampleData", "default", function(name=c("paired.chr01"), ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'name':
+ name <- match.arg(name);
+
+ path <- system.file("data-ex", package="PSCBS", mustWork=TRUE);
+
+ if (name == "paired.chr01") {
+ filename <- "PairedPSCBS,exData,chr01.Rbin";
+ }
+
+ pathname <- Arguments$getReadablePathname(filename, path=path);
+ data <- loadObject(pathname);
+
+ data;
+}, protected=TRUE)
+
+
+############################################################################
+# HISTORY:
+# 2013-04-11
+# o Created.
+############################################################################
diff --git a/R/findLargeGaps.R b/R/findLargeGaps.R
new file mode 100644
index 0000000..1916b11
--- /dev/null
+++ b/R/findLargeGaps.R
@@ -0,0 +1,120 @@
+###########################################################################/**
+# @RdocDefault findLargeGaps
+# @alias findLargeGaps.data.frame
+#
+# @title "Identifies gaps of a genome where there exist no observations"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{chromosome}{(Optional) An @integer @vector of length J of
+# chromosome indices.}
+# \item{x}{A @numeric @vector of J of genomic locations.}
+# \item{minLength}{A positive @numeric scalar specifying the minimum
+# length of a gap.}
+# \item{resolution}{A non-negative @numeric specifying the minimum
+# length unit, which by default equals one nucleotide/base pair.}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns @data.frame zero or more rows and with columns
+# \code{chromosome} (if given), \code{start}, \code{stop},
+# and \code{length}.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# Use @see "gapsToSegments" to turn the set of identified gaps into
+# the complementary set of segments such that they can be passed
+# to @see "segmentByCBS", @see "segmentByPairedPSCBS" and
+# @see "segmentByNonPairedPSCBS" via argument \code{knownSegments}.
+# }
+#
+# @keyword IO
+#*/###########################################################################
+setMethodS3("findLargeGaps", "default", function(chromosome=NULL, x, minLength, resolution=1L, ...) {
+ # Argument 'x':
+ x <- Arguments$getNumerics(x);
+ nbrOfLoci <- length(x);
+
+ # Argument 'chromosome':
+ if (!is.null(chromosome)) {
+ disallow <- c("Inf");
+ chromosome <- Arguments$getIntegers(chromosome, range=c(0,Inf), disallow=disallow, length=c(nbrOfLoci, nbrOfLoci));
+ }
+
+ # Argument 'minLength':
+ minLength <- Arguments$getNumeric(minLength, range=c(0,Inf));
+
+ # Argument 'resolution':
+ resolution <- Arguments$getNumeric(resolution, range=c(0,Inf));
+ if (resolution >= minLength) {
+ throw(sprintf("Cannot identify large gaps. Argument 'resolution' (=%g) is not strictly smaller than 'minLength' (=%g).", resolution, minLength))
+ }
+
+ if (!is.null(chromosome)) {
+ allChromosomes <- sort(unique(chromosome));
+ nbrOfChromosomes <- length(allChromosomes);
+
+ xEmpty <- vector(mode(x), length=0L)
+ gaps <- data.frame(chromosome=integer(0L), start=xEmpty, end=xEmpty);
+ for (cc in seq(along=allChromosomes)) {
+ chr <- allChromosomes[cc];
+ idxs <- which(chromosome == chr);
+ chromosomeCC <- chromosome[idxs];
+ xCC <- x[idxs];
+ gapsCC <- findLargeGaps(chromosome=NULL, x=xCC, minLength=minLength, ...);
+ if (nrow(gapsCC) > 0) {
+ gapsCC <- cbind(chromosome=chr, gapsCC);
+ gaps <- rbind(gaps, gapsCC);
+ }
+ } # for (cc ...)
+ } else {
+ x <- x[is.finite(x)];
+ x <- sort(x);
+ dx <- diff(x);
+
+ isGap <- (dx >= minLength);
+ idxsL <- which(isGap);
+##str(list(x=x, dx=dx, isGap=isGap, idxsL=idxsL))
+ xL <- x[idxsL];
+ xR <- x[idxsL+1L];
+##str(list(x=x, dx=dx, isGap=isGap, idxsL=idxsL, xL=xL, xR=xR))
+ gaps <- data.frame(start=xL+resolution, end=xR-resolution);
+ gaps$length <- gaps$end - gaps$start;
+ }
+
+ ## Sanity checks
+ stopifnot(is.data.frame(gaps))
+ stopifnot(all(gaps$start <= gaps$end))
+ stopifnot(all(gaps$length >= 0))
+
+ gaps;
+}) # findLargeGaps()
+
+
+setMethodS3("findLargeGaps", "data.frame", function(chromosome, ...) {
+ data <- chromosome;
+ findLargeGaps(chromosome=data$chromosome, x=data$x, ...);
+}) # findLargeGaps()
+
+
+
+###############################################################################
+# HISTORY:
+# 2015-04-25
+# o BUG FIX: findLargeGaps() could return NULL. Now it always returns
+# a data.frame.
+# 2012-02-22
+# o BUG FIX: findLargeGaps() did not handle missing values for
+# argument 'chromosome'.
+# 2011-11-22
+# o Added findLargeGaps().
+# o Created.
+###############################################################################
diff --git a/R/findNeutralCopyNumberState.R b/R/findNeutralCopyNumberState.R
new file mode 100644
index 0000000..21f55a6
--- /dev/null
+++ b/R/findNeutralCopyNumberState.R
@@ -0,0 +1,202 @@
+###########################################################################/**
+# @RdocDefault findNeutralCopyNumberState
+#
+# @title "Call segments to be copy neutral based on allelic imbalance calls and total copy number estimates"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{C}{A @numeric @vector of region-level total copy number estimates.}
+# \item{isAI}{A @logical @vector of "allelic imbalance" calls.}
+# \item{weights}{An optional @numeric @vector of non-negative weights.}
+# \item{...}{Further argumants to be passed to the density estimation
+# function.}
+# \item{minDensity}{A @numeric value, below which density peaks are
+# discarded.}
+# \item{flavor}{A @character string specifying how to identify the
+# mode of the AB segments.}
+# \item{verbose}{If @TRUE, extra information is output.}
+# }
+#
+# \value{
+# A @logical @vector of "neutral copy number state" calls.
+# }
+#
+# @author "PN, HB"
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("findNeutralCopyNumberState", "default", function(C, isAI, weights=NULL, ..., minDensity=1e-10, flavor=c("firstPeak", "maxPeak"), verbose=FALSE) {
+ # This will load the 'aroma.light' namespace, if not already done.
+ findPeaksAndValleys <- .use("findPeaksAndValleys", package="aroma.light");
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'C':
+ C <- Arguments$getNumerics(C);
+ nbrOfLoci <- length(C);
+
+ # Argument 'isAI':
+ length2 <- rep(nbrOfLoci, times=2);
+ isAI <- Arguments$getLogicals(isAI, length=length2, disallow=NULL);
+
+ # Argument 'weights':
+ if (!is.null(weights)) {
+ weights <- Arguments$getNumerics(weights, range=c(0, Inf), length=length2);
+ }
+
+ # Argument 'minDensity':
+ minDensity <- Arguments$getDouble(minDensity);
+
+ # Argument 'flavor':
+ flavor <- match.arg(flavor);
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+
+ verbose && enter(verbose, "Identifying segments that are copy neutral states");
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setup
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Identify segments in allelic balance
+ isAB <- !isAI;
+
+ # Identify segments that cannot be called
+ isNA <- (is.na(isAB) | is.na(C));
+
+ # Only segments in allelic balance can be considered to be neutral
+ isNeutral <- isAB;
+
+ # Extracting segments in allelic balance
+ idxs <- which(isAB);
+ n <- length(idxs);
+ verbose && cat(verbose, "Number of segments in allelic balance: ", n);
+
+ # Special cases?
+ if (n == 0) {
+ # No segments are in allelic balance
+ verbose && exit(verbose);
+ return(isNeutral);
+ } else if (n == 1) {
+ # Only one segment is in allelic balance. The best we can do
+ # is to call that segment neutral.
+ verbose && exit(verbose);
+ return(isNeutral);
+ } else if (n < 5) {
+ # What to do when the number of segments is really low? /HB 2010-09-09
+ warning("The calling of regions in a copy-neutral state is uncertain, because there are less than five (5) regions in allelic balance: ", n);
+ }
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Look only segments in allelic balance
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Subset and standardize weights
+ if (!is.null(weights)) {
+ weights <- weights[idxs];
+ weights <- weights / sum(weights);
+ }
+ y <- C[idxs];
+ idxs <- NULL; # Not needed anymore
+
+ if (verbose) {
+ cat(verbose, "Data points:");
+ df <- data.frame(C=y, weights=weights);
+ print(verbose, head(df));
+ str(verbose, df);
+ df <- NULL; # Not needed anymore
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Estimate the empirical density
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fit <- findPeaksAndValleys(y, weights=weights, ...);
+ verbose && cat(verbose, "Fit:");
+
+ verbose && cat(verbose, "Fit filtered by 'minDensity':");
+ ok <- (fit[,"density"] > minDensity);
+ verbose && print(verbose, fit[ok,]);
+
+ # Look for peaks with enough density
+ isPeak <- (fit[,"type"] == "peak") & ok;
+ idxs <- which(isPeak);
+
+ # Sanity check
+ stopifnot(length(idxs) >= 1);
+
+ # Extract the first peak
+ if (flavor == "firstPeak") {
+ idx <- idxs[1];
+ } else if (flavor == "maxPeak") {
+ idx <- idxs[which.max(fit[idxs,"density"])];
+ }
+
+ neutralC <- fit[idx,"x"];
+
+ verbose && cat(verbose, "Neutral copy number:");
+ verbose && cat(verbose, "Mode at: ", neutralC);
+ verbose && cat(verbose, "Mode ampliture: ", fit[idx,"density"]);
+
+ # If there is more than one peak, we should only call segments that
+ # are not part of that other peak.
+ if (idx+1 <= nrow(fit)) {
+ nextValleyC <- fit[idx+1, "x"];
+ } else {
+ nextValleyC <- Inf;
+ }
+ verbose && cat(verbose, "Upper range at: ", nextValleyC);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Call copy-neutral regions
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ isNeutral <- isNeutral & (C < nextValleyC);
+
+ # Segments with missing values cannot be called
+ isNeutral[isNA] <- NA;
+
+ verbose && cat(verbose, "Neutral region calls:");
+ verbose && summary(verbose, isNeutral);
+
+ verbose && exit(verbose);
+
+ isNeutral;
+}) # findNeutralCopyNumberState()
+
+
+##############################################################################
+# HISTORY
+# 2013-09-26 [HB]
+# o CLEANUP: Now findNeutralCopyNumberState() no longer attached
+# 'aroma.light', but only loads its namespace.
+# 2013-03-19 [HB]
+# o Added argument 'flavor' to findNeutralCopyNumberState() specifying how
+# to identify the main mode of the AB segments.
+# 2012-02-24 [HB]
+# o Moved findNeutralCopyNumberState() from aroma.light.
+# 2012-02-23 [HB]
+# o Renamed argument 'densityThreshold' to 'minDensity'.
+# 2011-07-10 [HB]
+# o Made findNeutralCopyNumberState() a default method.
+# o Made the Rd help "internal".
+# 2010-09-09 [HB]
+# o Now segments with missing values are not called.
+# o Added support for the case when there is no peak/no segments in AB.
+# o Added support for the case when there is only one weak.
+# o Added sanity checks.
+# 2010-09-08 [PN]
+# o Created.
+##############################################################################
diff --git a/R/gapsToSegments.R b/R/gapsToSegments.R
new file mode 100644
index 0000000..8742805
--- /dev/null
+++ b/R/gapsToSegments.R
@@ -0,0 +1,149 @@
+###########################################################################/**
+# @set "class=data.frame"
+# @RdocMethod gapsToSegments
+# @alias gapsToSegments
+#
+# @title "Gets the genomic segments that are complementary to the gaps"
+#
+# \description{
+# @get "title", with default chromosome boundaries being \code{-Inf}
+# and \code{+Inf}.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{gaps}{A @data.frame with columns \code{chromosome}, \code{start},
+# and \code{stop}. Any overlapping gaps will throw an error.}
+# \item{resolution}{A non-negative @numeric specifying the minimum
+# length unit, which by default equals one nucleotide/base pair.}
+# \item{minLength}{Minimum length of segments to be kept.}
+# \item{dropGaps}{If @TRUE, the gaps themselves are not part of the output.}
+# \item{...}{Not used.}
+# }
+#
+# \value{
+# Returns @data.frame of least one row with columns \code{chromosome}
+# if that argument is given), \code{start}, \code{stop} and \code{length}.
+# The segments are ordered along the genome.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# @see "findLargeGaps".
+# }
+#
+# @keyword IO
+#*/###########################################################################
+setMethodS3("gapsToSegments", "data.frame", function(gaps, resolution=1L, minLength=0L, dropGaps=FALSE, ...) {
+ # To please R CMD check
+ chromosome <- NULL; rm(list="chromosome");
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'gaps':
+ keys <- colnames(gaps);
+ stopifnot(all(is.element(c("start", "end"), keys)));
+ stopifnot(all(gaps$start <= gaps$end, na.rm=TRUE));
+ hasChr <- is.element("chromosome", keys)
+
+ ## Nothing more to do?
+ if (nrow(gaps) == 0L) {
+ knownSegments <- data.frame(chromosome=integer(1L), start=-Inf, end=+Inf);
+ if (!hasChr) knownSegments$hromosome <- NULL
+ return(knownSegments)
+ }
+
+ # Order gaps by the genome
+ o <- order(gaps$chromosome, gaps$start, gaps$end);
+ gaps <- gaps[o,];
+
+ # For each chromosome...
+ knownSegments <- NULL
+ chromosomes <- sort(unique(gaps$chromosome));
+ for (chr in chromosomes) {
+ gapsCC <- subset(gaps, chromosome == chr);
+ nCC <- nrow(gapsCC);
+
+ starts <- gapsCC$start;
+ ends <- gapsCC$end;
+
+ # Assert that no overlapping gaps where specified
+ if (!all(starts[-1] >= ends[-nCC], na.rm=TRUE)) {
+ print(knownSegments);
+ throw("INTERNAL ERROR: Detected overlapping gaps on chromosome ", chr, " in argument 'gaps'.");
+ }
+
+ # All boundaries in order
+ # (this is possible because gaps are non-overlapping)
+ naValue <- NA_real_;
+ if (dropGaps) {
+ bps <- rep(naValue, times=2*nCC);
+ bps[seq(from=1, to=2*nCC, by=2)] <- starts - resolution;
+ bps[seq(from=2, to=2*nCC, by=2)] <- ends + resolution;
+ bps <- c(-Inf, bps, +Inf);
+ dim(bps) <- c(2L, nCC+1L);
+ } else {
+ bps <- rep(naValue, times=4*nCC);
+ bps[seq(from=1, to=4*nCC, by=4)] <- starts - resolution;
+ bps[seq(from=2, to=4*nCC, by=4)] <- starts;
+ bps[seq(from=3, to=4*nCC, by=4)] <- ends;
+ bps[seq(from=4, to=4*nCC, by=4)] <- ends + resolution;
+ bps <- c(-Inf, bps, +Inf);
+ dim(bps) <- c(2L, 2*nCC+1L);
+ }
+
+ knownSegmentsCC <- data.frame(chromosome=chr, start=bps[1L,], end=bps[2L,]);
+
+ knownSegments <- rbind(knownSegments, knownSegmentsCC);
+ } # for (chr ...)
+
+# o <- with(knownSegments, order(chromosome, start, end));
+# knownSegments <- knownSegments[o,];
+# rownames(knownSegments) <- NULL;
+
+ # Append segment lengths
+ knownSegments$length <- knownSegments$end - knownSegments$start;
+
+ # Drop too short segments
+ keep <- (knownSegments$length >= minLength);
+ knownSegments <- knownSegments[keep,];
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate generated 'knownSegments'
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ stopifnot(is.data.frame(knownSegments))
+ stopifnot(nrow(knownSegments) >= 1L)
+ for (chr in sort(unique(knownSegments$chromosome))) {
+ dd <- subset(knownSegments, chromosome == chr);
+
+ # Known segments must not overlap
+ if (!all(dd$start[-1] >= dd$end[-nrow(dd)], na.rm=TRUE)) {
+ throw("INTERNAL ERROR: Detected overlapping segments on chromosome ", chr, " in generated 'knownSegments'.");
+ }
+ }
+
+ knownSegments;
+}) # gapsToSegments()
+
+
+###############################################################################
+# HISTORY:
+# 2012-09-13
+# o Added argument 'dropGaps' to gapsToSegments().
+# 2012-07-22
+# o Added argument 'minLength' to gapsToSegments().
+# 2011-12-12
+# o BUG FIX: Now gapsToSegments() gave invalid segments for chromosomes
+# with more than one gap.
+# o ROBUSTNESS: Now gapsToSegments() validates argument 'gaps' and
+# asserts that it returns non-overlapping segments.
+# 2011-11-22
+# o Made gapsToSegments() a method for 'data.frame' class.
+# o Renamed gapsToKnownSegments() to gapsToSegments().
+# 2011-10-xx
+# o Created.
+###############################################################################
diff --git a/R/installDNAcopy.R b/R/installDNAcopy.R
new file mode 100644
index 0000000..1ff8df9
--- /dev/null
+++ b/R/installDNAcopy.R
@@ -0,0 +1,66 @@
+############################################################################/**
+# @RdocDefault installDNAcopy
+#
+# @title "Install the DNAcopy package"
+#
+# @synopsis
+#
+# \description{
+# @get "title", if missing.
+# }
+#
+# \arguments{
+# \item{...}{Arguments passed to the install function.}
+# \item{force}{If @FALSE and the \pkg{DNAcopy} package is already
+# installed, then it will not be re-install.
+# If @TRUE, it will be installed.}
+# }
+#
+# \value{
+# Returns nothing.
+# }
+#
+# \details{
+# This function is will download and call the \code{biocLite()}
+# installation function from the Bioconductor Project website.
+# This function will also make sure that \pkg{DNAcopy} is loaded so
+# that it is reported by @see "utils::sessionInfo".
+# }
+#
+# @author "HB"
+#
+# @keyword internal
+#*/############################################################################
+setMethodS3("installDNAcopy", "default", function(..., force=FALSE) {
+ # Argument 'force':
+ force <- Arguments$getLogical(force);
+
+ # Package to be installed
+ pkgName <- "DNAcopy";
+
+ # Is DNAcopy already available?
+ if (!force && isPackageInstalled(pkgName)) {
+ library(pkgName, character.only=TRUE);
+ return(invisible());
+ }
+
+ # If not, install it...
+ # To please R CMD check
+ biocLite <- NULL; rm(list="biocLite");
+ source("http://www.bioconductor.org/biocLite.R");
+ biocLite(pkgName, ...);
+
+ # ...and load it
+ library(pkgName, character.only=TRUE);
+
+ return(invisible());
+}) # installDNAcopy()
+
+
+############################################################################
+# HISTORY:
+# 2013-09-10
+# o Now 'R CMD check' no longer complaints about DNAcopy.
+# 2011-05-31
+# o Created.
+############################################################################
diff --git a/R/prememoize.R b/R/prememoize.R
new file mode 100644
index 0000000..44fa02a
--- /dev/null
+++ b/R/prememoize.R
@@ -0,0 +1,45 @@
+.setupCacheRootPath <- function(...) {
+ # Setup the cache root path, possibly by prompting the user.
+ ns <- getNamespace("R.cache");
+ setupCacheRootPath <- get("setupCacheRootPath", mode="function", envir=ns);
+ setupCacheRootPath();
+} # .setupCacheRootPath()
+
+# CRAN POLICY: Add precalculated memoization files to the R.cache
+# directory, unless running interactively. The reason for doing this
+# is solely to make segmentBy[Non]PairedPSCBS examples to run faster
+# on R CMD check but not having to create these memoized files.
+# /HB 2012-11-05
+# UPDATE: Now it will also gain first-time users. /HB 2013-09-27
+.prememoize <- function(verbose=FALSE) {
+ # Explictly setup cache root here, since it's only done by 'R.cache'
+ # if that package is attached. Here we only load it. /HB 2013-09-27
+ .setupCacheRootPath();
+
+ # This will make sure that the pre-generated calculations available
+ # in the 'PSCBS' package are copied to the R.cache cache directory.
+ # This regardless of whether a 'PSCBS' cache subdirectory exists
+ # or not. /HB 2013-09-27
+ path <- "PSCBS/segmentByCBS/sbdry"
+ pathS <- system.file("misc/_Rcache", path, package="PSCBS");
+ pathD <- getCachePath(path);
+ copyDirectory(pathS, pathD, copy.mode=FALSE, recursive=FALSE, overwrite=TRUE);
+ if (verbose) {
+ message("Added pre-memoized calculations: ", getAbsolutePath(pathD));
+ }
+} # .prememoize()
+
+############################################################################
+# HISTORY:
+# 2013-09-27
+# o Now .prememorize() also copies pre-generated calculations in
+# interactive session. It is also called every time the package
+# is attached, which means it will also gain first-time users.
+# o Added .setupCacheRootPath() until R.cache exports it.
+# o Added argument 'verbose' to .prememoize().
+# 2013-09-26
+# o CLEANUP: Now .prememoize() no longer attaches 'R.cache', but only
+# loads its namespace.
+# 2012-11-05
+# o Created.
+############################################################################
diff --git a/R/randomSeed.R b/R/randomSeed.R
new file mode 100644
index 0000000..bc81093
--- /dev/null
+++ b/R/randomSeed.R
@@ -0,0 +1,122 @@
+###########################################################################/**
+# @RdocFunction randomSeed
+#
+# @title "Sets and resets the .Random.seed in the global environment"
+#
+# \description{
+# @get "title".
+# }
+#
+# \usage{
+# @usage randomSeed
+# }
+#
+# \arguments{
+# \item{action}{A @character string specifying the action.}
+# \item{seed}{Random seed to be set; only for \code{action="set"}.
+# If \code{length(seed) == 1}, then \code{set.seed(seed)} is
+# used, otherwise \code{.Random.seed} is assigned the value.}
+# \item{kind}{(optional) A @character string specifying type of
+# random number generator to use, cf. @see "base::RNGkind".}
+# \item{n}{Number of random seeds to generate by \code{action}.}
+# \item{backup}{If @TRUE, the previous (seed, kind) state is recorded
+# such that it can be reset later.}
+# }
+#
+# \value{
+# Returns a \code{.Random.seed}.
+# If more than one is returned, the they are returned as a @list.
+# }
+#
+# @author "HB"
+#
+# @keyword internal
+#*/###########################################################################
+randomSeed <- local({
+ oldSeed <- NULL
+ oldKind <- NULL
+ lecuyerSeed <- NULL
+
+ genv <- globalenv()
+
+ getSeed <- function() {
+ if (exists(".Random.seed", envir=genv, inherits=FALSE)) {
+ get(".Random.seed", envir=genv, inherits=FALSE)
+ } else {
+ NULL
+ }
+ }
+
+ setSeed <- function(seed, kind=NULL, backup=TRUE) {
+ force(seed) ## FIX: Why is this needed?
+
+ ## Set new RNG kind?
+ newKind <- (!is.null(kind) && !identical(kind, RNGkind()[1L]))
+ if (newKind) {
+ if (backup) {
+ oldSeed <<- getSeed()
+ oldKind <<- RNGkind()[1L]
+ }
+ RNGkind(kind) ## Sets .Random.seed
+ }
+
+ ## Reset or set seed?
+ if (is.null(seed)) {
+ if (exists(".Random.seed", envir=genv, inherits=FALSE)) {
+ rm(list=".Random.seed", envir=genv, inherits=FALSE)
+ lecuyerSeed <<- NULL
+ }
+ } else {
+ if (backup && !newKind) oldSeed <<- getSeed()
+
+ if (length(seed) == 1L) {
+ set.seed(seed)
+ lecuyerSeed <<- getSeed()
+ } else {
+ assign(".Random.seed", seed, envir=genv, inherits=FALSE)
+ lecuyerSeed <<- seed
+ }
+ }
+ }
+
+ advanceSeed <- function() {
+ ## Nothing to do?
+ if (RNGkind()[1L] != "L'Ecuyer-CMRG") return()
+
+ if (is.null(lecuyerSeed)) {
+ stats::runif(1)
+ lecuyerSeed <<- getSeed()
+ }
+
+ lecuyerSeed <<- nextRNGStream(lecuyerSeed)
+ assign(".Random.seed", lecuyerSeed, envir=genv, inherits=FALSE)
+ }
+
+
+ function(action=c("set", "advance", "reset", "get"), seed=NULL, kind=NULL, n=1L, backup=TRUE) {
+ action <- match.arg(action)
+ n <- as.integer(n)
+ stopifnot(n >= 1)
+
+ ## Record existing RNG kind (only once)
+ if (is.null(oldKind)) oldKind <<- RNGkind()[1L]
+
+ if (action == "set") {
+ setSeed(seed=seed, kind=kind, backup=backup)
+ } else if (action == "advance") {
+ seeds <- list()
+ for (kk in seq_len(n)) {
+ advanceSeed()
+ seeds[[kk]] <- getSeed()
+ }
+ if (n == 1) seeds <- seeds[[1]]
+ return(seeds)
+ } else if (action == "reset") {
+ setSeed(seed=oldSeed, kind=oldKind, backup=FALSE)
+ } else if (action == "get") {
+ return(getSeed())
+ }
+
+ invisible(getSeed())
+ }
+}) # randomSeed()
diff --git a/R/segmentByCBS.R b/R/segmentByCBS.R
new file mode 100644
index 0000000..a90594d
--- /dev/null
+++ b/R/segmentByCBS.R
@@ -0,0 +1,1165 @@
+###########################################################################/**
+# @RdocDefault segmentByCBS
+# @alias segmentByCBS.data.frame
+# @alias segmentByCBS.CBS
+# @alias segmentByCBS.CNA
+# @alias segmentByCBS
+#
+# @title "Segment genomic signals using the CBS method"
+#
+# \description{
+# @get "title" of the \pkg{DNAcopy} package.
+# This is a convenient low-level wrapper for the \code{DNAcopy::segment()}
+# method. It is intended to be applied to a sample at the time.
+# For more details on the Circular Binary Segmentation (CBS) method
+# see [1,2].
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{y}{A @numeric @vector of J genomic signals to be segmented.}
+# \item{chromosome}{Optional @numeric @vector of length J, specifying
+# the chromosome of each loci. If a scalar, it is expanded to
+# a vector of length J.}
+# \item{x}{Optional @numeric @vector of J genomic locations.
+# If @NULL, index locations \code{1:J} are used.}
+# \item{index}{An optional @integer @vector of length J specifying
+# the genomewide indices of the loci.}
+# \item{w}{Optional @numeric @vector in [0,1] of J weights.}
+# \item{undo}{A non-negative @numeric. If greater than zero, then
+# arguments \code{undo.splits="sdundo"} and \code{undo.SD=undo}
+# are passed to \code{DNAcopy::segment()}.
+# In the special case when \code{undo} is + at Inf, the segmentation
+# result will not contain any changepoints (in addition to what
+# is specified by argument \code{knownSegments}).}
+# \item{avg}{A @character string specifying how to calculating
+# segment mean levels \emph{after} change points have been
+# identified.}
+# \item{...}{Additional arguments passed to the \code{DNAcopy::segment()}
+# segmentation function.}
+# \item{joinSegments}{If @TRUE, there are no gaps between neighboring
+# segments.
+# If @FALSE, the boundaries of a segment are defined by the support
+# that the loci in the segments provides, i.e. there exist a locus
+# at each end point of each segment. This also means that there
+# is a gap between any neighboring segments, unless the change point
+# is in the middle of multiple loci with the same position.
+# The latter is what \code{DNAcopy::segment()} returns.
+# }
+# \item{knownSegments}{Optional @data.frame specifying
+# \emph{non-overlapping} known segments. These segments must
+# not share loci. See @see "findLargeGaps" and @see "gapsToSegments".}
+# \item{seed}{An (optional) @integer specifying the random seed to be
+# set before calling the segmentation method. The random seed is
+# set to its original state when exiting. If @NULL, it is not set.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns a @see "CBS" object.
+# }
+#
+# \details{
+# Internally @see "DNAcopy::segment" of \pkg{DNAcopy} is used to
+# segment the signals.
+# This segmentation method support weighted segmentation.
+# }
+#
+# \section{Reproducibility}{
+# The \code{DNAcopy::segment()} implementation of CBS uses approximation
+# through random sampling for some estimates. Because of this,
+# repeated calls using the same signals may result in slightly
+# different results, unless the random seed is set/fixed.
+# }
+#
+# \section{Missing and non-finite values}{
+# Signals may contain missing values (@NA or @NaN), but not
+# infinite values (+/- at Inf). Loci with missing-value signals
+# are preserved and keep in the result.
+#
+# Likewise, genomic positions may contain missing values.
+# However, if they do, such loci are silently excluded before
+# performing the segmentation, and are not kept in the results.
+# The mapping between the input locus-level data and ditto of
+# the result can be inferred from the \code{index} column of
+# the locus-level data of the result.
+#
+# None of the input data may have infinite values,
+# i.e. - at Inf or + at Inf. If so, an informative error is thrown.
+# }
+#
+# \examples{
+# @include "../incl/segmentByCBS.Rex"
+# @include "../incl/segmentByCBS,plot.Rex"
+# @include "../incl/segmentByCBS,tests.Rex"
+# }
+#
+# @author "HB"
+#
+# \references{
+# [1] @include "../incl/OlshenVenkatraman_2004.Rd" \cr
+# [2] @include "../incl/VenkatramanOlshen_2007.Rd" \cr
+# }
+#
+# \seealso{
+# To segment allele-specific tumor copy-number signals from a tumor
+# \emph{with} a matched normal, see @see "segmentByPairedPSCBS".
+# For the same \emph{without} a matched normal,
+# see @see "segmentByNonPairedPSCBS".
+#
+# It is also possible to prune change points after segmentation (with
+# identical results) using
+# \code{\link[PSCBS:pruneBySdUndo.CBS]{pruneBySdUndo}()}.
+# }
+# @keyword IO
+#*/###########################################################################
+setMethodS3("segmentByCBS", "default", function(y, chromosome=0L, x=NULL, index=seq(along=y), w=NULL, undo=0, avg=c("mean", "median"), ..., joinSegments=TRUE, knownSegments=NULL, seed=NULL, verbose=FALSE) {
+ # Local copies of DNAcopy functions
+ getbdry <- .use("getbdry", package="DNAcopy");
+ CNA <- .use("CNA", package="DNAcopy");
+ segment <- .use("segment", package="DNAcopy");
+
+ R_SANITY_CHECK <- TRUE;
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Local functions
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # DNAcopy::getbdry() is slow for now default settings. Below we
+ # implement a memoized version of this function.
+ getbdry2 <- function(eta, nperm, alpha, tol=0.01, verbose=FALSE) {
+ # Explictly setup cache root here, since it's only done by 'R.cache'
+ # if that package is attached. Here we only load it. /HB 2013-09-27
+ .setupCacheRootPath();
+
+ key <- list(method="segmentByCBS",
+ eta=eta, nperm=as.integer(nperm), alpha=alpha, tol=tol,
+ version="0.16.1");
+ dirs <- c("PSCBS", "segmentByCBS", "sbdry");
+ bdry <- loadCache(key=key, dirs=dirs);
+ if (!is.null(bdry)) return(bdry);
+
+ max.ones <- floor(nperm * alpha) + 1L;
+ bdry <- getbdry(eta=eta, nperm=nperm, max.ones=max.ones, tol=tol);
+
+ saveCache(bdry, key=key, dirs=dirs);
+
+ bdry;
+ } # getbdry2()
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'y':
+ disallow <- c("Inf");
+ y <- Arguments$getDoubles(y, disallow=disallow);
+ nbrOfLoci <- length(y);
+
+ length2 <- rep(nbrOfLoci, times=2);
+
+ # Argument 'chromosome':
+ if (is.null(chromosome)) {
+ chromosome <- 0L;
+ } else {
+ disallow <- c("Inf");
+ chromosome <- Arguments$getIntegers(chromosome, range=c(0,Inf), disallow=disallow);
+ if (length(chromosome) > 1) {
+ chromosome <- Arguments$getIntegers(chromosome, length=length2, disallow=disallow);
+ ## # If 'chromosome' is a vector of length J, then it must contain
+ ## # a unique chromosome.
+ ## chromosomes <- sort(unique(chromosome));
+ ## if (length(chromosomes) > 1) {
+ ## throw("Argument 'chromosome' specifies more than one unique chromosome: ", paste(seqToHumanReadable(chromosomes), collapse=", "));
+ ## }
+ ## chromosome <- chromosomes;
+ }
+ }
+
+ # For future usage
+ chrom <- rep(chromosome, length.out=nbrOfLoci);
+
+ # Argument 'x':
+ if (is.null(x)) {
+ x <- seq(length=nbrOfLoci);
+ } else {
+ disallow <- c("Inf");
+ x <- Arguments$getDoubles(x, length=length2, disallow=disallow);
+ }
+
+ # Argument 'index':
+ if (is.null(index)) {
+ index <- seq(along=y);
+ } else {
+ index <- Arguments$getIndices(index);
+ }
+
+ # Argument 'w':
+ hasWeights <- !is.null(w);
+ if (hasWeights) {
+ disallow <- c("NA", "NaN", "Inf");
+ w <- Arguments$getDoubles(w, range=c(0,1), length=length2, disallow=disallow);
+ }
+
+ # Argument 'undo':
+ undo <- Arguments$getDouble(undo, range=c(0,Inf));
+
+ # Argument 'avg':
+ avg <- match.arg(avg)
+
+ # Argument 'cpFlavor':
+ joinSegments <- Arguments$getLogical(joinSegments);
+
+ # Argument 'knownSegments':
+ if (is.null(knownSegments)) {
+ knownSegments <- data.frame(chromosome=integer(0), start=integer(0), end=integer(0));
+ } else {
+# if (!joinSegments) {
+# throw("Argument 'knownSegments' should only be specified if argument 'joinSegments' is TRUE.");
+# }
+ }
+
+ if (!is.data.frame(knownSegments)) {
+ throw("Argument 'knownSegments' is not a data.frame: ", class(knownSegments)[1]);
+ }
+
+ if (!all(is.element(c("chromosome", "start", "end"), colnames(knownSegments)))) {
+ throw("Argument 'knownSegments' does not have the required column names: ", hpaste(colnames(knownSegments)));
+ }
+
+ # Detailed validation of 'knownSegments'.
+ for (chr in sort(unique(knownSegments$chromosome))) {
+ dd <- subset(knownSegments, chromosome == chr);
+
+ # Order segments by 'start'.
+ o <- order(dd$start);
+ dd <- dd[o,];
+
+ # Known segments must not share 'start' or 'end' loci
+ for (field in c("start", "end")) {
+ xs <- dd[[field]];
+ xs <- xs[!is.na(xs)];
+ if (anyDuplicated(xs) > 0) {
+ print(knownSegments);
+ throw(sprintf("Detected segments on chromosome %s with non-unique '%s' positions in argument 'knownSegments'", chr, field));
+ }
+ } # for (field ...)
+
+ # Known segments must not overlap
+ if (!all(dd$start[-1] >= dd$end[-nrow(dd)], na.rm=TRUE)) {
+ print(knownSegments);
+ throw("Detected overlapping segments on chromosome ", chr, " in argument 'knownSegments'.");
+ }
+ }
+
+ # Argument 'seed':
+ if (!is.null(seed)) {
+ seed <- Arguments$getIntegers(seed);
+ }
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Segmenting by CBS");
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setup data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Setup up data", level=-10);
+ data <- data.frame(chrom=chrom, x=x, y=y, index=index);
+ if (hasWeights) {
+ verbose && cat(verbose, "Adding locus-specific weights", level=-10);
+ data$w <- w;
+ }
+ verbose && str(verbose, data, level=-10);
+ # Not needed anymore
+ chrom <- x <- index <- y <- w <- NULL;
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Drop data points without known genomic positions, because that
+ # is what DNAcopy::CNA() will do otherwise.
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ok <- (!is.na(data$chrom) & !is.na(data$x));
+ if (any(!ok)) {
+ verbose && enter(verbose, "Dropping loci with unknown locations", level=-10);
+ verbose && cat(verbose, "Number of loci dropped: ", sum(!ok), level=-10);
+ data <- data[ok,,drop=FALSE];
+ verbose && exit(verbose);
+ }
+ ok <- NULL; # Not needed anymore
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Reorder data points along the genome, because that is what
+ # DNAcopy::segment() will return. At the end, we will undo
+ # the sort such that the returned 'data' object is always in
+ # the same order and number of loci as the input data.
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Ordering data along genome", level=-50);
+ o <- order(data$chrom, data$x, decreasing=FALSE, na.last=TRUE);
+ # Any change?
+ if (any(o != seq(along=o))) {
+ data <- data[o,,drop=FALSE];
+ }
+ o <- NULL; # Not needed anymore
+ verbose && str(verbose, data, level=-50);
+ verbose && exit(verbose);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Multiple chromosomes?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Identify all chromosomes, excluding missing values
+ chromosomes <- sort(unique(data$chrom), na.last=NA);
+ nbrOfChromosomes <- length(chromosomes);
+ if (nbrOfChromosomes > 1) {
+ verbose && enter(verbose, "Segmenting multiple chromosomes");
+ verbose && cat(verbose, "Number of chromosomes: ", nbrOfChromosomes);
+
+ # Generate random seeds?
+ seeds <- NULL
+ if (!is.null(seed)) {
+ randomSeed("set", seed=seed, kind="L'Ecuyer-CMRG")
+ verbose && printf(verbose, "Random seed temporarily set (seed=c(%s), kind=\"L'Ecuyer-CMRG\")\n", paste(seed, collapse=", "))
+ seeds <- randomSeed("advance", n=nbrOfChromosomes)
+ verbose && printf(verbose, "Produced %d seeds from this stream for future usage\n", length(seeds))
+ randomSeed("reset")
+ }
+
+ fitList <- listenv()
+ for (kk in seq(length=nbrOfChromosomes)) {
+ chromosomeKK <- chromosomes[kk];
+ chrTag <- sprintf("Chr%02d", chromosomeKK);
+ verbose && enter(verbose, sprintf("Chromosome #%d ('%s') of %d", kk, chrTag, nbrOfChromosomes));
+
+ seedKK <- seeds[[kk]]
+
+ # Extract subset of data and parameters for this chromosome
+ dataKK <- subset(data, chrom == chromosomeKK);
+ verbose && str(verbose, dataKK, level=-10);
+ chrom <- x <- index <- y <- w <- NULL
+ fields <- attachLocally(dataKK, fields=c("chrom", "x", "index", "y", "w"));
+ dataKK <- NULL; # Not needed anymore
+
+ knownSegmentsKK <- NULL;
+ if (!is.null(knownSegments)) {
+ knownSegmentsKK <- subset(knownSegments, chromosome == chromosomeKK);
+ if (nrow(knownSegmentsKK) == 0L) {
+ knownSegmentsKK <- data.frame(chromosome=chromosomeKK, start=-Inf, end=+Inf);
+ }
+ verbose && cat(verbose, "Known segments:", level=-5);
+ verbose && print(verbose, knownSegmentsKK, level=-5);
+ }
+
+ fitList[[chrTag]] %<=% {
+ fit <- segmentByCBS(y=y,
+ chromosome=chrom, x=x,
+ w=w,
+ index=index,
+ undo=undo,
+ avg=avg,
+ joinSegments=joinSegments,
+ knownSegments=knownSegmentsKK,
+ ...,
+ seed=seedKK,
+ verbose=verbose);
+
+ # Sanity checks
+ if (R_SANITY_CHECK) {
+ if (nrow(knownSegmentsKK) == 0) {
+ # Since all missing data have been dropped...
+ stopifnot(nrow(fit$data) == length(y));
+ # ...and ordered along the genome already.
+ stopifnot(all.equal(fit$data$y, y));
+ }
+
+ # Assert weights were used
+ stopifnot(!hasWeights || !is.null(fit$data$w))
+ } # if (R_SANITY_CHECK)
+
+ verbose && print(verbose, head(as.data.frame(fit)), level=-10);
+ verbose && print(verbose, tail(as.data.frame(fit)), level=-10);
+
+ fit
+ } ## fitList[[chrTag]] <- ...
+
+ rm(list=fields) # Not needed anymore
+ verbose && exit(verbose);
+ } # for (kk ...)
+
+ verbose && enter(verbose, "Merging (independently) segmented chromosome", level=-50);
+ fitList <- as.list(fitList)
+ fit <- Reduce(append, fitList);
+ # Not needed anymore
+ fitList <- NULL;
+
+ # Update parameters that otherwise may be incorrect
+ fit$params$seed <- seed;
+
+ verbose && str(verbose, fit, level=-10);
+ verbose && exit(verbose);
+
+ segs <- as.data.frame(fit);
+ if (nrow(segs) < 6) {
+ verbose && print(verbose, segs, level=-10);
+ } else {
+ verbose && print(verbose, head(segs), level=-10);
+ verbose && print(verbose, tail(segs), level=-10);
+ }
+
+ verbose && exit(verbose);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Return results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ return(fit);
+ } # if (nbrOfChromosomes > 1)
+
+ verbose && cat(verbose, "Chromosome: ", data$chrom[1L]);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Subset 'knownSegments'
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Keeping only current chromosome for 'knownSegments'", level=-10);
+
+ # Assume no missing values
+ currChromosome <- data$chrom[1];
+ verbose && cat(verbose, "Chromosome: ", currChromosome, level=-10);
+
+ knownSegments <- subset(knownSegments, chromosome == currChromosome);
+ if (nrow(knownSegments) == 0L) {
+ knownSegments <- data.frame(chromosome=currChromosome, start=-Inf, end=+Inf);
+ }
+ nbrOfSegments <- nrow(knownSegments);
+
+ verbose && cat(verbose, "Known segments for this chromosome:", level=-10);
+ verbose && print(verbose, knownSegments, level=-10);
+
+ verbose && exit(verbose);
+
+
+ # Sanity checks
+ if (R_SANITY_CHECK) {
+ # Here 'knownSegments' should specify at most a single chromosome
+ uChromosomes <- sort(unique(knownSegments$chromosome));
+ if (length(uChromosomes) > 1) {
+ throw("INTERNAL ERROR: Argument 'knownSegments' specifies more than one chromosome: ", hpaste(uChromosomes));
+ }
+ } # if (R_SANITY_CHECK)
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Multiple segments?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Sanity check of limitation /HB 2011-10-19
+ if (nbrOfSegments > 1) {
+ verbose && enter(verbose, "Segmenting multiple segments on current chromosome", level=-5);
+ verbose && cat(verbose, "Number of segments: ", nbrOfSegments, level=-5);
+
+ # Create a splitter-only CBS object
+ dataS <- data.frame(y=c(0,0), chromosome=c(1,2), x=c(0,0))
+ if (hasWeights) dataS$w <- 1
+ splitter <- segmentByCBS(dataS)
+ dataS <- NULL
+ suppressWarnings({
+ splitter <- extractSegment(splitter, 2);
+ # Sanity check
+ if (R_SANITY_CHECK) {
+ stopifnot(nbrOfSegments(splitter, splitters=TRUE) == 1);
+ } # if (R_SANITY_CHECK)
+ });
+
+
+ # Generate random seeds?
+ seeds <- NULL
+ if (!is.null(seed)) {
+ randomSeed("set", seed=seed, kind="L'Ecuyer-CMRG")
+ verbose && printf(verbose, "Random seed temporarily set (seed=c(%s), kind=\"L'Ecuyer-CMRG\")\n", paste(seed, collapse=", "))
+ seeds <- randomSeed("advance", n=nbrOfSegments)
+ verbose && printf(verbose, "Produced %d seeds from this stream for future usage\n", length(seeds))
+ randomSeed("reset")
+ }
+
+ fitList <- listenv()
+ for (jj in seq(length=nbrOfSegments)) {
+ seg <- knownSegments[jj,];
+ chromosomeJJ <- seg$chromosome;
+ xStart <- seg$start;
+ xEnd <- seg$end;
+ segTag <- sprintf("chr%s:(%s,%s)", chromosomeJJ, xStart, xEnd);
+ verbose && enter(verbose, sprintf("Segment #%d ('%s') of %d", jj, segTag, nbrOfSegments), level=-10);
+
+ ## Nothing to do?
+ isSplitter <- (is.na(xStart) && is.na(xEnd));
+ if (isSplitter) {
+ fit <- splitter
+ verbose && cat(verbose, "Nothing to segment. Inserting an explicit splitter.", level=-10)
+ fitList[[segTag]] <- fit
+ fit <- NULL
+ verbose && exit(verbose)
+ next
+ }
+
+ # Extract subset of data and parameters for this segment
+ dataJJ <- subset(data, chrom == chromosomeJJ & xStart <= x & x <= xEnd)
+ verbose && str(verbose, dataJJ, level=-50)
+ chrom <- x <- index <- y <- w <- NULL
+ fields <- attachLocally(dataJJ, fields=c("chrom", "x", "index", "y", "w"))
+ dataJJ <- NULL # Not needed anymore
+ nbrOfLoci <- length(y)
+
+ # Empty segment?
+ # [AD HOC. Should be done by segmentCBS(). /HB 2011-10-21]
+ if(nbrOfLoci == 0) {
+ fit <- splitter
+ fit$output$chromosome <- chromosomeJJ
+ fit$output$start <- xStart
+ fit$output$end <- xEnd
+ fit$output$nbrOfLoci <- nbrOfLoci
+ fitList[[segTag]] <- fit
+ fit <- NULL
+ verbose && exit(verbose)
+ next
+ }
+
+ seedJJ <- seeds[[jj]]
+
+ fitList[[segTag]] %<=% {
+ fit <- segmentByCBS(y=y,
+ chromosome=chrom, x=x,
+ w=w,
+ index=index,
+ undo=undo,
+ avg=avg,
+ joinSegments=joinSegments,
+ knownSegments=seg,
+ ...,
+ seed=seedJJ,
+ verbose=less(verbose,1))
+
+ # Sanity checks
+ if (R_SANITY_CHECK) {
+ stopifnot(nrow(fit$data) == nbrOfLoci)
+ stopifnot(all.equal(fit$data$y, y))
+
+ # Assert weights were used
+ stopifnot(!hasWeights || !is.null(fit$data$w))
+ } # if (R_SANITY_CHECK)
+
+ segs <- as.data.frame(fit)
+ if (nrow(segs) < 6) {
+ verbose && print(verbose, segs, level=-10)
+ } else {
+ verbose && print(verbose, head(segs), level=-10)
+ verbose && print(verbose, tail(segs), level=-10)
+ }
+
+ # Sanity check
+ if (R_SANITY_CHECK) {
+ stopifnot(TRUE && nbrOfSegments(fit, splitters=TRUE) > 0)
+ } # if (R_SANITY_CHECK)
+
+ fit
+ }
+
+ rm(list=fields) # Not needed anymore
+
+ verbose && exit(verbose);
+ } # for (jj ...)
+
+
+ verbose && enter(verbose, "Merging (independently) segmented known segments", level=-10);
+ verbose && cat(verbose, "Number of segments: ", length(fitList), level=-10);
+ fitList <- as.list(fitList)
+ verbose && str(verbose, fitList, level=-50)
+ appendT <- function(...) append(..., addSplit=FALSE);
+ fit <- Reduce(appendT, fitList);
+ # Not needed anymore
+ fitList <- NULL;
+
+ # Update parameters that otherwise may be incorrect
+ fit$params$seed <- seed;
+
+ verbose && str(verbose, fit, level=-10);
+ verbose && exit(verbose);
+
+ segs <- getSegments(fit);
+ if (nrow(segs) > 6) {
+ verbose && print(verbose, head(segs), level=-10);
+ verbose && print(verbose, tail(segs), level=-10);
+ } else {
+ verbose && print(verbose, segs, level=-10);
+ }
+
+ # Sanity checks
+ if (R_SANITY_CHECK) {
+ segs <- getSegments(fit);
+ stopifnot(all(segs$start[-1] >= segs$end[-nrow(segs)], na.rm=TRUE));
+ stopifnot(all(diff(segs$start) >= 0, na.rm=TRUE)); ## FIXME: > 0
+ stopifnot(all(diff(segs$end) >= 0, na.rm=TRUE)); ## FIXME: > 0
+
+ # if (nrow(fit$data) != length(y)) {
+ # print(c(nrow(fit$data), nrow(data)));
+ # }
+ # stopifnot(nrow(fit$data) == nrow(data));
+ # stopifnot(all(fit$data$chromosome == data$chromosome));
+ # stopifnot(all(fit$data$x == data$x));
+ # stopifnot(all(fit$data$index == data$index));
+ # stopifnot(all.equal(fit$data$y, data$y));
+ } # if (R_SANITY_CHECK)
+
+ verbose && exit(verbose);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Return results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ return(fit);
+ } # if (nbrOfSegments > 1)
+
+ nbrOfSegments <- nrow(knownSegments);
+
+ # Sanity check
+ if (R_SANITY_CHECK) {
+ stopifnot(nbrOfSegments <= 1);
+ } # if (R_SANITY_CHECK)
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Specific segment?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (nbrOfSegments > 0) {
+ knownSegments <- subset(knownSegments, chromosome == chromosome);
+ nbrOfSegments <- nrow(knownSegments);
+ # Sanity check
+ if (R_SANITY_CHECK) {
+ stopifnot(nbrOfSegments <= 1);
+ } # if (R_SANITY_CHECK)
+ }
+
+ if (nbrOfSegments == 1) {
+ seg <- knownSegments[1,];
+ chromosomeJJ <- seg$chromosome;
+ xStart <- seg$start;
+ xEnd <- seg$end;
+ segTag <- sprintf("chr%s:(%s,%s)", chromosomeJJ, xStart, xEnd);
+ verbose && printf(verbose, "Extracting segment '%s'", segTag, level=-50);
+
+ # Extract subset of data and parameters for this segment
+ data <- subset(data, chrom == chromosomeJJ & xStart <= x & x <= xEnd);
+ verbose && str(verbose, data, level=-50);
+ }
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Retrieving segmentation function
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Retrieving the fit function", level=-50);
+ # We need to attach the 'DNAcopy' package
+ pkgName <- "DNAcopy"
+ use(pkgName);
+ pkg <- packageDescription(pkgName);
+ pkgVer <- pkg$Version;
+ pkgDetails <- sprintf("%s v%s", pkgName, pkgVer);
+
+ methodName <- "segment";
+ verbose && cat(verbose, "Method: ", methodName, level=-50);
+ verbose && cat(verbose, "Package: ", pkgDetails, level=-50);
+
+ # Get the fit function for the segmentation method
+# fitFcn <- getExportedValue(pkgName, methodName);
+ fitFcn <- getFromNamespace(methodName, pkgName);
+ verbose && str(verbose, "Function: ", fitFcn, level=-50);
+ formals <- formals(fitFcn);
+ verbose && cat(verbose, "Formals:", level=-50);
+ verbose && str(verbose, formals, level=-50);
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setting up arguments to pass to segmentation function
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Setting up method arguments", level=-50);
+
+ verbose && enter(verbose, "Setting up ", pkgName, " data structure", level=-50);
+
+ sampleName <- "y"; # This is going to be the name of the data field
+
+ # Supress all warnings, in order to avoid warnings by DNAcopy::CNA()
+ # on "array has repeated maploc positions". Ideally we should filter
+ # just those out. /HB 2013-10-22
+ suppressWarnings({
+ cnData <- CNA(
+ genomdat = data$y,
+ chrom = data$chrom,
+ data.type = "logratio",
+ maploc = data$x,
+ sampleid = sampleName,
+ presorted = TRUE
+ );
+ });
+ verbose && str(verbose, cnData, level=-50);
+ names(cnData)[3] <- sampleName;
+ verbose && str(verbose, cnData, level=-50);
+ verbose && exit(verbose);
+
+ # Sanity check
+ if (R_SANITY_CHECK) {
+ # (because all loci with unknown locations have already been dropped)
+ stopifnot(nrow(cnData) == nrow(data));
+ } # if (R_SANITY_CHECK)
+
+
+ userArgs <- list(...);
+ if (length(userArgs) > 0) {
+ verbose && cat(verbose, "User arguments:", level=-50);
+ verbose && str(verbose, userArgs, level=-50);
+ }
+
+ # Check if 'sbdry' can/should be precalculated. This uses memoization
+ # so that next time you segment with same 'nperm', 'alpha' and 'eta'
+ # parameters, there will be much less startup overhead.
+ if (length(userArgs) > 0 && !is.element("sbdry", names(userArgs))) {
+ keys <- c("nperm", "alpha", "eta");
+ keep <- is.element(keys, names(userArgs));
+ if (any(keep)) {
+ verbose && enter(verbose, "Precalculating argument 'sbdry' (with memoization)", level=-50);
+ # Precalculate boundaries
+ argsT <- formals[keys];
+ keys <- keys[keep];
+ argsT[keys] <- userArgs[keys];
+ argsT$verbose <- less(verbose, 5);
+ sbdry <- do.call(getbdry2, args=argsT);
+ userArgs$sbdry <- sbdry;
+ verbose && exit(verbose);
+ }
+ }
+
+ params <- list();
+
+ if (hasWeights) {
+ params$weights <- data$w;
+ }
+
+ if (undo > 0) {
+ params$undo.splits <- "sdundo";
+ params$undo.SD <- undo;
+ }
+
+ verbose && cat(verbose, "Segmentation parameters:", level=-50);
+ verbose && str(verbose, params, level=-50);
+
+ # Assign/overwrite by user arguments
+ if (length(userArgs) > 0) {
+ for (ff in names(userArgs)) {
+ params[[ff]] <- userArgs[[ff]];
+ }
+ }
+
+ verbose && cat(verbose, "Segmentation and user parameters:", level=-50);
+ verbose && str(verbose, params, level=-50);
+
+ # Cleaning out unknown parameters
+ keep <- (names(params) %in% names(formals));
+ params <- params[keep];
+
+ args <- c(list(cnData), params, verbose=as.logical(verbose));
+ verbose && cat(verbose, "Final arguments:", level=-50);
+ verbose && str(verbose, args, level=-50);
+
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Calling segmentation function
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, sprintf("Calling %s() of %s", methodName, pkgName), level=-50);
+
+ # There are a few cases where we can/need to do a dummy segmentation
+ # based on a single data points:
+ # (a) WORKAROUND for the case when there are no data points.
+ # (b) SPEEDUP: When undo=+Inf we don't really have to segment.
+ nbrOfNonMissingLoci <- sum(!is.na(cnData$y));
+ if (nbrOfNonMissingLoci == 0) {
+ args[[1]] <- CNA(genomdat=0, chrom=0, maploc=0);
+ if (hasWeights) args$weights <- 1.0
+ } else if (undo == +Inf) {
+ args[[1]] <- CNA(genomdat=0, chrom=0, maploc=0);
+ if (hasWeights) args$weights <- 1.0
+ verbose && cat(verbose, "Skipping identification of new change points (undo=+Inf)", level=-50);
+ }
+
+
+ ## Set random seed?
+ if (!is.null(seed)) {
+ randomSeed("set", seed=seed, kind="L'Ecuyer-CMRG")
+ on.exit(randomSeed("reset"), add=TRUE)
+ verbose && printf(verbose, "Random seed temporarily set (seed=c(%s), kind=\"L'Ecuyer-CMRG\")\n", paste(seed, collapse=", "))
+ }
+
+ # In case the method writes to stdout, we capture it
+ # Note: DNAcopy::segment() *does* this.
+ stdout <- capture.output({
+ # Does not work, because some internal function of the fit function
+ # may only be accessible from within the namespace
+ # How to do this for DNAcopy::segment()? /HB
+## fit <- do.call(fitFcn, args);
+ # This works, but requires that one loads the package and that the
+ # function is not masked in the search() path.
+ t <- system.time({
+ fit <- do.call(methodName, args);
+ });
+ # Drop the 'call' (because it will be huge due to the do.call() call)
+ fit$call <- NULL;
+ });
+ attr(fit, "processingTime") <- t;
+ attr(fit, "pkgDetails") <- pkgDetails;
+ attr(fit, "randomSeed") <- seed;
+
+ # WORKAROUND for the case when there are no data points.
+ if (nbrOfNonMissingLoci == 0) {
+ # Drop dummy data point...
+ fit$data <- cnData; ## fit$data[-1,,drop=FALSE];
+ # ...dummy region found
+ output <- fit$output;
+ segRows <- fit$segRows;
+
+ # Sanity check
+ if (R_SANITY_CHECK) {
+ stopifnot(nrow(output) == 1);
+ } # if (R_SANITY_CHECK)
+
+ # Was a region specified?
+ if (nbrOfSegments == 1) {
+ seg <- knownSegments[1,];
+ output$ID <- sampleName;
+ output$chrom <- seg$chromosome;
+ if (is.finite(seg$start)) {
+ output$loc.start <- seg$start;
+ }
+ if (is.finite(seg$end)) {
+ output$loc.end <- seg$end;
+ }
+ output$num.mark <- 0L;
+ output$seg.mean <- NA_real_;
+ segRows[1,] <- NA_integer_;
+ } else {
+ output <- output[-1,,drop=FALSE];
+ segRows <- segRows[-1,,drop=FALSE];
+ }
+ fit$output <- output;
+ fit$segRows <- segRows;
+ } else if (undo == +Inf) {
+ # Drop dummy data point...
+ fit$data <- cnData; ## fit$data[-1,,drop=FALSE];
+ # ...dummy region found
+ output <- fit$output;
+ segRows <- fit$segRows;
+
+ # Sanity check
+ if (R_SANITY_CHECK) {
+ stopifnot(nrow(output) == 1);
+ } # if (R_SANITY_CHECK)
+
+ # Was a region specified?
+ if (nbrOfSegments == 1) {
+ seg <- knownSegments[1,];
+ output$ID <- sampleName;
+ output$chrom <- seg$chromosome;
+ if (is.finite(seg$start)) {
+ output$loc.start <- seg$start;
+ } else {
+ output$loc.start <- min(cnData$maploc, na.rm=TRUE);
+ }
+ if (is.finite(seg$end)) {
+ output$loc.end <- seg$end;
+ } else {
+ output$loc.end <- max(cnData$maploc, na.rm=TRUE);
+ }
+ }
+ output$num.mark <- nrow(fit$data);
+ output$seg.mean <- mean(fit$data$y, na.rm=TRUE);
+ segRows$endRow <- nrow(fit$data);
+
+ fit$output <- output;
+ fit$segRows <- segRows;
+ } # if (undo == +Inf)
+
+ verbose && cat(verbose, "Captured output that was sent to stdout:", level=-50);
+ stdout <- paste(stdout, collapse="\n");
+ verbose && cat(verbose, stdout, level=-50);
+
+ verbose && cat(verbose, "Fitting time (in seconds):", level=-50);
+ verbose && print(verbose, t, level=-50);
+
+ verbose && cat(verbose, "Fitting time per 1000 loci (in seconds):", level=-50);
+ verbose && print(verbose, 1000*t/nbrOfLoci, level=-50);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Restructure
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Restructuring results", level=-50);
+
+ # Coerce
+ fit$output$num.mark <- as.integer(fit$output$num.mark);
+
+ # Coerce 'chrom' to a plain integer
+ fit$data$chrom <- unclass(fit$data$chrom);
+
+ # Store genomewide index
+ fit$data$index <- data$index;
+
+ # Store weights
+ fit$data$w <- data$w;
+
+ # Not needed anymore
+ data <- NULL;
+
+ verbose && exit(verbose);
+
+
+ # Store also interesting parameters to DNAcopy::segment()
+ keys <- setdiff(names(formals), c("x", "weights", "sbdry", "verbose"));
+ keys <- c(keys, "undo", "seed");
+ keep <- is.element(names(params), keys);
+ keep <- names(params)[keep];
+ params <- params[keep];
+ params$undo <- undo;
+ params$joinSegments <- joinSegments;
+ params$knownSegments <- knownSegments;
+ params$seed <- seed;
+ fit$params <- params;
+
+# class(fit) <- c("CBS", class(fit));
+ class(fit) <- c("CBS", "AbstractCBS");
+
+ # Sanity checks
+ if (R_SANITY_CHECK) {
+ segRows <- fit$segRows;
+ stopifnot(all(segRows[,1] <= segRows[,2], na.rm=TRUE));
+ stopifnot(all(segRows[-nrow(segRows),2] < segRows[-1,1], na.rm=TRUE));
+ } # if (R_SANITY_CHECK)
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Renaming column names
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ data <- getLocusData(fit);
+ names <- colnames(data);
+ names <- gsub("chrom", "chromosome", names, fixed=TRUE);
+ names <- gsub("maploc", "x", names, fixed=TRUE);
+ colnames(data) <- names;
+
+ # Drop 'CNA' class and DNAcopy attributes
+ class(data) <- c("data.frame");
+ attr(data, "data.type") <- NULL;
+
+ fit$data <- data;
+
+ segs <- fit$output;
+
+ names <- colnames(segs);
+ names <- gsub("ID", "sampleName", names, fixed=TRUE);
+ names <- gsub("seg.mean", "mean", names, fixed=TRUE);
+ names <- gsub("chrom", "chromosome", names, fixed=TRUE);
+ names <- gsub("num.mark", "nbrOfLoci", names, fixed=TRUE);
+ names <- gsub("loc.", "", names, fixed=TRUE); # loc.start, loc.end
+ colnames(segs) <- names;
+ fit$output <- segs;
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Join segments?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (joinSegments) {
+ if (nbrOfSegments == 1) {
+ starts <- knownSegments$start;
+ ends <- knownSegments$end;
+ if (is.infinite(starts)) starts <- segs$start;
+ if (is.infinite(ends)) ends <- segs$end;
+ range <- range(c(starts, ends), na.rm=TRUE);
+ } else {
+ range <- NULL;
+ }
+
+ fit <- joinSegments(fit, range=range, verbose=less(verbose, 10));
+
+ # Sanity checks
+ if (R_SANITY_CHECK) {
+ segRows <- fit$segRows;
+ stopifnot(all(segRows[,1] <= segRows[,2], na.rm=TRUE));
+ stopifnot(all(segRows[-nrow(segRows),2] < segRows[-1,1], na.rm=TRUE));
+ } # if (R_SANITY_CHECK)
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Update?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (avg != "mean") {
+ verbose && enter(verbose, "Updating mean level using different estimator")
+ verbose && cat(verbose, "Estimator: ", avg)
+ fit <- updateMeans(fit, avg=avg, verbose=less(verbose, 20))
+ verbose && exit(verbose)
+ }
+
+
+ verbose && cat(verbose, "Results object:", level=-10);
+ verbose && str(verbose, fit, level=-10);
+
+ verbose && exit(verbose);
+
+
+ verbose && exit(verbose);
+
+ fit;
+}) # segmentByCBS()
+
+
+setMethodS3("segmentByCBS", "data.frame", function(y, ...) {
+ # To please R CMD check
+ data <- y;
+
+ y <- data$y;
+ if (is.null(y)) {
+ y <- data$cn;
+ if (is.null(y)) {
+ y <- data$CT;
+ }
+ }
+
+ segmentByCBS(y=y, chromosome=data$chromosome, x=data$x, index=data$index, w=data$w, ...);
+})
+
+
+setMethodS3("segmentByCBS", "CBS", function(...) {
+ resegment(...);
+}) # segmentByCBS()
+
+
+
+############################################################################
+# HISTORY:
+# 2013-09-26
+# o CLEANUP: Now segmentByCBS() no longer attaches 'R.cache' in its
+# internal getbdry2() function, but only loads its namespace.
+# 2012-09-20
+# o BUG FIX: segmentByCBS(... knownSegments) could return segments for
+# chromosome 0 even though it did not exist in the input data.
+# 2012-09-13
+# o SPEEDUP: Now segmentByCBS(..., undo=+Inf) returns much faster, which
+# is possible because there is no need to identify new change points.
+# o CONSISTENCY FIX: Changed the behavior of extreme values of argument
+# 'undo' to segmentByCBS() such that 'undo=0' (was 'undo=+Inf') now
+# means that it will not ask DNAcopy::segment() to undo the segmentation,
+# and such that 'undo=+Inf' means that no changepoints will be identified.
+# The latter case allows you to effectively skip the segmentation but
+# still calculate all the CBS statistics across a set of known segments
+# via segmentByCBS(..., undo=+Inf, knownSegments=knownSegments).
+# 2012-06-05
+# o Now segmentByCBS() for data frame:s does a better job identifying
+# the CN signals.
+# 2012-02-22
+# o BUG FIX: segmentByCBS(..., knownSegments=knownSegments) would
+# incorrectly throw a sanity-check exception if 'knownSegments'
+# contains a segment with 'start' and 'stop' positions being equal.
+# 2011-11-17
+# o BUG FIX: Now parameter 'seed' is preserved by segmentByCBS().
+# o Added segmentByCBS() for CBS, which is just a wrapper for resegment().
+# o ROBUSTNESS: Now segmentByCBS() does more validation of 'knownSegments'.
+# o ROBUSTNESS: Added more sanity checks for (start,end) of segments
+# after merging segments that have been segmented separately due
+# to 'knownSegments'.
+# o Adjusted segmentByCBS() such that it can handle 'knownSegments' with
+# chromosome boundaries given as -Inf and +Inf.
+# 2011-11-15
+# o Now more segmentation parameters are stored in the CBS object.
+# o SPEEDUP: Now segmentByCBS() will use memoization to retrieve
+# so called "sequential boundaries for early stopping", iff any of
+# the DNAcopy::segment() arguments 'alpha', 'nperm' and 'eta' are
+# specified. See also DNAcopy::getbdry().
+# 2011-10-20
+# o Now the result of segmentByCBS() is guaranteed to include the
+# segments given by argument 'knownSegments'. Before empty segments
+# would be dropped.
+# 2011-10-19
+# o Replaced argument 'knownCPs' with 'knownSegments' for segmentByCBS().
+# o Added support for specifying known change points in segmentByCBS().
+# 2011-10-02
+# o Added segmentByCBS() for data.frame such that the locus-level data
+# arguments can also be passed via a data.frame.
+# 2011-09-04
+# o ROBUSTNESS: Added drop=FALSE to matrix subsettings.
+# 2011-09-03
+# o Now segmentByCBS() always returns a CBS object. To coerce to a
+# DNAcopy object (as defined in the DNAcopy class) use as.DNAcopy().
+# o Removed argument 'columnNamesFlavor'.
+# 2011-09-02
+# o Forgot to pass on argument 'index' in multi-chromosome processing.
+# 2011-09-01
+# o GENERALIZATION: Now segmentByCBS() can process multiple chromosomes.
+# o Now the random seed is set at the very beginning of the code, which
+# should not make a difference, i.e. it should give identical results.
+# 2011-06-14
+# o GENERALIZATION: Added argument 'columnNamesFlavor' to segmentByCBS().
+# o CONVENTION: Changed the column names of returned data frames.
+# They now follow the camelCase naming convention and are shorter.
+# 2011-05-31
+# o Now explicitly using DNAcopy::nnn() to call DNAcopy functions.
+# 2011-04-07
+# o ROBUSTNESS: Added 'segRows' field validation in segmentByCBS().
+# 2010-12-01
+# o Now segmentByCBS() is utilizing 'segRows' from DNAcopy::segment(),
+# which makes it possible to drop all code of trying to infer which
+# loci belong to which segments.
+# o Now the 'data' object returned also contains column 'index'.
+# 2010-12-01
+# o Now the genomewide index is always stored in the 'data' field.
+# o Added argument 'index' to segmentByCBS().
+# 2010-11-30
+# o Now segmentByCBS() returns a field 'lociToExclude'.
+# 2010-11-28
+# o BUG FIX: The algorithm in segmentByCBS() that infers which loci( of
+# the ones share the same genomic positions) that should be exclude
+# from each segment did not take missing signals into account.
+# 2010-11-21
+# o Now segmentByCBS(..., joinSegments=TRUE) utilizes joinSegments().
+# 2010-11-20
+# o Now it is possible to specify the boundaries of the regions to be
+# segmented as known change points via argument 'knownCPs'.
+# 2010-11-19
+# o Added argument 'joinSegments' to segmentByCBS() in order to specify
+# if neighboring segments should be joined or not.
+# o Now segmentByCBS() returns an object of class CBS.
+# o Now segmentByCBS() allows for unknown genomic positions.
+# o Now segmentByCBS() allows for missing signals.
+# o Added argument 'preservOrder' to segmentByCBS(). If TRUE, then
+# the loci in the returned 'data' object are ordered as the input
+# data, otherwise it is ordered along the genome.
+# 2010-11-16
+# o Now the 'data' object returned by segmentByCBS() contains field
+# 'index' if and only if the loci had to be reorder along the genome.
+# 2010-11-02
+# o Added argument 'undo' to segmentByCBS(), which corresponds to
+# undo.splits="sdundo" and undo.SD=undo, if undo < Inf.
+# 2010-10-25
+# o Now segmentByCBS() also returns element 'lociNotPartOfSegment',
+# if there are segments that share end points, which can happen if
+# a change point is called in middle of a set of loci that have the
+# same genomic positions. In such cases, 'lociNotPartOfSegment'
+# specifies which loci are *not* part of which segment. Then by
+# identifying the loci that are within a segment by their positions
+# and excluding any of the above, one knows exactly which loci
+# CBS included in each segment.
+# 2010-10-02
+# o Added argument optional 'chromosome'.
+# 2010-09-02
+# o ROBUSTNESS: Now segmentByCBS() also works if there are no data points.
+# 2010-07-09
+# o Created from segmentByCBS() for RawGenomicSignals in aroma.core.
+# The latter will eventually call this method.
+############################################################################
diff --git a/R/segmentByNonPairedPSCBS.R b/R/segmentByNonPairedPSCBS.R
new file mode 100644
index 0000000..147f600
--- /dev/null
+++ b/R/segmentByNonPairedPSCBS.R
@@ -0,0 +1,288 @@
+###########################################################################/**
+# @RdocDefault segmentByNonPairedPSCBS
+# @alias segmentByNonPairedPSCBS.data.frame
+# @alias segmentByNonPairedPSCBS.PairedPSCBS
+# @alias segmentByNonPairedPSCBS
+#
+# @title "Segment total copy numbers and allele B fractions using the Non-paired PSCBS method"
+#
+# \description{
+# @get "title" [1].
+# This method does not requires matched normals.
+# This is a low-level segmentation method.
+# It is intended to be applied to one tumor sample at the time.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{CT}{A @numeric @vector of J tumor total copy number (TCN)
+# ratios in [0,+ at Inf) (due to noise, small negative values are
+# also allowed). The TCN ratios are typically scaled such that
+# copy-neutral diploid loci have a mean of two.}
+# \item{betaT}{A @numeric @vector of J tumor allele B fractions (BAFs)
+# in [0,1] (due to noise, values may be slightly outside as well)
+# or @NA for non-polymorphic loci.}
+# \item{...}{Additional arguments passed to @see "segmentByPairedPSCBS".}
+# \item{flavor}{A @character specifying what type of segmentation and
+# calling algorithm to be used.}
+# \item{tauA, tauB}{Lower and upper thresholds (\code{tauA < tauB} for
+# calling SNPs heterozygous based on the tumor allele B fractions
+# (\code{betaT}). If @NA, then they are estimates from data.
+# }
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns the segmentation results as a @see "NonPairedPSCBS" object.
+# }
+#
+# \details{
+# Internally @see "segmentByPairedPSCBS" is used for segmentation.
+# This segmentation method does \emph{not} support weights.
+# }
+#
+# \section{Reproducibility}{
+# The "DNAcopy::segment" implementation of CBS uses approximation
+# through random sampling for some estimates. Because of this,
+# repeated calls using the same signals may result in slightly
+# different results, unless the random seed is set/fixed.
+# }
+#
+# \section{Whole-genome segmentation is preferred}{
+# Although it is possible to segment each chromosome independently
+# using Paired PSCBS, we strongly recommend to segment whole-genome
+# (TCN,BAF) data at once. The reason for this is that downstream
+# CN-state calling methods, such as the AB and the LOH callers,
+# performs much better on whole-genome data. In fact, they may
+# fail to provide valid calls if done chromsome by chromosome.
+# }
+#
+# \section{Missing and non-finite values}{
+# The total copy number signals as well as any optional positions
+# must not contain missing values, i.e. @NAs or @NaNs.
+# If there are any, an informative error is thrown.
+# Allele B fractions may contain missing values, because such are
+# interpreted as representing non-polymorphic loci.
+#
+# None of the input signals may have infinite values, i.e. - at Inf or + at Inf.
+# If so, an informative error is thrown.
+# }
+#
+# \section{Non-Paired PSCBS with known genotypes}{
+# If allele B fractions for the matched normal (\code{betaN}) are
+# not available, but genotypes (\code{muN}) are, then it is possible
+# to run Paired PSCBS. See @see "segmentByPairedPSCBS" for details.
+# }
+#
+# @examples "../incl/segmentByNonPairedPSCBS.Rex"
+#
+# @author "HB"
+#
+# \references{
+# [1] @include "../incl/OlshenA_etal_2011.Rd" \cr
+# [2] @include "../incl/BengtssonH_etal_2010.Rd" \cr
+# }
+#
+# \seealso{
+# To segment paired tumor-normal total copy numbers and allele B fractions,
+# see @see "segmentByPairedPSCBS".
+#
+# To segment total copy numbers, or any other unimodal signals,
+# see @see "segmentByCBS".
+# }
+#
+# @keyword IO
+#*/###########################################################################
+setMethodS3("segmentByNonPairedPSCBS", "default", function(CT, betaT, ..., flavor=c("tcn", "tcn&dh", "tcn,dh", "sqrt(tcn),dh", "sqrt(tcn)&dh"), tauA=NA, tauB=1-tauA, verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'CT':
+ disallow <- c("Inf");
+ CT <- Arguments$getDoubles(CT, disallow=disallow);
+ nbrOfLoci <- length(CT);
+ length2 <- rep(nbrOfLoci, times=2);
+
+ # Argument 'betaT':
+ betaT <- Arguments$getDoubles(betaT, length=length2, disallow="Inf");
+
+ # Argument 'flavor':
+ flavor <- match.arg(flavor);
+ knownFlavors <- eval(formals(segmentByPairedPSCBS.default)$flavor);
+ if (!is.element(flavor, knownFlavors)) {
+ throw("Segmentation flavor is not among the supported ones (", paste(sprintf("\"%s\"", knownFlavors), collapse=", "), "): ", flavor);
+ }
+
+ # Argument 'tauA' & 'tauB':
+ if (!is.na(tauA) && !is.na(tauB)) {
+ tauA <- Arguments$getDouble(tauA);
+ tauB <- Arguments$getDouble(tauB);
+ if (tauB < tauA) {
+ throw("Argument 'tauA' must be smaller than 'tauB': ", tauA, " > ", tauB);
+ }
+ tauA <- Arguments$getDouble(tauA, range=c(-0.5, +0.5));
+ tauB <- Arguments$getDouble(tauB, range=c(+0.5, +1.5));
+ }
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Segmenting non-paired tumor signals using Non-paired PSCBS");
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setup input data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && cat(verbose, "Number of loci: ", nbrOfLoci);
+
+ # SNPs are identifies as those loci that have non-missing 'betaT'
+ isSnp <- !is.na(betaT);
+ nbrOfSnps <- sum(isSnp);
+ verbose && cat(verbose, "Number of SNPs: ", nbrOfSnps);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Call tumor "genotypes"
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Calling \"genotypes\" from tumor allele B fractions");
+ verbose && str(verbose, betaT);
+
+ if (is.na(tauA) && is.na(tauB)) {
+ mBAF <- abs(betaT - 1/2);
+ findPeaksAndValleys <- .use("findPeaksAndValleys", package="aroma.light");
+ fitT <- findPeaksAndValleys(mBAF);
+ type <- NULL; rm(list="type"); # To please 'R CMD check'.
+ fitT <- subset(fitT, type == "peak");
+ o <- order(fitT$density, decreasing=TRUE);
+ fitT <- fitT[o,];
+ fitT <- fitT[1,];
+ z <- mBAF[mBAF >= fitT$x] - fitT$x;
+ q <- quantile(z, probs=0.95, na.rm=TRUE, names=FALSE);
+ qU <- fitT$x+q;
+ verbose && cat(verbose, "Upper quantile: ", qU);
+ qL <- fitT$x - q;
+ verbose && cat(verbose, "Symmetric lower quantile: ", qL);
+ tauA <- 1/2-qL;
+ tauB <- 1/2+qL;
+ verbose && cat(verbose, "(tauA, tauB) estimates: (%g,%g)", tauA, tauB);
+
+ # Sanity check on (tauA, tauB) estimates
+ if (tauB < tauA) {
+ throw("Failed to estimate (tauA, tauB). The estimate 'tauA' is greater than 'tauB', which it should not: ", tauA, " > ", tauB);
+ }
+ tauA <- Arguments$getDouble(tauA, range=c(-0.5, +0.5));
+ tauB <- Arguments$getDouble(tauB, range=c(+0.5, +1.5));
+ }
+
+ verbose && cat(verbose, "Homozygous treshholds:");
+ verbose && print(verbose, c(tauA, tauB));
+
+ isHomA <- isSnp & (betaT <= tauA);
+ isHomB <- isSnp & (betaT >= tauB);
+ isHom <- (isHomA | isHomB);
+ isHet <- isSnp & !isHom;
+
+ # Tumor proxy for germline genotypes
+ naValue <- NA_real_;
+ muNx <- rep(naValue, times=length(betaT));
+ muNx[isHomA] <- 0;
+ muNx[isHet] <- 1/2;
+ muNx[isHomB] <- 1;
+ # Not needed anymore
+ isHomA <- isHomB <- isHom <- isHet <- NULL;
+
+ verbose && cat(verbose, "Inferred germline genotypes (via tumor):");
+ verbose && str(verbose, muNx);
+ verbose && print(verbose, table(muNx));
+ verbose && exit(verbose);
+
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Segment using Paired PSCBS segmentation
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Segment using Paired PSCBS");
+ fit <- segmentByPairedPSCBS(CT=CT, betaT=betaT, muN=muNx, tbn=FALSE, flavor=flavor, ..., verbose=verbose);
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Coerce fit object to Non-Paired PSCBS results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Coercing to Non-Paired PSCBS results");
+
+ data <- fit$data;
+ class(data) <- gsub("PairedPSCNData", "NonPairedPSCNData", class(data), fixed=TRUE);
+# class(data) <- c("NonPairedPSCNData", class(data));
+ fit$data <- data;
+ # Not needed anymore
+ data <- NULL;
+
+ segs <- fit$output;
+ class(segs) <- gsub("PairedPSCNSegments", "NonPairedPSCNSegments", class(segs), fixed=TRUE);
+# class(segs) <- c("NonPairedPSCNSegments", class(segs));
+ fit$output <- segs;
+ # Not needed anymore
+ segs <- NULL;
+
+ params <- fit$params;
+ params$tauA <- tauA;
+ params$tauB <- tauB;
+ fit$params <- params;
+ # Not needed anymore
+ params <- NULL;
+
+# class(fit) <- gsub("PairedPSCBS", "NonPairedPSCBS", class(fit), fixed=TRUE);
+ class(fit) <- c("NonPairedPSCBS", class(fit));
+
+ verbose && exit(verbose);
+
+
+ verbose && print(verbose, head(as.data.frame(fit)));
+ verbose && print(verbose, tail(as.data.frame(fit)));
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Return results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fit;
+}) # segmentByNonPairedPSCBS()
+
+
+
+setMethodS3("segmentByNonPairedPSCBS", "data.frame", function(CT, ...) {
+ # To please R CMD check
+ data <- CT;
+
+
+ segmentByNonPairedPSCBS(CT=data$CT, betaT=data$betaT,
+ chromosome=data$chromosome, x=data$x, ...);
+})
+
+
+
+setMethodS3("segmentByNonPairedPSCBS", "PairedPSCBS", function(...) {
+ resegment(...);
+})
+
+
+
+############################################################################
+# HISTORY:
+# 2013-07-19
+# o ROBUSTNESS: Added a sanity check on the estimates of (tauA, tauB)
+# when they are estimated from data in segmentByNonPairedPSCBS().
+# 2012-11-05
+# o DOCUMENTATION FIX: example(segmentByNonPairedPSCBS) was for the
+# paired case.
+# 2012-08-20
+# o BUG FIX: segmentByNonPairedPSCBS() forgot to specify namespace
+# aroma.light when trying to call findPeaksAndValleys().
+# 2012-04-20
+# o Created from segmentByPairedPSCBS.R.
+############################################################################
diff --git a/R/segmentByPairedPSCBS.R b/R/segmentByPairedPSCBS.R
new file mode 100644
index 0000000..87af6ee
--- /dev/null
+++ b/R/segmentByPairedPSCBS.R
@@ -0,0 +1,1420 @@
+###########################################################################/**
+# @RdocDefault segmentByPairedPSCBS
+# @alias segmentByPairedPSCBS.data.frame
+# @alias segmentByPairedPSCBS.PairedPSCBS
+# @alias segmentByPairedPSCBS
+#
+# @title "Segment total copy numbers and allele B fractions using the Paired PSCBS method"
+#
+# \description{
+# @get "title" [1].
+# This method requires matched normals.
+# This is a low-level segmentation method.
+# It is intended to be applied to one tumor-normal sample at the time.
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{CT}{A @numeric @vector of J tumor total copy number (TCN)
+# ratios in [0,+ at Inf) (due to noise, small negative values are
+# also allowed). The TCN ratios are typically scaled such that
+# copy-neutral diploid loci have a mean of two.}
+# \item{thetaT, thetaN}{(alternative) As an alternative to specifying
+# tumor TCN \emph{ratios} relative to the match normal by
+# argument \code{CT}, on may specify total tumor and normal
+# signals seperately, in which case the TCN ratios \code{CT} are
+# calculated as \eqn{CT = 2*thetaT/thetaN}.}
+# \item{betaT}{A @numeric @vector of J tumor allele B fractions (BAFs)
+# in [0,1] (due to noise, values may be slightly outside as well)
+# or @NA for non-polymorphic loci.}
+# \item{betaN}{A @numeric @vector of J matched normal BAFs in [0,1]
+# (due to noise, values may be slightly outside as well) or @NA
+# for non-polymorphic loci.}
+# \item{muN}{An optional @numeric @vector of J genotype calls in
+# \{0,1/2,1\} for AA, AB, and BB, respectively,
+# and @NA for non-polymorphic loci.
+# If not given, they are estimated from the normal BAFs using
+# @see "aroma.light::callNaiveGenotypes" as described in [2].}
+# \item{rho}{(alternative to \code{betaT} and \code{betaN}/\code{muN})
+# A @numeric @vector of J decrease-of-heterozygosity signals (DHs)
+# in [0,1] (due to noise, values may be slightly larger than one
+# as well). By definition, DH should be @NA for homozygous loci
+# and for non-polymorphic loci.}
+# \item{chromosome}{(Optional) An @integer scalar (or a @vector of length J),
+# which can be used to specify which chromosome each locus belongs to
+# in case multiple chromosomes are segments.
+# This argument is also used for annotation purposes.}
+# \item{x}{Optional @numeric @vector of J genomic locations.
+# If @NULL, index locations \code{1:J} are used.}
+# \item{alphaTCN, alphaDH}{The significance levels for segmenting total
+# copy numbers (TCNs) and decrease-in-heterozygosity signals (DHs),
+# respectively.}
+# \item{undoTCN, undoDH}{Non-negative @numerics. If greater than 0,
+# then a cleanup of segmentions post segmentation is done.
+# See argument \code{undo} of @see "segmentByCBS" for more
+# details.}
+# \item{avgTCN, avgDH}{A @character string specifying how to calculating
+# segment mean levels \emph{after} change points have been
+# identified.}
+# \item{...}{Additional arguments passed to @see "segmentByCBS".}
+# \item{flavor}{A @character specifying what type of segmentation and
+# calling algorithm to be used.}
+# \item{tbn}{If @TRUE, \code{betaT} is normalized before segmentation
+# using the TumorBoost method [2], otherwise not.}
+# \item{preserveScale}{Passed to @see "aroma.light::normalizeTumorBoost",
+# which is only called if \code{tbn} is @TRUE.}
+# \item{joinSegments}{If @TRUE, there are no gaps between neighboring
+# segments.
+# If @FALSE, the boundaries of a segment are defined by the support
+# that the loci in the segments provides, i.e. there exist a locus
+# at each end point of each segment. This also means that there
+# is a gap between any neighboring segments, unless the change point
+# is in the middle of multiple loci with the same position.
+# The latter is what \code{DNAcopy::segment()} returns.
+# }
+# \item{knownSegments}{Optional @data.frame specifying
+# \emph{non-overlapping} known segments. These segments must
+# not share loci. See @see "findLargeGaps" and @see "gapsToSegments".}
+# \item{dropMissingCT}{If @TRUE, loci for which 'CT' is missing
+# are dropped, otherwise not.}
+# \item{seed}{An (optional) @integer specifying the random seed to be
+# set before calling the segmentation method. The random seed is
+# set to its original state when exiting. If @NULL, it is not set.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns the segmentation results as a @see "PairedPSCBS" object.
+# }
+#
+# \details{
+# Internally @see "segmentByCBS" is used for segmentation.
+# The Paired PSCBS segmentation method does \emph{not} support weights.
+# }
+#
+# \section{Reproducibility}{
+# The "DNAcopy::segment" implementation of CBS uses approximation
+# through random sampling for some estimates. Because of this,
+# repeated calls using the same signals may result in slightly
+# different results, unless the random seed is set/fixed.
+# }
+#
+# \section{Whole-genome segmentation is preferred}{
+# Although it is possible to segment each chromosome independently
+# using Paired PSCBS, we strongly recommend to segment whole-genome
+# (TCN,BAF) data at once. The reason for this is that downstream
+# CN-state calling methods, such as the AB and the LOH callers,
+# performs much better on whole-genome data. In fact, they may
+# fail to provide valid calls if done chromsome by chromosome.
+# }
+#
+# \section{Missing and non-finite values}{
+# The total copy number signals as well as any optional positions
+# must not contain missing values, i.e. @NAs or @NaNs.
+# If there are any, an informative error is thrown.
+# Allele B fractions may contain missing values, because such are
+# interpreted as representing non-polymorphic loci.
+#
+# None of the input signals may have infinite values, i.e. - at Inf or + at Inf.
+# If so, an informative error is thrown.
+# }
+#
+# \section{Paired PSCBS with only genotypes}{
+# If allele B fractions for the matched normal (\code{betaN}) are
+# not available, but genotypes (\code{muN}) are, then it is possible
+# to run a version of Paired PSCBS where TumorBoost normalization
+# of the tumor allele B fractions is skipped. In order for this
+# to work, argument \code{tbn} must be set to @FALSE.
+# }
+#
+# @examples "../incl/segmentByPairedPSCBS.Rex"
+#
+# @author "HB"
+#
+# \references{
+# [1] @include "../incl/OlshenA_etal_2011.Rd" \cr
+# [2] @include "../incl/BengtssonH_etal_2010.Rd" \cr
+# }
+#
+# \seealso{
+# Internally, @see "aroma.light::callNaiveGenotypes" is used to
+# call naive genotypes, @see "aroma.light::normalizeTumorBoost" is
+# used for TumorBoost normalization, and @see "segmentByCBS" is used
+# to segment TCN and DH separately.
+#
+# To segment tumor total copy numbers and allele B fractions
+# \emph{without} a matched normal, see @see "segmentByNonPairedPSCBS".
+#
+# To segment total copy-numbers, or any other unimodal signals,
+# see @see "segmentByCBS".
+# }
+#
+# @keyword IO
+#*/###########################################################################
+setMethodS3("segmentByPairedPSCBS", "default", function(CT, thetaT=NULL, thetaN=NULL, betaT=NULL, betaN=NULL, muN=NULL, rho=NULL, chromosome=0, x=NULL, alphaTCN=0.009, alphaDH=0.001, undoTCN=0, undoDH=0, ..., avgTCN=c("mean", "median"), avgDH=c("mean", "median"), flavor=c("tcn&dh", "tcn,dh", "sqrt(tcn),dh", "sqrt(tcn)&dh", "tcn"), tbn=is.null(rho), preserveScale=getOption("PSCBS/preserveScale", FALSE), joinSegments=TRUE, knownSegments=NULL, dropMissingCT=TRUE, seed=NULL, verbose=FALSE) {
+ # WORKAROUND: If Hmisc is loaded after R.utils, it provides a buggy
+ # capitalize() that overrides the one we want to use. Until PSCBS
+ # gets a namespace, we do the following workaround. /HB 2011-07-14
+ capitalize <- R.utils::capitalize;
+
+ # To please R CMD check
+ index <- NULL; rm(list="index");
+
+ # Settings for sanity checks
+ tol <- getOption("PSCBS/sanityChecks/tolerance", 0.0005);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'thetaT' & 'thetaN':
+ if (!is.null(thetaT) && !is.null(thetaN)) {
+ thetaT <- Arguments$getDoubles(thetaT, disallow=disallow);
+ nbrOfLoci <- length(thetaT);
+ length2 <- rep(nbrOfLoci, times=2L);
+ thetaN <- Arguments$getDoubles(thetaN, length=length2, disallow=disallow);
+ CT <- 2 * thetaT / thetaN;
+ } else if (!is.null(thetaT) || !is.null(thetaN)) {
+ throw("Either argument 'CT' needs to be specified or *both* of arguments 'thetaT' and 'thetaN'");
+ }
+
+ # Argument 'CT':
+ disallow <- c("Inf");
+ CT <- Arguments$getDoubles(CT, disallow=disallow);
+ nbrOfLoci <- length(CT);
+ length2 <- rep(nbrOfLoci, times=2L);
+
+
+ # Argument 'betaT':
+ if (!is.null(betaT)) {
+ betaT <- Arguments$getDoubles(betaT, length=length2, disallow="Inf")
+ }
+
+ # Argument 'betaN':
+ if (!is.null(betaN)) {
+ betaN <- Arguments$getDoubles(betaN, length=length2, disallow="Inf");
+ }
+
+ # Argument 'muN':
+ if (!is.null(muN)) {
+ muN <- Arguments$getDoubles(muN, length=length2, range=c(0,1), disallow="Inf");
+ if (all(is.na(muN)) == nbrOfLoci) {
+ throw(sprintf("All genotypes ('muN') are NAs: %d (100%%) out of %d", nbrOfLoci, nbrOfLoci));
+ }
+ }
+
+ # Argument 'rho':
+ if (!is.null(rho)) {
+ rho <- Arguments$getDoubles(rho, range=c(0,Inf), length=length2, disallow="Inf")
+ }
+
+ if (is.null(muN)) {
+ if (is.null(betaN) && is.null(rho)) {
+ throw("If argument 'muN' is not given, then either 'betaN' or 'rho' must be.")
+ }
+ }
+
+ # Argument 'tbn':
+ tbn <- Arguments$getLogical(tbn);
+ if (!is.null(tbn)) {
+ if (tbn) {
+ if (is.null(betaT)) {
+ throw("Cannot do TumorBoost normalization (tbn=TRUE) without tumor BAFs ('betaT').")
+ }
+ if (is.null(betaN)) {
+ throw("Cannot do TumorBoost normalization (tbn=TRUE) with normal BAFs ('betaN').")
+ }
+ }
+ }
+
+ # Argument 'preserveScale':
+ if (tbn && missing(preserveScale)) {
+ if (!is.element("PSCBS/preserveScale", names(options()))) {
+ warning("Argument 'preserveScale' for segmentByPairedPSCBS() now defaults to FALSE. Prior to PSCBS v0.50.0 (October 2015) the default was TRUE. To avoid this warning, explicitly specify this argument when calling segmentByPairedPSCBS() or make sure to set option 'PSCBS/preserveScale' to either TRUE or FALSE. This warning will be removed in a future version.");
+ }
+ }
+ preserveScale <- Arguments$getLogical(preserveScale);
+
+ # Argument 'chromosome':
+ if (is.null(chromosome)) {
+ chromosome <- 0L;
+ } else {
+ disallow <- c("Inf");
+ chromosome <- Arguments$getIntegers(chromosome, range=c(0,Inf), disallow=disallow);
+ if (length(chromosome) > 1) {
+ chromosome <- Arguments$getIntegers(chromosome, length=length2, disallow=disallow);
+ }
+ }
+
+ # Argument 'x':
+ if (is.null(x)) {
+ x <- seq(length=nbrOfLoci);
+ } else {
+ disallow <- c("Inf");
+ x <- Arguments$getDoubles(x, length=length2, disallow=disallow);
+ }
+
+ # Argument 'alphaTCN':
+ alphaTCN <- Arguments$getDouble(alphaTCN, range=c(0,1));
+
+ # Argument 'alphaDH':
+ alphaDH <- Arguments$getDouble(alphaDH, range=c(0,1));
+
+ # Argument 'undoTCN':
+ undoTCN <- Arguments$getDouble(undoTCN, range=c(0,Inf));
+
+ # Argument 'undoDH':
+ undoDH <- Arguments$getDouble(undoDH, range=c(0,Inf));
+
+ # Argument 'avgTCN' & 'avgDH':
+ avgTCN <- match.arg(avgTCN);
+ avgDH <- match.arg(avgDH);
+
+ # Argument 'flavor':
+ flavor <- match.arg(flavor);
+ knownFlavors <- eval(formals(segmentByPairedPSCBS.default)$flavor);
+ if (!is.element(flavor, knownFlavors)) {
+ throw("Segmentation flavor is not among the supported ones (", paste(sprintf("\"%s\"", knownFlavors), collapse=", "), "): ", flavor);
+ }
+
+ # Argument 'joinSegments':
+ joinSegments <- Arguments$getLogical(joinSegments);
+
+ # Argument 'knownSegments':
+ if (is.null(knownSegments)) {
+ knownSegments <- data.frame(chromosome=integer(0), start=integer(0), end=integer(0));
+ } else {
+ if (!joinSegments) {
+## warning("Argument 'knownSegments' should only be specified if argument 'joinSegments' is TRUE.");
+ }
+ }
+
+ if (!is.data.frame(knownSegments)) {
+ throw("Argument 'knownSegments' is not a data.frame: ", class(knownSegments)[1]);
+ }
+
+ if (!all(is.element(c("chromosome", "start", "end"), colnames(knownSegments)))) {
+ throw("Argument 'knownSegments' does not have the required column names: ", hpaste(colnames(knownSegments)));
+ }
+
+ # Argument 'dropMissingCT':
+ dropMissingCT <- Arguments$getLogical(dropMissingCT);
+ if (!dropMissingCT) {
+ if (is.element(flavor, c("tcn&dh", "sqrt(tcn)&dh"))) {
+ throw("Missing values in 'CT' are (currently) not supported by the chosen 'flavor': ", flavor);
+ }
+ }
+
+
+ # Argument 'seed':
+ if (!is.null(seed)) {
+ seed <- Arguments$getIntegers(seed);
+ }
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Segmenting paired tumor-normal signals using Paired PSCBS");
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Call genotypes?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Are genotype calls muN missing and can they be called?
+ if (is.null(muN) && !is.null(betaN)) {
+ verbose && enter(verbose, "Calling genotypes from normal allele B fractions");
+ verbose && str(verbose, betaN);
+ callNaiveGenotypes <- .use("callNaiveGenotypes", package="aroma.light");
+ muN <- callNaiveGenotypes(betaN, censorAt=c(0,1));
+ verbose && cat(verbose, "Called genotypes:");
+ verbose && str(verbose, muN);
+ verbose && print(verbose, table(muN));
+ # Assert proper calls
+ muN <- Arguments$getDoubles(muN, length=length2, range=c(0,1), disallow="Inf");
+ # Sanity check
+ if (all(is.na(muN))) {
+ throw(sprintf("All genotypes ('muN') called from the normal allele B fractions ('betaN') are NAs: %d (100%%) out of %d", nbrOfLoci, nbrOfLoci));
+ }
+ verbose && exit(verbose);
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Normalize betaT using betaN (TumorBoost normalization)
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (tbn) {
+ verbose && enter(verbose, "Normalizing betaT using betaN (TumorBoost)");
+ normalizeTumorBoost <- .use("normalizeTumorBoost", package="aroma.light");
+ betaTN <- normalizeTumorBoost(betaT=betaT, betaN=betaN, muN=muN, preserveScale=preserveScale);
+ verbose && cat(verbose, "Normalized BAFs:");
+ verbose && str(verbose, betaTN);
+
+ # Assert that no missing values where introduced
+ keep <- (is.finite(betaT) & is.finite(betaN) & is.finite(muN));
+ if (anyNA(betaTN[keep])) {
+ throw("Internal error: normalizeTumorBoost() introduced missing values.");
+ }
+ # Not needed anymore
+ keep <- NULL;
+ verbose && exit(verbose);
+ } else {
+ betaTN <- betaT;
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setup data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Setup up data");
+ data <- data.frame(chromosome=chromosome, x=x, CT=CT)
+ if (!is.null(thetaT)) {
+ data$thetaT <- thetaT
+ data$thetaN <- thetaN
+ }
+ if (!is.null(betaT)) data$betaT <- betaT
+ if (!is.null(betaTN)) data$betaTN <- betaTN
+ if (!is.null(betaN)) data$betaN <- betaN
+ if (!is.null(muN)) data$muN <- muN
+ if (!is.null(rho)) data$rho <- rho
+ verbose && str(verbose, data)
+ # Not needed anymore
+ chromosome <- x <- CT <- thetaT <- thetaN <- betaT <- betaTN <- betaN <- muN <- rho <- NULL
+
+ # Sanity check
+ stopifnot(nrow(data) == nbrOfLoci);
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Drop data points without known genomic positions, because that
+ # is what DNAcopy::CNA() will do otherwise. At the end, we will
+ # undo this such that the returned 'data' object is complete.
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ok <- (!is.na(data$chromosome) & !is.na(data$x));
+ if (any(!ok)) {
+ verbose && enter(verbose, "Dropping loci with unknown locations");
+ verbose && cat(verbose, "Number of loci dropped: ", sum(!ok));
+ data <- data[ok,,drop=FALSE];
+ nbrOfLoci <- nrow(data);
+ verbose && exit(verbose);
+ }
+ ok <- NULL; # Not needed anymore
+
+ # Sanity check
+ stopifnot(nrow(data) == nbrOfLoci);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Drop loci for which CT is missing (regardless of betaT)
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (dropMissingCT) {
+ ok <- (!is.na(data$CT))
+ if (any(!ok)) {
+ verbose && enter(verbose, "Dropping loci for which TCNs are missing");
+ verbose && cat(verbose, "Number of loci dropped: ", sum(!ok));
+ data <- data[ok,,drop=FALSE];
+ nbrOfLoci <- nrow(data);
+ verbose && exit(verbose);
+ }
+ ok <- NULL; # Not needed anymore
+
+ # Sanity check
+ stopifnot(nrow(data) == nbrOfLoci);
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Reorder data points along the genome, because that is what
+ # DNAcopy::segment() will return. At the end, we will undo
+ # the sort such that the returned 'data' object is always in
+ # the same order and number of loci as the input data.
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Ordering data along genome");
+ o <- order(data$chromosome, data$x, decreasing=FALSE, na.last=TRUE);
+ # Any change?
+ if (any(o != seq(along=o))) {
+ data <- data[o,,drop=FALSE];
+ }
+ o <- NULL; # Not needed anymore
+ verbose && str(verbose, data);
+ verbose && exit(verbose);
+
+ # Attach 'index' (guaranteed to be ordered)
+ data$index <- seq(length=nrow(data));
+
+ # Sanity check
+ stopifnot(nrow(data) == nbrOfLoci);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Assert no missing values in (chromosome, x, CT)
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Sanity check
+ ok <- (!is.na(data$chromosome) & !is.na(data$x));
+ if (!all(ok)) {
+ throw("INTERNAL ERROR: Detected (chromosome, x) with missing values also after filtering.");
+ }
+
+ # Sanity check
+ if (dropMissingCT) {
+ ok <- (!is.na(data$CT));
+ if (!all(ok)) {
+ throw("INTERNAL ERROR: Detected TCN with missing values also after filtering.");
+ }
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Multiple chromosomes?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Identify all chromosomes, excluding missing values
+ chromosomes <- sort(unique(data$chromosome), na.last=NA);
+ nbrOfChromosomes <- length(chromosomes);
+ if (nbrOfChromosomes > 1) {
+ verbose && enter(verbose, "Segmenting multiple chromosomes");
+ verbose && cat(verbose, "Number of chromosomes: ", nbrOfChromosomes);
+
+ # Generate random seeds?
+ seeds <- NULL
+ if (!is.null(seed)) {
+ randomSeed("set", seed=seed, kind="L'Ecuyer-CMRG")
+ verbose && printf(verbose, "Random seed temporarily set (seed=c(%s), kind=\"L'Ecuyer-CMRG\")\n", paste(seed, collapse=", "))
+ seeds <- randomSeed("advance", n=nbrOfChromosomes)
+ verbose && printf(verbose, "Produced %d seeds from this stream for future usage\n", length(seeds))
+ randomSeed("reset")
+ }
+
+ fitList <- listenv()
+ for (kk in seq(length=nbrOfChromosomes)) {
+ chromosomeKK <- chromosomes[kk];
+ chrTag <- sprintf("Chr%02d", chromosomeKK);
+ verbose && enter(verbose, sprintf("Chromosome #%d ('%s') of %d", kk, chrTag, nbrOfChromosomes));
+
+ seedKK <- seeds[[kk]]
+
+ # Extract subset of data and parameters for this chromosome
+ dataKK <- subset(data, chromosome == chromosomeKK);
+ verbose && str(verbose, dataKK);
+ fields <- attachLocally(dataKK, fields=c("CT", "thetaT", "thetaN", "betaT", "betaTN", "betaN", "muN", "rho", "chromosome", "x"));
+ dataKK <- NULL; # Not needed anymore
+
+ knownSegmentsKK <- NULL;
+ if (!is.null(knownSegments)) {
+ knownSegmentsKK <- subset(knownSegments, chromosome == chromosomeKK);
+ verbose && cat(verbose, "Known segments:");
+ verbose && print(verbose, knownSegmentsKK);
+ }
+
+ fitList[[chrTag]] %<=% {
+ fit <- segmentByPairedPSCBS(CT=CT, thetaT=thetaT, thetaN=thetaN,
+ betaT=betaTN, betaN=betaN, muN=muN, rho=rho,
+ chromosome=chromosome, x=x,
+ tbn=FALSE, joinSegments=joinSegments,
+ knownSegments=knownSegmentsKK,
+ alphaTCN=alphaTCN, alphaDH=alphaDH,
+ undoTCN=undoTCN, undoDH=undoDH,
+ avgTCN=avgTCN, avgDH=avgDH,
+ flavor=flavor,
+ ...,
+ seed=seedKK,
+ verbose=verbose)
+
+ # Sanity checks
+ if (nrow(knownSegmentsKK) == 0) {
+ stopifnot(nrow(fit$data) == length(CT))
+ stopifnot(all.equal(fit$data$CT, CT))
+ stopifnot(all.equal(fit$data$muN, muN))
+ }
+
+ # Update betaT (which is otherwise equals betaTN)
+ fit$data$betaT <- betaT
+
+ verbose && print(verbose, head(as.data.frame(fit)))
+ verbose && print(verbose, tail(as.data.frame(fit)))
+
+ fit
+ } ## fitList[[chrTag]] <- ...
+
+ rm(list=fields) # Not needed anymore
+ verbose && exit(verbose);
+ } # for (kk ...)
+
+ verbose && enter(verbose, "Merging (independently) segmented chromosome");
+ fitList <- as.list(fitList)
+ fit <- Reduce(append, fitList);
+ fitList <- NULL; # Not needed anymore
+ verbose && str(verbose, fit);
+ verbose && exit(verbose);
+
+ # Update parameters that otherwise may be incorrect
+ fit$params$tbn <- tbn;
+ fit$params$seed <- seed;
+
+ segs <- as.data.frame(fit);
+ if (nrow(segs) < 6) {
+ verbose && print(verbose, segs);
+ } else {
+ verbose && print(verbose, head(segs));
+ verbose && print(verbose, tail(segs));
+ }
+
+ verbose && exit(verbose);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Return results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ return(fit);
+ } # if (nbrOfChromosomes > 1)
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Subset 'knownSegments'
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Keeping only current chromosome for 'knownSegments'");
+
+ currChromosome <- data$chromosome[1];
+ verbose && cat(verbose, "Chromosome: ", currChromosome);
+
+ knownSegments <- subset(knownSegments, chromosome == currChromosome);
+ nbrOfSegments <- nrow(knownSegments);
+
+ verbose && cat(verbose, "Known segments for this chromosome:");
+ verbose && print(verbose, knownSegments);
+
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Sanity checks
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Here 'knownSegments' should specify at most a single chromosome
+ uChromosomes <- sort(unique(knownSegments$chromosome));
+ if (length(uChromosomes) > 1) {
+ throw("INTERNAL ERROR: Argument 'knownSegments' specifies more than one chromosome: ", hpaste(uChromosomes));
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Assert no missing values in (chromosome, x, CT)
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Sanity check
+ ok <- (!is.na(data$chromosome) & !is.na(data$x));
+ if (!all(ok)) {
+ throw("INTERNAL ERROR: Detected (chromosome, x) with missing values also after filtering.");
+ }
+
+ # Sanity check
+ if (dropMissingCT) {
+ ok <- (!is.na(data$CT));
+ if (!all(ok)) {
+ throw("INTERNAL ERROR: Detected TCN with missing values also after filtering.");
+ }
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Setup input data
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && cat(verbose, "alphaTCN: ", alphaTCN);
+ verbose && cat(verbose, "alphaDH: ", alphaDH);
+ verbose && cat(verbose, "Number of loci: ", nbrOfLoci);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Calculate decrease-of-heterozygosity signals (DHs)?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (is.null(data$rho)) {
+ verbose && enter(verbose, "Calculating DHs")
+ # SNPs are identifies as those loci that have non-missing 'betaTN' & 'muN'
+ isSnp <- (!is.na(data$betaTN) & !is.na(data$muN))
+ nbrOfSnps <- sum(isSnp)
+ verbose && cat(verbose, "Number of SNPs: ", nbrOfSnps)
+
+ # DH is by definition only defined for heterozygous SNPs.
+ # For simplicity, we set it to be NA for non-heterozygous loci.
+ isHet <- isSnp & (data$muN == 1/2)
+ verbose && printf(verbose, "Number of heterozygous SNPs: %d (%.2f%%)\n",
+ sum(isHet), 100*sum(isHet)/nbrOfSnps)
+ rho <- rep(NA_real_, length=nbrOfLoci)
+ rho[isHet] <- 2*abs(data$betaTN[isHet]-1/2)
+ verbose && cat(verbose, "Normalized DHs:")
+ verbose && str(verbose, rho)
+ data$rho <- rho
+ isSnp <- isHet <- rho <- NULL # Not needed anymore
+ verbose && exit(verbose)
+ }
+ ## Sanity check
+ stopifnot(!is.null(data$rho))
+
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Generate random seeds?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ seeds <- NULL
+ if (!is.null(seed)) {
+ randomSeed("set", seed=seed, kind="L'Ecuyer-CMRG")
+ verbose && printf(verbose, "Random seed temporarily set (seed=c(%s), kind=\"L'Ecuyer-CMRG\")\n", paste(seed, collapse=", "))
+ seeds <- randomSeed("advance", n=2L) ## For TCN and DH
+ names(seeds) <- c("TCN", "DH")
+ verbose && printf(verbose, "Produced %d seeds from this stream for future usage\n", length(seeds))
+ randomSeed("reset")
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # 1a. Identification of change points in total copy numbers
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Identification of change points by total copy numbers");
+
+ fields <- attachLocally(data, fields=c("CT", "thetaT", "thetaN", "chromosome", "x", "index"));
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Assert no missing values in (chromosome, x, CT)
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Sanity check
+ ok <- (!is.na(data$chromosome) & !is.na(data$x));
+ if (!all(ok)) {
+ throw("INTERNAL ERROR: Detected (chromosome, x) with missing values also after filtering.");
+ }
+
+ # Sanity check
+ if (dropMissingCT) {
+ ok <- (!is.na(data$CT));
+ if (!all(ok)) {
+ throw("INTERNAL ERROR: Detected CT with missing values also after filtering.");
+ }
+ }
+
+
+ # Segment TCN ratios
+ # Calculate tumor-normal TCN ratios?
+ fit <- segmentByCBS(CT,
+ chromosome=chromosome, x=x, index=index,
+ joinSegments=joinSegments,
+ knownSegments=knownSegments,
+ alpha=alphaTCN, undo=undoTCN, ...,
+ seed=seeds[["TCN"]],
+ verbose=verbose);
+ verbose && str(verbose, fit);
+
+ rm(list=fields); # Not needed anymore
+
+ # Sanity check
+ if (nrow(knownSegments) == 0) {
+ stopifnot(nrow(fit$data) == nrow(data));
+ stopifnot(all(fit$data$chromosome == data$chromosome));
+ stopifnot(all(fit$data$x == data$x));
+ stopifnot(all(fit$data$index == data$index));
+ stopifnot(all.equal(fit$data$y, data$CT));
+ }
+
+ tcnSegments <- fit$output;
+ tcnSegRows <- fit$segRows;
+ fit <- NULL; # Not needed anymore
+
+ # Sanity checks
+ stopifnot(all(tcnSegRows[,1] <= tcnSegRows[,2], na.rm=TRUE));
+ stopifnot(all(tcnSegRows[-nrow(tcnSegRows),2] < tcnSegRows[-1,1], na.rm=TRUE));
+
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # 1b. Restructure TCN segmentation results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ verbose && enter(verbose, "Restructure TCN segmentation results");
+ # Drop dummy columns
+ keep <- setdiff(colnames(tcnSegments), c("sampleName"));
+ tcnSegments <- tcnSegments[,keep,drop=FALSE];
+
+ # Tag fields by TCN
+ names <- names(tcnSegments);
+ # Adding 'tcn' prefix to column names
+ names <- sprintf("tcn%s", capitalize(names));
+ names <- gsub("tcnChromosome", "chromosome", names, fixed=TRUE);
+ names(tcnSegments) <- names;
+ verbose && print(verbose, tcnSegments);
+
+ nbrOfSegs <- nrow(tcnSegments);
+ verbose && cat(verbose, "Number of TCN segments: ", nbrOfSegs);
+
+ verbose && exit(verbose);
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # 2a. Identification of additional change points using DH
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # For each segment independently, segment decrease of heterozygousity (DH)
+ # using CBS. By definition, only heterozygous SNPs are used.
+
+ if (flavor == "tcn") {
+ verbose && enter(verbose, "TCN-only segmentation");
+
+ tcnSegsExpanded <- tcnSegRows;
+ dhSegRows <- tcnSegRows;
+
+ # Segments
+ segs <- tcnSegments;
+ segs[,"tcnId"] <- seq(length=nbrOfSegs);
+ segs[,"dhId"] <- rep(1L, times=nbrOfSegs);
+ segs[,c("tcnNbrOfSNPs", "tcnNbrOfHets", "dhNbrOfLoci")] <- 0L;
+ segs[,"dhStart"] <- segs[,"tcnStart"];
+ segs[,"dhEnd"] <- segs[,"tcnEnd"];
+
+ # For each TCN segment...
+ for (kk in seq(length=nbrOfSegs)) {
+ tcnId <- kk;
+
+ xStart <- tcnSegments[kk,"tcnStart"];
+ xEnd <- tcnSegments[kk,"tcnEnd"];
+ regionTag <- sprintf("[%10g,%10g]", xStart, xEnd);
+ verbose && enter(verbose, sprintf("Total CN segment #%d (%s) of %d", kk, regionTag, nbrOfSegs));
+
+ # Empty segment?
+ rowStart <- tcnSegRows[kk,1];
+ rowEnd <- tcnSegRows[kk,2];
+
+ # Empty segment or a segment separator?
+ isEmptySegment <- (is.na(rowStart) && is.na(rowEnd));
+
+ # Nothing to do?
+ if (isEmptySegment) {
+ verbose && exit(verbose);
+ next;
+ }
+
+ nbrOfTCNLociKK <- tcnSegments[kk,"tcnNbrOfLoci"];
+ verbose && cat(verbose, "Number of TCN loci in segment: ", nbrOfTCNLociKK);
+ rows <- seq(from=rowStart, length=nbrOfTCNLociKK);
+ dataKK <- data[rows,,drop=FALSE];
+ nbrOfLociKK <- nrow(dataKK);
+
+ verbose && cat(verbose, "Locus data for TCN segment:");
+ verbose && str(verbose, dataKK);
+
+ verbose && cat(verbose, "Number of loci: ", nbrOfLociKK);
+ hasDH <- !is.null(dataKK$rho)
+ if (hasDH) {
+ isSnpKK <- !is.na(dataKK$rho)
+ isHetsKK <- (isSnpKK & (dataKK$rho > 0))
+ } else {
+ isSnpKK <- !is.na(dataKK$muN)
+ isHetsKK <- (isSnpKK & (dataKK$muN == 1/2))
+ }
+ nbrOfSnpsKK <- sum(isSnpKK)
+ nbrOfHetsKK <- sum(isHetsKK)
+ verbose && printf(verbose, "Number of SNPs: %d (%.2f%%)\n",
+ nbrOfSnpsKK, 100*nbrOfSnpsKK/nbrOfLociKK);
+
+ verbose && printf(verbose, "Number of heterozygous SNPs: %d (%.2f%%)\n",
+ nbrOfHetsKK, 100*nbrOfHetsKK/nbrOfSnpsKK);
+
+ segs[kk,"tcnNbrOfSNPs"] <- nbrOfSnpsKK;
+ segs[kk,"tcnNbrOfHets"] <- nbrOfHetsKK;
+ segs[kk,"dhNbrOfLoci"] <- nbrOfHetsKK;
+
+ # Adjust 'dhRows[kk,]'
+ rows <- rows[isHetsKK];
+ rows <- range(rows, na.rm=TRUE);
+ dhSegRows[kk,] <- rows;
+
+ # Sanity check
+ if (nbrOfHetsKK > 0) {
+ stopifnot(all(dhSegRows[kk,1] <= dhSegRows[kk,2], na.rm=TRUE));
+ }
+
+ # Calculate dhMean
+ rhoKK <- dataKK[["rho"]][isHetsKK];
+ segs[kk,"dhMean"] <- mean(rhoKK, na.rm=TRUE);
+
+ verbose && exit(verbose);
+ } # for (kk ...)
+
+ # Reorder segmentation columns
+ keys <- c("tcnId", "dhId", colnames(tcnSegments));
+ keys <- c(keys, setdiff(colnames(segs), keys));
+ segs <- segs[,keys];
+
+ verbose && exit(verbose);
+ } else {
+ dhSegRows <- NULL;
+ tcnSegsExpanded <- NULL;
+
+ # For each TCN segment...
+ segs <- vector("list", length=nbrOfSegs);
+ for (kk in seq(length=nbrOfSegs)) {
+ tcnId <- kk;
+
+ xStart <- tcnSegments[kk,"tcnStart"];
+ xEnd <- tcnSegments[kk,"tcnEnd"];
+ regionTag <- sprintf("[%10g,%10g]", xStart, xEnd);
+ verbose && enter(verbose, sprintf("Total CN segment #%d (%s) of %d", kk, regionTag, nbrOfSegs));
+
+ # Empty segment?
+ rowStart <- tcnSegRows[kk,1];
+ rowEnd <- tcnSegRows[kk,2];
+
+ # Empty segment or a segment separator?
+ isEmptySegment <- (is.na(rowStart) && is.na(rowEnd));
+ isSplitter <- (isEmptySegment && is.na(xStart) && is.na(xEnd));
+ isEmptySegment <- (isEmptySegment & !isSplitter);
+
+ if (isSplitter) {
+ verbose && cat(verbose, "No signals to segment. Just a \"splitter\" segment. Skipping.");
+
+ # Sanity check
+ stopifnot(kk >= 1);
+
+ # Add a splitter segment
+ segT <- segs[[kk-1]];
+ segT <- segT[NA_integer_,];
+ keys <- colnames(tcnSegments);
+ segT[,keys] <- tcnSegments[kk,keys];
+ segT[,"tcnId"] <- tcnId;
+ segT[,"dhId"] <- 1L;
+ segT[,c("tcnNbrOfSNPs", "tcnNbrOfHets", "dhNbrOfLoci")] <- 0L;
+ segT[,"dhStart"] <- xStart;
+ segT[,"dhEnd"] <- xEnd;
+ segs[[kk]] <- segT;
+ verbose && print(verbose, segT);
+
+ # Add a splitter to TCN and DH segment row matrix
+ segRowsT <- dhSegRows[NA_integer_,];
+ dhSegRows <- rbind(dhSegRows, segRowsT);
+
+ segRowsT <- tcnSegsExpanded[NA_integer_,];
+ tcnSegsExpanded <- rbind(tcnSegsExpanded, segRowsT);
+
+ verbose && exit(verbose);
+ next;
+ } # if (isSplitter)
+
+
+ nbrOfTCNLociKK <- tcnSegments[kk,"tcnNbrOfLoci"];
+ verbose && cat(verbose, "Number of TCN loci in segment: ", nbrOfTCNLociKK);
+
+ # Sanity check
+ stopifnot(!isEmptySegment || (isEmptySegment && (nbrOfTCNLociKK == 0)));
+
+ if (nbrOfTCNLociKK > 0) {
+ # Extract locus data for TCN segment
+ rows <- rowStart:rowEnd;
+ ## if (nrow(knownSegments) == 0) {
+ ## gammaT <- tcnSegments[kk,"tcnMean"];
+ ## verbose && print(verbose, all.equal(mean(dataKK$CT, na.rm=TRUE), gammaT, tolerance=tol));
+ ## stopifnot(all.equal(mean(dataKK$CT, na.rm=TRUE), gammaT, tolerance=tol));
+ ## }
+ } else {
+ rows <- integer(0);
+ } # if (nbrOfTCNLociKK > 0)
+
+ dataKK <- data[rows,,drop=FALSE];
+ nbrOfLociKK <- nrow(dataKK);
+
+ # Sanity check
+ stopifnot(length(dataKK$CT) == nbrOfTCNLociKK);
+ ## stopifnot(sum(!is.na(dataKK$CT)) == nbrOfTCNLociKK);
+
+ verbose && cat(verbose, "Locus data for TCN segment:");
+ verbose && str(verbose, dataKK);
+
+ verbose && cat(verbose, "Number of loci: ", nbrOfLociKK);
+
+ hasDH <- !is.null(dataKK$rho)
+ if (hasDH) {
+ isSnpKK <- !is.na(dataKK$rho)
+ isHetsKK <- (isSnpKK & (dataKK$rho > 0))
+ } else {
+ isSnpKK <- !is.na(dataKK$muN)
+ isHetsKK <- (isSnpKK & (dataKK$muN == 1/2))
+ }
+ nbrOfSnpsKK <- sum(isSnpKK)
+ nbrOfHetsKK <- sum(isHetsKK)
+ verbose && printf(verbose, "Number of SNPs: %d (%.2f%%)\n",
+ nbrOfSnpsKK, 100*nbrOfSnpsKK/nbrOfLociKK);
+ verbose && printf(verbose, "Number of heterozygous SNPs: %d (%.2f%%)\n",
+ nbrOfHetsKK, 100*nbrOfHetsKK/nbrOfSnpsKK);
+
+ # Since segments in 'knownSegments' has already been used in the TCN
+ # segmentation, they are not needed in the DH segmentation.
+ currChromosome <- data$chromosome[1];
+ verbose && cat(verbose, "Chromosome: ", currChromosome);
+ knownSegmentsT <- data.frame(chromosome=currChromosome, start=xStart, end=xEnd);
+
+ verbose && enter(verbose, "Segmenting DH signals");
+ fields <- attachLocally(dataKK, fields=c("chromosome", "x", "rho", "index"));
+
+ fit <- segmentByCBS(rho,
+ chromosome=chromosome, x=x,
+ joinSegments=joinSegments,
+ knownSegments=knownSegmentsT,
+ alpha=alphaDH, undo=undoDH, ...,
+ seed=seeds[["DH"]],
+ verbose=verbose);
+ verbose && str(verbose, fit);
+ dhSegments <- fit$output;
+ dhSegRowsKK <- fit$segRows;
+
+ verbose && cat(verbose, "DH segmentation (locally-indexed) rows:");
+ verbose && print(verbose, dhSegRowsKK);
+ verbose && str(verbose, index);
+
+ # Remap to genome-wide indices
+ for (cc in 1:2) {
+ dhSegRowsKK[,cc] <- index[dhSegRowsKK[,cc]];
+ }
+
+ verbose && cat(verbose, "DH segmentation rows:");
+ verbose && print(verbose, dhSegRowsKK);
+
+ # Not needed anymore
+ rm(list=fields);
+ fit <- NULL;
+ verbose && exit(verbose);
+
+ # Drop dummy columns
+ keep <- setdiff(colnames(dhSegments), c("sampleName", "chromosome"));
+ dhSegments <- dhSegments[,keep,drop=FALSE];
+
+ # Tag fields by DH
+ names <- names(dhSegments);
+ # Adding 'dh' prefix to column names
+ names <- sprintf("dh%s", capitalize(names));
+ names(dhSegments) <- names;
+
+ # Special case: If there where not enough data to segment DH...
+ if (nrow(dhSegments) == 0) {
+ dhSegments <- dhSegments[NA_integer_,,drop=FALSE];
+ dhSegRowsKK <- dhSegRowsKK[NA_integer_,,drop=FALSE];
+ }
+
+ verbose && cat(verbose, "DH segmentation table:");
+ verbose && print(verbose, dhSegments);
+ verbose && print(verbose, dhSegRowsKK);
+
+ # Expand the TCN segmentation result data frame
+ rows <- rep(kk, times=nrow(dhSegments));
+ verbose && cat(verbose, "Rows:");
+ verbose && print(verbose, rows);
+ tcnSegmentsKK <- tcnSegments[rows,,drop=FALSE];
+ tcnSegRowsKK <- tcnSegRows[rows,,drop=FALSE];
+ # Sanity check
+ stopifnot(nrow(tcnSegmentsKK) == nrow(dhSegments));
+ stopifnot(nrow(tcnSegRowsKK) == nrow(dhSegments));
+ stopifnot(is.na(tcnSegRowsKK[,1]) || is.na(dhSegRowsKK[,1]) || (tcnSegRowsKK[,1] <= dhSegRowsKK[,1]));
+ stopifnot(is.na(tcnSegRowsKK[,2]) || is.na(dhSegRowsKK[,2]) || (dhSegRowsKK[,2] <= tcnSegRowsKK[,2]));
+ verbose && cat(verbose, "TCN segmentation rows:");
+ verbose && print(verbose, tcnSegRowsKK);
+ stopifnot(all(tcnSegRowsKK[,1] == tcnSegRowsKK[1,1], na.rm=TRUE));
+ stopifnot(all(tcnSegRowsKK[,2] == tcnSegRowsKK[1,2], na.rm=TRUE));
+
+ verbose && cat(verbose, "TCN and DH segmentation rows:");
+ verbose && print(verbose, tcnSegRowsKK);
+ verbose && print(verbose, dhSegRowsKK);
+ verbose && print(verbose, tcnSegsExpanded);
+
+ # Append
+ tcnSegsExpanded <- rbind(tcnSegsExpanded, tcnSegRowsKK);
+ verbose && cat(verbose, "TCN segmentation (expanded) rows:");
+ verbose && print(verbose, tcnSegsExpanded);
+ rownames(tcnSegsExpanded) <- NULL;
+
+ dhSegRows <- rbind(dhSegRows, dhSegRowsKK);
+ rownames(dhSegRows) <- NULL;
+
+ verbose && cat(verbose, "TCN and DH segmentation rows:");
+ verbose && print(verbose, tcnSegRows);
+ verbose && print(verbose, dhSegRows);
+ verbose && print(verbose, tcnSegsExpanded);
+
+ # Sanity checks
+ stopifnot(all(tcnSegRows[,1] <= tcnSegRows[,2], na.rm=TRUE));
+ stopifnot(all(tcnSegRows[-nrow(tcnSegRows),2] < tcnSegRows[-1,1], na.rm=TRUE));
+ stopifnot(all(dhSegRows[,1] <= dhSegRows[,2], na.rm=TRUE));
+ stopifnot(all(dhSegRows[-nrow(dhSegRows),2] < dhSegRows[-1,1], na.rm=TRUE));
+ stopifnot(all(tcnSegsExpanded[,1] <= tcnSegsExpanded[,2], na.rm=TRUE));
+ stopifnot(all(tcnSegsExpanded[,1] <= dhSegRows[,1], na.rm=TRUE));
+ stopifnot(all(tcnSegsExpanded[,2] >= dhSegRows[,2], na.rm=TRUE));
+ ## if (!all(tcnSegsExpanded[-nrow(tcnSegsExpanded),2] < tcnSegsExpanded[-1,1], na.rm=TRUE)) {
+ ## stopifnot(all(tcnSegsExpanded[-nrow(tcnSegsExpanded),2] < tcnSegsExpanded[-1,1], na.rm=TRUE));
+ ## }
+
+
+ # Sanity check
+ stopifnot(nrow(dhSegRows) == nrow(tcnSegsExpanded));
+
+ # Append information on number of SNPs and hets in CN region
+ tcnSegmentsKK <- cbind(
+ tcnSegmentsKK,
+ tcnNbrOfSNPs=nbrOfSnpsKK,
+ tcnNbrOfHets=nbrOfHetsKK
+ );
+ verbose && cat(verbose, "Total CN segmentation table (expanded):");
+ verbose && print(verbose, tcnSegmentsKK);
+
+ # Sanity check
+ stopifnot(nrow(tcnSegmentsKK) == nrow(dhSegments));
+
+ # Combine TCN and DH segmentation results
+ tcndhSegments <- cbind(
+ tcnId=rep(kk, times=nrow(dhSegments)),
+ dhId=seq(length=nrow(dhSegments)),
+ tcnSegmentsKK,
+ dhSegments
+ );
+
+ segs[[kk]] <- tcndhSegments;
+
+ verbose && cat(verbose, "(TCN,DH) segmentation for one total CN segment:");
+ verbose && print(verbose, segs[[kk]]);
+
+ verbose && exit(verbose);
+ } # for (kk ...)
+
+ segs <- Reduce(rbind, segs);
+ rownames(segs) <- NULL;
+ } # if (flavor == "tcn")
+
+ # Sanity check
+ stopifnot(nrow(dhSegRows) == nrow(tcnSegsExpanded));
+ rownames(tcnSegRows) <- rownames(dhSegRows) <- NULL;
+
+ stopifnot(all(tcnSegRows[,1] <= tcnSegRows[,2], na.rm=TRUE));
+ stopifnot(all(tcnSegRows[-nrow(tcnSegRows),2] < tcnSegRows[-1,1], na.rm=TRUE));
+ if (flavor != "tcn") {
+ stopifnot(all(dhSegRows[,1] <= dhSegRows[,2], na.rm=TRUE));
+ }
+ stopifnot(all(dhSegRows[-nrow(dhSegRows),2] < dhSegRows[-1,1], na.rm=TRUE));
+ stopifnot(all(tcnSegsExpanded[,1] <= tcnSegsExpanded[,2], na.rm=TRUE));
+## stopifnot(all(tcnSegsExpanded[-nrow(tcnSegsExpanded),2] < tcnSegsExpanded[-1,1], na.rm=TRUE));
+
+ # Move 'chromosome' column to the first column
+ idx <- match("chromosome", names(segs));
+ idxs <- c(idx, seq(length=ncol(segs))[-idx]);
+ segs <- segs[,idxs,drop=FALSE];
+ verbose && print(verbose, segs);
+
+ verbose && enter(verbose, "Calculating (C1,C2) per segment");
+ # Append (C1,C2) estimates
+ tcn <- segs$tcnMean;
+ dh <- segs$dhMean;
+ C1 <- 1/2*(1-dh)*tcn;
+ C2 <- tcn - C1;
+ segs <- cbind(segs, c1Mean=C1, c2Mean=C2);
+ verbose && exit(verbose);
+
+ nbrOfSegs <- nrow(segs);
+ verbose && cat(verbose, "Number of segments: ", nbrOfSegs);
+
+ verbose && exit(verbose);
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Create result object
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ params <- list(
+ alphaTCN = alphaTCN,
+ alphaDH = alphaDH,
+ flavor = flavor,
+ tbn = tbn,
+ joinSegments = joinSegments,
+ knownSegments = knownSegments,
+ seed = seed
+ );
+
+ # Should we drop attributes? /HB 2010-09-24
+ stopifnot(all(data$index == seq(length=nrow(data))));
+ data$index <- NULL; # Drop, because it is guaranteed to be ordered
+ class(data) <- c("PairedPSCNData", class(data));
+
+ class(segs) <- c("PairedPSCNSegments", class(segs));
+
+ fit <- list(
+ data = data,
+ output = segs,
+ tcnSegRows = tcnSegsExpanded,
+ dhSegRows = dhSegRows,
+ params = params
+ );
+
+ class(fit) <- c("PairedPSCBS", "PSCBS", "AbstractCBS");
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Update?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (avgTCN != "mean" || avgDH != "mean") {
+ verbose && enter(verbose, "Updating mean level using different estimator");
+ verbose && cat(verbose, "TCN estimator: ", avgTCN);
+ verbose && cat(verbose, "DH estimator: ", avgDH);
+ fit <- updateMeans(fit, avgTCN=avgTCN, avgDH=avgDH, verbose=less(verbose, 20));
+ verbose && exit(verbose);
+ }
+
+ if (is.element(flavor, c("tcn&dh", "sqrt(tcn)&dh"))) {
+ fit$params$flavor <- gsub("&", ",", flavor, fixed=TRUE); # AD HOC.
+ fit <- postsegmentTCN(fit, verbose=verbose);
+
+ # Sanity check
+ CT <- fit$data$CT;
+ tcnSegRows <- fit$tcnSegRows;
+ dhSegRows <- fit$dhSegRows;
+ for (jj in 1:nrow(tcnSegRows)) {
+ tcnSegRowJJ <- unlist(tcnSegRows[jj,,drop=TRUE], use.names=FALSE);
+ dhSegRowJJ <- unlist(dhSegRows[jj,,drop=TRUE], use.names=FALSE);
+ stopifnot(
+ is.na(tcnSegRowJJ[1]) || is.na(dhSegRowJJ[1]) ||
+ # A TCN segment must start at or before a DH segment...
+ (tcnSegRowJJ[1] <= dhSegRowJJ[1]) ||
+ # ...unless there was an outlier at the left edge.
+ (is.na(CT[dhSegRowJJ[1]]) && (tcnSegRowJJ[1] - 1L <= dhSegRowJJ[1]))
+ );
+ stopifnot(
+ is.na(tcnSegRowJJ[2]) || is.na(dhSegRowJJ[2]) ||
+ # A TCN segment must end at or after a DH segment...
+ (dhSegRowJJ[2] <= tcnSegRowJJ[2]) ||
+ # ...unless there was an outlier at the right edge.
+ (is.na(CT[dhSegRowJJ[2]]) && (dhSegRowJJ[2] <= tcnSegRowJJ[2] + 1L))
+ );
+ } # for (jj ...)
+ # Not needed anymore
+ CT <- tcnSegRows <- dhSegRows <- NULL;
+ }
+
+ verbose && print(verbose, head(as.data.frame(fit)));
+ verbose && print(verbose, tail(as.data.frame(fit)));
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Return results
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ fit;
+}) # segmentByPairedPSCBS()
+
+
+
+setMethodS3("segmentByPairedPSCBS", "data.frame", function(CT, ...) {
+ # To please R CMD check
+ data <- CT;
+
+ segmentByPairedPSCBS(CT=data$CT, thetaT=data$thetaT, thetaN=data$thetaN,
+ betaT=data$betaT, betaN=data$betaN,
+ muN=data$muN, rho=data$rho,
+ chromosome=data$chromosome, x=data$x, ...);
+})
+
+
+
+setMethodS3("segmentByPairedPSCBS", "PairedPSCBS", function(...) {
+ resegment(...);
+}) # segmentByPairedPSCBS()
+
+
+
+############################################################################
+# HISTORY:
+# 2014-06-08
+# o Now segmentByPairedPSCBS() gives a warning about future change of the
+# default value of argument 'preserveScale' (from current TRUE to FALSE).
+# The warning only appears if the argument is not specified explicitly.
+# 2014-03-30
+# o As an alternative to argument 'CT', segmentByPairedPSCBS() now accepts
+# arguments 'thetaT' and 'thetaN', in case 'CT' is calculated as
+# CT=2*thetaT/thetaN (and all of 'CT', 'thetaT' and 'thetaN' are stored
+# as part the locus-level data signals.
+# 2014-01-29
+# o ROBUSTNESS: Now segmentByPairedPSCBS() asserts that argument 'muN'
+# is not all NAs. Similarily, if 'muN' is called from 'betaN' the
+# same assertion is done after calling.
+# 2013-02-01
+# o BUG FIX: segmentByPairedPSCBS(..., avgDH="median") only worked for
+# single-chromosome data. Same for avgTCN="median".
+# 2013-01-16
+# o Added arguments 'avgTCN' and 'avgDH' to segmentByPairedPSCBS().
+# 2012-09-15
+# o Added argument 'dropMissingCT' to segmentByPairedPSCBS().
+# 2012-09-13
+# o CONSISTENCY FIX: Changed the behavior of extreme values of argument
+# 'undoTCN' and 'undoDH' to segmentByPairedPSCBS() such that it is
+# consistent with the new rules for 'undo' of segmentByCBS().
+# 2012-07-22
+# o GENERALIZATION/BUG FIX: Now segmentByPairedPSCBS() drops loci for
+# which CT is missing (regardless of betaT). For instance, in rare cases
+# when the reference (e.g. the normal) is missing, then it may be that
+# CT is missing while betaT is not.
+# o Now the verbose output in segmentByPairedPSCBS() specifies the range
+# of segments with greater precision.
+# 2012-04-20
+# o Now it is possible to skip the DH segmentation in Paired PSCBS, i.e.
+# segmentByPairedPSCBS(..., flavor="tcn").
+# o BUG FIX: segmentByPairedPSCBS() would throw "error in `$<-.data.frame
+# `(`*tmp*`, "rho" ..." if some loci points has unknown genomic positions.
+# 2011-11-19
+# o GENERALIZATION: Now it is possible to run Paired PSCBS (without
+# TumorBoost) when only genotypes but not BAFs are available for the
+# matched normal.
+# 2011-11-17
+# o ROBUSTNESS: Now all internal iterative calls to segmentByPairedPSCBS()
+# and segmentByCBS() have an explicit seed=NULL.
+# o BUG FIX: Now 'tbn' argument is correctly preserved in the stored
+# parameter settings of segmentByPairedPSCBS().
+# o BUG FIX: segmentByPairedPSCBS() would give an error when trying to
+# segment DH if the TCN segment contains no data points, which could
+# happen if 'knownSegments' specifies an empty segment, centromere.
+# o Added segmentByPairedPSCBS() for PairedPSCBS, which is just a
+# wrapper for resegment().
+# 2011-10-21
+# o Now segmentByPairedCBS() handles forced separators in 'knownSegments'.
+# 2011-10-20
+# o CLEANUP: Dropped a stray debug output message in segmentByPairedPSCBS().
+# o Replaced argument 'knownCPs' with 'knownSegments' for segmentByCBS().
+# 2011-10-02
+# o Added segmentByPairedPSCBS() for data.frame such that the locus-level
+# data arguments can also be passed via a data.frame.
+# 2011-09-04
+# o ROBUSTNESS: Added drop=FALSE to matrix subsettings.
+# o CLEANUP: Removed all references to/usage of DNAcopy fields, which
+# are no longer part of the CBS class.
+# 2011-09-03
+# o Updated code to not use deprecated argument 'columnNamesFlavor'
+# of segmentByCBS().
+# 2011-08-08
+# o BUG FIX: If dropSegmentationOutliers() would drop an outlier next to
+# a change point, such that total copy-number signal would become NA,
+# then the sanity checks that TCN segments always overlaps DH segments
+# would fail. Now the sanity checks are aware of this special case.
+# o Moved the sanity checks that tests the TCN and DH "segRows" from the
+# bootstrapTCNandDHByRegion() to segmentByPairedPSCBS(). This is the
+# first step to fix a failure in the sanity checks that could happend
+# iff one first run dropSegmentationOutliers().
+# 2011-07-15
+# o DOCUMENTATION: Added a section to help("segmentByPairedPSCBS") on
+# the importance of doing a whole-genome PSCBS segmentations if
+# calling AB and LOH states afterward.
+# 2011-07-14
+# o DOCUMENTATION: Added to the help that arguments betaT, betaN and muN
+# may contain NAs for non-polymorphic loci.
+# o BUG FIX/ROBUSTNESS: In some cases, the segmentation table would
+# contain column names with incorrect capitalization, e.g. "tcnnbrOfLoci"
+# instead of "tcnNbrOfLoci". This would cause several downstream
+# methods to give an error. The reason for this is that the Hmisc
+# package, if loaded after R.utils, overrides capitalize() in R.utils
+# with another (buggy?) capitalize() function. To avoid this, we
+# now everywhere specify explicitly that we want to the one in R.utils.
+# 2011-07-06
+# o DOCUMENTATION: The description of argument 'chromosome' for
+# segmentByPairedPSCBS() did not describe how to segment multiple
+# chromosomes in one call.
+# 2011-07-05
+# o BUG FIX: Output fields 'tcnNbrOfSNPs'and 'tcnNbrOfHets' were mistakenly
+# labelled as 'tcnNbrOr...'. Thanks Christine Ho at UC Berkeley for
+# reporting on this.
+# 2011-06-28
+# o DOCUMENTATION: Clarified that argument 'CT' should be tumor copy
+# number ratios relative to the normal.
+# 2011-06-14
+# o CONVENTION: Changed the column names of returned data frames.
+# They now follow the camelCase naming convention and are shorter.
+# 2011-05-29
+# o Renamed options to reflect new package name.
+# 2011-04-07
+# o ROBUSTNESS: Added validation of the different 'tcnSegRows' and
+# 'dhSegRows' calculations in segmentByPairedPSCBS(). This helps
+# us narrow down a bug in postsegmentTCN().
+# 2010-12-09
+# o BUG FIX: When there were multiple chromsomes processed by
+# segmentByPairedPSCBS(), then the returned data object would
+# contain 'betaT' identical to 'betaTN'.
+# 2010-12-02
+# o Now segmentByPairedPSCBS() uses option "psCBS/sanityChecks/tolerance".
+# 2010-11-30
+# o Now segmentByPairedPSCBS() returns data frames 'tcnLociToExclude'
+# and 'dhLociToExclude'.
+# o BUG FIX: Argument 'flavor' of segmentByPairedPSCBS() would be ignored
+# if multiple chromsomomes were segmented.
+# 2010-11-28
+# o BUG FIX: Iff argument 'chromosome' to segmentByPairedPSCBS() was of
+# length greater than one and specified exactly one unique chromosome,
+# then exception "Number of elements in argument 'chromosome' should
+# be exactly 8712 not 86209 value(s)" would be thrown.
+# 2010-11-27
+# o BUG FIX: segmentByPairedPSCBS() would not accept missing values in
+# argument 'chromosome'.
+# o Now arguments '...' of segmentByPairedPSCBS() are passed to
+# the two segmentByCBS() calls.
+# 2010-11-22
+# o BUG FIX: segmentByPairedPSCBS() would not subset the correct set of
+# DH signals if there were some missing values in TCN.
+# 2010-11-21
+# o Changed the default to flavor="tch&dh".
+# o Added support for flavors "tcn&dh", which, contrary to "tcn,dh",
+# enforces TCN and DH to have the same change points.
+# o Now segmentByPairedPSCBS() also returns minor and major copy numbers
+# for each segment.
+# o Forgot to return arguments 'joinSegments' & 'knownCPs' in 'params'.
+# 2010-11-20
+# o Now it is possible to specify the boundaries of the regions to be
+# segmented as known change points via argument 'knownCPs'.
+# o Added argument 'joinSegments' to segmentByPairedPSCBS() in order to
+# specify if neighboring segments should be joined or not.
+# o Now segmentByCBS() allows for unknown genomic positions.
+# o Now segmentByCBS() allows also for missing total CN signals.
+# 2010-11-16
+# o BUG FIX: In the rare cases where two loci at the same positions are
+# split up into two neighboring segments, then segmentByPairedPSCBS()
+# would fail to infer which they were if and only if the loci were not
+# ordered along the genome. This could happen with for instance
+# Affymetrix GenomeWideSNP_6 data.
+# o DOCUMENTATION: Clarified the form of argument 'muN', and added
+# references to papers and cross links to more internal methods.
+# 2010-11-04
+# o BUG FIX: There was a stray/debug stop() statement left in
+# segmentByPairedPSCBS() causing an "error" in the rare case
+# when loci that have the same physical locations are split
+# into two different segments.
+# 2010-11-02
+# o Added arguments 'undoTCN' and 'undoDH' to segmentByPairedPSCBS().
+# o BUG FIX: Arguments 'alphaTCN' and 'alphaDH' of segmentByPairedPSCBS()
+# were not used when more than one chromosome were segmented.
+# 2010-10-25
+# o BUG FIX: Now the correct set of loci are extracted from each TCN
+# segment, in the rare case that two neighboring TCN segments have
+# the same end points.
+# 2010-10-18
+# o Added arguments 'alphaTCN' and 'alphaDH' to segmentByPairedPSCBS().
+# o Now segmentByPairedPSCBS() can segment multiple chromosomes.
+# 2010-10-17
+# o Added argument 'tbn' to segmentByPairedPSCBS() specifying whether
+# TumorBoostNormalization should be applied or not.
+# 2010-10-10
+# o The default is now to segment TCN on the original scale, not the sqrt().
+# o Added flavor "sqrt(tcn),dh", which is segments sqrt(TCN) and then DH,
+# as original proposed by ABO.
+# 2010-10-03
+# o CLEAN UP: Now segmentByPairedPSCBS() is making use of argument
+# 'chromosome' of segmentByCBS().
+# 2010-10-02
+# o Argument 'chromosome' default to 0 and have to be a finite integer.
+# 2010-09-24
+# o Now the 'data' field returned is a data.frame (no longer a list).
+# o Now the 'chromosome' field of the data field is expanded to have the
+# same number of elements as the other locus fields.
+# 2010-09-18
+# o Added argument 'chromosome' to segmentByPairedPSCBS(), which, if given,
+# adds a chromosome column to the data and segmentation results.
+# 2010-09-08
+# o Now segmentByPairedPSCBS() also returns the TumorBoost normalized data.
+# This also means that plot() for PairedPSCBS no longer has to
+# recalculate them.
+# 2010-09-04
+# o Added drawLevels() for PairedPSCBS.
+# o Added as.data.frame() and print() for PairedPSCBS.
+# 2010-09-03
+# o Added plot().
+# 2010-07-09
+# o The segmentByPairedPSCBS() method was written completely from scratch.
+# o Created.
+############################################################################
diff --git a/R/testROH.R b/R/testROH.R
new file mode 100644
index 0000000..0df10a7
--- /dev/null
+++ b/R/testROH.R
@@ -0,0 +1,170 @@
+###########################################################################/**
+# @set "class=numeric"
+# @RdocMethod testROH
+#
+# @title "Tests if a segment is in Run-of-Homozygosity (ROH)"
+#
+# \description{
+# @get "title".
+# }
+#
+# @synopsis
+#
+# \arguments{
+# \item{muN}{An @numeric @vector of J genotype calls in
+# \{0,1/2,1\} for AA, AB, and BB, respectively,
+# and @NA for non-polymorphic loci.}
+# \item{csN}{(optional) A @numeric @vector of J genotype confidence scores.
+# If @NULL, ad hoc scores calculated from \code{betaN} are used.}
+# \item{betaN}{(optional) A @numeric @vector of J matched normal BAFs
+# in [0,1] (due to noise, values may be slightly outside as well)
+# or @NA for non-polymorphic loci.}
+# \item{minNbrOfSnps}{Minimum number of SNPs required to test segment.
+# If not tested, @NA is returned.}
+# \item{delta}{A @double scalar specifying the maximum (weighted)
+# proportion of heterozygous SNPs allowed in an ROH region.}
+# \item{...}{Not used.}
+# \item{verbose}{See @see "R.utils::Verbose".}
+# }
+#
+# \value{
+# Returns a @logical.
+# }
+#
+# @author "PN, HB"
+#
+# @keyword internal
+#*/###########################################################################
+setMethodS3("testROH", "numeric", function(muN, csN=NULL, betaN=NULL, minNbrOfSnps=1, delta=1/12, ..., verbose=FALSE) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'muN':
+ muN <- Arguments$getDoubles(muN, range=c(0,1));
+ nbrOfSnps <- length(muN);
+ length2 <- rep(nbrOfSnps, times=2);
+
+ # Argument 'csN' & 'betaN':
+ if (!is.null(csN)) {
+ csN <- Arguments$getDoubles(csN, range=c(0,1), length=length2);
+ } else {
+ if (!is.null(betaN)) {
+ betaN <- Arguments$getDoubles(betaN, length=length2);
+ }
+ }
+
+ # Argument 'minNbrOfSnps':
+ minNbrOfSnps <- Arguments$getInteger(minNbrOfSnps, range=c(1,Inf));
+
+ # Argument 'verbose':
+ verbose <- Arguments$getVerbose(verbose);
+ if (verbose) {
+ pushState(verbose);
+ on.exit(popState(verbose));
+ }
+
+
+ verbose && enter(verbose, "Testing for ROH");
+
+ # Default ROH call
+ call <- NA;
+
+ verbose && cat(verbose, "Number of SNPs: ", nbrOfSnps);
+
+ # Nothing todo?
+ if (nbrOfSnps < minNbrOfSnps) {
+ verbose && exit(verbose);
+ return(call);
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Calculate genotype confidence scores (from betaN)?
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if (is.null(csN)) {
+ if (!is.null(betaN)) {
+ verbose && enter(verbose, "Calculating confidence scores");
+ # Assuming naive genotyping a'la aroma.light::callNaiveGenotypes()
+ # was used to call genotypes 'muN' from 'betaN'.
+
+ # AD HOC: We also have to assume that the thresholds were 1/3 and 2/3.
+ a <- 1/3; # was fit$x[1];
+ b <- 2/3; # was fit$x[2];
+
+ # AD HOC: We have to make some assumption about which SNPs are diploid.
+ # Assume all for now
+ isDiploid <- rep(TRUE, times=nbrOfSnps);
+
+ # KNOWN ISSUE: Scores for homozygotes are in [0,1/3], whereas
+ # heterzygotes are in [0,1/6]. /PN 2011-11-11
+ csN[isDiploid] <- rowMins(abs(cbind(betaN[isDiploid]-a, betaN[isDiploid]-b)));
+ verbose && exit(verbose);
+ }
+ }
+
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Call ROH
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Identify heterozygous SNPs
+ isHet <- (muN == 1/2);
+ verbose && print(verbose, summary(isHet));
+
+ # With or without genotype confidence scores?
+ if (!is.null(csN)) {
+ # 0-1 weights (just to make sure)
+ # Weights summing to one
+ w <- csN / sum(csN, na.rm=TRUE);
+
+ wnHets <- sum(isHet*w, na.rm=TRUE);
+ wnSnps <- sum(w, na.rm=TRUE); # == 1 /HB
+
+ # Sanity check
+ stopifnot(isZero(wnSnps - 1.0, eps=sqrt(.Machine$double.eps)));
+ } else {
+ wnHets <- sum(isHet, na.rm=TRUE);
+ wnSnps <- 1;
+ }
+
+ propHets <- wnHets/wnSnps;
+ verbose && print(verbose, propHets);
+
+ call <- (propHets < delta);
+ verbose && print(verbose, call);
+
+ # Record parameter settings
+ attr(call, "minNbrOfSnps") <- minNbrOfSnps;
+ attr(call, "delta") <- delta;
+
+ verbose && exit(verbose);
+
+ call;
+}) # testROH()
+
+
+##############################################################################
+# HISTORY
+# 2014-03-30 [HB]
+# o GENERALIZATION: Now testROH() default to equal confidence scores
+# whenever neither 'csN' not 'betaN' is given. This means that
+# callROH() can also be done if only 'muN' was provided.
+# o Updated the ordering and the defaults of testROH() arguments to make
+# it clear that 'betaN' is optional and only used if 'csN' is not given.
+# 2013-03-08 [HB]
+# o Added Rdoc help.
+# 2012-05-30 [HB]
+# o Now testROH() return parameter settings as attributes.
+# 2011-11-21 [HB]
+# o BUG FIX: The internal sanity check on weights was slightly too
+# conservative.
+# 2011-11-12 [HB]
+# o Renamed argument 'tauROH' to 'delta', cf. how we do for AB and LOH.
+# o Added argument 'minNbrOfSnps' to testROH().
+# o Added verbose output.
+# 2011-11-12 [PN]
+# o Implemented a naive caller based on the weighted proportion of hets
+# in the segment.
+# 2011-11-04 [HB]
+# o Added skeleton for testROH().
+# o Created.
+##############################################################################
diff --git a/R/weightedQuantile.R b/R/weightedQuantile.R
new file mode 100644
index 0000000..e6cfdda
--- /dev/null
+++ b/R/weightedQuantile.R
@@ -0,0 +1,129 @@
+############################################################################/**
+# @RdocDefault weightedQuantile
+#
+# @title "Weighted Quantile Value"
+#
+# @synopsis
+#
+# \description{
+# Computes a weighted quantile of a numeric vector.
+# }
+#
+# \arguments{
+# \item{x}{a @numeric @vector containing the values whose weighted
+# quantile is to be computed.}
+# \item{w}{a numeric @vector of weights the same length as
+# \code{x} giving the weights to use for each element of \code{x}.
+# Negative weights are treated as zero weights.
+# Default value is equal weight to all values.}
+# \item{probs}{a @numeric @vector of quantiles in [0,1] to be retrieved.}
+# \item{na.rm}{a @logical value indicating whether @NA values in
+# \code{x} should be stripped before the computation proceeds,
+# or not.}
+# \item{method}{If \code{"wtd.quantile"}, then @see "Hmisc::wtd.quantile"
+# of the \pkg{Hmisc} package is used.
+# No other methods are currently supported.}
+# \item{...}{Additional arguments passed to the estimator.}
+# }
+#
+# \value{
+# Returns the weighted quantile.
+# }
+#
+# @author "HB"
+#
+# \seealso{
+# Internally the following functions may be used:
+# @see "stats::quantile" (if no weights are specified), or
+# @see "Hmisc::wtd.quantile".
+# For a weighted median estimator, @see "matrixStats::weightedMedian"
+# of the \pkg{matrixStats} package.
+# }
+#
+# @keyword univar
+# @keyword robust
+# @keyword internal
+#*/############################################################################
+setMethodS3("weightedQuantile", "default", function(x, w, probs=c(0, 0.25, 0.5, 0.75, 1), na.rm=TRUE, method=c("wtd.quantile"), ...) {
+ # Argument 'x':
+ x <- Arguments$getNumerics(x);
+
+ # Argument 'w':
+ if (missing(w)) {
+ # By default use weights that are one.
+ w <- rep(1, times=length(x));
+ } else {
+ w <- Arguments$getNumerics(w, range=c(0,Inf), length=rep(length(x), times=2L));
+ }
+
+ naValue <- NA;
+ storage.mode(naValue) <- storage.mode(x);
+
+ # Argument 'na.rm':
+ if (is.na(na.rm)) {
+ # There are no NAs
+ } else if (isTRUE(na.rm)) {
+ # Remove values that are NA's
+ tmp <- !(is.na(x) | is.na(w));
+ x <- .subset(x, tmp);
+ w <- .subset(w, tmp);
+ } else if (anyNA(x)) {
+ return(naValue);
+ }
+
+ # Argument 'method':
+ method <- match.arg(method);
+ if (method == "wtd.quantile") {
+ # This will load 'Hmisc', if not already done
+ wtd.quantile <- Hmisc::wtd.quantile;
+ }
+
+
+
+ # Remove values with zero (and negative) weight. This will:
+ # (1) take care of the case when all weights are zero,
+ # (2) it will most likely speed up the sorting.
+ n <- length(w);
+ tmp <- (w > 0);
+ if (!all(tmp)) {
+ x <- .subset(x, tmp);
+ w <- .subset(w, tmp);
+ n <- sum(tmp);
+ }
+
+ # Are there any values left to calculate the weighted median of?
+ if (n == 0) {
+ return(naValue);
+ } else if (n == 1) {
+ return(x);
+ }
+
+ # Are any weights Inf? Then treat them with equal weight and all others
+ # with weight zero. If they have equal weight, regular quantile
+ # can be used instead, which is assumed to be faster.
+ tmp <- is.infinite(w);
+ if (any(tmp)) {
+ x <- .subset(x, tmp);
+ # Here we know there are no NAs.
+ return(quantile(x, probs=probs, na.rm=FALSE, ...));
+ }
+
+ # Here we know that there are no missing values in the data
+ if (method == "wtd.quantile") {
+ wtd.quantile(x, weights=w, probs=probs, normwt=TRUE, na.rm=FALSE, ...);
+ } else {
+ throw("Cannot estimate weighted quantiles: Argument 'method' is unknown: ", method);
+ }
+}) # weightedQuantile()
+
+
+############################################################################
+# HISTORY:
+# 2013-09-26 [HB]
+# o CLEANUP: Now weightedQuantile(..., method=="wtd.quantile") no longer
+# attaches 'Hmisc', but only loads its namespace.
+# 2012-08-30
+# o Updated Rdoc cross reference for matrixStats to point to matrixStats.
+# 2011-04-08
+# o Created.
+############################################################################
diff --git a/R/writeWIG.R b/R/writeWIG.R
new file mode 100644
index 0000000..37e73ab
--- /dev/null
+++ b/R/writeWIG.R
@@ -0,0 +1,143 @@
+setMethodS3("extractWIG", "AbstractCBS", function(fit, signal, transform=NULL, nbrOfDecimals=4L, label=toupper(signal), graphType=c("bar", "points", "line"), viewLimits=NULL, colors=c(negative="231,41,138", positive="117,112,179"), ...) {
+ # Argument 'graphType':
+ graphType <- match.arg(graphType)
+
+ # Argument 'nbrOfDecimals':
+ nbrOfDecimals <- Arguments$getInteger(nbrOfDecimals);
+
+ data <- getSegments(fit, splitter=FALSE)
+ fields <- c("chromosome", "start", "end", "mean")
+ if (!is.null(signal)) {
+ fields[-1] <- sprintf("%s%s", signal, capitalize(fields[-1]))
+ }
+ data <- data[,fields]
+ colnames(data) <- c("chromosome", "start", "end", "mean")
+ data$chromosome <- sprintf("chr%d", data$chromosome)
+
+ ## Round / truncate
+ for (ff in c("start", "end")) {
+ data[[ff]] <- as.integer(round(data[[ff]], digits=0L))
+ }
+
+ # Transform mean levels?
+ if (!is.null(transform)) {
+ data[["mean"]] <- transform(data[["mean"]])
+ }
+
+ # Round mean levels
+ if (!is.null(nbrOfDecimals)) {
+ data[["mean"]] <- round(data[["mean"]], digits=nbrOfDecimals);
+ }
+
+ # Drop segments with missing values
+ data <- na.omit(data)
+
+ ## Track information
+ track <- list(
+ type="wiggle_0",
+ name=sampleName(fit),
+ description=sprintf("Data type: %s", class(fit)),
+ graphType=graphType,
+ visibility="full",
+ maxHeightPixels="128:96:64",
+ yLineOnOff="on",
+ autoScale="true"
+ )
+ if (is.na(track$name)) track$name <- "Unknown sample"
+ if (!is.null(signal)) track$name <- sprintf("%s [%s]", track$name, label)
+
+ if (!is.null(viewLimits)) {
+ track$viewLimits <- sprintf("%g:%g", viewLimits[1], viewLimits[2])
+ }
+
+ if (!is.null(colors)) {
+ if (!is.null(names(colors))) colors <- colors[c("negative", "positive")]
+ track$color <- colors[["negative"]]
+ track$altColor <- colors[["positive"]]
+ }
+
+ attr(data, "track") <- track
+
+ data
+}, protected=TRUE)
+
+
+
+setMethodS3("extractWIG", "CBS", function(fit, ..., colors=c(negative="231,41,138", positive="117,112,179")) {
+ NextMethod("extractWIG", signal=NULL, colors=colors)
+}, protected=TRUE)
+
+
+setMethodS3("extractWIG", "PSCBS", function(fit, signal=c("tcn", "dh"), ..., colors=c(negative="231,41,138", positive="117,112,179")) {
+ signal <- match.arg(signal)
+ NextMethod("extractWIG", signal=signal, colors=colors)
+}, protected=TRUE)
+
+
+# \references{
+# [1] Wiggle Track Format (WIG), UCSC Genome Browser
+# \url{http://genome.ucsc.edu/goldenPath/help/wiggle.html}
+# }
+setMethodS3("writeWIG", "AbstractCBS", function(fit, name=getSampleName(fit), tags=NULL, ext="wig", path=NULL, overwrite=FALSE, skip=FALSE, ...) {
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Validate arguments
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Argument 'name' and 'tags':
+ name <- Arguments$getCharacter(name);
+ tags <- Arguments$getCharacters(tags);
+
+ # Argument 'ext':
+ ext <- Arguments$getCharacter(ext);
+
+ # Arguments 'path':
+ path <- Arguments$getWritablePath(path);
+
+
+ fullname <- paste(c(name, tags), collapse=",");
+ filename <- sprintf("%s.%s", fullname, ext);
+ pathname <- Arguments$getWritablePathname(filename, path=path, mustNotExist=(!overwrite && !skip));
+
+ # File already exists?
+ if (isFile(pathname)) {
+ # Skip?
+ if (skip) {
+ return(pathname);
+ }
+
+ # Overwrite!
+ file.remove(pathname);
+ }
+
+ ## Write file (atomically)
+ pathnameT <- pushTemporaryFile(pathname)
+
+ bed <- extractWIG(fit, ...)
+
+ ## Generate 'track' definition line
+ track <- attr(bed, "track")
+ track <- lapply(track, FUN=function(value) {
+ if (is.character(value)) value <- dQuote(value)
+ value
+ })
+ track <- unlist(track, use.names=TRUE)
+ track <- sprintf("%s=%s", names(track), track)
+ track <- paste(track, collapse=" ")
+ track <- sprintf("track %s", track)
+
+
+ cat(track, "\n", sep="", file=pathnameT)
+ write.table(bed, file=pathnameT,
+ col.names=FALSE, row.names=FALSE, sep="\t", quote=FALSE,
+ append=TRUE)
+
+ pathname <- popTemporaryFile(pathnameT)
+
+ pathname
+})
+
+
+############################################################################
+# HISTORY:
+# 2015-09-08
+# o Added extractWIG() and writeWIG() for CBS objects.
+############################################################################
diff --git a/R/zzz.R b/R/zzz.R
new file mode 100644
index 0000000..bc1bef7
--- /dev/null
+++ b/R/zzz.R
@@ -0,0 +1,65 @@
+# This should ideally be added to 'R.utils' one day, e.g. as import().
+# /HB 2014-06-08
+.use <- function(name=NULL, package, ..., mode="function") {
+ # Attach package?
+ if (is.null(name)) {
+ use(package, ...);
+ return(invisible(NULL))
+ }
+
+ # Retrieve a particular function
+ use(package, ..., how="load");
+ ns <- getNamespace(package);
+ res <- get(name, mode=mode, envir=ns);
+
+ invisible(res);
+} # .use()
+
+
+.onLoad <- function(libname, pkgname) {
+ ## covr: skip=5
+ ns <- getNamespace(pkgname);
+ pkg <- Package(pkgname);
+ # Assign '.PSCBS' object [since 'PSCBS' is a constructor/Class].
+ name <- sprintf(".%s", pkgname);
+ assign(name, pkg, envir=ns, inherits=FALSE);
+} # .onLoad()
+
+
+.onAttach <- function(libname, pkgname) {
+ # Copy some pre-memoized CBS-parameter calculations to the 'R.cache'
+ # cache. This speeds up the calculation for common CBS use cases.
+ .prememoize();
+
+ # Inform user if DNAcopy is missing
+ if (!isPackageInstalled("DNAcopy")) {
+ msg <- "The Bioconductor package 'DNAcopy' is not installed. Please see http://www.bioconductor.org/ on how to install it, or try calling PSCBS::installDNAcopy().";
+ hrule <- paste(rep("*", times=getOption("width", 80L)-1L), collapse="");
+ packageStartupMessage(sprintf("%s\nNOTE: %s\n%s", hrule, msg, hrule));
+ }
+
+ # Get '.PSCBS' object [since 'PSCBS' is a constructor/Class].
+ name <- sprintf(".%s", pkgname);
+ pkg <- get(name, envir=getNamespace(pkgname), inherits=FALSE);
+ startupMessage(pkg);
+}
+
+
+############################################################################
+# HISTORY:
+# 2014-06-08
+# o CLEANUP: Using R.utils::use() instead of require().
+# 2014-02-04
+# o Added .useDNAcopy() to simplify backward compatibility.
+# 2013-10-13
+# o Added .onLoad() that creates Package '.PSCBS' object, which is
+# used in .onAttach(). This is a workaround for not allocating a
+# local Package on in .onAttach(), which then will be garbage
+# collected and finalize():d, which in turn can generate cyclic
+# loading of namespaces in R.oo (< 1.16.0).
+# 2013-09-27
+# o Added .useAromaLight() to simplify backward compatibility.
+# o Added .requirePkg() from the R.rsp package.
+# 2011-07-23
+# o Added a namespace to the package.
+############################################################################
diff --git a/build/vignette.rds b/build/vignette.rds
new file mode 100644
index 0000000..daf228b
Binary files /dev/null and b/build/vignette.rds differ
diff --git a/inst/CITATION b/inst/CITATION
new file mode 100644
index 0000000..ce802c7
--- /dev/null
+++ b/inst/CITATION
@@ -0,0 +1,53 @@
+citHeader("Please cite one or more of the below references");
+
+citEntry(
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # BibTeX entry:
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ entry = "Article",
+ author = "Adam B. Olshen and Henrik Bengtsson and Pierre Neuvial and Paul Spellman and Richard A. Olshen and Venkatraman E. Seshan",
+ title = "Parent-specific copy number in paired tumor-normal studies using circular binary segmentation",
+ journal = "Bioinformatics",
+ year = "2011",
+ volume = "27",
+ number = "15",
+ doi = "10.1093/bioinformatics/btr329",
+ url = "http://bioinformatics.oxfordjournals.org/content/27/15/2038",
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Plain-text citation:
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ textVersion = paste(sep="",
+ "A.B. Olshen, H. Bengtsson, P. Neuvial, P.T. Spellman, R.A. Olshen, V.E. Seshan. ",
+ "Parent-specific copy number in paired tumor-normal studies using circular binary segmentation, ",
+ "Bioinformatics, ",
+ "2011"
+ )
+);
+
+
+citEntry(
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # BibTeX entry:
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ entry = "Article",
+ author = "H. Bengtsson and Pierre Neuvial and Terence P Speed",
+ title = "TumorBoost: Normalization of allele-specific tumor copy numbers from a single pair of tumor-normal genotyping microarrays",
+ journal = "BMC Bioinformatics",
+ year = "2010",
+ month = "May",
+ volume = "11",
+ number = "245",
+ doi = "10.1186/1471-2105-11-245",
+ url = "http://www.biomedcentral.com/1471-2105/11/245/",
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ # Plain-text citation:
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ textVersion = paste(sep="",
+ "H. Bengtsson, P. Neuvial and T.P. Speed. ",
+ "TumorBoost: Normalization of allele-specific tumor copy numbers from a single pair of tumor-normal genotyping microarrays, ",
+ "BMC Bioinformatics, ",
+ "2010"
+ )
+);
diff --git a/inst/data-ex/PairedPSCBS,exData,chr01.Rbin b/inst/data-ex/PairedPSCBS,exData,chr01.Rbin
new file mode 100644
index 0000000..9d96d66
Binary files /dev/null and b/inst/data-ex/PairedPSCBS,exData,chr01.Rbin differ
diff --git a/inst/doc/CBS.R b/inst/doc/CBS.R
new file mode 100644
index 0000000..8e3518a
--- /dev/null
+++ b/inst/doc/CBS.R
@@ -0,0 +1,94 @@
+###########################################################################
+## This 'tangle' R script was created from an RSP document.
+## RSP source document: './CBS.tex.rsp'
+## Metadata 'title': 'Total copy-number segmentation using CBS'
+## Metadata 'author': 'Henrik Bengtsson'
+## Metadata 'engine': 'R.rsp::rsp'
+## Metadata 'keywords': 'copy numbers, genomic aberrations'
+###########################################################################
+
+t0 <- Sys.time()
+R.utils::use("R.utils")
+
+# RSP specific
+R.rsp <- R.oo::Package("R.rsp")
+withCapture <- R.utils::withCapture
+options("withCapture/newline"=FALSE)
+options(str=strOptions(strict.width="cut"))
+options(width=85)
+options(digits=3)
+
+# Graphics
+use("R.devices")
+options("devEval/args/field"="fullname") # Preferred for LaTeX
+devOptions("png", width=840)
+
+# Analysis
+use("PSCBS")
+PSCBS <- R.oo::Package("PSCBS")
+fixLocations <- function(fit, ...) {
+ for (key in grep("(end|start)$", colnames(fit$output))) {
+ fit$output[[key]] <- as.integer(fit$output[[key]])
+ }
+ fit
+} # fixLocations()
+
+signalType <- "TCN"
+R.rsp$version
+R.rsp$author
+format(as.Date(PSCBS$date), format="%B %d, %Y")
+fullname <- "PairedPSCBS,exData,chr01"
+withCapture({
+data <- PSCBS::exampleData("paired.chr01")
+data <- data[,c("chromosome", "x", "CT")]
+colnames(data)[3] <- "y"
+str(data)
+})
+signalType
+signalType
+withCapture({
+data <- dropSegmentationOutliers(data)
+})
+signalType
+withCapture({
+gaps <- findLargeGaps(data, minLength=1e6)
+gaps
+})
+withCapture({
+knownSegments <- gapsToSegments(gaps)
+knownSegments
+})
+signalType
+signalType
+withCapture({
+fit <- segmentByCBS(data, knownSegments=knownSegments, seed=0xBEEF, verbose=-10)
+})
+signalType
+nbrOfSegments(fit)
+signalType
+fit <- fixLocations(fit)
+withCapture({
+getSegments(fit, simplify=TRUE)
+})
+segs <- getSegments(fit, simplify=TRUE)
+which(segs$nbrOfLoci == 0)
+signalType
+signalType
+signalType
+toPNG(fullname, tags=c(class(fit)[1L], "tracks"), aspectRatio=0.35, {
+ plotTracks(fit)
+ })
+signalType
+signalType
+signalType
+signalType
+withCapture({
+fitP <- pruneByHClust(fit, h=0.25, verbose=-10)
+})
+toPNG(fullname, tags=c(class(fitP)[1L], "pruned", "tracks"), aspectRatio=0.35, {
+ plotTracks(fitP)
+ })
+signalType
+toLatex(sessionInfo())
+dt <- round(Sys.time()-t0, digits=2)
+attr(dt, "units")
diff --git a/inst/doc/CBS.pdf b/inst/doc/CBS.pdf
new file mode 100644
index 0000000..696a995
Binary files /dev/null and b/inst/doc/CBS.pdf differ
diff --git a/inst/doc/CBS.tex.rsp b/inst/doc/CBS.tex.rsp
new file mode 100644
index 0000000..979b1df
--- /dev/null
+++ b/inst/doc/CBS.tex.rsp
@@ -0,0 +1,305 @@
+<%@meta language="R-vignette" content="--------------------------------
+DIRECTIVES FOR R:
+
+%\VignetteIndexEntry{Total copy-number segmentation using CBS}
+%\VignetteKeyword{copy numbers}
+%\VignetteKeyword{genomic aberrations}
+%\VignetteAuthor{Henrik Bengtsson}
+%\VignetteEngine{R.rsp::rsp}
+--------------------------------------------------------------------"%>
+
+<% t0 <- Sys.time() %>
+
+<%
+R.utils::use("R.utils")
+
+# RSP specific
+R.rsp <- R.oo::Package("R.rsp")
+withCapture <- R.utils::withCapture
+options("withCapture/newline"=FALSE)
+options(str=strOptions(strict.width="cut"))
+options(width=85)
+options(digits=3)
+
+# Graphics
+use("R.devices")
+options("devEval/args/field"="fullname") # Preferred for LaTeX
+devOptions("png", width=840)
+
+# Analysis
+use("PSCBS")
+PSCBS <- R.oo::Package("PSCBS")
+fixLocations <- function(fit, ...) {
+ for (key in grep("(end|start)$", colnames(fit$output))) {
+ fit$output[[key]] <- as.integer(fit$output[[key]])
+ }
+ fit
+} # fixLocations()
+
+signalType <- "TCN"
+%>
+
+\documentclass[letter]{article}
+\usepackage{xspace}
+\usepackage{alltt}
+\usepackage{xcolor}
+\usepackage{natbib} % \citep{}, \citet{}
+
+\usepackage{graphicx}
+\graphicspath{{figures/}}
+
+<%-------------------------------------------------------------------
+ Assign PDF metadata
+ -------------------------------------------------------------------%>
+% PDF metadata
+\usepackage{hyperref}
+% Ideally \hypersetup{hidelinks}, but for backward compatibility:
+\hypersetup{pdfborder={0 0 0}}
+\hypersetup{
+ pdfauthor={<%@meta name="author"%>},
+ pdftitle={<%@meta name="title"%>},
+ pdfsubject={},
+ pdfkeywords={<%@meta name="keywords"%>},
+ pdfproducer={R.rsp v<%=R.rsp$version%> by <%=R.rsp$author%>}
+}
+
+% Page margins
+\addtolength{\oddsidemargin}{-0.5in}
+\addtolength{\evensidemargin}{-0.5in}
+\addtolength{\textwidth}{1in}
+\addtolength{\topmargin}{-0.5in}
+\addtolength{\textheight}{1in}
+
+% Placement of floats
+\setcounter{bottomnumber}{2}
+\renewcommand{\topfraction}{1.0}
+\renewcommand{\bottomfraction}{1.0}
+\renewcommand{\textfraction}{0.0}
+\renewcommand{\floatpagefraction}{1.0}
+
+% Macros
+\newcommand{\keywords}[1]{{\footnotesize{\textbf{Keywords: }#1}}\xspace}
+\newcommand{\pkg}[1]{\textsl{#1}\xspace}
+\newcommand{\file}[1]{\textsl{#1}\xspace}
+\newcommand{\code}[1]{\texttt{#1}\xspace}
+\newcommand{\bs}{$\backslash$}
+
+\newenvironment{rspVerbatim}{\vspace{-\parskip}\begin{alltt}\color{blue}}{\end{alltt}}
+\newenvironment{escapeRspVerbatim}{\vspace{-\parskip}\begin{alltt}}{\end{alltt}}
+
+
+\title{<%@meta name="title"%>}
+\author{<%@meta name="author"%>}
+\date{<%=format(as.Date(PSCBS$date), format="%B %d, %Y")%>}
+
+\begin{document}
+
+\maketitle
+\begin{abstract}
+The Circular Binary Segmentation (CBS) method partitions a genome into segments of constant total copy numbers (TCNs) based on DNA microarray data. The method also calls ....
+CBS was designed to work with data from any DNA microarray technology and generation, including Affymetrix and Illumina.
+
+This document shows how to use the \pkg{PSCBS} package to run CBS on a tumor sample.
+\end{abstract}
+
+\keywords{<%@meta name="keywords"%>}
+
+\begin{center}
+\emph{This vignette is distributed as part of the \pkg{PSCBS} package, which is available on CRAN (\url{http://cran.r-project.org/}).
+The authors very much appreciate feedback on this document.}
+\end{center}
+
+\clearpage
+\tableofcontents
+
+\clearpage
+
+<%-------------------------------------------------------------------
+ BACKGROUND
+ -------------------------------------------------------------------%>
+\section{Background}
+\label{secBackground}
+We will here use a small example data set to illustrate how to setup the data in a format suitable for CBS, how to identify segments, how to call them, and how to plot and export the segmentation results.
+The statistical model and the algorithm behind CBS is explained in detail in \citet{OlshenA_etal_2004, VenkatramanOlshen_2007}.
+
+
+<%-------------------------------------------------------------------
+ EXAMPLE
+ -------------------------------------------------------------------%>
+\section{Preparing data to be segmented}
+The CBS method requires total copy-number (TCN) estimates. More precisely, it requires TCN ratios for a sample of interest relative to a reference ($y$). The genomic location of the loci in form of chromosome and physical position are also required.
+
+
+\subsection{Locus-level total copy-number signals}
+\label{secData}
+In this example we will use a small example data set part of the \pkg{PSCBS} package. It can be loaded as:
+<%
+fullname <- "PairedPSCBS,exData,chr01"
+%>
+\begin{verbatim}
+<%=withCapture({
+data <- PSCBS::exampleData("paired.chr01")
+data <- data[,c("chromosome", "x", "CT")]
+colnames(data)[3] <- "y"
+str(data)
+})%>
+\end{verbatim}
+In additional to the mandatory fields (\code{chromosome}, \code{x}, and \code{C} this data set also contains .... The latter will not be used here.
+
+\subsection{Dropping <%=signalType%> outliers}
+\label{secTCNOutliers}
+There may be some outliers among the <%=signalType%>s. In CBS~\citep{OlshenA_etal_2004,VenkatramanOlshen_2007}, the authors propose a method for identifying outliers and then to shrink such values toward their neighbors ("smooth") before performing segmentation. At the time CBS was developed it made sense to not just to drop outliers because the resolution was low and every datapoint was valuable. With modern technologies the resolution is much higher and we can afford dropping such o [...]
+\begin{verbatim}
+<%=withCapture({
+data <- dropSegmentationOutliers(data)
+})%>
+\end{verbatim}
+Dropping <%=signalType%> outliers is optional.
+
+
+
+\section{CBS segmentation}
+
+\subsection{Skipping centromeres and other large gaps}
+\label{secGaps}
+The CBS method does not take the physical locations (in units of nucleotides) of the loci in to account when segmenting the data, only their relative ordering along the genome. This means that after having ordered the loci along genome, it will treat two "neighboring" loci that are on both sides of the centromere equally as two neighboring loci that are only few hundred bases apart. This may introduce erroneous change points that appears to be inside the centromere and biological impos [...]
+
+To avoid this, although not mandatory, we will locate all gaps of the genome where there are no observered loci. As a threshold we will consider a region to be a "gap" if the distance between the two closest loci is greater than 1Mb.
+\begin{verbatim}
+<%=withCapture({
+gaps <- findLargeGaps(data, minLength=1e6)
+gaps
+})%>
+\end{verbatim}
+which shows that there is a 20.5Mb long gap between 121.0Mb and 141.5Mb on Chromosome~1. This is the centromere of Chromosome~1.
+Gaps cannot be specified directly. Instead they need to be give as part of a set of "known" segments, which is done as:
+\begin{verbatim}
+<%=withCapture({
+knownSegments <- gapsToSegments(gaps)
+knownSegments
+})%>
+\end{verbatim}
+Below, we will use this to tell CBS to segment Chromosome~1 in three independent segments, where the first segments is from the beginning of the chromosomes (hence '-Inf') to 120.1Mb, the second from 120.1-141.5Mb (the above gap), and the third is from 141.5Mb to the end of the chromosome (hence '+Inf').
+Just as CBS segments chromosomes independently of each other, it also segments priorly known segments independently of each other.
+Specifying known segments is optional.
+
+
+\subsection{Identifying <%=signalType%> segments}
+We are now ready to segment the locus-level <%=signalType%> signals. This is done by\footnote{We fix the random seed in order for the results of this vignette to be exactly reproducible.}:
+\begin{verbatim}
+<%=withCapture({
+fit <- segmentByCBS(data, knownSegments=knownSegments, seed=0xBEEF, verbose=-10)
+})%>
+\end{verbatim}
+Note that this may take several minutes when applied to whole-genome data.
+
+The result of the segmentation is a set of segments identified to have the same underlying <%=signalType%> levels. In this particular case, <%=nbrOfSegments(fit)%> <%=signalType%> segments were found:
+<% fit <- fixLocations(fit) %>
+\begin{verbatim}
+<%=withCapture({
+getSegments(fit, simplify=TRUE)
+})%>
+\end{verbatim}
+<% segs <- getSegments(fit, simplify=TRUE) %>
+Note how Segment~\#<%=which(segs$nbrOfLoci == 0)%> has no mean-level estimates. It is because it corresponds to the centromere (the gap) that was identified above. CBS did indeed try to segment it, but since there are no data points, all estimates are missing values.
+
+
+\subsection{Displaying genomic <%=signalType%> profiles}
+To plot the <%=signalType%> segmentation results, do:
+\begin{verbatim}
+plotTracks(fit)
+\end{verbatim}
+which displays <%=signalType%> as in Figure~\ref{figTracks}.
+To zoom in on a partical region, do:
+\begin{verbatim}
+plotTracks(fit, xlim=c(120,244)*1e6)
+\end{verbatim}
+\begin{figure}[htp]
+ \begin{center}
+ \resizebox{0.96\textwidth}{!}{\includegraphics{<%=toPNG(fullname, tags=c(class(fit)[1L], "tracks"), aspectRatio=0.35, {
+ plotTracks(fit)
+ })%>}}
+ \end{center}
+ \caption{Segments identified by CBS.
+ The <%=signalType%> signals with the <%=signalType%> mean levels (purple).
+ }
+ \label{figTracks}
+\end{figure}
+
+
+
+
+
+
+\section{Calling segments}
+TBA.
+
+<%---
+\subsection{Results from calling <%=signalType%> states}
+All calls are appended to the segmentation results as logical columns:
+\begin{verbatim}
+<%=withCapture({
+getSegments(fit, simplify=TRUE)
+})%>
+\end{verbatim}
+<% segs <- getSegments(fit, simplify=TRUE) %>
+---%>
+
+\section{Saving results}
+
+\subsection{Writing segments to a tab-delimited text file}
+To write the <%=signalType%> segmentation results to file, do:
+\begin{verbatim}
+pathname <- writeSegments(fit, name="MySample", simplify=TRUE)
+\end{verbatim}
+
+
+\section{Experimental}
+In this section we illustrate some of the ongoing and future work of the PSCBS package. Please be aware that these methods are very much under construction, possibly incomplete and in worst case even incorrect.
+
+
+\subsection{Pruning segmentation profile}
+By using hierarchical cluster of the segment means it is possible to prune the <%=signalType%> profile such that change points with very small absolute changes are dropped. If change points are dropped this way, this results in a smaller number of segments, which are hence longer.
+\begin{verbatim}
+<%=withCapture({
+fitP <- pruneByHClust(fit, h=0.25, verbose=-10)
+})%>
+\end{verbatim}
+\begin{figure}[htp]
+ \begin{center}
+ \resizebox{0.96\textwidth}{!}{\includegraphics{<%=toPNG(fullname, tags=c(class(fitP)[1L], "pruned", "tracks"), aspectRatio=0.35, {
+ plotTracks(fitP)
+ })%>}}
+ \end{center}
+ \caption{Pruned <%=signalType%> segments plotted as in Figure~\ref{figTracks}.}
+ \label{figTracksPruned}
+\end{figure}
+
+
+\subsection{Report generation}
+A multipage PDF report that contains both whole-genome and per-chromosome summaries and figures can be generated by:
+\begin{verbatim}
+> report(fit, sampleName="CBS", studyName="CBS-Ex", verbose=-10)
+\end{verbatim}
+By default, the reports are written to directory \code{reports/<studyName>/} under the current working directory. In addition to the PDF, that directory also contains subdirectory \code{figures/} holding all generated figure files (e.g. PNGs and PDFs) for easy inclusion elsewhere.
+
+
+
+<%-------------------------------------------------------------------
+ REFERENCES
+ -------------------------------------------------------------------%>
+\bibliographystyle{natbib}
+\bibliography{PSCBS}
+
+
+<%-------------------------------------------------------------------
+ APPENDIX
+ -------------------------------------------------------------------%>
+\clearpage
+\section*{Appendix}
+\subsection*{Session information}
+<%=toLatex(sessionInfo())%>
+This report was automatically generated using \code{rfile()} of the R.rsp package.
+Total processing time after RSP-to-R translation was <%=dt <- round(Sys.time()-t0, digits=2)%> <%=attr(dt, "units")%>.
+
+\end{document}
diff --git a/inst/doc/PairedPSCBS.R b/inst/doc/PairedPSCBS.R
new file mode 100644
index 0000000..e1ccae6
--- /dev/null
+++ b/inst/doc/PairedPSCBS.R
@@ -0,0 +1,92 @@
+###########################################################################
+## This 'tangle' R script was created from an RSP document.
+## RSP source document: './PairedPSCBS.tex.rsp'
+## Metadata 'title': 'Parent-specific copy-number segmentation using Paired PSCBS'
+## Metadata 'author': 'Henrik Bengtsson'
+## Metadata 'engine': 'R.rsp::rsp'
+## Metadata 'keywords': 'copy numbers, allele specific, parent specific, genomic aberrations'
+###########################################################################
+
+t0 <- Sys.time()
+R.utils::use("R.utils")
+
+# RSP specific
+R.rsp <- R.oo::Package("R.rsp")
+withCapture <- R.utils::withCapture
+options("withCapture/newline"=FALSE)
+options(str=strOptions(strict.width="cut"))
+options(width=85)
+options(digits=3)
+
+# Graphics
+use("R.devices")
+options("devEval/args/field"="fullname") # Preferred for LaTeX
+devOptions("png", width=840)
+
+# Analysis
+use("PSCBS")
+PSCBS <- R.oo::Package("PSCBS")
+fixLocations <- function(fit, ...) {
+ for (key in grep("(end|start)$", colnames(fit$output))) {
+ fit$output[[key]] <- as.integer(fit$output[[key]])
+ }
+ fit
+} # fixLocations()
+R.rsp$version
+R.rsp$author
+format(as.Date(PSCBS$date), format="%B %d, %Y")
+fullname <- "PairedPSCBS,exData,chr01"
+withCapture({
+data <- PSCBS::exampleData("paired.chr01")
+str(data)
+})
+withCapture({
+data <- dropSegmentationOutliers(data)
+})
+withCapture({
+gaps <- findLargeGaps(data, minLength=1e6)
+gaps
+})
+withCapture({
+knownSegments <- gapsToSegments(gaps)
+knownSegments
+})
+withCapture({
+fit <- segmentByPairedPSCBS(data, knownSegments=knownSegments, preserveScale=FALSE, seed=0xBEEF, verbose=-10)
+})
+nbrOfSegments(fit)
+fit <- fixLocations(fit)
+withCapture({
+getSegments(fit, simplify=TRUE)
+})
+segs <- getSegments(fit, simplify=TRUE)
+which(segs$tcnNbrOfLoci == 0)
+which(segs$dhNbrOfLoci == 0)
+toPNG(fullname, tags=c(class(fit)[1L], "tracks"), aspectRatio=0.6, {
+ plotTracks(fit)
+ })
+withCapture({
+fit <- callROH(fit, verbose=-10)
+})
+withCapture({
+fit <- callAB(fit, verbose=-10)
+})
+withCapture({
+fit <- callLOH(fit, verbose=-10)
+})
+withCapture({
+fit <- callNTCN(fit, verbose=-10)
+})
+withCapture({
+getSegments(fit, simplify=TRUE)
+})
+segs <- getSegments(fit, simplify=TRUE)
+withCapture({
+fitP <- pruneByHClust(fit, h=0.25, verbose=-10)
+})
+toPNG(fullname, tags=c(class(fitP)[1L], "pruned", "tracks"), aspectRatio=0.6, {
+ plotTracks(fitP)
+ })
+toLatex(sessionInfo())
+dt <- round(Sys.time()-t0, digits=2)
+attr(dt, "units")
diff --git a/inst/doc/PairedPSCBS.pdf b/inst/doc/PairedPSCBS.pdf
new file mode 100644
index 0000000..8b57659
Binary files /dev/null and b/inst/doc/PairedPSCBS.pdf differ
diff --git a/inst/doc/PairedPSCBS.tex.rsp b/inst/doc/PairedPSCBS.tex.rsp
new file mode 100644
index 0000000..7dbe86d
--- /dev/null
+++ b/inst/doc/PairedPSCBS.tex.rsp
@@ -0,0 +1,421 @@
+<%@meta language="R-vignette" content="--------------------------------
+DIRECTIVES FOR R:
+%\VignetteIndexEntry{Parent-specific copy-number segmentation using Paired PSCBS}
+%\VignetteAuthor{Henrik Bengtsson}
+%\VignetteKeyword{copy numbers}
+%\VignetteKeyword{allele specific}
+%\VignetteKeyword{parent specific}
+%\VignetteKeyword{genomic aberrations}
+%\VignetteEngine{R.rsp::rsp}
+--------------------------------------------------------------------"%>
+
+
+<% t0 <- Sys.time() %>
+
+<%
+R.utils::use("R.utils")
+
+# RSP specific
+R.rsp <- R.oo::Package("R.rsp")
+withCapture <- R.utils::withCapture
+options("withCapture/newline"=FALSE)
+options(str=strOptions(strict.width="cut"))
+options(width=85)
+options(digits=3)
+
+# Graphics
+use("R.devices")
+options("devEval/args/field"="fullname") # Preferred for LaTeX
+devOptions("png", width=840)
+
+# Analysis
+use("PSCBS")
+PSCBS <- R.oo::Package("PSCBS")
+fixLocations <- function(fit, ...) {
+ for (key in grep("(end|start)$", colnames(fit$output))) {
+ fit$output[[key]] <- as.integer(fit$output[[key]])
+ }
+ fit
+} # fixLocations()
+%>
+
+\documentclass[letter]{article}
+\usepackage{xspace}
+\usepackage{alltt}
+\usepackage{xcolor}
+\usepackage{natbib} % \citep{}, \citet{}
+
+\usepackage{graphicx}
+\graphicspath{{figures/}}
+
+<%-------------------------------------------------------------------
+ Assign PDF metadata
+ -------------------------------------------------------------------%>
+% PDF metadata
+\usepackage{hyperref}
+% Ideally \hypersetup{hidelinks}, but for backward compatibility:
+\hypersetup{pdfborder={0 0 0}}
+\hypersetup{
+ pdfauthor={<%@meta name="author"%>},
+ pdftitle={<%@meta name="title"%>},
+ pdfsubject={},
+ pdfkeywords={<%@meta name="keywords"%>},
+ pdfproducer={R.rsp v<%=R.rsp$version%> by <%=R.rsp$author%>}
+}
+
+% Page margins
+\addtolength{\oddsidemargin}{-0.5in}
+\addtolength{\evensidemargin}{-0.5in}
+\addtolength{\textwidth}{1in}
+\addtolength{\topmargin}{-0.5in}
+\addtolength{\textheight}{1in}
+
+% Placement of floats
+\setcounter{bottomnumber}{2}
+\renewcommand{\topfraction}{1.0}
+\renewcommand{\bottomfraction}{1.0}
+\renewcommand{\textfraction}{0.0}
+\renewcommand{\floatpagefraction}{1.0}
+
+% Macros
+\newcommand{\keywords}[1]{{\footnotesize{\textbf{Keywords: }#1}}\xspace}
+\newcommand{\pkg}[1]{\textsl{#1}\xspace}
+\newcommand{\file}[1]{\textsl{#1}\xspace}
+\newcommand{\code}[1]{\texttt{#1}\xspace}
+\newcommand{\bs}{$\backslash$}
+
+\newcommand{\alphaTCN}{\alpha_{\textnormal{TCN}}\xspace}
+\newcommand{\alphaDH}{\alpha_{\textnormal{DH}}\xspace}
+\newcommand{\LOH}{\ensuremath{\textnormal{LOH}}\xspace}
+\newcommand{\AB}{\ensuremath{\textnormal{AB}}\xspace}
+
+\newenvironment{rspVerbatim}{\vspace{-\parskip}\begin{alltt}\color{blue}}{\end{alltt}}
+\newenvironment{escapeRspVerbatim}{\vspace{-\parskip}\begin{alltt}}{\end{alltt}}
+
+
+\title{<%@meta name="title"%>}
+\author{<%@meta name="author"%>}
+\date{<%=format(as.Date(PSCBS$date), format="%B %d, %Y")%>}
+
+\begin{document}
+
+\maketitle
+\begin{abstract}
+The Paired Parent-Specific Circular Binary Segmentation (Paired PSCBS) method partitions a tumor genome into segments of constant parent-specific copy numbers (PSCNs) based on SNP DNA microarray data from a matched tumor-normal pair. The method also calls segments with run of homozygosity (ROH), segments in allelic balance (AB) and segments with loss of heterozygosity (LOH).
+Paired PSCBS was designed to work with data from any SNP microarray technology and generation, including Affymetrix and Illumina.
+
+This document shows how to use the \pkg{PSCBS} package to run Paired PSCBS on a tumor-normal pair.
+\end{abstract}
+
+\keywords{<%@meta name="keywords"%>}
+
+\begin{center}
+\emph{This vignette is distributed as part of the \pkg{PSCBS} package, which is available on CRAN (\url{http://cran.r-project.org/}).
+The authors very much appreciate feedback on this document.}
+\end{center}
+
+\clearpage
+\tableofcontents
+
+\clearpage
+
+
+<%-------------------------------------------------------------------
+ BACKGROUND
+ -------------------------------------------------------------------%>
+\section{Background}
+\label{secBackground}
+We will here use a small example data set to illustrate how to setup the data in a format suitable for Paired PSCBS, how to identify segments, how to call them, and how to plot and export the segmentation results.
+The statistical model and the algorithm behind Paired PSCBS is explained in detail in~\citet{OlshenA_etal_2011}.
+
+
+<%-------------------------------------------------------------------
+ EXAMPLE
+ -------------------------------------------------------------------%>
+\section{Preparing data to be segmented}
+The Paired PSCBS~\citep{OlshenA_etal_2011} method requires tumor-normal paired parent-specific copy-number (PSCN) signals. More precisely, it requires total copy-number (TCN) estimates for the tumor relative to the matched normal ($C_T$), allele B fractions (BAFs) for the tumor ($\beta_T$) and BAFs for the matched normal ($\beta_N$). The genomic locations of the loci in form of chromosome and physical position are also required.
+
+
+\subsection{Locus-level SNP copy-number signals}
+\label{secData}
+In this example we will use a small example data set part of the \pkg{PSCBS} package. It can be loaded as:
+<%
+fullname <- "PairedPSCBS,exData,chr01"
+%>
+\begin{verbatim}
+<%=withCapture({
+data <- PSCBS::exampleData("paired.chr01")
+str(data)
+})%>
+\end{verbatim}
+In additional to the mandatory fields (\code{chromosome}, \code{x}, \code{CT}, \code{betaT}, and \code{betaN}), this data set also contains TCNs for normal (\code{CN}) relative to a large pool of normal samples. The latter will not be used here.
+
+\subsection{Dropping TCN outliers}
+\label{secTCNOutliers}
+There may be some outliers among the TCNs. In CBS~\citep{OlshenA_etal_2004,VenkatramanOlshen_2007}, the authors propose a method for identifying outliers and then to shrink such values toward their neighbors ("smooth") before performing segmentation. At the time CBS was developed it made sense to not just to drop outliers because the resolution was low and every datapoint was valuable. With modern technologies the resolution is much higher and we can afford dropping such outliers, whi [...]
+\begin{verbatim}
+<%=withCapture({
+data <- dropSegmentationOutliers(data)
+})%>
+\end{verbatim}
+Dropping TCN outliers is optional.
+
+
+
+\section{Paired PSCBS segmentation}
+
+\subsection{Skipping centromeres and other large gaps}
+\label{secGaps}
+Like the CBS method, Paired PSCBS does not take the physical locations (in units of nucleotides) of the loci in to account when segmenting the data, only their relative ordering along the genome. This means that after having ordered the loci along genome, it will treat two "neighboring" loci that are on both sides of the centromere equally to two neighboring loci that are only a few hundred bases apart. This may introduce erroneous change points that appear to be inside the centromere. [...]
+
+To avoid this, although not mandatory, we will locate all gaps of the genome where there are no observered loci. As a threshold we will consider a region to be a "gap" if the distance between the two closest loci is greater than 1Mb.
+\begin{verbatim}
+<%=withCapture({
+gaps <- findLargeGaps(data, minLength=1e6)
+gaps
+})%>
+\end{verbatim}
+which shows that there is a 20.5Mb long gap between 121.0Mb and 141.5Mb on Chromosome~1. This is the centromere of Chromosome~1.
+It is not possible to specify "gaps" to the segmentation function. Instead they need to be given as part of a set of "known" segments, which is done as:
+\begin{verbatim}
+<%=withCapture({
+knownSegments <- gapsToSegments(gaps)
+knownSegments
+})%>
+\end{verbatim}
+Below, we will use this to tell Paired PSCBS to segment Chromosome~1 into three independent segments, where the first segment is from the beginning of the chromosome (hence '-Inf') to 120.1Mb, the second one from 120.1-141.5Mb (the above gap), and the third one is from 141.5Mb to the end of the chromosome (hence '+Inf').
+Just as Paired PSCBS segments chromosomes independently of each other, it also segments priorly known segments independently of each other.
+Specifying known segments is optional.
+
+
+\subsection{Identifying PSCN segments}
+We are now ready to segment the locus-level PSCN signals. This is done by\footnote{We fix the random seed in order for the results of this vignette to be numerically reproducible.}:
+\begin{verbatim}
+<%=withCapture({
+fit <- segmentByPairedPSCBS(data, knownSegments=knownSegments, preserveScale=FALSE, seed=0xBEEF, verbose=-10)
+})%>
+\end{verbatim}
+Note that this may take several minutes when applied to whole-genome data.
+The above call will also normalize the tumor BAFs using the TumorBoost normalization method~\citep{BengtssonH_etal_2010} (without preserving the relative scale for homozygous and heterozygous BAFs; in a future version, this will be the default). If this has already been done or the tumor signals have been normalized by other means, the TumorBoost step can be skipped by setting argument \code{tbn=FALSE}.
+
+The result of the segmentation is a set of segments identified to have the same underlying PSCN levels. In this particular case, <%=nbrOfSegments(fit)%> PSCN segments were found:
+<% fit <- fixLocations(fit) %>
+\begin{verbatim}
+<%=withCapture({
+getSegments(fit, simplify=TRUE)
+})%>
+\end{verbatim}
+<% segs <- getSegments(fit, simplify=TRUE) %>
+Note that Segment~\#<%=which(segs$tcnNbrOfLoci == 0)%> has no mean-level estimates. It is because it corresponds to the centromere (the gap) that was identified above. Paired PSCBS did indeed try to segment it, but since there are no data points, all estimates are missing values.
+Similarly, for Segment~\#<%=which(segs$dhNbrOfLoci == 0)%> the DH and minor and major CNs mean estimates are all missing values. This is because, Paired PSCBS identified that segment by first segmenting the TCN signals by themselves, and after which it tried to segment the DH signals within that segment. Since there are no heterozygous SNPs in the segment, there are no DH signals, and hence there is no DH mean estimate.
+
+
+\subsection{Displaying genomic PSCN profiles}
+To plot the PSCN segmentation results, do:
+\begin{verbatim}
+plotTracks(fit)
+\end{verbatim}
+which by default displays three panels containing TCN, decrease of heterozygosity (DH), and minor and major CNs as in Figure~\ref{figTracks}.
+To plot only one panel with TCN and minor and major CNs and zoom in on a particular region, do (not shown):
+\begin{verbatim}
+plotTracks(fit, tracks="tcn,c1,c2", xlim=c(120,244)*1e6)
+\end{verbatim}
+\begin{figure}[htp]
+ \begin{center}
+ \resizebox{0.96\textwidth}{!}{\includegraphics{<%=toPNG(fullname, tags=c(class(fit)[1L], "tracks"), aspectRatio=0.6, {
+ plotTracks(fit)
+ })%>}}
+ \end{center}
+ \caption{PSCN segments identified by Paired PSCBS.
+ \textbf{Top}: The TCN signals with the TCN mean levels (purple).
+ \textbf{Middle}: The DH signals with the DH mean levels (orange).
+ \textbf{Bottom}: The TCN signals with the minor CN ($C_1$; blue), the major CN ($C_2$; red) and the TCN ($C=C_1+C_2$; purple) mean levels.
+ }
+ \label{figTracks}
+\end{figure}
+
+
+
+
+
+
+\section{Calling segments}
+The calling algorithms for allelic balance (AB) and loss of heterozygosity (LOH) are based on quantile estimates of the different mean levels. These estimates are obtained using non-parametric bootstrap techniques. For more details, see~\citet{OlshenA_etal_2011}.
+After the Paired PSCBS method was published, we have added methods for calling run of homozygosity (ROH) and neutral total copy number (NTCN).
+\emph{The ROH and NTCN calling methods should be considered under development until further notice, meaning they and their results may change without notice.}
+
+
+
+\subsection{Calling segments with run of homozygosity (ROH)*}
+\emph{Please note that this method is under development. This means that it may change without further notice.}
+
+A region has a run of homozygotes (ROH) if all of its SNPs are homozygous (in the normal). Since such a region has no heterozyous SNPs, its decrease in heterozygosity (DH) is undefined. Likewise, the minor and major copy numbers are unknown.
+ However, if there are genotyping errors within an ROH region, we will obtain a non-missing DH mean level and hence also finite minor and major CNs. In order to adjust for these faulty estimates, we test if the identified segments are ROHs or not by:
+\begin{verbatim}
+<%=withCapture({
+fit <- callROH(fit, verbose=-10)
+})%>
+\end{verbatim}
+This will also set the corresponding DH and minor and major CN mean levels to NA. The total CN mean levels are not affected by the ROH call.
+
+\subsubsection{Tuning parameters}
+For each segment, the test for ROH calculates the fraction of SNPs
+that are called heterozygous. If the fraction of heterozygotes is smaller
+than a threshold, the segmented is called ROH, otherwise not.
+The default threshold is 1/12.
+To use a different threshold, set argument \code{delta} to a scalar in $[0,1]$.
+For example, using \code{callROH(fit, delta=1/30)} makes the ROH caller
+more conservative.\footnote{It is our plan to replace this basic test with a bionomial test.}
+
+
+\subsection{Calling segments in allelic balance (AB)}
+The AB caller tests whether the DH level of a segment is small enough to be considered zero, which means that the minor and the major CNs are equal, i.e. the segment is in allelic balance.
+To call the AB state of all segments, do:
+\begin{verbatim}
+<%=withCapture({
+fit <- callAB(fit, verbose=-10)
+})%>
+\end{verbatim}
+Because the caller utilizes bootstrapping techniques, calling AB may take some time if there is a large number of segments.
+Segments already called ROH will not be called for AB, and their AB statuses will have a missing value (\code{NA}).
+
+
+\subsubsection{Tuning parameters}
+The AB caller tests whether a segment's DH is zero or not, by comparing its DH level (or more precisely, the $5\%$ quantile of its bootstrapped DH mean level) to a threshold. This threshold will be a function of the noise level, because the noiser the BAF signals (and hence the DH signals), the greater the bias of the DH mean level for segments in AB will be. Because of this, the threshold is choosen from data by estimating the noise level of the DH signals near zero.
+Further rationales and details are given in~\citet{OlshenA_etal_2011}.
+The AB threshold can be estimated explicitly and used in the caller as
+\begin{verbatim}
+deltaAB <- estimateDeltaAB(fit, scale=1)
+fit <- callAB(fit, delta=deltaAB)
+\end{verbatim}
+By decreasing argument \code{scale} (a positive scalar), a smaller
+threshold will be obtained resulting in a more conservative AB caller.
+
+
+\subsection{Calling segments with loss of heterozygosity (LOH)}
+The LOH caller tests whether the minor CN level of a segment is large enough to be considered non-zero, which means that the segment is \emph{not} in LOH.
+To call the LOH state of all segments, do:
+\begin{verbatim}
+<%=withCapture({
+fit <- callLOH(fit, verbose=-10)
+})%>
+\end{verbatim}
+Note that in order to call LOH, one has to call allelic balance first. Since the bootstrapping was already done in the AB caller, it is not repeated here, which is why calling LOH is faster than calling AB.
+Analogously to the AB caller, segments already called ROH will not be called for LOH, and their LOH statuses will have a missing value (\code{NA}).
+Segments already called AB will be called non-LOH, because AB and LOH are exclusively mutual states.
+
+\subsubsection{Tuning parameters}
+The LOH caller tests whether a segment's minor CN is non-zero or not, by comparing its minor CN level (or more precisely, the $95\%$ quantile of its bootstrapped minor CN mean level) to a threshold. This threshold will, among other components, be a function of normal contamination, i.e. the greater the fraction of normal cells is the greater the threshold needs to be in order to call LOH in the tumor cells. Because of this, the threshold is choosen from data as the midpoint of the esti [...]
+The LOH threshold can be estimated explicitly and used as:
+\begin{verbatim}
+deltaLOH <- estimateDeltaLOH(fit, midpoint=1/2)
+fit <- callLOH(fit, delta=deltaLOH)
+\end{verbatim}
+By decreasing argument \code{midpoint} in $[0,1]$, a smaller
+threshold will be obtained resulting in a more conservative LOH caller.
+
+
+
+\subsection{Calling segments with neutral total copy number (NTCN)*}
+\emph{Please note that this method is under development. This means that it may change without further notice.}
+
+The neutral total copy number (NTCN) caller tests whether the total CN level of a segment is neutral (e.g. diploid) or not.
+To call the NTCN state of all segments, do:
+\begin{verbatim}
+<%=withCapture({
+fit <- callNTCN(fit, verbose=-10)
+})%>
+\end{verbatim}
+
+
+\subsubsection{Tuning parameters}
+The NTCN caller identifies segments which TCN mean levels (or more precisely, which $95\%$ confidence intervals) are within a given "acceptance" region. This acceptance region is determined by the $95\%$ confidence interval of an initial set of AB segments identified to be copy neutral and then expanded by half a TCN unit length.
+The true length of half a total copy number unit is specified by the argument \code{delta} to \code{callNTCN()}. Its length should be a function of the overall background signals (which includes normal contamination and more), such that the width of the acceptance region becomes smaller when the background increases.
+The background signal (\code{kappa}) and \code{delta} can be estimated explicitly as:
+\begin{verbatim}
+kappa <- estimateKappa(fit)
+deltaCN <- estimateDeltaCN(fit, scale=1, kappa=kappa)
+fit <- callNTCN(fit, delta=deltaCN, verbose=-10)
+\end{verbatim}
+By decreasing the tuning parameter \code{scale} (a positive scalar), a smaller acceptance region will be obtained, which results in a more conservative CN caller.
+
+
+
+\subsection{Results from calling ROH, AB, LOH and NTCN}
+All calls are appended to the segmentation results as logical columns:
+\begin{verbatim}
+<%=withCapture({
+getSegments(fit, simplify=TRUE)
+})%>
+\end{verbatim}
+<% segs <- getSegments(fit, simplify=TRUE) %>
+
+
+\section{Saving results}
+
+\subsection{Writing segments to a tab-delimited text file}
+To write the PSCN segmentation results to file, do:
+\begin{verbatim}
+pathname <- writeSegments(fit, name="MySample", simplify=TRUE)
+\end{verbatim}
+With \code{simplify=FALSE} (default) quantile estimates of the different mean levels will also be written, which roughly doubles the file size.
+
+
+
+\section{Experimental}
+In this section we illustrate some of the ongoing and future work that will be contained in the PSCBS package. Please be aware that these methods are very much under construction, possibly incomplete and in the worst case, even incorrect.
+
+
+\subsection{Less biased Decrease of Heterozygosity (DH) estimates}
+The DH mean levels of the segments are estimated as the sample mean of the DH signals within each segment. Since DH signals are by definition truncated at zero, the mean level estimates will always be greater than zero even if the true underlying DH is exactly zero. An additional bias is introduced because the distribution of the DH signals is skewed for small DHs, causing the sample mean estimate to be biased. A less biased estimate can be obtained by using the median estimator. To [...]
+
+
+\subsection{Pruning segmentation profile}
+By applying hierarchical clustering on the segment means, it is possible to prune the PSCN profile such that change points with very small absolute changes are dropped. If change points are dropped this way, this results in a smaller number of segments, which are hence longer on average. To prune Paired PSCBS segmentation results this way, do:
+\begin{verbatim}
+<%=withCapture({
+fitP <- pruneByHClust(fit, h=0.25, verbose=-10)
+})%>
+\end{verbatim}
+The result of this is shown in Figure~\ref{figTracksPruned}.
+\begin{figure}[htp]
+ \begin{center}
+ \resizebox{0.96\textwidth}{!}{\includegraphics{<%=toPNG(fullname, tags=c(class(fitP)[1L], "pruned", "tracks"), aspectRatio=0.6, {
+ plotTracks(fitP)
+ })%>}}
+ \end{center}
+ \caption{Pruned PSCN segments plotted as in Figure~\ref{figTracks}.}
+ \label{figTracksPruned}
+\end{figure}
+In the current implementation, any segment calls and quantile mean levels estimates previously are dropped when pruning.
+
+
+\subsection{Report generation}
+A multipage PDF report that contains both whole-genome and per-chromosome summaries and figures can be generated by:
+\begin{verbatim}
+> report(fit, sampleName="PairedPSCBS", studyName="PSCBS-Ex", verbose=-10)
+\end{verbatim}
+By default, the reports are written to directory \code{reports/<studyName>/} under the current working directory. In addition to the PDF, that directory also contains subdirectory \code{figures/} holding all generated figure files (e.g. PNGs and PDFs) for easy inclusion elsewhere.
+
+
+
+
+
+<%-------------------------------------------------------------------
+ REFERENCES
+ -------------------------------------------------------------------%>
+\bibliographystyle{natbib}
+\bibliography{PSCBS}
+
+
+<%-------------------------------------------------------------------
+ APPENDIX
+ -------------------------------------------------------------------%>
+\clearpage
+\section*{Appendix}
+\subsection*{Session information}
+<%=toLatex(sessionInfo())%>
+This report was automatically generated using \code{rfile()} of the R.rsp package.
+Total processing time after RSP-to-R translation was <%=dt <- round(Sys.time()-t0, digits=2)%> <%=attr(dt, "units")%>.
+
+\end{document}
diff --git a/inst/misc/_Rcache/PSCBS/segmentByCBS/sbdry/0109d43cd74c8e7e46db1abde235c808.Rcache b/inst/misc/_Rcache/PSCBS/segmentByCBS/sbdry/0109d43cd74c8e7e46db1abde235c808.Rcache
new file mode 100644
index 0000000..3650278
Binary files /dev/null and b/inst/misc/_Rcache/PSCBS/segmentByCBS/sbdry/0109d43cd74c8e7e46db1abde235c808.Rcache differ
diff --git a/inst/misc/_Rcache/PSCBS/segmentByCBS/sbdry/2aba5b85ae757609b8b4c9fc60be1156.Rcache b/inst/misc/_Rcache/PSCBS/segmentByCBS/sbdry/2aba5b85ae757609b8b4c9fc60be1156.Rcache
new file mode 100644
index 0000000..6c8cec8
Binary files /dev/null and b/inst/misc/_Rcache/PSCBS/segmentByCBS/sbdry/2aba5b85ae757609b8b4c9fc60be1156.Rcache differ
diff --git a/inst/templates/rsp/CBS,report.tex.rsp b/inst/templates/rsp/CBS,report.tex.rsp
new file mode 100644
index 0000000..bfad67b
--- /dev/null
+++ b/inst/templates/rsp/CBS,report.tex.rsp
@@ -0,0 +1,491 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Authors: Henrik Bengtsson
+% Created on: 2011-09-30
+% Last updated: 2012-02-27
+%
+% Usage: (compiles *.tex.rsp => tex.rsp.R => *.tex => *.dvi)
+% R.rsp::rsp("CBS.tex.rsp", path="reports,rsp/");
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+<%
+library("PSCBS");
+library("R.devices");
+library("R.cache");
+library("R.utils"); # setOption()
+stopifnot(exists("rspArgs", mode="list"));
+%>
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% LATEX STARTUP
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\documentclass[twoside,12pt]{report}
+\usepackage{fancyvrb}
+\usepackage{xspace}
+\usepackage{subfigure} % \subfigure[<title>]{}
+\usepackage[round]{natbib}
+
+\addtolength{\oddsidemargin}{-0.5in}
+\addtolength{\evensidemargin}{-0.5in}
+\addtolength{\textwidth}{1in}
+\addtolength{\topmargin}{-0.8in}
+\addtolength{\textheight}{1.3in}
+
+\renewcommand{\topfraction}{1.00} % max fraction of floats at top
+\renewcommand{\bottomfraction}{1.0} % max fraction of floats at bottom
+\renewcommand{\textfraction}{0.00}
+
+\usepackage{fancyhdr}
+\pagestyle{fancy}
+%% \fancyhead{} % clear all header fields
+%% \fancyfoot{} % clear all footer fields
+%% \fancyhead[LE,RO]{\slshape \rightmark}
+%% \fancyfoot[C]{\thepage}
+
+\fancyhf{}
+\fancyhead[LE,RO]{\thepage}
+\fancyhead[RE]{\textit{\nouppercase{\leftmark}}}
+\fancyhead[LO]{\textit{\nouppercase{\rightmark}}}
+
+\newcommand{\code}[1]{\texttt{#1}\xspace}
+
+
+\newcommand{\TCN}{TCN\xspace}
+\newcommand{\BAF}{\BAF\xspace}
+\newcommand{\BAFN}{BAF$_{N}$\xspace}
+\newcommand{\BAFT}{BAF$_{T}$\xspace}
+\newcommand{\BAFTN}{BAF$^*_{T}$\xspace}
+
+
+<% cbsReport <- function(fit, sampleName=NULL, dataSet=NULL, studyName="CBS", Clim=c(0,4), reportPath=file.path("reports", studyName), figPath=file.path(reportPath, "figures"), ..., figForce=FALSE) { %>
+<%
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Validate arguments
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Argument 'fit':
+fit <- Arguments$getInstanceOf(fit, "CBS");
+
+# Argument 'sampleName':
+if (is.null(sampleName)) {
+ sampleName <- sampleName(fit);
+}
+sampleName <- Arguments$getCharacter(sampleName);
+
+# Argument 'dataSet':
+if (!is.null(dataSet)) {
+ dataSet <- Arguments$getCharacter(dataSet);
+}
+
+# Argument 'studyName':
+studyName <- Arguments$getCharacter(studyName);
+
+# Argument 'reportPath':
+reportPath <- Arguments$getWritablePath(reportPath);
+
+# Argument 'figPath':
+figPath <- Arguments$getWritablePath(figPath);
+
+# Argument 'figForce':
+figForce <- Arguments$getLogical(figForce);
+%>
+
+<%
+oFigPath <- setOption("devEval/args/path", figPath);
+on.exit({
+ setOption("devEval/args/path", oFigPath);
+}, add=TRUE);
+
+oPar <- setOption("devNew/args/par", list(lwd=2));
+on.exit({
+ setOption("devNew/args/par", oPar);
+}, add=TRUE);
+%>
+
+<%
+studyLbl <- sprintf("Study: %s\\\\", toLatex(studyName));
+if (!is.null(dataSet)) {
+ dataSetLbl <- sprintf("Data set: %s\\\\", toLatex(dataSet));
+} else {
+ dataSetLbl <- "";
+}
+%>
+
+\title{CBS Report:\\<%=studyLbl%><%=dataSetLbl%>Sample: <%=toLatex(sampleName)%>}
+\author{Report template by Henrik Bengtsson}
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+% GRAPHICS SETTINGS
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+<%
+setOption("devEval/args/force", figForce);
+%>
+\usepackage{graphicx}
+\graphicspath{{<%=figPath%>/} {../<%=figPath%>/}}
+
+<%
+# GGPLOT2 SETTINGS
+ClimX <- Clim + c(-1,1)*diff(Clim)*0.08;
+
+muNCols <- c("#999999", "#000000", "#999999");
+
+require("ggplot2") || throw("Package not loaded: ggplot2");
+xnbrOpts <- element_text(colour="grey50", size=20, hjust=1, lineheight=0.9);
+ynbrOpts <- element_text(colour="grey50", size=20, vjust=1, lineheight=0.9);
+xlabOpts <- element_text(colour="black", size=28, hjust=0.5);
+ylabOpts <- element_text(colour="black", size=28, vjust=0.5, angle=90);
+
+labList <- list(
+ CT = expression(C[T]),
+ betaN = expression(beta[N]),
+ betaT = expression(beta[T]),
+ betaTN = expression(tilde(beta)[T]),
+ rho = expression(rho),
+ rhoN = expression(tilde(rho)),
+ c1 = expression(C[1]),
+ c2 = expression(C[2]),
+ c1N = expression(tilde(C)[1]),
+ c2N = expression(tilde(C)[2])
+);
+
+symbolList <- list(
+ CT = "$C_{T}$",
+ betaN = "$\\beta_{N}$",
+ betaT = "$\\beta_{T}$",
+ betaTN = "$\\tilde{\\beta}_{T}$",
+ rho = "$\\rho$",
+ rhoN = "$\\tilde{\\rho}$",
+ c1 = "$C_{1}$",
+ c2 = "$C_{2}$",
+ c1N = "$\\tilde{C}_{1}$",
+ c2N = "$\\tilde{C}_{2}$"
+);
+%>
+
+\begin{document}
+
+\maketitle
+\begin{abstract}
+This is a quality control (QC) report on the sample '<%=toLatex(sampleName)%>' in data set '<%=toLatex(dataSet)%>'.
+\end{abstract}
+
+\tableofcontents
+
+\clearpage
+
+
+%>
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% DATA
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Introduction}
+
+\chapter{Data}
+\label{ch:Data}
+
+\section{Samples}
+
+\section{Microarray data}
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% METHODS
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Methods}
+\label{ch:Methods}
+
+\section{Segmentation}
+\label{sec:Segmentation}
+We use the CBS segmentation method~\citep{OlshenA_etal_2007} to partion the genome into segments such that all signals in a particular segment are likely to originate from the same underlying total copy-number state.
+
+
+<%--
+\section{Post-segmentation pruning}
+\label{sec:PostSegmentationPruning}
+<%
+fitP <- pruneByHClust(fit, h=0.25);
+#print(fitP);
+%>
+--%>
+
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% RESULTS
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+% WHOLE-GENOME RESULTS
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+\chapter{Whole-Genome Results}
+\label{ch:WholeGenomeResults}
+
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+% SUMMARY ANNOTATION
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+<% summaryOfAnnotation <- function(fit, ...) { %>
+\section{Summary of annotation}
+<%
+data <- getLocusData(fit, fields="full");
+nbrOfLoci <- nrow(data);
+
+chromosomes <- getChromosomes(fit);
+nbrOfChromosomes <- length(chromosomes);
+chromosomesH <- seqToHumanReadable(chromosomes);
+chromosomesH <- if (nbrOfChromosomes == 1) {
+ sprintf("Chr %s", chromosomesH);
+} else {
+ sprintf("Chrs %s", chromosomesH);
+}
+chrsTags <- if (nbrOfChromosomes == 1) {
+ sprintf("chr%02d", chromosomes[1]);
+} else {
+ sprintf("chrs%02d-%02d", min(chromosomes), max(chromosomes));
+}
+%>
+
+\begin{table}[htbp]
+ \begin{center}
+ \begin{tabular}{lrr}
+ Description & Count & Fraction \\
+ \hline
+ Number of loci & <%=nbrOfLoci%> & 100.00\% \\
+ Number of chromosomes & <%=nbrOfChromosomes%> & - \\
+ \end{tabular}
+ \caption{
+ Summary of the locus-level data on <%=chromosomesH%>.
+ }
+ \label{tbl:LocusStats}
+ \end{center}
+\end{table}
+
+<% } # summaryOfAnnotation() %>
+
+
+<%=summaryOfAnnotation(fit)%>
+
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+% SIGNAL DENSITIES
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+<% signalDensities <- function(fit, ...) { %>
+\clearpage
+\section{Signal densities}
+\label{sec:SignalDensities}
+<%
+require("ggplot2") || throw("Package not loaded: ggplot2");
+data <- getLocusData(fit, fields="full");
+chromosomes <- getChromosomes(fit);
+nbrOfChromosomes <- length(chromosomes);
+chromosomesH <- seqToHumanReadable(chromosomes);
+chromosomesH <- if (nbrOfChromosomes == 1) {
+ sprintf("Chr %s", chromosomesH);
+} else {
+ sprintf("Chrs %s", chromosomesH);
+}
+chrsTags <- if (nbrOfChromosomes == 1) {
+ sprintf("chr%02d", chromosomes[1]);
+} else {
+ sprintf("chrs%02d-%02d", min(chromosomes), max(chromosomes));
+}
+%>
+\begin{figure}[htbp]
+ \begin{center}
+<%
+ fields <- c("y");
+%>
+<% for (ff in fields) { %>
+<%
+ symbol <- symbolList[[ff]];
+ panelTitle <- switch(ff, y="\\TCN", CT="\\TCN", betaN="\\BAFN", betaT="\\BAFT", betaTN="\\BAFTN", "NNN");
+ lim <- switch(ff, y=ClimX, CT=ClimX, c1=ClimX, c2=ClimX, c1N=ClimX, c2N=ClimX);
+%>
+\raisebox{4ex}{<%=symbol%>}
+<% for (by in c("all")) { %>
+<%
+ tags <- c(chrsTags, by, ff);
+%>
+ \resizebox{0.33\textwidth}{!}{%
+ \includegraphics{<%={
+ toPNG(name=sampleName, tags=tags, width=640, aspectRatio=0.3, {
+ gg <- ggplot(data, aes_string(x=ff, y="..count.."));
+ if (by == "all") {
+ if (ff == "CT" && any(!data$isSNP, na.rm=TRUE)) {
+ gg <- gg + aes(group=type, colour=type);
+ }
+ }
+
+ # See https://github.com/hadley/ggplot2/wiki/Legend-Attributes
+ gg <- gg + theme(legend.position=c(0.97, 0.75),
+ legend.justification = 1,
+ legend.direction="vertical",
+ legend.title=element_text(size=0),
+ legend.text=element_text(size=16));
+
+ gg <- gg + geom_density(size=2, na.rm=TRUE);
+ gg <- gg + xlab(NULL);
+ gg <- gg + ylab(NULL);
+ gg <- gg + xlim(lim);
+ gg <- gg + theme(axis.text.x=xnbrOpts, axis.text.y=ynbrOpts);
+ gg <- gg + theme(axis.title.x=xlabOpts, axis.title.y=ylabOpts);
+ suppressWarnings({
+ print(gg);
+ });
+ }, force=FALSE);
+ }%>}%
+ }%
+<% } # for (by ...) %>
+\\ %
+<% } # for (ff ...) %>
+ \end{center}
+ \caption{
+ Density estimates of locus-level signals on <%=chromosomesH%>.
+ }
+ \label{fig:SignalDensity}
+\end{figure}
+<% } # signalDensities() %>
+
+<%=signalDensities(fit)%>
+
+
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+% TOTAL COPY-NUMBER SEGMENTATION TRACKS
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+<% tcnSegmentationTracks <- function(fit, ...) { %>
+\clearpage
+\section{Total copy-number segmentation tracks}
+\label{sec:TCNSegmentationTracks}
+<%
+chromosomes <- getChromosomes(fit);
+nbrOfChromosomes <- length(chromosomes);
+chromosomesH <- seqToHumanReadable(chromosomes);
+chromosomesH <- if (nbrOfChromosomes == 1) {
+ sprintf("Chr %s", chromosomesH);
+} else {
+ sprintf("Chrs %s", chromosomesH);
+}
+chrsTags <- if (nbrOfChromosomes == 1) {
+ sprintf("chr%02d", chromosomes[1]);
+} else {
+ sprintf("chrs%02d-%02d", min(chromosomes), max(chromosomes));
+}
+%>
+\begin{figure}[htbp]
+ \begin{center}
+ <% for (track in c("tcn")) { %>
+ \resizebox{\textwidth}{!}{%
+ \includegraphics{<%={
+ tags <- c(chrsTags, "CBS", gsub("[*-]", "", track), getChecksum(fit));
+ toPNG(name=sampleName, tags=tags, width=1024, aspectRatio=0.25, par=list(mar=c(2.8,4,1,1)+0.1, cex=1.5), {
+ plotTracks(fit, tracks=track, lwd=5, Clim=Clim);
+ }, force=FALSE);
+ }%>}%
+ }%
+ \\
+ <% } # for (track ...) %>
+ \end{center}
+ \caption{
+ Results of CBS segmentation on <%=chromosomesH%> projected onto TCN.
+ There are in total $S=<%=nbrOfSegments(fit, splitters=FALSE)%>$ segments.
+ }
+ \label{fig:CBS}
+\end{figure}
+<% } # tcnSegmentationTracks() %>
+
+<%=tcnSegmentationTracks(fit)%>
+
+
+
+
+
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+% PER CHROMOSOME SEGMENTATION
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+<% if (nbrOfChromosomes(fit) > 1) { %>
+<% for (chr in getChromosomes(fit)) { %>
+\chapter{Chromosome <%=chr%> Results}
+\label{sec:Chromosome<%=chr%>Results}
+<%
+fitT <- extractChromosome(fit, chromosome=chr);
+%>
+<%=summaryOfAnnotation(fitT)%>
+<%=signalDensities(fitT)%>
+<%=tcnSegmentationTracks(fitT)%>
+<% } # for (chr ...) %>
+<% } # if (nbrOfChromosomes(fit) > 1) %>
+
+
+<%--
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+% PRUNED: WHOLE-GENOME SEGMENTATION
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+\section{Hierarchical pruning}
+\label{sec:HierarchicalPruning}
+
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+% PRUNED: PER CHROMOSOME SEGMENTATION
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+--%>
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% REFERENCES
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% \clearpage
+\bibliography{bioinformatics-journals-abbr,PSCBS}
+%\bibliographystyle{plain}
+\bibliographystyle{natbib}
+
+
+\appendix
+\chapter{Appendix}
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Session information
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% \clearpage
+\section*{Session information}
+<%=toLatex(sessionInfo())%>
+This report was automatically generated using \code{rsp()} of the R.rsp package.
+The template for this report was created by Henrik Bengtsson on April 20, 2012.
+\end{document}
+
+<% } # cbsReport() %>
+
+<%=do.call("cbsReport", args=rspArgs)%>
+
+
+
+<%
+######################################################################
+# RSP CLOSEUP
+######################################################################
+# Function for renaming report afterwards
+assign("renamePDF", function() {
+ filename <- sprintf("%s,report.pdf", studyName);
+ pathname <- file.path(reportPath, filename);
+ file.rename("report.pdf", pathname);
+}, envir=globalenv());
+%>
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% HISTORY:
+% 2013-10-18
+% o BUG FIX: Report template assumed that R.utils was attached.
+% 2012-11-03
+% o Replaced deprecated ggplot2 functions.
+% 2012-02-28
+% o Now it is possible to turn off usage of the alpha channel in
+% plots, e.g. setOption("PSCBS::report/useAlphaChannel", FALSE).
+% This is useful for if the alpha channel is not supported.
+% 2012-02-27
+% o First successful run with real data.
+% o Now all of the report uses a PairedPSCBS object.
+% o Now making more use of templates.
+% o Now passing a data frame to segmentByPairedCBS().
+% 2011-09-30
+% o Created.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
diff --git a/inst/templates/rsp/NonPairedPSCBS,report.tex.rsp b/inst/templates/rsp/NonPairedPSCBS,report.tex.rsp
new file mode 100644
index 0000000..10e3f5e
--- /dev/null
+++ b/inst/templates/rsp/NonPairedPSCBS,report.tex.rsp
@@ -0,0 +1,269 @@
+<%--------------------------------------------------------------------
+ This is an RSP LaTeX template for the report system of PSCBS.
+--------------------------------------------------------------------%>
+<%@meta author="Henrik Bengtsson"%>
+<%@meta date="2013-03-21"%>
+
+<%--------------------------------------------------------------------
+Include RSP templates
+--------------------------------------------------------------------%>
+<%@include file="includes/reportHeader.tex.rsp"%>
+
+<%
+library("PSCBS");
+library("R.devices");
+library("R.cache");
+getChecksum <- R.cache::getChecksum;
+stopifnot(exists("rspArgs", mode="list"));
+%>
+
+
+<%--------------------------------------------------------------------
+Report configuration
+--------------------------------------------------------------------%>
+<%@logical SIGNAL_DENSITIES="${PSCBS::reports/signalDensities}" default="TRUE"%>
+<%@logical LEVEL_DENSITIES="${PSCBS::reports/levelDensities}" default="TRUE"%>
+<%@logical C1C2="${PSCBS::reports/pscnSegmentationTransitions}" default="FALSE"%>
+
+<%-- To implement --%>
+<%@logical PER_GENOTYPE="${PSCBS::reports/perGenotype}" default="TRUE"%>
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% LATEX STARTUP
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\documentclass[twoside,12pt]{article}
+\usepackage{fancyvrb} % Custom verbose environments
+\usepackage{lastpage} % Total number of pages
+\usepackage{xspace}
+\usepackage{subfigure} % \subfigure[<title>]{}
+\usepackage[round]{natbib}
+
+% No paragraph indentation
+\setlength{\parindent}{0cm}
+
+\addtolength{\oddsidemargin}{-0.4in}
+\addtolength{\evensidemargin}{-1.02in}
+\addtolength{\textwidth}{1.5in}
+\addtolength{\topmargin}{-1.0in}
+\addtolength{\textheight}{1.5in}
+
+\renewcommand{\topfraction}{1.00} % max fraction of floats at top
+\renewcommand{\bottomfraction}{1.0} % max fraction of floats at bottom
+\renewcommand{\textfraction}{0.00}
+
+<%@include file="includes/reportSetupGraphics.tex.rsp"%>
+<%@include file="includes/reportSetupMacros.tex.rsp"%>
+
+
+<% pairedPSCBSReport <- function(fit, sampleName=sampleName(fit), dataSet=NULL, studyName=NULL, chromosomes=NULL, Clim=c(0,4), Blim=c(0,1), reportPerChromosome=TRUE, ...) { %>
+
+<%@if name="SIGNAL_DENSITIES"%>
+ <%@include file="includes/signalDensities.tex.rsp"%>
+<%@endif%>
+<%@include file="includes/summaryOfAnnotationAndGenotypeCalls.tex.rsp"%>
+<%@include file="includes/pscnSegmentationTracks.tex.rsp"%>
+<%@if name="LEVEL_DENSITIES"%>
+ <%@include file="includes/levelDensities.tex.rsp"%>
+<%@endif%>
+<%@include file="includes/pscnSegmentationTransitions.tex.rsp"%>
+
+<%
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Validate arguments
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Argument 'fit':
+fit <- Arguments$getInstanceOf(fit, "PairedPSCBS");
+fitClass <- class(fit)[1L];
+if (inherits(fit, "NonPairedPSCBS")) {
+ fitClassLbl <- "Non-paired PSCBS";
+} else if (inherits(fit, "PairedPSCBS")) {
+ fitClassLbl <- "Paired PSCBS";
+} else if (inherits(fit, "CBS")) {
+ fitClassLbl <- "CBS";
+} else {
+ fitClassLbl <- fitClass;
+}
+
+# Argument 'sampleName':
+stopifnot(is.character(sampleName));
+sampleName <- Arguments$getCharacter(sampleName);
+sampleNameEscDots <- gsub(".", "_", sampleName, fixed=TRUE);
+
+# Argument 'dataSet':
+if (!is.null(dataSet)) {
+ dataSet <- Arguments$getCharacter(dataSet);
+} else {
+ dataSet <- "?";
+}
+dataSetLbl <- sprintf("Data set: %s\\\\", toLatex(dataSet));
+
+# Argument 'studyName':
+if (is.null(studyName)) studyName <- fitClassLbl;
+studyName <- Arguments$getCharacter(studyName);
+studyLbl <- sprintf("Study: %s\\\\", toLatex(studyName));
+
+# Argument 'chromosomes':
+if (!is.null(chromosomes)) {
+ fit <- extractChromosomes(fit, chromosomes);
+}
+%>
+
+<%reportHeaderSetup(fit, sampleName=sampleName, dataSet=dataSet, studyName=studyName) %>
+<%reportHeaderUpdate(fit)%>
+
+<%
+ClimX <- Clim + c(-1,1)*diff(Clim)*0.08;
+BlimX <- Blim + c(-1,1)*diff(Blim)*0.08;
+%>
+
+\begin{document}
+\title{<%=fitClassLbl%> Report:\\<%=studyLbl%><%=dataSetLbl%>Sample: <%=toLatex(sampleName)%>}
+\author{Report template by <%@meta name="author"%>}
+\maketitle
+\thispagestyle{fancy}
+
+%%\tableofcontents
+
+%>
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% DATA
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% METHODS
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\section{Introduction}
+\label{sec:Introduction}
+This is a quality control (QC) report based on non-paired tumor SNP microarray data.
+
+\subsection{Method}
+\label{sec:Method}
+We use a non-paired PSCBS segmentation method to partion the genome into segments such that all signals in a particular segment are likely to originate from the same underlying parent-specific copy-number state. This method is adopted from the Paired PSCBS segmentation method~\citep{OlshenA_etal_2011} with two main differences.
+First, heterozygous SNPs are "called" based on tumor allele B fractions ("tumor BAFs"), which are poor proxies for the corresponding normal ones. This is a major disadvantage compared to having a matched normal.
+Second, the tumor BAFs cannot be normalized using the TumorBoost method~\citep{BengtssonH_etal_2010}.
+
+
+<%--
+\subsection{Post-segmentation pruning}
+\label{sec:PostSegmentationPruning}
+<%
+fitP <- pruneByHClust(fit, h=0.25);
+#print(fitP);
+%>
+--%>
+
+\clearpage
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% RESULTS
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+% WHOLE-GENOME RESULTS
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+\section{Whole-Genome Results}
+\label{ch:WholeGenomeResults}
+
+<%=summaryOfAnnotationAndGenotypeCalls(fit)%>
+<%@if name="SIGNAL_DENSITIES"%>
+<%=signalDensities(fit, fields=c("CT", "betaT", "rho", "c1", "c2"))%>
+<%@endif%>
+<%=pscnSegmentationTracks(fit)%>
+<%@if name="LEVEL_DENSITIES"%>
+<%=levelDensities(fit, fields=c("tcn", "dh", "c1", "c2"))%>
+<%@endif%>
+<%@if name="C1C2"%>
+<%=pscnSegmentationTransitions(fit)%>
+<%@endif%>
+
+
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+% PER CHROMOSOME SEGMENTATION
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+<% if (reportPerChromosome && nbrOfChromosomes(fit) > 1) { %>
+<% for (chr in getChromosomes(fit)) { %>
+<%
+fitT <- extractChromosome(fit, chromosome=chr);
+%>
+\clearpage
+\section{Chromosome <%=chr%>}
+\label{sec:Chromosome<%=chr%>Results}
+<%reportHeaderUpdate(fit)%>
+<%=summaryOfAnnotationAndGenotypeCalls(fitT)%>
+<%@if name="SIGNAL_DENSITIES"%>
+<%=signalDensities(fitT, fields=c("CT", "betaT", "rho", "c1", "c2"))%>
+<%@endif%>
+<%=pscnSegmentationTracks(fitT)%>
+<%---
+<%@if name="LEVEL_DENSITIES"%>
+<%=levelDensities(fitT, fields=c("tcn", "dh", "c1", "c2"))%>
+<%@endif%>
+---%>
+<%@if name="C1C2"%>
+<%=pscnSegmentationTransitions(fitT)%>
+<%@endif%>
+<% } # for (chr ...) %>
+<% } # if (reportPerChromosome && nbrOfChromosomes(fit) > 1) %>
+
+
+<%--
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+% PRUNED: WHOLE-GENOME SEGMENTATION
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+\subsection{Hierarchical pruning}
+\label{sec:HierarchicalPruning}
+
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+% PRUNED: PER CHROMOSOME SEGMENTATION
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+--%>
+
+
+\clearpage
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% REFERENCES
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+<%@include file="includes/references.tex.rsp"%>
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% APPENDIX
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\appendix
+\section{Appendix}
+<%@include file="includes/sessionInfo.tex.rsp"%>
+
+\end{document}
+
+<% } # pairedPSCBSReport() %>
+
+<%---
+<%
+message(paste(capture.output({ str(rspArgs) }), collapse="\n"));
+message(paste(capture.output({ ll() }), collapse="\n"));
+%>
+---%>
+<%=do.call("pairedPSCBSReport", args=rspArgs)%>
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% HISTORY:
+# 2012-11-03
+# o Replaced deprecated ggplot2 functions.
+# 2012-09-16
+# o Added easy report configuration at the very top.
+# 2012-05-30
+# o Removed ggplot2 warnings on missing values.
+# 2012-02-28
+# o Now it is possible to turn off usage of the alpha channel in
+# plots, e.g. setOption("PSCBS::report/useAlphaChannel", FALSE).
+# This is useful for if the alpha channel is not supported.
+% 2012-02-27
+% o First successful run with real data.
+% o Now all of the report uses a PairedPSCBS object.
+% o Now making more use of templates.
+% o Now passing a data frame to segmentByPairedCBS().
+% 2011-09-30
+% o Created.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
diff --git a/inst/templates/rsp/PSCBS.bib b/inst/templates/rsp/PSCBS.bib
new file mode 100644
index 0000000..d06fd93
--- /dev/null
+++ b/inst/templates/rsp/PSCBS.bib
@@ -0,0 +1,139 @@
+ at ARTICLE{BengtssonH_etal_2010,
+ author = {Henrik Bengtsson and Pierre Neuvial and Terence P Speed},
+ title = {{TumorBoost}: Normalization of allele-specific tumor copy numbers
+ from a single pair of tumor-normal genotyping microarrays},
+ journal = {BMC Bioinformatics},
+ year = {2010},
+ volume = {11},
+ pages = {245},
+ number = {1},
+ month = {May},
+ abstract = {ABSTRACT: BACKGROUND: High-throughput genotyping microarrays assess
+ both total DNA copy number and allelic composition, which makes them
+ a tool of choice for copy number studies in cancer, including total
+ copy number and loss of heterozygosity (LOH) analyses. Even after
+ state of the art preprocessing methods, allelic signal estimates
+ from genotyping arrays still suffer from systematic effects that
+ make them difficult to use effectively for such downstream analyses.
+ RESULTS: We propose a method, TumorBoost, for normalizing allelic
+ estimates of one tumor sample based on estimates from a single matched
+ normal. The method applies to any paired tumor-normal estimates from
+ any microarray-based technology, combined with any preprocessing
+ method. We demonstrate that it increases the signal-to-noise ratio
+ of allelic signals, making it significantly easier to detect allelic
+ imbalances. CONCLUSIONS: TumorBoost increases the power to detect
+ somatic copy-number events (including copy-neutral LOH) in the tumor
+ from allelic signals of Affymetrix or Illumina origin. We also conclude
+ that high-precision allelic estimates can be obtained from a single
+ pair of tumor-normal hybridizations, if TumorBoost is combined with
+ single-array preprocessing methods such as (allele-specific) CRMA
+ v2 for Affymetrix or BeadStudio's (proprietary) XY-normalization
+ method for Illumina. A bounded-memory implementation is available
+ in the open-source and cross-platform R package aroma.cn, which is
+ part of the Aroma Project (http://www.aroma-project.org/).},
+ doi = {10.1186/1471-2105-11-245},
+ file = {:BengtssonH_etal_2010-TumorBoost.pdf:PDF},
+ language = {eng},
+ medline-pst = {aheadofprint},
+ owner = {hb},
+ pii = {1471-2105-11-245},
+ pmid = {20462408},
+ timestamp = {2010.05.15},
+ url = {http://dx.doi.org/10.1186/1471-2105-11-245}
+}
+
+ at ARTICLE{OlshenA_etal_2011,
+ author = {Adam B. Olshen and Henrik Bengtsson and Pierre Neuvial and Paul Spellman
+ and Richard A. Olshen and Venkatraman E. Seshan},
+ title = {Parent-specific copy number in paired tumor-normal studies using
+ circular binary segmentation},
+ journal = {Bioinformatics},
+ year = {2011},
+ volume = {27},
+ pages = {2038-2046},
+ number = {15},
+ doi = {10.1093/bioinformatics/btr329},
+ pmid = {21666266},
+ url = {http://bioinformatics.oxfordjournals.org/content/27/15/2038}
+}
+
+
+ at ARTICLE{VenkatramanOlshen_2007,
+ author = {E. S. Venkatraman and Adam B Olshen},
+ title = {{A} faster circular binary segmentation algorithm for the analysis
+ of array {CGH} data.},
+ journal = {Bioinformatics},
+ year = {2007},
+ volume = {23},
+ pages = {657--663},
+ number = {6},
+ month = {Mar},
+ abstract = {MOTIVATION: Array CGH technologies enable the simultaneous measurement
+ of DNA copy number for thousands of sites on a genome. We developed
+ the circular binary segmentation (CBS) algorithm to divide the genome
+ into regions of equal copy number. The algorithm tests for change-points
+ using a maximal t-statistic with a permutation reference distribution
+ to obtain the corresponding P-value. The number of computations required
+ for the maximal test statistic is O(N2), where N is the number of
+ markers. This makes the full permutation approach computationally
+ prohibitive for the newer arrays that contain tens of thousands markers
+ and highlights the need for a faster algorithm. RESULTS: We present
+ a hybrid approach to obtain the P-value of the test statistic in
+ linear time. We also introduce a rule for stopping early when there
+ is strong evidence for the presence of a change. We show through
+ simulations that the hybrid approach provides a substantial gain
+ in speed with only a negligible loss in accuracy and that the stopping
+ rule further increases speed. We also present the analyses of array
+ CGH data from breast cancer cell lines to show the impact of the
+ new approaches on the analysis of real data. AVAILABILITY: An R version
+ of the CBS algorithm has been implemented in the "DNAcopy" package
+ of the Bioconductor project. The proposed hybrid method for the P-value
+ is available in version 1.2.1 or higher and the stopping rule for
+ declaring a change early is available in version 1.5.1 or higher.},
+ doi = {10.1093/bioinformatics/btl646},
+ file = {VenkatramanOlshen_2007-A faster circular binary segmentation algorithm for the analysis of array CGH data.pdf:VenkatramanOlshen_2007-A faster circular binary segmentation algorithm for the analysis of array CGH data.pdf:PDF},
+ keywords = {Algorithms; Chromosome Mapping, methods; Gene Dosage, genetics; Oligonucleotide
+ Array Sequence Analysis, methods; Programming Languages; Sequence
+ Alignment, methods; Sequence Analysis, DNA, methods; Software; Time
+ Factors},
+ owner = {hb},
+ pii = {btl646},
+ pmid = {17234643},
+ timestamp = {2007.02.02},
+ url = {http://dx.doi.org/10.1093/bioinformatics/btl646}
+}
+
+
+ at ARTICLE{OlshenA_etal_2004,
+ author = {Adam B Olshen and E. S. Venkatraman and Robert Lucito and Michael
+ Wigler},
+ title = {Circular binary segmentation for the analysis of array-based DNA
+ copy number data.},
+ journal = {Biostatistics},
+ year = {2004},
+ volume = {5},
+ pages = {557--572},
+ number = {4},
+ month = {Oct},
+ abstract = {DNA sequence copy number is the number of copies of DNA at a region
+ of a genome. Cancer progression often involves alterations in DNA
+ copy number. Newly developed microarray technologies enable simultaneous
+ measurement of copy number at thousands of sites in a genome. We
+ have developed a modification of binary segmentation, which we call
+ circular binary segmentation, to translate noisy intensity measurements
+ into regions of equal copy number. The method is evaluated by simulation
+ and is demonstrated on cell line data with known copy number alterations
+ and on a breast cancer cell line data set.},
+ doi = {10.1093/biostatistics/kxh008},
+ file = {OlshenA_etal_2004-Circular binary segmentation for the analysis of array-based DNA copy number data.pdf:OlshenA_etal_2004-Circular binary segmentation for the analysis of array-based DNA copy number data.pdf:PDF},
+ keywords = {Breast Neoplasms; Cell Line, Tumor; Computer Simulation; Female; Gene
+ Dosage; Genome, Human; Humans; Olig; e Analysis; onucleotide Array
+ Sequence;
+
+ CBS},
+ owner = {hb},
+ pii = {5/4/557},
+ pmid = {15475419},
+ timestamp = {2007.07.09},
+ url = {http://dx.doi.org/10.1093/biostatistics/kxh008}
+}
diff --git a/inst/templates/rsp/PairedPSCBS,report.tex.rsp b/inst/templates/rsp/PairedPSCBS,report.tex.rsp
new file mode 100644
index 0000000..f66a490
--- /dev/null
+++ b/inst/templates/rsp/PairedPSCBS,report.tex.rsp
@@ -0,0 +1,670 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Authors: Henrik Bengtsson
+% Created on: 2011-09-30
+% Last updated: See HISTORY below.
+%
+% Usage: (compiles *.tex.rsp => tex.rsp.R => *.tex => *.dvi)
+% R.rsp::rsp("PairedPSCBS.tex.rsp", path="reports,rsp/");
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+<%
+library("PSCBS");
+library("R.devices");
+library("R.cache");
+library("R.utils"); # setOption()
+stopifnot(exists("rspArgs", mode="list"));
+%>
+
+
+<%
+# = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+# REPORT CONFIGURATION
+# = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+REPORT_DENSITIES <- getOption("PSCBS::reports/densities", TRUE);
+REPORT_TUMORBOOST <- getOption("PSCBS::reports/TumorBoost", TRUE);
+REPORT_USE_ALPHA_CHANNEL <- getOption("PSCBS::report/useAlphaChannel", TRUE);
+REPORT_PER_CHROMOSOME <- getOption("PSCBS::reports/perChromosome", TRUE);
+REPORT_C1C2 <- getOption("PSCBS::reports/pscnSegmentationTransitions", FALSE);
+# To implement:
+REPORT_PER_GENOTYPE <- getOption("PSCBS::reports/perGenotype", TRUE);
+%>
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% LATEX STARTUP
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\documentclass[twoside,12pt]{report}
+\usepackage{fancyvrb}
+\usepackage{xspace}
+\usepackage{subfigure} % \subfigure[<title>]{}
+\usepackage[round]{natbib}
+
+\addtolength{\oddsidemargin}{-0.5in}
+\addtolength{\evensidemargin}{-0.5in}
+\addtolength{\textwidth}{1in}
+\addtolength{\topmargin}{-0.8in}
+\addtolength{\textheight}{1.3in}
+
+\renewcommand{\topfraction}{1.00} % max fraction of floats at top
+\renewcommand{\bottomfraction}{1.0} % max fraction of floats at bottom
+\renewcommand{\textfraction}{0.00}
+
+\usepackage{fancyhdr}
+\pagestyle{fancy}
+%% \fancyhead{} % clear all header fields
+%% \fancyfoot{} % clear all footer fields
+%% \fancyhead[LE,RO]{\slshape \rightmark}
+%% \fancyfoot[C]{\thepage}
+
+\fancyhf{}
+\fancyhead[LE,RO]{\thepage}
+\fancyhead[RE]{\textit{\nouppercase{\leftmark}}}
+\fancyhead[LO]{\textit{\nouppercase{\rightmark}}}
+
+\newcommand{\code}[1]{\texttt{#1}\xspace}
+
+
+\newcommand{\TCN}{TCN\xspace}
+\newcommand{\BAF}{\BAF\xspace}
+\newcommand{\BAFN}{BAF$_{N}$\xspace}
+\newcommand{\BAFT}{BAF$_{T}$\xspace}
+\newcommand{\BAFTN}{BAF$^*_{T}$\xspace}
+
+
+<% pairedPSCBSReport <- function(fit, sampleName=NULL, dataSet=NULL, studyName="PairedPSCBS", Clim=c(0,4), Blim=c(0,1), reportPath=file.path("reports", studyName), figPath=file.path(reportPath, "figures"), ..., figForce=FALSE) { %>
+<%
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Validate arguments
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Argument 'fit':
+fit <- Arguments$getInstanceOf(fit, "PairedPSCBS");
+
+# Argument 'sampleName':
+if (is.null(sampleName)) {
+ sampleName <- sampleName(fit);
+}
+sampleName <- Arguments$getCharacter(sampleName);
+
+# Argument 'dataSet':
+if (!is.null(dataSet)) {
+ dataSet <- Arguments$getCharacter(dataSet);
+}
+
+# Argument 'studyName':
+studyName <- Arguments$getCharacter(studyName);
+
+# Argument 'reportPath':
+reportPath <- Arguments$getWritablePath(reportPath);
+
+# Argument 'figPath':
+figPath <- Arguments$getWritablePath(figPath);
+
+# Argument 'figForce':
+figForce <- Arguments$getLogical(figForce);
+%>
+
+<%
+oFigPath <- setOption("devEval/args/path", figPath);
+on.exit({
+ setOption("devEval/args/path", oFigPath);
+}, add=TRUE);
+
+oPar <- setOption("devNew/args/par", list(lwd=2));
+on.exit({
+ setOption("devNew/args/par", oPar);
+}, add=TRUE);
+%>
+
+<%
+studyLbl <- sprintf("Study: %s\\\\", toLatex(studyName));
+if (!is.null(dataSet)) {
+ dataSetLbl <- sprintf("Data set: %s\\\\", toLatex(dataSet));
+} else {
+ dataSetLbl <- "";
+}
+%>
+
+\title{Paired PSCBS Report:\\<%=studyLbl%><%=dataSetLbl%>Sample: <%=toLatex(sampleName)%>}
+\author{Report template by Henrik Bengtsson}
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+% GRAPHICS SETTINGS
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+<%
+setOption("devEval/args/force", figForce);
+%>
+\usepackage{graphicx}
+\graphicspath{{<%=figPath%>/} {../<%=figPath%>/}}
+
+<%
+# GGPLOT2 SETTINGS
+ClimX <- Clim + c(-1,1)*diff(Clim)*0.08;
+BlimX <- Blim + c(-1,1)*diff(Blim)*0.08;
+
+muNCols <- c("#999999", "#000000", "#999999");
+
+require("ggplot2") || throw("Package not loaded: ggplot2");
+xnbrOpts <- element_text(colour="grey50", size=20, hjust=1, lineheight=0.9);
+ynbrOpts <- element_text(colour="grey50", size=20, vjust=1, lineheight=0.9);
+xlabOpts <- element_text(colour="black", size=28, hjust=0.5);
+ylabOpts <- element_text(colour="black", size=28, vjust=0.5, angle=90);
+
+labList <- list(
+ CT = expression(C[T]),
+ betaN = expression(beta[N]),
+ betaT = expression(beta[T]),
+ betaTN = expression(tilde(beta)[T]),
+ rho = expression(rho),
+ rhoN = expression(tilde(rho)),
+ c1 = expression(C[1]),
+ c2 = expression(C[2]),
+ c1N = expression(tilde(C)[1]),
+ c2N = expression(tilde(C)[2])
+);
+
+symbolList <- list(
+ CT = "$C_{T}$",
+ betaN = "$\\beta_{N}$",
+ betaT = "$\\beta_{T}$",
+ betaTN = "$\\tilde{\\beta}_{T}$",
+ rho = "$\\rho$",
+ rhoN = "$\\tilde{\\rho}$",
+ c1 = "$C_{1}$",
+ c2 = "$C_{2}$",
+ c1N = "$\\tilde{C}_{1}$",
+ c2N = "$\\tilde{C}_{2}$"
+);
+%>
+
+\begin{document}
+
+\maketitle
+\begin{abstract}
+This is a quality control (QC) report on the paired tumor-normal sample '<%=toLatex(sampleName)%>' in data set '<%=toLatex(dataSet)%>'.
+\end{abstract}
+
+\tableofcontents
+
+\clearpage
+
+
+%>
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% DATA
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Introduction}
+
+\chapter{Data}
+\label{ch:Data}
+
+\section{Samples}
+
+\section{Microarray data}
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% METHODS
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Methods}
+\label{ch:Methods}
+
+\section{Segmentation}
+\label{sec:Segmentation}
+We use the Paired PSCBS segmentation method~\citep{OlshenA_etal_2011} with TumorBoost normalization~\citep{BengtssonH_etal_2010} to partion the genome into segments such that all signals in a particular segment are likely to originate from the same underlying parent-specific copy-number state.
+Germline genotypes are called based on the normal allele B fractions (BAFs), cf.~\citet{BengtssonH_etal_2010}.
+
+
+<%--
+\section{Post-segmentation pruning}
+\label{sec:PostSegmentationPruning}
+<%
+fitP <- pruneByHClust(fit, h=0.25);
+#print(fitP);
+%>
+--%>
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% RESULTS
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+% WHOLE-GENOME RESULTS
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+\chapter{Whole-Genome Results}
+\label{ch:WholeGenomeResults}
+
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+% SUMMARY ANNOTATION AND GENOTYPE CALLS
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+<% summaryOfAnnotationAndGenotypeCalls <- function(fit, ...) { %>
+\section{Summary of annotation and genotype calls}
+<%
+data <- getLocusData(fit, fields="full");
+nbrOfLoci <- nrow(data);
+nbrOfSNPs <- sum(data$isSNP, na.rm=TRUE);
+nbrOfHets <- sum(data$isHet, na.rm=TRUE);
+
+chromosomes <- getChromosomes(fit);
+nbrOfChromosomes <- length(chromosomes);
+chromosomesH <- seqToHumanReadable(chromosomes);
+chromosomesH <- if (nbrOfChromosomes == 1) {
+ sprintf("Chr %s", chromosomesH);
+} else {
+ sprintf("Chrs %s", chromosomesH);
+}
+chrsTags <- if (nbrOfChromosomes == 1) {
+ sprintf("chr%02d", chromosomes[1]);
+} else {
+ sprintf("chrs%02d-%02d", min(chromosomes), max(chromosomes));
+}
+%>
+
+\begin{table}[htbp]
+ \begin{center}
+ \begin{tabular}{lrr}
+ Description & Count & Fraction \\
+ \hline
+ Number of loci & <%=nbrOfLoci%> & 100.00\% \\
+ Number of SNPs & <%=nbrOfSNPs%> & <%=sprintf("%.2f", 100*nbrOfSNPs/nbrOfLoci)%>\% \\
+ Number of heterozygous SNPs* & <%=nbrOfHets%> & <%=sprintf("%.2f", 100*nbrOfHets/nbrOfSNPs)%>\% \\
+ Number of non-polymorphic loci & <%=nbrOfLoci-nbrOfSNPs%> & <%=sprintf("%.2f", 100*(1-nbrOfSNPs/nbrOfLoci))%>\% \\
+ Number of chromosomes & <%=nbrOfChromosomes%> & - \\
+ \end{tabular}
+ \caption{
+ Summary of the locus-level data on <%=chromosomesH%>.
+ A locus is considered to be a SNP if it has either a non-missing BAF for either the tumor or the normal.
+ (*) Genotype calls are based on (whole-genome) naive genotyping of the germline BAFs.
+ }
+ \label{tbl:LocusStats}
+ \end{center}
+\end{table}
+
+<% } # summaryOfAnnotationAndGenotypeCalls() %>
+
+
+<%=summaryOfAnnotationAndGenotypeCalls(fit)%>
+
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+% SIGNAL DENSITIES
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+<% signalDensities <- function(fit, ...) { %>
+<% if (!REPORT_DENSITIES) return(); %>
+\clearpage
+\section{Signal densities}
+\label{sec:SignalDensities}
+<%
+require("ggplot2") || throw("Package not loaded: ggplot2");
+data <- getLocusData(fit, fields="full");
+chromosomes <- getChromosomes(fit);
+nbrOfChromosomes <- length(chromosomes);
+chromosomesH <- seqToHumanReadable(chromosomes);
+chromosomesH <- if (nbrOfChromosomes == 1) {
+ sprintf("Chr %s", chromosomesH);
+} else {
+ sprintf("Chrs %s", chromosomesH);
+}
+chrsTags <- if (nbrOfChromosomes == 1) {
+ sprintf("chr%02d", chromosomes[1]);
+} else {
+ sprintf("chrs%02d-%02d", min(chromosomes), max(chromosomes));
+}
+%>
+\begin{figure}[htbp]
+ \begin{center}
+<%
+ fields <- c("CT", "betaN", "betaT", "rho", "c1", "c2", "betaTN", "rhoN", "c1N", "c2N");
+%>
+<% for (ff in fields) { %>
+<%
+ symbol <- symbolList[[ff]];
+ panelTitle <- switch(ff, CT="\\TCN", betaN="\\BAFN", betaT="\\BAFT", betaTN="\\BAFTN", "NNN");
+ lim <- switch(ff, CT=ClimX, c1=ClimX, c2=ClimX, c1N=ClimX, c2N=ClimX, BlimX);
+%>
+\raisebox{4ex}{<%=symbol%>}
+<% for (by in c("all", "muN")) { %>
+<%
+ tags <- c(chrsTags, by, ff);
+%>
+ \resizebox{0.33\textwidth}{!}{%
+ \includegraphics{<%={
+ toPNG(name=sampleName, tags=tags, width=640, aspectRatio=0.3, {
+ gg <- ggplot(data, aes_string(x=ff, y="..count.."));
+
+ if (by == "all") {
+ if (ff == "CT" && any(!data$isSNP, na.rm=TRUE)) {
+ gg <- gg + aes(group=type, colour=type);
+ }
+ } else if (by == "muN") {
+ gg <- gg + aes_string(group="muNx", colour="muNx");
+ gg <- gg + scale_color_manual(values=muNCols);
+ }
+
+ # See https://github.com/hadley/ggplot2/wiki/Legend-Attributes
+ gg <- gg + theme(legend.position=c(0.97, 0.75),
+ legend.justification = 1,
+ legend.direction="vertical",
+ legend.title=element_text(size=0),
+ legend.text=element_text(size=16));
+
+ gg <- gg + geom_density(size=2, na.rm=TRUE);
+ gg <- gg + xlab(NULL);
+ gg <- gg + ylab(NULL);
+ gg <- gg + xlim(lim);
+ gg <- gg + theme(axis.text.x=xnbrOpts, axis.text.y=ynbrOpts);
+ gg <- gg + theme(axis.title.x=xlabOpts, axis.title.y=ylabOpts);
+ suppressWarnings({
+ print(gg);
+ });
+ }, force=FALSE);
+ }%>}%
+ }%
+<% } # for (by ...) %>
+\\ %
+<% } # for (ff ...) %>
+ \end{center}
+ \caption{
+ Density estimates of locus-level signals on <%=chromosomesH%> with and without TumorBoost normalization. The signals in the left and right panels are without and with stratification on genotype calls (AA and BB in gray and AB in black).
+ We expect to see three genotype groups for the normal BAFs ($\beta_{N}$).
+ The tumor BAFs ($\beta_{T}$) should be more distinct after normalization
+ ($\tilde{\beta}_{T}$), particularly for homozygous SNPs.
+ If there are no allelic imbalances in the tumor, then the density of
+ the tumor should be similar to that of the normal.
+ }
+ \label{fig:SignalDensity}
+\end{figure}
+<% } # signalDensities() %>
+
+<%=signalDensities(fit)%>
+
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+% BEFORE AND AFTER TUMORBOOST
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+<% beforeAndAfterTumorBoost <- function(fit, ...) { %>
+<% if (!REPORT_TUMORBOOST) return(); %>
+\clearpage
+\section{Before and after TumorBoost}
+\label{sec:BeforeAndAfterTumorBoost}
+\begin{figure}[htbp]
+ \begin{center}
+<%
+require("ggplot2") || throw("Package not loaded: ggplot2");
+data <- getLocusData(fit, fields="full");
+chromosomes <- getChromosomes(fit);
+nbrOfChromosomes <- length(chromosomes);
+chromosomesH <- seqToHumanReadable(chromosomes);
+chromosomesH <- if (nbrOfChromosomes == 1) {
+ sprintf("Chr %s", chromosomesH);
+} else {
+ sprintf("Chrs %s", chromosomesH);
+}
+chrsTags <- if (nbrOfChromosomes == 1) {
+ sprintf("chr%02d", chromosomes[1]);
+} else {
+ sprintf("chrs%02d-%02d", min(chromosomes), max(chromosomes));
+}
+%>
+<%
+dataT <- subset(data, type == "SNP");
+%>
+<% for (ff in c("betaT", "betaTN")) { %>
+ \resizebox{0.40\textwidth}{!}{%
+ \includegraphics{<%={
+ tags <- c(chrsTags, sprintf("%s-vs-betaN", ff));
+ toPNG(name=sampleName, tags=tags, width=640, aspectRatio=0.85, {
+ gg <- ggplot(dataT, aes_string(x="betaN", y=ff));
+ gg <- gg + aes_string(group="muNx", colour="muNx");
+ gg <- gg + scale_color_manual(values=muNCols);
+
+ # See https://github.com/hadley/ggplot2/wiki/Legend-Attributes
+ gg <- gg + theme(#legend.position=c(0.97, 0.85),
+ #legend.justification = 1,
+ legend.direction="vertical",
+ legend.title=element_text(size=0),
+ legend.text=element_text(size=16));
+
+ if (REPORT_USE_ALPHA_CHANNEL) {
+ gg <- gg + geom_point(alpha=min(10e3/nrow(dataT), 0.5), na.rm=TRUE);
+ } else {
+ gg <- gg + geom_point(na.rm=TRUE);
+ }
+ gg <- gg + xlab(labList[["betaN"]]) + ylab(labList[[ff]]);
+ gg <- gg + xlim(BlimX) + ylim(BlimX);
+ gg <- gg + theme(axis.text.x=xnbrOpts, axis.text.y=ynbrOpts);
+ gg <- gg + theme(axis.title.x=xlabOpts, axis.title.y=ylabOpts);
+ print(gg);
+ });
+ }%>}%
+ }%
+<% } # for (ff ...) %>
+ \end{center}
+ \caption{
+ Tumor-normal BAFs before (left) and after (right) TumorBoost normalization
+ on <%=chromosomesH%>.
+ We expect to see only two homozygote groups. If there are more, then the
+ tumor and the normal BAFs are not from the same individual.
+ If there are no allelic imbalances in the tumor, then there is
+ also only one heterozygous group.
+ }
+ \label{fig:BAFBAF}
+\end{figure}
+<% } # beforeAndAfterTumorBoost() %>
+
+<%=beforeAndAfterTumorBoost(fit)%>
+
+
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+% PARENT-SPECIFIC COPY-NUMBER SEGMENTATION TRACKS
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+<% pscnSegmentationTracks <- function(fit, ...) { %>
+\clearpage
+\section{Parent-specific copy-number segmentation tracks}
+\label{sec:PSCNSegmentationTracks}
+<%
+chromosomes <- getChromosomes(fit);
+nbrOfChromosomes <- length(chromosomes);
+chromosomesH <- seqToHumanReadable(chromosomes);
+chromosomesH <- if (nbrOfChromosomes == 1) {
+ sprintf("Chr %s", chromosomesH);
+} else {
+ sprintf("Chrs %s", chromosomesH);
+}
+chrsTags <- if (nbrOfChromosomes == 1) {
+ sprintf("chr%02d", chromosomes[1]);
+} else {
+ sprintf("chrs%02d-%02d", min(chromosomes), max(chromosomes));
+}
+%>
+\begin{figure}[htbp]
+ \begin{center}
+ <% for (track in c("tcn", "dh", "tcn,c1,c2")) { %>
+<%-- <% for (track in c("tcn*", "betaT", "betaTN*", "dh*", "tcn*,c1*,c2-*")) { %> --%>
+ \resizebox{\textwidth}{!}{%
+ \includegraphics{<%={
+ tags <- c(chrsTags, "PairedPSCBS", gsub("[*-]", "", track), getChecksum(fit));
+ toPNG(name=sampleName, tags=tags, width=1024, aspectRatio=0.25, par=list(mar=c(2.8,4,1,1)+0.1, cex=1.5), {
+ plotTracks(fit, tracks=track, lwd=5, Clim=Clim);
+# plotTrack2(fit, panels=track, lwd=5, Clim=Clim);
+ }, force=FALSE);
+ }%>}%
+ }%
+ \\
+ <% } # for (track ...) %>
+ \end{center}
+ \caption{
+ Results of Paired PSCBS segmentation on <%=chromosomesH%> projected onto
+ TCN (top), \BAFT (row 2), \BAFTN (row 3), DH (row 4), as well as TCN, $C_1$ and $C_2$ (bottom).
+ Paired PSCBS segmentation is always done on TCN and DH data.
+ There are in total $S=<%=nbrOfSegments(fit, splitters=FALSE)%>$ segments.
+ }
+ \label{fig:PairedPSCBS}
+\end{figure}
+<% } # pscnSegmentationTracks() %>
+
+<%=pscnSegmentationTracks(fit)%>
+
+
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+% PARENT-SPECIFIC COPY-NUMBER TRANSITIONS
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+<% pscnSegmentationTransitions <- function(fit, ...) { %>
+<% if (!REPORT_C1C2) return(); %>
+\clearpage
+\section{Parent-specific copy-number transitions}
+\label{sec:PSCNSegmentationTransitions}
+<%
+# plotC1C2Grid()
+require("aroma.cn") || throw("Package not loaded: aroma.cn");
+
+chromosomes <- getChromosomes(fit);
+nbrOfChromosomes <- length(chromosomes);
+chromosomesH <- seqToHumanReadable(chromosomes);
+chromosomesH <- if (nbrOfChromosomes == 1) {
+ sprintf("Chr %s", chromosomesH);
+} else {
+ sprintf("Chrs %s", chromosomesH);
+}
+chrsTags <- if (nbrOfChromosomes == 1) {
+ sprintf("chr%02d", chromosomes[1]);
+} else {
+ sprintf("chrs%02d-%02d", min(chromosomes), max(chromosomes));
+}
+%>
+\begin{figure}[htbp]
+ \begin{center}
+ \resizebox{0.6\textwidth}{!}{%
+ \includegraphics{<%={
+ tags <- c(chrsTags, "PairedPSCBS", "C1C2", getChecksum(fit));
+ toPNG(name=sampleName, tags=tags, width=640, aspectRatio=1, par=list(mar=c(4,4,1,1)+0.1, cex=2), {
+ plotC1C2Grid(fit, Clim=ClimX);
+ linesC1C2(fit, lwd=2);
+ }, force=FALSE);
+ }%>}%
+ }%
+ \end{center}
+ \caption{
+ A graph representation of the minor ($C_1$) and major ($C_2$)
+ copy-number segmentation on <%=chromosomesH%>,
+ where the nodes represent ($S=<%=nbrOfSegments(fit, splitters=FALSE)%>$)
+ segments and the lines change points.
+ The size of a node reflects the length of the corresponding segment.
+ The marginal distributions (gray curves) of the minor and the major CNs
+ are projected onto the horizontal and vertical axis, respectively.
+ To easy a visual comparison, the latter is also projected onto the
+ horizontal axis (light blue curve).
+ }
+ \label{fig:C1C2}
+\end{figure}
+<% } # pscnSegmentationTransitions() %>
+
+<%=pscnSegmentationTransitions(fit)%>
+
+
+
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+% PER CHROMOSOME SEGMENTATION
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+<% if (REPORT_PER_CHROMOSOME && nbrOfChromosomes(fit) > 1) { %>
+<% for (chr in getChromosomes(fit)) { %>
+\chapter{Chromosome <%=chr%> Results}
+\label{sec:Chromosome<%=chr%>Results}
+<%
+fitT <- extractChromosome(fit, chromosome=chr);
+%>
+<%=summaryOfAnnotationAndGenotypeCalls(fitT)%>
+
+<%=signalDensities(fitT)%>
+
+<%=beforeAndAfterTumorBoost(fitT)%>
+
+<%=pscnSegmentationTracks(fitT)%>
+
+<%=pscnSegmentationTransitions(fitT)%>
+<% } # for (chr ...) %>
+<% } # if (REPORT_PER_CHROMOSOME && nbrOfChromosomes(fit) > 1) %>
+
+
+<%--
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+% PRUNED: WHOLE-GENOME SEGMENTATION
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+\section{Hierarchical pruning}
+\label{sec:HierarchicalPruning}
+
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+% PRUNED: PER CHROMOSOME SEGMENTATION
+% = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+--%>
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% REFERENCES
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% \clearpage
+\bibliography{bioinformatics-journals-abbr,PSCBS}
+%\bibliographystyle{plain}
+\bibliographystyle{natbib}
+
+
+\appendix
+\chapter{Appendix}
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Session information
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% \clearpage
+\section*{Session information}
+<%=toLatex(sessionInfo())%>
+This report was automatically generated using \code{rsp()} of the R.rsp package.
+The template for this report was created by Henrik Bengtsson on April 20, 2012.
+\end{document}
+
+<% } # pairedPSCBSReport() %>
+
+<%=do.call("pairedPSCBSReport", args=rspArgs)%>
+
+
+
+<%
+######################################################################
+# RSP CLOSEUP
+######################################################################
+# Function for renaming report afterwards
+assign("renamePDF", function() {
+ filename <- sprintf("%s,report.pdf", studyName);
+ pathname <- file.path(reportPath, filename);
+ file.rename("report.pdf", pathname);
+}, envir=globalenv());
+%>
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% HISTORY:
+% 2014-05-24
+# o Replaced a deprecated opts() of ggplot2 with theme().
+% 2013-10-18
+% o BUG FIX: Report template assumed that R.utils was attached.
+% 2012-11-03
+% o Replaced deprecated ggplot2 functions.
+% 2012-09-16
+% o Added easy report configuration at the very top.
+% 2012-05-30
+% o Removed ggplot2 warnings on missing values.
+% 2012-02-28
+% o Now it is possible to turn off usage of the alpha channel in
+% plots, e.g. setOption("PSCBS::report/useAlphaChannel", FALSE).
+% This is useful for if the alpha channel is not supported.
+% 2012-02-27
+% o First successful run with real data.
+% o Now all of the report uses a PairedPSCBS object.
+% o Now making more use of templates.
+% o Now passing a data frame to segmentByPairedCBS().
+% 2011-09-30
+% o Created.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
diff --git a/inst/templates/rsp/bioinformatics-journals-abbr.bib b/inst/templates/rsp/bioinformatics-journals-abbr.bib
new file mode 100644
index 0000000..cef4a86
--- /dev/null
+++ b/inst/templates/rsp/bioinformatics-journals-abbr.bib
@@ -0,0 +1,66 @@
+ at comment{DESCRIPTION:%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ Usage:
+ \bibliography{<journals-bib-file>, <reference-bib-file>}
+
+ Example:
+ \bibliography{bioinformatics-journals-full,hb-at-maths.lth.se}
+ \bibliography{bioinformatics-journals-abbr,hb-at-maths.lth.se}
+
+ Description:
+ This bib-file should be included as a preamble for the main bib-file
+ containing the actual references.
+
+ Author:
+ Henrik Bengtsson, <hb at maths.lth.se>
+
+ Version:
+ See end of file for document history.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+% Journals
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ at STRING{AmStat = {Am. Stat.}}
+ at STRING{AnnStat = {Ann. Statist.}}
+ at STRING{AnalChem = {Anal. Chem.}}
+ at STRING{ApplStat = {Appl. Statist.}}
+ at STRING{Bioinformatics = {Bioinformatics}}
+ at STRING{Biometrika = {Biometrika}}
+ at STRING{BJMSP = {Br. J. Math. Stat. Psychol.}}
+ at STRING{Blood = {Blood, Am Soc Hematol}}
+ at STRING{BMCBioinfo = {BMC Bioinfo.}}
+ at STRING{BMCBiotech = {BMC Biotech.}}
+ at STRING{BMCGen = {BMC Genom.}}
+ at STRING{CancerRes = {Cancer Res.}}
+ at STRING{ExpCellRes = {Exp. Cell Res.}}
+ at STRING{GenBio = {Genome Bio.}}
+ at STRING{GenRes = {Genome Res.}}
+ at STRING{JASA = {J. Am. Stat. Assoc.}}
+ at STRING{JBioOpt = {J. Biomed. Optics}}
+ at STRING{JCompBio = {J. Comput. Biol.}}
+ at STRING{JCompGraphStat = {J. Comp. Graph. Stat.}}
+ at STRING{JRSS = {J. Royal Stat. Soc.}}
+ at STRING{JSPI = {J. Stat. Plan. Inf.}}
+ at STRING{Microcirc = {Microcirc.}}
+ at STRING{NAR = {Nucleic Acids Res.}}
+ at STRING{NatBiotech = {Nature Biotechnol.}}
+ at STRING{NatGen = {Nature Genet.}}
+ at STRING{NatMed = {Nature Med.}}
+ at STRING{NatMet = {Nature Met.}}
+ at STRING{PNAS = {Proc. Natl. Acad. Sci. USA}}
+ at STRING{SAGMB = {Stat. App. Gen. Mol. Bio.}}
+ at STRING{Sankhya = {Sankhya}}
+ at STRING{StatInf = {Stat. Inf.}}
+ at STRING{StatSci = {Stat. Sci.}}
+ at STRING{StatSin = {Stat. Sin.}}
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+% Institutions
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ at STRING{MatStatLU = {Centre for Math. Sci., Lund Univ.}}
+
+
+ at comment{HISTORY:%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+o 2004-12-07
+ Created.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
diff --git a/inst/templates/rsp/includes/levelDensities.tex.rsp b/inst/templates/rsp/includes/levelDensities.tex.rsp
new file mode 100644
index 0000000..37b1f42
--- /dev/null
+++ b/inst/templates/rsp/includes/levelDensities.tex.rsp
@@ -0,0 +1,104 @@
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+% LEVEL DENSITIES
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+<% levelDensities <- function(fit, fields=c("tcn", "dh", "c1", "c2"), ...) { %>
+<%
+# Argument 'fields':
+fields <- match.arg(fields, several.ok=TRUE);
+%>
+
+\clearpage
+\section{Level densities}
+\label{sec:LevelDensities}
+<%
+require("ggplot2") || throw("Package not loaded: ggplot2");
+data <- getSegments(fit);
+unknown <- setdiff(fields, gsub("Mean$", "", names(data)));
+if (length(unknown) > 0L) {
+ throw("Unknown locus data fields: ", paste(sQuote(unknown), collapse=", "));
+}
+w <- sqrt(data$dhNbrOfLoci)
+w <- w / sum(w, na.rm=TRUE);
+data <- cbind(data, weight=w);
+params <- fit$params;
+
+chromosomes <- getChromosomes(fit);
+nbrOfChromosomes <- length(chromosomes);
+chromosomesH <- seqToHumanReadable(chromosomes);
+chromosomesH <- if (nbrOfChromosomes == 1) {
+ sprintf("Chr %s", chromosomesH);
+} else {
+ sprintf("Chrs %s", chromosomesH);
+}
+chrsTags <- if (nbrOfChromosomes == 1) {
+ sprintf("chr%02d", chromosomes[1]);
+} else {
+ sprintf("chrs%02d-%02d", min(chromosomes), max(chromosomes));
+}
+%>
+\begin{figure}[htbp]
+ \begin{center}
+<% for (ff in fields) { %>
+<%
+ symbol <- symbolList[[ff]];
+ panelTitle <- switch(ff, tcn="\\TCN", "NNN");
+ lim <- switch(ff, tcn=ClimX, CT=ClimX, c1=ClimX, c2=ClimX, c1N=ClimX, c2N=ClimX, BlimX);
+ column <- sprintf("%sMean", ff);
+%>
+\raisebox{4ex}{<%=symbol%>}
+<%
+ tags <- c(chrsTags, "segments", ff);
+%>
+ \resizebox{0.33\textwidth}{!}{%
+ \includegraphics{<%={
+ toPNG(name=sampleNameEscDots, tags=tags, width=640, aspectRatio=0.3, {
+#### gg <- ggplot(dataT, aes_string(x=column, weights="weight", y="..count.."));
+ gg <- ggplot(data, aes_string(x=column, weight="weight", y="..count.."));
+
+ h <- NULL;
+ if (ff == "tcn") {
+ h <- params$ntcnRange;
+## label <- expression(%+-%*Delta[CN]);
+ col <- "purple";
+ } else if (ff == "dh") {
+ h <- params$deltaAB;
+ label <- expression(Delta[AB]);
+ col <- "orange";
+ } else if (ff == "c1") {
+ h <- params$deltaLowC1;
+ label <- expression(Delta[LOH]);
+ col <- "blue";
+ }
+
+ if (!is.null(h)) {
+ gg <- gg + geom_vline(xintercept=h, colour=col, size=1.5);
+ }
+
+ # See https://github.com/hadley/ggplot2/wiki/Legend-Attributes
+ gg <- gg + theme(legend.position=c(0.97, 0.75),
+ legend.justification = 1,
+ legend.direction="vertical",
+ legend.title=element_text(size=0),
+ legend.text=element_text(size=16));
+
+ gg <- gg + geom_density(size=2, na.rm=TRUE);
+ gg <- gg + xlab(NULL);
+ gg <- gg + ylab(NULL);
+ gg <- gg + xlim(lim);
+ gg <- gg + theme(axis.text.x=xnbrOpts, axis.text.y=ynbrOpts);
+ gg <- gg + theme(axis.title.x=xlabOpts, axis.title.y=ylabOpts);
+ suppressWarnings({
+ print(gg);
+ });
+ }) # toPNG()
+ }%>}%
+ }%
+\\ %
+<% } # for (ff ...) %>
+ \end{center}
+ \caption{
+ Density estimates of (weighted) \emph{segment-level} signals on <%=chromosomesH%> where weights are proportional to the square-root of the number of heterozygous SNPs in each segment.
+ }
+ \label{fig:LevelDensity}
+\end{figure}
+<% } # levelDensities() %>
diff --git a/inst/templates/rsp/includes/pscnSegmentationTracks.tex.rsp b/inst/templates/rsp/includes/pscnSegmentationTracks.tex.rsp
new file mode 100644
index 0000000..aef3547
--- /dev/null
+++ b/inst/templates/rsp/includes/pscnSegmentationTracks.tex.rsp
@@ -0,0 +1,47 @@
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+% PARENT-SPECIFIC COPY-NUMBER SEGMENTATION TRACKS
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+<% pscnSegmentationTracks <- function(fit, ...) { %>
+\clearpage
+\subsection{Parent-specific copy-number segmentation tracks}
+\label{sec:PSCNSegmentationTracks}
+<%
+chromosomes <- getChromosomes(fit);
+nbrOfChromosomes <- length(chromosomes);
+chromosomesH <- seqToHumanReadable(chromosomes);
+chromosomesH <- if (nbrOfChromosomes == 1) {
+ sprintf("Chr %s", chromosomesH);
+} else {
+ sprintf("Chrs %s", chromosomesH);
+}
+chrsTags <- if (nbrOfChromosomes == 1) {
+ sprintf("chr%02d", chromosomes[1]);
+} else {
+ sprintf("chrs%02d-%02d", min(chromosomes), max(chromosomes));
+}
+%>
+\begin{figure}[htbp]
+ \begin{center}
+ <% for (track in c("tcn", "dh", "tcn,c1,c2")) { %>
+<%-- <% for (track in c("tcn*", "betaT", "betaTN*", "dh*", "tcn*,c1*,c2-*")) { %> --%>
+ \resizebox{\textwidth}{!}{%
+ \includegraphics{<%={
+ tags <- c(chrsTags, fitClass, gsub("[*-]", "", track), getChecksum(fit));
+ toPNG(name=sampleNameEscDots, tags=tags, width=1024, aspectRatio=0.25, {
+ par(mar=c(1.3,4,0.7,1.2)+0.1, cex=1.5);
+ plotTracksManyChromosomes(fit, tracks=track, knownSegment=TRUE, Clim=Clim);
+ });
+ }%>}%
+ }%
+ \\
+ <% } # for (track ...) %>
+ \end{center}
+ \caption{
+ Results of <%=fitClassLbl%> segmentation on <%=chromosomesH%> projected onto
+ TCN (top), DH (middle), as well as TCN, $C_1$ and $C_2$ (bottom).
+ PSCBS segmentation is always done on TCN and DH data.
+ There are in total $S=<%=nbrOfSegments(fit, splitters=FALSE)%>$ segments.
+ }
+ \label{fig:PairedPSCBS}
+\end{figure}
+<% } # pscnSegmentationTracks() %>
diff --git a/inst/templates/rsp/includes/pscnSegmentationTransitions.tex.rsp b/inst/templates/rsp/includes/pscnSegmentationTransitions.tex.rsp
new file mode 100644
index 0000000..7f62096
--- /dev/null
+++ b/inst/templates/rsp/includes/pscnSegmentationTransitions.tex.rsp
@@ -0,0 +1,51 @@
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+% PARENT-SPECIFIC COPY-NUMBER TRANSITIONS
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+<% pscnSegmentationTransitions <- function(fit, ...) { %>
+\clearpage
+\subsection{Parent-specific copy-number transitions}
+\label{sec:PSCNSegmentationTransitions}
+<%
+# plotC1C2Grid()
+require("aroma.cn") || throw("Package not loaded: aroma.cn");
+
+chromosomes <- getChromosomes(fit);
+nbrOfChromosomes <- length(chromosomes);
+chromosomesH <- seqToHumanReadable(chromosomes);
+chromosomesH <- if (nbrOfChromosomes == 1) {
+ sprintf("Chr %s", chromosomesH);
+} else {
+ sprintf("Chrs %s", chromosomesH);
+}
+chrsTags <- if (nbrOfChromosomes == 1) {
+ sprintf("chr%02d", chromosomes[1]);
+} else {
+ sprintf("chrs%02d-%02d", min(chromosomes), max(chromosomes));
+}
+%>
+\begin{figure}[htbp]
+ \begin{center}
+ \resizebox{0.6\textwidth}{!}{%
+ \includegraphics{<%={
+ tags <- c(chrsTags, fitClass, "C1C2", getChecksum(fit));
+ toPNG(name=sampleNameEscDots, tags=tags, width=640, aspectRatio=1, par=list(mar=c(4,4,1,1)+0.1, cex=2), {
+ plotC1C2Grid(fit, Clim=ClimX);
+ linesC1C2(fit, lwd=2);
+ }, force=FALSE);
+ }%>}%
+ }%
+ \end{center}
+ \caption{
+ A graph representation of the minor ($C_1$) and major ($C_2$)
+ copy-number segmentation on <%=chromosomesH%>,
+ where the nodes represent ($S=<%=nbrOfSegments(fit, splitters=FALSE)%>$)
+ segments and the lines change points.
+ The size of a node reflects the length of the corresponding segment.
+ The marginal distributions (gray curves) of the minor and the major CNs
+ are projected onto the horizontal and vertical axis, respectively.
+ To easy a visual comparison, the latter is also projected onto the
+ horizontal axis (light blue curve).
+ }
+ \label{fig:C1C2}
+\end{figure}
+<% } # pscnSegmentationTransitions() %>
diff --git a/inst/templates/rsp/includes/references.tex.rsp b/inst/templates/rsp/includes/references.tex.rsp
new file mode 100644
index 0000000..65d0f6d
--- /dev/null
+++ b/inst/templates/rsp/includes/references.tex.rsp
@@ -0,0 +1,6 @@
+<%--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==
+ REFERENCES
+==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--%>
+\bibliography{bioinformatics-journals-abbr,PSCBS}
+%\bibliographystyle{plain}
+\bibliographystyle{natbib}
diff --git a/inst/templates/rsp/includes/reportHeader.tex.rsp b/inst/templates/rsp/includes/reportHeader.tex.rsp
new file mode 100644
index 0000000..70e2e09
--- /dev/null
+++ b/inst/templates/rsp/includes/reportHeader.tex.rsp
@@ -0,0 +1,81 @@
+<%--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==
+ REPORT HEADER
+==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--%>
+
+<%---------------------------------------------------------------------
+ Usage: Add reportHeaderSetup(fit) to the LaTeX preamble
+---------------------------------------------------------------------%>
+<% reportHeaderSetup <- function(fit, sampleName=sampleName(fit), studyName, dataSet, ...) { %>
+<%
+getChecksum <- R.cache::getChecksum;
+fitClass <- class(fit)[1L];
+sampleName <- Arguments$getCharacter(sampleName);
+sampleNameEscDots <- gsub(".", "_", sampleName, fixed=TRUE);
+%>
+% Header contain project and sample metadata
+\usepackage{fancyhdr}
+\setlength{\headheight}{40pt}
+\pagestyle{fancy}{\fancyhf{}} % Custom header (specified below)
+\renewcommand{\headrulewidth}{0pt} % Drop horizontal ruler
+\fancyfoot{} % clear all footer fields
+\newcommand{\chrLabel}[1]{WG\xspace}
+
+\fancyhead[C]{%
+ \small
+ \raggedright
+%% \textbf{Study:Dataset:Sample}:
+ <%=toLatex(studyName)%>:<%=toLatex(dataSet)%>:<%=toLatex(sampleName)%>:\chrLabel
+ \hfill
+ \thepage/\pageref{LastPage}\\
+%% \textbf{Compiled} & <%=Sys.Date()%>
+ \centering
+ \resizebox{\headwidth}{!}{\includegraphics{<%=
+ tags <- c("wg", fitClass, "tcn,c1,c2", getChecksum(fit));
+ toPNG(name=sampleNameEscDots, tags=tags, width=1024, aspectRatio=0.07, {
+ par(oma=c(0,0,0,0), mar=c(0,0,0,0));
+ plotTracks(fit, tracks="tcn,c1,c2", scatter=NULL, calls=NULL, callTresholds=FALSE, lwd=5, Clim=c(0,4), xlab="", ylab="", subplots=FALSE);
+ })%>}}%
+%% \vspace{0.2ex}
+%% \hline
+}
+<% } # reportHeaderSetup() %>
+
+
+<%---------------------------------------------------------------------
+ Usage: Add reportHeaderUpdate(fit) whenever subsetting 'fit'
+---------------------------------------------------------------------%>
+<% reportHeaderUpdate <- function(fit, ...) { %>
+<%
+chromosomes <- getChromosomes(fit);
+nbrOfChromosomes <- length(chromosomes);
+chrsTags <- if (nbrOfChromosomes == 1) {
+ sprintf("chr%02d", chromosomes[1]);
+} else {
+ sprintf("chrs%02d-%02d", min(chromosomes), max(chromosomes));
+}
+%>
+\renewcommand{\chrLabel}{<%=chrsTags%>}
+<% } # reportHeaderUpdate() %>
+
+
+<%--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==
+ HISTORY:
+ 2012-11-03
+ o Replaced deprecated ggplot2 functions.
+ 2012-09-16
+ o Added easy report configuration at the very top.
+ 2012-05-30
+ o Removed ggplot2 warnings on missing values.
+ 2012-02-28
+ o Now it is possible to turn off usage of the alpha channel in
+ plots, e.g. setOption("PSCBS::report/useAlphaChannel", FALSE).
+ This is useful for if the alpha channel is not supported.
+ 2012-02-27
+ o First successful run with real data.
+ o Now all of the report uses a PairedPSCBS object.
+ o Now making more use of templates.
+ o Now passing a data frame to segmentByPairedCBS().
+ 2011-09-30
+ o Created.
+==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--%>
+
diff --git a/inst/templates/rsp/includes/reportSetupGraphics.tex.rsp b/inst/templates/rsp/includes/reportSetupGraphics.tex.rsp
new file mode 100644
index 0000000..921ec10
--- /dev/null
+++ b/inst/templates/rsp/includes/reportSetupGraphics.tex.rsp
@@ -0,0 +1,63 @@
+<%--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==
+ GRAPHICS SETTINGS
+==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--%>
+
+<%--------------------------------------------------------------------
+ Where to save images files
+--------------------------------------------------------------------%>
+\usepackage{graphicx}
+<%
+setOption <- R.utils::setOption; # Don't assume 'R.utils' is attached.
+figPath <- getOption("devEval/args/path", "figures/");
+oFigPath <- setOption("devEval/args/path", figPath);
+on.exit({
+ setOption("devEval/args/path", oFigPath);
+}, add=TRUE);
+
+oPar <- setOption("devNew/args/par", list(lwd=2));
+on.exit({
+ setOption("devNew/args/par", oPar);
+}, add=TRUE);
+%>
+% Figure paths
+\graphicspath{{<%=figPath%>/} {../<%=figPath%>/}}
+
+
+<%--------------------------------------------------------------------
+ Required packages
+--------------------------------------------------------------------%>
+<%
+require("ggplot2") || throw("Package not loaded: ggplot2");
+%>
+
+
+<%--------------------------------------------------------------------
+ Color schemes
+--------------------------------------------------------------------%>
+<%
+muNCols <- c("#999999", "#000000", "#999999");
+
+# ggplot2 options
+xnbrOpts <- element_text(colour="grey50", size=20, hjust=1, lineheight=0.9);
+ynbrOpts <- element_text(colour="grey50", size=20, vjust=1, lineheight=0.9);
+xlabOpts <- element_text(colour="black", size=28, hjust=0.5);
+ylabOpts <- element_text(colour="black", size=28, vjust=0.5, angle=90);
+%>
+
+<%--------------------------------------------------------------------
+ Figure label schemes
+--------------------------------------------------------------------%>
+<%
+labList <- list(
+ CT = expression(C[T]),
+ betaN = expression(beta[N]),
+ betaT = expression(beta[T]),
+ betaTN = expression(tilde(beta)[T]),
+ rho = expression(rho),
+ rhoN = expression(tilde(rho)),
+ c1 = expression(C[1]),
+ c2 = expression(C[2]),
+ c1N = expression(tilde(C)[1]),
+ c2N = expression(tilde(C)[2])
+);
+%>
diff --git a/inst/templates/rsp/includes/reportSetupMacros.tex.rsp b/inst/templates/rsp/includes/reportSetupMacros.tex.rsp
new file mode 100644
index 0000000..9ab4dd1
--- /dev/null
+++ b/inst/templates/rsp/includes/reportSetupMacros.tex.rsp
@@ -0,0 +1,39 @@
+<%--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==
+ LATEX SETTINGS
+==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--%>
+
+<%--------------------------------------------------------------------
+ LaTeX commands
+--------------------------------------------------------------------%>
+\newcommand{\code}[1]{\texttt{#1}\xspace}
+
+
+<%--------------------------------------------------------------------
+ LaTeX acronyms
+--------------------------------------------------------------------%>
+\newcommand{\TCN}{TCN\xspace}
+\newcommand{\BAF}{\BAF\xspace}
+\newcommand{\BAFN}{BAF$_{N}$\xspace}
+\newcommand{\BAFT}{BAF$_{T}$\xspace}
+\newcommand{\BAFTN}{BAF$^*_{T}$\xspace}
+
+
+<%--------------------------------------------------------------------
+ R-to-LaTeX symbols
+--------------------------------------------------------------------%>
+<%
+symbolList <- list(
+ CT = "$C_{T}$",
+ tcn = "$\\bar{C_{T}}$",
+ betaN = "$\\beta_{N}$",
+ betaT = "$\\beta_{T}$",
+ betaTN = "$\\tilde{\\beta}_{T}$",
+ dh = "$\\bar{\\rho}$",
+ rho = "$\\rho$",
+ rhoN = "$\\tilde{\\rho}$",
+ c1 = "$C_{1}$",
+ c2 = "$C_{2}$",
+ c1N = "$\\tilde{C}_{1}$",
+ c2N = "$\\tilde{C}_{2}$"
+);
+%>
diff --git a/inst/templates/rsp/includes/sessionInfo.tex.rsp b/inst/templates/rsp/includes/sessionInfo.tex.rsp
new file mode 100644
index 0000000..c290ded
--- /dev/null
+++ b/inst/templates/rsp/includes/sessionInfo.tex.rsp
@@ -0,0 +1,7 @@
+<%--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==
+ SESSION INFORMATION
+==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--==--%>
+\section*{Session information}
+<%=paste(toLatex(sessionInfo()), collapse="\n")%>
+This report was generated via \code{report(fit)} which utilizes the R.rsp package.
+The template for this report was created by Henrik Bengtsson and last updated on March 21, 2013.
diff --git a/inst/templates/rsp/includes/signalDensities.tex.rsp b/inst/templates/rsp/includes/signalDensities.tex.rsp
new file mode 100644
index 0000000..d23d23c
--- /dev/null
+++ b/inst/templates/rsp/includes/signalDensities.tex.rsp
@@ -0,0 +1,111 @@
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+% SIGNAL DENSITIES
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+<% signalDensities <- function(fit, fields=c("CT", "betaN", "betaT", "rho", "c1", "c2", "betaTN", "rhoN", "c1N", "c2N"), ...) { %>
+<%
+# Argument 'fields':
+fields <- match.arg(fields, several.ok=TRUE);
+%>
+
+\clearpage
+\section{Signal densities}
+\label{sec:SignalDensities}
+<%
+require("ggplot2") || throw("Package not loaded: ggplot2");
+data <- getLocusData(fit, fields="full");
+unknown <- setdiff(fields, names(data));
+if (length(unknown) > 0L) {
+ throw("Unknown locus data fields: ", paste(sQuote(unknown), collapse=", "));
+}
+params <- fit$params;
+
+chromosomes <- getChromosomes(fit);
+nbrOfChromosomes <- length(chromosomes);
+chromosomesH <- seqToHumanReadable(chromosomes);
+chromosomesH <- if (nbrOfChromosomes == 1) {
+ sprintf("Chr %s", chromosomesH);
+} else {
+ sprintf("Chrs %s", chromosomesH);
+}
+chrsTags <- if (nbrOfChromosomes == 1) {
+ sprintf("chr%02d", chromosomes[1]);
+} else {
+ sprintf("chrs%02d-%02d", min(chromosomes), max(chromosomes));
+}
+%>
+\begin{figure}[htbp]
+ \begin{center}
+<% for (ff in fields) { %>
+<%
+ symbol <- symbolList[[ff]];
+ panelTitle <- switch(ff, CT="\\TCN", betaN="\\BAFN", betaT="\\BAFT", betaTN="\\BAFTN", "NNN");
+ lim <- switch(ff, CT=ClimX, c1=ClimX, c2=ClimX, c1N=ClimX, c2N=ClimX, BlimX);
+%>
+\raisebox{4ex}{<%=symbol%>}
+<% for (by in c("all", "muN")) { %>
+<%
+ tags <- c(chrsTags, by, ff);
+%>
+ \resizebox{0.33\textwidth}{!}{%
+ \includegraphics{<%={
+ toPNG(name=sampleNameEscDots, tags=tags, width=640, aspectRatio=0.3, {
+ gg <- ggplot(data, aes_string(x=ff, y="..count.."));
+
+ if (by == "all") {
+ if (ff == "CT" && any(!data$isSNP, na.rm=TRUE)) {
+ gg <- gg + aes(group=type, colour=type);
+ }
+
+ h <- NULL;
+ if (ff == "rho") {
+ h <- params$deltaAB;
+ label <- expression(Delta[AB]);
+ col <- "orange";
+ } else if (ff == "c1") {
+ h <- params$deltaLowC1;
+ label <- expression(Delta[LOH]);
+ col <- "blue";
+ }
+
+ if (!is.null(h)) {
+ gg <- gg + geom_vline(xintercept=h, colour=col, size=1.5);
+ }
+ } else if (by == "muN") {
+ gg <- gg + aes_string(group="muNx", colour="muNx");
+ gg <- gg + scale_color_manual(values=muNCols);
+ }
+
+ # See https://github.com/hadley/ggplot2/wiki/Legend-Attributes
+ gg <- gg + theme(legend.position=c(0.97, 0.75),
+ legend.justification = 1,
+ legend.direction="vertical",
+ legend.title=element_text(size=0),
+ legend.text=element_text(size=16));
+
+ gg <- gg + geom_density(size=2, na.rm=TRUE);
+ gg <- gg + xlab(NULL);
+ gg <- gg + ylab(NULL);
+ gg <- gg + xlim(lim);
+ gg <- gg + theme(axis.text.x=xnbrOpts, axis.text.y=ynbrOpts);
+ gg <- gg + theme(axis.title.x=xlabOpts, axis.title.y=ylabOpts);
+ suppressWarnings({
+ print(gg);
+ });
+ }, force=FALSE);
+ }%>}%
+ }%
+<% } # for (by ...) %>
+\\ %
+<% } # for (ff ...) %>
+ \end{center}
+ \caption{
+ Density estimates of \emph{locus-level} signals on <%=chromosomesH%>
+ with and without TumorBoost normalization.
+ The signals in the left and right panels are without and with stratification on genotype calls (AA and BB in gray and AB in black).
+ If there are no allelic imbalances in the tumor, then the density of
+ the tumor should be similar to a normal sample, that is, three bands
+ of signals corresponding to the three genotype groups.
+ }
+ \label{fig:SignalDensity}
+\end{figure}
+<% } # signalDensities() %>
diff --git a/inst/templates/rsp/includes/summaryOfAnnotationAndGenotypeCalls.tex.rsp b/inst/templates/rsp/includes/summaryOfAnnotationAndGenotypeCalls.tex.rsp
new file mode 100644
index 0000000..f76e7e6
--- /dev/null
+++ b/inst/templates/rsp/includes/summaryOfAnnotationAndGenotypeCalls.tex.rsp
@@ -0,0 +1,47 @@
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+% SUMMARY ANNOTATION AND GENOTYPE CALLS
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+<% summaryOfAnnotationAndGenotypeCalls <- function(fit, ...) { %>
+\subsection{Summary of annotation and genotype calls}
+<%
+data <- getLocusData(fit, fields="full");
+nbrOfLoci <- nrow(data);
+nbrOfSNPs <- sum(data$isSNP, na.rm=TRUE);
+nbrOfHets <- sum(data$isHet, na.rm=TRUE);
+
+chromosomes <- getChromosomes(fit);
+nbrOfChromosomes <- length(chromosomes);
+chromosomesH <- seqToHumanReadable(chromosomes);
+chromosomesH <- if (nbrOfChromosomes == 1) {
+ sprintf("Chr %s", chromosomesH);
+} else {
+ sprintf("Chrs %s", chromosomesH);
+}
+chrsTags <- if (nbrOfChromosomes == 1) {
+ sprintf("chr%02d", chromosomes[1]);
+} else {
+ sprintf("chrs%02d-%02d", min(chromosomes), max(chromosomes));
+}
+%>
+<% reportHeaderUpdate(fit) %>
+\begin{table}[htbp]
+ \begin{center}
+ \begin{tabular}{lrr}
+ Description & Count & Fraction \\
+ \hline
+ Number of loci & <%=nbrOfLoci%> & 100.00\% \\
+ Number of SNPs & <%=nbrOfSNPs%> & <%=sprintf("%.2f", 100*nbrOfSNPs/nbrOfLoci)%>\% \\
+ Number of heterozygous SNPs* & <%=nbrOfHets%> & <%=sprintf("%.2f", 100*nbrOfHets/nbrOfSNPs)%>\% \\
+ Number of non-polymorphic loci & <%=nbrOfLoci-nbrOfSNPs%> & <%=sprintf("%.2f", 100*(1-nbrOfSNPs/nbrOfLoci))%>\% \\
+ Number of chromosomes & <%=nbrOfChromosomes%> & - \\
+ \end{tabular}
+ \caption{
+ Summary of the locus-level data on <%=chromosomesH%>.
+ A locus is considered to be a SNP if it has either a non-missing BAF for the tumor.
+ (*) Heterozygous calls are based on (whole-genome) naive calling by thresholding \emph{tumor} DHs.
+ }
+ \label{tbl:LocusStats}
+ \end{center}
+\end{table}
+
+<% } # summaryOfAnnotationAndGenotypeCalls() %>
diff --git a/inst/templates/rsp/natbib.bst b/inst/templates/rsp/natbib.bst
new file mode 100644
index 0000000..a679e1d
--- /dev/null
+++ b/inst/templates/rsp/natbib.bst
@@ -0,0 +1,1288 @@
+%%
+%% This is file `natbib.bst', generated
+%% on <1994/9/16> with the docstrip utility (2.2h).
+%%
+%% The original source files were:
+%%
+%% genbst.mbs (with options: `ay,nat,seq-lab,nm-rev,dt-beg,yr-par,vol-bf,
+%% volp-com,etal-it')
+%% ----------------------------------------
+%% *** Personal bib style, PWD ***
+%%
+%% (Here are the specifications of the source file)
+%% \ProvidesFile{genbst.mbs}[1994/09/16 1.5 (PWD)]
+%% For use with BibTeX version 0.99a or later
+%% and with LaTeX 2.09 or 2e
+%%-------------------------------------------------------------------
+%% NOTICE:
+%% This file may be used for non-profit purposes.
+%% It may not be distributed in exchange for money,
+%% other than distribution costs.
+%%
+%% The author provides it `as is' and does not guarantee it in any way.
+%%
+%% Copyright (C) 1994 Patrick W. Daly
+%% Max-Planck-Institut f\"ur Aeronomie
+%% Postfach 20
+%% D-37189 Katlenburg-Lindau
+%% Germany
+%%
+%% E-mail:
+%% SPAN-- nsp::linmpi::daly (note nsp also known as ecd1)
+%% Internet-- daly at linmpi.dnet.gwdg.de
+%%-----------------------------------------------------------
+%% \CharacterTable
+%% {Upper-case \A\B\C\D\E\F\G\H\I\J\K\L\M\N\O\P\Q\R\S\T\U\V\W\X\Y\Z
+%% Lower-case \a\b\c\d\e\f\g\h\i\j\k\l\m\n\o\p\q\r\s\t\u\v\w\x\y\z
+%% Digits \0\1\2\3\4\5\6\7\8\9
+%% Exclamation \! Double quote \" Hash (number) \#
+%% Dollar \$ Percent \% Ampersand \&
+%% Acute accent \' Left paren \( Right paren \)
+%% Asterisk \* Plus \+ Comma \,
+%% Minus \- Point \. Solidus \/
+%% Colon \: Semicolon \; Less than \<
+%% Equals \= Greater than \> Question mark \?
+%% Commercial at \@ Left bracket \[ Backslash \\
+%% Right bracket \] Circumflex \^ Underscore \_
+%% Grave accent \` Left brace \{ Vertical bar \|
+%% Right brace \} Tilde \~}
+%%---------------------------------------------------------------------
+ % This is an author-year citation style bibliography. As such, it is
+ % non-standard LaTeX, and requires a special package file to function properly.
+ % Such a package is natbib.sty by Patrick W. Daly
+ % The form of the \bibitem entries is
+ % \bibitem[Jones et al.(1990)]{key}...
+ % \bibitem[Jones et al.(1990)Jones, Baker, and Smith]{key}...
+ % The essential feature is that the label (the part in brackets) consists
+ % of the author names, as they should appear in the citation, with the year
+ % in parentheses following. There must be no space before the opening
+ % parenthesis!
+ % With natbib v5.3, a full list of authors may also follow the year.
+ % In natbib.sty, it is possible to define the type of enclosures that is
+ % really wanted (brackets or parentheses), but in either case, there must
+ % be parentheses in the label.
+ % The \cite command functions as follows:
+ % \cite{key} ==>> Jones et al. (1990)
+ % \cite[]{key} ==>> (Jones et al., 1990)
+ % \cite[chap. 2]{key} ==>> (Jones et al., 1990, chap. 2)
+ % \cite[e.g.][]{key} ==>> (e.g. Jones et al., 1990)
+ % \cite[e.g.][p. 32]{key} ==>> (e.g. Jones et al., p. 32)
+ % \citeauthor{key} Jones et al.
+ % \citefullauthor{key} Jones, Baker, and Smith
+ % \citeyear{key} 1990
+%%---------------------------------------------------------------------
+
+ENTRY
+ { address
+ author
+ booktitle
+ chapter
+ edition
+ editor
+ howpublished
+ institution
+ journal
+ key
+ month
+ note
+ number
+ organization
+ pages
+ publisher
+ school
+ series
+ title
+ type
+ volume
+ year
+ }
+ {}
+ { label extra.label sort.label }
+
+INTEGERS { output.state before.all mid.sentence after.sentence after.block }
+
+FUNCTION {init.state.consts}
+{ #0 'before.all :=
+ #1 'mid.sentence :=
+ #2 'after.sentence :=
+ #3 'after.block :=
+}
+
+STRINGS { s t }
+
+FUNCTION {output.nonnull}
+{ 's :=
+ output.state mid.sentence =
+ { ", " * write$ }
+ { output.state after.block =
+ { add.period$ write$
+ newline$
+ "\newblock " write$
+ }
+ { output.state before.all =
+ 'write$
+ { add.period$ " " * write$ }
+ if$
+ }
+ if$
+ mid.sentence 'output.state :=
+ }
+ if$
+ s
+}
+
+FUNCTION {output}
+{ duplicate$ empty$
+ 'pop$
+ 'output.nonnull
+ if$
+}
+
+FUNCTION {output.check}
+{ 't :=
+ duplicate$ empty$
+ { pop$ "empty " t * " in " * cite$ * warning$ }
+ 'output.nonnull
+ if$
+}
+
+FUNCTION {fin.entry}
+{ add.period$
+ write$
+ newline$
+}
+
+FUNCTION {new.block}
+{ output.state before.all =
+ 'skip$
+ { after.block 'output.state := }
+ if$
+}
+
+FUNCTION {new.sentence}
+{ output.state after.block =
+ 'skip$
+ { output.state before.all =
+ 'skip$
+ { after.sentence 'output.state := }
+ if$
+ }
+ if$
+}
+
+FUNCTION {not}
+{ { #0 }
+ { #1 }
+ if$
+}
+
+FUNCTION {and}
+{ 'skip$
+ { pop$ #0 }
+ if$
+}
+
+FUNCTION {or}
+{ { pop$ #1 }
+ 'skip$
+ if$
+}
+
+FUNCTION {non.stop}
+{ duplicate$
+ "}" * add.period$
+ #-1 #1 substring$ "." =
+}
+
+FUNCTION {new.block.checkb}
+{ empty$
+ swap$ empty$
+ and
+ 'skip$
+ 'new.block
+ if$
+}
+
+FUNCTION {field.or.null}
+{ duplicate$ empty$
+ { pop$ "" }
+ 'skip$
+ if$
+}
+
+FUNCTION {emphasize}
+{ duplicate$ empty$
+ { pop$ "" }
+ { "{\em " swap$ * non.stop
+ { "\/}" * }
+ { "}" * }
+ if$
+ }
+ if$
+}
+
+FUNCTION {bolden}
+{ duplicate$ empty$
+ { pop$ "" }
+ { "{\bf " swap$ * "}" * }
+ if$
+}
+
+INTEGERS { nameptr namesleft numnames }
+
+FUNCTION {format.names}
+{ 's :=
+ #1 'nameptr :=
+ s num.names$ 'numnames :=
+ numnames 'namesleft :=
+ { namesleft #0 > }
+ { s nameptr
+ "{vv~}{ll}{, jj}{, f.}" format.name$ 't :=
+ nameptr #1 >
+ {
+ namesleft #1 >
+ { ", " * t * }
+ {
+ numnames #2 >
+ { "," * }
+ 'skip$
+ if$
+ t "others" =
+ { " " * "et~al." emphasize * }
+ { " and " * t * }
+ if$
+ }
+ if$
+ }
+ 't
+ if$
+ nameptr #1 + 'nameptr :=
+ namesleft #1 - 'namesleft :=
+ }
+ while$
+}
+
+FUNCTION {format.names.ed}
+{ 's :=
+ #1 'nameptr :=
+ s num.names$ 'numnames :=
+ numnames 'namesleft :=
+ { namesleft #0 > }
+ { s nameptr
+ "{f.~}{vv~}{ll}{, jj}"
+ format.name$ 't :=
+ nameptr #1 >
+ {
+ namesleft #1 >
+ { ", " * t * }
+ {
+ numnames #2 >
+ { "," * }
+ 'skip$
+ if$
+ t "others" =
+ { " " * "et~al." emphasize * }
+ { " and " * t * }
+ if$
+ }
+ if$
+ }
+ 't
+ if$
+ nameptr #1 + 'nameptr :=
+ namesleft #1 - 'namesleft :=
+ }
+ while$
+}
+
+FUNCTION {format.key}
+{ empty$
+ { key field.or.null }
+ { "" }
+ if$
+}
+
+FUNCTION {format.authors}
+{ author empty$
+ { "" }
+ { author format.names }
+ if$
+}
+
+FUNCTION {format.editors}
+{ editor empty$
+ { "" }
+ { editor format.names
+ editor num.names$ #1 >
+ { ", editors" * }
+ { ", editor" * }
+ if$
+ }
+ if$
+}
+
+FUNCTION {format.in.editors}
+{ editor empty$
+ { "" }
+ { editor format.names.ed
+ editor num.names$ #1 >
+ { ", editors" * }
+ { ", editor" * }
+ if$
+ }
+ if$
+}
+
+FUNCTION {format.title}
+{ title empty$
+ { "" }
+ { title "t" change.case$
+ }
+ if$
+}
+
+FUNCTION {format.full.names}
+{'s :=
+ #1 'nameptr :=
+ s num.names$ 'numnames :=
+ numnames 'namesleft :=
+ { namesleft #0 > }
+ { s nameptr
+ "{vv~}{ll}" format.name$ 't :=
+ nameptr #1 >
+ {
+ namesleft #1 >
+ { ", " * t * }
+ {
+ numnames #2 >
+ { "," * }
+ 'skip$
+ if$
+ t "others" =
+ { " " * "et~al." emphasize * }
+ { " and " * t * }
+ if$
+ }
+ if$
+ }
+ 't
+ if$
+ nameptr #1 + 'nameptr :=
+ namesleft #1 - 'namesleft :=
+ }
+ while$
+}
+
+FUNCTION {author.editor.key.full}
+{ author empty$
+ { editor empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { editor format.full.names }
+ if$
+ }
+ { author format.full.names }
+ if$
+}
+
+FUNCTION {author.key.full}
+{ author empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { author format.full.names }
+ if$
+}
+
+FUNCTION {editor.key.full}
+{ editor empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { editor format.full.names }
+ if$
+}
+
+FUNCTION {make.full.names}
+{ type$ "book" =
+ type$ "inbook" =
+ or
+ 'author.editor.key.full
+ { type$ "proceedings" =
+ 'editor.key.full
+ 'author.key.full
+ if$
+ }
+ if$
+}
+
+FUNCTION {output.bibitem}
+{ newline$
+ "\bibitem[" write$
+ label write$
+ ")" make.full.names * "]{" * write$
+ cite$ write$
+ "}" write$
+ newline$
+ ""
+ before.all 'output.state :=
+}
+
+FUNCTION {n.dashify}
+{ 't :=
+ ""
+ { t empty$ not }
+ { t #1 #1 substring$ "-" =
+ { t #1 #2 substring$ "--" = not
+ { "--" *
+ t #2 global.max$ substring$ 't :=
+ }
+ { { t #1 #1 substring$ "-" = }
+ { "-" *
+ t #2 global.max$ substring$ 't :=
+ }
+ while$
+ }
+ if$
+ }
+ { t #1 #1 substring$ *
+ t #2 global.max$ substring$ 't :=
+ }
+ if$
+ }
+ while$
+}
+
+FUNCTION {word.in}
+{ "In " }
+
+FUNCTION {format.date}
+{ year duplicate$ empty$
+ { "empty year in " cite$ * "; set to ????" * warning$
+ pop$ "????" }
+ 'skip$
+ if$
+ before.all 'output.state :=
+ " (" swap$ * extra.label * ")" *
+}
+
+FUNCTION {format.btitle}
+{ title emphasize
+}
+
+FUNCTION {tie.or.space.connect}
+{ duplicate$ text.length$ #3 <
+ { "~" }
+ { " " }
+ if$
+ swap$ * *
+}
+
+FUNCTION {either.or.check}
+{ empty$
+ 'pop$
+ { "can't use both " swap$ * " fields in " * cite$ * warning$ }
+ if$
+}
+
+FUNCTION {format.bvolume}
+{ volume empty$
+ { "" }
+ { "volume" volume tie.or.space.connect
+ series empty$
+ 'skip$
+ { " of " * series emphasize * }
+ if$
+ "volume and number" number either.or.check
+ }
+ if$
+}
+
+FUNCTION {format.number.series}
+{ volume empty$
+ { number empty$
+ { series field.or.null }
+ { output.state mid.sentence =
+ { "number" }
+ { "Number" }
+ if$
+ number tie.or.space.connect
+ series empty$
+ { "there's a number but no series in " cite$ * warning$ }
+ { " in " * series * }
+ if$
+ }
+ if$
+ }
+ { "" }
+ if$
+}
+
+FUNCTION {format.edition}
+{ edition empty$
+ { "" }
+ { output.state mid.sentence =
+ { edition "l" change.case$ " edition" * }
+ { edition "t" change.case$ " edition" * }
+ if$
+ }
+ if$
+}
+
+INTEGERS { multiresult }
+
+FUNCTION {multi.page.check}
+{ 't :=
+ #0 'multiresult :=
+ { multiresult not
+ t empty$ not
+ and
+ }
+ { t #1 #1 substring$
+ duplicate$ "-" =
+ swap$ duplicate$ "," =
+ swap$ "+" =
+ or or
+ { #1 'multiresult := }
+ { t #2 global.max$ substring$ 't := }
+ if$
+ }
+ while$
+ multiresult
+}
+
+FUNCTION {format.pages}
+{ pages empty$
+ { "" }
+ { pages multi.page.check
+ { "pages" pages n.dashify tie.or.space.connect }
+ { "page" pages tie.or.space.connect }
+ if$
+ }
+ if$
+}
+
+FUNCTION {format.vol.num.pages}
+{ volume field.or.null
+ bolden
+ number empty$
+ 'skip$
+ { "(" number * ")" * *
+ volume empty$
+ { "there's a number but no volume in " cite$ * warning$ }
+ 'skip$
+ if$
+ }
+ if$
+ pages empty$
+ 'skip$
+ { duplicate$ empty$
+ { pop$ format.pages }
+ { ", " * pages n.dashify * }
+ if$
+ }
+ if$
+}
+
+FUNCTION {format.chapter.pages}
+{ chapter empty$
+ 'format.pages
+ { type empty$
+ { "chapter" }
+ { type "l" change.case$ }
+ if$
+ chapter tie.or.space.connect
+ pages empty$
+ 'skip$
+ { ", " * format.pages * }
+ if$
+ }
+ if$
+}
+
+FUNCTION {format.in.ed.booktitle}
+{ booktitle empty$
+ { "" }
+ { editor empty$
+ { word.in booktitle emphasize * }
+ { word.in format.in.editors * ", " * booktitle emphasize * }
+ if$
+ }
+ if$
+}
+
+FUNCTION {format.thesis.type}
+{ type empty$
+ 'skip$
+ { pop$
+ type "t" change.case$
+ }
+ if$
+}
+
+FUNCTION {format.tr.number}
+{ type empty$
+ { "Technical Report" }
+ 'type
+ if$
+ number empty$
+ { "t" change.case$ }
+ { number tie.or.space.connect }
+ if$
+}
+
+FUNCTION {format.article.crossref}
+{
+ word.in
+ "\cite{" * crossref * "}" *
+}
+
+FUNCTION {format.book.crossref}
+{ volume empty$
+ { "empty volume in " cite$ * "'s crossref of " * crossref * warning$
+ word.in
+ }
+ { "Volume" volume tie.or.space.connect
+ " of " *
+ }
+ if$
+ "\cite{" * crossref * "}" *
+}
+
+FUNCTION {format.incoll.inproc.crossref}
+{
+ word.in
+ "\cite{" * crossref * "}" *
+}
+
+FUNCTION {article}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.title "title" output.check
+ new.block
+ crossref missing$
+ { journal emphasize "journal" output.check
+ format.vol.num.pages output
+ }
+ { format.article.crossref output.nonnull
+ format.pages output
+ }
+ if$
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {book}
+{ output.bibitem
+ author empty$
+ { format.editors "author and editor" output.check
+ editor format.key output
+ }
+ { format.authors output.nonnull
+ crossref missing$
+ { "author and editor" editor either.or.check }
+ 'skip$
+ if$
+ }
+ if$
+ format.date "year" output.check
+ new.block
+ format.btitle "title" output.check
+ crossref missing$
+ { format.bvolume output
+ new.block
+ format.number.series output
+ new.sentence
+ publisher "publisher" output.check
+ address output
+ }
+ {
+ new.block
+ format.book.crossref output.nonnull
+ }
+ if$
+ format.edition output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {booklet}
+{ output.bibitem
+ format.authors output
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.title "title" output.check
+ new.block
+ howpublished output
+ address output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {inbook}
+{ output.bibitem
+ author empty$
+ { format.editors "author and editor" output.check
+ editor format.key output
+ }
+ { format.authors output.nonnull
+ crossref missing$
+ { "author and editor" editor either.or.check }
+ 'skip$
+ if$
+ }
+ if$
+ format.date "year" output.check
+ new.block
+ format.btitle "title" output.check
+ crossref missing$
+ { format.bvolume output
+ format.chapter.pages "chapter and pages" output.check
+ new.block
+ format.number.series output
+ new.sentence
+ publisher "publisher" output.check
+ address output
+ }
+ { format.chapter.pages "chapter and pages" output.check
+ new.block
+ format.book.crossref output.nonnull
+ }
+ if$
+ format.edition output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {incollection}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.title "title" output.check
+ new.block
+ crossref missing$
+ { format.in.ed.booktitle "booktitle" output.check
+ format.bvolume output
+ format.number.series output
+ format.chapter.pages output
+ new.sentence
+ publisher "publisher" output.check
+ address output
+ format.edition output
+ }
+ { format.incoll.inproc.crossref output.nonnull
+ format.chapter.pages output
+ }
+ if$
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {inproceedings}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.title "title" output.check
+ new.block
+ crossref missing$
+ { format.in.ed.booktitle "booktitle" output.check
+ format.bvolume output
+ format.number.series output
+ format.pages output
+ address output
+ new.sentence
+ organization output
+ publisher output
+ }
+ { format.incoll.inproc.crossref output.nonnull
+ format.pages output
+ }
+ if$
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {conference} { inproceedings }
+
+FUNCTION {manual}
+{ output.bibitem
+ format.authors output
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.btitle "title" output.check
+ organization address new.block.checkb
+ organization output
+ address output
+ format.edition output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {mastersthesis}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.btitle "title" output.check
+ new.block
+ "Master's thesis" format.thesis.type output.nonnull
+ school "school" output.check
+ address output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {misc}
+{ output.bibitem
+ format.authors output
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.title output
+ new.block
+ howpublished output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {phdthesis}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.btitle "title" output.check
+ new.block
+ "Ph.D. thesis" format.thesis.type output.nonnull
+ school "school" output.check
+ address output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {proceedings}
+{ output.bibitem
+ format.editors output
+ editor format.key output
+ format.date "year" output.check
+ new.block
+ format.btitle "title" output.check
+ format.bvolume output
+ format.number.series output
+ address output
+ new.sentence
+ organization output
+ publisher output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {techreport}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.title "title" output.check
+ new.block
+ format.tr.number output.nonnull
+ institution "institution" output.check
+ address output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {unpublished}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.title "title" output.check
+ new.block
+ note "note" output.check
+ fin.entry
+}
+
+FUNCTION {default.type} { misc }
+
+MACRO {jan} {"January"}
+
+MACRO {feb} {"February"}
+
+MACRO {mar} {"March"}
+
+MACRO {apr} {"April"}
+
+MACRO {may} {"May"}
+
+MACRO {jun} {"June"}
+
+MACRO {jul} {"July"}
+
+MACRO {aug} {"August"}
+
+MACRO {sep} {"September"}
+
+MACRO {oct} {"October"}
+
+MACRO {nov} {"November"}
+
+MACRO {dec} {"December"}
+
+MACRO {acmcs} {"ACM Computing Surveys"}
+
+MACRO {acta} {"Acta Informatica"}
+
+MACRO {cacm} {"Communications of the ACM"}
+
+MACRO {ibmjrd} {"IBM Journal of Research and Development"}
+
+MACRO {ibmsj} {"IBM Systems Journal"}
+
+MACRO {ieeese} {"IEEE Transactions on Software Engineering"}
+
+MACRO {ieeetc} {"IEEE Transactions on Computers"}
+
+MACRO {ieeetcad}
+ {"IEEE Transactions on Computer-Aided Design of Integrated Circuits"}
+
+MACRO {ipl} {"Information Processing Letters"}
+
+MACRO {jacm} {"Journal of the ACM"}
+
+MACRO {jcss} {"Journal of Computer and System Sciences"}
+
+MACRO {scp} {"Science of Computer Programming"}
+
+MACRO {sicomp} {"SIAM Journal on Computing"}
+
+MACRO {tocs} {"ACM Transactions on Computer Systems"}
+
+MACRO {tods} {"ACM Transactions on Database Systems"}
+
+MACRO {tog} {"ACM Transactions on Graphics"}
+
+MACRO {toms} {"ACM Transactions on Mathematical Software"}
+
+MACRO {toois} {"ACM Transactions on Office Information Systems"}
+
+MACRO {toplas} {"ACM Transactions on Programming Languages and Systems"}
+
+MACRO {tcs} {"Theoretical Computer Science"}
+
+READ
+
+FUNCTION {sortify}
+{ purify$
+ "l" change.case$
+}
+
+INTEGERS { len }
+
+FUNCTION {chop.word}
+{ 's :=
+ 'len :=
+ s #1 len substring$ =
+ { s len #1 + global.max$ substring$ }
+ 's
+ if$
+}
+
+FUNCTION {format.lab.names}
+{ 's :=
+ s #1 "{vv~}{ll}" format.name$
+ s num.names$ duplicate$
+ #2 >
+ { pop$ " " * "et~al." emphasize * }
+ { #2 <
+ 'skip$
+ { s #2 "{ff }{vv }{ll}{ jj}" format.name$ "others" =
+ { " " * "et~al." emphasize * }
+ { " and " * s #2 "{vv~}{ll}" format.name$ * }
+ if$
+ }
+ if$
+ }
+ if$
+}
+
+FUNCTION {author.key.label}
+{ author empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { author format.lab.names }
+ if$
+}
+
+FUNCTION {author.editor.key.label}
+{ author empty$
+ { editor empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { editor format.lab.names }
+ if$
+ }
+ { author format.lab.names }
+ if$
+}
+
+FUNCTION {editor.key.label}
+{ editor empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { editor format.lab.names }
+ if$
+}
+
+FUNCTION {calc.label}
+{ type$ "book" =
+ type$ "inbook" =
+ or
+ 'author.editor.key.label
+ { type$ "proceedings" =
+ 'editor.key.label
+ 'author.key.label
+ if$
+ }
+ if$
+ "("
+ *
+ year duplicate$ empty$
+ { pop$ "????" }
+ { purify$ #-1 #4 substring$ }
+ if$
+ *
+ 'label :=
+}
+
+FUNCTION {sort.format.names}
+{ 's :=
+ #1 'nameptr :=
+ ""
+ s num.names$ 'numnames :=
+ numnames 'namesleft :=
+ { namesleft #0 > }
+ { nameptr #1 >
+ { " " * }
+ 'skip$
+ if$
+ s nameptr
+ "{vv{ } }{ll{ }}{ f{ }}{ jj{ }}"
+ format.name$ 't :=
+ nameptr numnames = t "others" = and
+ { "et al" * }
+ { numnames #2 > nameptr #2 = and
+ { "zzzzzz" * #1 'namesleft := }
+ { t sortify * }
+ if$
+ }
+ if$
+ nameptr #1 + 'nameptr :=
+ namesleft #1 - 'namesleft :=
+ }
+ while$
+}
+
+FUNCTION {sort.format.title}
+{ 't :=
+ "A " #2
+ "An " #3
+ "The " #4 t chop.word
+ chop.word
+ chop.word
+ sortify
+ #1 global.max$ substring$
+}
+
+FUNCTION {author.sort}
+{ author empty$
+ { key empty$
+ { "to sort, need author or key in " cite$ * warning$
+ ""
+ }
+ { key sortify }
+ if$
+ }
+ { author sort.format.names }
+ if$
+}
+
+FUNCTION {author.editor.sort}
+{ author empty$
+ { editor empty$
+ { key empty$
+ { "to sort, need author, editor, or key in " cite$ * warning$
+ ""
+ }
+ { key sortify }
+ if$
+ }
+ { editor sort.format.names }
+ if$
+ }
+ { author sort.format.names }
+ if$
+}
+
+FUNCTION {editor.sort}
+{ editor empty$
+ { key empty$
+ { "to sort, need editor or key in " cite$ * warning$
+ ""
+ }
+ { key sortify }
+ if$
+ }
+ { editor sort.format.names }
+ if$
+}
+
+FUNCTION {presort}
+{ calc.label
+ label sortify
+ " "
+ *
+ type$ "book" =
+ type$ "inbook" =
+ or
+ 'author.editor.sort
+ { type$ "proceedings" =
+ 'editor.sort
+ 'author.sort
+ if$
+ }
+ if$
+ #1 entry.max$ substring$
+ 'sort.label :=
+ sort.label
+ *
+ " "
+ *
+ title field.or.null
+ sort.format.title
+ *
+ #1 entry.max$ substring$
+ 'sort.key$ :=
+}
+
+ITERATE {presort}
+
+SORT
+
+STRINGS { last.label next.extra }
+
+INTEGERS { last.extra.num }
+
+FUNCTION {initialize.extra.label.stuff}
+{ #0 int.to.chr$ 'last.label :=
+ "" 'next.extra :=
+ #0 'last.extra.num :=
+}
+
+FUNCTION {forward.pass}
+{ last.label label =
+ { last.extra.num #1 + 'last.extra.num :=
+ last.extra.num int.to.chr$ 'extra.label :=
+ }
+ { "a" chr.to.int$ 'last.extra.num :=
+ "" 'extra.label :=
+ label 'last.label :=
+ }
+ if$
+}
+
+FUNCTION {reverse.pass}
+{ next.extra "b" =
+ { "a" 'extra.label := }
+ 'skip$
+ if$
+ extra.label 'next.extra :=
+ label extra.label * 'label :=
+}
+
+EXECUTE {initialize.extra.label.stuff}
+
+ITERATE {forward.pass}
+
+REVERSE {reverse.pass}
+
+FUNCTION {bib.sort.order}
+{ sort.label
+ " "
+ *
+ year field.or.null sortify
+ *
+ " "
+ *
+ title field.or.null
+ sort.format.title
+ *
+ #1 entry.max$ substring$
+ 'sort.key$ :=
+}
+
+ITERATE {bib.sort.order}
+
+SORT
+
+FUNCTION {begin.bib}
+{ preamble$ empty$
+ 'skip$
+ { preamble$ write$ newline$ }
+ if$
+ "\begin{thebibliography}{}" write$ newline$
+}
+
+EXECUTE {begin.bib}
+
+EXECUTE {init.state.consts}
+
+ITERATE {call.type$}
+
+FUNCTION {end.bib}
+{ newline$
+ "\end{thebibliography}" write$ newline$
+}
+
+EXECUTE {end.bib}
+%% End of customized bst file
+
diff --git a/man/AbstractCBS.Rd b/man/AbstractCBS.Rd
new file mode 100644
index 0000000..22fd729
--- /dev/null
+++ b/man/AbstractCBS.Rd
@@ -0,0 +1,82 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{AbstractCBS}
+\docType{class}
+\alias{AbstractCBS}
+
+
+\title{The AbstractCBS class}
+
+\description{
+ Package: PSCBS \cr
+\bold{Class AbstractCBS}\cr
+
+\code{list}\cr
+\code{~~|}\cr
+\code{~~+--}\emph{\code{AbstractCBS}}\cr
+
+\bold{Directly known subclasses:}\cr
+\emph{\link[PSCBS]{CBS}}, \emph{\link[PSCBS]{NonPairedPSCBS}}, \emph{\link[PSCBS]{PSCBS}}, \emph{\link[PSCBS]{PairedPSCBS}}\cr
+
+public abstract static class \bold{AbstractCBS}\cr
+extends list\cr
+
+
+
+ All CBS-style segmentation results extend this class, e.g.
+ \code{\link{CBS}} and \code{\link{PairedPSCBS}}.
+}
+
+\usage{
+AbstractCBS(fit=list(), sampleName=fit$sampleName, ...)
+}
+
+\arguments{
+ \item{fit}{A \code{\link[base]{list}} structure containing the segmentation results.}
+ \item{sampleName}{A \code{\link[base]{character}} string.}
+ \item{...}{Not used.}
+}
+
+\section{Fields and Methods}{
+ \bold{Methods:}\cr
+\tabular{rll}{
+ \tab \code{adjustPloidyScale} \tab -\cr
+ \tab \code{append} \tab -\cr
+ \tab \code{extractCNs} \tab -\cr
+ \tab \code{getChangePoints} \tab -\cr
+ \tab \code{getChromosomes} \tab -\cr
+ \tab \code{getLocusData} \tab -\cr
+ \tab \code{getSegmentSizes} \tab -\cr
+ \tab \code{getSegments} \tab -\cr
+ \tab \code{load} \tab -\cr
+ \tab \code{mergeThreeSegments} \tab -\cr
+ \tab \code{nbrOfChangePoints} \tab -\cr
+ \tab \code{nbrOfChromosomes} \tab -\cr
+ \tab \code{nbrOfLoci} \tab -\cr
+ \tab \code{nbrOfSegments} \tab -\cr
+ \tab \code{ploidy} \tab -\cr
+ \tab \code{ploidy<-} \tab -\cr
+ \tab \code{plotTracks} \tab -\cr
+ \tab \code{sampleCNs} \tab -\cr
+ \tab \code{save} \tab -\cr
+ \tab \code{writeWIG} \tab -\cr
+}
+
+
+ \bold{Methods inherited from list}:\cr
+all.equal, as.data.frame, attachLocally, callHooks, relist, within
+
+
+}
+
+\author{Henrik Bengtsson}
+
+
+\keyword{classes}
+\keyword{internal}
diff --git a/man/CBS.Rd b/man/CBS.Rd
new file mode 100644
index 0000000..89fdbdb
--- /dev/null
+++ b/man/CBS.Rd
@@ -0,0 +1,81 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% CBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{CBS}
+\docType{class}
+\alias{CBS}
+
+
+\title{The CBS class}
+
+\description{
+ A CBS object holds results from the
+ Circular Binary Segmentation (CBS) method
+ for \emph{one} sample for one or more chromosomes.
+
+ Package: PSCBS \cr
+\bold{Class CBS}\cr
+
+\code{list}\cr
+\code{~~|}\cr
+\code{~~+--}\code{\link[PSCBS]{AbstractCBS}}\cr
+\code{~~~~~~~|}\cr
+\code{~~~~~~~+--}\emph{\code{CBS}}\cr
+
+\bold{Directly known subclasses:}\cr
+\cr
+
+public abstract static class \bold{CBS}\cr
+extends \emph{\link[PSCBS]{AbstractCBS}}\cr
+
+
+}
+
+\usage{
+CBS(...)
+}
+
+\arguments{
+ \item{...}{Arguments passed to the constructor of \code{\link{AbstractCBS}}.}
+}
+
+\section{Fields and Methods}{
+ \bold{Methods:}\cr
+\tabular{rll}{
+ \tab \code{append} \tab -\cr
+ \tab \code{as} \tab -\cr
+ \tab \code{estimateStandardDeviation} \tab -\cr
+ \tab \code{plotTracks} \tab -\cr
+ \tab \code{pruneBySdUndo} \tab -\cr
+ \tab \code{segmentByCBS} \tab -\cr
+ \tab \code{seqOfSegmentsByDP} \tab -\cr
+ \tab \code{writeSegments} \tab -\cr
+}
+
+
+ \bold{Methods inherited from AbstractCBS}:\cr
+adjustPloidyScale, all.equal, append, as.data.frame, clearCalls, drawChangePoints, drawKnownSegments, dropChangePoint, dropChangePoints, dropRegion, dropRegions, extractCNs, extractChromosome, extractChromosomes, extractRegions, extractSegments, extractWIG, getChangePoints, getChromosomeOffsets, getChromosomeRanges, getChromosomes, getLocusData, getLocusSignalNames, getMeanEstimators, getSampleName, getSegmentSizes, getSegmentTrackPrefixes, getSegments, load, mergeThreeSegments, mergeTwo [...]
+
+ \bold{Methods inherited from list}:\cr
+all.equal, as.data.frame, attachLocally, callHooks, relist, within
+
+
+}
+
+\section{Difference to DNAcopy object}{
+ A CBS object is similar to DNAcopy objects with the major
+ difference that a CBS object holds only one sample, whereas
+ a DNAcopy object can hold more than one sample.
+}
+
+\section{See also}{
+ The \code{\link{segmentByCBS}}() method returns an object of this class.
+}
+
+\author{Henrik Bengtsson}
+\keyword{classes}
diff --git a/man/Non-documented_objects.Rd b/man/Non-documented_objects.Rd
new file mode 100644
index 0000000..da38ab9
--- /dev/null
+++ b/man/Non-documented_objects.Rd
@@ -0,0 +1,332 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% 999.NonDocumentedObjects.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{Non-documented objects}
+\alias{Non-documented objects}
+\title{Non-documented objects}
+
+
+% Other missing docs
+\alias{extractWIG}
+\alias{extractWIG.AbstractCBS}
+\alias{extractWIG.CBS}
+\alias{extractWIG.PSCBS}
+\alias{all.equal.AbstractCBS}
+\alias{all.equal.CBS}
+\alias{append}
+\alias{append.default}
+\alias{applyByRegion}
+\alias{applyByRegion.PairedPSCBS}
+\alias{arrowsC1C2}
+\alias{arrowsC1C2.PairedPSCBS}
+\alias{arrowsDeltaC1C2}
+\alias{arrowsDeltaC1C2.PairedPSCBS}
+\alias{as.CBS}
+\alias{as.DNAcopy}
+\alias{as.character.CBS}
+\alias{as.data.frame.PSCBS}
+\alias{bootstrapCIs}
+\alias{bootstrapCIs.PairedPSCBS}
+\alias{bootstrapDHByRegion}
+\alias{bootstrapDHByRegion.PairedPSCBS}
+\alias{bootstrapTCNandDHByRegion}
+\alias{callAB}
+\alias{callABandHighAI}
+\alias{callABandHighAI.PairedPSCBS}
+\alias{callABandLowC1}
+\alias{callABandLowC1.PairedPSCBS}
+\alias{callAllelicBalance}
+\alias{callAllelicBalance.default}
+\alias{callAllelicBalanceByDH}
+\alias{callAmplifications}
+\alias{callArms}
+\alias{callArms.CBS}
+\alias{callExtremeAllelicImbalanceByDH}
+\alias{callExtremeAllelicImbalanceByDH.PairedPSCBS}
+\alias{callGainsAndLosses}
+\alias{callLOH}
+\alias{callLowC1ByC1}
+\alias{callLowC1ByC1.PairedPSCBS}
+\alias{callOutliers}
+\alias{drawCentromeres}
+\alias{drawCentromeres.CBS}
+\alias{drawChromosomes}
+\alias{drawChromosomes.CBS}
+\alias{drawConfidenceBands}
+\alias{drawConfidenceBands.PairedPSCBS}
+\alias{drawLevels}
+\alias{drawLevels.CBS}
+\alias{drawLevels.DNAcopy}
+\alias{drawLevels.PairedPSCBS}
+\alias{dropChangePoint}
+\alias{dropRegion}
+\alias{dropRegions}
+\alias{estimateDeltaAB}
+\alias{estimateDeltaABBySmallDH}
+\alias{estimateDeltaLOH}
+\alias{estimateDeltaLOHByMinC1ForNonAB}
+\alias{estimateHighDHQuantileAtAB}
+\alias{estimateHighDHQuantileAtAB.PairedPSCBS}
+\alias{estimateKappa}
+\alias{estimateKappaByC1Density}
+\alias{estimateMeanForDH}
+\alias{estimateMeanForDH.PairedPSCBS}
+\alias{estimateStandardDeviation}
+\alias{estimateStandardDeviation.DNAcopy}
+\alias{estimateStdDevForHeterozygousBAF}
+\alias{estimateStdDevForHeterozygousBAF.PairedPSCBS}
+\alias{extractC1C2}
+\alias{extractCallsByLocus}
+\alias{extractCallsByLocus.PairedPSCBS}
+\alias{extractCallsByLocus.CBS}
+\alias{extractChromosome}
+\alias{extractChromosome.AbstractCBS}
+\alias{extractChromosomes}
+\alias{extractChromosomes.AbstractCBS}
+\alias{extractChromosomes.CBS}
+\alias{extractChromosomes.PSCBS}
+\alias{extractDeltaC1C2}
+\alias{extractDeltaC1C2.PairedPSCBS}
+\alias{extractLocusLevelC1C2}
+\alias{extractLocusLevelC1C2.PairedPSCBS}
+\alias{extractLocusLevelTCN}
+\alias{extractLocusLevelTCN.PairedPSCBS}
+\alias{extractMinorMajorCNs}
+\alias{extractRegion}
+\alias{extractRegion.AbstractCBS}
+\alias{extractRegions}
+\alias{extractRegions.AbstractCBS}
+\alias{extractSegmentMeansByLocus}
+\alias{extractSegmentMeansByLocus.DNAcopy}
+\alias{extractTCNAndDHs}
+\alias{getCallStatistics}
+\alias{getCallStatisticsByArms}
+\alias{getCallStatisticsByArms.CBS}
+\alias{getChromosomeOffsets}
+\alias{getChromosomeRanges}
+\alias{getChromosomeRanges.CBS}
+\alias{getChromosomes}
+\alias{getChromosomes.DNAcopy}
+\alias{getFGA}
+\alias{getFGG}
+\alias{getFGL}
+\alias{getFractionOfGenomeAltered}
+\alias{getFractionOfGenomeGained}
+\alias{getFractionOfGenomeLost}
+\alias{getLocusData}
+\alias{getLocusData.CBS}
+\alias{getLocusData.PSCBS}
+\alias{getSampleName}
+\alias{getSampleNames}
+\alias{getSampleNames.DNAcopy}
+\alias{getSegments}
+\alias{getSegments.CBS}
+\alias{getSignalType}
+\alias{getSignalType.CBS}
+\alias{highlightArmCalls}
+\alias{highlightArmCalls.CBS}
+\alias{highlightCalls}
+\alias{highlightCalls.CBS}
+\alias{highlightLocusCalls}
+\alias{highlightLocusCalls.CBS}
+\alias{isWholeChromosomeGained}
+\alias{isWholeChromosomeGained.CBS}
+\alias{isWholeChromosomeLost}
+\alias{isWholeChromosomeLost.CBS}
+\alias{joinSegments}
+\alias{linesC1C2}
+\alias{linesC1C2.PairedPSCBS}
+\alias{linesDeltaC1C2}
+\alias{linesDeltaC1C2.PairedPSCBS}
+\alias{mergeNonCalledSegments}
+\alias{mergeTwoSegments}
+\alias{mergeTwoSegments.CBS}
+\alias{nbrOfAmplifications}
+\alias{nbrOfAmplifications.CBS}
+\alias{nbrOfChangePoints}
+\alias{nbrOfChromosomes}
+\alias{nbrOfGains}
+\alias{nbrOfGains.CBS}
+\alias{nbrOfLoci}
+\alias{nbrOfLoci.DNAcopy}
+\alias{nbrOfLosses}
+\alias{nbrOfLosses.CBS}
+\alias{nbrOfSamples}
+\alias{nbrOfSamples.DNAcopy}
+\alias{nbrOfSegments}
+\alias{nbrOfSegments.DNAcopy}
+\alias{plot.CBS}
+\alias{plot.PairedPSCBS}
+\alias{plotC1C2}
+\alias{plotC1C2.PairedPSCBS}
+\alias{plotDeltaC1C2}
+\alias{plotDeltaC1C2.PairedPSCBS}
+\alias{plotTracksManyChromosomes.CBS}
+\alias{pointsC1C2}
+\alias{pointsC1C2.PairedPSCBS}
+\alias{pointsDeltaC1C2}
+\alias{pointsDeltaC1C2.PairedPSCBS}
+\alias{postsegmentTCN}
+\alias{postsegmentTCN.PairedPSCBS}
+\alias{print.AbstractCBS}
+\alias{sampleName}
+\alias{sampleName<-}
+\alias{setLocusData}
+\alias{setSampleName}
+\alias{setSegments}
+\alias{signalType}
+\alias{signalType.CBS}
+\alias{signalType<-}
+\alias{signalType<-.CBS}
+\alias{subset.CBS}
+\alias{tileChromosomes}
+\alias{tileChromosomes.AbstractCBS}
+\alias{tileChromosomes.CBS}
+\alias{tileChromosomes.PairedPSCBS}
+\alias{writeLocusData}
+\alias{writeLocusData.CBS}
+\alias{writeSegments}
+\alias{extractSegments.AbstractCBS}
+\alias{extractSegment.AbstractCBS}
+\alias{extractSegment}
+\alias{extractSegments}
+\alias{extractSegments.CBS}
+\alias{extractSegments.PairedPSCBS}
+\alias{isSegmentSplitter}
+\alias{isSegmentSplitter.CBS}
+\alias{isSegmentSplitter.PSCBS}
+\alias{extractCNs}
+\alias{extractCNs.AbstractCBS}
+\alias{extractCNs.CBS}
+\alias{extractCNs.PairedPSCBS}
+\alias{extractTotalCNs}
+\alias{extractTotalCNs.CBS}
+\alias{getSegmentSizes}
+\alias{getSegmentSizes.AbstractCBS}
+\alias{getSegmentSizes.CBS}
+\alias{getSegmentSizes.PSCBS}
+\alias{sampleCNs}
+\alias{sampleCNs.AbstractCBS}
+\alias{mergeThreeSegments}
+\alias{callROH}
+\alias{callROHOneSegment}
+\alias{callROHOneSegment.PairedPSCBS}
+\alias{testROH}
+\alias{pruneBySdUndo}
+\alias{updateBoundaries}
+\alias{updateBoundaries.CBS}
+\alias{resegment}
+\alias{resegment.AbstractCBS}
+\alias{resegment.CBS}
+\alias{resegment.PairedPSCBS}
+\alias{hclustCNs}
+\alias{pruneByHClust}
+\alias{updateMeansTogether}
+\alias{updateMeans}
+\alias{drawChangePoints}
+\alias{drawChangePoints.AbstractCBS}
+\alias{drawKnownSegments}
+\alias{drawKnownSegments.AbstractCBS}
+\alias{drawChangePoints.CBS}
+\alias{drawChangePoints.PSCBS}
+\alias{drawChangePointsC1C2}
+\alias{drawChangePointsC1C2.PairedPSCBS}
+\alias{extractDhSegment}
+\alias{extractDhSegment.PairedPSCBS}
+\alias{callNTCN}
+\alias{callCopyNeutral}
+\alias{callCopyNeutralByTCNofAB}
+\alias{dropChangePoints}
+\alias{calcStatsForCopyNeutralABs}
+\alias{calcStatsForCopyNeutralABs.PairedPSCBS}
+\alias{callGainNeutralLoss}
+\alias{callGNL}
+\alias{renameChromosomes}
+\alias{renameChromosomes.AbstractCBS}
+\alias{report}
+\alias{writeSegments.DNAcopy}
+\alias{estimateDeltaCN}
+\alias{estimateDeltaCN.PairedPSCBS}
+\alias{shiftTCN}
+\alias{shiftTCN.AbstractCBS}
+\alias{shiftTCN.CBS}
+\alias{shiftTCN.PairedPSCBS}
+\alias{getChromosomeOffsets.AbstractCBS}
+\alias{getChromosomeRanges.PairedPSCBS}
+\alias{getChromosomeRanges.AbstractCBS}
+\alias{seqOfSegmentsByDP}
+\alias{seqOfSegmentsByDP.AbstractCBS}
+\alias{seqOfSegmentsByDP.CBS}
+\alias{seqOfSegmentsByDP.PairedPSCBS}
+\alias{seqOfSegmentsByDP.matrix}
+\alias{getChromosomeOffsets.PairedPSCBS}
+\alias{getLocusSignalNames}
+\alias{getLocusSignalNames.AbstractCBS}
+\alias{getLocusSignalNames.CBS}
+\alias{getLocusSignalNames.PSCBS}
+\alias{getSegmentTrackPrefixes}
+\alias{getSegmentTrackPrefixes.AbstractCBS}
+\alias{getSegmentTrackPrefixes.CBS}
+\alias{getSegmentTrackPrefixes.PSCBS}
+\alias{pruneByDP}
+\alias{getMeanEstimators}
+\alias{getMeanEstimators.AbstractCBS}
+\alias{resegment.NonPairedPSCBS}
+\alias{setMeanEstimators}
+\alias{setMeanEstimators.AbstractCBS}
+\alias{resetSegments}
+\alias{getLocusData.NonPairedPSCBS}
+\alias{getLocusData.PairedPSCBS}
+\alias{plotTracks}
+\alias{plotTracks1}
+\alias{plotTracks2}
+\alias{plotTracksManyChromosomes}
+\alias{getSmoothLocusData}
+\alias{bootstrapSegmentsAndChangepoints}
+\alias{bootstrapSegmentsAndChangepoints.PairedPSCBS}
+\alias{getChangePoints}
+\alias{getChangePoints.AbstractCBS}
+\alias{getChangePoints.CBS}
+\alias{getChangePoints.PSCBS}
+\alias{clearBootstrapSummaries}
+\alias{clearBootstrapSummaries.PairedPSCBS}
+\alias{findBootstrapSummaries}
+\alias{findBootstrapSummaries.PairedPSCBS}
+\alias{hasBootstrapSummaries}
+\alias{hasBootstrapSummaries.PairedPSCBS}
+\alias{clearCalls}
+\alias{clearCalls.AbstractCBS}
+\alias{estimateDeltaCN.CBS}
+\alias{extractSegmentDataByLocus}
+\alias{extractSegmentDataByLocus.PairedPSCBS}
+\alias{updateMeansC1C2}
+\alias{updateMeansC1C2.PairedPSCBS}
+\alias{encodeCalls}
+\alias{encodeCalls.data.frame}
+\alias{callGLAO}
+\alias{callGLAO.CBS}
+\alias{unTumorBoost}
+\alias{unTumorBoost.PairedPSCBS}
+
+\description{
+ This page contains aliases for all "non-documented" objects that
+ \code{R CMD check} detects in this package.
+
+ Almost all of them are \emph{generic} functions that have specific
+ document for the corresponding method coupled to a specific class.
+ Other functions are re-defined by \code{setMethodS3()} to
+ \emph{default} methods. Neither of these two classes are non-documented
+ in reality.
+ The rest are deprecated methods.
+}
+
+\author{Henrik Bengtsson}
+
+
+\keyword{documentation}
+\keyword{internal}
diff --git a/man/NonPairedPSCBS.Rd b/man/NonPairedPSCBS.Rd
new file mode 100644
index 0000000..72b6159
--- /dev/null
+++ b/man/NonPairedPSCBS.Rd
@@ -0,0 +1,69 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% NonPairedPSCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{NonPairedPSCBS}
+\docType{class}
+\alias{NonPairedPSCBS}
+
+
+\title{The NonPairedPSCBS class}
+
+\description{
+ Package: PSCBS \cr
+\bold{Class NonPairedPSCBS}\cr
+
+\code{list}\cr
+\code{~~|}\cr
+\code{~~+--}\code{\link[PSCBS]{AbstractCBS}}\cr
+\code{~~~~~~~|}\cr
+\code{~~~~~~~+--}\code{\link[PSCBS]{PSCBS}}\cr
+\code{~~~~~~~~~~~~|}\cr
+\code{~~~~~~~~~~~~+--}\emph{\code{NonPairedPSCBS}}\cr
+
+\bold{Directly known subclasses:}\cr
+\cr
+
+public abstract static class \bold{NonPairedPSCBS}\cr
+extends \emph{\link[PSCBS]{PSCBS}}\cr
+
+
+
+ A NonPairedPSCBS is an object containing the results from the
+ Non-paired PSCBS method.
+}
+
+\usage{NonPairedPSCBS(fit=list(), ...)}
+
+\arguments{
+ \item{fit}{A \code{\link[base]{list}} structure containing the Non-paired PSCBS results.}
+ \item{...}{Not used.}
+}
+
+\section{Fields and Methods}{
+ \bold{Methods:}\cr
+\emph{No methods defined}.
+
+
+ \bold{Methods inherited from PSCBS}:\cr
+append, as.data.frame, drawChangePoints, extractChromosomes, extractWIG, getLocusData, getLocusSignalNames, getSegmentTrackPrefixes, isSegmentSplitter, writeSegments
+
+ \bold{Methods inherited from AbstractCBS}:\cr
+adjustPloidyScale, all.equal, append, as.data.frame, clearCalls, drawChangePoints, drawKnownSegments, dropChangePoint, dropChangePoints, dropRegion, dropRegions, extractCNs, extractChromosome, extractChromosomes, extractRegions, extractSegments, extractWIG, getChangePoints, getChromosomeOffsets, getChromosomeRanges, getChromosomes, getLocusData, getLocusSignalNames, getMeanEstimators, getSampleName, getSegmentSizes, getSegmentTrackPrefixes, getSegments, load, mergeThreeSegments, mergeTwo [...]
+
+ \bold{Methods inherited from list}:\cr
+all.equal, as.data.frame, attachLocally, callHooks, relist, within
+
+
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ The \code{\link{segmentByNonPairedPSCBS}}() method returns an object of this class.
+}
+\keyword{classes}
diff --git a/man/PSCBS-package.Rd b/man/PSCBS-package.Rd
new file mode 100644
index 0000000..e9aaaeb
--- /dev/null
+++ b/man/PSCBS-package.Rd
@@ -0,0 +1,66 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% 999.package.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{PSCBS-package}
+\alias{PSCBS-package}
+
+\docType{package}
+
+\title{Package PSCBS}
+
+
+
+\description{
+ Segmentation of allele-specific DNA copy number data and detection of regions with abnormal copy number within each parental chromosome. Both tumor-normal paired and tumor-only analyses are supported..
+
+ This package should be considered to be in an alpha or beta phase.
+ You should expect the API to be changing over time.
+}
+
+\section{Installation and updates}{
+ To install this package, use \code{install.packages("PSCBS")}.
+}
+
+\section{To get started}{
+ To get started, see:
+ \enumerate{
+ \item Vignettes '\href{../doc/index.html}{Parent-specific copy-number segmentation using Paired PSCBS}' and '\href{../doc/index.html}{Total copy-number segmentation using CBS}'.
+ \item \code{\link{segmentByCBS}}() - segments total copy-numbers, or any
+ other unimodal genomic signals, using the CBS method [3,4].
+ \item \code{\link{segmentByPairedPSCBS}}() - segments allele-specific
+ tumor signal from a tumor \emph{with} a matched normal
+ using the Paired PSCBS method [1,2].
+ \item \code{\link{segmentByNonPairedPSCBS}}() - segments allele-specific
+ tumor signal from a tumor \emph{without} a matched normal
+ using the Non-Paired PSCBS method adopted from [1,2].
+ }
+}
+
+\section{How to cite}{
+ Please use [1] and [2] to cite when using Paired PSCBS,
+ and [3] and [4] when using CBS.
+ When using Non-Paired PSCBS, please cite [1] and [2] as well.
+}
+
+\author{Henrik Bengtsson}
+
+\section{License}{
+ GPL (>= 2).
+}
+
+\references{
+ [1] A.B. Olshen, H. Bengtsson, P. Neuvial, P.T. Spellman, R.A. Olshen, V.E. Seshan, \emph{Parent-specific copy number in paired tumor-normal studies using circular binary segmentation}, Bioinformatics, 2011
+ \cr
+ [2] H. Bengtsson, P. Neuvial and T.P. Speed, \emph{TumorBoost: Normalization of allele-specific tumor copy numbers from a single pair of tumor-normal genotyping microarrays}, BMC Bioinformatics, 2010
+ \cr
+ [3] A.B. Olshen, E.S. Venkatraman (aka Venkatraman E. Seshan), R. Lucito and M. Wigler, \emph{Circular binary segmentation for the analysis of array-based DNA copy number data}, Biostatistics, 2004
+ \cr
+ [4] E.S. Venkatraman and A.B. Olshen, \emph{A faster circular binary segmentation algorithm for the analysis of array CGH data}, Bioinformatics, 2007
+ \cr
+}
+\keyword{package}
diff --git a/man/PSCBS.Rd b/man/PSCBS.Rd
new file mode 100644
index 0000000..3879a17
--- /dev/null
+++ b/man/PSCBS.Rd
@@ -0,0 +1,67 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PSCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{PSCBS}
+\docType{class}
+\alias{PSCBS}
+
+
+\title{The PSCBS class}
+
+\description{
+ Package: PSCBS \cr
+\bold{Class PSCBS}\cr
+
+\code{list}\cr
+\code{~~|}\cr
+\code{~~+--}\code{\link[PSCBS]{AbstractCBS}}\cr
+\code{~~~~~~~|}\cr
+\code{~~~~~~~+--}\emph{\code{PSCBS}}\cr
+
+\bold{Directly known subclasses:}\cr
+\emph{\link[PSCBS]{NonPairedPSCBS}}, \emph{\link[PSCBS]{PairedPSCBS}}\cr
+
+public abstract static class \bold{PSCBS}\cr
+extends \emph{\link[PSCBS]{AbstractCBS}}\cr
+
+
+
+ A PSCBS is an object containing results from parent-specific copy-number
+ (PSCN) segmentation.
+}
+
+\usage{PSCBS(fit=list(), ...)}
+
+\arguments{
+ \item{fit}{A \code{\link[base]{list}} structure containing the PSCN segmentation results.}
+ \item{...}{Not used.}
+}
+
+\section{Fields and Methods}{
+ \bold{Methods:}\cr
+\tabular{rll}{
+ \tab \code{append} \tab -\cr
+ \tab \code{writeSegments} \tab -\cr
+}
+
+
+ \bold{Methods inherited from AbstractCBS}:\cr
+adjustPloidyScale, all.equal, append, as.data.frame, clearCalls, drawChangePoints, drawKnownSegments, dropChangePoint, dropChangePoints, dropRegion, dropRegions, extractCNs, extractChromosome, extractChromosomes, extractRegions, extractSegments, extractWIG, getChangePoints, getChromosomeOffsets, getChromosomeRanges, getChromosomes, getLocusData, getLocusSignalNames, getMeanEstimators, getSampleName, getSegmentSizes, getSegmentTrackPrefixes, getSegments, load, mergeThreeSegments, mergeTwo [...]
+
+ \bold{Methods inherited from list}:\cr
+all.equal, as.data.frame, attachLocally, callHooks, relist, within
+
+
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ \code{\link{PairedPSCBS}}.
+}
+\keyword{classes}
diff --git a/man/PairedPSCBS.Rd b/man/PairedPSCBS.Rd
new file mode 100644
index 0000000..9ecbd1f
--- /dev/null
+++ b/man/PairedPSCBS.Rd
@@ -0,0 +1,87 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{PairedPSCBS}
+\docType{class}
+\alias{PairedPSCBS}
+
+
+\title{The PairedPSCBS class}
+
+\description{
+ Package: PSCBS \cr
+\bold{Class PairedPSCBS}\cr
+
+\code{list}\cr
+\code{~~|}\cr
+\code{~~+--}\code{\link[PSCBS]{AbstractCBS}}\cr
+\code{~~~~~~~|}\cr
+\code{~~~~~~~+--}\code{\link[PSCBS]{PSCBS}}\cr
+\code{~~~~~~~~~~~~|}\cr
+\code{~~~~~~~~~~~~+--}\emph{\code{PairedPSCBS}}\cr
+
+\bold{Directly known subclasses:}\cr
+\cr
+
+public abstract static class \bold{PairedPSCBS}\cr
+extends \emph{\link[PSCBS]{PSCBS}}\cr
+
+
+
+ A PairedPSCBS is an object containing the results from the
+ Paired PSCBS method.
+}
+
+\usage{PairedPSCBS(fit=list(), ...)}
+
+\arguments{
+ \item{fit}{A \code{\link[base]{list}} structure containing the Paired PSCBS results.}
+ \item{...}{Not used.}
+}
+
+\section{Fields and Methods}{
+ \bold{Methods:}\cr
+\tabular{rll}{
+ \tab \code{callAB} \tab -\cr
+ \tab \code{callCopyNeutral} \tab -\cr
+ \tab \code{callGNL} \tab -\cr
+ \tab \code{callGNLByTCNofAB} \tab -\cr
+ \tab \code{callGainNeutralLoss} \tab -\cr
+ \tab \code{callLOH} \tab -\cr
+ \tab \code{callNTCN} \tab -\cr
+ \tab \code{callROH} \tab -\cr
+ \tab \code{estimateDeltaAB} \tab -\cr
+ \tab \code{estimateDeltaLOH} \tab -\cr
+ \tab \code{estimateKappa} \tab -\cr
+ \tab \code{extractCNs} \tab -\cr
+ \tab \code{hasBootstrapSummaries} \tab -\cr
+ \tab \code{plotTracks} \tab -\cr
+ \tab \code{segmentByNonPairedPSCBS} \tab -\cr
+ \tab \code{segmentByPairedPSCBS} \tab -\cr
+ \tab \code{seqOfSegmentsByDP} \tab -\cr
+}
+
+
+ \bold{Methods inherited from PSCBS}:\cr
+append, as.data.frame, drawChangePoints, extractChromosomes, extractWIG, getLocusData, getLocusSignalNames, getSegmentTrackPrefixes, isSegmentSplitter, writeSegments
+
+ \bold{Methods inherited from AbstractCBS}:\cr
+adjustPloidyScale, all.equal, append, as.data.frame, clearCalls, drawChangePoints, drawKnownSegments, dropChangePoint, dropChangePoints, dropRegion, dropRegions, extractCNs, extractChromosome, extractChromosomes, extractRegions, extractSegments, extractWIG, getChangePoints, getChromosomeOffsets, getChromosomeRanges, getChromosomes, getLocusData, getLocusSignalNames, getMeanEstimators, getSampleName, getSegmentSizes, getSegmentTrackPrefixes, getSegments, load, mergeThreeSegments, mergeTwo [...]
+
+ \bold{Methods inherited from list}:\cr
+all.equal, as.data.frame, attachLocally, callHooks, relist, within
+
+
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ The \code{\link{segmentByPairedPSCBS}}() method returns an object of this class.
+}
+\keyword{classes}
diff --git a/man/Restructuring_AbstractCBS_objects.Rd b/man/Restructuring_AbstractCBS_objects.Rd
new file mode 100644
index 0000000..d04d466
--- /dev/null
+++ b/man/Restructuring_AbstractCBS_objects.Rd
@@ -0,0 +1,72 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.RESTRUCT.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{Restructuring AbstractCBS objects}
+\alias{Restructuring AbstractCBS objects}
+\title{Restructuring AbstractCBS objects}
+
+\alias{RestructPSCBS}
+
+\description{
+ This page describes available methods for restructuring an
+ \code{\link{AbstractCBS}} object.
+
+ \itemize{
+ \item \code{\link[PSCBS:append.AbstractCBS]{*append}()}
+ - Appends one \code{\link{AbstractCBS}} to another.
+
+ \item \code{\link[PSCBS:extractChromosomes.AbstractCBS]{*extractChromosomes}()} /
+ \code{\link[PSCBS:extractChromosome.AbstractCBS]{*extractChromosome}()}
+ - Extracts an \code{\link{AbstractCBS}} with the specified chromosomes.
+
+ \item \code{\link[PSCBS:extractSegments.AbstractCBS]{*extractSegments}()} /
+ \code{\link[PSCBS:extractSegment.AbstractCBS]{*extractSegment}()}
+ - Extracts an \code{\link{AbstractCBS}} with the specified segments.
+
+ \item \code{\link[PSCBS:extractRegions.AbstractCBS]{*extractRegions}()} /
+ \code{\link[PSCBS:extractRegion.AbstractCBS]{*extractRegion}()}
+ - Extracts an \code{\link{AbstractCBS}} with the specified regions
+ each of a certain size, where a region is defined as a
+ connected set of segments.
+
+ \item \code{\link[PSCBS:dropRegions.AbstractCBS]{*dropRegions}()} /
+ \code{\link[PSCBS:dropRegion.AbstractCBS]{*dropRegion}()}
+ - Drops specified regions and returns an \code{\link{AbstractCBS}}
+ without them.
+
+ \item \code{\link[PSCBS:dropChangePoint.AbstractCBS]{*dropChangePoint}()} /
+ \code{\link[PSCBS:mergeTwoSegments.AbstractCBS]{*mergeTwoSegments}()}
+ - Drops a change point by merging two neighboring segments
+ and recalculates the statistics for the merged segment
+ before returning an \code{\link{AbstractCBS}}.
+
+ \item \code{\link[PSCBS:dropChangePoints.AbstractCBS]{*dropChangePoints}()}
+ - Drops zero or more change points
+ and recalculates the segment statistics
+ before returning an \code{\link{AbstractCBS}}.
+
+ \item \code{\link[PSCBS:mergeThreeSegments.AbstractCBS]{*mergeThreeSegments}()}
+ - Merges a segment with its two flanking segments
+ and recalculates the statistics for the merged segment
+ before returning an \code{\link{AbstractCBS}}.
+ }
+
+ All of the above methods are implemented for \code{\link{CBS}} and
+ \code{\link{PairedPSCBS}} objects.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{AbstractCBS}}.
+}
+
+
+\keyword{documentation}
+\keyword{internal}
diff --git a/man/append.AbstractCBS.Rd b/man/append.AbstractCBS.Rd
new file mode 100644
index 0000000..3de3571
--- /dev/null
+++ b/man/append.AbstractCBS.Rd
@@ -0,0 +1,42 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.RESTRUCT.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{append.AbstractCBS}
+\alias{append.AbstractCBS}
+\alias{AbstractCBS.append}
+\alias{append,AbstractCBS-method}
+
+\title{Appends one segmentation result to another}
+
+\description{
+ Appends one segmentation result to another,
+ where both holds segmentation results \emph{of the same sample}.
+}
+
+\usage{
+\method{append}{AbstractCBS}(...)
+}
+
+\arguments{
+ \item{x, other}{The two \code{\link{AbstractCBS}} objects to be combined.}
+ \item{addSplit}{If \code{\link[base:logical]{TRUE}}, a "divider" is added between chromosomes.}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns a object of the same class as argument \code{x}.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{AbstractCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/append.CBS.Rd b/man/append.CBS.Rd
new file mode 100644
index 0000000..d9c5eff
--- /dev/null
+++ b/man/append.CBS.Rd
@@ -0,0 +1,42 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% CBS.RESTRUCT.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{append.CBS}
+\alias{append.CBS}
+\alias{CBS.append}
+\alias{append,CBS-method}
+
+\title{Appends one segmentation result to another}
+
+\description{
+ Appends one segmentation result to another.
+}
+
+\usage{
+\method{append}{CBS}(x, other, addSplit=TRUE, ...)
+}
+
+\arguments{
+ \item{x, other}{The two \code{\link{CBS}} objects to be combined.}
+ \item{other}{A \code{\link{PSCBS}} object.}
+ \item{addSplit}{If \code{\link[base:logical]{TRUE}}, a "divider" is added between chromosomes.}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns a \code{\link{CBS}} object of the same class as argument \code{x}.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{CBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/append.PSCBS.Rd b/man/append.PSCBS.Rd
new file mode 100644
index 0000000..1bf8612
--- /dev/null
+++ b/man/append.PSCBS.Rd
@@ -0,0 +1,42 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PSCBS.RESTRUCT.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{append.PSCBS}
+\alias{append.PSCBS}
+\alias{PSCBS.append}
+\alias{append,PSCBS-method}
+
+\title{Appends one segmentation result to another}
+
+\description{
+ Appends one segmentation result to another.
+}
+
+\usage{
+\method{append}{PSCBS}(x, other, addSplit=TRUE, ...)
+}
+
+\arguments{
+ \item{x, other}{The two \code{\link{PSCBS}} objects to be combined.}
+ \item{other}{A \code{\link{PSCBS}} object.}
+ \item{addSplit}{If \code{\link[base:logical]{TRUE}}, a "divider" is added between chromosomes.}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns a \code{\link{PSCBS}} object of the same class as argument \code{x}.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{PSCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/as.CBS.DNAcopy.Rd b/man/as.CBS.DNAcopy.Rd
new file mode 100644
index 0000000..d143717
--- /dev/null
+++ b/man/as.CBS.DNAcopy.Rd
@@ -0,0 +1,45 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% CBS.EXTS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{as.CBS.DNAcopy}
+\alias{as.CBS.DNAcopy}
+\alias{DNAcopy.as.CBS}
+\alias{as.CBS,DNAcopy-method}
+
+\title{Coerces a DNAcopy object to a CBS object}
+
+\description{
+ Coerces a DNAcopy object to a CBS object.
+}
+
+\usage{
+\method{as.CBS}{DNAcopy}(fit, sample=1L, ...)
+}
+
+\arguments{
+ \item{fit}{A \code{\link{DNAcopy}} object (of the \pkg{DNAcopy} package.)}
+ \item{sample}{An index specifying which sample to extract,
+ if more than one exists.}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns a \code{\link{CBS}} object.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ \code{\link[PSCBS:as.DNAcopy.CBS]{as.DNAcopy()}}.
+ For more information see \code{\link{DNAcopy}}.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/as.DNAcopy.CBS.Rd b/man/as.DNAcopy.CBS.Rd
new file mode 100644
index 0000000..e5bd108
--- /dev/null
+++ b/man/as.DNAcopy.CBS.Rd
@@ -0,0 +1,88 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% DNAcopy.EXTS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{as.DNAcopy.CBS}
+\alias{as.DNAcopy.CBS}
+\alias{CBS.as.DNAcopy}
+\alias{as.DNAcopy,CBS-method}
+
+\title{Coerces a CBS object to a DNAcopy object}
+
+\description{
+ Coerces a CBS object to a DNAcopy object.
+}
+
+\usage{
+\method{as.DNAcopy}{CBS}(fit, ...)
+}
+
+\arguments{
+ \item{fit}{A \code{\link{CBS}} object."}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns a \code{\link{DNAcopy}} object (of the \pkg{DNAcopy} package).
+}
+
+\examples{
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Simulating copy-number data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+set.seed(0xBEEF)
+
+# Number of loci
+J <- 1000
+
+mu <- double(J)
+mu[200:300] <- mu[200:300] + 1
+mu[350:400] <- NA # centromere
+mu[650:800] <- mu[650:800] - 1
+eps <- rnorm(J, sd=1/2)
+y <- mu + eps
+x <- sort(runif(length(y), max=length(y))) * 1e5
+w <- runif(J)
+w[650:800] <- 0.001
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- segmentByCBS(y, x=x)
+print(fit)
+plotTracks(fit)
+
+
+
+# Coerce an CBS object to a DNAcopy object
+fitD <- as.DNAcopy(fit)
+
+# Coerce an DNAcopy object to a CBS object
+fitC <- as.CBS(fitD)
+
+# Sanity check
+fitD2 <- as.DNAcopy(fit)
+stopifnot(all.equal(fitD2, fitD))
+
+fitC2 <- as.CBS(fitD2)
+stopifnot(all.equal(fitC2, fitC))
+
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ \code{\link[PSCBS:as.CBS.DNAcopy]{as.CBS()}}.
+ For more information see \code{\link{CBS}}.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/as.data.frame.AbstractCBS.Rd b/man/as.data.frame.AbstractCBS.Rd
new file mode 100644
index 0000000..4abbf15
--- /dev/null
+++ b/man/as.data.frame.AbstractCBS.Rd
@@ -0,0 +1,40 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{as.data.frame.AbstractCBS}
+\alias{as.data.frame.AbstractCBS}
+\alias{AbstractCBS.as.data.frame}
+\alias{as.data.frame,AbstractCBS-method}
+
+\title{Gets the table of segments}
+
+\description{
+ Gets the table of segments.
+}
+
+\usage{
+\method{as.data.frame}{AbstractCBS}(x, ...)
+}
+
+\arguments{
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns a \code{\link[base]{data.frame}}, where each row corresponds to
+ a unique segment.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Utilizes \code{\link[PSCBS:getSegments.AbstractCBS]{*getSegments}()}.
+ For more information see \code{\link{AbstractCBS}}..
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/as.data.frame.CBS.Rd b/man/as.data.frame.CBS.Rd
new file mode 100644
index 0000000..413b931
--- /dev/null
+++ b/man/as.data.frame.CBS.Rd
@@ -0,0 +1,42 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% CBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{as.data.frame.CBS}
+\alias{as.data.frame.CBS}
+\alias{CBS.as.data.frame}
+\alias{as.data.frame,CBS-method}
+
+\title{Gets the table of segments}
+
+\description{
+ Gets the table of segments.
+}
+
+\usage{
+\method{as.data.frame}{CBS}(x, ...)
+}
+
+\arguments{
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns a \code{\link[base]{data.frame}}, where each row corresponds to
+ a unique segment.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Utilizes \code{\link[PSCBS:getSegments.CBS]{*getSegments}()}.
+ For more information see \code{\link{CBS}}..
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/bootstrapTCNandDHByRegion.PairedPSCBS.Rd b/man/bootstrapTCNandDHByRegion.PairedPSCBS.Rd
new file mode 100644
index 0000000..8ce12e6
--- /dev/null
+++ b/man/bootstrapTCNandDHByRegion.PairedPSCBS.Rd
@@ -0,0 +1,51 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.BOOT.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{bootstrapTCNandDHByRegion.PairedPSCBS}
+\alias{bootstrapTCNandDHByRegion.PairedPSCBS}
+\alias{PairedPSCBS.bootstrapTCNandDHByRegion}
+\alias{bootstrapTCNandDHByRegion,PairedPSCBS-method}
+
+\title{Estimate confidence intervals of TCN and DH segment levels}
+
+\description{
+ Estimate confidence intervals of TCN and DH segment levels using bootstrap.
+}
+
+\usage{
+\method{bootstrapTCNandDHByRegion}{PairedPSCBS}(fit, B=1000L, boot=NULL, ..., probs=c(0.025, 0.05, 0.95,
+ 0.975), statsFcn=NULL, what=c("segment", "changepoint"), force=FALSE, verbose=FALSE,
+ .debug=FALSE)
+}
+
+\arguments{
+ \item{B}{A postive \code{\link[base]{integer}} specifying the number of bootstrap samples.}
+ \item{boot}{Alternatively, to generating \code{B} bootstrap samples,
+ this specifies a pre-generated set of bootstrap samples as
+ returned by \code{bootstrapSegmentsAndChangepoints()}.}
+ \item{...}{Additional arguments passed to \code{bootstrapSegmentsAndChangepoints()}.}
+ \item{probs}{The default quantiles to be estimated.}
+ \item{statsFcn}{A (optional) \code{\link[base]{function}} that estimates confidence
+ intervals given locus-level data.
+ If \code{\link[base]{NULL}}, the \code{\link[stats]{quantile}} function is used.}
+ \item{what}{A \code{\link[base]{character}} \code{\link[base]{vector}} specifying what to bootstrap.}
+ \item{force}{If \code{\link[base:logical]{TRUE}}, already existing estimates are ignored,
+ otherwise not.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+ \item{.debug}{(internal) If \code{\link[base:logical]{TRUE}}, additional sanity checks are
+ performed internally.}
+}
+
+\value{
+ Returns a \code{\link{PairedPSCBS}} object.
+}
+
+\author{Henrik Bengtsson}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/callAB.PairedPSCBS.Rd b/man/callAB.PairedPSCBS.Rd
new file mode 100644
index 0000000..9adc61c
--- /dev/null
+++ b/man/callAB.PairedPSCBS.Rd
@@ -0,0 +1,69 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.callAB.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{callAB.PairedPSCBS}
+\alias{callAB.PairedPSCBS}
+\alias{PairedPSCBS.callAB}
+\alias{callAB,PairedPSCBS-method}
+\alias{PairedPSCBS.callAllelicBalance}
+\alias{callAllelicBalance.PairedPSCBS}
+\alias{callAllelicBalance,PairedPSCBS-method}
+
+
+\title{Calls segments that are in allelic balance}
+
+\description{
+ Calls segments that are in allelic balance, i.e. that have equal minor and major copy numbers.
+}
+
+\usage{
+\method{callAB}{PairedPSCBS}(fit, flavor=c("DeltaAB*"), ..., minSize=1, xorCalls=TRUE, force=FALSE)
+}
+
+\arguments{
+ \item{flavor}{A \code{\link[base]{character}} string specifying which type of
+ call to use.}
+ \item{...}{Additional arguments passed to the caller.}
+ \item{minSize}{An optional \code{\link[base]{integer}} specifying the minimum number
+ of data points in order to call a segments. If fewer data points,
+ then the call is set to \code{\link[base]{NA}} regardless.}
+ \item{xorCalls}{If \code{\link[base:logical]{TRUE}}, a region already called LOH, will
+ for consistency never be called AB, resulting in either an AB
+ call set to \code{\link[base:logical]{FALSE}} or \code{\link[base]{NA}} (as explained below).}
+ \item{force}{If \code{\link[base:logical]{FALSE}}, and allelic-balance calls already exits,
+ then nothing is done, otherwise the calls are done.}
+}
+
+\value{
+ Returns a \code{\link{PairedPSCBS}} object with allelic-balance calls.
+}
+
+\section{AB and LOH consistency}{
+ Biologically, a segment can not be both in allelic balance (AB) and
+ in loss-of-heterozygosity (LOH) at the same time.
+ To avoid reporting such inconsistencies, the LOH caller will,
+ if argument \code{xorCalls=TRUE}, never report a segment to be in
+ LOH if it is already called to be in AB.
+ However, regardless of of the AB call, a segment is still always
+ tested for LOH, to check weather the LOH caller is consistent with the
+ AB caller or not. Thus, in order to distinguish the case where
+ the AB caller and LOH caller agree from when they disagree,
+ we report either (AB,LOH)=(TRUE,FALSE) or (TRUE,NA). The former is
+ reported when they are consistent, and the latter when they are not,
+ or when the AB caller could not call it.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Internally, one of the following methods are used:
+ \code{\link[PSCBS:callAllelicBalanceByDH.PairedPSCBS]{*callAllelicBalanceByDH}()}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/callAllelicBalanceByDH.PairedPSCBS.Rd b/man/callAllelicBalanceByDH.PairedPSCBS.Rd
new file mode 100644
index 0000000..e891120
--- /dev/null
+++ b/man/callAllelicBalanceByDH.PairedPSCBS.Rd
@@ -0,0 +1,58 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.callAB.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{callAllelicBalanceByDH.PairedPSCBS}
+\alias{callAllelicBalanceByDH.PairedPSCBS}
+\alias{PairedPSCBS.callAllelicBalanceByDH}
+\alias{callAllelicBalanceByDH,PairedPSCBS-method}
+
+\title{Calls segments that are in allelic balance}
+
+\description{
+ Calls segments that are in allelic balance by thresholding on DH using a predetermined threshold.
+ The variability of the DH mean levels is taken into account via a
+ bootstrap estimator.
+}
+
+\usage{
+\method{callAllelicBalanceByDH}{PairedPSCBS}(fit, delta=estimateDeltaAB(fit, flavor = "qq(DH)"), alpha=0.05,
+ ..., verbose=FALSE)
+}
+
+\arguments{
+ \item{flavor}{A \code{\link[base]{character}} string specifying which type of
+ call to use.}
+ \item{delta}{(Tuning parameter) A non-negative \code{\link[base]{numeric}} threshold.}
+ \item{alpha}{A \code{\link[base]{numeric}} in [0,1] specifying the upper and lower
+ quantiles calculated by the bootstrap estimator.}
+ \item{...}{Additional arguments passed to the bootstrap estimator
+ \code{\link[PSCBS:bootstrapTCNandDHByRegion.PairedPSCBS]{*bootstrapTCNandDHByRegion}()}.}
+}
+
+\value{
+ Returns a \code{\link{PairedPSCBS}} object with allelic-balance calls.
+}
+
+\author{Henrik Bengtsson}
+
+\section{Algorithm}{
+ \itemize{
+ \item Foo
+ \item Bar
+ }
+}
+
+\seealso{
+ Instead of calling this method explicitly, it is recommended
+ to use the \code{\link[PSCBS:callAllelicBalance.PairedPSCBS]{*callAllelicBalance}()} method.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/callAmplifications.CBS.Rd b/man/callAmplifications.CBS.Rd
new file mode 100644
index 0000000..0b2879f
--- /dev/null
+++ b/man/callAmplifications.CBS.Rd
@@ -0,0 +1,62 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% CBS.CALL.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{callAmplifications.CBS}
+\alias{callAmplifications.CBS}
+\alias{CBS.callAmplifications}
+\alias{callAmplifications,CBS-method}
+
+\title{Calls (focal) amplifications}
+
+\description{
+ Calls (focal) amplifications.
+}
+
+\usage{
+\method{callAmplifications}{CBS}(fit, adjust=1, maxLength=2e+07, method=c("ucsf-exp"), ...,
+ verbose=FALSE)
+}
+
+\arguments{
+ \item{adjust}{A positive scale factor adjusting the sensitivity of the
+ caller, where a value less (greater) than 1.0 makes the caller
+ less (more) sensitive.}
+ \item{maxLength}{A \code{\link[base]{double}} scalar specifying the maximum length of a segment
+ in order for it to be considered a focal amplification.}
+ \item{method}{A \code{\link[base]{character}} string specifying the calling algorithm to use.}
+ \item{...}{Additional/optional arguments used to override the default
+ parameters used by the caller.}
+ \item{verbose}{\code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns a \code{\link[PSCBS]{CBS}} object where \code{\link[base]{logical}} column
+ 'amplificationCall' has been appended to the segmentation table.
+}
+
+\section{The UCSF caller}{
+ If \code{method == "ucsf-exp"}, then segments are called using [1], i.e.
+ a segment is called an amplification if ...
+}
+
+\author{Henrik Bengtsson}
+
+\references{
+ [1] Fridlyand et al. \emph{Breast tumor copy number aberration
+ phenotypes and genomic instability}, BMC Cancer, 2006. \cr
+}
+
+\seealso{
+ \code{\link[PSCBS:callGainsAndLosses.CBS]{*callGainsAndLosses}()}.
+ \code{\link[PSCBS:callOutliers.CBS]{*callOutliers}()}.
+ For more information see \code{\link{CBS}}.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/callCopyNeutral.PairedPSCBS.Rd b/man/callCopyNeutral.PairedPSCBS.Rd
new file mode 100644
index 0000000..6cf49cc
--- /dev/null
+++ b/man/callCopyNeutral.PairedPSCBS.Rd
@@ -0,0 +1,52 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.callCopyNeutral.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{callCopyNeutral.PairedPSCBS}
+\alias{callCopyNeutral.PairedPSCBS}
+\alias{PairedPSCBS.callCopyNeutral}
+\alias{callCopyNeutral,PairedPSCBS-method}
+\alias{PairedPSCBS.callNTCN}
+\alias{callNTCN.PairedPSCBS}
+\alias{callNTCN,PairedPSCBS-method}
+
+
+\title{Calls segments that have a neutral total copy number}
+
+\description{
+ Calls segments that have a neutral total copy number (NTCN),
+ i.e. that have a TCN that corresponds to the ploidy of the genome.
+}
+
+\usage{
+\method{callCopyNeutral}{PairedPSCBS}(fit, flavor=c("TCN|AB"), ..., minSize=1, force=FALSE)
+}
+
+\arguments{
+ \item{flavor}{A \code{\link[base]{character}} string specifying which type of
+ call to use.}
+ \item{...}{Additional arguments passed to the caller.}
+ \item{minSize}{An optional \code{\link[base]{integer}} specifying the minimum number
+ of data points in order to call a segments. If fewer data points,
+ then the call is set to \code{\link[base]{NA}} regardless.}
+ \item{force}{If \code{\link[base:logical]{FALSE}}, and copy-neutral calls already exits,
+ then nothing is done, otherwise the calls are done.}
+}
+
+\value{
+ Returns a \code{\link{PairedPSCBS}} object with copy-neutral calls.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Internally, one of the following methods are used:
+ \code{\link[PSCBS:callCopyNeutralByTCNofAB.PairedPSCBS]{*callCopyNeutralByTCNofAB}()}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/callCopyNeutralByTCNofAB.PairedPSCBS.Rd b/man/callCopyNeutralByTCNofAB.PairedPSCBS.Rd
new file mode 100644
index 0000000..c6cb139
--- /dev/null
+++ b/man/callCopyNeutralByTCNofAB.PairedPSCBS.Rd
@@ -0,0 +1,58 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.callCopyNeutral.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{callCopyNeutralByTCNofAB.PairedPSCBS}
+\alias{callCopyNeutralByTCNofAB.PairedPSCBS}
+\alias{PairedPSCBS.callCopyNeutralByTCNofAB}
+\alias{callCopyNeutralByTCNofAB,PairedPSCBS-method}
+
+\title{Calls regions that are copy neutral}
+
+\description{
+ Calls regions that are copy neutral from the total copy numbers (TCNs) of segments
+ in allelic balance (AB).
+}
+
+\usage{
+\method{callCopyNeutralByTCNofAB}{PairedPSCBS}(fit, delta=estimateDeltaCN(fit), alpha=0.05, ..., force=FALSE,
+ verbose=FALSE)
+}
+
+\arguments{
+ \item{fit}{A PairedPSCBS fit object as returned by
+ \code{\link[PSCBS]{segmentByPairedPSCBS}}.}
+ \item{delta}{A non-negative \code{\link[base]{double}} specifying the width of the
+ "acceptance" region.
+ Defaults to half of the distance between two integer TCN states,
+ i.e. 1/2. This argument should be shrunken as a function of
+ the amount of the normal contamination and other background signals.}
+ \item{alpha}{A \code{\link[base]{double}} in [0,0.5] specifying the significance level
+ of the confidence intervals used.}
+ \item{...}{Additional arguments passed to
+ \code{\link[PSCBS:calcStatsForCopyNeutralABs.PairedPSCBS]{*calcStatsForCopyNeutralABs}()}.}
+ \item{force}{If \code{\link[base:logical]{TRUE}}, an already called object is skipped, otherwise not.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns a \code{\link{PairedPSCBS}} fit object where a column
+ with the copy-neutral call.
+}
+
+\details{
+ ...
+}
+
+%% examples "../incl/callCopyNeutralByTCNofAB.PairedPSCBS.Rex"
+
+\author{Henrik Bengtsson}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/callGNL.PairedPSCBS.Rd b/man/callGNL.PairedPSCBS.Rd
new file mode 100644
index 0000000..ae347a0
--- /dev/null
+++ b/man/callGNL.PairedPSCBS.Rd
@@ -0,0 +1,62 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.callGNL.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{callGNL.PairedPSCBS}
+\alias{callGNL.PairedPSCBS}
+\alias{PairedPSCBS.callGNL}
+\alias{callGNL,PairedPSCBS-method}
+\alias{PairedPSCBS.callGainNeutralLoss}
+\alias{callGainNeutralLoss.PairedPSCBS}
+\alias{callGainNeutralLoss,PairedPSCBS-method}
+
+\alias{callGNLByTCNofAB}
+\alias{PairedPSCBS.callGNLByTCNofAB}
+\alias{callGNLByTCNofAB.PairedPSCBS}
+\alias{callGNLByTCNofAB,PairedPSCBS-method}
+
+\alias{callGNLByTCNofABv1}
+\alias{PairedPSCBS.callGNLByTCNofABv1}
+\alias{callGNLByTCNofABv1.PairedPSCBS}
+\alias{callGNLByTCNofABv1,PairedPSCBS-method}
+
+
+\title{Calls segments that are gained, copy neutral, or lost}
+
+\description{
+ Calls segments that are gained, copy neutral, or lost, where copy neutral means having a total copy number
+ that corresponds to the ploidy of the genome.
+}
+
+\usage{
+\method{callGNL}{PairedPSCBS}(fit, flavor=c("TCN|AB"), ..., minSize=1, force=FALSE)
+}
+
+\arguments{
+ \item{flavor}{A \code{\link[base]{character}} string specifying which type of
+ call to use.}
+ \item{...}{Additional arguments passed to the caller.}
+ \item{minSize}{An optional \code{\link[base]{integer}} specifying the minimum number
+ of data points in order to call a segments. If fewer data points,
+ then the call is set to \code{\link[base]{NA}} regardless.}
+ \item{force}{If \code{\link[base:logical]{FALSE}}, and copy-neutral calls already exits,
+ then nothing is done, otherwise the calls are done.}
+}
+
+\value{
+ Returns a \code{\link{PairedPSCBS}} object with added calls.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Internally, one of the following methods are used:
+ \code{callGNLByTCNofAB()}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/callGainsAndLosses.CBS.Rd b/man/callGainsAndLosses.CBS.Rd
new file mode 100644
index 0000000..bfb4612
--- /dev/null
+++ b/man/callGainsAndLosses.CBS.Rd
@@ -0,0 +1,108 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% CBS.CALL.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{callGainsAndLosses.CBS}
+\alias{callGainsAndLosses.CBS}
+\alias{CBS.callGainsAndLosses}
+\alias{callGainsAndLosses,CBS-method}
+
+\title{Calls gains and losses}
+
+\description{
+ Calls gains and losses.
+}
+
+\usage{
+\method{callGainsAndLosses}{CBS}(fit, adjust=1, method=c("ucsf-mad", "ucsf-dmad"), ..., verbose=FALSE)
+}
+
+\arguments{
+ \item{adjust}{A positive scale factor adjusting the sensitivity of the
+ caller, where a value less (greater) than 1.0 makes the caller
+ less (more) sensitive.}
+ \item{method}{A \code{\link[base]{character}} string specifying the calling algorithm to use.}
+ \item{...}{Additional/optional arguments used to override the default
+ parameters used by the caller.}
+}
+
+\value{
+ Returns a \code{\link[PSCBS]{CBS}} object where \code{\link[base]{logical}} columns
+ 'lossCall' and 'gainCall' have been appended to the segmentation table.
+}
+
+\section{The UCSF caller}{
+ If \code{method == "ucsf-mad"}, then segments are called using [1], i.e.
+ a segment is called gained or lost if its segment level is
+ at least two standard deviations away from the median segment level
+ on Chr1-22, where standard deviation is estimated using MAD.
+ Then same is done for \code{method == "ucsf-dmad"} with the difference
+ that the standard deviation is estimated using a robust first order
+ variance estimator.
+}
+
+\examples{
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Simulating copy-number data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+set.seed(0xBEEF)
+
+# Number of loci
+J <- 1000
+
+mu <- double(J)
+mu[200:300] <- mu[200:300] + 1
+mu[350:400] <- NA # centromere
+mu[650:800] <- mu[650:800] - 1
+eps <- rnorm(J, sd=1/2)
+y <- mu + eps
+x <- sort(runif(length(y), max=length(y))) * 1e5
+w <- runif(J)
+w[650:800] <- 0.001
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- segmentByCBS(y, x=x)
+print(fit)
+plotTracks(fit)
+
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# CALLS
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Call gains and losses by segments
+fitC <- callGainsAndLosses(fit)
+
+# Call amplifications by segments
+fitC <- callAmplifications(fitC)
+
+# Call outliers by loci
+fitC <- callOutliers(fitC)
+
+}
+
+\author{Henrik Bengtsson}
+
+\references{
+ [1] Fridlyand et al. \emph{Breast tumor copy number aberration
+ phenotypes and genomic instability}, BMC Cancer, 2006. \cr
+}
+
+\seealso{
+ \code{\link[PSCBS:callAmplifications.CBS]{*callAmplifications}()}.
+ \code{\link[PSCBS:callOutliers.CBS]{*callOutliers}()}.
+ For more information see \code{\link{CBS}}.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/callLOH.PairedPSCBS.Rd b/man/callLOH.PairedPSCBS.Rd
new file mode 100644
index 0000000..b5fcd54
--- /dev/null
+++ b/man/callLOH.PairedPSCBS.Rd
@@ -0,0 +1,66 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.callLOH.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{callLOH.PairedPSCBS}
+\alias{callLOH.PairedPSCBS}
+\alias{PairedPSCBS.callLOH}
+\alias{callLOH,PairedPSCBS-method}
+
+\title{Calls segments that are in LOH}
+
+\description{
+ Calls segments that are in LOH, i.e. that have "zero" minor copy number.
+}
+
+\usage{
+\method{callLOH}{PairedPSCBS}(fit, flavor=c("SmallC1", "LargeDH"), ..., minSize=1, xorCalls=TRUE, force=FALSE)
+}
+
+\arguments{
+ \item{flavor}{A \code{\link[base]{character}} string specifying which type of
+ call to use.}
+ \item{...}{Additional arguments passed to the caller.}
+ \item{minSize}{An optional \code{\link[base]{integer}} specifying the minimum number
+ of data points in order to call a segments. If fewer data points,
+ then the call is set to \code{\link[base]{NA}} regardless.}
+ \item{xorCalls}{If \code{\link[base:logical]{TRUE}}, a region already called AB, will
+ for consistency never be called LOH, resulting in either an LOH
+ call set to \code{\link[base:logical]{FALSE}} or \code{\link[base]{NA}} (as explained below).}
+ \item{force}{If \code{\link[base:logical]{FALSE}}, and allelic-balance calls already exits,
+ then nothing is done, otherwise the calls are done.}
+}
+
+\value{
+ Returns a \code{\link{PairedPSCBS}} object with LOH calls.
+}
+
+\section{AB and LOH consistency}{
+ Biologically, a segment can not be both in allelic balance (AB) and
+ in loss-of-heterozygosity (LOH) at the same time.
+ To avoid reporting such inconsistencies, the LOH caller will,
+ if argument \code{xorCalls=TRUE}, never report a segment to be in
+ LOH if it is already called to be in AB.
+ However, regardless of of the AB call, a segment is still always
+ tested for LOH, to check weather the LOH caller is consistent with the
+ AB caller or not. Thus, in order to distinguish the case where
+ the AB caller and LOH caller agree from when they disagree,
+ we report either (AB,LOH)=(TRUE,FALSE) or (TRUE,NA). The former is
+ reported when they are consistent, and the latter when they are not,
+ or when the LOH caller could not call it.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Internally, one of the following methods are used:
+ \code{\link[PSCBS:callLowC1ByC1.PairedPSCBS]{*callLowC1ByC1}()},
+ \code{\link[PSCBS:callExtremeAllelicImbalanceByDH.PairedPSCBS]{*callExtremeAllelicImbalanceByDH}()}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/callOutliers.CBS.Rd b/man/callOutliers.CBS.Rd
new file mode 100644
index 0000000..7b59566
--- /dev/null
+++ b/man/callOutliers.CBS.Rd
@@ -0,0 +1,63 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% CBS.CALL.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{callOutliers.CBS}
+\alias{callOutliers.CBS}
+\alias{CBS.callOutliers}
+\alias{callOutliers,CBS-method}
+
+\title{Calls outliers}
+
+\description{
+ Calls outliers.
+}
+
+\usage{
+\method{callOutliers}{CBS}(fit, adjust=1, method=c("ucsf-mad"), ...)
+}
+
+\arguments{
+ \item{adjust}{A positive scale factor adjusting the sensitivity of the
+ caller, where a value less (greater) than 1.0 makes the caller
+ less (more) sensitive.}
+ \item{method}{A \code{\link[base]{character}} string specifying the calling algorithm to use.}
+ \item{...}{Additional/optional arguments used to override the default
+ parameters used by the caller.}
+}
+
+\value{
+ Returns a \code{\link[PSCBS]{CBS}} object where \code{\link[base]{logical}} columns
+ 'negOutlierCall' and 'posOutlierCall' have been appended
+ to the segmentation table.
+}
+
+\section{The UCSF caller}{
+ If \code{method == "ucsf-mad"}, then loci are called using [1];
+ "Finally, to identify single technical or biological outliers such
+ as high level amplifications, the presence of the outliers within
+ a segment was allowed by assigning the original observed log2ratio
+ to the clones for which the observed values were more than four
+ tumor-specific MAD away from the smoothed values." [1; Suppl. Mat.]
+}
+
+\author{Henrik Bengtsson}
+
+\references{
+ [1] Fridlyand et al. \emph{Breast tumor copy number aberration
+ phenotypes and genomic instability}, BMC Cancer, 2006. \cr
+}
+
+\seealso{
+ \code{\link[PSCBS:callGainsAndLosses.CBS]{*callGainsAndLosses}()}.
+ \code{\link[PSCBS:callAmplifications.CBS]{*callAmplifications}()}.
+ For more information see \code{\link{CBS}}.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/callROH.PairedPSCBS.Rd b/man/callROH.PairedPSCBS.Rd
new file mode 100644
index 0000000..7d65ab6
--- /dev/null
+++ b/man/callROH.PairedPSCBS.Rd
@@ -0,0 +1,48 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.callROH.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{callROH.PairedPSCBS}
+\alias{callROH.PairedPSCBS}
+\alias{PairedPSCBS.callROH}
+\alias{callROH,PairedPSCBS-method}
+\alias{callROH.NonPairedPSCBS}
+
+\title{Calls segments that are in ROH}
+
+\description{
+ Calls segments that are in ROH, i.e. that have no (true) heterozygous genotypes.
+ Run of homozygosity (ROH) is a property of the normal (germline) sample.
+}
+
+\usage{
+\method{callROH}{PairedPSCBS}(fit, ..., updateMeans=TRUE, force=FALSE, verbose=FALSE)
+}
+
+\arguments{
+ \item{...}{Additional arguments passed to \code{\link{testROH}}().}
+ \item{updateMeans}{If \code{\link[base:logical]{TRUE}}, DH and (C1,C2) mean levels are set
+ to \code{\link[base]{NA}} for segments called ROH, otherwise not.}
+ \item{force}{If \code{\link[base:logical]{FALSE}}, and ROH calls already exits,
+ then nothing is done, otherwise the calls are done.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns a \code{\link{PairedPSCBS}} object with ROH calls.
+}
+
+\author{Pierre Neuvial, Henrik Bengtsson}
+
+\seealso{
+ Internally, \code{\link{testROH}}() is used.
+ To call allelic balance (AB) see \code{\link[PSCBS:callAB.PairedPSCBS]{*callAB}()}.
+ To call loss of heterozygosity (LOH) see \code{\link[PSCBS:callLOH.PairedPSCBS]{*callLOH}()}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/callSegmentationOutliers.Rd b/man/callSegmentationOutliers.Rd
new file mode 100644
index 0000000..3116f26
--- /dev/null
+++ b/man/callSegmentationOutliers.Rd
@@ -0,0 +1,69 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% callSegmentationOutliers.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{callSegmentationOutliers}
+\alias{callSegmentationOutliers}
+
+\alias{callSegmentationOutliers.default}
+\alias{callSegmentationOutliers.data.frame}
+\alias{dropSegmentationOutliers}
+\alias{dropSegmentationOutliers.default}
+\alias{dropSegmentationOutliers.data.frame}
+
+\title{Calls/drops single-locus outliers along the genome}
+
+\description{
+ Calls/drops single-locus outliers along the genome that have a signal that differ significantly from the
+ neighboring loci.
+}
+
+\usage{
+ \method{callSegmentationOutliers}{default}(y, chromosome=0, x=NULL, method="DNAcopy::smooth.CNA", ...,
+ verbose=FALSE)
+ \method{callSegmentationOutliers}{data.frame}(y, ...)
+ \method{dropSegmentationOutliers}{default}(y, ...)
+ \method{dropSegmentationOutliers}{data.frame}(y, ...)
+}
+
+\arguments{
+ \item{y}{A \code{\link[base]{numeric}} \code{\link[base]{vector}} of J genomic signals to be segmented.}
+ \item{chromosome}{(Optional) An \code{\link[base]{integer}} scalar
+ (or a \code{\link[base]{vector}} of length J contain a unique value).
+ Only used for annotation purposes.}
+ \item{x}{Optional \code{\link[base]{numeric}} \code{\link[base]{vector}} of J genomic locations.
+ If \code{\link[base]{NULL}}, index locations \code{1:J} are used.}
+ \item{method}{A \code{\link[base]{character}} string specifying the method
+ used for calling outliers.}
+ \item{...}{Additional arguments passed to internal outlier
+ detection method.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ \code{callSegmentationOutliers()} returns a \code{\link[base]{logical}} \code{\link[base]{vector}} of length J.
+ \code{dropSegmentationOutliers()} returns an object of the same type
+ as argument \code{y}, where the signals for which outliers were called
+ have been set to \code{\link[base]{NA}}.
+}
+
+\section{Missing and non-finite values}{
+ Signals as well as genomic positions may contain missing
+ values, i.e. \code{\link[base]{NA}}s or \code{\link[base:is.finite]{NaN}}s. By definition, these cannot
+ be outliers.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Internally \code{\link[DNAcopy]{smooth.CNA}} is utilized to identify
+ the outliers.
+}
+
+
+\keyword{methods}
+\keyword{IO}
diff --git a/man/dropChangePoints.AbstractCBS.Rd b/man/dropChangePoints.AbstractCBS.Rd
new file mode 100644
index 0000000..55f0d34
--- /dev/null
+++ b/man/dropChangePoints.AbstractCBS.Rd
@@ -0,0 +1,46 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.RESTRUCT.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{dropChangePoints.AbstractCBS}
+\alias{dropChangePoints.AbstractCBS}
+\alias{AbstractCBS.dropChangePoints}
+\alias{dropChangePoints,AbstractCBS-method}
+
+\title{Drops zero or more change points}
+
+\description{
+ Drops zero or more change points, which is done by dropping one change point at the
+ time using \code{\link[PSCBS:dropChangePoint.AbstractCBS]{*dropChangePoint}()}
+ and recalculating the segment statistics at the end.
+
+ \emph{NOTE: This method only works if there is only one chromosome.}
+}
+
+\usage{
+\method{dropChangePoints}{AbstractCBS}(fit, idxs, update=TRUE, ...)
+}
+
+\arguments{
+ \item{idxs}{An \code{\link[base]{integer}} \code{\link[base]{vector}} specifying the change points to be dropped.}
+ \item{update}{If \code{\link[base:logical]{TRUE}}, segment statistics are updated.}
+ \item{...}{Other arguments passed to \code{\link[PSCBS:dropChangePoint.AbstractCBS]{*dropChangePoint}()}
+ and \code{\link[PSCBS:updateMeans.AbstractCBS]{*updateMeans}()}.}
+}
+
+\value{
+ Returns an \code{\link{AbstractCBS}} of the same class with
+ \code{length(idxs)} segments.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{AbstractCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/dropRegions.AbstractCBS.Rd b/man/dropRegions.AbstractCBS.Rd
new file mode 100644
index 0000000..be2603a
--- /dev/null
+++ b/man/dropRegions.AbstractCBS.Rd
@@ -0,0 +1,55 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.RESTRUCT.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{dropRegions.AbstractCBS}
+\alias{dropRegions.AbstractCBS}
+\alias{AbstractCBS.dropRegions}
+\alias{dropRegions,AbstractCBS-method}
+\alias{AbstractCBS.dropRegion}
+\alias{dropRegion.AbstractCBS}
+\alias{dropRegion,AbstractCBS-method}
+
+
+\title{Drops chromosomal regions (a connected set of segments)}
+
+\description{
+ Drops chromosomal regions (a connected set of segments) each of a certain size (number of segments).
+ \emph{None of the statistics are recalculated}.
+}
+
+\usage{
+\method{dropRegions}{AbstractCBS}(this, regions, H=1, ..., asMissing=FALSE, verbose=FALSE)
+}
+
+\arguments{
+ \item{regions}{An \code{\link[base]{integer}} \code{\link[base]{vector}} of length R specifying the indices
+ of the left most segment in each of the R regions to be dropped.}
+ \item{H}{A non-negative \code{\link[base]{integer}} specifying the size of each region,
+ i.e. the number of segments per region.}
+ \item{...}{Additional arguments passed to \code{\link[PSCBS:extractRegions.AbstractCBS]{*extractRegions}()}.}
+ \item{asMissing}{If \code{\link[base:logical]{TRUE}}, dropped segments are replaced by missing values,
+ otherwise they are truly dropped.}
+ \item{verbose}{A \code{\link[base]{logical}} or a \code{\link[R.utils]{Verbose}} object.}
+}
+
+\value{
+ Returns an \code{\link{AbstractCBS}} object of the same class with (at most)
+ R*H segments dropped.
+ If some regions overlap (share segments), then fewer than R*H segments
+ are dropped.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Internally \code{\link[PSCBS:extractRegions.AbstractCBS]{*extractRegions}()} is used.
+ See also \code{\link[PSCBS:dropChangePoint.AbstractCBS]{*dropChangePoint}()} and \code{\link[PSCBS:mergeTwoSegments.AbstractCBS]{*mergeTwoSegments}()}.
+ For more information see \code{\link{AbstractCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/estimateDeltaAB.PairedPSCBS.Rd b/man/estimateDeltaAB.PairedPSCBS.Rd
new file mode 100644
index 0000000..6cc05d8
--- /dev/null
+++ b/man/estimateDeltaAB.PairedPSCBS.Rd
@@ -0,0 +1,50 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.estimateDeltaAB.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{estimateDeltaAB.PairedPSCBS}
+\alias{estimateDeltaAB.PairedPSCBS}
+\alias{PairedPSCBS.estimateDeltaAB}
+\alias{estimateDeltaAB,PairedPSCBS-method}
+
+\title{Estimate a threshold for calling allelic balance from DH}
+
+\description{
+ Estimate a threshold for calling allelic balance from DH to be used by the \code{\link[PSCBS:callAB.PairedPSCBS]{*callAB}()} method.
+}
+
+\usage{
+\method{estimateDeltaAB}{PairedPSCBS}(this, scale=NULL, flavor=c("qq(DH)", "q(DH)", "mad(hBAF)", "median(DH)"),
+ ..., max=Inf, verbose=FALSE)
+}
+
+\arguments{
+ \item{scale}{An optional \code{\link[base]{numeric}} scale factor.}
+ \item{flavor}{A \code{\link[base]{character}} string specifying which type of
+ estimator to use.}
+ \item{...}{Additional arguments passed to the estimator.}
+ \item{max}{(Optional) The maxium estimate allowed. If greater than
+ this value, the estimate will be truncated.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns the threshold estimate as a \code{\link[base]{numeric}} scalar.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Internally, one of the following methods are used:
+ \code{\link[PSCBS:estimateDeltaABBySmallDH.PairedPSCBS]{*estimateDeltaABBySmallDH}()},
+ \code{\link[PSCBS:estimateStdDevForHeterozygousBAF.PairedPSCBS]{*estimateStdDevForHeterozygousBAF}()},
+ \code{\link[PSCBS:estimateMeanForDH.PairedPSCBS]{*estimateMeanForDH}()}, and
+ \code{\link[PSCBS:estimateHighDHQuantileAtAB.PairedPSCBS]{*estimateHighDHQuantileAtAB}()}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/estimateDeltaABBySmallDH.PairedPSCBS.Rd b/man/estimateDeltaABBySmallDH.PairedPSCBS.Rd
new file mode 100644
index 0000000..0e8a0d0
--- /dev/null
+++ b/man/estimateDeltaABBySmallDH.PairedPSCBS.Rd
@@ -0,0 +1,65 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.estimateDeltaAB.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{estimateDeltaABBySmallDH.PairedPSCBS}
+\alias{estimateDeltaABBySmallDH.PairedPSCBS}
+\alias{PairedPSCBS.estimateDeltaABBySmallDH}
+\alias{estimateDeltaABBySmallDH,PairedPSCBS-method}
+
+\title{Estimate a threshold for calling allelic balance from DH}
+
+\description{
+ Estimate a threshold for calling allelic balance from DH.
+}
+
+\usage{
+\method{estimateDeltaABBySmallDH}{PairedPSCBS}(fit, q1=0.05, q2=0.9, ..., verbose=FALSE)
+}
+
+\arguments{
+ \item{q1}{A \code{\link[base]{numeric}} value specifying the weighted quantile of the
+ segment-level DHs used to identify segments with small DH means.}
+ \item{q2}{A \code{\link[base]{numeric}} value specifying the quantile of the locus-level
+ DH signals for those segments with small DH mean levels.}
+ \item{...}{Not used.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns the threshold estimate as a \code{\link[base]{numeric}} scalar.
+}
+
+\section{Algorithm}{
+ \itemize{
+ \item Grabs the segment-level DH estimates.
+ \item Calculate segment weights proportional to the number
+ of heterozygous SNPs.
+ \item Calculate \eqn{\Delta} as the 5\% quantile of the weighted DH means.
+ \item Choose the segments with means less than \eqn{\Delta}.
+ \item Calculate threshold \eqn{\Delta_{AB}} as the 90\% "symmetric" quantile
+ of the observed locus-level DHs from the selected segments
+ in Step 4.
+ The q:th "symmetric" quantile is estimated by estimating
+ the ((1-q), 50\%) quantiles, calculating their distance as
+ "50\%-(1-q)" and add to the median (50\%), i.e.
+ "median + (median-(1-q))" = "2*median-1 + q", which should
+ equal q if the distribution is symmetric.
+ }
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Instead of calling this method explicitly, it is recommended
+ to use the \code{\link[PSCBS:estimateDeltaAB.PairedPSCBS]{*estimateDeltaAB}()} method.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/estimateDeltaLOH.PairedPSCBS.Rd b/man/estimateDeltaLOH.PairedPSCBS.Rd
new file mode 100644
index 0000000..725ccae
--- /dev/null
+++ b/man/estimateDeltaLOH.PairedPSCBS.Rd
@@ -0,0 +1,48 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.estimateDeltaLOH.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{estimateDeltaLOH.PairedPSCBS}
+\alias{estimateDeltaLOH.PairedPSCBS}
+\alias{PairedPSCBS.estimateDeltaLOH}
+\alias{estimateDeltaLOH,PairedPSCBS-method}
+
+\title{Estimate a threshold for calling LOH from DH}
+
+\description{
+ Estimate a threshold for calling LOH from DH to be used by the \code{\link[PSCBS:callLOH.PairedPSCBS]{*callLOH}()} method.
+}
+
+\usage{
+\method{estimateDeltaLOH}{PairedPSCBS}(this, flavor=c("minC1|nonAB"), ..., max=Inf, verbose=FALSE)
+}
+
+\arguments{
+ \item{scale}{An optional \code{\link[base]{numeric}} scale factor.}
+ \item{flavor}{A \code{\link[base]{character}} string specifying which type of
+ estimator to use.}
+ \item{...}{Additional arguments passed to the estimator.}
+ \item{max}{(Optional) The maxium estimate allowed. If greater than
+ this value, the estimate will be truncated.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns the threshold estimate as a \code{\link[base]{numeric}} scalar or -\code{\link[base:is.finite]{Inf}}.
+ In case it is not possible to estimate the LOH threshold, then
+ -\code{\link[base:is.finite]{Inf}} is returned.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Internally, one of the following methods are used:
+ \code{\link[PSCBS:estimateDeltaLOHByMinC1ForNonAB.PairedPSCBS]{*estimateDeltaLOHByMinC1ForNonAB}()}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/estimateDeltaLOHByMinC1ForNonAB.PairedPSCBS.Rd b/man/estimateDeltaLOHByMinC1ForNonAB.PairedPSCBS.Rd
new file mode 100644
index 0000000..d288636
--- /dev/null
+++ b/man/estimateDeltaLOHByMinC1ForNonAB.PairedPSCBS.Rd
@@ -0,0 +1,66 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.estimateDeltaLOH.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{estimateDeltaLOHByMinC1ForNonAB.PairedPSCBS}
+\alias{estimateDeltaLOHByMinC1ForNonAB.PairedPSCBS}
+\alias{PairedPSCBS.estimateDeltaLOHByMinC1ForNonAB}
+\alias{estimateDeltaLOHByMinC1ForNonAB,PairedPSCBS-method}
+
+\title{Estimate a threshold for calling LOH from DH}
+
+\description{
+ Estimate a threshold for calling LOH from DH based on the location of guessed C1=0 and C1=1 peaks.
+}
+
+\usage{
+\method{estimateDeltaLOHByMinC1ForNonAB}{PairedPSCBS}(this, midpoint=1/2, maxC=3 * (ploidy(this)/2), ...,
+ verbose=FALSE)
+}
+
+\arguments{
+ \item{midpoint}{A \code{\link[base]{numeric}} scalar in [0,1] specifying the relative
+ position of the midpoint between the estimated locations of
+ C1=0 and C1=1 mean parameters.}
+ \item{maxC}{Maximum total copy number of a segment in order to
+ be included in the initial set of segments.}
+ \item{...}{Not used.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns the estimated LOH treshold as a \code{\link[base]{numeric}} scalar or -\code{\link[base:is.finite]{Inf}}.
+ In case it is not possible to estimate the LOH threshold, then
+ -\code{\link[base:is.finite]{Inf}} is returned.
+}
+
+\details{
+ This method requires that calls for allelic balances already have
+ been me made, cf. \code{\link[PSCBS:callAllelicBalance.PairedPSCBS]{*callAllelicBalance}()}.
+}
+
+\section{Algorithm}{
+ \itemize{
+ \item Grabs the segment-level C1 estimates.
+ \item Calculate segment weights proportional to the number of heterozygous SNPs.
+ \item Estimate the C1=1 location as the weighted median C1 for segments that have been called to be in allelic balance.
+ \item Estimate the C1=0 location as the smallest C1 among segments that are not in allelic balance.
+ \item Let the LOH threshold be the midpoint of the estimates C1=0 and C1=1 locations.
+ }
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Instead of calling this method explicitly, it is recommended
+ to use the \code{\link[PSCBS:estimateDeltaLOH.PairedPSCBS]{*estimateDeltaLOH}()} method.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/estimateKappa.PairedPSCBS.Rd b/man/estimateKappa.PairedPSCBS.Rd
new file mode 100644
index 0000000..3ea1290
--- /dev/null
+++ b/man/estimateKappa.PairedPSCBS.Rd
@@ -0,0 +1,45 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.estimateKappa.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{estimateKappa.PairedPSCBS}
+\alias{estimateKappa.PairedPSCBS}
+\alias{PairedPSCBS.estimateKappa}
+\alias{estimateKappa,PairedPSCBS-method}
+
+\title{Estimate global background in segmented copy numbers}
+
+\description{
+ Estimate global background in segmented copy numbers.
+ The global background, here called \eqn{\kappa},
+ may have multiple origins where normal contamination is one,
+ but not necessarily the only one.
+}
+
+\usage{
+\method{estimateKappa}{PairedPSCBS}(this, flavor=c("density(C1)"), ...)
+}
+
+\arguments{
+ \item{flavor}{A \code{\link[base]{character}} string specifying which type of
+ estimator to use.}
+ \item{...}{Additional arguments passed to the estimator.}
+}
+
+\value{
+ Returns the background estimate as a \code{\link[base]{numeric}} scalar.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Internally, one of the following methods are used:
+ \code{\link[PSCBS:estimateKappaByC1Density.PairedPSCBS]{*estimateKappaByC1Density}()}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/estimateKappaByC1Density.PairedPSCBS.Rd b/man/estimateKappaByC1Density.PairedPSCBS.Rd
new file mode 100644
index 0000000..f0db112
--- /dev/null
+++ b/man/estimateKappaByC1Density.PairedPSCBS.Rd
@@ -0,0 +1,95 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.estimateKappa.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{estimateKappaByC1Density.PairedPSCBS}
+\alias{estimateKappaByC1Density.PairedPSCBS}
+\alias{PairedPSCBS.estimateKappaByC1Density}
+\alias{estimateKappaByC1Density,PairedPSCBS-method}
+
+\title{Estimate global background in segmented copy numbers}
+
+\description{
+ Estimate global background in segmented copy numbers based on the location of peaks in a weighted
+ density estimator of the minor copy number mean levels.
+
+ The global background, here called \eqn{\kappa},
+ may have multiple origins where normal contamination is one,
+ but not necessarily the only one.
+
+ \emph{Assumptions:} This estimator assumes that there are segments
+ with C1=0 and C1=1, i.e. some deletions and, typically, some normal
+ segements.
+}
+
+\usage{
+\method{estimateKappaByC1Density}{PairedPSCBS}(this, typeOfWeights=c("dhNbrOfLoci", "sqrt(dhNbrOfLoci)"),
+ adjust=1, from=0, minDensity=0.2, ..., verbose=FALSE)
+}
+
+\arguments{
+ \item{typeOfWeights}{A \code{\link[base]{character}} string specifying how weights
+ are calculated.}
+ \item{adjust}{A \code{\link[base]{numeric}} scale factor specifying the size of
+ the bandwidth parameter used by the density estimator.}
+ \item{from}{A \code{\link[base]{numeric}} scalar specifying the lower bound for the
+ support of the estimated density.}
+ \item{minDensity}{A non-negative \code{\link[base]{numeric}} threshold specifying
+ the minimum density a peak should have in order to consider
+ it a peak.}
+ \item{...}{Not used.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns the background estimate as a \code{\link[base]{numeric}} scalar.
+}
+
+\section{Algorithm}{
+ \itemize{
+ \item Retrieve segment-level minor copy numbers and corresponding weights:
+ \enumerate{
+ \item Grabs the segment-level C1 estimates.
+ \item Calculate segment weights.
+ The default (\code{typeOfWeights="dhNbrOfLoci"}) is to use
+ weights proportional to the number of heterozygous SNPs.
+ An alternative (\code{typeOfWeights="sqrt(dhNbrOfLoci)"}) is
+ to use the square root of those counts.
+ }
+
+ \item Identify subset of regions with C1=0:
+ \enumerate{
+ \item Estimates the weighted empirical density function
+ (truncated at zero below). Tuning parameter 'adjust'.
+ \item Find the first two peaks
+ (with a density greater than tuning parameter 'minDensity').
+ \item Assumes that the two peaks corresponds to C1=0 and C1=1.
+ \item Defines threshold Delta0.5 as the center location between
+ these two peaks.
+ }
+
+ \item Estimate the global background signal:
+ \enumerate{
+ \item For all segments with C1 < Delta0.5, calculate the weighted
+ median of their C1:s.
+ \item Let kappa be the above weighted median.
+ This is the estimated background.
+ }
+ }
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Instead of calling this method explicitly, it is recommended
+ to use the \code{\link[PSCBS:estimateKappa.PairedPSCBS]{*estimateKappa}()} method.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/estimateStandardDeviation.CBS.Rd b/man/estimateStandardDeviation.CBS.Rd
new file mode 100644
index 0000000..7123868
--- /dev/null
+++ b/man/estimateStandardDeviation.CBS.Rd
@@ -0,0 +1,50 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% CBS.EXTS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{estimateStandardDeviation.CBS}
+\alias{estimateStandardDeviation.CBS}
+\alias{CBS.estimateStandardDeviation}
+\alias{estimateStandardDeviation,CBS-method}
+
+\title{Estimates the whole-genome standard deviation of the signals}
+
+\description{
+ Estimates the whole-genome standard deviation of the signals.
+}
+
+\usage{
+\method{estimateStandardDeviation}{CBS}(fit, chromosomes=NULL, method=c("diff", "res", "abs",
+ "DNAcopy"), estimator=c("mad", "sd"), na.rm=TRUE, weights=NULL, ...)
+}
+
+\arguments{
+ \item{chromosomes}{An optional \code{\link[base]{vector}} specifying the subset of
+ chromosomes used for the estimate. If \code{\link[base]{NULL}}, all chromosomes are used.}
+ \item{method}{A \code{\link[base]{character}} string specifying the method used.}
+ \item{estimator}{A \code{\link[base]{character}} string or a \code{\link[base]{function}} specifying the
+ internal estimator.}
+ \item{na.rm}{If \code{\link[base:logical]{TRUE}}, missing values are dropped, otherwise not.}
+ \item{weights}{An optional \code{\link[base]{double}} \code{\link[base]{vector}} of \code{nbrOfLoci()}
+ non-negative weights.}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns a non-negative \code{\link[base]{numeric}} scale.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{CBS}}.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/exampleData.Rd b/man/exampleData.Rd
new file mode 100644
index 0000000..e22a4dd
--- /dev/null
+++ b/man/exampleData.Rd
@@ -0,0 +1,39 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% exampleData.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{exampleData}
+\alias{exampleData.default}
+\alias{exampleData}
+
+\title{Gets an example data set}
+
+\description{
+ Gets an example data set.
+}
+
+\usage{
+\method{exampleData}{default}(name=c("paired.chr01"), ...)
+}
+
+\arguments{
+ \item{name}{A \code{\link[base]{character}} string specifying the name of the data set.}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns \code{\link[base]{data.frame}}.
+}
+
+\author{Henrik Bengtsson}
+
+
+
+
+\keyword{IO}
+\keyword{data}
+\keyword{internal}
diff --git a/man/extractMinorMajorCNs.PairedPSCBS.Rd b/man/extractMinorMajorCNs.PairedPSCBS.Rd
new file mode 100644
index 0000000..e202b2e
--- /dev/null
+++ b/man/extractMinorMajorCNs.PairedPSCBS.Rd
@@ -0,0 +1,44 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.EXTS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{extractMinorMajorCNs.PairedPSCBS}
+\alias{extractMinorMajorCNs.PairedPSCBS}
+\alias{PairedPSCBS.extractMinorMajorCNs}
+\alias{extractMinorMajorCNs,PairedPSCBS-method}
+\alias{PairedPSCBS.extractC1C2}
+\alias{extractC1C2.PairedPSCBS}
+\alias{extractC1C2,PairedPSCBS-method}
+
+
+\title{Extract minor and major copy-number mean levels per segment}
+
+\description{
+ Extract minor and major copy-number mean levels per segment.
+}
+
+\usage{
+\method{extractMinorMajorCNs}{PairedPSCBS}(fit, ...)
+}
+
+\arguments{
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns a \code{\link[base]{data.frame}}.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ \code{\link[PSCBS:extractTCNAndDHs.PairedPSCBS]{*extractTCNAndDHs}()}
+ For more information see \code{\link{PairedPSCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/extractSegmentMeansByLocus.CBS.Rd b/man/extractSegmentMeansByLocus.CBS.Rd
new file mode 100644
index 0000000..eb788d3
--- /dev/null
+++ b/man/extractSegmentMeansByLocus.CBS.Rd
@@ -0,0 +1,41 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% CBS.EXTS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{extractSegmentMeansByLocus.CBS}
+\alias{extractSegmentMeansByLocus.CBS}
+\alias{CBS.extractSegmentMeansByLocus}
+\alias{extractSegmentMeansByLocus,CBS-method}
+
+\title{Extracts segments means at each locus}
+
+\description{
+ Extracts segments means at each locus.
+}
+
+\usage{
+\method{extractSegmentMeansByLocus}{CBS}(fit, ...)
+}
+
+\arguments{
+ \item{...}{Arguments passed to \code{\link[PSCBS:getLocusData.CBS]{*getLocusData}()}.}
+}
+
+\value{
+ Returns a \code{\link[base]{numeric}} \code{\link[base]{vector}} of length \code{nbrOfLoci()}.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{CBS}}.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/extractTCNAndDHs.PairedPSCBS.Rd b/man/extractTCNAndDHs.PairedPSCBS.Rd
new file mode 100644
index 0000000..47276ff
--- /dev/null
+++ b/man/extractTCNAndDHs.PairedPSCBS.Rd
@@ -0,0 +1,40 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.EXTS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{extractTCNAndDHs.PairedPSCBS}
+\alias{extractTCNAndDHs.PairedPSCBS}
+\alias{PairedPSCBS.extractTCNAndDHs}
+\alias{extractTCNAndDHs,PairedPSCBS-method}
+
+\title{Extract TCN and DH mean levels per segment}
+
+\description{
+ Extract TCN and DH mean levels per segment.
+}
+
+\usage{
+\method{extractTCNAndDHs}{PairedPSCBS}(fit, ...)
+}
+
+\arguments{
+ \item{...}{Arguments passed to \code{getSegments()}.}
+}
+
+\value{
+ Returns a \code{\link[base]{data.frame}}.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ \code{\link[PSCBS:extractMinorMajorCNs.PairedPSCBS]{*extractMinorMajorCNs}()}.
+ For more information see \code{\link{PairedPSCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/findLargeGaps.Rd b/man/findLargeGaps.Rd
new file mode 100644
index 0000000..e6a25f3
--- /dev/null
+++ b/man/findLargeGaps.Rd
@@ -0,0 +1,51 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% findLargeGaps.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{findLargeGaps}
+\alias{findLargeGaps.default}
+\alias{findLargeGaps}
+\alias{findLargeGaps.data.frame}
+
+\title{Identifies gaps of a genome where there exist no observations}
+
+\description{
+ Identifies gaps of a genome where there exist no observations.
+}
+
+\usage{
+\method{findLargeGaps}{default}(chromosome=NULL, x, minLength, resolution=1L, ...)
+}
+
+\arguments{
+ \item{chromosome}{(Optional) An \code{\link[base]{integer}} \code{\link[base]{vector}} of length J of
+ chromosome indices.}
+ \item{x}{A \code{\link[base]{numeric}} \code{\link[base]{vector}} of J of genomic locations.}
+ \item{minLength}{A positive \code{\link[base]{numeric}} scalar specifying the minimum
+ length of a gap.}
+ \item{resolution}{A non-negative \code{\link[base]{numeric}} specifying the minimum
+ length unit, which by default equals one nucleotide/base pair.}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns \code{\link[base]{data.frame}} zero or more rows and with columns
+ \code{chromosome} (if given), \code{start}, \code{stop},
+ and \code{length}.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Use \code{\link{gapsToSegments}}() to turn the set of identified gaps into
+ the complementary set of segments such that they can be passed
+ to \code{\link{segmentByCBS}}(), \code{\link{segmentByPairedPSCBS}}() and
+ \code{\link{segmentByNonPairedPSCBS}}() via argument \code{knownSegments}.
+}
+
+
+\keyword{IO}
diff --git a/man/findNeutralCopyNumberState.Rd b/man/findNeutralCopyNumberState.Rd
new file mode 100644
index 0000000..9ba7fe0
--- /dev/null
+++ b/man/findNeutralCopyNumberState.Rd
@@ -0,0 +1,44 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% findNeutralCopyNumberState.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{findNeutralCopyNumberState}
+\alias{findNeutralCopyNumberState.default}
+\alias{findNeutralCopyNumberState}
+
+\title{Call segments to be copy neutral based on allelic imbalance calls and total copy number estimates}
+
+\description{
+ Call segments to be copy neutral based on allelic imbalance calls and total copy number estimates.
+}
+
+\usage{
+\method{findNeutralCopyNumberState}{default}(C, isAI, weights=NULL, ..., minDensity=1e-10,
+ flavor=c("firstPeak", "maxPeak"), verbose=FALSE)
+}
+
+\arguments{
+ \item{C}{A \code{\link[base]{numeric}} \code{\link[base]{vector}} of region-level total copy number estimates.}
+ \item{isAI}{A \code{\link[base]{logical}} \code{\link[base]{vector}} of "allelic imbalance" calls.}
+ \item{weights}{An optional \code{\link[base]{numeric}} \code{\link[base]{vector}} of non-negative weights.}
+ \item{...}{Further argumants to be passed to the density estimation
+ function.}
+ \item{minDensity}{A \code{\link[base]{numeric}} value, below which density peaks are
+ discarded.}
+ \item{flavor}{A \code{\link[base]{character}} string specifying how to identify the
+ mode of the AB segments.}
+ \item{verbose}{If \code{\link[base:logical]{TRUE}}, extra information is output.}
+}
+
+\value{
+ A \code{\link[base]{logical}} \code{\link[base]{vector}} of "neutral copy number state" calls.
+}
+
+\author{Pierre Neuvial, Henrik Bengtsson}
+
+
+\keyword{internal}
diff --git a/man/gapsToSegments.data.frame.Rd b/man/gapsToSegments.data.frame.Rd
new file mode 100644
index 0000000..c26dcda
--- /dev/null
+++ b/man/gapsToSegments.data.frame.Rd
@@ -0,0 +1,49 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% gapsToSegments.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{gapsToSegments.data.frame}
+\alias{gapsToSegments.data.frame}
+\alias{gapsToSegments}
+
+\title{Gets the genomic segments that are complementary to the gaps}
+
+\description{
+ Gets the genomic segments that are complementary to the gaps, with default chromosome boundaries being \code{-Inf}
+ and \code{+Inf}.
+}
+
+\usage{
+\method{gapsToSegments}{data.frame}(gaps, resolution=1L, minLength=0L, dropGaps=FALSE, ...)
+}
+
+\arguments{
+ \item{gaps}{A \code{\link[base]{data.frame}} with columns \code{chromosome}, \code{start},
+ and \code{stop}. Any overlapping gaps will throw an error.}
+ \item{resolution}{A non-negative \code{\link[base]{numeric}} specifying the minimum
+ length unit, which by default equals one nucleotide/base pair.}
+ \item{minLength}{Minimum length of segments to be kept.}
+ \item{dropGaps}{If \code{\link[base:logical]{TRUE}}, the gaps themselves are not part of the output.}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns \code{\link[base]{data.frame}} of least one row with columns \code{chromosome}
+ if that argument is given), \code{start}, \code{stop} and \code{length}.
+ The segments are ordered along the genome.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ \code{\link{findLargeGaps}}().
+}
+
+
+\keyword{methods}
+\keyword{IO}
diff --git a/man/getBootstrapLocusSets.PairedPSCBS.Rd b/man/getBootstrapLocusSets.PairedPSCBS.Rd
new file mode 100644
index 0000000..be3e43b
--- /dev/null
+++ b/man/getBootstrapLocusSets.PairedPSCBS.Rd
@@ -0,0 +1,53 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.BOOT.sets.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{getBootstrapLocusSets.PairedPSCBS}
+\alias{getBootstrapLocusSets.PairedPSCBS}
+\alias{PairedPSCBS.getBootstrapLocusSets}
+\alias{getBootstrapLocusSets,PairedPSCBS-method}
+\alias{getBootstrapLocusSets}
+
+\title{Generates original and bootstrapped segment-specific index sets}
+
+\description{
+ Generates original and bootstrapped segment-specific index sets, which can be used to calculate various bootstrap summaries,
+ e.g. segment mean levels.
+}
+
+\usage{
+\method{getBootstrapLocusSets}{PairedPSCBS}(fit, B=1000L, by=c("betaTN", "betaT"), seed=NULL, verbose=FALSE,
+ .validate=FALSE, ...)
+}
+
+\arguments{
+ \item{B}{A non-negative \code{\link[base]{integer}} specifying the number of bootstrap samples.}
+ \item{by}{Should \code{betaTN} or \code{betaT} be used?}
+ \item{seed}{An (optional) \code{\link[base]{integer}} specifying the random seed to be
+ set before sampling indices. The random seed is set to its original
+ state when exiting. If \code{\link[base]{NULL}}, it is not set.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+ \item{.validate}{If \code{\link[base:logical]{TRUE}}, additional sanity checks are performed
+ to validate the correctness. This is only needed for troubleshooting
+ if it is suspected there is a bug.}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns a \code{\link[base]{list}}.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ This is used internally by various bootstrap methods.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/getCallStatistics.CBS.Rd b/man/getCallStatistics.CBS.Rd
new file mode 100644
index 0000000..c26b623
--- /dev/null
+++ b/man/getCallStatistics.CBS.Rd
@@ -0,0 +1,70 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% CBS.CALL.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{getCallStatistics.CBS}
+\alias{getCallStatistics.CBS}
+\alias{CBS.getCallStatistics}
+\alias{getCallStatistics,CBS-method}
+
+\title{Calculates various call statistics per chromosome}
+
+\description{
+ Calculates various call statistics per chromosome.
+}
+
+\usage{
+\method{getCallStatistics}{CBS}(fit, regions=NULL, shrinkRegions=TRUE, ..., verbose=FALSE)
+}
+
+\arguments{
+ \item{regions}{An optional \code{\link[base]{data.frame}} with columns "chromosome",
+ "start", and "end" specifying the regions of interest to calculate
+ statistics for. If \code{\link[base]{NULL}}, all of the genome is used.}
+ \item{shrinkRegions}{If \code{\link[base:logical]{TRUE}}, regions are shrunk to the support of
+ the data.}
+ \item{...}{Not used.}
+ \item{verbose}{\code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns a CxK \code{\link[base]{data.frame}}, where C is the number of regions that
+ meet the criteria setup by argument \code{regions}
+ and (K-4)/2 is the number of call types.
+ The first column is the chromosome index, the second and the third
+ are the first and last position, and the fourth the length
+ (=last-first+1) of the chromosome.
+ The following columns contains call summaries per chromosome.
+ For each chromosome and call type, the total length of such calls
+ on that chromosome is reported together how large of a fraction
+ of the chromosome such calls occupy.
+}
+
+\details{
+ The estimators implemented here are based solely on the
+ segmentation results, which is very fast.
+ In the original proposal by Fridlyand et al. [1], the authors
+ estimates the parameters by converting segment-level calls back
+ to locus-level calls and there do the calculations.
+ The difference between the two approaches should be minor,
+ particularly for large density arrays.
+}
+
+\author{Henrik Bengtsson}
+
+\references{
+ [1] Fridlyand et al. \emph{Breast tumor copy number aberration
+ phenotypes and genomic instability}, BMC Cancer, 2006. \cr
+}
+
+\seealso{
+ For more information see \code{\link{CBS}}.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/getChromosomes.AbstractCBS.Rd b/man/getChromosomes.AbstractCBS.Rd
new file mode 100644
index 0000000..9125c3e
--- /dev/null
+++ b/man/getChromosomes.AbstractCBS.Rd
@@ -0,0 +1,39 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{getChromosomes.AbstractCBS}
+\alias{getChromosomes.AbstractCBS}
+\alias{AbstractCBS.getChromosomes}
+\alias{getChromosomes,AbstractCBS-method}
+
+\title{Gets the set of chromosomes}
+
+\description{
+ Gets the set of chromosomes in the segmentation result.
+}
+
+\usage{
+\method{getChromosomes}{AbstractCBS}(this, ...)
+}
+
+\arguments{
+ \item{...}{Arguments passed to \code{\link[PSCBS:getSegments.AbstractCBS]{*getSegments}()}.}
+}
+
+\value{
+ Returns a unique and sorted \code{\link[base]{vector}} of chromosomes segmented.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ \code{\link[PSCBS:nbrOfChromosomes.AbstractCBS]{*nbrOfChromosomes}()}.
+ For more information see \code{\link{AbstractCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/getFractionOfGenomeLost.CBS.Rd b/man/getFractionOfGenomeLost.CBS.Rd
new file mode 100644
index 0000000..a3a881a
--- /dev/null
+++ b/man/getFractionOfGenomeLost.CBS.Rd
@@ -0,0 +1,67 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% CBS.CALL.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{getFractionOfGenomeLost.CBS}
+\alias{getFractionOfGenomeLost.CBS}
+\alias{CBS.getFractionOfGenomeLost}
+\alias{getFractionOfGenomeLost,CBS-method}
+\alias{CBS.getFractionOfGenomeGained}
+\alias{getFractionOfGenomeGained.CBS}
+\alias{getFractionOfGenomeGained,CBS-method}
+
+\alias{CBS.getFractionOfGenomeAltered}
+\alias{getFractionOfGenomeAltered.CBS}
+\alias{getFractionOfGenomeAltered,CBS-method}
+
+\alias{CBS.getFGL}
+\alias{getFGL.CBS}
+\alias{getFGL,CBS-method}
+
+\alias{CBS.getFGG}
+\alias{getFGG.CBS}
+\alias{getFGG,CBS-method}
+
+\alias{CBS.getFGA}
+\alias{getFGA.CBS}
+\alias{getFGA,CBS-method}
+
+
+\title{Calculates the fraction of the genome lost, gained, or aberrant either way}
+
+\description{
+ Calculates the fraction of the genome lost, gained, or aberrant either way (in sense of total copy numbers),
+ using definitions closely related to those presented in [1].
+}
+
+\usage{
+\method{getFractionOfGenomeLost}{CBS}(fit, ...)
+}
+
+\arguments{
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns a \code{\link[base]{double}} in [0,1].
+}
+
+\author{Henrik Bengtsson}
+
+\references{
+ [1] Fridlyand et al. \emph{Breast tumor copy number aberration
+ phenotypes and genomic instability}, BMC Cancer, 2006. \cr
+}
+
+\seealso{
+ Internally, \code{\link[PSCBS:getCallStatistics.CBS]{*getCallStatistics}()} is used.
+ For more information see \code{\link{CBS}}.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/getLocusData.AbstractCBS.Rd b/man/getLocusData.AbstractCBS.Rd
new file mode 100644
index 0000000..46908d8
--- /dev/null
+++ b/man/getLocusData.AbstractCBS.Rd
@@ -0,0 +1,46 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{getLocusData.AbstractCBS}
+\alias{getLocusData.AbstractCBS}
+\alias{AbstractCBS.getLocusData}
+\alias{getLocusData,AbstractCBS-method}
+\alias{AbstractCBS.setLocusData}
+\alias{setLocusData.AbstractCBS}
+\alias{setLocusData,AbstractCBS-method}
+
+\alias{setLocusData.AbstractCBS}
+
+\title{Gets the locus-level data}
+
+\description{
+ Gets the locus-level data.
+}
+
+\usage{
+\method{getLocusData}{AbstractCBS}(...)
+}
+
+\arguments{
+ \item{splitters}{If \code{\link[base:logical]{TRUE}}, "splitters" between chromosomes are
+ preserved, otherwise dropped.}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns a JxL \code{\link[base]{data.frame}}, where J in the number of loci,
+ and L is the number of locus-specific fields.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{AbstractCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/getSampleName.AbstractCBS.Rd b/man/getSampleName.AbstractCBS.Rd
new file mode 100644
index 0000000..9c4befc
--- /dev/null
+++ b/man/getSampleName.AbstractCBS.Rd
@@ -0,0 +1,43 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{getSampleName.AbstractCBS}
+\alias{getSampleName.AbstractCBS}
+\alias{AbstractCBS.getSampleName}
+\alias{getSampleName,AbstractCBS-method}
+\alias{AbstractCBS.sampleName}
+\alias{sampleName.AbstractCBS}
+\alias{sampleName,AbstractCBS-method}
+
+
+\title{Gets the name of the sample segmented}
+
+\description{
+ Gets the name of the sample segmented.
+}
+
+\usage{
+\method{getSampleName}{AbstractCBS}(fit, ...)
+}
+
+\arguments{
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns a \code{\link[base]{character}} string.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ \code{\link[PSCBS:setSampleName.AbstractCBS]{*setSampleName}()}.
+ For more information see \code{\link{AbstractCBS}}..
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/getSegments.AbstractCBS.Rd b/man/getSegments.AbstractCBS.Rd
new file mode 100644
index 0000000..d258cdf
--- /dev/null
+++ b/man/getSegments.AbstractCBS.Rd
@@ -0,0 +1,47 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{getSegments.AbstractCBS}
+\alias{getSegments.AbstractCBS}
+\alias{AbstractCBS.getSegments}
+\alias{getSegments,AbstractCBS-method}
+\alias{AbstractCBS.setSegments}
+\alias{setSegments.AbstractCBS}
+\alias{setSegments,AbstractCBS-method}
+
+\alias{setSegments.AbstractCBS}
+
+\title{Gets the segments}
+
+\description{
+ Gets the segments.
+}
+
+\usage{
+\method{getSegments}{AbstractCBS}(...)
+}
+
+\arguments{
+ \item{simplify}{If \code{\link[base:logical]{TRUE}}, redundant and intermediate information is dropped.}
+ \item{splitters}{If \code{\link[base:logical]{TRUE}}, "splitters" between chromosomes are
+ preserved, otherwise dropped.}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns a SxK \code{\link[base]{data.frame}}, where S in the number of segments,
+ and K is the number of segment-specific fields.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{AbstractCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/getSegments.PSCBS.Rd b/man/getSegments.PSCBS.Rd
new file mode 100644
index 0000000..7a1f075
--- /dev/null
+++ b/man/getSegments.PSCBS.Rd
@@ -0,0 +1,41 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PSCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{getSegments.PSCBS}
+\alias{getSegments.PSCBS}
+\alias{PSCBS.getSegments}
+\alias{getSegments,PSCBS-method}
+
+\title{Gets the segments}
+
+\description{
+ Gets the segments.
+}
+
+\usage{
+\method{getSegments}{PSCBS}(fit, simplify=FALSE, splitters=TRUE, addGaps=FALSE, ...)
+}
+
+\arguments{
+ \item{simplify}{If \code{\link[base:logical]{TRUE}}, redundant and intermediate information is dropped.}# \item{splitters}{If \code{\link[base:logical]{TRUE}}, "splitters" between chromosomes are
+ preserved, otherwise dropped.}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns a SxK \code{\link[base]{data.frame}}, where S in the number of segments,
+ and K is the number of segment-specific fields.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{PSCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/getSmoothLocusData.CBS.Rd b/man/getSmoothLocusData.CBS.Rd
new file mode 100644
index 0000000..b871f49
--- /dev/null
+++ b/man/getSmoothLocusData.CBS.Rd
@@ -0,0 +1,46 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% CBS.SMOOTH.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{getSmoothLocusData.CBS}
+\alias{getSmoothLocusData.CBS}
+\alias{CBS.getSmoothLocusData}
+\alias{getSmoothLocusData,CBS-method}
+
+\title{Gets smoothed locus-level data}
+
+\description{
+ Gets smoothed locus-level data.
+}
+
+\usage{
+\method{getSmoothLocusData}{CBS}(fit, by, ...)
+}
+
+\arguments{
+ \item{fit}{An \code{\link{CBS}} object.}
+ \item{by}{A \code{\link[base]{numeric}} scalar specifying the bin size.}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns a \code{\link[base]{data.frame}} where the
+ first three columns are 'chromosome', 'x' (position),
+ and 'count' (number of loci average over for the given bin),
+ and the remaining ones are the smoothed locus-level data.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{CBS}}.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/hclustCNs.AbstractCBS.Rd b/man/hclustCNs.AbstractCBS.Rd
new file mode 100644
index 0000000..d5375ce
--- /dev/null
+++ b/man/hclustCNs.AbstractCBS.Rd
@@ -0,0 +1,46 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.HCLUST.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{hclustCNs.AbstractCBS}
+\alias{hclustCNs.AbstractCBS}
+\alias{AbstractCBS.hclustCNs}
+\alias{hclustCNs,AbstractCBS-method}
+
+\title{Performs a hierarchical clustering of the CN mean levels}
+
+\description{
+ Performs a hierarchical clustering of the CN mean levels.
+}
+
+\usage{
+\method{hclustCNs}{AbstractCBS}(fit, size=NULL, distMethod="euclidean", hclustMethod="ward.D", ...,
+ verbose=FALSE)
+}
+
+\arguments{
+ \item{size}{Argument passed to \code{\link[PSCBS:sampleCNs.AbstractCBS]{*sampleCNs}()}.}
+ \item{distMethod, hclustMethod}{Argument \code{method} for
+ \code{\link[stats]{dist}} and "stats::hclust", respectively.}
+ \item{...}{Not used.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns a \code{hclust} object as returned by \code{\link[stats]{hclust}}.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ This method is utilized by \code{\link[PSCBS:pruneByHClust.AbstractCBS]{*pruneByHClust}()}.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/installDNAcopy.Rd b/man/installDNAcopy.Rd
new file mode 100644
index 0000000..9bc4e33
--- /dev/null
+++ b/man/installDNAcopy.Rd
@@ -0,0 +1,44 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% installDNAcopy.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{installDNAcopy}
+\alias{installDNAcopy.default}
+\alias{installDNAcopy}
+
+\title{Install the DNAcopy package}
+
+\usage{
+\method{installDNAcopy}{default}(..., force=FALSE)
+}
+
+\description{
+ Install the DNAcopy package, if missing.
+}
+
+\arguments{
+ \item{...}{Arguments passed to the install function.}
+ \item{force}{If \code{\link[base:logical]{FALSE}} and the \pkg{DNAcopy} package is already
+ installed, then it will not be re-install.
+ If \code{\link[base:logical]{TRUE}}, it will be installed.}
+}
+
+\value{
+ Returns nothing.
+}
+
+\details{
+ This function is will download and call the \code{biocLite()}
+ installation function from the Bioconductor Project website.
+ This function will also make sure that \pkg{DNAcopy} is loaded so
+ that it is reported by \code{\link[utils]{sessionInfo}}.
+}
+
+\author{Henrik Bengtsson}
+
+
+\keyword{internal}
diff --git a/man/joinSegments.CBS.Rd b/man/joinSegments.CBS.Rd
new file mode 100644
index 0000000..46f3393
--- /dev/null
+++ b/man/joinSegments.CBS.Rd
@@ -0,0 +1,49 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% CBS.joinSegments.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{joinSegments.CBS}
+\alias{joinSegments.CBS}
+\alias{CBS.joinSegments}
+\alias{joinSegments,CBS-method}
+
+\title{Joins neighboring segments such that there is no gap in between them}
+
+\description{
+ Joins neighboring segments such that there is no gap in between them.
+ For instance, consider two neighboring segments [x1,x2] and [x3,x4]
+ with x1 < x2 < x3 < x4. After join the segments, they are
+ [x1,x23] and [x23,x4] where x23 = (x2 + x3)/2.
+}
+
+\usage{
+\method{joinSegments}{CBS}(fit, range=NULL, verbose=FALSE, ...)
+}
+
+\arguments{
+ \item{range}{(optional) A \code{\link[base]{numeric}} \code{\link[base]{vector}} of length two.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns an updated \code{\link{CBS}} object.
+}
+
+\details{
+ This function assumes only chromosome exists.
+ If more, an error will be thrown.
+}
+
+\author{Henrik Bengtsson}
+
+
+
+\keyword{internal}
+\keyword{methods}
+\keyword{IO}
diff --git a/man/load.AbstractCBS.Rd b/man/load.AbstractCBS.Rd
new file mode 100644
index 0000000..7f6f56c
--- /dev/null
+++ b/man/load.AbstractCBS.Rd
@@ -0,0 +1,46 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{AbstractCBS$load}
+\alias{AbstractCBS$load}
+\alias{load.AbstractCBS}
+\alias{AbstractCBS.load}
+\alias{load,AbstractCBS-method}
+\alias{load}
+
+\title{Loads an AbstractCBS object from file}
+
+\description{
+ Loads an AbstractCBS object from file and assert that it is of the requested class.
+}
+
+\usage{
+## Static method (use this):
+## AbstractCBS$load(...)
+
+## Don't use the below:
+\method{load}{AbstractCBS}(static, ...)
+}
+
+\arguments{
+ \item{...}{Additional arguments passed to \code{\link[R.utils]{loadObject}}.}
+}
+
+\value{
+ Returns the loaded AbstractCBS object.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Internally \code{\link[R.utils]{loadObject}} is used.
+ To save an object, see \code{\link[PSCBS:save.AbstractCBS]{*save}()}.
+ For more information see \code{\link{AbstractCBS}}..
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/mergeNonCalledSegments.CBS.Rd b/man/mergeNonCalledSegments.CBS.Rd
new file mode 100644
index 0000000..169f909
--- /dev/null
+++ b/man/mergeNonCalledSegments.CBS.Rd
@@ -0,0 +1,42 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% CBS.CALL.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{mergeNonCalledSegments.CBS}
+\alias{mergeNonCalledSegments.CBS}
+\alias{CBS.mergeNonCalledSegments}
+\alias{mergeNonCalledSegments,CBS-method}
+
+\title{Merge neighboring segments that are not called}
+
+\description{
+ Merge neighboring segments that are not called
+}
+
+\usage{
+\method{mergeNonCalledSegments}{CBS}(fit, ..., verbose=FALSE)
+}
+
+\arguments{
+ \item{...}{Not used.}
+ \item{verbose}{\code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns an object of the same class
+ with the same of fewer number of segments.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{CBS}}.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/mergeThreeSegments.AbstractCBS.Rd b/man/mergeThreeSegments.AbstractCBS.Rd
new file mode 100644
index 0000000..d32a740
--- /dev/null
+++ b/man/mergeThreeSegments.AbstractCBS.Rd
@@ -0,0 +1,41 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.RESTRUCT.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{mergeThreeSegments.AbstractCBS}
+\alias{mergeThreeSegments.AbstractCBS}
+\alias{AbstractCBS.mergeThreeSegments}
+\alias{mergeThreeSegments,AbstractCBS-method}
+
+\title{Merge a segment and its two flanking segments}
+
+\description{
+ Merge a segment and its two flanking segments into one segment, and recalculating the segment statistics.
+}
+
+\usage{
+\method{mergeThreeSegments}{AbstractCBS}(fit, middle, ...)
+}
+
+\arguments{
+ \item{middle}{An \code{\link[base]{integer}} specifying the three segments
+ (middle-1, middle, middle+1) to be merged.}
+ \item{...}{Additional arguments passed to \code{\link[PSCBS:mergeTwoSegments.AbstractCBS]{*mergeTwoSegments}()}.}
+}
+
+\value{
+ Returns an \code{\link{AbstractCBS}} of the same class with two less segment.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Internally \code{\link[PSCBS:mergeTwoSegments.AbstractCBS]{*mergeTwoSegments}()} is used.
+ For more information see \code{\link{AbstractCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/mergeTwoSegments.AbstractCBS.Rd b/man/mergeTwoSegments.AbstractCBS.Rd
new file mode 100644
index 0000000..07874a2
--- /dev/null
+++ b/man/mergeTwoSegments.AbstractCBS.Rd
@@ -0,0 +1,51 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.RESTRUCT.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{mergeTwoSegments.AbstractCBS}
+\alias{mergeTwoSegments.AbstractCBS}
+\alias{AbstractCBS.mergeTwoSegments}
+\alias{mergeTwoSegments,AbstractCBS-method}
+\alias{AbstractCBS.dropChangePoint}
+\alias{dropChangePoint.AbstractCBS}
+\alias{dropChangePoint,AbstractCBS-method}
+
+
+\title{Merge two neighboring segments}
+
+\description{
+ Merge two neighboring segments into one segment, which is done by dropping their
+ common change point and recalculating the segment statistics.
+}
+
+\usage{
+\method{mergeTwoSegments}{AbstractCBS}(...)
+}
+
+\arguments{
+ \item{left}{An \code{\link[base]{integer}} specifying the segments (left, left+1)
+ to be merged.}
+ \item{update}{If \code{\link[base:logical]{TRUE}}, segment statistics are updated.}
+ \item{verbose}{A \code{\link[base]{logical}} or a \code{\link[R.utils]{Verbose}} object.}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns an \code{\link{AbstractCBS}} of the same class with one less segment.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ To merge a segment and its two flanking segments, see
+ \code{\link[PSCBS:mergeThreeSegments.AbstractCBS]{*mergeThreeSegments}()}.
+ To drop regions (a connected set of segments)
+ see \code{\link[PSCBS:dropRegions.AbstractCBS]{*dropRegions}()}.
+ For more information see \code{\link{AbstractCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/mergeTwoSegments.PairedPSCBS.Rd b/man/mergeTwoSegments.PairedPSCBS.Rd
new file mode 100644
index 0000000..61a7ffc
--- /dev/null
+++ b/man/mergeTwoSegments.PairedPSCBS.Rd
@@ -0,0 +1,44 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.RESTRUCT.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{mergeTwoSegments.PairedPSCBS}
+\alias{mergeTwoSegments.PairedPSCBS}
+\alias{PairedPSCBS.mergeTwoSegments}
+\alias{mergeTwoSegments,PairedPSCBS-method}
+
+\title{Merge two neighboring segments}
+
+\description{
+ Merge two neighboring segments by recalculating segment statistics.
+}
+
+\usage{
+\method{mergeTwoSegments}{PairedPSCBS}(this, left, update=TRUE, verbose=FALSE, ...)
+}
+
+\arguments{
+ \item{left}{An \code{\link[base]{integer}} specifying the segments (left, left+1)
+ to be merged.}
+ \item{update}{If \code{\link[base:logical]{TRUE}}, segment statistics are updated.}
+ \item{verbose}{A \code{\link[base]{logical}} or a \code{\link[R.utils]{Verbose}} object.}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns a \code{\link{PairedPSCBS}} with one less segment.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ To drop regions (a connected set of segments) see \code{dropRegions()}.
+ For more information see \code{\link{PairedPSCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/nbrOfChangePoints.AbstractCBS.Rd b/man/nbrOfChangePoints.AbstractCBS.Rd
new file mode 100644
index 0000000..b6b6abe
--- /dev/null
+++ b/man/nbrOfChangePoints.AbstractCBS.Rd
@@ -0,0 +1,41 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{nbrOfChangePoints.AbstractCBS}
+\alias{nbrOfChangePoints.AbstractCBS}
+\alias{AbstractCBS.nbrOfChangePoints}
+\alias{nbrOfChangePoints,AbstractCBS-method}
+
+\title{Gets the number of change points}
+
+\description{
+ Gets the number of change points, which is defined as the number of segments minus
+ the number of chromosomes.
+}
+
+\usage{
+\method{nbrOfChangePoints}{AbstractCBS}(fit, ignoreGaps=FALSE, dropEmptySegments=TRUE, ...)
+}
+
+\arguments{
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns an \code{\link[base]{integer}}.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ \code{\link[PSCBS:nbrOfSegments.AbstractCBS]{*nbrOfSegments}()}
+ \code{\link[PSCBS:nbrOfChromosomes.AbstractCBS]{*nbrOfChromosomes}()}
+ For more information see \code{\link{AbstractCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/nbrOfChromosomes.AbstractCBS.Rd b/man/nbrOfChromosomes.AbstractCBS.Rd
new file mode 100644
index 0000000..d45a915
--- /dev/null
+++ b/man/nbrOfChromosomes.AbstractCBS.Rd
@@ -0,0 +1,39 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{nbrOfChromosomes.AbstractCBS}
+\alias{nbrOfChromosomes.AbstractCBS}
+\alias{AbstractCBS.nbrOfChromosomes}
+\alias{nbrOfChromosomes,AbstractCBS-method}
+
+\title{Gets the number of chromosomes}
+
+\description{
+ Gets the number of chromosomes.
+}
+
+\usage{
+\method{nbrOfChromosomes}{AbstractCBS}(this, ...)
+}
+
+\arguments{
+ \item{...}{Arguments passed to \code{\link[PSCBS:getChromosomes.AbstractCBS]{*getChromosomes}()}.}
+}
+
+\value{
+ Returns an \code{\link[base]{integer}}.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ \code{\link[PSCBS:getChromosomes.AbstractCBS]{*getChromosomes}()}.
+ For more information see \code{\link{AbstractCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/nbrOfLoci.AbstractCBS.Rd b/man/nbrOfLoci.AbstractCBS.Rd
new file mode 100644
index 0000000..5699068
--- /dev/null
+++ b/man/nbrOfLoci.AbstractCBS.Rd
@@ -0,0 +1,38 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{nbrOfLoci.AbstractCBS}
+\alias{nbrOfLoci.AbstractCBS}
+\alias{AbstractCBS.nbrOfLoci}
+\alias{nbrOfLoci,AbstractCBS-method}
+
+\title{Gets the number of loci}
+
+\description{
+ Gets the number of loci.
+}
+
+\usage{
+\method{nbrOfLoci}{AbstractCBS}(fit, splitters=FALSE, ...)
+}
+
+\arguments{
+ \item{splitters, ...}{Arguments passed to \code{\link[PSCBS:getLocusData.AbstractCBS]{*getLocusData}()}.}
+}
+
+\value{
+ Returns an \code{\link[base]{integer}}.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{AbstractCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/nbrOfSegments.AbstractCBS.Rd b/man/nbrOfSegments.AbstractCBS.Rd
new file mode 100644
index 0000000..2103875
--- /dev/null
+++ b/man/nbrOfSegments.AbstractCBS.Rd
@@ -0,0 +1,40 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{nbrOfSegments.AbstractCBS}
+\alias{nbrOfSegments.AbstractCBS}
+\alias{AbstractCBS.nbrOfSegments}
+\alias{nbrOfSegments,AbstractCBS-method}
+
+\title{Gets the number of segments}
+
+\description{
+ Gets the number of segments.
+}
+
+\usage{
+\method{nbrOfSegments}{AbstractCBS}(this, splitters=FALSE, ...)
+}
+
+\arguments{
+ \item{splitters, ...}{Arguments passed to \code{\link[PSCBS:getSegments.AbstractCBS]{*getSegments}()}.}
+}
+
+\value{
+ Returns an \code{\link[base]{integer}}.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ \code{\link[PSCBS:nbrOfChangePoints.AbstractCBS]{*nbrOfChangePoints}()}
+ \code{\link[PSCBS:nbrOfChromosomes.AbstractCBS]{*nbrOfChromosomes}()}
+ For more information see \code{\link{AbstractCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/ploidy.AbstractCBS.Rd b/man/ploidy.AbstractCBS.Rd
new file mode 100644
index 0000000..d0a4703
--- /dev/null
+++ b/man/ploidy.AbstractCBS.Rd
@@ -0,0 +1,60 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{ploidy.AbstractCBS}
+\alias{ploidy.AbstractCBS}
+\alias{AbstractCBS.ploidy}
+\alias{ploidy,AbstractCBS-method}
+\alias{AbstractCBS.ploidy<-}
+\alias{ploidy<-.AbstractCBS}
+\alias{ploidy<-,AbstractCBS-method}
+
+\alias{AbstractCBS.setPloidy}
+\alias{setPloidy.AbstractCBS}
+\alias{setPloidy,AbstractCBS-method}
+
+\alias{AbstractCBS.adjustPloidyScale}
+\alias{adjustPloidyScale.AbstractCBS}
+\alias{adjustPloidyScale,AbstractCBS-method}
+
+\alias{adjustPloidyScale.PairedPSCBS}
+\alias{adjustPloidyScale}
+\alias{ploidy}
+\alias{ploidy<-}
+\alias{setPloidy}
+
+\title{Gets and sets ploidy}
+
+\description{
+ Gets and sets ploidy.
+}
+
+\usage{
+ \method{ploidy}{AbstractCBS}(fit, ...)
+ \method{ploidy}{AbstractCBS}(fit) <- value
+}
+
+\arguments{
+ \item{fit}{An \code{\link{AbstractCBS}} object.}
+ \item{value}{An \code{\link[base]{integer}} (in \eqn{1,2,\ldots}) specifying the genome ploidy .}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns (invisibly) an updated object.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{AbstractCBS}}..
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/plotTracks.AbstractCBS.Rd b/man/plotTracks.AbstractCBS.Rd
new file mode 100644
index 0000000..19f1e78
--- /dev/null
+++ b/man/plotTracks.AbstractCBS.Rd
@@ -0,0 +1,39 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.PLOT.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{plotTracks.AbstractCBS}
+\alias{plotTracks.AbstractCBS}
+\alias{AbstractCBS.plotTracks}
+\alias{plotTracks,AbstractCBS-method}
+
+\title{Plots the segmentation result along the genome}
+
+\description{
+ Plots the segmentation result along the genome.
+}
+
+\usage{
+\method{plotTracks}{AbstractCBS}(...)
+}
+
+\arguments{
+ \item{...}{...}
+}
+
+\value{
+ Returns nothing.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{AbstractCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/plotTracks.CBS.Rd b/man/plotTracks.CBS.Rd
new file mode 100644
index 0000000..c0f4285
--- /dev/null
+++ b/man/plotTracks.CBS.Rd
@@ -0,0 +1,47 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% CBS.PLOT.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{plotTracks.CBS}
+\alias{plotTracks.CBS}
+\alias{CBS.plotTracks}
+\alias{plotTracks,CBS-method}
+
+\title{Plots copy numbers along the genome}
+
+\description{
+ Plots copy numbers along the genome for one or more chromosomes.
+ Each type of track is plotted in its own panel.
+}
+
+\usage{
+\method{plotTracks}{CBS}(x, scatter=TRUE, pch=20, col="gray", meanCol="purple", cex=1, grid=FALSE,
+ Clim="auto", xScale=1e-06, Clab="auto", ..., byIndex=FALSE, mar=NULL, add=FALSE)
+}
+
+\arguments{
+ \item{x}{A result object returned by \code{\link{segmentByCBS}}().}
+ \item{pch}{The type of points to use.}
+ \item{Clim}{The range of copy numbers.}
+ \item{xScale}{The scale factor used for genomic positions.}
+ \item{...}{Not used.}
+ \item{add}{If \code{\link[base:logical]{TRUE}}, the panels plotted are added to the existing plot,
+ otherwise a new plot is created.}
+}
+
+\value{
+ Returns nothing.
+}
+
+\author{Henrik Bengtsson}
+
+
+
+\keyword{internal}
+\keyword{methods}
+\keyword{IO}
diff --git a/man/plotTracks.PairedPSCBS.Rd b/man/plotTracks.PairedPSCBS.Rd
new file mode 100644
index 0000000..a3e5d30
--- /dev/null
+++ b/man/plotTracks.PairedPSCBS.Rd
@@ -0,0 +1,76 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PairedPSCBS.PLOT.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{plotTracks.PairedPSCBS}
+\alias{plotTracks.PairedPSCBS}
+\alias{PairedPSCBS.plotTracks}
+\alias{plotTracks,PairedPSCBS-method}
+\alias{PairedPSCBS.plotTracks1}
+\alias{plotTracks1.PairedPSCBS}
+\alias{plotTracks1,PairedPSCBS-method}
+
+\alias{PairedPSCBS.plotTracks2}
+\alias{plotTracks2.PairedPSCBS}
+\alias{plotTracks2,PairedPSCBS-method}
+
+\alias{PairedPSCBS.plotTracksManyChromosomes}
+\alias{plotTracksManyChromosomes.PairedPSCBS}
+\alias{plotTracksManyChromosomes,PairedPSCBS-method}
+
+\alias{plot}
+
+\title{Plots parental specific copy numbers along the genome}
+
+\description{
+ Plots parental specific copy numbers along the genome for one or more chromosomes.
+ It is possible to specify what type of tracks to plot.
+ Each type of track is plotted in its own panel.
+}
+
+\usage{
+\method{plotTracks}{PairedPSCBS}(fit, ...)
+}
+
+\arguments{
+ \item{x}{A result object returned by \code{\link{segmentByPairedPSCBS}}().}
+ \item{tracks}{A \code{\link[base]{character}} \code{\link[base]{vector}} specifying what types of tracks to plot.}
+ \item{scatter}{A \code{\link[base]{character}} \code{\link[base]{vector}} specifying which of the tracks should
+ have scatter plot.}
+ \item{calls}{A \code{\link[base]{character}} \code{\link[base]{vector}} of regular expression identifying
+ call labels to be highlighted in the panels.}
+ \item{pch}{The type of the scatter points, if any.}
+ \item{col}{The color of the scatter points, if any.}
+ \item{cex}{The size of the scatter points, if any.}
+ \item{changepoints}{If \code{\link[base:logical]{TRUE}}, changepoints are drawn as vertical lines.}
+ \item{grid}{If \code{\link[base:logical]{TRUE}}, horizontal lines are displayed.}
+ \item{quantiles}{A \code{\link[base]{numeric}} \code{\link[base]{vector}} in [0,1] specifying the quantiles
+ of the confidence bands to be drawn, if any.}
+ \item{xlim}{(Optional) The genomic range to plot.}
+ \item{Clim}{The range of copy numbers.}
+ \item{Blim}{The range of allele B fractions (BAFs) and
+ decrease of heterozygosity (DHs).}
+ \item{xScale}{The scale factor used for genomic positions.}
+ \item{...}{Not used.}
+ \item{add}{If \code{\link[base:logical]{TRUE}}, the panels plotted are added to the existing plot,
+ otherwise a new plot is created.}
+ \item{subplots}{If \code{\link[base:logical]{TRUE}}, then subplots are automatically setup.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns nothing.
+}
+
+\author{Henrik Bengtsson}
+
+
+
+\keyword{internal}
+\keyword{methods}
+\keyword{IO}
diff --git a/man/pruneByDP.AbstractCBS.Rd b/man/pruneByDP.AbstractCBS.Rd
new file mode 100644
index 0000000..477df6e
--- /dev/null
+++ b/man/pruneByDP.AbstractCBS.Rd
@@ -0,0 +1,51 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.PRUNE.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{pruneByDP.AbstractCBS}
+\alias{pruneByDP.AbstractCBS}
+\alias{AbstractCBS.pruneByDP}
+\alias{pruneByDP,AbstractCBS-method}
+
+\title{Prunes the CN profile using dynamical programming}
+
+\description{
+ Prunes the CN profile using dynamical programming by specifying the target number of segments or alternative
+ how of many change points to drop.
+}
+
+\usage{
+\method{pruneByDP}{AbstractCBS}(fit, nbrOfSegments, ..., verbose=FALSE)
+}
+
+\arguments{
+ \item{nbrOfSegments}{An \code{\link[base]{integer}} specifying the number of segments after
+ pruning. If negative, the it specifies the number of change points
+ to drop.}
+ \item{...}{Optional arguments passed to \code{\link[PSCBS:seqOfSegmentsByDP.AbstractCBS]{*seqOfSegmentsByDP}()}.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns a pruned object of the same class.
+}
+
+\examples{\dontrun{
+ # Drop two segments
+ fitP <- pruneByDP(fit, nbrOfSegments=-2);
+}}
+
+\author{Henrik Bengtsson, Pierre Neuvial}
+
+\references{
+ [1] ... \cr
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/pruneByHClust.AbstractCBS.Rd b/man/pruneByHClust.AbstractCBS.Rd
new file mode 100644
index 0000000..4785473
--- /dev/null
+++ b/man/pruneByHClust.AbstractCBS.Rd
@@ -0,0 +1,48 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.HCLUST.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{pruneByHClust.AbstractCBS}
+\alias{pruneByHClust.AbstractCBS}
+\alias{AbstractCBS.pruneByHClust}
+\alias{pruneByHClust,AbstractCBS-method}
+
+\title{Prunes the CN profile by pruning and merging through hierarchical clustering}
+
+\description{
+ Prunes the CN profile by pruning and merging through hierarchical clustering.
+}
+
+\usage{
+\method{pruneByHClust}{AbstractCBS}(fit, ..., size=NULL, distMethod="euclidean", hclustMethod="ward.D",
+ merge=TRUE, update=TRUE, verbose=FALSE)
+}
+
+\arguments{
+ \item{...}{Arguments passed to \code{\link[stats]{cutree}},
+ particularly either of thresholds \code{h} or \code{k}.}
+ \item{size, distMethod, hclustMethod}{Arguments (as well as
+ some of \code{...}) passed to \code{\link[PSCBS:hclustCNs.AbstractCBS]{*hclustCNs}()}.}
+ \item{merge}{If \code{\link[base:logical]{TRUE}}, consecutive segments that belong to the
+ same PSCN cluster will be merged into one large segment.}
+ \item{update}{If \code{\link[base:logical]{TRUE}}, segment means are updated afterwards, otherwise not.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns a pruned object of the same class.
+}
+
+\examples{\dontrun{
+ fitP <- pruneByHClust(fit, h=0.25);
+}}
+
+\author{Henrik Bengtsson}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/pruneBySdUndo.CBS.Rd b/man/pruneBySdUndo.CBS.Rd
new file mode 100644
index 0000000..d4487c4
--- /dev/null
+++ b/man/pruneBySdUndo.CBS.Rd
@@ -0,0 +1,91 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% CBS.PRUNE.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{pruneBySdUndo.CBS}
+\alias{pruneBySdUndo.CBS}
+\alias{CBS.pruneBySdUndo}
+\alias{pruneBySdUndo,CBS-method}
+
+\title{Prune the CBS profile by dropping change points that are too small}
+
+\description{
+ Prune the CBS profile by dropping change points that are too small, where "too small" means that the amplitude of the
+ change points is less than a multiple of the overall standard deviation
+ of the copy-number signals.
+}
+
+\usage{
+\method{pruneBySdUndo}{CBS}(fit, rho=3, sigma="DNAcopy", ..., verbose=FALSE)
+}
+
+\arguments{
+ \item{fit}{A \code{\link{CBS}} object.}
+ \item{rho}{A positive \code{\link[base]{double}} scalar specifying the number of standard
+ deviations (\code{rho*sigma}) required in order to keep a change point.
+ More change points are dropped the greater this value is.}
+ \item{sigma}{The whole-genome standard deviation of the locus-level
+ copy number signals. The default is to calculate it from the data
+ and as done in the \pkg{DNAcopy} package.}
+ \item{...}{(Optional) Additional arguments passed to the standard
+ deviation estimator function.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns a \code{\link{CBS}} object (of the same class as \code{fit}).
+}
+
+\details{
+ This method corresponds to using the \code{undo} argument when calling
+ \code{\link{segmentByCBS}}(), which in turn corresponds to using the
+ \code{undo.splits="sdundo"} and \code{undo.SD} of the underlying
+ \code{\link[DNAcopy]{segment}} method.
+}
+
+\examples{
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Simulating copy-number data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+set.seed(0xBEEF)
+
+# Number of loci
+J <- 1000
+
+mu <- double(J)
+mu[1:100] <- mu[1:100] + 0.3
+mu[200:300] <- mu[200:300] + 1
+mu[350:400] <- NA # centromere
+mu[650:800] <- mu[650:800] - 1
+eps <- rnorm(J, sd=1/2)
+y <- mu + eps
+x <- sort(runif(length(y), max=length(y))) * 1e5
+w <- runif(J)
+w[650:800] <- 0.001
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- segmentByCBS(y, x=x)
+print(fit)
+plotTracks(fit)
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Post-segmentation pruning
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fitP <- pruneBySdUndo(fit, rho=1)
+drawLevels(fitP, col="red")
+}
+
+\author{Henrik Bengtsson, Pierre Neuvial}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/randomSeed.Rd b/man/randomSeed.Rd
new file mode 100644
index 0000000..4b0508e
--- /dev/null
+++ b/man/randomSeed.Rd
@@ -0,0 +1,44 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% randomSeed.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{randomSeed}
+\alias{randomSeed}
+
+
+\title{Sets and resets the .Random.seed in the global environment}
+
+\description{
+ Sets and resets the .Random.seed in the global environment.
+}
+
+\usage{
+ randomSeed(action=c("set", "advance", "reset", "get"), seed=NULL, kind=NULL, n=1L,
+ backup=TRUE)
+}
+
+\arguments{
+ \item{action}{A \code{\link[base]{character}} string specifying the action.}
+ \item{seed}{Random seed to be set; only for \code{action="set"}.
+ If \code{length(seed) == 1}, then \code{set.seed(seed)} is
+ used, otherwise \code{.Random.seed} is assigned the value.}
+ \item{kind}{(optional) A \code{\link[base]{character}} string specifying type of
+ random number generator to use, cf. \code{\link[base]{RNGkind}}().}
+ \item{n}{Number of random seeds to generate by \code{action}.}
+ \item{backup}{If \code{\link[base:logical]{TRUE}}, the previous (seed, kind) state is recorded
+ such that it can be reset later.}
+}
+
+\value{
+ Returns a \code{.Random.seed}.
+ If more than one is returned, the they are returned as a \code{\link[base]{list}}.
+}
+
+\author{Henrik Bengtsson}
+
+
+\keyword{internal}
diff --git a/man/report.AbstractCBS.Rd b/man/report.AbstractCBS.Rd
new file mode 100644
index 0000000..9da19f6
--- /dev/null
+++ b/man/report.AbstractCBS.Rd
@@ -0,0 +1,52 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.REPORT.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{report.AbstractCBS}
+\alias{report.AbstractCBS}
+\alias{AbstractCBS.report}
+\alias{report,AbstractCBS-method}
+
+\title{Generates a report of the segmentation results}
+
+\description{
+ Generates a report of the segmentation results.
+ Currently reports can be generated for segmentation results of class
+ \code{\link{CBS}} and \code{\link{PairedPSCBS}}.
+}
+
+\usage{
+\method{report}{AbstractCBS}(fit, sampleName=getSampleName(fit), studyName, ..., rspTags=NULL,
+ rootPath="reports/", .filename="*", skip=TRUE, envir=new.env(), verbose=FALSE)
+}
+
+\arguments{
+ \item{fit}{An \code{\link{AbstractCBS}} object.}
+ \item{sampleName}{A \code{\link[base]{character}} string specifying the name of the
+ sample segmented.}
+ \item{studyName}{A \code{\link[base]{character}} string specifying the name of study/project.}
+ \item{...}{Optional arguments passed to the RSP template.}
+ \item{rspTags}{Optional \code{\link[base]{character}} \code{\link[base]{vector}} of tags for further specifying
+ which RSP report to generate.}
+ \item{rootPath}{The root directory where to write the report.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns the pathname of the generated PDF.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{AbstractCBS}}.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/resetSegments.AbstractCBS.Rd b/man/resetSegments.AbstractCBS.Rd
new file mode 100644
index 0000000..dc751bb
--- /dev/null
+++ b/man/resetSegments.AbstractCBS.Rd
@@ -0,0 +1,43 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{resetSegments.AbstractCBS}
+\alias{resetSegments.AbstractCBS}
+\alias{AbstractCBS.resetSegments}
+\alias{resetSegments,AbstractCBS-method}
+
+\title{Reset the segments}
+
+\description{
+ Reset the segments. More precisely, it removes columns in the segmentation
+ result table that have been added by methods after the actual
+ segmentation method, e.g. bootstrap estimated mean level quantiles
+ and various calls.
+ It leave the basic segmentation results untouched,
+ i.e. the partitioning and the segment means.
+}
+
+\usage{
+\method{resetSegments}{AbstractCBS}(fit, ...)
+}
+
+\arguments{
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns an object if the same class as the input result.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{AbstractCBS}}.
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/save.AbstractCBS.Rd b/man/save.AbstractCBS.Rd
new file mode 100644
index 0000000..35d2f5e
--- /dev/null
+++ b/man/save.AbstractCBS.Rd
@@ -0,0 +1,40 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{save.AbstractCBS}
+\alias{save.AbstractCBS}
+\alias{AbstractCBS.save}
+\alias{save,AbstractCBS-method}
+
+\title{Saves an AbstractCBS object to file}
+
+\description{
+ Saves an AbstractCBS object to file.
+}
+
+\usage{
+\method{save}{AbstractCBS}(this, ...)
+}
+
+\arguments{
+ \item{...}{Additional arguments passed to \code{\link[R.utils]{saveObject}}.}
+}
+
+\value{
+ Returns what \code{\link[R.utils]{saveObject}} returns.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Internally \code{\link[R.utils]{saveObject}} is used.
+ To load an object, see \code{\link[PSCBS:load.AbstractCBS]{*load}()}.
+ For more information see \code{\link{AbstractCBS}}..
+}
+\keyword{internal}
+\keyword{methods}
diff --git a/man/segmentByCBS.Rd b/man/segmentByCBS.Rd
new file mode 100644
index 0000000..3514b9b
--- /dev/null
+++ b/man/segmentByCBS.Rd
@@ -0,0 +1,248 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% segmentByCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{segmentByCBS}
+\alias{segmentByCBS.default}
+\alias{segmentByCBS}
+\alias{segmentByCBS.data.frame}
+\alias{segmentByCBS.CBS}
+\alias{segmentByCBS.CNA}
+\alias{segmentByCBS}
+
+\title{Segment genomic signals using the CBS method}
+
+\description{
+ Segment genomic signals using the CBS method of the \pkg{DNAcopy} package.
+ This is a convenient low-level wrapper for the \code{DNAcopy::segment()}
+ method. It is intended to be applied to a sample at the time.
+ For more details on the Circular Binary Segmentation (CBS) method
+ see [1,2].
+}
+
+\usage{
+\method{segmentByCBS}{default}(y, chromosome=0L, x=NULL, index=seq(along = y), w=NULL, undo=0,
+ avg=c("mean", "median"), ..., joinSegments=TRUE, knownSegments=NULL, seed=NULL,
+ verbose=FALSE)
+}
+
+\arguments{
+ \item{y}{A \code{\link[base]{numeric}} \code{\link[base]{vector}} of J genomic signals to be segmented.}
+ \item{chromosome}{Optional \code{\link[base]{numeric}} \code{\link[base]{vector}} of length J, specifying
+ the chromosome of each loci. If a scalar, it is expanded to
+ a vector of length J.}
+ \item{x}{Optional \code{\link[base]{numeric}} \code{\link[base]{vector}} of J genomic locations.
+ If \code{\link[base]{NULL}}, index locations \code{1:J} are used.}
+ \item{index}{An optional \code{\link[base]{integer}} \code{\link[base]{vector}} of length J specifying
+ the genomewide indices of the loci.}
+ \item{w}{Optional \code{\link[base]{numeric}} \code{\link[base]{vector}} in [0,1] of J weights.}
+ \item{undo}{A non-negative \code{\link[base]{numeric}}. If greater than zero, then
+ arguments \code{undo.splits="sdundo"} and \code{undo.SD=undo}
+ are passed to \code{DNAcopy::segment()}.
+ In the special case when \code{undo} is +\code{\link[base:is.finite]{Inf}}, the segmentation
+ result will not contain any changepoints (in addition to what
+ is specified by argument \code{knownSegments}).}
+ \item{avg}{A \code{\link[base]{character}} string specifying how to calculating
+ segment mean levels \emph{after} change points have been
+ identified.}
+ \item{...}{Additional arguments passed to the \code{DNAcopy::segment()}
+ segmentation function.}
+ \item{joinSegments}{If \code{\link[base:logical]{TRUE}}, there are no gaps between neighboring
+ segments.
+ If \code{\link[base:logical]{FALSE}}, the boundaries of a segment are defined by the support
+ that the loci in the segments provides, i.e. there exist a locus
+ at each end point of each segment. This also means that there
+ is a gap between any neighboring segments, unless the change point
+ is in the middle of multiple loci with the same position.
+ The latter is what \code{DNAcopy::segment()} returns.
+ }
+ \item{knownSegments}{Optional \code{\link[base]{data.frame}} specifying
+ \emph{non-overlapping} known segments. These segments must
+ not share loci. See \code{\link{findLargeGaps}}() and \code{\link{gapsToSegments}}().}
+ \item{seed}{An (optional) \code{\link[base]{integer}} specifying the random seed to be
+ set before calling the segmentation method. The random seed is
+ set to its original state when exiting. If \code{\link[base]{NULL}}, it is not set.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns a \code{\link{CBS}} object.
+}
+
+\details{
+ Internally \code{\link[DNAcopy]{segment}} of \pkg{DNAcopy} is used to
+ segment the signals.
+ This segmentation method support weighted segmentation.
+}
+
+\section{Reproducibility}{
+ The \code{DNAcopy::segment()} implementation of CBS uses approximation
+ through random sampling for some estimates. Because of this,
+ repeated calls using the same signals may result in slightly
+ different results, unless the random seed is set/fixed.
+}
+
+\section{Missing and non-finite values}{
+ Signals may contain missing values (\code{\link[base]{NA}} or \code{\link[base:is.finite]{NaN}}), but not
+ infinite values (+/-\code{\link[base:is.finite]{Inf}}). Loci with missing-value signals
+ are preserved and keep in the result.
+
+ Likewise, genomic positions may contain missing values.
+ However, if they do, such loci are silently excluded before
+ performing the segmentation, and are not kept in the results.
+ The mapping between the input locus-level data and ditto of
+ the result can be inferred from the \code{index} column of
+ the locus-level data of the result.
+
+ None of the input data may have infinite values,
+ i.e. -\code{\link[base:is.finite]{Inf}} or +\code{\link[base:is.finite]{Inf}}. If so, an informative error is thrown.
+}
+
+\examples{
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Simulating copy-number data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+set.seed(0xBEEF)
+
+# Number of loci
+J <- 1000
+
+mu <- double(J)
+mu[200:300] <- mu[200:300] + 1
+mu[350:400] <- NA # centromere
+mu[650:800] <- mu[650:800] - 1
+eps <- rnorm(J, sd=1/2)
+y <- mu + eps
+x <- sort(runif(length(y), max=length(y))) * 1e5
+w <- runif(J)
+w[650:800] <- 0.001
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- segmentByCBS(y, x=x)
+print(fit)
+plotTracks(fit)
+
+
+
+xlab <- "Position (Mb)"
+ylim <- c(-3,3)
+xMb <- x/1e6
+plot(xMb,y, pch=20, col="#aaaaaa", xlab=xlab, ylim=ylim)
+drawLevels(fit, col="red", lwd=2, xScale=1e-6)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# TESTS
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- segmentByCBS(y, x=x, seed=0xBEEF)
+print(fit)
+## id chromosome start end nbrOfLoci mean
+## 1 y 0 55167.82 20774251 201 0.0164
+## 2 y 0 20774250.85 29320105 99 1.0474
+## 3 y 0 29320104.86 65874675 349 -0.0227
+## 4 y 0 65874675.06 81348129 151 -1.0813
+## 5 y 0 81348129.20 99910827 200 -0.0612
+
+
+# Test #1: Reverse the ordering and segment
+fitR <- segmentByCBS(rev(y), x=rev(x), seed=0xBEEF)
+# Sanity check
+stopifnot(all.equal(getSegments(fitR), getSegments(fit)))
+# Sanity check
+stopifnot(all.equal(rev(getLocusData(fitR)$index), getLocusData(fit)$index))
+
+# Test #2: Reverse, but preserve ordering of 'data' object
+fitRP <- segmentByCBS(rev(y), x=rev(x), preserveOrder=TRUE)
+stopifnot(all.equal(getSegments(fitRP), getSegments(fit)))
+
+
+# (Test #3: Change points inbetween data points at the same locus)
+x[650:654] <- x[649]
+fitC <- segmentByCBS(rev(y), x=rev(x), preserveOrder=TRUE, seed=0xBEEF)
+
+# Test #4: Allow for some missing values in signals
+y[450] <- NA
+fitD <- segmentByCBS(y, x=x, seed=0xBEEF)
+
+
+# Test #5: Allow for some missing genomic annotations
+x[495] <- NA
+fitE <- segmentByCBS(y, x=x, seed=0xBEEF)
+
+
+# Test #6: Undo all change points found
+fitF <- segmentByCBS(y, x=x, undo=Inf, seed=0xBEEF)
+print(fitF)
+stopifnot(nbrOfSegments(fitF) == 1L)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# MISC.
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Emulate a centromere
+x[650:699] <- NA
+fit <- segmentByCBS(y, x=x, seed=0xBEEF)
+xMb <- x/1e6
+plot(xMb,y, pch=20, col="#aaaaaa", xlab=xlab, ylim=ylim)
+drawLevels(fit, col="red", lwd=2, xScale=1e-6)
+
+fitC <- segmentByCBS(y, x=x, joinSegments=FALSE, seed=0xBEEF)
+drawLevels(fitC, col="blue", lwd=2, xScale=1e-6)
+
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Multiple chromosomes
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Appending CBS results
+fit1 <- segmentByCBS(y, chromosome=1, x=x)
+fit2 <- segmentByCBS(y, chromosome=2, x=x)
+fit <- append(fit1, fit2)
+print(fit)
+plotTracks(fit, subset=NULL, lwd=2, Clim=c(-3,3))
+
+
+# Segmenting multiple chromosomes at once
+chromosomeWG <- rep(1:2, each=J)
+xWG <- rep(x, times=2)
+yWG <- rep(y, times=2)
+fitWG <- segmentByCBS(yWG, chromosome=chromosomeWG, x=xWG)
+print(fitWG)
+plotTracks(fitWG, subset=NULL, lwd=2, Clim=c(-3,3))
+
+# Assert same results
+fit$data[,"index"] <- getLocusData(fitWG)[,"index"] # Ignore 'index'
+stopifnot(all.equal(getLocusData(fitWG), getLocusData(fit)))
+stopifnot(all.equal(getSegments(fitWG), getSegments(fit)))
+
+}
+
+\author{Henrik Bengtsson}
+
+\references{
+ [1] A.B. Olshen, E.S. Venkatraman (aka Venkatraman E. Seshan), R. Lucito and M. Wigler, \emph{Circular binary segmentation for the analysis of array-based DNA copy number data}, Biostatistics, 2004
+ \cr
+ [2] E.S. Venkatraman and A.B. Olshen, \emph{A faster circular binary segmentation algorithm for the analysis of array CGH data}, Bioinformatics, 2007
+ \cr
+}
+
+\seealso{
+ To segment allele-specific tumor copy-number signals from a tumor
+ \emph{with} a matched normal, see \code{\link{segmentByPairedPSCBS}}().
+ For the same \emph{without} a matched normal,
+ see \code{\link{segmentByNonPairedPSCBS}}().
+
+ It is also possible to prune change points after segmentation (with
+ identical results) using
+ \code{\link[PSCBS:pruneBySdUndo.CBS]{pruneBySdUndo}()}.
+}
+
+\keyword{IO}
diff --git a/man/segmentByNonPairedPSCBS.Rd b/man/segmentByNonPairedPSCBS.Rd
new file mode 100644
index 0000000..c7dbb82
--- /dev/null
+++ b/man/segmentByNonPairedPSCBS.Rd
@@ -0,0 +1,183 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% segmentByNonPairedPSCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{segmentByNonPairedPSCBS}
+\alias{segmentByNonPairedPSCBS.default}
+\alias{segmentByNonPairedPSCBS}
+\alias{segmentByNonPairedPSCBS.data.frame}
+\alias{segmentByNonPairedPSCBS.PairedPSCBS}
+\alias{segmentByNonPairedPSCBS}
+
+\title{Segment total copy numbers and allele B fractions using the Non-paired PSCBS method}
+
+\description{
+ Segment total copy numbers and allele B fractions using the Non-paired PSCBS method [1].
+ This method does not requires matched normals.
+ This is a low-level segmentation method.
+ It is intended to be applied to one tumor sample at the time.
+}
+
+\usage{
+\method{segmentByNonPairedPSCBS}{default}(CT, betaT, ..., flavor=c("tcn", "tcn&dh", "tcn,dh",
+ "sqrt(tcn),dh", "sqrt(tcn)&dh"), tauA=NA, tauB=1 - tauA, verbose=FALSE)
+}
+
+\arguments{
+ \item{CT}{A \code{\link[base]{numeric}} \code{\link[base]{vector}} of J tumor total copy number (TCN)
+ ratios in [0,+\code{\link[base:is.finite]{Inf}}) (due to noise, small negative values are
+ also allowed). The TCN ratios are typically scaled such that
+ copy-neutral diploid loci have a mean of two.}
+ \item{betaT}{A \code{\link[base]{numeric}} \code{\link[base]{vector}} of J tumor allele B fractions (BAFs)
+ in [0,1] (due to noise, values may be slightly outside as well)
+ or \code{\link[base]{NA}} for non-polymorphic loci.}
+ \item{...}{Additional arguments passed to \code{\link{segmentByPairedPSCBS}}().}
+ \item{flavor}{A \code{\link[base]{character}} specifying what type of segmentation and
+ calling algorithm to be used.}
+ \item{tauA, tauB}{Lower and upper thresholds (\code{tauA < tauB} for
+ calling SNPs heterozygous based on the tumor allele B fractions
+ (\code{betaT}). If \code{\link[base]{NA}}, then they are estimates from data.
+ }
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns the segmentation results as a \code{\link{NonPairedPSCBS}} object.
+}
+
+\details{
+ Internally \code{\link{segmentByPairedPSCBS}}() is used for segmentation.
+ This segmentation method does \emph{not} support weights.
+}
+
+\section{Reproducibility}{
+ The "DNAcopy::segment" implementation of CBS uses approximation
+ through random sampling for some estimates. Because of this,
+ repeated calls using the same signals may result in slightly
+ different results, unless the random seed is set/fixed.
+}
+
+\section{Whole-genome segmentation is preferred}{
+ Although it is possible to segment each chromosome independently
+ using Paired PSCBS, we strongly recommend to segment whole-genome
+ (TCN,BAF) data at once. The reason for this is that downstream
+ CN-state calling methods, such as the AB and the LOH callers,
+ performs much better on whole-genome data. In fact, they may
+ fail to provide valid calls if done chromsome by chromosome.
+}
+
+\section{Missing and non-finite values}{
+ The total copy number signals as well as any optional positions
+ must not contain missing values, i.e. \code{\link[base]{NA}}s or \code{\link[base:is.finite]{NaN}}s.
+ If there are any, an informative error is thrown.
+ Allele B fractions may contain missing values, because such are
+ interpreted as representing non-polymorphic loci.
+
+ None of the input signals may have infinite values, i.e. -\code{\link[base:is.finite]{Inf}} or +\code{\link[base:is.finite]{Inf}}.
+ If so, an informative error is thrown.
+}
+
+\section{Non-Paired PSCBS with known genotypes}{
+ If allele B fractions for the matched normal (\code{betaN}) are
+ not available, but genotypes (\code{muN}) are, then it is possible
+ to run Paired PSCBS. See \code{\link{segmentByPairedPSCBS}}() for details.
+}
+
+\examples{
+verbose <- R.utils::Arguments$getVerbose(-10*interactive(), timestamp=TRUE)
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Load SNP microarray data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+data <- PSCBS::exampleData("paired.chr01")
+str(data)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Paired PSCBS segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Drop single-locus outliers
+dataS <- dropSegmentationOutliers(data)
+
+# Speed up example by segmenting fewer loci
+dataS <- dataS[seq(from=1, to=nrow(data), by=20),]
+
+str(dataS)
+
+R.oo::attachLocally(dataS)
+
+# Non-Paired PSCBS segmentation
+fit <- segmentByNonPairedPSCBS(CT, betaT=betaT,
+ chromosome=chromosome, x=x,
+ seed=0xBEEF, verbose=verbose)
+print(fit)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Bootstrap segment level estimates
+# (used by the AB caller, which, if skipped here,
+# will do it automatically)
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- bootstrapTCNandDHByRegion(fit, B=100, verbose=verbose)
+print(fit)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Calling segments in allelic balance (AB)
+# NOTE: Ideally, this should be done on whole-genome data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Explicitly estimate the threshold in DH for calling AB
+# (which be done by default by the caller, if skipped here)
+deltaAB <- estimateDeltaAB(fit, flavor="qq(DH)", verbose=verbose)
+print(deltaAB)
+
+fit <- callAB(fit, delta=deltaAB, verbose=verbose)
+print(fit)
+
+
+# Even if not explicitly specified, the estimated
+# threshold parameter is returned by the caller
+stopifnot(fit$params$deltaAB == deltaAB)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Calling segments in loss-of-heterozygosity (LOH)
+# NOTE: Ideally, this should be done on whole-genome data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Explicitly estimate the threshold in C1 for calling LOH
+# (which be done by default by the caller, if skipped here)
+deltaLOH <- estimateDeltaLOH(fit, flavor="minC1|nonAB", verbose=verbose)
+print(deltaLOH)
+
+fit <- callLOH(fit, delta=deltaLOH, verbose=verbose)
+print(fit)
+plotTracks(fit)
+
+# Even if not explicitly specified, the estimated
+# threshold parameter is returned by the caller
+stopifnot(fit$params$deltaLOH == deltaLOH)
+}
+
+\author{Henrik Bengtsson}
+
+\references{
+ [1] A.B. Olshen, H. Bengtsson, P. Neuvial, P.T. Spellman, R.A. Olshen, V.E. Seshan, \emph{Parent-specific copy number in paired tumor-normal studies using circular binary segmentation}, Bioinformatics, 2011
+ \cr
+ [2] H. Bengtsson, P. Neuvial and T.P. Speed, \emph{TumorBoost: Normalization of allele-specific tumor copy numbers from a single pair of tumor-normal genotyping microarrays}, BMC Bioinformatics, 2010
+ \cr
+}
+
+\seealso{
+ To segment paired tumor-normal total copy numbers and allele B fractions,
+ see \code{\link{segmentByPairedPSCBS}}().
+
+ To segment total copy numbers, or any other unimodal signals,
+ see \code{\link{segmentByCBS}}().
+}
+
+
+\keyword{IO}
diff --git a/man/segmentByPairedPSCBS.Rd b/man/segmentByPairedPSCBS.Rd
new file mode 100644
index 0000000..527bfe6
--- /dev/null
+++ b/man/segmentByPairedPSCBS.Rd
@@ -0,0 +1,251 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% segmentByPairedPSCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{segmentByPairedPSCBS}
+\alias{segmentByPairedPSCBS.default}
+\alias{segmentByPairedPSCBS}
+\alias{segmentByPairedPSCBS.data.frame}
+\alias{segmentByPairedPSCBS.PairedPSCBS}
+\alias{segmentByPairedPSCBS}
+
+\title{Segment total copy numbers and allele B fractions using the Paired PSCBS method}
+
+\description{
+ Segment total copy numbers and allele B fractions using the Paired PSCBS method [1].
+ This method requires matched normals.
+ This is a low-level segmentation method.
+ It is intended to be applied to one tumor-normal sample at the time.
+}
+
+\usage{
+\method{segmentByPairedPSCBS}{default}(CT, thetaT=NULL, thetaN=NULL, betaT=NULL, betaN=NULL, muN=NULL,
+ rho=NULL, chromosome=0, x=NULL, alphaTCN=0.009, alphaDH=0.001, undoTCN=0, undoDH=0,
+ ..., avgTCN=c("mean", "median"), avgDH=c("mean", "median"),
+ flavor=c("tcn&dh", "tcn,dh", "sqrt(tcn),dh", "sqrt(tcn)&dh", "tcn"), tbn=is.null(rho),
+ preserveScale=getOption("PSCBS/preserveScale", FALSE), joinSegments=TRUE,
+ knownSegments=NULL, dropMissingCT=TRUE, seed=NULL, verbose=FALSE)
+}
+
+\arguments{
+ \item{CT}{A \code{\link[base]{numeric}} \code{\link[base]{vector}} of J tumor total copy number (TCN)
+ ratios in [0,+\code{\link[base:is.finite]{Inf}}) (due to noise, small negative values are
+ also allowed). The TCN ratios are typically scaled such that
+ copy-neutral diploid loci have a mean of two.}
+ \item{thetaT, thetaN}{(alternative) As an alternative to specifying
+ tumor TCN \emph{ratios} relative to the match normal by
+ argument \code{CT}, on may specify total tumor and normal
+ signals seperately, in which case the TCN ratios \code{CT} are
+ calculated as \eqn{CT = 2*thetaT/thetaN}.}
+ \item{betaT}{A \code{\link[base]{numeric}} \code{\link[base]{vector}} of J tumor allele B fractions (BAFs)
+ in [0,1] (due to noise, values may be slightly outside as well)
+ or \code{\link[base]{NA}} for non-polymorphic loci.}
+ \item{betaN}{A \code{\link[base]{numeric}} \code{\link[base]{vector}} of J matched normal BAFs in [0,1]
+ (due to noise, values may be slightly outside as well) or \code{\link[base]{NA}}
+ for non-polymorphic loci.}
+ \item{muN}{An optional \code{\link[base]{numeric}} \code{\link[base]{vector}} of J genotype calls in
+ \{0,1/2,1\} for AA, AB, and BB, respectively,
+ and \code{\link[base]{NA}} for non-polymorphic loci.
+ If not given, they are estimated from the normal BAFs using
+ \code{\link[aroma.light]{callNaiveGenotypes}} as described in [2].}
+ \item{rho}{(alternative to \code{betaT} and \code{betaN}/\code{muN})
+ A \code{\link[base]{numeric}} \code{\link[base]{vector}} of J decrease-of-heterozygosity signals (DHs)
+ in [0,1] (due to noise, values may be slightly larger than one
+ as well). By definition, DH should be \code{\link[base]{NA}} for homozygous loci
+ and for non-polymorphic loci.}
+ \item{chromosome}{(Optional) An \code{\link[base]{integer}} scalar (or a \code{\link[base]{vector}} of length J),
+ which can be used to specify which chromosome each locus belongs to
+ in case multiple chromosomes are segments.
+ This argument is also used for annotation purposes.}
+ \item{x}{Optional \code{\link[base]{numeric}} \code{\link[base]{vector}} of J genomic locations.
+ If \code{\link[base]{NULL}}, index locations \code{1:J} are used.}
+ \item{alphaTCN, alphaDH}{The significance levels for segmenting total
+ copy numbers (TCNs) and decrease-in-heterozygosity signals (DHs),
+ respectively.}
+ \item{undoTCN, undoDH}{Non-negative \code{\link[base]{numeric}}s. If greater than 0,
+ then a cleanup of segmentions post segmentation is done.
+ See argument \code{undo} of \code{\link{segmentByCBS}}() for more
+ details.}
+ \item{avgTCN, avgDH}{A \code{\link[base]{character}} string specifying how to calculating
+ segment mean levels \emph{after} change points have been
+ identified.}
+ \item{...}{Additional arguments passed to \code{\link{segmentByCBS}}().}
+ \item{flavor}{A \code{\link[base]{character}} specifying what type of segmentation and
+ calling algorithm to be used.}
+ \item{tbn}{If \code{\link[base:logical]{TRUE}}, \code{betaT} is normalized before segmentation
+ using the TumorBoost method [2], otherwise not.}
+ \item{preserveScale}{Passed to \code{\link[aroma.light]{normalizeTumorBoost}},
+ which is only called if \code{tbn} is \code{\link[base:logical]{TRUE}}.}
+ \item{joinSegments}{If \code{\link[base:logical]{TRUE}}, there are no gaps between neighboring
+ segments.
+ If \code{\link[base:logical]{FALSE}}, the boundaries of a segment are defined by the support
+ that the loci in the segments provides, i.e. there exist a locus
+ at each end point of each segment. This also means that there
+ is a gap between any neighboring segments, unless the change point
+ is in the middle of multiple loci with the same position.
+ The latter is what \code{DNAcopy::segment()} returns.
+ }
+ \item{knownSegments}{Optional \code{\link[base]{data.frame}} specifying
+ \emph{non-overlapping} known segments. These segments must
+ not share loci. See \code{\link{findLargeGaps}}() and \code{\link{gapsToSegments}}().}
+ \item{dropMissingCT}{If \code{\link[base:logical]{TRUE}}, loci for which 'CT' is missing
+ are dropped, otherwise not.}
+ \item{seed}{An (optional) \code{\link[base]{integer}} specifying the random seed to be
+ set before calling the segmentation method. The random seed is
+ set to its original state when exiting. If \code{\link[base]{NULL}}, it is not set.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns the segmentation results as a \code{\link{PairedPSCBS}} object.
+}
+
+\details{
+ Internally \code{\link{segmentByCBS}}() is used for segmentation.
+ The Paired PSCBS segmentation method does \emph{not} support weights.
+}
+
+\section{Reproducibility}{
+ The "DNAcopy::segment" implementation of CBS uses approximation
+ through random sampling for some estimates. Because of this,
+ repeated calls using the same signals may result in slightly
+ different results, unless the random seed is set/fixed.
+}
+
+\section{Whole-genome segmentation is preferred}{
+ Although it is possible to segment each chromosome independently
+ using Paired PSCBS, we strongly recommend to segment whole-genome
+ (TCN,BAF) data at once. The reason for this is that downstream
+ CN-state calling methods, such as the AB and the LOH callers,
+ performs much better on whole-genome data. In fact, they may
+ fail to provide valid calls if done chromsome by chromosome.
+}
+
+\section{Missing and non-finite values}{
+ The total copy number signals as well as any optional positions
+ must not contain missing values, i.e. \code{\link[base]{NA}}s or \code{\link[base:is.finite]{NaN}}s.
+ If there are any, an informative error is thrown.
+ Allele B fractions may contain missing values, because such are
+ interpreted as representing non-polymorphic loci.
+
+ None of the input signals may have infinite values, i.e. -\code{\link[base:is.finite]{Inf}} or +\code{\link[base:is.finite]{Inf}}.
+ If so, an informative error is thrown.
+}
+
+\section{Paired PSCBS with only genotypes}{
+ If allele B fractions for the matched normal (\code{betaN}) are
+ not available, but genotypes (\code{muN}) are, then it is possible
+ to run a version of Paired PSCBS where TumorBoost normalization
+ of the tumor allele B fractions is skipped. In order for this
+ to work, argument \code{tbn} must be set to \code{\link[base:logical]{FALSE}}.
+}
+
+\examples{
+verbose <- R.utils::Arguments$getVerbose(-10*interactive(), timestamp=TRUE)
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Load SNP microarray data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+data <- PSCBS::exampleData("paired.chr01")
+str(data)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Paired PSCBS segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Drop single-locus outliers
+dataS <- dropSegmentationOutliers(data)
+
+# Speed up example by segmenting fewer loci
+dataS <- dataS[seq(from=1, to=nrow(data), by=10),]
+
+str(dataS)
+
+R.oo::attachLocally(dataS)
+
+# Paired PSCBS segmentation
+fit <- segmentByPairedPSCBS(CT, betaT=betaT, betaN=betaN,
+ chromosome=chromosome, x=x,
+ seed=0xBEEF, verbose=verbose)
+print(fit)
+
+# Plot results
+plotTracks(fit)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Bootstrap segment level estimates
+# (used by the AB caller, which, if skipped here,
+# will do it automatically)
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- bootstrapTCNandDHByRegion(fit, B=100, verbose=verbose)
+print(fit)
+plotTracks(fit)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Calling segments in allelic balance (AB)
+# NOTE: Ideally, this should be done on whole-genome data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Explicitly estimate the threshold in DH for calling AB
+# (which be done by default by the caller, if skipped here)
+deltaAB <- estimateDeltaAB(fit, flavor="qq(DH)", verbose=verbose)
+print(deltaAB)
+## [1] 0.1657131
+
+fit <- callAB(fit, delta=deltaAB, verbose=verbose)
+print(fit)
+plotTracks(fit)
+
+# Even if not explicitly specified, the estimated
+# threshold parameter is returned by the caller
+stopifnot(fit$params$deltaAB == deltaAB)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Calling segments in loss-of-heterozygosity (LOH)
+# NOTE: Ideally, this should be done on whole-genome data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Explicitly estimate the threshold in C1 for calling LOH
+# (which be done by default by the caller, if skipped here)
+deltaLOH <- estimateDeltaLOH(fit, flavor="minC1|nonAB", verbose=verbose)
+print(deltaLOH)
+## [1] 0.625175
+
+fit <- callLOH(fit, delta=deltaLOH, verbose=verbose)
+print(fit)
+plotTracks(fit)
+
+# Even if not explicitly specified, the estimated
+# threshold parameter is returned by the caller
+stopifnot(fit$params$deltaLOH == deltaLOH)
+}
+
+\author{Henrik Bengtsson}
+
+\references{
+ [1] A.B. Olshen, H. Bengtsson, P. Neuvial, P.T. Spellman, R.A. Olshen, V.E. Seshan, \emph{Parent-specific copy number in paired tumor-normal studies using circular binary segmentation}, Bioinformatics, 2011
+ \cr
+ [2] H. Bengtsson, P. Neuvial and T.P. Speed, \emph{TumorBoost: Normalization of allele-specific tumor copy numbers from a single pair of tumor-normal genotyping microarrays}, BMC Bioinformatics, 2010
+ \cr
+}
+
+\seealso{
+ Internally, \code{\link[aroma.light]{callNaiveGenotypes}} is used to
+ call naive genotypes, \code{\link[aroma.light]{normalizeTumorBoost}} is
+ used for TumorBoost normalization, and \code{\link{segmentByCBS}}() is used
+ to segment TCN and DH separately.
+
+ To segment tumor total copy numbers and allele B fractions
+ \emph{without} a matched normal, see \code{\link{segmentByNonPairedPSCBS}}().
+
+ To segment total copy-numbers, or any other unimodal signals,
+ see \code{\link{segmentByCBS}}().
+}
+
+
+\keyword{IO}
diff --git a/man/setSampleName.AbstractCBS.Rd b/man/setSampleName.AbstractCBS.Rd
new file mode 100644
index 0000000..d255f71
--- /dev/null
+++ b/man/setSampleName.AbstractCBS.Rd
@@ -0,0 +1,45 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{setSampleName.AbstractCBS}
+\alias{setSampleName.AbstractCBS}
+\alias{AbstractCBS.setSampleName}
+\alias{setSampleName,AbstractCBS-method}
+\alias{AbstractCBS.sampleName<-}
+\alias{sampleName<-.AbstractCBS}
+\alias{sampleName<-,AbstractCBS-method}
+
+
+\title{Sets the name of the sample segmented}
+
+\description{
+ Sets the name of the sample segmented.
+}
+
+\usage{
+\method{setSampleName}{AbstractCBS}(fit, name, ...)
+}
+
+\arguments{
+ \item{name}{A \code{\link[base]{character}} string.}
+ \item{...}{Not used.}
+}
+
+\value{
+ Returns (invisibly) an updated object.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ For more information see \code{\link{AbstractCBS}}..
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/testROH.numeric.Rd b/man/testROH.numeric.Rd
new file mode 100644
index 0000000..f4648d4
--- /dev/null
+++ b/man/testROH.numeric.Rd
@@ -0,0 +1,48 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% testROH.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{testROH.numeric}
+\alias{testROH.numeric}
+
+\title{Tests if a segment is in Run-of-Homozygosity (ROH)}
+
+\description{
+ Tests if a segment is in Run-of-Homozygosity (ROH).
+}
+
+\usage{
+\method{testROH}{numeric}(muN, csN=NULL, betaN=NULL, minNbrOfSnps=1, delta=1/12, ..., verbose=FALSE)
+}
+
+\arguments{
+ \item{muN}{An \code{\link[base]{numeric}} \code{\link[base]{vector}} of J genotype calls in
+ \{0,1/2,1\} for AA, AB, and BB, respectively,
+ and \code{\link[base]{NA}} for non-polymorphic loci.}
+ \item{csN}{(optional) A \code{\link[base]{numeric}} \code{\link[base]{vector}} of J genotype confidence scores.
+ If \code{\link[base]{NULL}}, ad hoc scores calculated from \code{betaN} are used.}
+ \item{betaN}{(optional) A \code{\link[base]{numeric}} \code{\link[base]{vector}} of J matched normal BAFs
+ in [0,1] (due to noise, values may be slightly outside as well)
+ or \code{\link[base]{NA}} for non-polymorphic loci.}
+ \item{minNbrOfSnps}{Minimum number of SNPs required to test segment.
+ If not tested, \code{\link[base]{NA}} is returned.}
+ \item{delta}{A \code{\link[base]{double}} scalar specifying the maximum (weighted)
+ proportion of heterozygous SNPs allowed in an ROH region.}
+ \item{...}{Not used.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns a \code{\link[base]{logical}}.
+}
+
+\author{Pierre Neuvial, Henrik Bengtsson}
+
+
+\keyword{methods}
+\keyword{internal}
diff --git a/man/updateMeans.AbstractCBS.Rd b/man/updateMeans.AbstractCBS.Rd
new file mode 100644
index 0000000..9d6a256
--- /dev/null
+++ b/man/updateMeans.AbstractCBS.Rd
@@ -0,0 +1,40 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{updateMeans.AbstractCBS}
+\alias{updateMeans.AbstractCBS}
+\alias{AbstractCBS.updateMeans}
+\alias{updateMeans,AbstractCBS-method}
+\alias{updateMeans.CBS}
+\alias{updateMeans.NonPairedPSCBS}
+\alias{updateMeans.PairedPSCBS}
+
+\title{Updates the CN mean levels for each segment independently}
+
+\description{
+ Updates the CN mean levels for each segment independently as if they were one large segment.
+ The locus-level data is not updated/modified.
+}
+
+\usage{
+\method{updateMeans}{AbstractCBS}(...)
+}
+
+\arguments{
+ \item{...}{Arguments specific to the class.}
+}
+
+\value{
+ Returns an object of the same class.
+}
+
+\author{Henrik Bengtsson}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/updateMeansTogether.AbstractCBS.Rd b/man/updateMeansTogether.AbstractCBS.Rd
new file mode 100644
index 0000000..d30eaf7
--- /dev/null
+++ b/man/updateMeansTogether.AbstractCBS.Rd
@@ -0,0 +1,48 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% AbstractCBS.HCLUST.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{updateMeansTogether.AbstractCBS}
+\alias{updateMeansTogether.AbstractCBS}
+\alias{AbstractCBS.updateMeansTogether}
+\alias{updateMeansTogether,AbstractCBS-method}
+\alias{updateMeansTogether.CBS}
+\alias{updateMeansTogether.PairedPSCBS}
+
+\title{Updates the CN mean levels jointly in sets of segments}
+
+\description{
+ Updates the CN mean levels jointly in sets of segments as if they were one large segment.
+ The locus-level data is not updated/modified.
+}
+
+\usage{
+\method{updateMeansTogether}{AbstractCBS}(...)
+}
+
+\arguments{
+ \item{idxList}{A \code{\link[base]{list}}, where each element is an \code{\link[base]{integer}} \code{\link[base]{vector}}
+ specifying segment indices of segments for which the mean levels
+ should be calculated jointly.}
+ \item{...}{Not used.}
+ \item{verbose}{See \code{\link[R.utils]{Verbose}}.}
+}
+
+\value{
+ Returns an object of the same class.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ This method is utilized by \code{\link[PSCBS:pruneByHClust.AbstractCBS]{*pruneByHClust}()}.
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/weightedQuantile.Rd b/man/weightedQuantile.Rd
new file mode 100644
index 0000000..4e6a137
--- /dev/null
+++ b/man/weightedQuantile.Rd
@@ -0,0 +1,60 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% weightedQuantile.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\name{weightedQuantile}
+\alias{weightedQuantile.default}
+\alias{weightedQuantile}
+
+\title{Weighted Quantile Value}
+
+\usage{
+\method{weightedQuantile}{default}(x, w, probs=c(0, 0.25, 0.5, 0.75, 1), na.rm=TRUE,
+ method=c("wtd.quantile"), ...)
+}
+
+\description{
+ Computes a weighted quantile of a numeric vector.
+}
+
+\arguments{
+ \item{x}{a \code{\link[base]{numeric}} \code{\link[base]{vector}} containing the values whose weighted
+ quantile is to be computed.}
+ \item{w}{a numeric \code{\link[base]{vector}} of weights the same length as
+ \code{x} giving the weights to use for each element of \code{x}.
+ Negative weights are treated as zero weights.
+ Default value is equal weight to all values.}
+ \item{probs}{a \code{\link[base]{numeric}} \code{\link[base]{vector}} of quantiles in [0,1] to be retrieved.}
+ \item{na.rm}{a \code{\link[base]{logical}} value indicating whether \code{\link[base]{NA}} values in
+ \code{x} should be stripped before the computation proceeds,
+ or not.}
+ \item{method}{If \code{"wtd.quantile"}, then \code{\link[Hmisc]{wtd.quantile}}
+ of the \pkg{Hmisc} package is used.
+ No other methods are currently supported.}
+ \item{...}{Additional arguments passed to the estimator.}
+}
+
+\value{
+ Returns the weighted quantile.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Internally the following functions may be used:
+ \code{\link[stats]{quantile}} (if no weights are specified), or
+ \code{\link[Hmisc]{wtd.quantile}}.
+ For a weighted median estimator, \code{\link[matrixStats]{weightedMedian}}
+ of the \pkg{matrixStats} package.
+}
+
+
+
+
+\keyword{univar}
+\keyword{robust}
+\keyword{internal}
diff --git a/man/writeSegments.CBS.Rd b/man/writeSegments.CBS.Rd
new file mode 100644
index 0000000..32517b4
--- /dev/null
+++ b/man/writeSegments.CBS.Rd
@@ -0,0 +1,54 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% CBS.IO.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+\name{writeSegments.CBS}
+\alias{writeSegments.CBS}
+\alias{CBS.writeSegments}
+\alias{writeSegments,CBS-method}
+\alias{writeWIG}
+\alias{writeWIG.AbstractCBS}
+
+\title{Writes the table of segments to file}
+
+\description{
+ Writes the table of segments to file.
+}
+
+\usage{
+\method{writeSegments}{CBS}(fit, name=getSampleName(fit), tags=NULL, ext="tsv", path=NULL,
+ addHeader=TRUE, createdBy=NULL, sep="\t", nbrOfDecimals=4L, splitters=FALSE,
+ overwrite=FALSE, skip=FALSE, ...)
+}
+
+\arguments{
+ \item{name, tags}{Name and optional tags part of the filename}.
+ \item{path}{The directory where the file will be written.}
+ \item{addHeader}{If \code{\link[base:logical]{TRUE}}, header comments are written.}
+ \item{createdBy}{A header comment of whom created the file.}
+ \item{splitters}{If \code{\link[base:logical]{TRUE}}, each chromosome is separated by a row
+ of missing values.}
+ \item{overwrite, skip}{If an output file already exists, these
+ arguments specifies what should happen.}
+ \item{...}{Additional arguments pass to \code{getSegments()}.}
+}
+
+\value{
+ Returns the pathname of the the file written.
+}
+
+\author{Henrik Bengtsson}
+
+\seealso{
+ Utilizes \code{\link[PSCBS:getSegments.CBS]{*getSegments}()}.
+ For more information see \code{\link{CBS}}..
+}
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/man/writeSegments.PSCBS.Rd b/man/writeSegments.PSCBS.Rd
new file mode 100644
index 0000000..3e759d8
--- /dev/null
+++ b/man/writeSegments.PSCBS.Rd
@@ -0,0 +1,52 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Do not modify this file since it was automatically generated from:
+%
+% PSCBS.IO.R
+%
+% by the Rdoc compiler part of the R.oo package.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+ \name{writeSegments.PSCBS}
+\alias{writeSegments.PSCBS}
+\alias{PSCBS.writeSegments}
+\alias{writeSegments,PSCBS-method}
+
+ \title{Writes the table of segments to file}
+
+ \description{
+ Writes the table of segments to file.
+ }
+
+ \usage{
+\method{writeSegments}{PSCBS}(fit, name=getSampleName(fit), tags=NULL, ext="tsv", path=NULL,
+ addHeader=TRUE, createdBy=NULL, sep="\t", nbrOfDecimals=4L, splitters=FALSE,
+ overwrite=FALSE, skip=FALSE, ...)
+}
+
+ \arguments{
+ \item{name, tags}{Name and optional tags part of the filename}.
+ \item{path}{The directory where the file will be written.}
+ \item{addHeader}{If \code{\link[base:logical]{TRUE}}, header comments are written.}
+ \item{createdBy}{A header comment of whom created the file.}
+ \item{splitters}{If \code{\link[base:logical]{TRUE}}, each chromosome is separated by a row
+ of missing values.}
+ \item{overwrite, skip}{If an output file already exists, these
+ arguments specifies what should happen.}
+ \item{...}{Additional arguments pass to \code{getSegments()}.}
+ }
+
+ \value{
+ Returns the pathname of the the file written.
+ }
+
+ \author{Henrik Bengtsson}
+
+ \seealso{
+ Utilizes \code{\link[PSCBS:getSegments.PSCBS]{*getSegments}()}.
+ For more information see \code{\link{PSCBS}}..
+ }
+
+
+\keyword{internal}
+\keyword{methods}
diff --git a/tests/PairedPSCBS,boot.R b/tests/PairedPSCBS,boot.R
new file mode 100644
index 0000000..176633a
--- /dev/null
+++ b/tests/PairedPSCBS,boot.R
@@ -0,0 +1,93 @@
+###########################################################
+# This tests:
+# - Bootstrapping for PairedPSCBS objects
+###########################################################
+library("PSCBS")
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Load SNP microarray data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+data <- PSCBS::exampleData("paired.chr01")
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Paired PSCBS segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Drop single-locus outliers
+dataS <- dropSegmentationOutliers(data)
+dataS <- dataS[seq(from=1, to=nrow(data), by=5),]
+nSegs <- 4L
+str(dataS)
+# Segment known regions
+knownSegments <- data.frame(
+ chromosome = c( 1, 1, 1),
+ start = c( -Inf, NA, 141510003),
+ end = c(120992603, NA, +Inf)
+)
+fit <- segmentByPairedPSCBS(dataS, knownSegments=knownSegments, avgDH="median", seed=0xBEEF)
+print(fit)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Bootstrap
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+B <- 1L
+seed <- 0xBEEF
+probs <- c(0.025, 0.05, 0.95, 0.975)
+
+sets <- getBootstrapLocusSets(fit, B=B, seed=seed)
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Subset by first segment
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ss <- 1L
+
+fitT <- extractSegment(fit, ss)
+dataT <- getLocusData(fitT)
+segsT <- getSegments(fitT)
+
+# Truth
+bootT <- bootstrapSegmentsAndChangepoints(fitT, B=B, seed=seed)
+bootT1 <- bootT$segments[1L,,,drop=FALSE]
+types <- dimnames(bootT1)[[3L]]
+dim(bootT1) <- dim(bootT1)[-1L]
+colnames(bootT1) <- types
+sumsT <- apply(bootT1, MARGIN=2L, FUN=quantile, probs=probs)
+print(sumsT)
+
+fitTB <- bootstrapTCNandDHByRegion(fitT, B=B, seed=seed)
+segsTB <- getSegments(fitTB)
+segsTB <- unlist(segsTB[,grep("_", colnames(segsTB))])
+dim(segsTB) <- dim(sumsT)
+dimnames(segsTB) <- dimnames(sumsT)
+print(segsTB)
+
+# Sanity check
+stopifnot(all.equal(segsTB, sumsT))
+
+# Calculate summaries using the existing bootstrap samples
+fitTBp <- bootstrapTCNandDHByRegion(fitT, .boot=bootT)
+# Sanity check
+all.equal(fitTBp, fitTB)
+
+
+# Bootstrap from scratch
+setsT <- getBootstrapLocusSets(fitT, B=B, seed=seed)
+lociT <- setsT$locusSet[[1L]]$bootstrap$loci
+idxs <- lociT$tcn
+tcnT <- array(dataT$CT[idxs], dim=dim(idxs))
+tcnT <- apply(tcnT, MARGIN=2L, FUN=mean, na.rm=TRUE)
+idxs <- lociT$dh
+dhT <- array(dataT$rho[idxs], dim=dim(idxs))
+dhT <- apply(dhT, MARGIN=2L, FUN=median, na.rm=TRUE)
+c1T <- (1-dhT) * tcnT / 2
+c2T <- tcnT - c1T
+bootT2 <- array(c(tcnT, dhT, c1T, c2T), dim=c(1L, 4L))
+colnames(bootT2) <- colnames(bootT1)
+print(bootT2)
+
+# This comparison is only valid if B == 1L
+if (B == 1L) {
+ # Sanity check
+ stopifnot(all.equal(bootT2, bootT1))
+}
diff --git a/tests/PairedPSCBS,plot.R.HIDE b/tests/PairedPSCBS,plot.R.HIDE
new file mode 100644
index 0000000..6fd8712
--- /dev/null
+++ b/tests/PairedPSCBS,plot.R.HIDE
@@ -0,0 +1,31 @@
+###########################################################
+# This tests:
+# - segmentByCBS(...)
+# - segmentByCBS(..., knownSegments)
+# - tileChromosomes()
+# - plotTracks()
+###########################################################
+library("PSCBS")
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Load SNP microarray data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+data <- PSCBS::exampleData("paired.chr01")
+
+## Setup basic data
+CT <- data$CT/data$CN
+muN <- callNaiveGenotypes(data$betaN, censorAt=c(0,1))
+isSnp <- (!is.na(data$betaT) & !is.na(data$muN))
+isHet <- isSnp & (data$muN == 1/2)
+rho <- rep(NA_real_, length=nrow(data))
+rho[isHet] <- 2*abs(data$betaTN[isHet]-1/2)
+
+data <- cbind(data[,c("chromosome", "x")], CT=CT, rho=rho)
+segs <- data.frame(chromosome=sort(unique(data$chromosome)))
+fit <- structure(list(data=data, output=segs), class=c("PairedPSCBS", "PSCBS", "AbstractCBS", class(data)))
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Paired PSCBS segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Drop single-locus outliers
+dataS <- dropSegmentationOutliers(data)
diff --git a/tests/findLargeGaps.R b/tests/findLargeGaps.R
new file mode 100644
index 0000000..655e646
--- /dev/null
+++ b/tests/findLargeGaps.R
@@ -0,0 +1,68 @@
+library("PSCBS")
+
+# Simulating copy-number data
+set.seed(0xBEEF)
+
+# Simulate CN data
+J <- 1000
+mu <- double(J)
+mu[200:300] <- mu[200:300] + 1
+mu[350:400] <- NA # centromere
+mu[650:800] <- mu[650:800] - 1
+eps <- rnorm(J, sd=1/2)
+y <- mu + eps
+x <- seq(from=1, to=100e6, length.out=J)
+
+data <- data.frame(chromosome=0L, x=x)
+
+gaps <- findLargeGaps(x=x, minLength=1e6)
+print(gaps)
+stopifnot(is.data.frame(gaps))
+stopifnot(nrow(gaps) == 0L)
+segs <- gapsToSegments(gaps)
+print(segs)
+stopifnot(is.data.frame(segs))
+stopifnot(nrow(segs) == 1L)
+
+
+gaps <- findLargeGaps(data, minLength=1e6)
+print(gaps)
+stopifnot(is.data.frame(gaps))
+stopifnot(nrow(gaps) == 0L)
+segs <- gapsToSegments(gaps)
+print(segs)
+stopifnot(is.data.frame(segs))
+stopifnot(nrow(segs) == 1L)
+
+
+## Add missing values
+data2 <- data
+data$x[30e6 < x & x < 50e6] <- NA
+gaps <- findLargeGaps(data, minLength=1e6)
+print(gaps)
+stopifnot(is.data.frame(gaps))
+stopifnot(nrow(gaps) == 1L)
+segs <- gapsToSegments(gaps)
+print(segs)
+stopifnot(is.data.frame(segs))
+stopifnot(nrow(segs) == 3L)
+
+
+
+# BUG FIX: Issue #6
+gaps <- findLargeGaps(chromosome=rep(1,10), x=1:10, minLength=2)
+print(gaps)
+stopifnot(is.data.frame(gaps))
+stopifnot(nrow(gaps) == 0L)
+# BUG FIX: Issue #9
+segs <- gapsToSegments(gaps)
+print(segs)
+stopifnot(is.data.frame(segs))
+stopifnot(nrow(segs) == 1L)
+
+
+# BUG FIX: PSCBS GitHub Issue #8
+gaps <- try({
+ findLargeGaps(chromosome=rep(1,3), x=as.numeric(1:3), minLength=1)
+})
+stopifnot(inherits(gaps, "try-error"))
diff --git a/tests/randomSeed.R b/tests/randomSeed.R
new file mode 100644
index 0000000..3c48995
--- /dev/null
+++ b/tests/randomSeed.R
@@ -0,0 +1,151 @@
+library("PSCBS")
+
+message("*** randomSeed() - setup ...")
+ovars <- ls(envir=globalenv())
+genv <- globalenv()
+RNGkind("Mersenne-Twister")
+if (exists(".Random.seed", envir=genv, inherits=FALSE))
+ rm(list=".Random.seed", envir=genv, inherits=FALSE)
+seed0 <- genv$.Random.seed
+stopifnot(is.null(seed0))
+okind0 <- RNGkind()[1L]
+
+sample1 <- function() { sample(0:9, size=1L) }
+message("*** randomSeed() - setup ... done")
+
+
+message("*** randomSeed('get') ...")
+## Get random seed
+seed <- randomSeed("get")
+stopifnot(identical(seed, seed0))
+
+## Repeat after new sample
+y1 <- sample1()
+message(sprintf("Random number: %d", y1))
+seed1 <- randomSeed("get")
+stopifnot(!identical(seed1, seed0))
+message("*** randomSeed('get') ... done")
+
+
+message("*** randomSeed('set', 42L) ...")
+randomSeed("set", seed=42L)
+seed2 <- randomSeed("get")
+stopifnot(!identical(seed2, seed1))
+
+y2 <- sample1()
+message(sprintf("Random number: %d (with random seed = 42L)", y2))
+
+## Reset to previous state
+randomSeed("reset")
+seed3 <- randomSeed("get")
+stopifnot(identical(seed3, seed1))
+stopifnot(identical(RNGkind()[1L], okind0),
+ identical(randomSeed("get"), seed1))
+message("*** randomSeed('set', 42L) ... done")
+
+
+message("*** randomSeed('set', NULL) ...")
+randomSeed("set", seed=NULL)
+seed4 <- randomSeed("get")
+stopifnot(is.null(seed4))
+
+y3 <- sample1()
+message(sprintf("Random number: %d", y3))
+
+message("*** randomSeed('set', NULL) ... done")
+
+
+message("*** randomSeed('set', 42L) again ...")
+seed5 <- randomSeed("get")
+randomSeed("set", seed=42L)
+y4 <- sample1()
+message(sprintf("Random number: %d (with random seed = 42L)", y4))
+stopifnot(identical(y4, y2))
+
+randomSeed("reset")
+stopifnot(identical(RNGkind()[1L], okind0),
+ identical(randomSeed("get"), seed5))
+message("*** randomSeed('set', 42L) again ... done")
+
+
+
+## L'Ecuyer-CMRG: Random number generation for parallel processing
+message("*** randomSeed(): L'Ecuyer-CMRG stream ...")
+
+okind <- RNGkind()[1L]
+stopifnot(identical(okind, okind0))
+
+randomSeed("set", seed=NULL)
+oseed <- randomSeed("get")
+stopifnot(is.null(oseed))
+
+randomSeed("set", seed=42L, kind="L'Ecuyer-CMRG")
+oseed2 <- randomSeed("reset")
+str(oseed2)
+stopifnot(identical(oseed2, oseed))
+stopifnot(identical(RNGkind()[1L], okind),
+ identical(randomSeed("get"), oseed))
+
+randomSeed("set", seed=42L, kind="L'Ecuyer-CMRG")
+seed0 <- randomSeed("get")
+seeds0 <- lapply(1:10, FUN=function(i) randomSeed("advance"))
+oseed2 <- randomSeed("reset")
+stopifnot(identical(oseed2, oseed))
+stopifnot(identical(RNGkind()[1L], okind),
+ identical(randomSeed("get"), oseed))
+
+
+## Assert reproducible .Random.seed stream
+randomSeed("set", seed=42L, kind="L'Ecuyer-CMRG")
+seed1 <- randomSeed("get")
+seeds1 <- lapply(1:10, FUN=function(i) randomSeed("advance"))
+stopifnot(identical(seed1, seed0))
+stopifnot(identical(seeds1, seeds0))
+
+randomSeed("reset")
+stopifnot(identical(RNGkind()[1L], okind),
+ identical(randomSeed("get"), oseed))
+
+randomSeed("set", seed=42L, kind="L'Ecuyer-CMRG")
+seeds2 <- randomSeed("advance", n=10L)
+stopifnot(identical(seeds2, seeds0))
+
+randomSeed("reset")
+stopifnot(identical(RNGkind()[1L], okind),
+ identical(randomSeed("get"), oseed))
+
+randomSeed("set", seed=seeds2[[1]], kind="L'Ecuyer-CMRG")
+randomSeed("reset")
+stopifnot(identical(RNGkind()[1L], okind),
+ identical(randomSeed("get"), oseed))
+
+randomSeed("set", seed=42L, kind="L'Ecuyer-CMRG")
+y0 <- sapply(1:10, FUN=function(ii) {
+ randomSeed("advance")
+ sample1()
+})
+print(y0)
+randomSeed("reset")
+
+randomSeed("set", seed=42L, kind="L'Ecuyer-CMRG")
+y1 <- sapply(1:10, FUN=function(ii) {
+ randomSeed("advance")
+ sample1()
+})
+print(y1)
+stopifnot(identical(y1, y0))
+randomSeed("reset")
+
+stopifnot(identical(RNGkind()[1L], okind))
+
+message("*** randomSeed(): L'Ecuyer-CMRG stream ... done")
+
+
+## Cleanup
+message("*** randomSeed() - cleanup ...")
+genv <- globalenv()
+RNGkind("Mersenne-Twister")
+if (exists(".Random.seed", envir=genv, inherits=FALSE))
+ rm(list=".Random.seed", envir=genv, inherits=FALSE)
+rm(list=ovars, envir=globalenv())
+message("*** randomSeed() - cleanup ... done")
diff --git a/tests/segmentByCBS,calls.R b/tests/segmentByCBS,calls.R
new file mode 100644
index 0000000..cf09a5f
--- /dev/null
+++ b/tests/segmentByCBS,calls.R
@@ -0,0 +1,63 @@
+# This test script calls a report generator which requires
+# the 'ggplot2' package, which in turn will require packages
+# 'colorspace', 'dichromat', 'munsell', 'reshape2' and 'scales'.
+
+# Only run this test in full testing mode
+if (Sys.getenv("_R_CHECK_FULL_") != "") {
+library("PSCBS")
+stext <- R.utils::stext
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Load SNP microarray data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+data <- PSCBS::exampleData("paired.chr01")
+str(data)
+
+data <- data.frame(chromosome=data$chromosome, x=data$x, y=data$CT)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# CBS segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Drop single-locus outliers
+dataS <- dropSegmentationOutliers(data)
+
+# Speed up example by segmenting fewer loci
+dataS <- dataS[seq(from=1, to=nrow(data), by=5),]
+
+str(dataS)
+
+gaps <- findLargeGaps(dataS, minLength=2e6)
+knownSegments <- gapsToSegments(gaps)
+
+# CBS segmentation
+fit <- segmentByCBS(dataS, knownSegments=knownSegments,
+ seed=0xBEEF, verbose=-10)
+signalType(fit) <- "ratio"
+plotTracks(fit)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Call using the UCSF MAD caller (not recommended)
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fitC <- callGainsAndLosses(fit)
+plotTracks(fitC)
+pars <- fitC$params$callGainsAndLosses
+stext(side=3, pos=1/2, line=-1, substitute(sigma==x, list(x=sprintf("%.2f", pars$sigmaMAD))))
+mu <- pars$muR
+tau <- unlist(pars[c("tauLoss", "tauGain")], use.names=FALSE)
+abline(h=mu, lty=2, lwd=2)
+abline(h=tau, lwd=2)
+mtext(side=4, at=tau[1], expression(Delta[LOSS]), adj=-0.2, cex=0.7, las=2, xpd=TRUE)
+mtext(side=4, at=tau[2], expression(Delta[GAIN]), adj=-0.2, cex=0.7, las=2, xpd=TRUE)
+title(main="CN caller: \"ucsf-mad\"")
+
+
+# Caller to be implemented
+deltaCN <- estimateDeltaCN(fit)
+tau <- mu + 1/2*c(-1,+1)*deltaCN
+abline(h=tau, lty=2, lwd=1, col="red")
+
+
+
+} # if (Sys.getenv("_R_CHECK_FULL_"))
diff --git a/tests/segmentByCBS,flavors.R.HIDE b/tests/segmentByCBS,flavors.R.HIDE
new file mode 100644
index 0000000..414e615
--- /dev/null
+++ b/tests/segmentByCBS,flavors.R.HIDE
@@ -0,0 +1,31 @@
+###########################################################
+# This tests:
+# - segmentByCBS(...)
+# - segmentByCBS(..., knownSegments)
+# - tileChromosomes()
+# - plotTracks()
+###########################################################
+library("PSCBS")
+subplots <- R.utils::subplots
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Simulating copy-number data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+set.seed(0xBEEF)
+
+# Number of loci
+J <- 1000
+
+mu <- double(J)
+mu[200:300] <- mu[200:300] + 1
+mu[650:800] <- mu[650:800] - 1
+eps <- rnorm(J, sd=1/2)
+y <- mu + eps
+x <- sort(runif(length(y), max=length(y))) * 1e5
+w <- runif(J)
+w[650:800] <- 0.001
+
+
+fit <- segmentByCBS(y, x=x, verbose=TRUE)
+print(fit)
+plotTracks(fit)
diff --git a/tests/segmentByCBS,futures.R b/tests/segmentByCBS,futures.R
new file mode 100644
index 0000000..0a457a8
--- /dev/null
+++ b/tests/segmentByCBS,futures.R
@@ -0,0 +1,89 @@
+library("PSCBS")
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Simulating copy-number data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+set.seed(0xBEEF)
+
+# Number of loci
+J <- 1000
+
+mu <- double(J)
+mu[200:300] <- mu[200:300] + 1
+mu[350:400] <- NA # centromere
+mu[650:800] <- mu[650:800] - 1
+eps <- rnorm(J, sd=1/2)
+y <- mu + eps
+x <- sort(runif(length(y), max=length(y))) * 1e5
+w <- runif(J)
+w[650:800] <- 0.001
+
+## Create multiple chromosomes
+data <- knownSegments <- list()
+for (cc in 1:3) {
+ data[[cc]] <- data.frame(chromosome=cc, y=y, x=x)
+ knownSegments[[cc]] <- data.frame(
+ chromosome=c( cc, cc, cc),
+ start =x[c( 1, 350, 401)],
+ end =x[c(349, 400, J)]
+ )
+}
+data <- Reduce(rbind, data)
+str(data)
+knownSegments <- Reduce(rbind, knownSegments)
+str(knownSegments)
+
+message("*** segmentByCBS() via futures ...")
+
+message("*** segmentByCBS() via 'lazy' futures without attaching 'future' ...")
+future::plan("lazy")
+print(future::plan)
+fitL <- segmentByCBS(data, seed=0xBEEF, verbose=TRUE)
+print(fitL)
+
+
+message("*** segmentByCBS() via futures with 'future' attached ...")
+library("future")
+oplan <- plan()
+
+strategies <- c("eager", "lazy")
+if (supportsMulticore()) strategies <- c(strategies, "multicore")
+
+## Test 'async' futures?
+pkg <- "async"
+if (require(pkg, character.only=TRUE)) {
+ backend("local")
+ strategies <- c(strategies, "batchjobs")
+}
+
+message("Future strategies to test: ", paste(sQuote(strategies), collapse=", "))
+
+fits <- list()
+for (strategy in strategies) {
+ message(sprintf("- segmentByCBS() using '%s' futures ...", strategy))
+ plan(strategy)
+ fit <- segmentByCBS(data, seed=0xBEEF, verbose=TRUE)
+ fits[[strategy]] <- fit
+ stopifnot(all.equal(fit, fits[[1]]))
+ stopifnot(all.equal(fit, fitL))
+}
+
+
+message("*** segmentByCBS() via futures with known segments ...")
+fits <- list()
+dataT <- subset(data, chromosome == 1)
+for (strategy in strategies) {
+ message(sprintf("- segmentByCBS() w/ known segments using '%s' futures ...", strategy))
+ plan(strategy)
+ fit <- segmentByCBS(dataT, knownSegments=knownSegments, seed=0xBEEF, verbose=TRUE)
+ fits[[strategy]] <- fit
+ stopifnot(all.equal(fit, fits[[1]]))
+}
+
+message("*** segmentByCBS() via futures ... DONE")
+
+
+## Cleanup
+plan(oplan)
+rm(list=c("fits", "dataT", "data", "fit"))
+
diff --git a/tests/segmentByCBS,median.R b/tests/segmentByCBS,median.R
new file mode 100644
index 0000000..8287db1
--- /dev/null
+++ b/tests/segmentByCBS,median.R
@@ -0,0 +1,118 @@
+library("PSCBS")
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Simulating copy-number data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+set.seed(0xBEEF)
+
+# Number of loci
+J <- 1000
+
+x <- sort(runif(J, max=J)) * 1e5
+
+mu <- double(J)
+mu[200:300] <- mu[200:300] + 1
+mu[350:400] <- NA # centromere
+mu[650:800] <- mu[650:800] - 1
+eps <- rnorm(J, sd=1/2)
+y <- mu + eps
+
+outliers <- seq(from=1L, to=J, length.out=0.2*J)
+y[outliers] <- y[outliers] + 1.5
+
+w <- rep(1.0, times=J)
+w[outliers] <- 0.01
+
+data <- data.frame(chromosome=1L, x=x, y=y)
+dataW <- cbind(data, w=w)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Single-chromosome segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+par(mar=c(2,3,0.2,1)+0.1)
+# Segment without weights
+fit <- segmentByCBS(data)
+sampleName(fit) <- "CBS_Example"
+print(fit)
+plotTracks(fit)
+## Highlight outliers (they pull up the mean levels)
+points(x[outliers]/1e6, y[outliers], col="purple")
+
+# Segment without weights but with median
+fitM <- segmentByCBS(data, avg="median")
+sampleName(fitM) <- "CBS_Example (median)"
+print(fitM)
+drawLevels(fitM, col="magenta", lty=3)
+
+# Segment with weights
+fitW <- segmentByCBS(dataW, avg="median")
+sampleName(fitW) <- "CBS_Example (weighted)"
+print(fitW)
+drawLevels(fitW, col="red")
+
+# Segment with weights and median
+fitWM <- segmentByCBS(dataW, avg="median")
+sampleName(fitWM) <- "CBS_Example (weighted median)"
+print(fitWM)
+drawLevels(fitWM, col="orange", lty=3)
+
+legend("topright", bg="white", legend=c("outliers", "non-weighted CBS (mean)", "non-weighted CBS (median)", "weighted CBS (mean)", "weighted CBS (median)"), col=c("purple", "purple", "magenta", "red", "orange"), lwd=c(NA,3,3,3,3), lty=c(NA,1,3,1,3), pch=c(1,NA,NA,NA,NA))
+
+## Assert that weighted segment means are less biased
+dmean <- getSegments(fit)$mean - getSegments(fitW)$mean
+cat("Segment mean differences:\n")
+print(dmean)
+stopifnot(all(dmean > 0, na.rm=TRUE))
+
+dmean <- getSegments(fitM)$mean - getSegments(fitWM)$mean
+cat("Segment median differences:\n")
+print(dmean)
+stopifnot(all(dmean > 0, na.rm=TRUE))
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Multi-chromosome segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+data2 <- data
+data2$chromosome <- 2L
+data <- rbind(data, data2)
+dataW <- cbind(data, w=w)
+
+par(mar=c(2,3,0.2,1)+0.1)
+# Segment without weights
+fit <- segmentByCBS(data)
+sampleName(fit) <- "CBS_Example"
+print(fit)
+plotTracks(fit, Clim=c(-3,3))
+
+# Segment without weights but with median
+fitM <- segmentByCBS(data, avg="median")
+sampleName(fitM) <- "CBS_Example (median)"
+print(fitM)
+drawLevels(fitM, col="magenta", lty=3)
+
+# Segment with weights
+fitW <- segmentByCBS(dataW, avg="median")
+sampleName(fitW) <- "CBS_Example (weighted)"
+print(fitW)
+drawLevels(fitW, col="red")
+
+# Segment with weights and median
+fitWM <- segmentByCBS(dataW, avg="median")
+sampleName(fitWM) <- "CBS_Example (weighted median)"
+print(fitWM)
+drawLevels(fitWM, col="orange", lty=3)
+
+legend("topright", bg="white", legend=c("outliers", "non-weighted CBS (mean)", "non-weighted CBS (median)", "weighted CBS (mean)", "weighted CBS (median)"), col=c("purple", "purple", "magenta", "red", "orange"), lwd=c(NA,3,3,3,3), lty=c(NA,1,3,1,3), pch=c(1,NA,NA,NA,NA))
+
+## Assert that weighted segment means are less biased
+dmean <- getSegments(fit)$mean - getSegments(fitW)$mean
+cat("Segment mean differences:\n")
+print(dmean)
+stopifnot(all(dmean > 0, na.rm=TRUE))
+
+dmean <- getSegments(fitM)$mean - getSegments(fitWM)$mean
+cat("Segment median differences:\n")
+print(dmean)
+stopifnot(all(dmean > 0, na.rm=TRUE))
diff --git a/tests/segmentByCBS,prune.R b/tests/segmentByCBS,prune.R
new file mode 100644
index 0000000..4c4fc44
--- /dev/null
+++ b/tests/segmentByCBS,prune.R
@@ -0,0 +1,58 @@
+library("PSCBS")
+
+## Compare segments
+assertMatchingSegments <- function(fitM, fit) {
+ chrs <- getChromosomes(fitM)
+ segsM <- lapply(chrs, FUN=function(chr) {
+ getSegments(extractChromosome(fitM, chr))
+ })
+ segs <- lapply(fit[chrs], FUN=getSegments)
+ stopifnot(all.equal(segsM, segs, check.attributes=FALSE))
+}
+
+## Simulate data
+set.seed(0xBEEF)
+J <- 1000
+mu <- double(J)
+mu[200:300] <- mu[200:300] + 1
+mu[350:400] <- NA
+mu[650:800] <- mu[650:800] - 1
+eps <- rnorm(J, sd=1/2)
+y <- mu + eps
+x <- sort(runif(length(y), max=length(y))) * 1e5
+
+data <- list()
+for (chr in 1:2) {
+ data[[chr]] <- data.frame(chromosome=chr, x=x, y=y)
+}
+data$M <- Reduce(rbind, data)
+
+## Segment
+message("*** segmentByCBS()")
+fit <- lapply(data, FUN=segmentByCBS)
+print(fit)
+assertMatchingSegments(fit$M, fit)
+
+## Join segments
+message("*** joinSegments()")
+fitj <- lapply(fit, FUN=joinSegments)
+print(fitj)
+assertMatchingSegments(fitj$M, fitj)
+
+## Reset segments
+message("*** resetSegments()")
+fitj <- lapply(fit, FUN=resetSegments)
+print(fitj)
+assertMatchingSegments(fitj$M, fitj)
+
+## Prune by SD undo
+message("*** pruneBySdUndo()")
+fitp <- lapply(fit, FUN=pruneBySdUndo)
+print(fitp)
+assertMatchingSegments(fitp$M, fitp)
+
+## Prune by hierarchical clustering
+message("*** pruneByHClust()")
+fitp <- lapply(fit, FUN=pruneByHClust, k=1L)
+print(fitp)
+assertMatchingSegments(fitp$M, fitp)
diff --git a/tests/segmentByCBS,report.R b/tests/segmentByCBS,report.R
new file mode 100644
index 0000000..a73e63a
--- /dev/null
+++ b/tests/segmentByCBS,report.R
@@ -0,0 +1,44 @@
+# This test script calls a report generator which requires
+# the 'ggplot2' package, which in turn will require packages
+# 'colorspace', 'dichromat', 'munsell', 'reshape2' and 'scales'.
+
+# Only run this test in full testing mode
+if (Sys.getenv("_R_CHECK_FULL_") != "") {
+library("PSCBS")
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Load SNP microarray data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+data <- PSCBS::exampleData("paired.chr01")
+str(data)
+
+data <- data.frame(chromosome=data$chromosome, x=data$x, y=data$CT)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# CBS segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Drop single-locus outliers
+dataS <- dropSegmentationOutliers(data)
+
+# Speed up example by segmenting fewer loci
+dataS <- dataS[seq(from=1, to=nrow(data), by=5),]
+
+str(dataS)
+
+gaps <- findLargeGaps(dataS, minLength=2e6)
+knownSegments <- gapsToSegments(gaps)
+
+# CBS segmentation
+fit <- segmentByCBS(dataS, knownSegments=knownSegments,
+ seed=0xBEEF, verbose=-10)
+signalType(fit) <- "ratio"
+
+# Fake a multi-chromosome segmentation
+fit1 <- fit
+fit2 <- renameChromosomes(fit, from=1, to=2)
+fit <- append(fit1, fit2)
+
+report(fit, sampleName="CBS", studyName="CBS-Ex", verbose=-10)
+
+} # if (Sys.getenv("_R_CHECK_FULL_"))
diff --git a/tests/segmentByCBS,shiftTCN.R b/tests/segmentByCBS,shiftTCN.R
new file mode 100644
index 0000000..5bf0a71
--- /dev/null
+++ b/tests/segmentByCBS,shiftTCN.R
@@ -0,0 +1,113 @@
+library("PSCBS")
+subplots <- R.utils::subplots
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Simulating copy-number data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+set.seed(0xBEEF)
+
+# Number of loci
+J <- 1000
+
+mu <- double(J)
+eps <- rnorm(J, sd=1/2)
+y <- mu + eps
+x <- sort(runif(length(y), max=length(y)))
+
+idxs <- which(200 <= x & x < 300)
+y[idxs] <- y[idxs] + 1
+idxs <- which(350 <= x & x < 400)
+y[idxs] <- NA # centromere
+x[idxs] <- NA # centromere
+idxs <- which(650 <= x & x < 800)
+y[idxs] <- y[idxs] - 1
+x <- x*1e5
+
+keep <- is.finite(x)
+x <- x[keep]
+y <- y[keep]
+
+data <- list()
+for (chr in 1:2) {
+ data[[chr]] <- data.frame(chromosome=chr, y=y, x=x)
+}
+data <- Reduce(rbind, data)
+
+
+subplots(7, ncol=1)
+par(mar=c(1.7,1,0.2,1)+0.1)
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- segmentByCBS(data)
+print(fit)
+
+Clim <- c(-3,3) + c(0,10)
+plotTracks(fit, Clim=Clim)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Shifting every other chromosome
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fitList <- list()
+chrs <- getChromosomes(fit)
+for (kk in seq(along=chrs)) {
+ chr <- chrs[kk]
+ fitKK <- extractChromosome(fit, chr)
+ if (kk %% 2 == 0) {
+ fitKK <- shiftTCN(fitKK, shift=+10)
+ }
+ fitList[[kk]] <- fitKK
+} # for (kk ...)
+fitT <- Reduce(append, fitList)
+# Sanity check
+stopifnot(nbrOfSegments(fitT) == nbrOfSegments(fit))
+
+plotTracks(fitT, Clim=Clim)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Shifting every other known segment
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+gaps <- findLargeGaps(data, minLength=40e5)
+knownSegments <- gapsToSegments(gaps, dropGaps=TRUE)
+fit <- segmentByCBS(data, knownSegments=knownSegments)
+
+subplots(2, ncol=1)
+plotTracks(fit, Clim=Clim)
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+
+fitList <- list()
+for (kk in seq(length=nrow(knownSegments))) {
+ seg <- knownSegments[kk,]
+ start <- seg$start
+ end <- seg$end
+ fitKK <- extractChromosome(fit, seg$chromosome)
+ segsKK <- getSegments(fitKK)
+ idxStart <- min(which(segsKK$start >= start))
+ idxEnd <- max(which(segsKK$end <= end))
+ idxs <- idxStart:idxEnd
+ fitKK <- extractSegments(fitKK, idxs)
+ if (kk %% 2 == 0) {
+ fitKK <- shiftTCN(fitKK, shift=+10)
+ }
+ fitList[[kk]] <- fitKK
+} # for (kk ...)
+fitT <- Reduce(append, fitList)
+# Sanity check
+stopifnot(nbrOfSegments(fitT) == nbrOfSegments(fit))
+
+plotTracks(fitT, Clim=Clim)
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+
+
+segList <- seqOfSegmentsByDP(fit);
+K <- length(segList);
+subplots(K, ncol=2, byrow=FALSE);
+par(mar=c(2,1,1,1));
+for (kk in 1:K) {
+ knownSegments <- segList[[kk]];
+ fitKK <- resegment(fit, knownSegments=knownSegments, undo=+Inf);
+ plotTracks(fitKK, Clim=c(-3,3));
+} # for (kk ...)
diff --git a/tests/segmentByCBS,weights.R b/tests/segmentByCBS,weights.R
new file mode 100644
index 0000000..c3b4aa6
--- /dev/null
+++ b/tests/segmentByCBS,weights.R
@@ -0,0 +1,165 @@
+library("PSCBS")
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Simulating copy-number data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+set.seed(0xBEEF)
+
+# Number of loci
+J <- 1000
+
+x <- sort(runif(J, max=J)) * 1e5
+
+mu <- double(J)
+mu[200:300] <- mu[200:300] + 1
+mu[350:400] <- NA # centromere
+mu[650:800] <- mu[650:800] - 1
+eps <- rnorm(J, sd=1/2)
+y <- mu + eps
+
+outliers <- seq(from=1L, to=J, length.out=0.2*J)
+y[outliers] <- y[outliers] + 1.5
+
+w <- rep(1.0, times=J)
+w[outliers] <- 0.01
+
+data <- data.frame(chromosome=1L, x=x, y=y)
+dataW <- cbind(data, w=w)
+
+
+par(mar=c(2,3,0.2,1)+0.1)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Single-chromosome segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Segment without weights
+fit <- segmentByCBS(data)
+sampleName(fit) <- "CBS_Example"
+print(fit)
+plotTracks(fit)
+## Highlight outliers (they pull up the mean levels)
+points(x[outliers]/1e6, y[outliers], col="purple")
+
+# Segment with weights
+fitW <- segmentByCBS(dataW)
+sampleName(fitW) <- "CBS_Example (weighted)"
+print(fitW)
+drawLevels(fitW, col="red")
+
+legend("topright", bg="white", legend=c("outliers", "non-weighted CBS", "weighted CBS"), col=c("purple", "purple", "red"), lwd=c(NA,3,3), pch=c(1,NA,NA))
+
+## Assert that weighted segment means are less biased
+dmean <- getSegments(fit)$mean - getSegments(fitW)$mean
+cat("Segment mean differences:\n")
+print(dmean)
+stopifnot(all(dmean > 0, na.rm=TRUE))
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Segmentation with some known change points
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+knownSegments <- data.frame(
+ chromosome=c( 1, 1),
+ start =x[c( 1, 401)],
+ end =x[c(349, J)]
+)
+fit2 <- segmentByCBS(dataW, knownSegments=knownSegments, verbose=TRUE)
+sampleName(fit2) <- "CBS_Example_2 (weighted)"
+print(fit2)
+plotTracks(fit2)
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+
+
+# Chromosome boundaries can be specified as -Inf and +Inf
+knownSegments <- data.frame(
+ chromosome=c( 1, 1),
+ start =c( -Inf, x[401]),
+ end =c(x[349], +Inf)
+)
+fit2b <- segmentByCBS(dataW, knownSegments=knownSegments, verbose=TRUE)
+sampleName(fit2b) <- "CBS_Example_2b (weighted)"
+print(fit2b)
+plotTracks(fit2b)
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+
+
+# As a proof of concept, it is possible to segment just the centromere,
+# which contains no data. All statistics will be NAs.
+knownSegments <- data.frame(
+ chromosome=c( 1),
+ start =x[c(350)],
+ end =x[c(400)]
+)
+fit3 <- segmentByCBS(dataW, knownSegments=knownSegments, verbose=TRUE)
+sampleName(fit3) <- "CBS_Example_3"
+print(fit3)
+plotTracks(fit3, Clim=c(0,5), xlim=c(0,100))
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+
+
+# If one specify the (empty) centromere as a segment, then its
+# estimated statistics will be NAs, which becomes a natural
+# separator between the two "independent" arms.
+knownSegments <- data.frame(
+ chromosome=c( 1, 1, 1),
+ start =x[c( 1, 350, 401)],
+ end =x[c(349, 400, J)]
+)
+fit4 <- segmentByCBS(dataW, knownSegments=knownSegments, verbose=TRUE)
+sampleName(fit4) <- "CBS_Example_4"
+print(fit4)
+plotTracks(fit4)
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+
+
+fit5 <- segmentByCBS(dataW, knownSegments=knownSegments, undo=Inf, verbose=TRUE)
+sampleName(fit5) <- "CBS_Example_5"
+print(fit5)
+plotTracks(fit5)
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+stopifnot(nbrOfSegments(fit5) == nrow(knownSegments))
+
+
+# One can also force a separator between two segments by setting
+# 'start' and 'end' to NAs ('chromosome' has to be given)
+knownSegments <- data.frame(
+ chromosome=c( 1, 1, 1),
+ start =x[c( 1, NA, 401)],
+ end =x[c(349, NA, J)]
+)
+fit6 <- segmentByCBS(dataW, knownSegments=knownSegments, verbose=TRUE)
+sampleName(fit6) <- "CBS_Example_6"
+print(fit6)
+plotTracks(fit6)
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Multi-chromosome segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+data2 <- data
+data2$chromosome <- 2L
+data <- rbind(data, data2)
+dataW <- cbind(data, w=w)
+
+par(mar=c(2,3,0.2,1)+0.1)
+# Segment without weights
+fit <- segmentByCBS(data)
+sampleName(fit) <- "CBS_Example"
+print(fit)
+plotTracks(fit, Clim=c(-3,3))
+
+# Segment with weights
+fitW <- segmentByCBS(dataW)
+sampleName(fitW) <- "CBS_Example (weighted)"
+print(fitW)
+drawLevels(fitW, col="red")
+
+legend("topright", bg="white", legend=c("outliers", "non-weighted CBS", "weighted CBS"), col=c("purple", "purple", "red"), lwd=c(NA,3,3), pch=c(1,NA,NA))
+
+## Assert that weighted segment means are less biased
+dmean <- getSegments(fit)$mean - getSegments(fitW)$mean
+cat("Segment mean differences:\n")
+print(dmean)
+stopifnot(all(dmean > 0, na.rm=TRUE))
diff --git a/tests/segmentByCBS.R b/tests/segmentByCBS.R
new file mode 100644
index 0000000..296352c
--- /dev/null
+++ b/tests/segmentByCBS.R
@@ -0,0 +1,158 @@
+###########################################################
+# This tests:
+# - segmentByCBS(...)
+# - segmentByCBS(..., knownSegments)
+# - tileChromosomes()
+# - plotTracks()
+###########################################################
+library("PSCBS")
+subplots <- R.utils::subplots
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Simulating copy-number data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+set.seed(0xBEEF)
+
+# Number of loci
+J <- 1000
+
+mu <- double(J)
+mu[200:300] <- mu[200:300] + 1
+mu[350:400] <- NA # centromere
+mu[650:800] <- mu[650:800] - 1
+eps <- rnorm(J, sd=1/2)
+y <- mu + eps
+x <- sort(runif(length(y), max=length(y))) * 1e5
+w <- runif(J)
+w[650:800] <- 0.001
+
+
+subplots(8, ncol=1L)
+par(mar=c(1.7,1,0.2,1)+0.1)
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- segmentByCBS(y, x=x)
+sampleName(fit) <- "CBS_Example"
+print(fit)
+plotTracks(fit)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Segmentation with some known change points
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+knownSegments <- data.frame(
+ chromosome=c( 0, 0),
+ start =x[c( 1, 401)],
+ end =x[c(349, J)]
+)
+fit2 <- segmentByCBS(y, x=x, knownSegments=knownSegments, verbose=TRUE)
+sampleName(fit2) <- "CBS_Example_2"
+print(fit2)
+plotTracks(fit2)
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+
+
+# Chromosome boundaries can be specified as -Inf and +Inf
+knownSegments <- data.frame(
+ chromosome=c( 0, 0),
+ start =c( -Inf, x[401]),
+ end =c(x[349], +Inf)
+)
+fit2b <- segmentByCBS(y, x=x, knownSegments=knownSegments, verbose=TRUE)
+sampleName(fit2b) <- "CBS_Example_2b"
+print(fit2b)
+plotTracks(fit2b)
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+
+
+# As a proof of concept, it is possible to segment just the centromere,
+# which contains no data. All statistics will be NAs.
+knownSegments <- data.frame(
+ chromosome=c( 0),
+ start =x[c(350)],
+ end =x[c(400)]
+)
+fit3 <- segmentByCBS(y, x=x, knownSegments=knownSegments, verbose=TRUE)
+sampleName(fit3) <- "CBS_Example_3"
+print(fit3)
+plotTracks(fit3, Clim=c(0,5), xlim=c(0,100))
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+
+
+
+# If one specify the (empty) centromere as a segment, then its
+# estimated statistics will be NAs, which becomes a natural
+# separator between the two "independent" arms.
+knownSegments <- data.frame(
+ chromosome=c( 0, 0, 0),
+ start =x[c( 1, 350, 401)],
+ end =x[c(349, 400, J)]
+)
+fit4 <- segmentByCBS(y, x=x, knownSegments=knownSegments, verbose=TRUE)
+sampleName(fit4) <- "CBS_Example_4"
+print(fit4)
+plotTracks(fit4)
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+
+
+
+fit5 <- segmentByCBS(y, x=x, knownSegments=knownSegments, undo=Inf, verbose=TRUE)
+sampleName(fit5) <- "CBS_Example_5"
+print(fit5)
+plotTracks(fit5)
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+stopifnot(nbrOfSegments(fit5) == nrow(knownSegments))
+
+
+# One can also force a separator between two segments by setting
+# 'start' and 'end' to NAs ('chromosome' has to be given)
+knownSegments <- data.frame(
+ chromosome=c( 0, 0, 0),
+ start =x[c( 1, NA, 401)],
+ end =x[c(349, NA, J)]
+)
+fit6 <- segmentByCBS(y, x=x, knownSegments=knownSegments, verbose=TRUE)
+sampleName(fit6) <- "CBS_Example_6"
+print(fit6)
+plotTracks(fit6)
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Segment multiple chromosomes
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Simulate multiple chromosomes
+fit1 <- renameChromosomes(fit, from=0, to=1)
+fit2 <- renameChromosomes(fit, from=0, to=2)
+fitM <- append(fit1, fit2)
+fitM <- segmentByCBS(fitM)
+sampleName(fitM) <- "CBS_Example_M"
+print(fitM)
+plotTracks(fitM, Clim=c(-3,3))
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Tiling multiple chromosomes
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Tile chromosomes
+fitT <- tileChromosomes(fitM)
+fitTb <- tileChromosomes(fitT)
+stopifnot(identical(fitTb, fitT))
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Write segmentation to file
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+pathT <- tempdir()
+
+## Tab-delimited file
+pathname <- writeSegments(fitM, path=pathT)
+print(pathname)
+
+## WIG file
+pathname <- writeWIG(fitM, path=pathT)
+print(pathname)
+
+unlink(pathT, recursive=TRUE)
diff --git a/tests/segmentByNonPairedPSCBS,medianDH.R b/tests/segmentByNonPairedPSCBS,medianDH.R
new file mode 100644
index 0000000..995928a
--- /dev/null
+++ b/tests/segmentByNonPairedPSCBS,medianDH.R
@@ -0,0 +1,78 @@
+library("PSCBS")
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Load SNP microarray data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+data <- PSCBS::exampleData("paired.chr01")
+str(data)
+
+# Non-paired / tumor-only data
+data <- data[,c("chromosome", "x", "CT", "betaT")]
+str(data)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Paired PSCBS segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Drop single-locus outliers
+dataS <- dropSegmentationOutliers(data)
+
+# Speed up example by segmenting fewer loci
+dataS <- dataS[seq(from=1, to=nrow(data), by=20),]
+
+# Fake a second chromosome
+dataT <- dataS
+dataT$chromosome <- 2L
+dataS <- rbind(dataS, dataT)
+rm(dataT)
+str(dataS)
+
+# Non-Paired PSCBS segmentation
+fit <- segmentByNonPairedPSCBS(dataS, avgDH="median", seed=0xBEEF, verbose=-10)
+print(fit)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Bootstrap segment level estimates
+# (used by the AB caller, which, if skipped here,
+# will do it automatically)
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- bootstrapTCNandDHByRegion(fit, B=100, verbose=-10)
+print(fit)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Calling segments in allelic balance (AB)
+# NOTE: Ideally, this should be done on whole-genome data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Explicitly estimate the threshold in DH for calling AB
+# (which be done by default by the caller, if skipped here)
+deltaAB <- estimateDeltaAB(fit, flavor="qq(DH)", verbose=-10)
+print(deltaAB)
+
+fit <- callAB(fit, delta=deltaAB, verbose=-10)
+print(fit)
+
+
+# Even if not explicitly specified, the estimated
+# threshold parameter is returned by the caller
+stopifnot(fit$params$deltaAB == deltaAB)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Calling segments in loss-of-heterozygosity (LOH)
+# NOTE: Ideally, this should be done on whole-genome data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Explicitly estimate the threshold in C1 for calling LOH
+# (which be done by default by the caller, if skipped here)
+deltaLOH <- estimateDeltaLOH(fit, flavor="minC1|nonAB", verbose=-10)
+print(deltaLOH)
+
+fit <- callLOH(fit, delta=deltaLOH, verbose=-10)
+print(fit)
+plotTracks(fit)
+
+# Even if not explicitly specified, the estimated
+# threshold parameter is returned by the caller
+stopifnot(fit$params$deltaLOH == deltaLOH)
diff --git a/tests/segmentByPairedPSCBS,DH.R b/tests/segmentByPairedPSCBS,DH.R
new file mode 100644
index 0000000..3c5a936
--- /dev/null
+++ b/tests/segmentByPairedPSCBS,DH.R
@@ -0,0 +1,64 @@
+library("PSCBS")
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Load SNP microarray data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+data <- PSCBS::exampleData("paired.chr01")
+str(data)
+
+# Drop single-locus outliers
+dataS <- dropSegmentationOutliers(data)
+
+# Run light-weight tests
+# Use only every 5th data point
+dataS <- dataS[seq(from=1, to=nrow(data), by=5),]
+# Number of segments (for assertion)
+nSegs <- 3L
+# Number of bootstrap samples (see below)
+B <- 100L
+
+str(dataS)
+R.oo::attachLocally(dataS)
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Calculate DH
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+muN <- aroma.light::callNaiveGenotypes(betaN, censorAt=c(0,1))
+# SNPs are identifies as those loci that have non-missing 'betaT' & 'muN'
+isSnp <- (!is.na(betaT) & !is.na(muN))
+isHet <- isSnp & (muN == 1/2)
+rho <- rep(NA_real_, length=length(muN))
+rho[isHet] <- 2*abs(betaT[isHet]-1/2)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Paired PSCBS segmentation using TCN and DH only
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- segmentByPairedPSCBS(CT, rho=rho,
+ chromosome=chromosome, x=x,
+ seed=0xBEEF, verbose=-10)
+print(fit)
+
+# Plot results
+plotTracks(fit)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Bootstrap segment level estimates
+# (used by the AB caller, which, if skipped here,
+# will do it automatically)
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- bootstrapTCNandDHByRegion(fit, B=B, verbose=-10)
+print(fit)
+plotTracks(fit)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Calling segments in allelic balance (AB) and
+# in loss-of-heterozygosity (LOH)
+# NOTE: Ideally, this should be done on whole-genome data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- callAB(fit, verbose=-10)
+fit <- callLOH(fit, verbose=-10)
+print(fit)
+plotTracks(fit)
diff --git a/tests/segmentByPairedPSCBS,calls.R b/tests/segmentByPairedPSCBS,calls.R
new file mode 100644
index 0000000..ed0c869
--- /dev/null
+++ b/tests/segmentByPairedPSCBS,calls.R
@@ -0,0 +1,124 @@
+library("PSCBS")
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Load SNP microarray data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+data <- PSCBS::exampleData("paired.chr01")
+str(data)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Paired PSCBS segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Drop single-locus outliers
+dataS <- dropSegmentationOutliers(data)
+
+# Find centromere
+gaps <- findLargeGaps(dataS, minLength=2e6)
+knownSegments <- gapsToSegments(gaps)
+
+
+# Run light-weight tests by default
+if (Sys.getenv("_R_CHECK_FULL_") == "") {
+ # Use only every 5th data point
+ dataS <- dataS[seq(from=1, to=nrow(data), by=5),]
+ # Number of segments (for assertion)
+ nSegs <- 4L
+ # Number of bootstrap samples (see below)
+ B <- 100L
+} else {
+ # Full tests
+ nSegs <- 11L
+ B <- 1000L
+}
+
+str(dataS)
+
+# Paired PSCBS segmentation
+fit <- segmentByPairedPSCBS(dataS, knownSegments=knownSegments,
+ seed=0xBEEF, verbose=-10)
+print(fit)
+
+# Plot results
+plotTracks(fit)
+
+# Sanity check
+stopifnot(nbrOfSegments(fit) == nSegs)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Bootstrap segment level estimates
+# (used by the AB caller, which, if skipped here,
+# will do it automatically)
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- bootstrapTCNandDHByRegion(fit, B=B, verbose=-10)
+print(fit)
+plotTracks(fit)
+
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Calling segments with run of homozygosity (ROH)
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- callROH(fit, verbose=-10)
+print(fit)
+plotTracks(fit)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Estimate background
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+kappa <- estimateKappa(fit, verbose=-10)
+print(kappa)
+## [1] 0.226011
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Calling segments in allelic balance (AB)
+# NOTE: Ideally, this should be done on whole-genome data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Explicitly estimate the threshold in DH for calling AB
+# (which be done by default by the caller, if skipped here)
+deltaAB <- estimateDeltaAB(fit, flavor="qq(DH)", verbose=-10)
+if (Sys.getenv("_R_CHECK_FULL_") == "") {
+ # Ad hoc workaround for not utilizing all of the data
+ # in the test, which results in a poor estimate
+ deltaAB <- 0.165
+}
+print(deltaAB)
+## [1] 0.1657131
+
+fit <- callAB(fit, delta=deltaAB, verbose=-10)
+print(fit)
+plotTracks(fit)
+
+# Even if not explicitly specified, the estimated
+# threshold parameter is returned by the caller
+stopifnot(fit$params$deltaAB == deltaAB)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Calling segments in loss-of-heterozygosity (LOH)
+# NOTE: Ideally, this should be done on whole-genome data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Explicitly estimate the threshold in C1 for calling LOH
+# (which be done by default by the caller, if skipped here)
+deltaLOH <- estimateDeltaLOH(fit, flavor="minC1|nonAB", verbose=-10)
+print(deltaLOH)
+## [1] 0.625175
+
+fit <- callLOH(fit, delta=deltaLOH, verbose=-10)
+print(fit)
+plotTracks(fit)
+
+# Even if not explicitly specified, the estimated
+# threshold parameter is returned by the caller
+stopifnot(fit$params$deltaLOH == deltaLOH)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Calling segments that are gained, copy neutral, and lost
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- callGNL(fit, verbose=-10)
+print(fit)
+plotTracks(fit)
diff --git a/tests/segmentByPairedPSCBS,futures.R b/tests/segmentByPairedPSCBS,futures.R
new file mode 100644
index 0000000..a23bcd5
--- /dev/null
+++ b/tests/segmentByPairedPSCBS,futures.R
@@ -0,0 +1,88 @@
+library("PSCBS")
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Load SNP microarray data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+data <- PSCBS::exampleData("paired.chr01")
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Paired PSCBS segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Drop single-locus outliers
+dataS <- dropSegmentationOutliers(data)
+
+# Run light-weight tests by default
+if (Sys.getenv("_R_CHECK_FULL_") == "") {
+ # Use only every 5th data point
+ dataS <- dataS[seq(from=1, to=nrow(data), by=5),]
+ # Number of segments (for assertion)
+ nSegs <- 4L
+} else {
+ # Full tests
+ nSegs <- 11L
+}
+
+str(dataS)
+
+
+## Create multiple chromosomes
+data <- list()
+for (cc in 1:3) {
+ dataS$chromosome <- cc
+ data[[cc]] <- dataS
+}
+data <- Reduce(rbind, data)
+str(data)
+
+
+message("*** segmentByPairedPSCBS() via futures ...")
+
+library("future")
+oplan <- plan()
+
+strategies <- c("eager", "lazy")
+if (supportsMulticore()) strategies <- c(strategies, "multicore")
+
+## Test 'async' futures?
+pkg <- "async"
+if (require(pkg, character.only=TRUE)) {
+ backend("local")
+ strategies <- c(strategies, "batchjobs")
+}
+
+message("Future strategies to test: ", paste(sQuote(strategies), collapse=", "))
+
+fits <- list()
+for (strategy in strategies) {
+ message(sprintf("- segmentByPairedPSCBS() using '%s' futures ...", strategy))
+ plan(strategy)
+ fit <- segmentByPairedPSCBS(data, seed=0xBEEF, verbose=TRUE)
+ fits[[strategy]] <- fit
+ stopifnot(all.equal(fit, fits[[1]]))
+}
+
+message("*** segmentByPairedPSCBS() via futures ... DONE")
+
+
+message("*** segmentByPairedPSCBS() via futures with known segments ...")
+fits <- list()
+dataT <- subset(data, chromosome == 1)
+gaps <- findLargeGaps(dataT, minLength=2e6)
+knownSegments <- gapsToSegments(gaps)
+
+for (strategy in strategies) {
+ message(sprintf("- segmentByCBS() w/ known segments using '%s' futures ...", strategy))
+ plan(strategy)
+ fit <- segmentByPairedPSCBS(dataT, knownSegments=knownSegments, seed=0xBEEF, verbose=TRUE)
+ fits[[strategy]] <- fit
+## FIXME: 2015-12-09
+ stopifnot(all.equal(fit, fits[[1]]))
+}
+
+message("*** segmentByPairedPSCBS() via futures ... DONE")
+
+
+## Cleanup
+plan(oplan)
+rm(list=c("fits", "data", "fit"))
diff --git a/tests/segmentByPairedPSCBS,noNormalBAFs.R b/tests/segmentByPairedPSCBS,noNormalBAFs.R
new file mode 100644
index 0000000..2f2d929
--- /dev/null
+++ b/tests/segmentByPairedPSCBS,noNormalBAFs.R
@@ -0,0 +1,70 @@
+library("PSCBS")
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Load SNP microarray data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+data <- PSCBS::exampleData("paired.chr01")
+str(data)
+
+# Drop single-locus outliers
+dataS <- dropSegmentationOutliers(data)
+
+# Run light-weight tests by default
+if (Sys.getenv("_R_CHECK_FULL_") == "") {
+ # Use only every 5th data point
+ dataS <- dataS[seq(from=1, to=nrow(data), by=5),]
+ # Number of segments (for assertion)
+ nSegs <- 3L
+ # Number of bootstrap samples (see below)
+ B <- 100L
+} else {
+ # Full tests
+ nSegs <- 8L
+ B <- 1000L
+}
+
+str(dataS)
+
+R.oo::attachLocally(dataS)
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Simulate that genotypes are known by other means
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+library("aroma.light")
+muN <- aroma.light::callNaiveGenotypes(betaN, censorAt=c(0,1))
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Paired PSCBS segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- segmentByPairedPSCBS(CT, betaT=betaT, muN=muN, tbn=FALSE,
+ chromosome=chromosome, x=x,
+ seed=0xBEEF, verbose=-10)
+print(fit)
+
+# Plot results
+plotTracks(fit)
+
+# Sanity check
+stopifnot(nbrOfSegments(fit) == nSegs)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Bootstrap segment level estimates
+# (used by the AB caller, which, if skipped here,
+# will do it automatically)
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- bootstrapTCNandDHByRegion(fit, B=B, verbose=-10)
+print(fit)
+plotTracks(fit)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Calling segments in allelic balance (AB) and
+# in loss-of-heterozygosity (LOH)
+# NOTE: Ideally, this should be done on whole-genome data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+fit <- callAB(fit, verbose=-10)
+fit <- callLOH(fit, verbose=-10)
+print(fit)
+plotTracks(fit)
diff --git a/tests/segmentByPairedPSCBS,report.R b/tests/segmentByPairedPSCBS,report.R
new file mode 100644
index 0000000..0dbb99a
--- /dev/null
+++ b/tests/segmentByPairedPSCBS,report.R
@@ -0,0 +1,41 @@
+# This test script calls a report generator which requires
+# the 'ggplot2' package, which in turn will require packages
+# 'colorspace', 'dichromat', 'munsell', 'reshape2' and 'scales'.
+
+# Only run this test in full testing mode
+if (Sys.getenv("_R_CHECK_FULL_") != "") {
+library("PSCBS")
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Load SNP microarray data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+data <- PSCBS::exampleData("paired.chr01")
+str(data)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Paired PSCBS segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Drop single-locus outliers
+dataS <- dropSegmentationOutliers(data)
+
+# Speed up example by segmenting fewer loci
+dataS <- dataS[seq(from=1, to=nrow(data), by=5),]
+
+str(dataS)
+
+gaps <- findLargeGaps(dataS, minLength=2e6)
+knownSegments <- gapsToSegments(gaps)
+
+# Paired PSCBS segmentation
+fit <- segmentByPairedPSCBS(dataS, knownSegments=knownSegments,
+ seed=0xBEEF, verbose=-10)
+
+# Fake a multi-chromosome segmentation
+fit1 <- fit
+fit2 <- renameChromosomes(fit, from=1, to=2)
+fit <- append(fit1, fit2)
+
+report(fit, sampleName="PairedPSCBS", studyName="PSCBS-Ex", verbose=-10)
+
+} # if (Sys.getenv("_R_CHECK_FULL_"))
diff --git a/tests/segmentByPairedPSCBS,seqOfSegmentsByDP.R b/tests/segmentByPairedPSCBS,seqOfSegmentsByDP.R
new file mode 100644
index 0000000..1a0ef74
--- /dev/null
+++ b/tests/segmentByPairedPSCBS,seqOfSegmentsByDP.R
@@ -0,0 +1,61 @@
+library("PSCBS")
+subplots <- R.utils::subplots
+stext <- R.utils::stext
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Load SNP microarray data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+data <- PSCBS::exampleData("paired.chr01")
+str(data)
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Paired PSCBS segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Drop single-locus outliers
+dataS <- dropSegmentationOutliers(data)
+
+# Run light-weight tests by default
+if (Sys.getenv("_R_CHECK_FULL_") == "") {
+ # Use only every 5th data point
+ dataS <- dataS[seq(from=1, to=nrow(data), by=5),]
+ # Number of segments (for assertion)
+ nSegs <- 3L
+ # Number of bootstrap samples (see below)
+ B <- 100L
+} else {
+ # Full tests
+ nSegs <- 12L
+ B <- 1000L
+}
+
+str(dataS)
+
+R.oo::attachLocally(dataS)
+
+
+gaps <- findLargeGaps(dataS, minLength=2e6);
+knownSegments <- gapsToSegments(gaps, dropGaps=TRUE);
+
+# Paired PSCBS segmentation
+fit <- segmentByPairedPSCBS(dataS, knownSegments=knownSegments,
+ seed=0xBEEF, verbose=-10);
+print(fit);
+
+fit1 <- fit;
+fit2 <- renameChromosomes(fit1, from=1, to=2);
+fit <- append(fit1, fit2);
+knownSegments <- tileChromosomes(fit)$params$knownSegments;
+
+segList <- seqOfSegmentsByDP(fit, verbose=-10);
+K <- length(segList);
+ks <- seq(from=1, to=K, length.out=min(5,K));
+subplots(length(ks), ncol=1, byrow=TRUE);
+par(mar=c(2,1,1,1));
+for (kk in ks) {
+ knownSegmentsKK <- segList[[kk]];
+ fitKK <- resegment(fit, knownSegments=knownSegmentsKK, undoTCN=+Inf, undoDH=+Inf);
+ plotTracks(fitKK, tracks="tcn,c1,c2", Clim=c(0,5), add=TRUE);
+ abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3);
+ stext(side=3, pos=0, sprintf("Number of segments: %d", nrow(knownSegmentsKK)));
+} # for (kk ...)
diff --git a/tests/segmentByPairedPSCBS.R b/tests/segmentByPairedPSCBS.R
new file mode 100644
index 0000000..81599d3
--- /dev/null
+++ b/tests/segmentByPairedPSCBS.R
@@ -0,0 +1,155 @@
+###########################################################
+# This tests:
+# - segmentByPairedPSCBS(...)
+# - segmentByPairedPSCBS(..., knownSegments)
+# - tileChromosomes()
+# - plotTracks()
+###########################################################
+library("PSCBS")
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Load SNP microarray data
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+data <- PSCBS::exampleData("paired.chr01")
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Paired PSCBS segmentation
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Drop single-locus outliers
+dataS <- dropSegmentationOutliers(data)
+
+# Run light-weight tests by default
+if (Sys.getenv("_R_CHECK_FULL_") == "") {
+ # Use only every 5th data point
+ dataS <- dataS[seq(from=1, to=nrow(data), by=5),]
+ # Number of segments (for assertion)
+ nSegs <- 4L
+} else {
+ # Full tests
+ nSegs <- 11L
+}
+
+str(dataS)
+
+fig <- 1;
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# (a) Don't segment the centromere (and force a separator)
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+knownSegments <- data.frame(
+ chromosome = c( 1, 1, 1),
+ start = c( -Inf, NA, 141510003),
+ end = c(120992603, NA, +Inf)
+)
+
+
+# Paired PSCBS segmentation
+fit <- segmentByPairedPSCBS(dataS, knownSegments=knownSegments,
+ seed=0xBEEF, verbose=-10)
+print(fit)
+
+# Plot results
+dev.set(2L)
+plotTracks(fit)
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+
+# Sanity check
+stopifnot(nbrOfSegments(fit) == nSegs)
+
+fit1 <- fit
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# (b) Segment also the centromere (which will become NAs)
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+knownSegments <- data.frame(
+ chromosome = c( 1, 1, 1),
+ start = c( -Inf, 120992604, 141510003),
+ end = c(120992603, 141510002, +Inf)
+)
+
+
+# Paired PSCBS segmentation
+fit <- segmentByPairedPSCBS(dataS, knownSegments=knownSegments,
+ seed=0xBEEF, verbose=-10)
+print(fit)
+
+# Plot results
+dev.set(3L)
+plotTracks(fit)
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+
+# Sanity check [TO FIX: See above]
+stopifnot(nbrOfSegments(fit) == nSegs)
+
+fit2 <- fit
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# (c) Do not segment the centromere (without a separator)
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+knownSegments <- data.frame(
+ chromosome = c( 1, 1),
+ start = c( -Inf, 141510003),
+ end = c(120992603, +Inf)
+)
+
+# Paired PSCBS segmentation
+fit <- segmentByPairedPSCBS(dataS, knownSegments=knownSegments,
+ seed=0xBEEF, verbose=-10)
+print(fit)
+
+# Plot results
+dev.set(4L)
+plotTracks(fit)
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+
+# Sanity check
+stopifnot(nbrOfSegments(fit) == nSegs-1L)
+
+fit3 <- fit
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# (d) Skip the identification of new change points
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+knownSegments <- data.frame(
+ chromosome = c( 1, 1),
+ start = c( -Inf, 141510003),
+ end = c(120992603, +Inf)
+)
+
+# Paired PSCBS segmentation
+fit <- segmentByPairedPSCBS(dataS, knownSegments=knownSegments,
+ undoTCN=Inf, undoDH=Inf,
+ seed=0xBEEF, verbose=-10)
+print(fit)
+
+# Plot results
+dev.set(5L)
+plotTracks(fit)
+abline(v=c(knownSegments$start, knownSegments$end)/1e6, lty=3)
+
+# Sanity check
+stopifnot(nbrOfSegments(fit) == nrow(knownSegments))
+
+fit4 <- fit
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Tiling multiple chromosomes
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Simulate multiple chromosomes
+fit1 <- fit
+fit2 <- renameChromosomes(fit, from=1, to=2)
+fitM <- append(fit1, fit2)
+
+# Tile chromosomes
+fitT <- tileChromosomes(fitM)
+fitTb <- tileChromosomes(fitT)
+stopifnot(identical(fitTb, fitT))
+
+# Plotting multiple chromosomes
+plotTracks(fitT)
diff --git a/vignettes/CBS.tex.rsp b/vignettes/CBS.tex.rsp
new file mode 100644
index 0000000..979b1df
--- /dev/null
+++ b/vignettes/CBS.tex.rsp
@@ -0,0 +1,305 @@
+<%@meta language="R-vignette" content="--------------------------------
+DIRECTIVES FOR R:
+
+%\VignetteIndexEntry{Total copy-number segmentation using CBS}
+%\VignetteKeyword{copy numbers}
+%\VignetteKeyword{genomic aberrations}
+%\VignetteAuthor{Henrik Bengtsson}
+%\VignetteEngine{R.rsp::rsp}
+--------------------------------------------------------------------"%>
+
+<% t0 <- Sys.time() %>
+
+<%
+R.utils::use("R.utils")
+
+# RSP specific
+R.rsp <- R.oo::Package("R.rsp")
+withCapture <- R.utils::withCapture
+options("withCapture/newline"=FALSE)
+options(str=strOptions(strict.width="cut"))
+options(width=85)
+options(digits=3)
+
+# Graphics
+use("R.devices")
+options("devEval/args/field"="fullname") # Preferred for LaTeX
+devOptions("png", width=840)
+
+# Analysis
+use("PSCBS")
+PSCBS <- R.oo::Package("PSCBS")
+fixLocations <- function(fit, ...) {
+ for (key in grep("(end|start)$", colnames(fit$output))) {
+ fit$output[[key]] <- as.integer(fit$output[[key]])
+ }
+ fit
+} # fixLocations()
+
+signalType <- "TCN"
+%>
+
+\documentclass[letter]{article}
+\usepackage{xspace}
+\usepackage{alltt}
+\usepackage{xcolor}
+\usepackage{natbib} % \citep{}, \citet{}
+
+\usepackage{graphicx}
+\graphicspath{{figures/}}
+
+<%-------------------------------------------------------------------
+ Assign PDF metadata
+ -------------------------------------------------------------------%>
+% PDF metadata
+\usepackage{hyperref}
+% Ideally \hypersetup{hidelinks}, but for backward compatibility:
+\hypersetup{pdfborder={0 0 0}}
+\hypersetup{
+ pdfauthor={<%@meta name="author"%>},
+ pdftitle={<%@meta name="title"%>},
+ pdfsubject={},
+ pdfkeywords={<%@meta name="keywords"%>},
+ pdfproducer={R.rsp v<%=R.rsp$version%> by <%=R.rsp$author%>}
+}
+
+% Page margins
+\addtolength{\oddsidemargin}{-0.5in}
+\addtolength{\evensidemargin}{-0.5in}
+\addtolength{\textwidth}{1in}
+\addtolength{\topmargin}{-0.5in}
+\addtolength{\textheight}{1in}
+
+% Placement of floats
+\setcounter{bottomnumber}{2}
+\renewcommand{\topfraction}{1.0}
+\renewcommand{\bottomfraction}{1.0}
+\renewcommand{\textfraction}{0.0}
+\renewcommand{\floatpagefraction}{1.0}
+
+% Macros
+\newcommand{\keywords}[1]{{\footnotesize{\textbf{Keywords: }#1}}\xspace}
+\newcommand{\pkg}[1]{\textsl{#1}\xspace}
+\newcommand{\file}[1]{\textsl{#1}\xspace}
+\newcommand{\code}[1]{\texttt{#1}\xspace}
+\newcommand{\bs}{$\backslash$}
+
+\newenvironment{rspVerbatim}{\vspace{-\parskip}\begin{alltt}\color{blue}}{\end{alltt}}
+\newenvironment{escapeRspVerbatim}{\vspace{-\parskip}\begin{alltt}}{\end{alltt}}
+
+
+\title{<%@meta name="title"%>}
+\author{<%@meta name="author"%>}
+\date{<%=format(as.Date(PSCBS$date), format="%B %d, %Y")%>}
+
+\begin{document}
+
+\maketitle
+\begin{abstract}
+The Circular Binary Segmentation (CBS) method partitions a genome into segments of constant total copy numbers (TCNs) based on DNA microarray data. The method also calls ....
+CBS was designed to work with data from any DNA microarray technology and generation, including Affymetrix and Illumina.
+
+This document shows how to use the \pkg{PSCBS} package to run CBS on a tumor sample.
+\end{abstract}
+
+\keywords{<%@meta name="keywords"%>}
+
+\begin{center}
+\emph{This vignette is distributed as part of the \pkg{PSCBS} package, which is available on CRAN (\url{http://cran.r-project.org/}).
+The authors very much appreciate feedback on this document.}
+\end{center}
+
+\clearpage
+\tableofcontents
+
+\clearpage
+
+<%-------------------------------------------------------------------
+ BACKGROUND
+ -------------------------------------------------------------------%>
+\section{Background}
+\label{secBackground}
+We will here use a small example data set to illustrate how to setup the data in a format suitable for CBS, how to identify segments, how to call them, and how to plot and export the segmentation results.
+The statistical model and the algorithm behind CBS is explained in detail in \citet{OlshenA_etal_2004, VenkatramanOlshen_2007}.
+
+
+<%-------------------------------------------------------------------
+ EXAMPLE
+ -------------------------------------------------------------------%>
+\section{Preparing data to be segmented}
+The CBS method requires total copy-number (TCN) estimates. More precisely, it requires TCN ratios for a sample of interest relative to a reference ($y$). The genomic location of the loci in form of chromosome and physical position are also required.
+
+
+\subsection{Locus-level total copy-number signals}
+\label{secData}
+In this example we will use a small example data set part of the \pkg{PSCBS} package. It can be loaded as:
+<%
+fullname <- "PairedPSCBS,exData,chr01"
+%>
+\begin{verbatim}
+<%=withCapture({
+data <- PSCBS::exampleData("paired.chr01")
+data <- data[,c("chromosome", "x", "CT")]
+colnames(data)[3] <- "y"
+str(data)
+})%>
+\end{verbatim}
+In additional to the mandatory fields (\code{chromosome}, \code{x}, and \code{C} this data set also contains .... The latter will not be used here.
+
+\subsection{Dropping <%=signalType%> outliers}
+\label{secTCNOutliers}
+There may be some outliers among the <%=signalType%>s. In CBS~\citep{OlshenA_etal_2004,VenkatramanOlshen_2007}, the authors propose a method for identifying outliers and then to shrink such values toward their neighbors ("smooth") before performing segmentation. At the time CBS was developed it made sense to not just to drop outliers because the resolution was low and every datapoint was valuable. With modern technologies the resolution is much higher and we can afford dropping such o [...]
+\begin{verbatim}
+<%=withCapture({
+data <- dropSegmentationOutliers(data)
+})%>
+\end{verbatim}
+Dropping <%=signalType%> outliers is optional.
+
+
+
+\section{CBS segmentation}
+
+\subsection{Skipping centromeres and other large gaps}
+\label{secGaps}
+The CBS method does not take the physical locations (in units of nucleotides) of the loci in to account when segmenting the data, only their relative ordering along the genome. This means that after having ordered the loci along genome, it will treat two "neighboring" loci that are on both sides of the centromere equally as two neighboring loci that are only few hundred bases apart. This may introduce erroneous change points that appears to be inside the centromere and biological impos [...]
+
+To avoid this, although not mandatory, we will locate all gaps of the genome where there are no observered loci. As a threshold we will consider a region to be a "gap" if the distance between the two closest loci is greater than 1Mb.
+\begin{verbatim}
+<%=withCapture({
+gaps <- findLargeGaps(data, minLength=1e6)
+gaps
+})%>
+\end{verbatim}
+which shows that there is a 20.5Mb long gap between 121.0Mb and 141.5Mb on Chromosome~1. This is the centromere of Chromosome~1.
+Gaps cannot be specified directly. Instead they need to be give as part of a set of "known" segments, which is done as:
+\begin{verbatim}
+<%=withCapture({
+knownSegments <- gapsToSegments(gaps)
+knownSegments
+})%>
+\end{verbatim}
+Below, we will use this to tell CBS to segment Chromosome~1 in three independent segments, where the first segments is from the beginning of the chromosomes (hence '-Inf') to 120.1Mb, the second from 120.1-141.5Mb (the above gap), and the third is from 141.5Mb to the end of the chromosome (hence '+Inf').
+Just as CBS segments chromosomes independently of each other, it also segments priorly known segments independently of each other.
+Specifying known segments is optional.
+
+
+\subsection{Identifying <%=signalType%> segments}
+We are now ready to segment the locus-level <%=signalType%> signals. This is done by\footnote{We fix the random seed in order for the results of this vignette to be exactly reproducible.}:
+\begin{verbatim}
+<%=withCapture({
+fit <- segmentByCBS(data, knownSegments=knownSegments, seed=0xBEEF, verbose=-10)
+})%>
+\end{verbatim}
+Note that this may take several minutes when applied to whole-genome data.
+
+The result of the segmentation is a set of segments identified to have the same underlying <%=signalType%> levels. In this particular case, <%=nbrOfSegments(fit)%> <%=signalType%> segments were found:
+<% fit <- fixLocations(fit) %>
+\begin{verbatim}
+<%=withCapture({
+getSegments(fit, simplify=TRUE)
+})%>
+\end{verbatim}
+<% segs <- getSegments(fit, simplify=TRUE) %>
+Note how Segment~\#<%=which(segs$nbrOfLoci == 0)%> has no mean-level estimates. It is because it corresponds to the centromere (the gap) that was identified above. CBS did indeed try to segment it, but since there are no data points, all estimates are missing values.
+
+
+\subsection{Displaying genomic <%=signalType%> profiles}
+To plot the <%=signalType%> segmentation results, do:
+\begin{verbatim}
+plotTracks(fit)
+\end{verbatim}
+which displays <%=signalType%> as in Figure~\ref{figTracks}.
+To zoom in on a partical region, do:
+\begin{verbatim}
+plotTracks(fit, xlim=c(120,244)*1e6)
+\end{verbatim}
+\begin{figure}[htp]
+ \begin{center}
+ \resizebox{0.96\textwidth}{!}{\includegraphics{<%=toPNG(fullname, tags=c(class(fit)[1L], "tracks"), aspectRatio=0.35, {
+ plotTracks(fit)
+ })%>}}
+ \end{center}
+ \caption{Segments identified by CBS.
+ The <%=signalType%> signals with the <%=signalType%> mean levels (purple).
+ }
+ \label{figTracks}
+\end{figure}
+
+
+
+
+
+
+\section{Calling segments}
+TBA.
+
+<%---
+\subsection{Results from calling <%=signalType%> states}
+All calls are appended to the segmentation results as logical columns:
+\begin{verbatim}
+<%=withCapture({
+getSegments(fit, simplify=TRUE)
+})%>
+\end{verbatim}
+<% segs <- getSegments(fit, simplify=TRUE) %>
+---%>
+
+\section{Saving results}
+
+\subsection{Writing segments to a tab-delimited text file}
+To write the <%=signalType%> segmentation results to file, do:
+\begin{verbatim}
+pathname <- writeSegments(fit, name="MySample", simplify=TRUE)
+\end{verbatim}
+
+
+\section{Experimental}
+In this section we illustrate some of the ongoing and future work of the PSCBS package. Please be aware that these methods are very much under construction, possibly incomplete and in worst case even incorrect.
+
+
+\subsection{Pruning segmentation profile}
+By using hierarchical cluster of the segment means it is possible to prune the <%=signalType%> profile such that change points with very small absolute changes are dropped. If change points are dropped this way, this results in a smaller number of segments, which are hence longer.
+\begin{verbatim}
+<%=withCapture({
+fitP <- pruneByHClust(fit, h=0.25, verbose=-10)
+})%>
+\end{verbatim}
+\begin{figure}[htp]
+ \begin{center}
+ \resizebox{0.96\textwidth}{!}{\includegraphics{<%=toPNG(fullname, tags=c(class(fitP)[1L], "pruned", "tracks"), aspectRatio=0.35, {
+ plotTracks(fitP)
+ })%>}}
+ \end{center}
+ \caption{Pruned <%=signalType%> segments plotted as in Figure~\ref{figTracks}.}
+ \label{figTracksPruned}
+\end{figure}
+
+
+\subsection{Report generation}
+A multipage PDF report that contains both whole-genome and per-chromosome summaries and figures can be generated by:
+\begin{verbatim}
+> report(fit, sampleName="CBS", studyName="CBS-Ex", verbose=-10)
+\end{verbatim}
+By default, the reports are written to directory \code{reports/<studyName>/} under the current working directory. In addition to the PDF, that directory also contains subdirectory \code{figures/} holding all generated figure files (e.g. PNGs and PDFs) for easy inclusion elsewhere.
+
+
+
+<%-------------------------------------------------------------------
+ REFERENCES
+ -------------------------------------------------------------------%>
+\bibliographystyle{natbib}
+\bibliography{PSCBS}
+
+
+<%-------------------------------------------------------------------
+ APPENDIX
+ -------------------------------------------------------------------%>
+\clearpage
+\section*{Appendix}
+\subsection*{Session information}
+<%=toLatex(sessionInfo())%>
+This report was automatically generated using \code{rfile()} of the R.rsp package.
+Total processing time after RSP-to-R translation was <%=dt <- round(Sys.time()-t0, digits=2)%> <%=attr(dt, "units")%>.
+
+\end{document}
diff --git a/vignettes/PSCBS.bib b/vignettes/PSCBS.bib
new file mode 100644
index 0000000..8bddbee
--- /dev/null
+++ b/vignettes/PSCBS.bib
@@ -0,0 +1,77 @@
+ at ARTICLE{OlshenA_etal_2004,
+ author = {Adam B Olshen and E. S. Venkatraman and Robert Lucito and Michael
+ Wigler},
+ title = {Circular binary segmentation for the analysis of array-based DNA
+ copy number data.},
+ journal = {Biostatistics},
+ year = {2004},
+ volume = {5},
+ pages = {557--572},
+ number = {4},
+ month = {Oct},
+ doi = {10.1093/biostatistics/kxh008},
+ keywords = {Breast Neoplasms; Cell Line, Tumor; Computer Simulation; Female; Gene
+ Dosage; Genome, Human; Humans; Olig; e Analysis; onucleotide Array
+ Sequence;
+
+ CBS},
+ pii = {5/4/557},
+ pmid = {15475419},
+ url = {http://dx.doi.org/10.1093/biostatistics/kxh008}
+}
+
+
+ at ARTICLE{VenkatramanOlshen_2007,
+ author = {E. S. Venkatraman and Adam B Olshen},
+ title = {{A} faster circular binary segmentation algorithm for the analysis
+ of array {CGH} data.},
+ journal = {Bioinformatics},
+ year = {2007},
+ volume = {23},
+ pages = {657--663},
+ number = {6},
+ month = {Mar},
+ doi = {10.1093/bioinformatics/btl646},
+ keywords = {Algorithms; Chromosome Mapping, methods; Gene Dosage, genetics; Oligonucleotide
+ Array Sequence Analysis, methods; Programming Languages; Sequence
+ Alignment, methods; Sequence Analysis, DNA, methods; Software; Time
+ Factors},
+ pii = {btl646},
+ pmid = {17234643},
+ url = {http://dx.doi.org/10.1093/bioinformatics/btl646}
+}
+
+
+ at ARTICLE{OlshenA_etal_2011,
+ author = {Adam B. Olshen and Henrik Bengtsson and Pierre Neuvial and Paul Spellman
+ and Richard A. Olshen and Venkatraman E. Seshan},
+ title = {Parent-specific copy number in paired tumor-normal studies using
+ circular binary segmentation},
+ journal = {Bioinformatics},
+ year = {2011},
+ volume = {27},
+ pages = {2038-2046},
+ number = {15},
+ doi = {10.1093/bioinformatics/btr329},
+ pmid = {21666266},
+ url = {http://bioinformatics.oxfordjournals.org/content/27/15/2038}
+}
+
+
+ at ARTICLE{BengtssonH_etal_2010,
+ author = {Henrik Bengtsson and Pierre Neuvial and Terence P Speed},
+ title = {{TumorBoost}: Normalization of allele-specific tumor copy numbers
+ from a single pair of tumor-normal genotyping microarrays},
+ journal = {BMC Bioinformatics},
+ year = {2010},
+ volume = {11},
+ pages = {245},
+ number = {1},
+ month = {May},
+ doi = {10.1186/1471-2105-11-245},
+ language = {eng},
+ medline-pst = {aheadofprint},
+ pii = {1471-2105-11-245},
+ pmid = {20462408},
+ url = {http://dx.doi.org/10.1186/1471-2105-11-245}
+}
diff --git a/vignettes/PairedPSCBS.tex.rsp b/vignettes/PairedPSCBS.tex.rsp
new file mode 100644
index 0000000..7dbe86d
--- /dev/null
+++ b/vignettes/PairedPSCBS.tex.rsp
@@ -0,0 +1,421 @@
+<%@meta language="R-vignette" content="--------------------------------
+DIRECTIVES FOR R:
+%\VignetteIndexEntry{Parent-specific copy-number segmentation using Paired PSCBS}
+%\VignetteAuthor{Henrik Bengtsson}
+%\VignetteKeyword{copy numbers}
+%\VignetteKeyword{allele specific}
+%\VignetteKeyword{parent specific}
+%\VignetteKeyword{genomic aberrations}
+%\VignetteEngine{R.rsp::rsp}
+--------------------------------------------------------------------"%>
+
+
+<% t0 <- Sys.time() %>
+
+<%
+R.utils::use("R.utils")
+
+# RSP specific
+R.rsp <- R.oo::Package("R.rsp")
+withCapture <- R.utils::withCapture
+options("withCapture/newline"=FALSE)
+options(str=strOptions(strict.width="cut"))
+options(width=85)
+options(digits=3)
+
+# Graphics
+use("R.devices")
+options("devEval/args/field"="fullname") # Preferred for LaTeX
+devOptions("png", width=840)
+
+# Analysis
+use("PSCBS")
+PSCBS <- R.oo::Package("PSCBS")
+fixLocations <- function(fit, ...) {
+ for (key in grep("(end|start)$", colnames(fit$output))) {
+ fit$output[[key]] <- as.integer(fit$output[[key]])
+ }
+ fit
+} # fixLocations()
+%>
+
+\documentclass[letter]{article}
+\usepackage{xspace}
+\usepackage{alltt}
+\usepackage{xcolor}
+\usepackage{natbib} % \citep{}, \citet{}
+
+\usepackage{graphicx}
+\graphicspath{{figures/}}
+
+<%-------------------------------------------------------------------
+ Assign PDF metadata
+ -------------------------------------------------------------------%>
+% PDF metadata
+\usepackage{hyperref}
+% Ideally \hypersetup{hidelinks}, but for backward compatibility:
+\hypersetup{pdfborder={0 0 0}}
+\hypersetup{
+ pdfauthor={<%@meta name="author"%>},
+ pdftitle={<%@meta name="title"%>},
+ pdfsubject={},
+ pdfkeywords={<%@meta name="keywords"%>},
+ pdfproducer={R.rsp v<%=R.rsp$version%> by <%=R.rsp$author%>}
+}
+
+% Page margins
+\addtolength{\oddsidemargin}{-0.5in}
+\addtolength{\evensidemargin}{-0.5in}
+\addtolength{\textwidth}{1in}
+\addtolength{\topmargin}{-0.5in}
+\addtolength{\textheight}{1in}
+
+% Placement of floats
+\setcounter{bottomnumber}{2}
+\renewcommand{\topfraction}{1.0}
+\renewcommand{\bottomfraction}{1.0}
+\renewcommand{\textfraction}{0.0}
+\renewcommand{\floatpagefraction}{1.0}
+
+% Macros
+\newcommand{\keywords}[1]{{\footnotesize{\textbf{Keywords: }#1}}\xspace}
+\newcommand{\pkg}[1]{\textsl{#1}\xspace}
+\newcommand{\file}[1]{\textsl{#1}\xspace}
+\newcommand{\code}[1]{\texttt{#1}\xspace}
+\newcommand{\bs}{$\backslash$}
+
+\newcommand{\alphaTCN}{\alpha_{\textnormal{TCN}}\xspace}
+\newcommand{\alphaDH}{\alpha_{\textnormal{DH}}\xspace}
+\newcommand{\LOH}{\ensuremath{\textnormal{LOH}}\xspace}
+\newcommand{\AB}{\ensuremath{\textnormal{AB}}\xspace}
+
+\newenvironment{rspVerbatim}{\vspace{-\parskip}\begin{alltt}\color{blue}}{\end{alltt}}
+\newenvironment{escapeRspVerbatim}{\vspace{-\parskip}\begin{alltt}}{\end{alltt}}
+
+
+\title{<%@meta name="title"%>}
+\author{<%@meta name="author"%>}
+\date{<%=format(as.Date(PSCBS$date), format="%B %d, %Y")%>}
+
+\begin{document}
+
+\maketitle
+\begin{abstract}
+The Paired Parent-Specific Circular Binary Segmentation (Paired PSCBS) method partitions a tumor genome into segments of constant parent-specific copy numbers (PSCNs) based on SNP DNA microarray data from a matched tumor-normal pair. The method also calls segments with run of homozygosity (ROH), segments in allelic balance (AB) and segments with loss of heterozygosity (LOH).
+Paired PSCBS was designed to work with data from any SNP microarray technology and generation, including Affymetrix and Illumina.
+
+This document shows how to use the \pkg{PSCBS} package to run Paired PSCBS on a tumor-normal pair.
+\end{abstract}
+
+\keywords{<%@meta name="keywords"%>}
+
+\begin{center}
+\emph{This vignette is distributed as part of the \pkg{PSCBS} package, which is available on CRAN (\url{http://cran.r-project.org/}).
+The authors very much appreciate feedback on this document.}
+\end{center}
+
+\clearpage
+\tableofcontents
+
+\clearpage
+
+
+<%-------------------------------------------------------------------
+ BACKGROUND
+ -------------------------------------------------------------------%>
+\section{Background}
+\label{secBackground}
+We will here use a small example data set to illustrate how to setup the data in a format suitable for Paired PSCBS, how to identify segments, how to call them, and how to plot and export the segmentation results.
+The statistical model and the algorithm behind Paired PSCBS is explained in detail in~\citet{OlshenA_etal_2011}.
+
+
+<%-------------------------------------------------------------------
+ EXAMPLE
+ -------------------------------------------------------------------%>
+\section{Preparing data to be segmented}
+The Paired PSCBS~\citep{OlshenA_etal_2011} method requires tumor-normal paired parent-specific copy-number (PSCN) signals. More precisely, it requires total copy-number (TCN) estimates for the tumor relative to the matched normal ($C_T$), allele B fractions (BAFs) for the tumor ($\beta_T$) and BAFs for the matched normal ($\beta_N$). The genomic locations of the loci in form of chromosome and physical position are also required.
+
+
+\subsection{Locus-level SNP copy-number signals}
+\label{secData}
+In this example we will use a small example data set part of the \pkg{PSCBS} package. It can be loaded as:
+<%
+fullname <- "PairedPSCBS,exData,chr01"
+%>
+\begin{verbatim}
+<%=withCapture({
+data <- PSCBS::exampleData("paired.chr01")
+str(data)
+})%>
+\end{verbatim}
+In additional to the mandatory fields (\code{chromosome}, \code{x}, \code{CT}, \code{betaT}, and \code{betaN}), this data set also contains TCNs for normal (\code{CN}) relative to a large pool of normal samples. The latter will not be used here.
+
+\subsection{Dropping TCN outliers}
+\label{secTCNOutliers}
+There may be some outliers among the TCNs. In CBS~\citep{OlshenA_etal_2004,VenkatramanOlshen_2007}, the authors propose a method for identifying outliers and then to shrink such values toward their neighbors ("smooth") before performing segmentation. At the time CBS was developed it made sense to not just to drop outliers because the resolution was low and every datapoint was valuable. With modern technologies the resolution is much higher and we can afford dropping such outliers, whi [...]
+\begin{verbatim}
+<%=withCapture({
+data <- dropSegmentationOutliers(data)
+})%>
+\end{verbatim}
+Dropping TCN outliers is optional.
+
+
+
+\section{Paired PSCBS segmentation}
+
+\subsection{Skipping centromeres and other large gaps}
+\label{secGaps}
+Like the CBS method, Paired PSCBS does not take the physical locations (in units of nucleotides) of the loci in to account when segmenting the data, only their relative ordering along the genome. This means that after having ordered the loci along genome, it will treat two "neighboring" loci that are on both sides of the centromere equally to two neighboring loci that are only a few hundred bases apart. This may introduce erroneous change points that appear to be inside the centromere. [...]
+
+To avoid this, although not mandatory, we will locate all gaps of the genome where there are no observered loci. As a threshold we will consider a region to be a "gap" if the distance between the two closest loci is greater than 1Mb.
+\begin{verbatim}
+<%=withCapture({
+gaps <- findLargeGaps(data, minLength=1e6)
+gaps
+})%>
+\end{verbatim}
+which shows that there is a 20.5Mb long gap between 121.0Mb and 141.5Mb on Chromosome~1. This is the centromere of Chromosome~1.
+It is not possible to specify "gaps" to the segmentation function. Instead they need to be given as part of a set of "known" segments, which is done as:
+\begin{verbatim}
+<%=withCapture({
+knownSegments <- gapsToSegments(gaps)
+knownSegments
+})%>
+\end{verbatim}
+Below, we will use this to tell Paired PSCBS to segment Chromosome~1 into three independent segments, where the first segment is from the beginning of the chromosome (hence '-Inf') to 120.1Mb, the second one from 120.1-141.5Mb (the above gap), and the third one is from 141.5Mb to the end of the chromosome (hence '+Inf').
+Just as Paired PSCBS segments chromosomes independently of each other, it also segments priorly known segments independently of each other.
+Specifying known segments is optional.
+
+
+\subsection{Identifying PSCN segments}
+We are now ready to segment the locus-level PSCN signals. This is done by\footnote{We fix the random seed in order for the results of this vignette to be numerically reproducible.}:
+\begin{verbatim}
+<%=withCapture({
+fit <- segmentByPairedPSCBS(data, knownSegments=knownSegments, preserveScale=FALSE, seed=0xBEEF, verbose=-10)
+})%>
+\end{verbatim}
+Note that this may take several minutes when applied to whole-genome data.
+The above call will also normalize the tumor BAFs using the TumorBoost normalization method~\citep{BengtssonH_etal_2010} (without preserving the relative scale for homozygous and heterozygous BAFs; in a future version, this will be the default). If this has already been done or the tumor signals have been normalized by other means, the TumorBoost step can be skipped by setting argument \code{tbn=FALSE}.
+
+The result of the segmentation is a set of segments identified to have the same underlying PSCN levels. In this particular case, <%=nbrOfSegments(fit)%> PSCN segments were found:
+<% fit <- fixLocations(fit) %>
+\begin{verbatim}
+<%=withCapture({
+getSegments(fit, simplify=TRUE)
+})%>
+\end{verbatim}
+<% segs <- getSegments(fit, simplify=TRUE) %>
+Note that Segment~\#<%=which(segs$tcnNbrOfLoci == 0)%> has no mean-level estimates. It is because it corresponds to the centromere (the gap) that was identified above. Paired PSCBS did indeed try to segment it, but since there are no data points, all estimates are missing values.
+Similarly, for Segment~\#<%=which(segs$dhNbrOfLoci == 0)%> the DH and minor and major CNs mean estimates are all missing values. This is because, Paired PSCBS identified that segment by first segmenting the TCN signals by themselves, and after which it tried to segment the DH signals within that segment. Since there are no heterozygous SNPs in the segment, there are no DH signals, and hence there is no DH mean estimate.
+
+
+\subsection{Displaying genomic PSCN profiles}
+To plot the PSCN segmentation results, do:
+\begin{verbatim}
+plotTracks(fit)
+\end{verbatim}
+which by default displays three panels containing TCN, decrease of heterozygosity (DH), and minor and major CNs as in Figure~\ref{figTracks}.
+To plot only one panel with TCN and minor and major CNs and zoom in on a particular region, do (not shown):
+\begin{verbatim}
+plotTracks(fit, tracks="tcn,c1,c2", xlim=c(120,244)*1e6)
+\end{verbatim}
+\begin{figure}[htp]
+ \begin{center}
+ \resizebox{0.96\textwidth}{!}{\includegraphics{<%=toPNG(fullname, tags=c(class(fit)[1L], "tracks"), aspectRatio=0.6, {
+ plotTracks(fit)
+ })%>}}
+ \end{center}
+ \caption{PSCN segments identified by Paired PSCBS.
+ \textbf{Top}: The TCN signals with the TCN mean levels (purple).
+ \textbf{Middle}: The DH signals with the DH mean levels (orange).
+ \textbf{Bottom}: The TCN signals with the minor CN ($C_1$; blue), the major CN ($C_2$; red) and the TCN ($C=C_1+C_2$; purple) mean levels.
+ }
+ \label{figTracks}
+\end{figure}
+
+
+
+
+
+
+\section{Calling segments}
+The calling algorithms for allelic balance (AB) and loss of heterozygosity (LOH) are based on quantile estimates of the different mean levels. These estimates are obtained using non-parametric bootstrap techniques. For more details, see~\citet{OlshenA_etal_2011}.
+After the Paired PSCBS method was published, we have added methods for calling run of homozygosity (ROH) and neutral total copy number (NTCN).
+\emph{The ROH and NTCN calling methods should be considered under development until further notice, meaning they and their results may change without notice.}
+
+
+
+\subsection{Calling segments with run of homozygosity (ROH)*}
+\emph{Please note that this method is under development. This means that it may change without further notice.}
+
+A region has a run of homozygotes (ROH) if all of its SNPs are homozygous (in the normal). Since such a region has no heterozyous SNPs, its decrease in heterozygosity (DH) is undefined. Likewise, the minor and major copy numbers are unknown.
+ However, if there are genotyping errors within an ROH region, we will obtain a non-missing DH mean level and hence also finite minor and major CNs. In order to adjust for these faulty estimates, we test if the identified segments are ROHs or not by:
+\begin{verbatim}
+<%=withCapture({
+fit <- callROH(fit, verbose=-10)
+})%>
+\end{verbatim}
+This will also set the corresponding DH and minor and major CN mean levels to NA. The total CN mean levels are not affected by the ROH call.
+
+\subsubsection{Tuning parameters}
+For each segment, the test for ROH calculates the fraction of SNPs
+that are called heterozygous. If the fraction of heterozygotes is smaller
+than a threshold, the segmented is called ROH, otherwise not.
+The default threshold is 1/12.
+To use a different threshold, set argument \code{delta} to a scalar in $[0,1]$.
+For example, using \code{callROH(fit, delta=1/30)} makes the ROH caller
+more conservative.\footnote{It is our plan to replace this basic test with a bionomial test.}
+
+
+\subsection{Calling segments in allelic balance (AB)}
+The AB caller tests whether the DH level of a segment is small enough to be considered zero, which means that the minor and the major CNs are equal, i.e. the segment is in allelic balance.
+To call the AB state of all segments, do:
+\begin{verbatim}
+<%=withCapture({
+fit <- callAB(fit, verbose=-10)
+})%>
+\end{verbatim}
+Because the caller utilizes bootstrapping techniques, calling AB may take some time if there is a large number of segments.
+Segments already called ROH will not be called for AB, and their AB statuses will have a missing value (\code{NA}).
+
+
+\subsubsection{Tuning parameters}
+The AB caller tests whether a segment's DH is zero or not, by comparing its DH level (or more precisely, the $5\%$ quantile of its bootstrapped DH mean level) to a threshold. This threshold will be a function of the noise level, because the noiser the BAF signals (and hence the DH signals), the greater the bias of the DH mean level for segments in AB will be. Because of this, the threshold is choosen from data by estimating the noise level of the DH signals near zero.
+Further rationales and details are given in~\citet{OlshenA_etal_2011}.
+The AB threshold can be estimated explicitly and used in the caller as
+\begin{verbatim}
+deltaAB <- estimateDeltaAB(fit, scale=1)
+fit <- callAB(fit, delta=deltaAB)
+\end{verbatim}
+By decreasing argument \code{scale} (a positive scalar), a smaller
+threshold will be obtained resulting in a more conservative AB caller.
+
+
+\subsection{Calling segments with loss of heterozygosity (LOH)}
+The LOH caller tests whether the minor CN level of a segment is large enough to be considered non-zero, which means that the segment is \emph{not} in LOH.
+To call the LOH state of all segments, do:
+\begin{verbatim}
+<%=withCapture({
+fit <- callLOH(fit, verbose=-10)
+})%>
+\end{verbatim}
+Note that in order to call LOH, one has to call allelic balance first. Since the bootstrapping was already done in the AB caller, it is not repeated here, which is why calling LOH is faster than calling AB.
+Analogously to the AB caller, segments already called ROH will not be called for LOH, and their LOH statuses will have a missing value (\code{NA}).
+Segments already called AB will be called non-LOH, because AB and LOH are exclusively mutual states.
+
+\subsubsection{Tuning parameters}
+The LOH caller tests whether a segment's minor CN is non-zero or not, by comparing its minor CN level (or more precisely, the $95\%$ quantile of its bootstrapped minor CN mean level) to a threshold. This threshold will, among other components, be a function of normal contamination, i.e. the greater the fraction of normal cells is the greater the threshold needs to be in order to call LOH in the tumor cells. Because of this, the threshold is choosen from data as the midpoint of the esti [...]
+The LOH threshold can be estimated explicitly and used as:
+\begin{verbatim}
+deltaLOH <- estimateDeltaLOH(fit, midpoint=1/2)
+fit <- callLOH(fit, delta=deltaLOH)
+\end{verbatim}
+By decreasing argument \code{midpoint} in $[0,1]$, a smaller
+threshold will be obtained resulting in a more conservative LOH caller.
+
+
+
+\subsection{Calling segments with neutral total copy number (NTCN)*}
+\emph{Please note that this method is under development. This means that it may change without further notice.}
+
+The neutral total copy number (NTCN) caller tests whether the total CN level of a segment is neutral (e.g. diploid) or not.
+To call the NTCN state of all segments, do:
+\begin{verbatim}
+<%=withCapture({
+fit <- callNTCN(fit, verbose=-10)
+})%>
+\end{verbatim}
+
+
+\subsubsection{Tuning parameters}
+The NTCN caller identifies segments which TCN mean levels (or more precisely, which $95\%$ confidence intervals) are within a given "acceptance" region. This acceptance region is determined by the $95\%$ confidence interval of an initial set of AB segments identified to be copy neutral and then expanded by half a TCN unit length.
+The true length of half a total copy number unit is specified by the argument \code{delta} to \code{callNTCN()}. Its length should be a function of the overall background signals (which includes normal contamination and more), such that the width of the acceptance region becomes smaller when the background increases.
+The background signal (\code{kappa}) and \code{delta} can be estimated explicitly as:
+\begin{verbatim}
+kappa <- estimateKappa(fit)
+deltaCN <- estimateDeltaCN(fit, scale=1, kappa=kappa)
+fit <- callNTCN(fit, delta=deltaCN, verbose=-10)
+\end{verbatim}
+By decreasing the tuning parameter \code{scale} (a positive scalar), a smaller acceptance region will be obtained, which results in a more conservative CN caller.
+
+
+
+\subsection{Results from calling ROH, AB, LOH and NTCN}
+All calls are appended to the segmentation results as logical columns:
+\begin{verbatim}
+<%=withCapture({
+getSegments(fit, simplify=TRUE)
+})%>
+\end{verbatim}
+<% segs <- getSegments(fit, simplify=TRUE) %>
+
+
+\section{Saving results}
+
+\subsection{Writing segments to a tab-delimited text file}
+To write the PSCN segmentation results to file, do:
+\begin{verbatim}
+pathname <- writeSegments(fit, name="MySample", simplify=TRUE)
+\end{verbatim}
+With \code{simplify=FALSE} (default) quantile estimates of the different mean levels will also be written, which roughly doubles the file size.
+
+
+
+\section{Experimental}
+In this section we illustrate some of the ongoing and future work that will be contained in the PSCBS package. Please be aware that these methods are very much under construction, possibly incomplete and in the worst case, even incorrect.
+
+
+\subsection{Less biased Decrease of Heterozygosity (DH) estimates}
+The DH mean levels of the segments are estimated as the sample mean of the DH signals within each segment. Since DH signals are by definition truncated at zero, the mean level estimates will always be greater than zero even if the true underlying DH is exactly zero. An additional bias is introduced because the distribution of the DH signals is skewed for small DHs, causing the sample mean estimate to be biased. A less biased estimate can be obtained by using the median estimator. To [...]
+
+
+\subsection{Pruning segmentation profile}
+By applying hierarchical clustering on the segment means, it is possible to prune the PSCN profile such that change points with very small absolute changes are dropped. If change points are dropped this way, this results in a smaller number of segments, which are hence longer on average. To prune Paired PSCBS segmentation results this way, do:
+\begin{verbatim}
+<%=withCapture({
+fitP <- pruneByHClust(fit, h=0.25, verbose=-10)
+})%>
+\end{verbatim}
+The result of this is shown in Figure~\ref{figTracksPruned}.
+\begin{figure}[htp]
+ \begin{center}
+ \resizebox{0.96\textwidth}{!}{\includegraphics{<%=toPNG(fullname, tags=c(class(fitP)[1L], "pruned", "tracks"), aspectRatio=0.6, {
+ plotTracks(fitP)
+ })%>}}
+ \end{center}
+ \caption{Pruned PSCN segments plotted as in Figure~\ref{figTracks}.}
+ \label{figTracksPruned}
+\end{figure}
+In the current implementation, any segment calls and quantile mean levels estimates previously are dropped when pruning.
+
+
+\subsection{Report generation}
+A multipage PDF report that contains both whole-genome and per-chromosome summaries and figures can be generated by:
+\begin{verbatim}
+> report(fit, sampleName="PairedPSCBS", studyName="PSCBS-Ex", verbose=-10)
+\end{verbatim}
+By default, the reports are written to directory \code{reports/<studyName>/} under the current working directory. In addition to the PDF, that directory also contains subdirectory \code{figures/} holding all generated figure files (e.g. PNGs and PDFs) for easy inclusion elsewhere.
+
+
+
+
+
+<%-------------------------------------------------------------------
+ REFERENCES
+ -------------------------------------------------------------------%>
+\bibliographystyle{natbib}
+\bibliography{PSCBS}
+
+
+<%-------------------------------------------------------------------
+ APPENDIX
+ -------------------------------------------------------------------%>
+\clearpage
+\section*{Appendix}
+\subsection*{Session information}
+<%=toLatex(sessionInfo())%>
+This report was automatically generated using \code{rfile()} of the R.rsp package.
+Total processing time after RSP-to-R translation was <%=dt <- round(Sys.time()-t0, digits=2)%> <%=attr(dt, "units")%>.
+
+\end{document}
diff --git a/vignettes/natbib.bst b/vignettes/natbib.bst
new file mode 100644
index 0000000..a679e1d
--- /dev/null
+++ b/vignettes/natbib.bst
@@ -0,0 +1,1288 @@
+%%
+%% This is file `natbib.bst', generated
+%% on <1994/9/16> with the docstrip utility (2.2h).
+%%
+%% The original source files were:
+%%
+%% genbst.mbs (with options: `ay,nat,seq-lab,nm-rev,dt-beg,yr-par,vol-bf,
+%% volp-com,etal-it')
+%% ----------------------------------------
+%% *** Personal bib style, PWD ***
+%%
+%% (Here are the specifications of the source file)
+%% \ProvidesFile{genbst.mbs}[1994/09/16 1.5 (PWD)]
+%% For use with BibTeX version 0.99a or later
+%% and with LaTeX 2.09 or 2e
+%%-------------------------------------------------------------------
+%% NOTICE:
+%% This file may be used for non-profit purposes.
+%% It may not be distributed in exchange for money,
+%% other than distribution costs.
+%%
+%% The author provides it `as is' and does not guarantee it in any way.
+%%
+%% Copyright (C) 1994 Patrick W. Daly
+%% Max-Planck-Institut f\"ur Aeronomie
+%% Postfach 20
+%% D-37189 Katlenburg-Lindau
+%% Germany
+%%
+%% E-mail:
+%% SPAN-- nsp::linmpi::daly (note nsp also known as ecd1)
+%% Internet-- daly at linmpi.dnet.gwdg.de
+%%-----------------------------------------------------------
+%% \CharacterTable
+%% {Upper-case \A\B\C\D\E\F\G\H\I\J\K\L\M\N\O\P\Q\R\S\T\U\V\W\X\Y\Z
+%% Lower-case \a\b\c\d\e\f\g\h\i\j\k\l\m\n\o\p\q\r\s\t\u\v\w\x\y\z
+%% Digits \0\1\2\3\4\5\6\7\8\9
+%% Exclamation \! Double quote \" Hash (number) \#
+%% Dollar \$ Percent \% Ampersand \&
+%% Acute accent \' Left paren \( Right paren \)
+%% Asterisk \* Plus \+ Comma \,
+%% Minus \- Point \. Solidus \/
+%% Colon \: Semicolon \; Less than \<
+%% Equals \= Greater than \> Question mark \?
+%% Commercial at \@ Left bracket \[ Backslash \\
+%% Right bracket \] Circumflex \^ Underscore \_
+%% Grave accent \` Left brace \{ Vertical bar \|
+%% Right brace \} Tilde \~}
+%%---------------------------------------------------------------------
+ % This is an author-year citation style bibliography. As such, it is
+ % non-standard LaTeX, and requires a special package file to function properly.
+ % Such a package is natbib.sty by Patrick W. Daly
+ % The form of the \bibitem entries is
+ % \bibitem[Jones et al.(1990)]{key}...
+ % \bibitem[Jones et al.(1990)Jones, Baker, and Smith]{key}...
+ % The essential feature is that the label (the part in brackets) consists
+ % of the author names, as they should appear in the citation, with the year
+ % in parentheses following. There must be no space before the opening
+ % parenthesis!
+ % With natbib v5.3, a full list of authors may also follow the year.
+ % In natbib.sty, it is possible to define the type of enclosures that is
+ % really wanted (brackets or parentheses), but in either case, there must
+ % be parentheses in the label.
+ % The \cite command functions as follows:
+ % \cite{key} ==>> Jones et al. (1990)
+ % \cite[]{key} ==>> (Jones et al., 1990)
+ % \cite[chap. 2]{key} ==>> (Jones et al., 1990, chap. 2)
+ % \cite[e.g.][]{key} ==>> (e.g. Jones et al., 1990)
+ % \cite[e.g.][p. 32]{key} ==>> (e.g. Jones et al., p. 32)
+ % \citeauthor{key} Jones et al.
+ % \citefullauthor{key} Jones, Baker, and Smith
+ % \citeyear{key} 1990
+%%---------------------------------------------------------------------
+
+ENTRY
+ { address
+ author
+ booktitle
+ chapter
+ edition
+ editor
+ howpublished
+ institution
+ journal
+ key
+ month
+ note
+ number
+ organization
+ pages
+ publisher
+ school
+ series
+ title
+ type
+ volume
+ year
+ }
+ {}
+ { label extra.label sort.label }
+
+INTEGERS { output.state before.all mid.sentence after.sentence after.block }
+
+FUNCTION {init.state.consts}
+{ #0 'before.all :=
+ #1 'mid.sentence :=
+ #2 'after.sentence :=
+ #3 'after.block :=
+}
+
+STRINGS { s t }
+
+FUNCTION {output.nonnull}
+{ 's :=
+ output.state mid.sentence =
+ { ", " * write$ }
+ { output.state after.block =
+ { add.period$ write$
+ newline$
+ "\newblock " write$
+ }
+ { output.state before.all =
+ 'write$
+ { add.period$ " " * write$ }
+ if$
+ }
+ if$
+ mid.sentence 'output.state :=
+ }
+ if$
+ s
+}
+
+FUNCTION {output}
+{ duplicate$ empty$
+ 'pop$
+ 'output.nonnull
+ if$
+}
+
+FUNCTION {output.check}
+{ 't :=
+ duplicate$ empty$
+ { pop$ "empty " t * " in " * cite$ * warning$ }
+ 'output.nonnull
+ if$
+}
+
+FUNCTION {fin.entry}
+{ add.period$
+ write$
+ newline$
+}
+
+FUNCTION {new.block}
+{ output.state before.all =
+ 'skip$
+ { after.block 'output.state := }
+ if$
+}
+
+FUNCTION {new.sentence}
+{ output.state after.block =
+ 'skip$
+ { output.state before.all =
+ 'skip$
+ { after.sentence 'output.state := }
+ if$
+ }
+ if$
+}
+
+FUNCTION {not}
+{ { #0 }
+ { #1 }
+ if$
+}
+
+FUNCTION {and}
+{ 'skip$
+ { pop$ #0 }
+ if$
+}
+
+FUNCTION {or}
+{ { pop$ #1 }
+ 'skip$
+ if$
+}
+
+FUNCTION {non.stop}
+{ duplicate$
+ "}" * add.period$
+ #-1 #1 substring$ "." =
+}
+
+FUNCTION {new.block.checkb}
+{ empty$
+ swap$ empty$
+ and
+ 'skip$
+ 'new.block
+ if$
+}
+
+FUNCTION {field.or.null}
+{ duplicate$ empty$
+ { pop$ "" }
+ 'skip$
+ if$
+}
+
+FUNCTION {emphasize}
+{ duplicate$ empty$
+ { pop$ "" }
+ { "{\em " swap$ * non.stop
+ { "\/}" * }
+ { "}" * }
+ if$
+ }
+ if$
+}
+
+FUNCTION {bolden}
+{ duplicate$ empty$
+ { pop$ "" }
+ { "{\bf " swap$ * "}" * }
+ if$
+}
+
+INTEGERS { nameptr namesleft numnames }
+
+FUNCTION {format.names}
+{ 's :=
+ #1 'nameptr :=
+ s num.names$ 'numnames :=
+ numnames 'namesleft :=
+ { namesleft #0 > }
+ { s nameptr
+ "{vv~}{ll}{, jj}{, f.}" format.name$ 't :=
+ nameptr #1 >
+ {
+ namesleft #1 >
+ { ", " * t * }
+ {
+ numnames #2 >
+ { "," * }
+ 'skip$
+ if$
+ t "others" =
+ { " " * "et~al." emphasize * }
+ { " and " * t * }
+ if$
+ }
+ if$
+ }
+ 't
+ if$
+ nameptr #1 + 'nameptr :=
+ namesleft #1 - 'namesleft :=
+ }
+ while$
+}
+
+FUNCTION {format.names.ed}
+{ 's :=
+ #1 'nameptr :=
+ s num.names$ 'numnames :=
+ numnames 'namesleft :=
+ { namesleft #0 > }
+ { s nameptr
+ "{f.~}{vv~}{ll}{, jj}"
+ format.name$ 't :=
+ nameptr #1 >
+ {
+ namesleft #1 >
+ { ", " * t * }
+ {
+ numnames #2 >
+ { "," * }
+ 'skip$
+ if$
+ t "others" =
+ { " " * "et~al." emphasize * }
+ { " and " * t * }
+ if$
+ }
+ if$
+ }
+ 't
+ if$
+ nameptr #1 + 'nameptr :=
+ namesleft #1 - 'namesleft :=
+ }
+ while$
+}
+
+FUNCTION {format.key}
+{ empty$
+ { key field.or.null }
+ { "" }
+ if$
+}
+
+FUNCTION {format.authors}
+{ author empty$
+ { "" }
+ { author format.names }
+ if$
+}
+
+FUNCTION {format.editors}
+{ editor empty$
+ { "" }
+ { editor format.names
+ editor num.names$ #1 >
+ { ", editors" * }
+ { ", editor" * }
+ if$
+ }
+ if$
+}
+
+FUNCTION {format.in.editors}
+{ editor empty$
+ { "" }
+ { editor format.names.ed
+ editor num.names$ #1 >
+ { ", editors" * }
+ { ", editor" * }
+ if$
+ }
+ if$
+}
+
+FUNCTION {format.title}
+{ title empty$
+ { "" }
+ { title "t" change.case$
+ }
+ if$
+}
+
+FUNCTION {format.full.names}
+{'s :=
+ #1 'nameptr :=
+ s num.names$ 'numnames :=
+ numnames 'namesleft :=
+ { namesleft #0 > }
+ { s nameptr
+ "{vv~}{ll}" format.name$ 't :=
+ nameptr #1 >
+ {
+ namesleft #1 >
+ { ", " * t * }
+ {
+ numnames #2 >
+ { "," * }
+ 'skip$
+ if$
+ t "others" =
+ { " " * "et~al." emphasize * }
+ { " and " * t * }
+ if$
+ }
+ if$
+ }
+ 't
+ if$
+ nameptr #1 + 'nameptr :=
+ namesleft #1 - 'namesleft :=
+ }
+ while$
+}
+
+FUNCTION {author.editor.key.full}
+{ author empty$
+ { editor empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { editor format.full.names }
+ if$
+ }
+ { author format.full.names }
+ if$
+}
+
+FUNCTION {author.key.full}
+{ author empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { author format.full.names }
+ if$
+}
+
+FUNCTION {editor.key.full}
+{ editor empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { editor format.full.names }
+ if$
+}
+
+FUNCTION {make.full.names}
+{ type$ "book" =
+ type$ "inbook" =
+ or
+ 'author.editor.key.full
+ { type$ "proceedings" =
+ 'editor.key.full
+ 'author.key.full
+ if$
+ }
+ if$
+}
+
+FUNCTION {output.bibitem}
+{ newline$
+ "\bibitem[" write$
+ label write$
+ ")" make.full.names * "]{" * write$
+ cite$ write$
+ "}" write$
+ newline$
+ ""
+ before.all 'output.state :=
+}
+
+FUNCTION {n.dashify}
+{ 't :=
+ ""
+ { t empty$ not }
+ { t #1 #1 substring$ "-" =
+ { t #1 #2 substring$ "--" = not
+ { "--" *
+ t #2 global.max$ substring$ 't :=
+ }
+ { { t #1 #1 substring$ "-" = }
+ { "-" *
+ t #2 global.max$ substring$ 't :=
+ }
+ while$
+ }
+ if$
+ }
+ { t #1 #1 substring$ *
+ t #2 global.max$ substring$ 't :=
+ }
+ if$
+ }
+ while$
+}
+
+FUNCTION {word.in}
+{ "In " }
+
+FUNCTION {format.date}
+{ year duplicate$ empty$
+ { "empty year in " cite$ * "; set to ????" * warning$
+ pop$ "????" }
+ 'skip$
+ if$
+ before.all 'output.state :=
+ " (" swap$ * extra.label * ")" *
+}
+
+FUNCTION {format.btitle}
+{ title emphasize
+}
+
+FUNCTION {tie.or.space.connect}
+{ duplicate$ text.length$ #3 <
+ { "~" }
+ { " " }
+ if$
+ swap$ * *
+}
+
+FUNCTION {either.or.check}
+{ empty$
+ 'pop$
+ { "can't use both " swap$ * " fields in " * cite$ * warning$ }
+ if$
+}
+
+FUNCTION {format.bvolume}
+{ volume empty$
+ { "" }
+ { "volume" volume tie.or.space.connect
+ series empty$
+ 'skip$
+ { " of " * series emphasize * }
+ if$
+ "volume and number" number either.or.check
+ }
+ if$
+}
+
+FUNCTION {format.number.series}
+{ volume empty$
+ { number empty$
+ { series field.or.null }
+ { output.state mid.sentence =
+ { "number" }
+ { "Number" }
+ if$
+ number tie.or.space.connect
+ series empty$
+ { "there's a number but no series in " cite$ * warning$ }
+ { " in " * series * }
+ if$
+ }
+ if$
+ }
+ { "" }
+ if$
+}
+
+FUNCTION {format.edition}
+{ edition empty$
+ { "" }
+ { output.state mid.sentence =
+ { edition "l" change.case$ " edition" * }
+ { edition "t" change.case$ " edition" * }
+ if$
+ }
+ if$
+}
+
+INTEGERS { multiresult }
+
+FUNCTION {multi.page.check}
+{ 't :=
+ #0 'multiresult :=
+ { multiresult not
+ t empty$ not
+ and
+ }
+ { t #1 #1 substring$
+ duplicate$ "-" =
+ swap$ duplicate$ "," =
+ swap$ "+" =
+ or or
+ { #1 'multiresult := }
+ { t #2 global.max$ substring$ 't := }
+ if$
+ }
+ while$
+ multiresult
+}
+
+FUNCTION {format.pages}
+{ pages empty$
+ { "" }
+ { pages multi.page.check
+ { "pages" pages n.dashify tie.or.space.connect }
+ { "page" pages tie.or.space.connect }
+ if$
+ }
+ if$
+}
+
+FUNCTION {format.vol.num.pages}
+{ volume field.or.null
+ bolden
+ number empty$
+ 'skip$
+ { "(" number * ")" * *
+ volume empty$
+ { "there's a number but no volume in " cite$ * warning$ }
+ 'skip$
+ if$
+ }
+ if$
+ pages empty$
+ 'skip$
+ { duplicate$ empty$
+ { pop$ format.pages }
+ { ", " * pages n.dashify * }
+ if$
+ }
+ if$
+}
+
+FUNCTION {format.chapter.pages}
+{ chapter empty$
+ 'format.pages
+ { type empty$
+ { "chapter" }
+ { type "l" change.case$ }
+ if$
+ chapter tie.or.space.connect
+ pages empty$
+ 'skip$
+ { ", " * format.pages * }
+ if$
+ }
+ if$
+}
+
+FUNCTION {format.in.ed.booktitle}
+{ booktitle empty$
+ { "" }
+ { editor empty$
+ { word.in booktitle emphasize * }
+ { word.in format.in.editors * ", " * booktitle emphasize * }
+ if$
+ }
+ if$
+}
+
+FUNCTION {format.thesis.type}
+{ type empty$
+ 'skip$
+ { pop$
+ type "t" change.case$
+ }
+ if$
+}
+
+FUNCTION {format.tr.number}
+{ type empty$
+ { "Technical Report" }
+ 'type
+ if$
+ number empty$
+ { "t" change.case$ }
+ { number tie.or.space.connect }
+ if$
+}
+
+FUNCTION {format.article.crossref}
+{
+ word.in
+ "\cite{" * crossref * "}" *
+}
+
+FUNCTION {format.book.crossref}
+{ volume empty$
+ { "empty volume in " cite$ * "'s crossref of " * crossref * warning$
+ word.in
+ }
+ { "Volume" volume tie.or.space.connect
+ " of " *
+ }
+ if$
+ "\cite{" * crossref * "}" *
+}
+
+FUNCTION {format.incoll.inproc.crossref}
+{
+ word.in
+ "\cite{" * crossref * "}" *
+}
+
+FUNCTION {article}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.title "title" output.check
+ new.block
+ crossref missing$
+ { journal emphasize "journal" output.check
+ format.vol.num.pages output
+ }
+ { format.article.crossref output.nonnull
+ format.pages output
+ }
+ if$
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {book}
+{ output.bibitem
+ author empty$
+ { format.editors "author and editor" output.check
+ editor format.key output
+ }
+ { format.authors output.nonnull
+ crossref missing$
+ { "author and editor" editor either.or.check }
+ 'skip$
+ if$
+ }
+ if$
+ format.date "year" output.check
+ new.block
+ format.btitle "title" output.check
+ crossref missing$
+ { format.bvolume output
+ new.block
+ format.number.series output
+ new.sentence
+ publisher "publisher" output.check
+ address output
+ }
+ {
+ new.block
+ format.book.crossref output.nonnull
+ }
+ if$
+ format.edition output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {booklet}
+{ output.bibitem
+ format.authors output
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.title "title" output.check
+ new.block
+ howpublished output
+ address output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {inbook}
+{ output.bibitem
+ author empty$
+ { format.editors "author and editor" output.check
+ editor format.key output
+ }
+ { format.authors output.nonnull
+ crossref missing$
+ { "author and editor" editor either.or.check }
+ 'skip$
+ if$
+ }
+ if$
+ format.date "year" output.check
+ new.block
+ format.btitle "title" output.check
+ crossref missing$
+ { format.bvolume output
+ format.chapter.pages "chapter and pages" output.check
+ new.block
+ format.number.series output
+ new.sentence
+ publisher "publisher" output.check
+ address output
+ }
+ { format.chapter.pages "chapter and pages" output.check
+ new.block
+ format.book.crossref output.nonnull
+ }
+ if$
+ format.edition output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {incollection}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.title "title" output.check
+ new.block
+ crossref missing$
+ { format.in.ed.booktitle "booktitle" output.check
+ format.bvolume output
+ format.number.series output
+ format.chapter.pages output
+ new.sentence
+ publisher "publisher" output.check
+ address output
+ format.edition output
+ }
+ { format.incoll.inproc.crossref output.nonnull
+ format.chapter.pages output
+ }
+ if$
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {inproceedings}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.title "title" output.check
+ new.block
+ crossref missing$
+ { format.in.ed.booktitle "booktitle" output.check
+ format.bvolume output
+ format.number.series output
+ format.pages output
+ address output
+ new.sentence
+ organization output
+ publisher output
+ }
+ { format.incoll.inproc.crossref output.nonnull
+ format.pages output
+ }
+ if$
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {conference} { inproceedings }
+
+FUNCTION {manual}
+{ output.bibitem
+ format.authors output
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.btitle "title" output.check
+ organization address new.block.checkb
+ organization output
+ address output
+ format.edition output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {mastersthesis}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.btitle "title" output.check
+ new.block
+ "Master's thesis" format.thesis.type output.nonnull
+ school "school" output.check
+ address output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {misc}
+{ output.bibitem
+ format.authors output
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.title output
+ new.block
+ howpublished output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {phdthesis}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.btitle "title" output.check
+ new.block
+ "Ph.D. thesis" format.thesis.type output.nonnull
+ school "school" output.check
+ address output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {proceedings}
+{ output.bibitem
+ format.editors output
+ editor format.key output
+ format.date "year" output.check
+ new.block
+ format.btitle "title" output.check
+ format.bvolume output
+ format.number.series output
+ address output
+ new.sentence
+ organization output
+ publisher output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {techreport}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.title "title" output.check
+ new.block
+ format.tr.number output.nonnull
+ institution "institution" output.check
+ address output
+ new.block
+ note output
+ fin.entry
+}
+
+FUNCTION {unpublished}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ new.block
+ format.title "title" output.check
+ new.block
+ note "note" output.check
+ fin.entry
+}
+
+FUNCTION {default.type} { misc }
+
+MACRO {jan} {"January"}
+
+MACRO {feb} {"February"}
+
+MACRO {mar} {"March"}
+
+MACRO {apr} {"April"}
+
+MACRO {may} {"May"}
+
+MACRO {jun} {"June"}
+
+MACRO {jul} {"July"}
+
+MACRO {aug} {"August"}
+
+MACRO {sep} {"September"}
+
+MACRO {oct} {"October"}
+
+MACRO {nov} {"November"}
+
+MACRO {dec} {"December"}
+
+MACRO {acmcs} {"ACM Computing Surveys"}
+
+MACRO {acta} {"Acta Informatica"}
+
+MACRO {cacm} {"Communications of the ACM"}
+
+MACRO {ibmjrd} {"IBM Journal of Research and Development"}
+
+MACRO {ibmsj} {"IBM Systems Journal"}
+
+MACRO {ieeese} {"IEEE Transactions on Software Engineering"}
+
+MACRO {ieeetc} {"IEEE Transactions on Computers"}
+
+MACRO {ieeetcad}
+ {"IEEE Transactions on Computer-Aided Design of Integrated Circuits"}
+
+MACRO {ipl} {"Information Processing Letters"}
+
+MACRO {jacm} {"Journal of the ACM"}
+
+MACRO {jcss} {"Journal of Computer and System Sciences"}
+
+MACRO {scp} {"Science of Computer Programming"}
+
+MACRO {sicomp} {"SIAM Journal on Computing"}
+
+MACRO {tocs} {"ACM Transactions on Computer Systems"}
+
+MACRO {tods} {"ACM Transactions on Database Systems"}
+
+MACRO {tog} {"ACM Transactions on Graphics"}
+
+MACRO {toms} {"ACM Transactions on Mathematical Software"}
+
+MACRO {toois} {"ACM Transactions on Office Information Systems"}
+
+MACRO {toplas} {"ACM Transactions on Programming Languages and Systems"}
+
+MACRO {tcs} {"Theoretical Computer Science"}
+
+READ
+
+FUNCTION {sortify}
+{ purify$
+ "l" change.case$
+}
+
+INTEGERS { len }
+
+FUNCTION {chop.word}
+{ 's :=
+ 'len :=
+ s #1 len substring$ =
+ { s len #1 + global.max$ substring$ }
+ 's
+ if$
+}
+
+FUNCTION {format.lab.names}
+{ 's :=
+ s #1 "{vv~}{ll}" format.name$
+ s num.names$ duplicate$
+ #2 >
+ { pop$ " " * "et~al." emphasize * }
+ { #2 <
+ 'skip$
+ { s #2 "{ff }{vv }{ll}{ jj}" format.name$ "others" =
+ { " " * "et~al." emphasize * }
+ { " and " * s #2 "{vv~}{ll}" format.name$ * }
+ if$
+ }
+ if$
+ }
+ if$
+}
+
+FUNCTION {author.key.label}
+{ author empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { author format.lab.names }
+ if$
+}
+
+FUNCTION {author.editor.key.label}
+{ author empty$
+ { editor empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { editor format.lab.names }
+ if$
+ }
+ { author format.lab.names }
+ if$
+}
+
+FUNCTION {editor.key.label}
+{ editor empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { editor format.lab.names }
+ if$
+}
+
+FUNCTION {calc.label}
+{ type$ "book" =
+ type$ "inbook" =
+ or
+ 'author.editor.key.label
+ { type$ "proceedings" =
+ 'editor.key.label
+ 'author.key.label
+ if$
+ }
+ if$
+ "("
+ *
+ year duplicate$ empty$
+ { pop$ "????" }
+ { purify$ #-1 #4 substring$ }
+ if$
+ *
+ 'label :=
+}
+
+FUNCTION {sort.format.names}
+{ 's :=
+ #1 'nameptr :=
+ ""
+ s num.names$ 'numnames :=
+ numnames 'namesleft :=
+ { namesleft #0 > }
+ { nameptr #1 >
+ { " " * }
+ 'skip$
+ if$
+ s nameptr
+ "{vv{ } }{ll{ }}{ f{ }}{ jj{ }}"
+ format.name$ 't :=
+ nameptr numnames = t "others" = and
+ { "et al" * }
+ { numnames #2 > nameptr #2 = and
+ { "zzzzzz" * #1 'namesleft := }
+ { t sortify * }
+ if$
+ }
+ if$
+ nameptr #1 + 'nameptr :=
+ namesleft #1 - 'namesleft :=
+ }
+ while$
+}
+
+FUNCTION {sort.format.title}
+{ 't :=
+ "A " #2
+ "An " #3
+ "The " #4 t chop.word
+ chop.word
+ chop.word
+ sortify
+ #1 global.max$ substring$
+}
+
+FUNCTION {author.sort}
+{ author empty$
+ { key empty$
+ { "to sort, need author or key in " cite$ * warning$
+ ""
+ }
+ { key sortify }
+ if$
+ }
+ { author sort.format.names }
+ if$
+}
+
+FUNCTION {author.editor.sort}
+{ author empty$
+ { editor empty$
+ { key empty$
+ { "to sort, need author, editor, or key in " cite$ * warning$
+ ""
+ }
+ { key sortify }
+ if$
+ }
+ { editor sort.format.names }
+ if$
+ }
+ { author sort.format.names }
+ if$
+}
+
+FUNCTION {editor.sort}
+{ editor empty$
+ { key empty$
+ { "to sort, need editor or key in " cite$ * warning$
+ ""
+ }
+ { key sortify }
+ if$
+ }
+ { editor sort.format.names }
+ if$
+}
+
+FUNCTION {presort}
+{ calc.label
+ label sortify
+ " "
+ *
+ type$ "book" =
+ type$ "inbook" =
+ or
+ 'author.editor.sort
+ { type$ "proceedings" =
+ 'editor.sort
+ 'author.sort
+ if$
+ }
+ if$
+ #1 entry.max$ substring$
+ 'sort.label :=
+ sort.label
+ *
+ " "
+ *
+ title field.or.null
+ sort.format.title
+ *
+ #1 entry.max$ substring$
+ 'sort.key$ :=
+}
+
+ITERATE {presort}
+
+SORT
+
+STRINGS { last.label next.extra }
+
+INTEGERS { last.extra.num }
+
+FUNCTION {initialize.extra.label.stuff}
+{ #0 int.to.chr$ 'last.label :=
+ "" 'next.extra :=
+ #0 'last.extra.num :=
+}
+
+FUNCTION {forward.pass}
+{ last.label label =
+ { last.extra.num #1 + 'last.extra.num :=
+ last.extra.num int.to.chr$ 'extra.label :=
+ }
+ { "a" chr.to.int$ 'last.extra.num :=
+ "" 'extra.label :=
+ label 'last.label :=
+ }
+ if$
+}
+
+FUNCTION {reverse.pass}
+{ next.extra "b" =
+ { "a" 'extra.label := }
+ 'skip$
+ if$
+ extra.label 'next.extra :=
+ label extra.label * 'label :=
+}
+
+EXECUTE {initialize.extra.label.stuff}
+
+ITERATE {forward.pass}
+
+REVERSE {reverse.pass}
+
+FUNCTION {bib.sort.order}
+{ sort.label
+ " "
+ *
+ year field.or.null sortify
+ *
+ " "
+ *
+ title field.or.null
+ sort.format.title
+ *
+ #1 entry.max$ substring$
+ 'sort.key$ :=
+}
+
+ITERATE {bib.sort.order}
+
+SORT
+
+FUNCTION {begin.bib}
+{ preamble$ empty$
+ 'skip$
+ { preamble$ write$ newline$ }
+ if$
+ "\begin{thebibliography}{}" write$ newline$
+}
+
+EXECUTE {begin.bib}
+
+EXECUTE {init.state.consts}
+
+ITERATE {call.type$}
+
+FUNCTION {end.bib}
+{ newline$
+ "\end{thebibliography}" write$ newline$
+}
+
+EXECUTE {end.bib}
+%% End of customized bst file
+
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-med/r-cran-pscbs.git
More information about the debian-med-commit
mailing list