[med-svn] [r-cran-nmf] 01/03: Imported Upstream version 0.20.6
Alba Crespi
albac-guest at moszumanska.debian.org
Sat Apr 9 23:03:54 UTC 2016
This is an automated email from the git hooks/post-receive script.
albac-guest pushed a commit to branch master
in repository r-cran-nmf.
commit 0d93457070bc7f134924b1ca9b3a176ebad0f0d5
Author: Alba Crespi <crespialba+debian at gmail.com>
Date: Sat Apr 9 23:42:48 2016 +0100
Imported Upstream version 0.20.6
---
.Rinstignore | 1 +
DESCRIPTION | 46 +
MD5 | 231 ++
NAMESPACE | 233 ++
NEWS | 622 +++++
R/Bioc-layer.R | 320 +++
R/NMF-class.R | 2562 +++++++++++++++++++++
R/NMFOffset-class.R | 165 ++
R/NMFSeed-class.R | 90 +
R/NMFSet-class.R | 1943 ++++++++++++++++
R/NMFStrategy-class.R | 419 ++++
R/NMFStrategyFunction-class.R | 69 +
R/NMFStrategyIterative-class.R | 960 ++++++++
R/NMFStrategyOctave-class.R | 150 ++
R/NMFfit-class.R | 734 ++++++
R/NMFns-class.R | 174 ++
R/NMFplots.R | 645 ++++++
R/NMFstd-class.R | 227 ++
R/aheatmap.R | 2168 ++++++++++++++++++
R/algorithmic.R | 191 ++
R/algorithms-base.R | 514 +++++
R/algorithms-brunet.R | 29 +
R/algorithms-lnmf.R | 87 +
R/algorithms-lsnmf.R | 94 +
R/algorithms-pe-nmf.R | 68 +
R/algorithms-siNMF.R | 122 +
R/algorithms-snmf.R | 678 ++++++
R/atracks.R | 536 +++++
R/colorcode.R | 238 ++
R/data.R | 61 +
R/extractFeatures.R | 389 ++++
R/fixed-terms.R | 376 +++
R/grid.R | 72 +
R/heatmaps.R | 541 +++++
R/nmf-package.R | 178 ++
R/nmf.R | 2898 ++++++++++++++++++++++++
R/nmfModel.R | 765 +++++++
R/options.R | 162 ++
R/parallel.R | 1241 ++++++++++
R/registry-algorithms.R | 453 ++++
R/registry-seed.R | 127 ++
R/registry.R | 96 +
R/rmatrix.R | 137 ++
R/rnmf.R | 368 +++
R/run.R | 68 +
R/seed-base.R | 13 +
R/seed-ica.R | 40 +
R/seed-nndsvd.R | 131 ++
R/setNMFClass.R | 52 +
R/simulation.R | 152 ++
R/tests.R | 45 +
R/transforms.R | 256 +++
R/utils.R | 1058 +++++++++
R/versions.R | 197 ++
README.md | 29 +
TODO | 18 +
build/vignette.rds | Bin 0 -> 355 bytes
data/esGolub.rda | Bin 0 -> 294808 bytes
demo/00Index | 3 +
demo/aheatmap.R | 61 +
demo/heatmaps.R | 25 +
demo/nmf.R | 163 ++
inst/CITATION | 50 +
inst/REFERENCES.bib | 380 ++++
inst/doc/NMF-unitTests.R | 9 +
inst/doc/NMF-unitTests.Rnw | 188 ++
inst/doc/NMF-unitTests.pdf | Bin 0 -> 105651 bytes
inst/doc/NMF-vignette.R | 503 ++++
inst/doc/NMF-vignette.Rnw | 1305 +++++++++++
inst/doc/NMF-vignette.pdf | Bin 0 -> 502364 bytes
inst/doc/consensus.pdf | Bin 0 -> 12107 bytes
inst/doc/heatmaps.R | 145 ++
inst/doc/heatmaps.Rnw | 481 ++++
inst/doc/heatmaps.pdf | Bin 0 -> 415144 bytes
inst/m-files/brunet-run.m | 38 +
inst/m-files/brunet.R | 118 +
inst/m-files/brunet.m | 198 ++
inst/scripts/grid.R | 60 +
inst/scripts/report.Rmd | 91 +
inst/tests/runit.NMFSet.r | 154 ++
inst/tests/runit.NMFStrategy-class.r | 114 +
inst/tests/runit.NMFclass.r | 922 ++++++++
inst/tests/runit.NMFfit-class.r | 161 ++
inst/tests/runit.aheatmap.R | 22 +
inst/tests/runit.algorithms.r | 277 +++
inst/tests/runit.bioc.r | 34 +
inst/tests/runit.distance.r | 76 +
inst/tests/runit.interface.r | 997 ++++++++
inst/tests/runit.options.r | 47 +
inst/tests/runit.parallel.r | 305 +++
inst/tests/runit.seed.r | 252 +++
inst/tests/runit.utils.r | 110 +
man/Frobenius-nmf.Rd | 143 ++
man/KL-nmf.Rd | 174 ++
man/NMF-class.Rd | 474 ++++
man/NMF-defunct.Rd | 38 +
man/NMF-deprecated.Rd | 12 +
man/NMF-package.Rd | 46 +
man/NMFList-class.Rd | 42 +
man/NMFOffset-class.Rd | 125 +
man/NMFSeed-class.Rd | 46 +
man/NMFStrategy-class.Rd | 135 ++
man/NMFStrategy.Rd | 181 ++
man/NMFStrategyFunction-class.Rd | 53 +
man/NMFStrategyIterative-class.Rd | 71 +
man/NMFStrategyOctave-class.Rd | 66 +
man/NMFfit-class.Rd | 327 +++
man/NMFfitX-class.Rd | 189 ++
man/NMFfitX.Rd | 48 +
man/NMFfitX1-class.Rd | 115 +
man/NMFfitXn-class.Rd | 185 ++
man/NMFns-class.Rd | 135 ++
man/NMFstd-class.Rd | 186 ++
man/RNG.Rd | 75 +
man/SNMF-nmf.Rd | 80 +
man/Strategy-class.Rd | 73 +
man/advanced.Rd | 25 +
man/aheatmap.Rd | 373 +++
man/algorithm-commaNMFList-method.Rd | 27 +
man/algorithm-commaNMFStrategyOctave-method.Rd | 23 +
man/algorithmic.Rd | 428 ++++
man/assess.Rd | 137 ++
man/atrack.Rd | 144 ++
man/basis-coef-methods.Rd | 343 +++
man/basiscor.Rd | 117 +
man/bioc.Rd | 39 +
man/c-commaNMF-method.Rd | 31 +
man/canFit.Rd | 53 +
man/ccBreaks.Rd | 12 +
man/ccPalette.Rd | 11 +
man/ccRamp.Rd | 11 +
man/ccSpec.Rd | 17 +
man/checkErrors.Rd | 17 +
man/cluster_mat.Rd | 33 +
man/connectivity.Rd | 141 ++
man/consensus-commaNMFfitX1-method.Rd | 24 +
man/consensus-commaNMFfitXn-method.Rd | 31 +
man/consensushc.Rd | 62 +
man/cophcor.Rd | 69 +
man/cutdendro.Rd | 16 +
man/deviance.Rd | 100 +
man/dimnames.Rd | 164 ++
man/dims.Rd | 95 +
man/dispersion.Rd | 62 +
man/dot-fcnnls.Rd | 63 +
man/esGolub.Rd | 81 +
man/fcnnls.Rd | 169 ++
man/fit.Rd | 123 +
man/fitted.Rd | 120 +
man/foreach.Rd | 164 ++
man/gfile.Rd | 11 +
man/grid.Rd | 44 +
man/heatmaps.Rd | 413 ++++
man/inplace.Rd | 42 +
man/lsNMF-nmf.Rd | 87 +
man/lverbose.Rd | 17 +
man/match_atrack.Rd | 19 +
man/nmf-compare.Rd | 189 ++
man/nmf.Rd | 795 +++++++
man/nmf.equal.Rd | 121 +
man/nmfAlgorithm.Rd | 66 +
man/nmfApply.Rd | 76 +
man/nmfCheck.Rd | 41 +
man/nmfEstimateRank.Rd | 198 ++
man/nmfFormals.Rd | 33 +
man/nmfModel.Rd | 454 ++++
man/nmfObject.Rd | 26 +
man/nmfReport.Rd | 58 +
man/nmfSeed.Rd | 79 +
man/nmfWrapper.Rd | 73 +
man/nmf_update_KL.Rd | 89 +
man/nmf_update_euclidean.Rd | 99 +
man/nneg.Rd | 198 ++
man/nsNMF-nmf.Rd | 121 +
man/objective-commaNMFfit-method.Rd | 24 +
man/offset-commaNMFOffset-method.Rd | 17 +
man/offset-commaNMFfit-method.Rd | 15 +
man/offset-nmf.Rd | 146 ++
man/options.Rd | 144 ++
man/parallel.Rd | 77 +
man/parse_formula.Rd | 21 +
man/plot-commaNMFfit-commamissing-method.Rd | 55 +
man/predict.Rd | 149 ++
man/profplot.Rd | 124 +
man/purity.Rd | 173 ++
man/randomize.Rd | 39 +
man/registry-algorithm.Rd | 64 +
man/residuals.Rd | 110 +
man/revPalette.Rd | 11 +
man/rmatrix.Rd | 153 ++
man/rnmf.Rd | 395 ++++
man/rss.Rd | 140 ++
man/runtime-commaNMFList-method.Rd | 25 +
man/runtime.all-commaNMFfitXn-method.Rd | 29 +
man/scale.NMF.Rd | 75 +
man/scores.Rd | 234 ++
man/seed.Rd | 113 +
man/setNMFMethod.Rd | 54 +
man/setNMFSeed.Rd | 72 +
man/setup.Rd | 82 +
man/show-commaNMF-method.Rd | 15 +
man/show-commaNMFList-method.Rd | 15 +
man/show-commaNMFOffset-method.Rd | 15 +
man/show-commaNMFSeed-method.Rd | 15 +
man/show-commaNMFStrategyIterative-method.Rd | 16 +
man/show-commaNMFfit-method.Rd | 15 +
man/show-commaNMFfitX-method.Rd | 15 +
man/show-commaNMFfitX1-method.Rd | 15 +
man/show-commaNMFfitXn-method.Rd | 15 +
man/show-commaNMFns-method.Rd | 15 +
man/silhouette.NMF.Rd | 81 +
man/smoothing.Rd | 39 +
man/sparseness.Rd | 81 +
man/staticVar.Rd | 31 +
man/stop-NMF.Rd | 136 ++
man/subset-NMF.Rd | 146 ++
man/syntheticNMF.Rd | 91 +
man/t.NMF.Rd | 41 +
man/terms-internal.Rd | 49 +
man/terms.Rd | 120 +
man/txtProgressBar.Rd | 56 +
man/types.Rd | 149 ++
man/utils.Rd | 28 +
src/distance.cpp | 166 ++
src/divergence.cpp | 218 ++
src/euclidean.cpp | 388 ++++
src/utils.cpp | 276 +++
tests/doRUnit.R | 62 +
vignettes/.install_extras | 1 +
vignettes/NMF-unitTests.Rnw | 188 ++
vignettes/NMF-vignette.Rnw | 1305 +++++++++++
vignettes/consensus.pdf | 2745 ++++++++++++++++++++++
vignettes/heatmaps.Rnw | 481 ++++
vignettes/src/bmc.R | 47 +
234 files changed, 50838 insertions(+)
diff --git a/.Rinstignore b/.Rinstignore
new file mode 100644
index 0000000..14a113a
--- /dev/null
+++ b/.Rinstignore
@@ -0,0 +1 @@
+vignettes/cleveref.sty
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..60dad34
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,46 @@
+Package: NMF
+Type: Package
+Title: Algorithms and Framework for Nonnegative Matrix Factorization
+ (NMF)
+Version: 0.20.6
+Date: 2015-05-25
+Author: Renaud Gaujoux, Cathal Seoighe
+Maintainer: Renaud Gaujoux <renaud at tx.technion.ac.il>
+Description: Provides a framework to perform Non-negative Matrix
+ Factorization (NMF). The package implements a set of already published algorithms
+ and seeding methods, and provides a framework to test, develop and plug
+ new/custom algorithms. Most of the built-in algorithms have been optimized
+ in C++, and the main interface function provides an easy way of performing
+ parallel computations on multicore machines.
+License: GPL (>= 2)
+URL: http://renozao.github.io/NMF
+BugReports: http://github.com/renozao/NMF/issues
+SCM: github:renozao, r-forge
+LazyLoad: yes
+VignetteBuilder: knitr
+Depends: R (>= 3.0.0), methods, utils, pkgmaker (>= 0.20), registry,
+ rngtools (>= 1.2.3), cluster
+Imports: graphics, stats, stringr (>= 1.0.0), digest, grid, grDevices,
+ gridBase, colorspace, RColorBrewer, foreach, doParallel,
+ ggplot2, reshape2
+Suggests: RcppOctave (>= 0.11), fastICA, doMPI, bigmemory (>= 4.2),
+ synchronicity, corpcor, xtable, devtools, knitr, bibtex, RUnit,
+ mail, Biobase
+Collate: 'rmatrix.R' 'nmf-package.R' 'utils.R' 'versions.R'
+ 'algorithmic.R' 'options.R' 'grid.R' 'colorcode.R' 'atracks.R'
+ 'aheatmap.R' 'NMF-class.R' 'transforms.R' 'Bioc-layer.R'
+ 'NMFstd-class.R' 'NMFOffset-class.R' 'registry.R' 'heatmaps.R'
+ 'NMFns-class.R' 'nmfModel.R' 'fixed-terms.R' 'NMFfit-class.R'
+ 'NMFSet-class.R' 'NMFStrategy-class.R' 'NMFSeed-class.R'
+ 'NMFStrategyFunction-class.R' 'NMFStrategyIterative-class.R'
+ 'NMFStrategyOctave-class.R' 'NMFplots.R'
+ 'registry-algorithms.R' 'algorithms-base.R'
+ 'algorithms-brunet.R' 'algorithms-lnmf.R' 'algorithms-lsnmf.R'
+ 'algorithms-pe-nmf.R' 'algorithms-siNMF.R' 'algorithms-snmf.R'
+ 'data.R' 'extractFeatures.R' 'registry-seed.R' 'parallel.R'
+ 'nmf.R' 'rnmf.R' 'run.R' 'seed-base.R' 'seed-ica.R'
+ 'seed-nndsvd.R' 'setNMFClass.R' 'simulation.R' 'tests.R'
+Packaged: 2015-05-25 21:34:47 UTC; renaud
+NeedsCompilation: yes
+Repository: CRAN
+Date/Publication: 2015-05-26 08:12:33
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..a71df70
--- /dev/null
+++ b/MD5
@@ -0,0 +1,231 @@
+9b3d758eef59f0fa3d3934f7012d8ae3 *DESCRIPTION
+dc463bcaef88f72ce59f851dcea117db *NAMESPACE
+192be80e51d0299e5f0e915bb8f1a19e *NEWS
+04f33b56f5ccb3f8668c07e3d9aaa7c3 *R/Bioc-layer.R
+67be79625bdfdd06e76bb2787a9f436d *R/NMF-class.R
+cb92fbe2ad8ed07d3b6988790361cf89 *R/NMFOffset-class.R
+56c06d6a59b72229d6fed8139b5917e1 *R/NMFSeed-class.R
+a6e1c940afa9605ea59dd22fdedb30d7 *R/NMFSet-class.R
+4d669da42d6a80c8935da68991d5cfec *R/NMFStrategy-class.R
+7c005d6fc277f6c4f194b3be145e9e11 *R/NMFStrategyFunction-class.R
+952c6d74fe3200647696bd1755707cf8 *R/NMFStrategyIterative-class.R
+9057be72901f4081ffd36dff90064e0c *R/NMFStrategyOctave-class.R
+9bfd9b9a7f095d2d23aad3192c7dad93 *R/NMFfit-class.R
+d4a9ccb2a64df0fcc003732b22087b29 *R/NMFns-class.R
+43617bc2d80d2df2fa79aac76e6877f4 *R/NMFplots.R
+06ce7f9fb62284b85f8faea26cd9bc08 *R/NMFstd-class.R
+b93c44a16dcada0f9afbdabd898c0294 *R/aheatmap.R
+2215efb3fafbbae155830aed6b0b3ae1 *R/algorithmic.R
+5c93753b2b401fd5b8c80b592f93193d *R/algorithms-base.R
+bc346e375c98c41a03c3ae745b5dbdf9 *R/algorithms-brunet.R
+015a5cef7738322d66ae1f280225f9e6 *R/algorithms-lnmf.R
+6600c764faf7481013e0d6481fc25151 *R/algorithms-lsnmf.R
+ff9c9ac7006e8ef914ddb1d883316cbb *R/algorithms-pe-nmf.R
+c7345e2125689ff69487338672fead40 *R/algorithms-siNMF.R
+512da544843f613eeb487c24e73095ce *R/algorithms-snmf.R
+eca172be180d1e51dec38a7aaab54bee *R/atracks.R
+04c8a4c2f078a8327a068943eef561d6 *R/colorcode.R
+7872d34875136dc2b2e8c1875ce2caa7 *R/data.R
+d5c1883b5350a8285e19c2772ceb50d8 *R/extractFeatures.R
+ec3cfef0d083ed95661a6c57bd61e660 *R/fixed-terms.R
+1f90bca8a7b53737476d0956b55502ab *R/grid.R
+5cf50ed45523796cab2a7a9533fd6981 *R/heatmaps.R
+8ae4dc88757079df32de4d541247444c *R/nmf-package.R
+8cb380f3596ae6bd5f7bd26cfc6dbbdf *R/nmf.R
+b0ef416f59a1be65a4409b9af8d4b9e0 *R/nmfModel.R
+b775850b0cf2d25c9d4f674298030b3a *R/options.R
+4888147bee54949ca191fa91cb17d668 *R/parallel.R
+8ea29d577c7c4e8f8b4dc34ba4421da4 *R/registry-algorithms.R
+bd61f889b0bb039c703a7de9898e5fbc *R/registry-seed.R
+66ca4afe8515dedd71d07dc05bbcc4d7 *R/registry.R
+c28c1144175993becd60f5a16156a3e2 *R/rmatrix.R
+b1d44e778d211021bc1754e90551c7c5 *R/rnmf.R
+373909c677f0e1db2301f30638145a13 *R/run.R
+dd767a7d1fde7adfe30b3fee7cf86f5b *R/seed-base.R
+1fcf1d8cb6162329731c7dd6d02c8a97 *R/seed-ica.R
+5ae81c6a61fc0e16090acde2f16da5d4 *R/seed-nndsvd.R
+71bf9f5ea7e161d5b3604040e37785ad *R/setNMFClass.R
+5017945c10bf9b95560568b58c90559a *R/simulation.R
+610b78f4f8f21a5a85d97967e4577bc8 *R/tests.R
+4d204e4cda9cdcb86f26bc220e0c3408 *R/transforms.R
+ce8005200ba770a584eab5ae7f703bb9 *R/utils.R
+77bc2b9255b6a8b6044e67e08ec91284 *R/versions.R
+ca5b072a375cfc90d9a1b8530a2159dc *README.md
+551e2ca0a05eff9062c105483449fac4 *TODO
+7ce651165cacaa2ee6b9dc93f0238d35 *build/vignette.rds
+f8015e2bc710fb0bf869d2fdddf90e73 *data/esGolub.rda
+7ee636d67aaf85d2b38c87f512559c1d *demo/00Index
+5d230c7b9bd8450e8f3621f0fa2e8fe9 *demo/aheatmap.R
+1772a84edd497138e1c2026608d99348 *demo/heatmaps.R
+51502b8ceeab50a22383047790cc5ab6 *demo/nmf.R
+64e0559e3860021948647aaa5f831499 *inst/CITATION
+c4d05e519580e330b6c7693b18650773 *inst/REFERENCES.bib
+b8685571f46f595488cf8a6811e5a748 *inst/doc/NMF-unitTests.R
+888e8d888eefa87589a5d1846a1b4dea *inst/doc/NMF-unitTests.Rnw
+4721c186b35c1cb974b8a57aa56e02c5 *inst/doc/NMF-unitTests.pdf
+11cdd75b60fc3577bf8e22c73c717cf1 *inst/doc/NMF-vignette.R
+d3a631ff66077530b722b7c779263367 *inst/doc/NMF-vignette.Rnw
+c8ca9dd04271005e6e8253264380d26b *inst/doc/NMF-vignette.pdf
+490308526e45334c1526083977dce954 *inst/doc/consensus.pdf
+5a53da6ca7bf0ae84bae0e8e4ff5984b *inst/doc/heatmaps.R
+117e593dae265395cc28634365848af2 *inst/doc/heatmaps.Rnw
+fb507f8eb6151f14de9b14a629c5d483 *inst/doc/heatmaps.pdf
+8228eb196a5735d46af06c261500aa04 *inst/m-files/brunet-run.m
+7b784dfee92d29634fe40f0270a01946 *inst/m-files/brunet.R
+aa0bc4166c0c05507a5fb0a85d3c16a8 *inst/m-files/brunet.m
+21a62ee5e50af50c0b22f88d167d068c *inst/scripts/grid.R
+2952972c46324b0beb29d6892b7e2e40 *inst/scripts/report.Rmd
+ede84a7c14827aaf8388753d3782649b *inst/tests/runit.NMFSet.r
+185a0cc2211506feff114fa1f7720e1f *inst/tests/runit.NMFStrategy-class.r
+73ca1b2198fc6359c11cb0e247047bfc *inst/tests/runit.NMFclass.r
+ba38b9bbe7cb50d383f2f9fb021a6d82 *inst/tests/runit.NMFfit-class.r
+c2fe5109fe6867bec03df76785b4a143 *inst/tests/runit.aheatmap.R
+69fb12d4a21c13d82b43f472d60adb5f *inst/tests/runit.algorithms.r
+d989ecfa90aef8cc16a84520fb3763f4 *inst/tests/runit.bioc.r
+f252a885bbb0046bd55e59fbd511888b *inst/tests/runit.distance.r
+3ac992c6681a6d2f7b014904db460648 *inst/tests/runit.interface.r
+59b288c96a3b2803f83d5a46c0d0b688 *inst/tests/runit.options.r
+03df1801f20a8612f71db7cb65772c55 *inst/tests/runit.parallel.r
+a628ceb384967f4f6575999bc1bc6b07 *inst/tests/runit.seed.r
+4fc04c7ba5d73eb1b804a9d25c436a3f *inst/tests/runit.utils.r
+767832f7e470c4704f4b7602d23a7798 *man/Frobenius-nmf.Rd
+63e0ab27b3b800565fa15751c0a46301 *man/KL-nmf.Rd
+d60a89e51d4ba938cb32ad04a2b07b85 *man/NMF-class.Rd
+3afb15f1474a46e4086d736a3c871caf *man/NMF-defunct.Rd
+dc30d7f32eb6954c2e9aa946f8b9df26 *man/NMF-deprecated.Rd
+116f36bf4cbaa1765e2fbe3c83862b58 *man/NMF-package.Rd
+06d347a23a138dccfd978daa81ea0e1b *man/NMFList-class.Rd
+201bfce1ddf5c18da7ac1bfe67ffb94f *man/NMFOffset-class.Rd
+425940f01b128ed86c081405ae146ab0 *man/NMFSeed-class.Rd
+895c97e9785c890a0181e953407ad117 *man/NMFStrategy-class.Rd
+78a5599bceeaad4bfce2d04ce03c8a21 *man/NMFStrategy.Rd
+5c94b9595c875433cb19171da1a62758 *man/NMFStrategyFunction-class.Rd
+18cd07fb2cccaa6d2600fefe5c47b7a9 *man/NMFStrategyIterative-class.Rd
+d961a29bd12aeeb4f39e476040e1a795 *man/NMFStrategyOctave-class.Rd
+3092af863a3f6a9b76f3f2f6fe769335 *man/NMFfit-class.Rd
+83e8b4200bb4ae294f0ded0ae6d6e70c *man/NMFfitX-class.Rd
+d9a31d45444d62f906d662fc8b265426 *man/NMFfitX.Rd
+634317c04783c19ed9ac96e8ad80ebba *man/NMFfitX1-class.Rd
+9d50da90ee74c75a432a7cd900578c0f *man/NMFfitXn-class.Rd
+f874ba9928c02022df7d9c8a2ac5bd4d *man/NMFns-class.Rd
+0af573b61066884e29f8152d8295575b *man/NMFstd-class.Rd
+96b321036e3c998e4e52ee730e5884c5 *man/RNG.Rd
+8b66c7ab49c34b0e5df0c652d45d437f *man/SNMF-nmf.Rd
+42afa8e2c6f5d7ac5c045174a05bf8d5 *man/Strategy-class.Rd
+28877eb83332222d0a67473a16148fbc *man/advanced.Rd
+7765d6e9380a12d8f5c6a0d838c3c41e *man/aheatmap.Rd
+762c9a6fd51a723065df7becaa801083 *man/algorithm-commaNMFList-method.Rd
+23b560ee5c0e22253100cd1f8effe26b *man/algorithm-commaNMFStrategyOctave-method.Rd
+54d030b5f5822647ddfdb8e731b91afe *man/algorithmic.Rd
+9c3697730dd0a7aea87f13af6f726812 *man/assess.Rd
+20413d9a4e878340f471a26415386685 *man/atrack.Rd
+a4855c2e0d6ece887e5e6b7fb27d640c *man/basis-coef-methods.Rd
+435ac6f77719a0d9a5a18994c40989c1 *man/basiscor.Rd
+1810d6750bc88981b602808d9f673c4a *man/bioc.Rd
+182672f1ed5b39098c5127c0d1b96a8f *man/c-commaNMF-method.Rd
+84c5ff2ee4546200a404c1968c7e4bd6 *man/canFit.Rd
+4a680134ba34c9d60f7cf8448de0175c *man/ccBreaks.Rd
+04aa500814501e01f971a9a9e649f7d6 *man/ccPalette.Rd
+30b38d0eb549f60d498fea802752f9e8 *man/ccRamp.Rd
+ead0bcb1b2960042e6c225abaf312d3f *man/ccSpec.Rd
+3c3630400842a8205c1698dd2ece18b9 *man/checkErrors.Rd
+94b8ec67220a6c9cb58bf5a9d07c21ce *man/cluster_mat.Rd
+491d24b685f65bb7aaafb80c3bcf908e *man/connectivity.Rd
+079f0bf31cd00add0215f852c2671793 *man/consensus-commaNMFfitX1-method.Rd
+4191760c707e50acc9085b946e6972e4 *man/consensus-commaNMFfitXn-method.Rd
+1adf8241b895a1da992f6fd39b394d60 *man/consensushc.Rd
+00357312e2fb0196a0c380f4134d2f32 *man/cophcor.Rd
+656b6a8bfe95f66aa37d808b14427b72 *man/cutdendro.Rd
+18de62f7c36df3b79d39e649b5f126c4 *man/deviance.Rd
+4d758173653d9a9e4fc6826f10288896 *man/dimnames.Rd
+d17124d62761eea2293f997a41b3b978 *man/dims.Rd
+0eda8c23e3906c11c2894eee60b12e26 *man/dispersion.Rd
+edcc1d52a2ad50aad945d5d74e65121a *man/dot-fcnnls.Rd
+6a8e20c9e88cc67efb77568d963ed321 *man/esGolub.Rd
+1913aebfe0827011d600e56f33587399 *man/fcnnls.Rd
+26389df3557196423682198ca30e4490 *man/fit.Rd
+c1baa89aba303ba8bd4ef407e184e55c *man/fitted.Rd
+06890b1489d4114507541c63b32ec5ed *man/foreach.Rd
+4bdd231e0439efdac037a437ebd0fdd9 *man/gfile.Rd
+fedca5f307d98d0e1f276cf0595e6673 *man/grid.Rd
+704aa7a66e9f87d1932a070f113df16f *man/heatmaps.Rd
+c103f3feaa7e2c4ddb4b5cb2de75356d *man/inplace.Rd
+42c4702adb4bd8432e51b7f0d2aab9be *man/lsNMF-nmf.Rd
+ad4bea9f6bf8da8c5b8af058d4e70581 *man/lverbose.Rd
+83ccd902c78857036785b022791144a5 *man/match_atrack.Rd
+17146cceec053543e3ad16d0570d092d *man/nmf-compare.Rd
+eaf6a741f1e1f5e39d456414a391b249 *man/nmf.Rd
+b5a35acf90da3f5d014c3686d234368d *man/nmf.equal.Rd
+625896d5746034a531a4d1da377fcb5f *man/nmfAlgorithm.Rd
+f9cb9d24d68ee319e7593c1d2fee3223 *man/nmfApply.Rd
+0ad0ee7ca0345c8bb2ab226df30a1860 *man/nmfCheck.Rd
+4952f5420fac8de51c8810e64b845974 *man/nmfEstimateRank.Rd
+d95047f4bf61f4c7ccaa1e921ba4b522 *man/nmfFormals.Rd
+01cf1a46a5f53333fcb88f697040aa64 *man/nmfModel.Rd
+d4898d6e3b1cd1b6b178a60c2d576ee5 *man/nmfObject.Rd
+49f4c64242cc5d0c47b94a9c42807ca2 *man/nmfReport.Rd
+fce06c76bfd398abc1a348d67e7e8c58 *man/nmfSeed.Rd
+7780fe2dae233c6ba52e340d797e2a11 *man/nmfWrapper.Rd
+48346311c56811ab4bfc502a46feac77 *man/nmf_update_KL.Rd
+01282dba5a9467f5c34e9d7b2d405ded *man/nmf_update_euclidean.Rd
+c28f918be30a5da8db623facf38eea9f *man/nneg.Rd
+f481c5f6107309c849530b83206f18f2 *man/nsNMF-nmf.Rd
+ca58350f90998275f533e264d5ce5942 *man/objective-commaNMFfit-method.Rd
+4082dd89c61fd2ae75e274171565642b *man/offset-commaNMFOffset-method.Rd
+c5c14f3e24e71b81dc726a027234fd77 *man/offset-commaNMFfit-method.Rd
+00d3fe2de32a02827359c85f3b2838fe *man/offset-nmf.Rd
+b948e9807bd7e64baab6a364285014d4 *man/options.Rd
+58a943ee17a5986367c921175a200923 *man/parallel.Rd
+1b26866d20f593b9a4d791975d0768f2 *man/parse_formula.Rd
+2959063b2e6978de03a0bf0d3b314046 *man/plot-commaNMFfit-commamissing-method.Rd
+6e450dcc8156f699b0e5d63c598a89d8 *man/predict.Rd
+1f31e742a28febed67c816936f541345 *man/profplot.Rd
+d8d2498c4b415b41cde4cf9e8049f8a5 *man/purity.Rd
+35694f86b6139a3ee2cd3f82a41ad824 *man/randomize.Rd
+3560f009b84aa4bf1d3dfcbc1ecb1e16 *man/registry-algorithm.Rd
+cb7ba12690237f166574749bb707d3f7 *man/residuals.Rd
+c8aa1d388b52049207fc058e157af5b6 *man/revPalette.Rd
+622964f68f0911dff7cf9eede6fac98e *man/rmatrix.Rd
+5200979607c31ee9e75d2e4f2e89a37c *man/rnmf.Rd
+08b1b09c30f90240167a25a5dc1671ef *man/rss.Rd
+e589f075ac5a2404fe136375475ab67c *man/runtime-commaNMFList-method.Rd
+67dd23b7d9dd5739289857be80513bbc *man/runtime.all-commaNMFfitXn-method.Rd
+b20c67b061270a8948c14f30c029d266 *man/scale.NMF.Rd
+0e9aa7fe953cbc4d0b2cdfdd6a61fabb *man/scores.Rd
+b1deacdafd60ed14a2ee40ec5dbffba3 *man/seed.Rd
+0a372ae7c4ebd520f9a087253bf5f5cc *man/setNMFMethod.Rd
+90119b84cf9e8a6c4d6faeb60d0c6cd9 *man/setNMFSeed.Rd
+571ad68968801bbafe7f2d2e25a22550 *man/setup.Rd
+7bb22e6720734f511e803a871fb26e39 *man/show-commaNMF-method.Rd
+2d06782ea4c4ad91ac5694f33575e923 *man/show-commaNMFList-method.Rd
+13c4118576e5e6767234d6b61f4d9159 *man/show-commaNMFOffset-method.Rd
+bb3a39862b068259cab8ea954454bcc2 *man/show-commaNMFSeed-method.Rd
+84b6af7f192d8e0919bf6a7795645353 *man/show-commaNMFStrategyIterative-method.Rd
+515b08c8a685e823723afeb4a1a313c8 *man/show-commaNMFfit-method.Rd
+f36b652373f4f16f2bb6828c2b5d585f *man/show-commaNMFfitX-method.Rd
+c1c89600aba522e34a6ba28190f2bd7c *man/show-commaNMFfitX1-method.Rd
+f14bfc191bb4d6d39684d9ee54a39736 *man/show-commaNMFfitXn-method.Rd
+becd00d7a3051215763271cd1eb8325e *man/show-commaNMFns-method.Rd
+08716df0024ce0ca8f6a3a6f1ce8f599 *man/silhouette.NMF.Rd
+9e8cf1622e25fed14b84bfcd0521ed35 *man/smoothing.Rd
+e6a7d35fb160e28931b03173e82cde35 *man/sparseness.Rd
+127c40883b9775f0c9a8500378c0efed *man/staticVar.Rd
+b60bd8e815ca75ea07f7bcec5e2b4d3e *man/stop-NMF.Rd
+ae4a92d9c449e96cf2f7578d778b4beb *man/subset-NMF.Rd
+c8cf5183b055fd8a2b16c1d27f65f101 *man/syntheticNMF.Rd
+4264ddc5ceb09fc3e2edf67a4ffea81e *man/t.NMF.Rd
+d0a67df32409d5fe6c871f24b2b71c7c *man/terms-internal.Rd
+b279c6ba4bf77ce4028e6e99ee3b6fb3 *man/terms.Rd
+8af3bdb9baf9ace2bff7cf278528808e *man/txtProgressBar.Rd
+7869fe34a7817d5f7aacb29c8b5bb7e7 *man/types.Rd
+c1dd149f5e75b70b800565157584fe7a *man/utils.Rd
+7cc4426f76a914383e70b17f2f35c312 *src/distance.cpp
+74facf85e6495aea68dd04b725cc6787 *src/divergence.cpp
+e78941582fb2d47fd1f87f9a48a37729 *src/euclidean.cpp
+0678d1eb5e2c82c47e9a296fee622380 *src/utils.cpp
+75c01c40d5204e71e378b8c27c963959 *tests/doRUnit.R
+888e8d888eefa87589a5d1846a1b4dea *vignettes/NMF-unitTests.Rnw
+d3a631ff66077530b722b7c779263367 *vignettes/NMF-vignette.Rnw
+e80ff821d37969bdb7ff73081b8f7c53 *vignettes/consensus.pdf
+117e593dae265395cc28634365848af2 *vignettes/heatmaps.Rnw
+c281ae2285729d8ddfb72a1dd198b148 *vignettes/src/bmc.R
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..0996155
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,233 @@
+export(rmatrix)
+export(str_args)
+export(randomize)
+export(pmax.inplace)
+export(neq.constraints.inplace)
+export(nmfObject)
+export(algorithm)
+export("algorithm<-")
+export(seeding)
+export("seeding<-")
+export(niter)
+export("niter<-")
+export(nrun)
+export(objective)
+export("objective<-")
+export(runtime)
+export(runtime.all)
+export(seqtime)
+export(modelname)
+export(run)
+export(logs)
+export(compare)
+export(nmf.options)
+export(nmf.getOption)
+export(nmf.resetOptions)
+export(nmf.printOptions)
+export(.atrack)
+export(match_atrack)
+export(atrack)
+export(aheatmap)
+export(fitted)
+export(basis)
+export(.basis)
+export("basis<-")
+export(".basis<-")
+export(loadings)
+export(coef)
+export(.coef)
+export("coef<-")
+export(".coef<-")
+export(coefficients)
+export(scoef)
+export(rnmf)
+export(is.nmf)
+export(nbasis)
+export(basisnames)
+export("basisnames<-")
+export(misc)
+export(is.empty.nmf)
+export(hasBasis)
+export(hasCoef)
+export(is.partial.nmf)
+export(summary)
+export(sparseness)
+export(purity)
+export(entropy)
+export(nmfApply)
+export(predict)
+export(basiscor)
+export(profcor)
+export(connectivity)
+export(rss)
+export(evar)
+export(deviance)
+export(nmfDistance)
+export(nmf.equal)
+export(nneg)
+export(posneg)
+export(offset)
+export(metaHeatmap)
+export(basismap)
+export(coefmap)
+export(smoothing)
+export(nmfModel)
+export(nmfModels)
+export(ibterms)
+export(icterms)
+export(iterms)
+export(nterms)
+export(nbterms)
+export(ncterms)
+export(bterms)
+export(cterms)
+export(ibasis)
+export(icoef)
+export(fit)
+export("fit<-")
+export(minfit)
+export(residuals)
+export("residuals<-")
+export(hasTrack)
+export(trackError)
+export(isNMFfit)
+export(consensus)
+export(consensushc)
+export(getRNG1)
+export(which.best)
+export(.getRNG)
+export(dispersion)
+export(consensusmap)
+export(cophcor)
+export(name)
+export("name<-")
+export(NMFStrategy)
+export(is.mixed)
+export(nmfFormals)
+export(nmfArgs)
+export(NMFSeed)
+export(staticVar)
+export(nmf_update.KL.h)
+export(nmf_update.KL.h_R)
+export(nmf_update.KL.w)
+export(nmf_update.KL.w_R)
+export(nmf_update.euclidean.h)
+export(nmf_update.euclidean.h_R)
+export(nmf_update.euclidean.w)
+export(nmf_update.euclidean.w_R)
+export(NMFStop)
+export(nmf.stop.iteration)
+export(nmf.stop.threshold)
+export(nmf.stop.stationary)
+export(nmf.stop.connectivity)
+export(profplot)
+export(profplot.default)
+export(setNMFMethod)
+export(nmfRegisterAlgorithm)
+export(canFit)
+export(getNMFMethod)
+export(nmfAlgorithm)
+export(existsNMFMethod)
+export(removeNMFMethod)
+export(nmfWrapper)
+export(nmf_update.brunet_R)
+export(nmf_update.brunet)
+export(nmf_update.lee_R)
+export(nmf_update.lee)
+export(nmf_update.euclidean_offset.h)
+export(nmf_update.euclidean_offset.w)
+export(nmf_update.offset_R)
+export(nmf_update.offset)
+export(nmf_update.ns)
+export(nmf_update.ns_R)
+export(fcnnls)
+export(.fcnnls)
+export(featureScore)
+export(extractFeatures)
+export(nmfSeed)
+export(getNMFSeed)
+export(existsNMFSeed)
+export(setNMFSeed)
+export(removeNMFSeed)
+export(getDoBackend)
+export(setDoBackend)
+export(register)
+export(ForeachBackend)
+export(getDoParHosts)
+export(getDoParNHosts)
+export(ts_eval)
+export(ts_tempfile)
+export(hostfile)
+export(gVariable)
+export(nmf)
+export(seed)
+export(nmfEstimateRank)
+export(nmfReport)
+export(syntheticNMF)
+export(nmfCheck)
+exportClasses(NMF)
+exportClasses(NMFstd)
+exportClasses(NMFOffset)
+exportClasses(NMFns)
+exportClasses(NMFfit)
+exportClasses(NMFList)
+exportClasses(NMFfitX)
+exportClasses(NMFfitX1)
+exportClasses(NMFfitXn)
+exportMethods(show)
+exportMethods(dim)
+exportMethods(dimnames)
+exportMethods("dimnames<-")
+exportMethods("[")
+exportMethods("$")
+exportMethods("$<-")
+exportMethods(.DollarNames)
+exportMethods(rposneg)
+exportMethods(fitted)
+exportMethods(plot)
+exportMethods(objective)
+exportMethods("objective<-")
+exportPattern("^featureNames")
+exportPattern("^sampleNames")
+exportPattern("^metagenes")
+exportPattern("^metaprofiles")
+exportPattern("^nmeta")
+import(graphics)
+import(rngtools)
+import(digest)
+import(stringr)
+import(stats)
+import(methods)
+import(grid)
+import(RColorBrewer)
+import(colorspace)
+import(grDevices)
+import(gridBase)
+import(pkgmaker)
+import(registry)
+import(cluster)
+import(foreach)
+import(doParallel)
+import(ggplot2)
+import(reshape2)
+importFrom(utils,.DollarNames)
+S3method(scale,NMF)
+S3method(.DollarNames,NMF)
+S3method(t,NMF)
+S3method(t,NMFstd)
+S3method(plot,NMF.consensus)
+S3method(nmfFormals,character)
+S3method(nmfFormals,NMFStrategy)
+S3method(nmfFormals,NMFStrategyFunction)
+S3method(nmfFormals,NMFStrategyIterative)
+S3method(profplot,default)
+S3method(silhouette,NMF)
+S3method(silhouette,NMFfitX)
+S3method(print,fcnnls)
+S3method(register,foreach_backend)
+S3method(register,doParallel_backend)
+S3method(register,doMPI_backend)
+S3method(print,foreach_backend)
+S3method(summary,NMF.rank)
+S3method(plot,NMF.rank)
+useDynLib(NMF)
diff --git a/NEWS b/NEWS
new file mode 100644
index 0000000..d85ce98
--- /dev/null
+++ b/NEWS
@@ -0,0 +1,622 @@
+*************************************************************************
+Changes in version 0.20.6
+*************************************************************************
+FIXES
+ o fixed new NOTEs in R CMD check (about requireNamespace)
+ o fixed error in heatmaps due to new version of stringr (>= 1.0.0)
+
+*************************************************************************
+Changes in version 0.20
+*************************************************************************
+NEW FEATURES
+ o aheatmap gains an argument txt that enables displaying text in each
+ cell of the heatmap.
+
+FIXES
+ o now all examples, vignettes and unit tests comply with CRAN policies
+ on the maximum number of cores to be used when checking packages (2).
+
+*************************************************************************
+Changes in version 0.18
+*************************************************************************
+NEW FEATURES
+ o aheatmap gains distfun methods 'spearman', 'kendall', and,
+ for completeness, 'pearson' (for which 'correlation' is now an alias),
+ which specifies the correlation method to use when computing the
+ distance matrix.
+
+CHANGES
+ o In order to fully comply with CRAN policies, internals of the
+ aheatmap function slightly changed. In particular, this brings an
+ issue when directly plotting to PDF graphic devices, where a first
+ blank page may appear. See the dedicated section in the man page
+ ?aheatmap for a work around.
+
+
+*************************************************************************
+Changes in version 0.17.3
+*************************************************************************
+NEW FEATURES
+ o add silhouette computation for NMF results, which can be performed on
+ samples, features or consensus matrix.
+ The average silhouette width is also computed by the summary methods.
+ (Thanks to Gordon Robertson for this suggestion)
+
+ o New runtime option 'shared.memory' (or 'm') for toggling usage of shared
+ memory (requires package synchronicity).
+
+CHANGES
+ o some plots are -- finally -- generated using ggplot2
+ This adds an Imports dependency to ggplot2 and reshape2.
+
+BUG FIXES
+ o fix a bug when running parallel NMF computation with
+ algorithms defined in other packages (this most probably only affected my
+ own packages, e.g., CellMix)
+
+*************************************************************************
+Changes in version 0.17.1
+*************************************************************************
+CHANGES
+ o Computations seeded with an NMF object now set slot @seed to 'NMF'
+ o Added unit tests on seeding with an NMF object
+ o Removed some obsolete comments
+
+BUG FIXES
+ o an error was thrown when running multiple sequential NMF
+ computations with nrun>=50: object '.MODE_SEQ' not found.
+ (reported by Kenneth Lopiano)
+
+
+*************************************************************************
+Changes in version 0.16.5
+*************************************************************************
+CHANGES
+ o Now depends on pkgmaker 0.16
+ o Disabled shared memory on Mac machines by default, due to un-resolved
+ bug that occurs with big-matrix descriptors.
+ It can be restored using nmf.options(shared.memory=TRUE)
+ o Package version is now shown on startup message
+ o Re-enabled unit test checks on CRAN, using the new function
+ pkgmaker::isCHECK, that definitely identifies if tests are run
+ under R CMD check.
+
+*************************************************************************
+* Changes in version 0.15.2 *
+*************************************************************************
+
+NEW FEATURES
+
+ o New function nmfObject() to update old versions of NMF objects,
+ eg., saved on disk.
+ o NMF strategies can now define default values for their parameters,
+ eg., `seed` to associate them with a seeding method that is not the
+ default method, `maxIter` to make default runs with more iterations
+ (for algorithms defined as NMFStrategyIterative), or any other
+ algorithm-specific parameter.
+ o new general utility function hasArg2 that is identical to hasArg
+ but takes the argument name as a character string, so that no
+ check NOTE is thrown.
+
+CHANGES
+
+ o All vignettes are now generated using knitr.
+ o New dependency to pkgmaker which incorporated many of the
+ general utility functions, initially defined for the NMF package.
+ o example check is faster (as requested by CRAN)
+ o the function selectMethodNMF was renamed into selectNMFMethod to
+ be consistent with the other related *NMFMethod functions (get, set, etc..)
+
+FIXES
+
+ o Fix computation of R-squared in profplot/corplot: now compute from
+ a linear fit that includes an intercept.
+
+*************************************************************************
+* Changes in version 0.8.6 *
+*************************************************************************
+
+NEW FEATURES
+
+ o Formula based NMF models that can incorporate fixed terms, which may
+ be used to correct for covariates or define group specific offsets.
+
+CHANGES
+
+ o Subsetting an NMF object with a single index now returns an NMF object,
+ except if argument drop is not missing (i.e. either TRUE or FALSE).
+
+*************************************************************************
+* Changes in version 0.6.03 *
+*************************************************************************
+
+WARNING
+ Due to the major changes made in the internal structure of the standard NMF
+ models, previous NMF fits are not compatible with this version.
+
+NEW FEATURES
+
+ o The factory function nmfModel has been enhanced and provides new
+ methods that makes more easier the creation of NMF objects.
+ See ?nmfModel.
+
+ o A new heatmap drawing function 'aheatmap' (for annotated heatmap) is
+ now used to generate the different heatmaps (basismap, coefmap and consensusmap).
+ It is a enhancement/fork of the function pheatmap from package pheatmap and draw
+ -- I think -- very nice heatmaps, providing a convenient and flexible
+ interface to add annotation tracks to both the columns and rows, with
+ sensible automatic legends.
+
+CHANGES
+
+ o Method nmfModel when called with no arguments does not return anymore
+ the list of available NMF models, but an empty NMF model.
+ To list the available models, directly call `nmfModels()`.
+
+ o The function `rmatrix` is now a S4 generic function.
+ It gains methods for generating random matrices based on a template matrix
+ or an NMF model.
+ See ?rmatrix.
+
+ o The function `rnmf` gains a method to generate a random NMF model
+ given numerical dimensions.
+
+ o The function nmfEstimateRank now returns the fits for each value of the
+ rank in element 'fit' of the result list.
+ See ?nmfEstimateRank.
+
+
+
+*************************************************************************
+* Changes in version 0.5.3 *
+*************************************************************************
+
+NEW FEATURES
+
+ o The state of the random number generator is systematically stored in the
+ 'NMFfit' object returned by function 'nmf'.
+ It is stored in a new slot 'rng.seed' and can be access via the new method
+ 'rngSeed' of class 'NMFfit'.
+ See ?rngSeed for more details.
+
+ o The number of cores to use in multicore computations can now also be
+ specified by the 'p - parallel' runtime option (e.g. 'p4' to use 4 cores).
+ Note that the value specified in option 'p' takes precedence on the one
+ passed via argument '.pbackend'.
+ See section 'Runtime options' in ?nmf for more details.
+
+ o Function 'nmfApply' now allows values 3 and 4 for argument 'MARGIN' to
+ apply a given function to the basis vectors (i.e. columns of the basis matrix W)
+ and basis profiles (i.e. rows of the mixture coefficients H) respectively.
+ See ?nmfApply for more details.
+
+ o New S4 generic 'basiscor' and 'profcor' to compute the
+ correlation matrices of the basis vectors and basis profiles respectively
+ from two NMF models or from an NMF model and a given compatible matrix.
+ See ?basiscor or ?profcor for more details.
+
+ o New S4 generic 'fitcmp' to compare the NMF models fitted by two
+ different runs of function 'nmf' (i.e. two 'NMFfit' objects).
+ See ?fitcmp for more details.
+
+ o New S4 generic 'canFit' that tells if an NMF method is able to
+ exactly or partly fit a given NMF model.
+ See ?canFit for more details.
+
+ o New function 'selectMethodNMF' that selects an appropriate NMF method to
+ fit a given NMF model.
+ See ?selectMethodNMF for more details.
+
+ o The verbosity level can be controlled more finely by the 'v - verbose'
+ runtime option (e.g. using .options='v1' or 'v2'). The greater is
+ the level the more information is printed.
+ The verbose outputs have been cleaned-up and should be more consistent
+ across the run mode (sequential or multicore).
+ See section 'Runtime options' in ?nmf for more details.
+
+CHANGES
+
+ o The standard update equations have been optimised further, by making
+ them modify the factor matrices in place. This speeds up the computation
+ and greatly improves the algorithms' memory footprint.
+
+ o The package NMF now depends on the package digest that is used to display
+ the state of random number generator in a concise way.
+
+ o The methods 'metaHeatmap' are split into 3 new S4 generic 'basismap' to
+ plot a heatmap of the basis matrix [formerly plotted by the call :
+ 'metaHeatmap(object.of.class.NMF, 'features', ...) ], 'coefmap' to plot a
+ heatmap of the mixture coefficient matrix [formerly plotted by the call :
+ 'metaHeatmap(object.of.class.NMF, 'samples', ...) ], and 'consensusmap' to
+ plot a heatmap of the consensus matrix associated with multiple runs of NMF
+ [formerly plotted by the call : 'metaHeatmap(object.of.class.NMFfitX, ...) ].
+
+
+BUG FIX
+
+ o In factory method 'nmfModel': the colnames (resp. rownames) of
+ matrix W (resp. H) are now correctly set when the rownames of H
+ (resp. the colnames of W) are not null.
+
+NEWLY DEPRECATED CLASSES, METHODS, FUNCTIONS, DATA SETS
+
+ o Deprecated Generics/Methods
+ 1) 'metaHeatmap,NMF' and 'metaHeatmap,NMFfitX' - S4 methods remain
+ with .Deprecated message.
+ They are replaced by the definition of 3 new S4 generic 'basismap',
+ 'coefmap' and 'consensusmap'. See the related point in section
+ CHANGES above.
+ They will be completely removed from the package in the next version.
+
+*************************************************************************
+* Changes in version 0.5.1 *
+*************************************************************************
+
+BUG FIX
+
+ o fix a small bug in method 'rss' to allow argument 'target' to be a
+ 'data.frame'. This was generating errors when computing the summary
+ measures and especially when the function 'nmfEstimateRank' was called
+ on a 'data.frame'. Thanks to Pavel Goldstein for reporting this.
+
+
+*************************************************************************
+* Changes in version 0.5 *
+*************************************************************************
+NEW FEATURES
+
+ o Method 'fcnnls' provides a user-friendly interface for the internal
+ function '.fcnnls' to solve non-nengative linear least square problems,
+ using the fast combinatorial approach from Benthem and Keenan (2004).
+ See '?fcnnls' for more details.
+
+ o New argument 'callback' in method 'nmf' allows to provide a callback
+ function when running multiple runs in default mode, that only keeps the
+ best result. The callback function is applied to the result of each run
+ before it possibly gets discarding. The results are stored in the
+ miscellaneous slot '.callback' accessible via the '$' operator (e.g. res$.callback).
+ See '?nmf' for more details.
+
+ o New method 'niter' to retrieve the number of iterations performed to fit
+ a NMF model. It is defined on objects of class 'NMFfit'.
+
+ o New function 'isNMFfit' to check if an object is a result from NMF fitting.
+
+ o New function 'rmatrix' to easily generate random matrices, and allow to specify the
+ distribution from which the entries are drawn. For example:
+
+ * 'rmatrix(100, 10)' generates a 100x10 matrix whose entries are drawn
+ from the uniform distribution
+
+ * 'rmatrix(100, 10, rnorm)' generates a 100x10 matrix whose entries are drawn
+ from the standard Normal distribution.
+
+ o New methods 'basisnames' and 'basisnames<-' to retrieve and set the basis vector
+ names. See '?basisnames'.
+
+
+CHANGES
+
+ o Add a CITATION file that provides the bibtex entries for citing the
+ BMC Bioinformatics paper for the package
+ (http://www.biomedcentral.com/1471-2105/11/367), the vignette and manual.
+ See 'citation('NMF')' for complete references.
+
+ o New argument 'ncol' in method 'nmfModel' to specify the target dimensions more
+ easily by calls like 'nmfModel(r, n, p)' to create a r-rank NMF model that fits a
+ n x p target matrix.
+
+ o The subset method '[]' of objects of class 'NMF' has been changed to be more convenient.
+ See
+
+BUG FIX
+
+ o Method 'dimnames' for objects of class 'NMF' now correctly sets the
+ names of each dimension.
+
+REMOVED CLASSES, METHODS, FUNCTIONS, DATA SETS
+
+ o Method 'extra' has completely been removed.
+
+*************************************************************************
+* Changes in version 0.4.8 *
+*************************************************************************
+BUG FIX
+
+ o When computing NMF with the SNMF/R(L) algorithms, an error could
+ occur if a restart (recomputation of the initial value) for the H
+ matrix (resp. W matrix) occured at the first iteration.
+ Thanks to Joe Maisog for reporting this.
+
+*************************************************************************
+* Changes in version 0.4.7 *
+*************************************************************************
+BUG FIX
+
+ o When computing the cophenetic correlation coefficient of a diagonal
+ matrix, the 'cophcor' method was returning 'NA' with a warning from
+ the 'cor' function. It now correctly returns 1.
+ Thanks to Joe Maisog for reporting this.
+
+
+*************************************************************************
+* Changes in version 0.4.4 *
+*************************************************************************
+
+CHANGES
+
+ o The major change is the explicit addition of the synchronicity package into
+ the suggested package dependencies. Since the publication of versions 4.x
+ of the bigmemory package, it is used by the NMF package to provide the mutex
+ functionality required by multicore computations.
+ Note This is relevant only for Linux/Mac-like platforms as the multicore
+ package is not yet supported on MS Windows.
+ Users using a recent version of the bigmemory package (i.e. >=4.x)
+ DO NEED to install the synchronicity package to be able to run multicore NMF
+ computations.
+ Versions of bigmemory prior to 4.x include the mutex functionality.
+
+ o Minor enhancement in error messages
+
+ o Method 'nmfModel' can now be called with arguments 'rank' and 'target'
+ swapped. This is for convenience and ease of use.
+
+BUG FIX
+
+ o Argument 'RowSideColors' of the 'metaHeatmap' function is now correctly
+ subset according to the value of argument 'filter'. However the argument
+ must be named with its complete name 'RowSideColors', not assuming
+ partial match. See KNOWN ISSUES.
+
+KNOWN ISSUES
+
+ o In the 'metaHeatmap' function, when argument 'filter' is not 'FALSE':
+ arguments 'RowSideColors', 'labRow', 'Rowv' that are intended to the
+ 'heatmap.plus'-like function (and are used to label the rows) should be
+ named using their complete name (i.e. not assuming partial match),
+ otherwise the filtering is not applied to these argument and an error
+ is generated.
+ This issue will be fixed in a future release.
+
+*************************************************************************
+* Changes in version 0.4.3 *
+*************************************************************************
+
+CHANGES
+
+ o function 'nmfEstimateRank' has been enhanced:
+ -run options can be passed to each internal call to the 'nmf' function.
+ See ?nmfEstiamteRank and ?nmf for details on the supported options.
+
+ - a new argument 'stop' allows to run the estimation with fault tolerance,
+ skipping runs that throw an error. Summary measures for these runs are set
+ to NAs and a warning is thrown with details about the errors.
+
+ o in function 'plot.NMF.rank': a new argument 'na.rm' allows to remove from
+ the plots the ranks for which the measures are NAs (due to errors during the
+ estimation process with 'nmfEstimateRank').
+
+BUG FIX
+
+ o Method 'consensus' is now exported in the NAMESPACE file.
+ Thanks to Gang Su for reporting this.
+
+ o Warnings and messages about loading packages are now suppressed.
+ This was particularly confusing for users that do not have the packages
+ and/or platform required for parallel computation: warnings were printed
+ whereas the computation was -- sequentially -- performed without
+ problem.
+ Thanks to Joe Maisog for reporting this.
+
+*************************************************************************
+* Changes in version 0.4.1 *
+*************************************************************************
+
+BUG FIX
+
+ o The 'metaHeatmap' function was not correctly handling row labels
+ when argument filter was not FALSE. All usual row formating in heatmaps
+ (label and ordering) are now working as expected.
+ Thanks to Andreas Schlicker, from The Netherlands Cancer Institute for
+ reporting this.
+
+ o An error was thrown on some environments/platforms (e.g. Solaris)
+ where not all the packages required for parallel computation were not
+ available -- even when using option 'p' ('p' in lower case), which
+ should have switched the computation to sequential.
+ This is solved and the error is only thrown when running NMF with
+ option 'P' (capital 'P').
+
+ o Not all the options were passed (e.g. 't' for tracking) in sequential
+ mode (option '-p').
+
+ o verbose/debug global nmf.options were not restored if a numerical random
+ seed were used.
+
+CHANGES
+
+ o The 'metaHeatmap' function nows support passing the name of a filtering
+ method in argument 'filter', which is passed to method 'extractFeatures'.
+ See ?metaHeatmap.
+
+ o Verbose and debug messages are better handled. When running a parallel
+ computation of multiple runs, verbose messages from each run are shown only
+ in debug mode.
+
+*************************************************************************
+* Changes in version 0.4 *
+*************************************************************************
+
+NEW FEATURES
+
+ o Part of the code has been optimised in C++ for speed and memory efficiency:
+
+ - the multiplicative updates for reducing the KL divergence and the euclidean
+ distance have been optimised in C++. This significantly reduces the
+ computation time of the methods that make use of them: 'lee', 'brunet',
+ 'offset', 'nsNMF' and 'lnmf'.
+ Old R version of the algorithm are still accessible with the suffix '.R#'.
+
+ - the computation of euclidean distance and KL divergence are implemented
+ in C++, and do not require the duplication of the original matrices as done
+ in R.
+
+ o Generic 'dimnames' is now defined for objects of class 'NMF' and returns
+ a list with 3 elements: the row names of the basis matrix, the column names
+ of the mixture coefficient matrix , and the column names of the basis matrix.
+ This implies that methods 'rownames' and 'columnames' are also available for
+ 'NMF' objects.
+
+ o A new class structure has been developed to handle the results of multiple
+ NMF runs in a cleaner and more structured way:
+
+ - Class 'NMFfitX' defines a common interface for multiple NMF runs of a
+ single algorithm.
+
+ - Class 'NMFfitX1' handles the sub-case where only the best fit is returned.
+ In particular, this class allows to handle such results as if coming
+ from a single run.
+
+ - Class 'NMFfitXn' handles the sub-case where the list of all the fits
+ is returned.
+
+ - Class 'NMFList' handles the case of heterogeneous NMF runs (different
+ algorithms, different factorization rank, different dimension, etc...)
+
+ o The vignette contains more examples and details about the use of package.
+
+ o The package is compatible with both versions 3.x and 4.x of the bigmemory
+ package. This package is used when running multicore parallel computations.
+ With version 4.x of bigmemory, the synchronicity package is also required as
+ it provides the mutex functionality that used to be provided by bigmemory 3.x.
+
+BUG FIX
+
+ o Running in multicore mode from the GUI on MacOS X is not allowed anymore as
+ it is not safe and were throwing an error ['The process has forked and ...'].
+ Thanks to Stephen Henderson from the UCL Cancer Institute (UK) for reporting this.
+
+ o Function 'nmf' now restores the random seed to its original value as before its call
+ with a numeric seed. This behaviour can be disabled with option 'restore.seed=FALSE' or '-r'
+
+NEWLY DEPRECATED CLASSES, METHODS, FUNCTIONS, DATA SETS
+
+ o Deprecated Generics/Methods
+ 1) 'errorPlot' - S4 generic/methods remains with .Deprecated message.
+ It is replaced by a definition of the 'plot' method for signatures
+ 'NMFfit,missing' and 'NMFList,missing'
+ It will be completely removed from the package in the next version.
+
+ o Deprecated Class
+ 1) 'NMFSet' - S4 class remains for backward compatibility, but is not
+ used anymore. It is replaced by the classes 'NMFfitX1', 'NMFfitXn',
+ 'NMFList'.
+
+*************************************************************************
+* Changes in version 0.3 *
+*************************************************************************
+
+NEW FEATURES
+
+ o Now requires R 2.10
+
+ o New list slot 'misc' in class 'NMF' to be able to define new NMF models,
+ without having to extend the S4 class. Access is done by methods '$' and '$<-'.
+
+ o More robust and convenient interface 'nmf'
+
+ o New built-in algorithm : PE-NMF [Zhang (2008)]
+
+ o The vignette and documentation have been enriched with more examples and
+ details on the functionalities.
+
+ o When possible the computation is run in parallel on all the available cores.
+ See option 'p' or 'parallel=TRUE' in argument '.options' of function 'nmf'.
+
+ o Algorithms have been optimized and run faster
+
+ o Plot for rank estimation: quality measure curves can be plotted together
+ with a set of reference measures.
+ The reference measures could for example come from the rank estimation of
+ randomized data, to investigate overfitting.
+
+ o New methods '$' and '$<-' to access slot 'extra' in class 'NMFfit'
+ These methods replace method 'extra' that is now defunct.
+
+ o Function 'randomize' allows to randomise a target matrix or
+ 'ExpressionSet' by permuting the entries within each columns using a
+ different permutation for each column. It is useful when checking for
+ over-fitting.
+
+CHANGES
+
+ o The 'random' method of class 'NMF' is renamed 'rnmf', but is still
+ accessible through name 'random' via the 'seed' argument in the
+ interface method 'nmf'.
+
+NEWLY DEFUNCT CLASSES, METHODS, FUNCTIONS, DATA SETS
+
+ o Defunct Generics/Methods
+ 1) 'extra' - S4 generic/methods remains with .Defunct message.
+ It will be completely removed from the package in the next version.
+
+*************************************************************************
+* Changes in version 0.2.4 *
+*************************************************************************
+
+CHANGES
+
+ o Class 'NMFStrategy' has a new slot 'mixed', that specify if the algorithm
+ can handle mixed signed input matrices.
+
+ o Method 'nmf-matrix,numeric,function' accepts a new parameter 'mixed' to
+ specify if the custom algorithm can handle mixed signed input matrices.
+
+*************************************************************************
+* Changes in version 0.2.3 *
+*************************************************************************
+
+NEW FEATURES
+
+ o Package 'Biobase' is not required anymore, and only suggested.
+ The definition and export of the NMF-BioConductor layer is done at
+ loading.
+
+ o 'nmfApply' S4 generic/method: a 'apply'-like method for objects of
+ class 'NMF'.
+
+ o 'predict' S4 method for objects of class 'NMF': the method replace the now
+ deprecated 'clusters' method.
+
+ o 'featureNames' and 'sampleNames' S4 method for objects of class 'NMFSet'.
+
+ o sub-setting S4 method '[' for objects of class 'NMF': row subsets are
+ applied to the rows of the basis matrix, column subsets are applied to
+ the columns of the mixture coefficient matrix.
+
+CHANGES
+
+ o method 'featureScore' has a new argument 'method' to allow choosing between
+ different scoring schema.
+
+ o method 'extractFeatures' has two new arguments: 'method' allows choosing
+ between different scoring and selection methods; 'format' allows to specify
+ the output format.
+ NOTE: the default output format has changed. The default result is now a
+ list whose elements are integer vectors (one per basis component) that
+ contain the indices of the basis-specific features. It is in practice what
+ one is usually interested in.
+
+BUG FIXES
+
+ o Methods 'basis<-' and 'coef<-' were not exported by file NAMESPACE.
+
+ o Method 'featureNames' was returning the column names of the mixture
+ coefficient matrix, instead of the row names of the basis matrix.
+
+ o 'metaHeatmap' with argument 'class' set would throw an error.
+
+NEWLY DEPRECATED CLASSES, METHODS, FUNCTIONS, DATA SETS
+
+ o Deprecated Generics/Methods
+ 1) clusters - S4 generic/methods remain with .Deprecated message
diff --git a/R/Bioc-layer.R b/R/Bioc-layer.R
new file mode 100644
index 0000000..d52f824
--- /dev/null
+++ b/R/Bioc-layer.R
@@ -0,0 +1,320 @@
+# Layer for Bioconductor
+#
+# - define methods with signature for use within Bioconductor
+# - define alias methods for use in the context of microarray analysis (metagenes, metaprofiles, ...)
+#
+# Author: Renaud Gaujoux \email{renaud@@cbio.uct.ac.za}
+###############################################################################
+
+#' @include NMF-class.R
+#' @include transforms.R
+NULL
+
+#' Specific NMF Layer for Bioconductor
+#'
+#' The package NMF provides an optional layer for working with common objects
+#' and functions defined in the Bioconductor platform.
+#'
+#' It provides:
+#' \itemize{
+#' \item computation functions that support \code{ExpressionSet} objects as
+#' inputs.
+#' \item aliases and methods for generic functions defined and widely used by
+#' Bioconductor base packages.
+#' \item specialised visualisation methods that adapt the titles and legend
+#' using bioinformatics terminology.
+#' \item functions to link the results with annotations, etc...
+#' }
+#'
+#' @rdname bioc
+#' @name bioc-NMF
+#'
+#' @aliases nmf,ExpressionSet,ANY,ANY-method
+#' @aliases nmf,matrix,ExpressionSet,ANY-method
+#'
+#' @aliases seed,ExpressionSet,ANY,ANY-method
+#'
+#' @aliases run,NMFStrategy,ExpressionSet,ANY-method
+#'
+#' @aliases nmfModel,ExpressionSet,ANY-method
+#' @aliases nmfModel,ANY,ExpressionSet-method
+#'
+#' @aliases rnmf,ANY,ExpressionSet-method
+#'
+#' @aliases nneg,ExpressionSet-method
+#' @aliases rposneg,ExpressionSet-method
+#'
+#' @aliases .atrack,ExpressionSet-method
+#'
+#' @aliases sampleNames,NMF-method
+#' @aliases sampleNames<-,NMF,ANY-method
+#' @aliases sampleNames,NMFfitX-method
+#' @aliases featureNames,NMF-method
+#' @aliases featureNames<-,NMF-method
+#' @aliases featureNames,NMFfitX-method
+#'
+#' @aliases nmeta
+#' @aliases metagenes metagenes<-
+#' @aliases metaprofiles metaprofiles<-
+#'
+#' @exportPattern ^featureNames
+#' @exportPattern ^sampleNames
+#' @exportPattern ^metagenes
+#' @exportPattern ^metaprofiles
+#' @exportPattern ^nmeta
+NULL
+
+# add extra package Biobase
+setPackageExtra('install.packages', 'Biobase', pkgs='Biobase')
+
+.onLoad.nmf.bioc <- function(){
+
+if( pkgmaker::require.quiet('Biobase') ){
+
+ # load Biobase package
+ requireNamespace('Biobase')
+ #library(Biobase)
+
+ #' Performs NMF on an ExpressionSet: the target matrix is the expression matrix \code{exprs(x)}.
+ #' @rdname bioc
+ setMethod('nmf', signature(x='ExpressionSet', rank='ANY', method='ANY'),
+ function(x, rank, method, ...)
+ {
+ # replace missing values by NULL values for correct dispatch
+ if( missing(method) ) method <- NULL
+ if( missing(rank) ) rank <- NULL
+
+ # apply NMF to the gene expression matrix
+ nmf(Biobase::exprs(x), rank, method, ...)
+ }
+ )
+
+ #' Fits an NMF model partially seeding the computation with a given
+ #' ExpressionSet object passed in \code{rank}.
+ #'
+ #' This method provides a shortcut for \code{nmf(x, exprs(rank), method, ...)}.
+ #'
+ #' @examples
+ #' # partially seed with an ExpressionSet (requires package Biobase)
+ #' \dontrun{
+ #' data(esGolub)
+ #' nmf(esGolub, esGolub[,1:3])
+ #' }
+ #'
+ setMethod('nmf', signature(x='matrix', rank='ExpressionSet', method='ANY'),
+ function(x, rank, method, ...){
+ # replace missing values by NULL values for correct dispatch
+ if( missing(method) ) method <- NULL
+
+ nmf(x, Biobase::exprs(rank), method, ...)
+ }
+ )
+
+
+ #' Seeds an NMF model directly on an ExpressionSet object.
+ #' This method provides a shortcut for \code{seed(exprs(x), model, method, ...)}.
+ #'
+ #' @examples
+ #' # run on an ExpressionSet (requires package Biobase)
+ #' \dontrun{
+ #' data(esGolub)
+ #' nmf(esGolub, 3)
+ #' }
+ #'
+ setMethod('seed', signature(x='ExpressionSet', model='ANY', method='ANY'),
+ function(x, model, method, ...)
+ {
+ # replace missing values by NULL values for correct dispatch
+ if( missing(method) ) method <- NULL
+ if( missing(model) ) model <- NULL
+
+ # apply NMF to the gene expression matrix
+ seed(Biobase::exprs(x), model, method, ...)
+ }
+ )
+
+ #' Runs an NMF algorithm on the expression matrix of an \code{ExpressionSet} object.
+ setMethod('run', signature(object='NMFStrategy', y='ExpressionSet', x='ANY'),
+ function(object, y, x, ...){
+
+ run(object, Biobase::exprs(y), x, ...)
+
+ }
+ )
+
+ ###% Method 'nmfModel' for 'ExpressionSet' target objects:
+ ###% -> use the expression matrix of 'target' as the target matrix
+ setMethod('nmfModel', signature(rank='ANY', target='ExpressionSet'),
+ function(rank, target, ...){
+ if( missing(rank) ) rank <- NULL
+ # call nmfModel on the expression matrix
+ nmfModel(rank, Biobase::exprs(target), ...)
+ }
+ )
+ setMethod('nmfModel', signature(rank='ExpressionSet', target='ANY'),
+ function(rank, target, ...){
+ if( missing(target) ) target <- NULL
+ # call nmfModel on the expression matrix
+ nmfModel(Biobase::exprs(rank), target, ...)
+ }
+ )
+
+ ###% Method 'rnmf' for 'ExpressionSet' target objects:
+ ###% -> use the expression matrix of 'target' as the target matrix
+ ###%
+ setMethod('rnmf', signature(x='ANY', target='ExpressionSet'),
+ function(x, target, ...){
+ rnmf(x, Biobase::exprs(target), ...)
+ }
+ )
+
+ ###% The method for an \code{ExpressionSet} object returns the data.frame that
+ ###% contains the phenotypic data (i.e. \code{pData(object)})
+ setMethod('.atrack', 'ExpressionSet',
+ function(object, data=NULL, ...){
+ if( is.null(data) ) data <- t(Biobase::exprs(object))
+ .atrack(Biobase::pData(object), data=data, ...)
+ }
+ )
+
+ #' Apply \code{nneg} to the expression matrix of an \code{\link{ExpressionSet}}
+ #' object (i.e. \code{exprs(object)}).
+ #' All extra arguments in \code{...} are passed to the method \code{nneg,matrix}.
+ #'
+ #' @examples
+ #'
+ #' E <- ExpressionSet(x)
+ #' nnE <- nneg(e)
+ #' exprs(nnE)
+ #'
+ setMethod('nneg', 'ExpressionSet'
+ , function(object, ...){
+ Biobase::exprs(object) <- nneg(Biobase::exprs(object), ...)
+ object
+ }
+ )
+
+ #' Apply \code{rposneg} to the expression matrix of an \code{\link{ExpressionSet}}
+ #' object (i.e. \code{exprs(object)}).
+ #'
+ #' @examples
+ #'
+ #' E <- ExpressionSet(x)
+ #' nnE <- posneg(E)
+ #' E2 <- rposneg(nnE)
+ #' all.equal(E, E2)
+ #'
+ setMethod('rposneg', 'ExpressionSet'
+ , function(object, ...){
+ Biobase::exprs(object) <- rposneg(Biobase::exprs(object), ...)
+ object
+ }
+ )
+
+ ###% Annotate the genes specific to each cluster.
+ ###%
+ ###% This function uses the \code{annaffy} package to generate an HTML table from the probe identifiers.
+# setGeneric('annotate', function(x, annotation, ...) standardGeneric('annotate') )
+# setMethod('annotate', signature(x='factor', annotation='character'),
+# function(x, annotation, filename='NMF genes', outdir='.', name='Cluster specific genes', ...)
+# {
+# library(annaffy)
+# anncols<-aaf.handler()[c(1:3, 6:13)]
+#
+# # add html suffix to filename if necessary
+# if( length(grep("\\.html$", filename)) == 0 ) filename <- paste(filename, 'html', sep='.')
+#
+# # for each cluster annotate the genes set
+# print(head(x))
+# by(names(x), x, function(g){
+# print(head(g))
+# if( length(g) == 0 ) return()
+# g <- as.character(g)
+# anntable <- aafTableAnn(g, annotation, anncols)
+# # generate HTML output
+# saveHTML(anntable, file.path(outdir,filename), title=paste(name, '[top', nrow(anntable),']'))
+# }, simplify=FALSE)
+#
+# # return nothing
+# invisible()
+# }
+# )
+#
+# setMethod('annotate', signature(x='NMF', annotation='character'),
+# function(x, annotation, ...)
+# {
+# s <- extractFeatures(x)
+# class <- .predict.nmf(t(s))
+# annotate(class, annotation=annotation, ...)
+# }
+# )
+
+ ## Assign BioConductor aliases
+ ###% number of metagenes
+ nmeta <- nbasis
+ ###% get/set methods of basis matrix
+ metagenes <- basis
+ `metagenes<-` <- `basis<-`
+ ###% get/set methods of mixture coefficients matrix
+ metaprofiles <- coef
+ `metaprofiles<-` <- `coef<-`
+
+ ###% Get/Set methods for rows/columns names of the basis and mixture matrices
+ # using the Biobase definition standard generics
+ setGeneric('featureNames', package='Biobase')
+ setGeneric('featureNames<-', package='Biobase')
+ setMethod('featureNames', 'NMF',
+ function(object){
+ rownames(object)
+ }
+ )
+ setReplaceMethod('featureNames', 'NMF',
+ function(object, value){
+ rownames(object) <- value
+ object
+ }
+ )
+ ###% For NMFfitX objects: returns the featureNames of the best fit
+ ###% There is no replace method for NMFfitX objects
+ setMethod('featureNames', 'NMFfitX',
+ function(object){
+ rownames(fit(object))
+ }
+ )
+
+ setGeneric('sampleNames', package='Biobase')
+ setGeneric('sampleNames<-', package='Biobase')
+ setMethod('sampleNames', 'NMF',
+ function(object){
+ colnames(object)
+ }
+ )
+ setReplaceMethod('sampleNames', 'NMF',
+ function(object, value){
+ colnames(object) <- value
+ object
+ }
+ )
+ ###% For NMFfitX objects: returns the sampleNames of the best fit
+ ###% There is no replace method for NMFfitX objects
+ setMethod('sampleNames', 'NMFfitX',
+ function(object){
+ colnames(fit(object))
+ }
+ )
+
+# # Export layer-specific methods [only if one is loading a namespace]
+# # NB: Only for R < 3.0.0
+# if( pkgmaker::testRversion("2.15.3", -1L) ){
+# ns <- pkgmaker::addNamespaceExport(c("nmeta"
+# ,"featureNames", "featureNames<-"
+# ,"sampleNames", "sampleNames<-"
+# ,"metagenes", "metagenes<-"
+# ,"metaprofiles", "metaprofiles<-"))
+# }
+
+ # return TRUE
+ TRUE
+}
+
+}
diff --git a/R/NMF-class.R b/R/NMF-class.R
new file mode 100644
index 0000000..3e624f6
--- /dev/null
+++ b/R/NMF-class.R
@@ -0,0 +1,2562 @@
+#library(R.utils)
+
+#' @include utils.R
+#' @include versions.R
+#' @include algorithmic.R
+#' @include aheatmap.R
+NULL
+
+#' Advanced Usage of the Package NMF
+#'
+#' The functions documented here provide advanced functionalities useful when
+#' developing within the framework implemented in the NMF package.
+#'
+#' @rdname advanced
+#' @name advanced-NMF
+NULL
+
+# declare old S3 class 'proc_time' to use it as a slot for class NMF
+setOldClass('proc_time', prototype=numeric())
+
+################################
+# Class: NMF
+################################
+
+#' Generic Interface for Nonnegative Matrix Factorisation Models
+#'
+#' The class \code{NMF} is a \emph{virtual class} that defines a common
+#' interface to handle Nonnegative Matrix Factorization models (NMF models)
+#' in a generic way.
+#' Provided a minimum set of generic methods is implemented by concrete
+#' model classes, these benefit from a whole set of functions and utilities
+#' to perform common computations and tasks in the context of Nonnegative Matrix
+#' Factorization.
+#'
+#' Class \code{NMF} makes it easy to develop new models that integrate well
+#' into the general framework implemented by the \emph{NMF} package.
+#'
+#' Following a few simple guidelines, new types of NMF models benefit from all the
+#' functionalities available for the built-in NMF models -- that derive themselves
+#' from class \code{NMF}.
+#' See section \emph{Implementing NMF models} below.
+#'
+#' See \code{\linkS4class{NMFstd}}, and references and links therein for
+#' details on the built-in implementations of the standard NMF model and its
+#' extensions.
+#'
+#' @slot misc A list that is used internally to temporarily store algorithm
+#' parameters during the computation.
+#'
+#' @export
+#' @family NMF-interface
+#'
+#' @section Implementing NMF models:
+#'
+#' The class \code{NMF} only defines a basic data/low-level interface for NMF models, as
+#' a collection of generic methods, responsible with data handling, upon which
+#' relies a comprehensive set of functions, composing a rich higher-level interface.
+#'
+#' Actual NMF models are defined as sub-classes that inherits from class
+#' \code{NMF}, and implement the management of data storage, providing
+#' definitions for the interface's pure virtual methods.
+#'
+#' The minimum requirement to define a new NMF model that integrates into
+#' the framework of the \emph{NMF} package are the followings:
+#'
+#' \itemize{
+#'
+#' \item Define a class that inherits from class \code{NMF} and implements the
+#' new model, say class \code{myNMF}.
+#'
+#' \item Implement the following S4 methods for the new class \code{myNMF}:
+#' \describe{
+#' \item{fitted}{\code{signature(object = "myNMF", value = "matrix")}:
+#' Must return the estimated target matrix as fitted by the NMF model
+#' \code{object}.
+#' }
+#' \item{basis}{\code{signature(object = "myNMF")}:
+#' Must return the basis matrix(e.g. the first matrix factor in
+#' the standard NMF model).
+#' }
+#' \item{basis<-}{\code{signature(object = "myNMF", value = "matrix")}:
+#' Must return \code{object} with the basis matrix set to
+#' \code{value}.
+#' }
+#' \item{coef}{\code{signature(object = "myNMF")}:
+#' Must return the matrix of mixture coefficients (e.g. the second matrix
+#' factor in the standard NMF model).
+#' }
+#' \item{coef<-}{\code{signature(object = "myNMF", value = "matrix")}:
+#' Must return \code{object} with the matrix of mixture coefficients set to
+#' \code{value}.
+#' }
+#' }
+#'
+#' The \emph{NMF} package provides "pure virtual" definitions of these
+#' methods for class \code{NMF} (i.e. with signatures \code{(object='NMF', ...)}
+#' and \code{(object='NMF', value='matrix')}) that throw an error if called, so
+#' as to force their definition for model classes.
+#'
+#' \item Optionally, implement method \code{rnmf}(signature(x="myNMF", target="ANY")).
+#' This method should call \code{callNextMethod(x=x, target=target, ...)} and
+#' fill the returned NMF model with its specific data suitable random values.
+#' }
+#'
+#' For concrete examples of NMF models implementations, see class
+#' \code{\linkS4class{NMFstd}} and its extensions (e.g. classes
+#' \code{\linkS4class{NMFOffset}} or \code{\linkS4class{NMFns}}).
+#'
+#' @section Creating NMF objects:
+#' Strictly speaking, because class \code{NMF} is virtual, no object of class
+#' \code{NMF} can be instantiated, only objects from its sub-classes.
+#' However, those objects are sometimes shortly referred in the documentation and
+#' vignettes as "\code{NMF} objects" instead of "objects that inherits from
+#' class \code{NMF}".
+#'
+#' For built-in models or for models that inherit from the standard model class
+#' \code{\linkS4class{NMFstd}}, the factory method \code{nmfModel} enables to easily create
+#' valid \code{NMF} objects in a variety of common situations.
+#' See documentation for the the factory method \code{\link{nmfModel}} for
+#' more details.
+#'
+#' @references
+#' Definition of Nonnegative Matrix Factorization in its modern formulation: \cite{Lee1999}
+#'
+#' Historical first definition and algorithms: \cite{Paatero1994}
+#'
+#' @family NMF-model Implementations of NMF models
+#' @seealso
+#' Main interface to perform NMF in \code{\link{nmf-methods}}.
+#'
+#' Built-in NMF models and factory method in \code{\link{nmfModel}}.
+#'
+#' Method \code{\link{seed}} to set NMF objects with values suitable to start
+#' algorithms with.
+#'
+#' @examples
+#'
+#' # show all the NMF models available (i.e. the classes that inherit from class NMF)
+#' nmfModels()
+#' # show all the built-in NMF models available
+#' nmfModels(builtin.only=TRUE)
+#'
+#' # class NMF is a virtual class so cannot be instantiated:
+#' try( new('NMF') )
+#'
+#' # To instantiate an NMF model, use the factory method nmfModel. see ?nmfModel
+#' nmfModel()
+#' nmfModel(3)
+#' nmfModel(3, model='NMFns')
+#'
+setClass('NMF'
+ , representation(
+ misc = 'list' # misceleneaous data used during fitting
+ )
+ , contains = 'VIRTUAL')
+
+#' Fitted Matrix in NMF Models
+#'
+#' Computes the estimated target matrix based on a given \emph{NMF} model.
+#' The estimation depends on the underlying NMF model.
+#' For example in the standard model \eqn{V \equiv W H}{V ~ W H}, the target matrix is
+#' estimated by the matrix product \eqn{W H}.
+#' In other models, the estimate may depend on extra parameters/matrix
+#' (cf. Non-smooth NMF in \code{\link{NMFns-class}}).
+#'
+#' This function is a S4 generic function imported from \link[stats]{fitted} in
+#' the package \emph{stats}.
+#' It is implemented as a pure virtual method for objects of class
+#' \code{NMF}, meaning that concrete NMF models must provide a
+#' definition for their corresponding class (i.e. sub-classes of
+#' class \code{NMF}).
+#' See \code{\linkS4class{NMF}} for more details.
+#'
+#' @param object an object that inherit from class \code{NMF}
+#' @param ... extra arguments to allow extension
+#'
+#' @return the target matrix estimate as fitted by the model \code{object}
+#' @export
+setGeneric('fitted', package='stats')
+#' @template VirtualNMF
+setMethod('fitted', signature(object='NMF'),
+ function(object, ...){
+ stop("NMF::fitted is a pure virtual method of interface 'NMF'. It should be overloaded in class '", class(object),"'.")
+ }
+)
+
+#' Accessing NMF Factors
+#'
+#' \code{basis} and \code{basis<-} are S4 generic functions which respectively
+#' extract and set the matrix of basis components of an NMF model
+#' (i.e. the first matrix factor).
+#'
+#' For example, in the case of the standard NMF model \eqn{V \equiv W H}{V ~ W H},
+#' the method \code{basis} will return the matrix \eqn{W}.
+#'
+#' \code{basis} and \code{basis<-} are defined for the top
+#' virtual class \code{\linkS4class{NMF}} only, and rely internally on the low-level
+#' S4 generics \code{.basis} and \code{.basis<-} respectively that effectively
+#' extract/set the coefficient data.
+#' These data are post/pre-processed, e.g., to extract/set only their
+#' non-fixed terms or check dimension compatibility.
+#'
+#' @param object an object from which to extract the factor matrices, typically an
+#' object of class \code{\linkS4class{NMF}}.
+#' @param ... extra arguments to allow extension and passed to the low-level
+#' access functions \code{.coef} and \code{.basis}.
+#'
+#' Note that these throw an error if used in replacement functions \code{}.
+#'
+#' @rdname basis-coef-methods
+#' @family NMF-interface
+#' @export
+#'
+setGeneric('basis', function(object, ...) standardGeneric('basis') )
+#' Default method returns the value of S3 slot or attribute \code{'basis'}.
+#' It returns \code{NULL} if none of these are set.
+#'
+#' Arguments \code{...} are not used by this method.
+setMethod('basis', signature(object='ANY'),
+ function(object, ...){
+ if( is.list(object) && 'basis' %in% names(object) ) object[['basis']]
+ else attr(object, 'basis')
+ }
+)
+#' @param all a logical that indicates whether the complete matrix factor
+#' should be returned (\code{TRUE}) or only the non-fixed part.
+#' This is relevant only for formula-based NMF models that include fixed basis or
+#' coefficient terms.
+#'
+#' @inline
+setMethod('basis', signature(object='NMF'),
+ function(object, all=TRUE, ...){
+ if( all || !length(i <- ibterms(object)) ){
+ # return all coefficients
+ .basis(object, ...)
+ } else {
+ # remove fixed basis
+ .basis(object, ...)[, -i]
+ }
+ }
+)
+
+#' \code{.basis} and \code{.basis<-} are the low-level S4 generics that simply
+#' return/set basis component data in an object.
+#' They are defined so that some common processing may be implemented in
+#' \code{basis} and \code{basis<-}.
+#'
+#' The methods \code{.basis}, \code{.coef} and their replacement versions
+#' are implemented as pure virtual methods for the interface class
+#' \code{NMF}, meaning that concrete NMF models must provide a
+#' definition for their corresponding class (i.e. sub-classes of
+#' class \code{NMF}).
+#' See \code{\linkS4class{NMF}} for more details.
+#'
+#' @rdname basis-coef-methods
+#' @export
+setGeneric('.basis', function(object, ...) standardGeneric('.basis') )
+#' @template VirtualNMF
+setMethod('.basis', signature(object='NMF'),
+ function(object, ...){
+ stop("NMF::.basis is a pure virtual method of interface 'NMF'. It should be overloaded in class '", class(object),"'.")
+ }
+)
+
+#' @export
+#' @rdname basis-coef-methods
+#' @inline
+setGeneric('basis<-', function(object, ..., value) standardGeneric('basis<-') )
+#' Default methods that calls \code{.basis<-} and check the validity of the
+#' updated object.
+#' @param use.dimnames logical that indicates if the object's dim names should be
+#' set using those from the new value, or left unchanged -- after truncating
+#' them to fit new dimensions if necessary.
+#' This is useful to only set the entries of a factor.
+#'
+setReplaceMethod('basis', signature(object='NMF', value='ANY'),
+ function(object, use.dimnames = TRUE, ..., value){
+
+ # error if passed extra arguments
+ if( length(xargs<- list(...)) ){
+ stop("basis<-,NMF - Unused arguments: ", str_out(xargs, Inf, use.names = TRUE))
+ }
+
+ # backup old dimnames to reapply them on exit
+ if( !use.dimnames ) odn <- dimnames(object)
+ nb_old <- nbasis(object)
+
+ # only set non-fixed terms
+ if( !nbterms(object) ) .basis(object) <- value
+ else{
+ i <- ibasis(object)
+ .basis(object)[,i] <- value[, i]
+ }
+ # adapt coef if empty
+ if( !hasCoef(object) ){
+ x <- basis(object)
+ .coef(object) <- rbind(coef(object)[1:min(nb_old, ncol(x)), , drop = FALSE], matrix(NA, max(ncol(x)-nb_old, 0), 0))
+# .coef(object) <- coef(object)[1:ncol(x), , drop = FALSE]
+ }
+ # check object validity
+ validObject(object)
+
+ # update other factor if necessary
+ if( use.dimnames ) basisnames(object) <- colnames(basis(object))
+ else if( !length(odn) ) dimnames(object) <- NULL
+ else dimnames(object) <- mapply(head, odn, dim(object), SIMPLIFY = FALSE)
+
+ object
+ }
+)
+#' @param value replacement value
+#' @rdname basis-coef-methods
+#' @export
+setGeneric('.basis<-', function(object, value) standardGeneric('.basis<-') )
+#' @template VirtualNMF
+setReplaceMethod('.basis', signature(object='NMF', value='matrix'),
+ function(object, value){
+ stop("NMF::.basis<- is a pure virtual method of interface 'NMF'. It should be overloaded in class '", class(object),"'.")
+ }
+)
+
+#' @export
+setGeneric('loadings', package='stats')
+#' Method loadings for NMF Models
+#'
+#' The method \code{loadings} is identical to \code{basis}, but do
+#' not accept any extra argument.
+#'
+#' The method \code{loadings} is provided to standardise the NMF interface
+#' against the one defined in the \code{\link{stats}} package,
+#' and emphasises the similarities between NMF and PCA or factorial analysis
+#' (see \code{\link{loadings}}).
+#'
+#' @rdname basis-coef-methods
+setMethod('loadings', 'NMF', function(x) basis(x) )
+
+#' Get/Set the Coefficient Matrix in NMF Models
+#'
+#' \code{coef} and \code{coef<-} respectively extract and set the
+#' coefficient matrix of an NMF model (i.e. the second matrix factor).
+#' For example, in the case of the standard NMF model \eqn{V \equiv WH}{V ~ W H},
+#' the method \code{coef} will return the matrix \eqn{H}.
+#'
+#' \code{coef} and \code{coef<-} are S4 methods defined for the corresponding
+#' generic functions from package \code{stats} (See \link[stats]{coef}).
+#' Similarly to \code{basis} and \code{basis<-}, they are defined for the top
+#' virtual class \code{\linkS4class{NMF}} only, and rely internally on the S4
+#' generics \code{.coef} and \code{.coef<-} respectively that effectively
+#' extract/set the coefficient data.
+#' These data are post/pre-processed, e.g., to extract/set only their
+#' non-fixed terms or check dimension compatibility.
+#'
+#' @rdname basis-coef-methods
+#' @export
+setGeneric('coef', package='stats')
+#' @inline
+setMethod('coef', 'NMF',
+ function(object, all=TRUE, ...){
+
+ if( all || !length(i <- icterms(object)) ){
+ # return all coefficients
+ .coef(object, ...)
+ } else {
+ # remove fixed coefficients
+ .coef(object, ...)[-i, ]
+ }
+
+ }
+)
+
+#' \code{.coef} and \code{.coef<-} are low-level S4 generics that simply
+#' return/set coefficient data in an object, leaving some common processing
+#' to be performed in \code{coef} and \code{coef<-}.
+#'
+#' @rdname basis-coef-methods
+#' @export
+setGeneric('.coef', function(object, ...) standardGeneric('.coef'))
+#' @template VirtualNMF
+setMethod('.coef', signature(object='NMF'),
+ function(object, ...){
+ stop("NMF::.coef is a pure virtual method of interface 'NMF'. It should be overloaded in class '", class(object),"'.")
+ }
+)
+
+#' @export
+#' @rdname basis-coef-methods
+#' @inline
+setGeneric('coef<-', function(object, ..., value) standardGeneric('coef<-') )
+#' Default methods that calls \code{.coef<-} and check the validity of the
+#' updated object.
+setReplaceMethod('coef', signature(object='NMF', value='ANY'),
+ function(object, use.dimnames = TRUE, ..., value){
+
+ # error if passed extra arguments
+ if( length(xargs<- list(...)) ){
+ stop("coef<-,NMF - Unused arguments: ", str_out(xargs, Inf, use.names = TRUE))
+ }
+ # backup old dimnames to reapply them on exit
+ if( !use.dimnames ) odn <- dimnames(object)
+ nb_old <- nbasis(object)
+
+ # only set non-fixed terms
+ if( !ncterms(object) ) .coef(object) <- value
+ else{
+ i <- icoef(object)
+ .coef(object)[i, ] <- value[i, ]
+ }
+ # adapt basis if empty before validation
+ if( !hasBasis(object) ){
+ x <- coef(object)
+ .basis(object) <- cbind(basis(object)[, 1:min(nb_old, nrow(x)), drop = FALSE], matrix(NA, 0, max(nrow(x)-nb_old, 0)))
+ }
+ # check object validity
+ validObject(object)
+
+ # update other factor if necessary
+ if( use.dimnames ) basisnames(object) <- rownames(coef(object))
+ else if( !length(odn) ) dimnames(object) <- NULL
+ else dimnames(object) <- mapply(head, odn, dim(object), SIMPLIFY = FALSE)
+
+
+ object
+ }
+)
+
+#' @export
+#' @rdname basis-coef-methods
+setGeneric('.coef<-', function(object, value) standardGeneric('.coef<-') )
+#' @template VirtualNMF
+setReplaceMethod('.coef', signature(object='NMF', value='matrix'),
+ function(object, value){
+ stop("NMF::.coef<- is a pure virtual method of interface 'NMF'. It should be overloaded in class '", class(object),"'.")
+ }
+)
+
+#' @description Methods \code{coefficients} and \code{coefficients<-} are
+#' simple aliases for methods \code{coef} and \code{coef<-} respectively.
+#'
+#' @export
+#' @rdname basis-coef-methods
+setGeneric('coefficients', package='stats')
+#' Alias to \code{coef,NMF}, therefore also pure virtual.
+#' @inline
+setMethod('coefficients', signature(object='NMF'), selectMethod('coef', 'NMF'))
+
+#' @description \code{scoef} is similar to \code{coef}, but returns the mixture
+#' coefficient matrix of an NMF model, with the columns scaled so that they
+#' sum up to a given value (1 by default).
+#'
+#' @param scale scaling factor, which indicates to the value the columns of the
+#' coefficient matrix should sum up to.
+#'
+#' @rdname basis-coef-methods
+#' @export
+#'
+#' @examples
+#'
+#' # Scaled coefficient matrix
+#' x <- rnmf(3, 10, 5)
+#' scoef(x)
+#' scoef(x, 100)
+#'
+setGeneric('scoef', function(object, ...) standardGeneric('scoef') )
+#' @inline
+setMethod('scoef', 'NMF',
+ function(object, scale=1){
+ sweep(coef(object), 2L, colSums(coef(object)) / scale, '/')
+ }
+)
+#' @inline
+setMethod('scoef', 'matrix',
+ function(object, scale=1){
+ sweep(object, 2L, colSums(object) / scale, '/')
+ }
+)
+
+unit.test(scoef, {
+ x <- rnmf(3, 10, 5)
+ checkIdentical(colSums(scoef(x)), rep(1, nbasis(x))
+ , "Default call: columns are scaled to sum-up to one")
+ checkIdentical(colSums(scoef(x, 100)), rep(1, nbasis(x))
+ , "Scale=10: columns are scaled to sum-up to 10")
+})
+
+#' Rescaling NMF Models
+#'
+#' Rescales an NMF model keeping the fitted target matrix identical.
+#'
+#' Standard NMF models are identifiable modulo a scaling factor, meaning that the
+#' basis components and basis profiles can be rescaled without changing the fitted
+#' values:
+#'
+#' \deqn{X = W_1 H_1 = (W_1 D) (D^{-1} H_1) = W_2 H_2}{X = W H = (W D) (D^-1 H)}
+#' with \eqn{D= \alpha diag(1/\delta_1, \ldots, 1\delta_r)}{D= alpha * diag(1/delta_1, ..., 1/delta_r)}
+#'
+#' The default call \code{scale(object)} rescales the basis NMF object so that each
+#' column of the basis matrix sums up to one.
+#'
+#' @param x an NMF object
+#' @param center either a numeric normalising vector \eqn{\delta}{delta}, or either
+#' \code{'basis'} or \code{'coef'}, which respectively correspond to using the
+#' column sums of the basis matrix or the inverse of the row sums of the
+#' coefficient matrix as a normalising vector.
+#' If numeric, \code{center} should be a single value or a vector of length the
+#' rank of the NMF model, i.e. the number of columns in the basis matrix.
+#' @param scale scaling coefficient applied to \eqn{D}, i.e. the value of \eqn{\alpha}{alpha},
+#' or, if \code{center='coef'}, the value of \eqn{1/\alpha}{1/alpha} (see section \emph{Details}).
+#'
+#' @return an NMF object
+#'
+#' @S3method scale NMF
+#' @examples
+#'
+#' # random 3-rank 10x5 NMF model
+#' x <- rnmf(3, 10, 5)
+#'
+#' # rescale based on basis
+#' colSums(basis(x))
+#' colSums(basis(scale(x)))
+#'
+#' rx <- scale(x, 'basis', 10)
+#' colSums(basis(rx))
+#' rowSums(coef(rx))
+#'
+#' # rescale based on coef
+#' rowSums(coef(x))
+#' rowSums(coef(scale(x, 'coef')))
+#' rx <- scale(x, 'coef', 10)
+#' rowSums(coef(rx))
+#' colSums(basis(rx))
+#'
+#' # fitted target matrix is identical but the factors have been rescaled
+#' rx <- scale(x, 'basis')
+#' all.equal(fitted(x), fitted(rx))
+#' all.equal(basis(x), basis(rx))
+#'
+scale.NMF <- function(x, center=c('basis', 'coef'), scale=1){
+
+ # determine base value
+ if( missing(center) ) center <- match.arg(center)
+ base <- center
+ delta <-
+ if( is.character(base) ){
+ base <- match.arg(center)
+ if( base == 'basis' ) colSums(basis(x))
+ else{
+ scale <- 1/scale
+ 1 / rowSums(coef(x))
+ }
+ }else if( is.numeric(base) ) base
+ else stop("Invalid base value: should be a numeric or one of "
+ , str_out(c('none', 'basis', 'coef')))
+
+ # scale
+ D <- scale/delta
+ # W <- W * D
+ basis(x) <- sweep(basis(x), 2L, D, '*')
+ # H <- D^-1 * H
+ coef(x) <- sweep(coef(x), 1L, D, '/')
+ x
+
+}
+
+unit.test("scale", {
+
+ r <- 3
+ x <- rnmf(r, 10, 5)
+
+ .lcheck <- function(msg, rx, ref, target){
+ .msg <- function(...) paste(msg, ':', ...)
+ checkTrue(!identical(basis(x), basis(rx)), .msg("changes basis matrix"))
+ checkTrue(!identical(coef(x), coef(rx)), .msg("changes coef matrix"))
+ checkEqualsNumeric(fitted(x), fitted(rx), .msg("fitted target is identical"))
+
+ brx <- colSums(basis(rx))
+ crx <- rowSums(coef(rx))
+ if( target == 1 ){
+ checkEquals(brx, ref, .msg("correctly scales basis components"))
+ checkTrue(!all(crx==ref), .msg("does not force scale on coefficient matrix"))
+ }else{
+ checkTrue(!all(brx==ref), .msg("does not force scale on basis matrix"))
+ checkEquals(crx, ref
+ , .msg("correctly scales rows of coef matrix"))
+ }
+ }
+
+ .check <- function(msg, ref, ...){
+ .lcheck(str_c(msg, " + argument center='basis'")
+ , scale(x, center='basis', ...), ref, 1)
+ .lcheck(str_c(msg, " + argument center='coef'")
+ , scale(x, center='coef', ...), ref, 2)
+ }
+
+ .lcheck("Default call", scale(x), rep(1, r), 1)
+ .check("Missing argument scale", rep(1, r))
+ .check("Argument scale=10", rep(10, r), scale=10)
+ s <- runif(r)
+ .check("Argument scale=numeric", s, scale=s)
+
+})
+
+#' Generating Random NMF Models
+#'
+#' Generates NMF models with random values drawn from a uniform distribution.
+#' It returns an NMF model with basis and mixture coefficient matrices filled
+#' with random values.
+#' The main purpose of the function \code{rnmf} is to provide a common
+#' interface to generate random seeds used by the \code{\link{nmf}} function.
+#'
+#' If necessary, extensions of the standard NMF model or custom models must
+#' define a method "rnmf,<NMF.MODEL.CLASS>,numeric" for initialising their
+#' specific slots other than the basis and mixture coefficient matrices.
+#' In order to benefit from the complete built-in interface, the overloading
+#' methods should call the generic version using function
+#' \code{\link{callNextMethod}}, prior to set the values of the specific slots.
+#' See for example the method \code{\link[=rnmf,NMFOffset,numeric-method]{rnmf}}
+#' defined for \code{\linkS4class{NMFOffset}} models:
+#' \code{showMethods(rnmf, class='NMFOffset', include=TRUE))}.
+#'
+#' For convenience, shortcut methods for working on \code{data.frame} objects
+#' directly are implemented.
+#' However, note that conversion of a \code{data.frame} into a \code{matrix}
+#' object may take some non-negligible time, for large datasets.
+#' If using this method or other NMF-related methods several times, consider
+#' converting your data \code{data.frame} object into a matrix once for good,
+#' when first loaded.
+#'
+#' @param x an object that determines the rank, dimension and/or class of the
+#' generated NMF model, e.g. a numeric value or an object that inherits from class
+#' \code{\linkS4class{NMF}}.
+#' See the description of the specific methods for more details on the supported
+#' types.
+#' @param target optional specification of target dimensions.
+#' See section \emph{Methods} for how this parameter is used by the different
+#' methods.
+#' @param ... extra arguments to allow extensions and passed to the next method
+#' eventually down to \code{\link{nmfModel}}, where they are used to initialise
+#' slots that are specific to the instantiating NMF model.
+#'
+#' @return An NMF model, i.e. an object that inherits from class
+#' \code{\linkS4class{NMF}}.
+#'
+#' @inline
+#' @export
+#' @seealso \code{\link{rmatrix}}
+#' @family NMF-interface
+setGeneric('rnmf', function(x, target, ...) standardGeneric('rnmf') )
+
+# Define the loading namespace
+.PKG.NAMESPACE <- packageEnv()
+
+#' Testing NMF Objects
+#'
+#' @description
+#' The functions documented here tests different characteristics of NMF objects.
+#'
+#' \code{is.nmf} tests if an object is an NMF model or a class that extends
+#' the class NMF.
+#'
+#' @details
+#'
+#' \code{is.nmf} tests if \code{object} is the name of a class (if a \code{character}
+#' string), or inherits from a class, that extends \code{\linkS4class{NMF}}.
+#'
+#' @note The function \code{is.nmf} does some extra work with the namespace as
+#' this function needs to return correct results even when called in \code{.onLoad}.
+#' See discussion on r-devel: \url{https://stat.ethz.ch/pipermail/r-devel/2011-June/061357.html}
+#'
+#' @param x an R object. See section \emph{Details}, for how each function
+#' uses this argument.
+#'
+#' @rdname types
+#' @export
+#'
+#' @examples
+#'
+#' # test if an object is an NMF model, i.e. that it implements the NMF interface
+#' is.nmf(1:4)
+#' is.nmf('NMFstd')
+#' is.nmf('NMFblah')
+#' is.nmf( nmfModel(3) )
+#' is.nmf( nmf(rmatrix(20,10), 3) )
+#'
+is.nmf <- function(x){
+
+ # load definition for base class NMF
+ clref <- getClass('NMF', .Force=TRUE, where=.PKG.NAMESPACE)
+ is(x, clref)
+
+}
+
+unit.test(is.nmf,{
+ checkTrue(!is.nmf(1:4), "on vector: FALSE")
+ checkTrue(!is.nmf(list(1:4)), "on list: FALSE")
+ checkTrue(is.nmf('NMF'), "on 'NMF': TRUE")
+ checkTrue(is.nmf('NMFstd'), "on 'NMFstd': TRUE")
+ checkTrue( is.nmf( nmfModel(3) ), "on empty model: TRUE")
+ checkTrue( is.nmf( rnmf(3, 20, 10) ), "on random model: TRUE")
+ checkTrue( is.nmf( nmf(rmatrix(20,10), 3) ), "on NMFfit object: TRUE")
+})
+
+isNMFclass <- function(x){
+
+ if( is.character(x) ){ # test object is a class that extends NMF
+ # load definition for base class NMF
+ clref <- getClass('NMF', .Force=TRUE, where=.PKG.NAMESPACE)
+ cl <- getClass(x, .Force=TRUE, where=.PKG.NAMESPACE)
+ if( is.null(cl) )
+ cl <- getClass(x, .Force=TRUE)
+ extends(cl, clref)
+ }else
+ FALSE
+
+}
+
+################################
+
+# Taken from Biobase
+selectSome <- function (obj, maxToShow = 5)
+{
+ len <- length(obj)
+ if (maxToShow < 3)
+ maxToShow <- 3
+ if (len > maxToShow) {
+ maxToShow <- maxToShow - 1
+ bot <- ceiling(maxToShow/2)
+ top <- len - (maxToShow - bot - 1)
+ nms <- obj[c(1:bot, top:len)]
+ c(as.character(nms[1:bot]), "...", as.character(nms[-c(1:bot)]))
+ }
+ else if (is.factor(obj))
+ as.character(obj)
+ else obj
+}
+
+
+.showFixedTerms <- function(x, ...){
+
+ s <-
+ sapply(x, function(t){
+ s <-
+ if( is.factor(t) ) selectSome(levels(t), ...)
+ else selectSome(t, ...)
+ s <- str_out(s, Inf, quote=FALSE)
+ if( is.factor(t) )
+ s <- str_c('<', s, ">")
+ s
+ })
+ paste(names(s), '=', s)
+}
+
+#' Show method for objects of class \code{NMF}
+#' @export
+setMethod('show', 'NMF',
+ function(object)
+ {
+ cat("<Object of class:", class(object), ">\n", sep='')
+ cat("features:", nrow(object), "\n")
+ cat("basis/rank:", nbasis(object), "\n")
+ cat("samples:", ncol(object), "\n")
+ # show fixed terms
+ if( (n <- ncterms(object)) ){
+ cat("fixed coef [", n, "]:\n"
+ , str_c(' ', .showFixedTerms(cterms(object), 4), collapse="\n")
+ , "\n", sep='')
+ }
+ if( (n <- nbterms(object)) ){
+ cat("fixed basis [", n, "]:\n"
+ , str_c(' ', .showFixedTerms(bterms(object), 4), collapse="\n")
+ , "\n", sep='')
+ }
+ # show the miscellaneous model parameters
+ if( length(object at misc) > 0L ){
+ cat("miscellaneous:", str_desc(object at misc, exdent=12L), ". (use 'misc(object)')\n")
+ }
+ }
+)
+
+
+#' Dimension of NMF Objects
+#'
+#' @description
+#' The methods \code{dim}, \code{nrow}, \code{ncol} and \code{nbasis} return
+#' the different dimensions associated with an NMF model.
+#'
+#' \code{dim} returns all dimensions in a length-3 integer vector:
+#' the number of row and columns of the estimated target matrix,
+#' as well as the factorization rank (i.e. the number of basis components).
+#'
+#' \code{nrow}, \code{ncol} and \code{nbasis} provide separate access to each
+#' of these dimensions respectively.
+#'
+#' @details
+#' The NMF package does not implement specific functions \code{nrow} and \code{ncol},
+#' but rather the S4 method \code{dim} for objects of class \code{\linkS4class{NMF}}.
+#' This allows the base methods \code{\link{nrow}} and \code{\link{ncol}} to
+#' directly work with such objects, to get the number of rows and columns of
+#' the target matrix estimated by an NMF model.
+#'
+#' The function \code{nbasis} is a new S4 generic defined in the package NMF, that
+#' returns the number of basis components of an object.
+#' Its default method should work for any object, that has a suitable
+#' \code{basis} method defined for its class.
+#'
+#' @param x an object with suitable \code{basis} and \code{coef} methods, such
+#' as an object that inherit from \code{\linkS4class{NMF}}.
+#' @param ... extra arguments to allow extension.
+#'
+#' @return a single integer value or, for \code{dim}, a length-3 integer vector,
+#' e.g. \code{c(2000, 30, 3)} for an \code{NMF} model that fits a 2000 x 30
+#' matrix using 3 basis components.
+#'
+#' @export
+#' @rdname dims
+#' @aliases dim-NMF
+setGeneric('nbasis', function(x, ...) standardGeneric('nbasis') )
+#' Default method which returns the number of columns of the basis matrix extracted
+#' from \code{x} using a suitable method \code{basis}, or, if the latter is \code{NULL},
+#' the value of attributes \code{'nbasis'}.
+#'
+#' For NMF models, this also corresponds to the number of rows in the coefficient
+#' matrix.
+#'
+setMethod('nbasis', signature(x='ANY'),
+ function(x, ...)
+ {
+ if( !is.null(n <- ncol(basis(x, ...))) ) n
+ else if( is.list(x) && 'nbasis' %in% names(x) ) x[['nbasis']]
+ else attr(x, 'nbasis')
+ }
+)
+#' method for NMF objects for the base generic \code{\link{dim}}.
+#' It returns all dimensions in a length-3 integer vector:
+#' the number of row and columns of the estimated target matrix,
+#' as well as the factorization rank (i.e. the number of basis components).
+#'
+#' @rdname dims
+#' @export
+setMethod('dim', signature(x='NMF'),
+ function(x){
+ c(nrow(basis(x)), ncol(coef(x)), nbasis(x))
+ }
+)
+
+
+#' Dimension names for NMF objects
+#'
+#' @description
+#' The methods \code{dimnames}, \code{rownames}, \code{colnames} and
+#' \code{basisnames} and their respective replacement form allow to get and set
+#' the dimension names of the matrix factors in a NMF model.
+#'
+#' \code{dimnames} returns all the dimension names in a single list.
+#' Its replacement form \code{dimnames<-} allows to set all dimension names at once.
+#'
+#' \code{rownames}, \code{colnames} and \code{basisnames} provide separate access
+#' to each of these dimension names respectively.
+#' Their respective replacement form allow to set each dimension names separately.
+#'
+#' @details
+#'
+#' The function \code{basisnames} is a new S4 generic defined in the package NMF,
+#' that returns the names of the basis components of an object.
+#' Its default method should work for any object, that has a suitable \code{basis}
+#' method defined for its class.
+#'
+#' The method \code{dimnames} is implemented for the base generic \code{\link{dimnames}},
+#' which make the base function \code{\link{rownames}} and \code{\link{colnames}}
+#' work directly.
+#'
+#' Overall, these methods behave as their equivalent on \code{matrix} objects.
+#' The function \code{basisnames<-} ensures that the dimension names are handled
+#' in a consistent way on both factors, enforcing the names on both matrix factors
+#' simultaneously.
+#'
+#' @param x an object with suitable \code{basis} and \code{coef} methods, such
+#' as an object that inherit from \code{\linkS4class{NMF}}.
+#' @param ... extra argument to allow extension.
+#'
+#' @export
+#' @rdname dimnames
+#' @aliases dimnames-NMF
+#'
+#' @examples
+#' # create a random NMF object
+#' a <- rnmf(2, 5, 3)
+#'
+#' # set dimensions
+#' dims <- list( features=paste('f', 1:nrow(a), sep='')
+#' , samples=paste('s', 1:ncol(a), sep='')
+#' , basis=paste('b', 1:nbasis(a), sep='') )
+#' dimnames(a) <- dims
+#' dimnames(a)
+#' basis(a)
+#' coef(a)
+#'
+#' # access the dimensions separately
+#' rownames(a)
+#' colnames(a)
+#' basisnames(a)
+#'
+#' # set only the first dimension (rows of basis): the other two dimnames are set to NULL
+#' dimnames(a) <- dims[1]
+#' dimnames(a)
+#' basis(a)
+#' coef(a)
+#'
+#' # set only the two first dimensions (rows and columns of basis and coef respectively):
+#' # the basisnames are set to NULL
+#' dimnames(a) <- dims[1:2]
+#' dimnames(a)
+#' basis(a)
+#'
+#' # reset the dimensions
+#' dimnames(a) <- NULL
+#' dimnames(a)
+#' basis(a)
+#' coef(a)
+#'
+#' # set each dimensions separately
+#' rownames(a) <- paste('X', 1:nrow(a), sep='') # only affect rows of basis
+#' basis(a)
+#'
+#' colnames(a) <- paste('Y', 1:ncol(a), sep='') # only affect columns of coef
+#' coef(a)
+#'
+#' basisnames(a) <- paste('Z', 1:nbasis(a), sep='') # affect both basis and coef matrices
+#' basis(a)
+#' coef(a)
+#'
+setGeneric('basisnames', function(x, ...) standardGeneric('basisnames') )
+#' Default method which returns the column names of the basis matrix extracted from
+#' \code{x}, using the \code{basis} method.
+#'
+#' For NMF objects these also correspond to the row names of the coefficient matrix.
+setMethod('basisnames', signature(x='ANY'),
+ function(x)
+ {
+ colnames(basis(x))
+ }
+)
+#' The generic \code{basisnames<-} simultaneously sets the names of the basis
+#' components and coefficients of an object, for which suitable \code{basis}
+#' and \code{coef} methods are defined.
+#'
+#' @details
+#' The function \code{basisnames<-} is a new S4 generic defined in the package NMF,
+#' that sets the names of the basis components of an object.
+#' Its default method should work for any object, that has suitable \code{basis<-}
+#' and \code{coef<-} methods method defined for its class.
+#'
+#' @export
+#' @inline
+#' @rdname dimnames
+setGeneric('basisnames<-', function(x, ..., value) standardGeneric('basisnames<-') )
+#' Default method which sets, respectively, the row and the column names of the basis
+#' matrix and coefficient matrix of \code{x} to \code{value}.
+setReplaceMethod('basisnames', 'ANY',
+ function(x, ..., value)
+ {
+ rownames(.coef(x)) <- value
+ colnames(.basis(x)) <- value
+ x
+ }
+)
+
+#' Returns the dimension names of the NMF model \code{x}.
+#'
+#' It returns either NULL if no dimnames are set on the object,
+#' or a 3-length list containing the row names of the basis matrix,
+#' the column names of the mixture coefficient matrix, and the column names of
+#' the basis matrix (i.e. the names of the basis components).
+#'
+#' @param value a character vector, or \code{NULL} or, in the case of
+#' \code{dimnames<-}, a list 2 or 3-length list of character vectors.
+#'
+#' @rdname dimnames
+#' @export
+setMethod('dimnames', 'NMF',
+ function(x){
+ b <- dimnames(basis(x))
+ if( is.null(b) )
+ b <- list(NULL, NULL)
+ c <- dimnames(coef(x))
+ if( is.null(c) )
+ c <- list(NULL, NULL)
+ l <- c(b[1],c[2],b[2])
+ if( all(sapply(l, is.null)) ) NULL else l
+ }
+)
+#' sets the dimension names of the NMF model \code{x}.
+#'
+#' \code{value} can be \code{NULL} which resets all dimension names, or a
+#' 1, 2 or 3-length list providing names at least for the rows of the basis
+#' matrix.
+#'
+#' The optional second element of \code{value} (NULL if absent) is used to set
+#' the column names of the coefficient matrix.
+#' The optional third element of \code{value} (NULL if absent) is used to set
+#' both the column names of the basis matrix and the row names of the
+#' coefficient matrix.
+#'
+#' @rdname dimnames
+#' @export
+setReplaceMethod('dimnames', 'NMF',
+ function(x, value){
+ if( !is.list(value) && !is.null(value) )
+ stop("NMF::dimnames - Invalid value: must be a list or NULL.")
+
+ if( length(value) == 0 )
+ value <- NULL
+ else if( length(value) == 1 )
+ value <- c(value, list(NULL, NULL))
+ else if( length(value) == 2 ) # if only the two first dimensions reset the third one
+ value <- c(value, list(NULL))
+ else if( length(value)!=3 ) # check length of value
+ stop("NMF::dimnames - invalid argument 'value' [a 2 or 3-length list is expected]")
+
+ # only set relevant dimensions
+ if( length(w <- which(dim(x) == 0)) ){
+ value[w] <- sapply(value[w], function(x) NULL, simplify=FALSE)
+ }
+ # set dimnames
+ dimnames(.basis(x)) <- value[c(1,3)]
+ dimnames(.coef(x)) <- value[c(3,2)]
+ # return updated model
+ x
+ }
+)
+
+#' Sub-setting NMF Objects
+#'
+#' This method provides a convenient way of sub-setting objects of class \code{NMF},
+#' using a matrix-like syntax.
+#'
+#' It allows to consistently subset one or both matrix factors in the NMF model, as well
+#' as retrieving part of the basis components or part of the mixture coefficients with
+#' a reduced amount of code.
+#'
+#' @details
+#' The returned value depends on the number of subset index passed and the
+#' value of argument \code{drop}:
+#'
+#' \itemize{ \item No index as in \code{x[]} or \code{x[,]}: the value is the
+#' object \code{x} unchanged.
+#'
+#' \item One single index as in \code{x[i]}: the value is the complete NMF
+#' model composed of the selected basis components, subset by \code{i},
+#' except if argument \code{drop=TRUE}, or if it is missing and \code{i} is of length 1.
+#' Then only the basis matrix is returned with dropped dimensions:
+#' \code{x[i, drop=TRUE]} <=> \code{drop(basis(x)[, i])}.
+#'
+#' This means for example that \code{x[1L]} is the first basis vector,
+#' and \code{x[1:3, drop = TRUE]} is the matrix composed of the 3 first basis vectors -- in columns.
+#'
+#' Note that in version <= 0.18.3, the call \code{x[i, drop = TRUE.or.FALSE]} was equivalent to
+#' \code{basis(x)[, i, drop=TRUE.or.FALSE]}.
+#'
+#' \item More than one index with \code{drop=FALSE} (default) as in
+#' \code{x[i,j]}, \code{x[i,]}, \code{x[,j]}, \code{x[i,j,k]}, \code{x[i,,k]},
+#' etc...: the value is a \code{NMF} object whose basis and/or mixture
+#' coefficient matrices have been subset accordingly. The third index \code{k}
+#' affects simultaneously the columns of the basis matrix AND the rows of the
+#' mixture coefficient matrix. In this case argument \code{drop} is not used.
+#'
+#' \item More than one index with \code{drop=TRUE} and \code{i} xor \code{j}
+#' missing: the value returned is the matrix that is the more affected by the
+#' subset index. That is that \code{x[i, , drop=TRUE]} and \code{x[i, , k,
+#' drop=TRUE]} return the basis matrix subset by \code{[i,]} and \code{[i,k]}
+#' respectively, while \code{x[, j, drop=TRUE]} and \code{x[, j, k, drop=TRUE]}
+#' return the mixture coefficient matrix subset by \code{[,j]} and \code{[k,j]}
+#' respectively.
+#'
+#' }
+#'
+#' @param i index used to subset on the \strong{rows} of the basis matrix (i.e.
+#' the features).
+#' It can be a \code{numeric}, \code{logical}, or \code{character} vector
+#' (whose elements must match the row names of \code{x}).
+#' In the case of a \code{logical} vector the entries are recycled if necessary.
+#' @param j index used to subset on the \strong{columns} of the mixture
+#' coefficient matrix (i.e. the samples).
+#' It can be a \code{numeric}, \code{logical}, or \code{character} vector
+#' (whose elements must match the column names of \code{x}).
+#' In the case of a \code{logical} vector the entries are recycled if necessary.
+#' @param ... used to specify a third index to subset on the basis components,
+#' i.e. on both the columns and rows of the basis matrix and mixture
+#' coefficient respectively.
+#' It can be a \code{numeric}, \code{logical}, or \code{character} vector
+#' (whose elements must match the basis names of \code{x}).
+#' In the case of a \code{logical} vector the entries are recycled if necessary.
+#'
+#' Note that only the first extra subset index is used.
+#' A warning is thrown if more than one extra argument is passed in \code{...}.
+#' @param drop single \code{logical} value used to drop the \code{NMF-class}
+#' wrapping and only return subsets of one of the factor matrices (see \emph{Details})
+#'
+#' @rdname subset-NMF
+#' @export
+#' @examples
+#' # create a dummy NMF object that highlight the different way of subsetting
+#' a <- nmfModel(W=outer(seq(1,5),10^(0:2)), H=outer(10^(0:2),seq(-1,-10)))
+#' basisnames(a) <- paste('b', 1:nbasis(a), sep='')
+#' rownames(a) <- paste('f', 1:nrow(a), sep='')
+#' colnames(a) <- paste('s', 1:ncol(a), sep='')
+#'
+#' # or alternatively:
+#' # dimnames(a) <- list( features=paste('f', 1:nrow(a), sep='')
+#' # , samples=paste('s', 1:ncol(a), sep='')
+#' # , basis=paste('b', 1:nbasis(a)) )
+#'
+#' # look at the resulting NMF object
+#' a
+#' basis(a)
+#' coef(a)
+#'
+#' # extract basis components
+#' a[1]
+#' a[1, drop=FALSE] # not dropping matrix dimension
+#' a[2:3]
+#'
+#' # subset on the features
+#' a[1,]
+#' a[2:4,]
+#' # dropping the NMF-class wrapping => return subset basis matrix
+#' a[2:4,, drop=TRUE]
+#'
+#' # subset on the samples
+#' a[,1]
+#' a[,2:4]
+#' # dropping the NMF-class wrapping => return subset coef matrix
+#' a[,2:4, drop=TRUE]
+#'
+#' # subset on the basis => subsets simultaneously basis and coef matrix
+#' a[,,1]
+#' a[,,2:3]
+#' a[4:5,,2:3]
+#' a[4:5,,2:3, drop=TRUE] # return subset basis matrix
+#' a[,4:5,2:3, drop=TRUE] # return subset coef matrix
+#'
+#' # 'drop' has no effect here
+#' a[,,2:3, drop=TRUE]
+#'
+setMethod('[', 'NMF',
+ function (x, i, j, ..., drop = FALSE)
+ {
+ k <- NULL
+ mdrop <- missing(drop)
+
+ # compute number of arguments: x and drop are always passed
+ Nargs <- nargs() - !mdrop
+ single.arg <- FALSE
+ k.notmissing <- FALSE
+ if( !missing(i) && Nargs < 3L ){
+ k <- i
+ single.arg <- TRUE
+ }
+ else if( Nargs > 3L ){
+ dots <- list(...)
+ if( length(dots) != 1 )
+ warning("NMF::[ - using only the first extra subset index, the remaining ", length(dots)-1," are discarded.")
+ k <- dots[[1]]
+ k.notmissing <- TRUE
+ }
+
+ # no indice was provided => return the object unchanged
+ if ( missing(i) && missing(j) && !k.notmissing ) {
+ # check if there is other arguments
+ if (length(list(...)) != 0)
+ stop("NMF::[] method - please specify which features, samples or basis to subset. See class?NMF.")
+ # otherwise return the untouched object
+ return(x)
+ }
+
+ # subset the rows of the basis matrix
+ if ( !missing(i) && !single.arg )
+ .basis(x) <- basis(x)[i, , drop = FALSE]
+
+ # subset the columns of mixture coefficient matrix
+ if (!missing(j))
+ .coef(x) <- coef(x)[, j, drop = FALSE]
+
+ # subset the basis: columns of basis matrix and row of mixture coefficient matrix
+ if( single.arg || k.notmissing ){
+ .basis(x) <- basis(x)[, k, drop = FALSE]
+ # return basis only single arg and drop=TRUE
+ if( single.arg && ((mdrop && length(k) == 1L) || drop) ) return( drop(basis(x)) )
+ .coef(x) <- coef(x)[k, , drop = FALSE]
+ }
+
+ # if drop is TRUE and only one dimension is missing then return affected matrix
+ if( !single.arg && drop ){
+ if( missing(i) && !missing(j) )
+ return( drop(coef(x)) )
+ else if( missing(j) && !missing(i) )
+ return( drop(basis(x)) )
+ }
+
+ # return subset object
+ return(x)
+ }
+)
+
+#' The function \code{misc} provides access to miscellaneous data members stored
+#' in slot \code{misc} (as a \code{list}), which allow extensions of NMF models
+#' to be implemented, without defining a new S4 class.
+#'
+#' @param object an object that inherit from class \code{NMF}
+#' @param ... extra arguments (not used)
+#'
+#' @rdname NMF-class
+#' @export
+misc <- function(object, ...){
+ if( !isS4(object) && is.list(object) ) object[['misc']]
+ else attr(object, 'misc')
+}
+#' shortcut for \code{x@@misc[[name, exact=TRUE]]} respectively.
+#' @rdname NMF-class
+#' @export
+setMethod('$', 'NMF',
+ function(x, name){
+ x at misc[[name, exact=TRUE]];
+ }
+)
+#' shortcut for \code{x@@misc[[name]] <- value}
+#' @rdname NMF-class
+#' @export
+setReplaceMethod('$', 'NMF',
+ function(x, name, value) {
+ x at misc[[name]] <- value
+ x
+ }
+)
+
+#' @importFrom utils .DollarNames
+setGeneric('.DollarNames', package='utils')
+
+#' @S3method .DollarNames NMF
+.DollarNames.NMF <- function(x, pattern = "") grep(pattern, names(misc(x)), value=TRUE)
+
+#' Auto-completion for \code{\linkS4class{NMF}} objects
+#' @rdname NMF-class
+#' @export
+setMethod('.DollarNames', 'NMF', .DollarNames.NMF)
+
+#' \code{is.empty.nmf} tests whether an \code{NMF} object describes an empty NMF model,
+#' i.e. it contains no data.
+#'
+#' @details
+#' \code{is.empty.nmf} returns \code{TRUE} if the basis and coefficient matrices of
+#' \code{x} have respectively zero rows and zero columns.
+#' It returns \code{FALSE} otherwise.
+#'
+#' In particular, this means that an empty model can still have a non-zero number
+#' of basis components, i.e. a factorization rank that is not null.
+#' This happens, for example, in the case of NMF models created calling the factory method
+#' \code{\link{nmfModel}} with a value only for the factorization rank.
+#'
+#' @param ... extra parameters to allow extension or passed to subsequent calls
+#'
+#' @rdname types
+#' @export
+#'
+#' @examples
+#'
+#' # empty model
+#' is.empty.nmf( nmfModel(3) )
+#' # non empty models
+#' is.empty.nmf( nmfModel(3, 10, 0) )
+#' is.empty.nmf( rnmf(3, 10, 5) )
+#'
+is.empty.nmf <- function(x, ...){
+ nrow(x) == 0 && ncol(x) == 0
+}
+
+
+#' \code{hasBasis} tests whether an objects contains a basis matrix -- returned by
+#' a suitable method \code{basis} -- with at least one row.
+#'
+#' @rdname types
+#' @export
+hasBasis <- function(x) nbasis(x) && nrow(basis(x)) != 0L
+
+#' \code{hasBasis} tests whether an objects contains a coefficient matrix
+#' -- returned by a suitable method \code{coef} -- with at least one column.
+#'
+#' @rdname types
+#' @export
+hasCoef <- function(x) nbasis(x) && ncol(coef(x)) != 0L
+
+#' \code{is.partial.nmf} tests whether an NMF model object contains either an empty
+#' basis or coefficient matrix.
+#' It is a shorcut for \code{!hasCoef(x) || !hasBasis(x)}.
+#'
+#' @rdname types
+#' @export
+is.partial.nmf <- function(x) !hasCoef(x) || !hasBasis(x)
+
+#' Returns the target matrix estimate of the NMF model \code{x}, perturbated by
+#' adding a random matrix generated using the default method of \code{rmatrix}:
+#' it is a equivalent to \code{fitted(x) + rmatrix(fitted(x), ...)}.
+#'
+#' This method can be used to generate random target matrices that depart from
+#' a known NMF model to a controlled extend.
+#' This is useful to test the robustness of NMF algorithms to the presence of
+#' certain types of noise in the data.
+#'
+#' @examples
+#' # generate noisy fitted target from an NMF model (the true model)
+#' gr <- as.numeric(mapply(rep, 1:3, 3))
+#' h <- outer(1:3, gr, '==') + 0
+#' x <- rnmf(10, H=h)
+#' y <- rmatrix(x)
+#' \dontrun{
+#' # show heatmap of the noisy target matrix: block patterns should be clear
+#' aheatmap(y)
+#' }
+#' \dontshow{ stopifnot( identical(dim(y), dim(x)[1:2]) ) }
+#'
+#' # test NMF algorithm on noisy data
+#' # add some noise to the true model (drawn from uniform [0,1])
+#' res <- nmf(rmatrix(x), 3)
+#' summary(res)
+#'
+#' # add more noise to the true model (drawn from uniform [0,10])
+#' res <- nmf(rmatrix(x, max=10), 3)
+#' summary(res)
+#'
+setMethod('rmatrix', 'NMF',
+ function(x, ...){
+ a <- fitted(x)
+ a + rmatrix(a, ...)
+ }
+)
+
+unit.test('rmatrix,NMF',{
+
+ x <- nmfModel(3, 20, 5)
+ checTrue(is.matrix(y <- rmatrix(x)), "default call: no error")
+ checkIdentical(dim(y), dim(x)[1:2], "default call: correct dimension")
+ checkTrue( !any(is.na(basis(y))), 'default call: no NAs in basis anymore')
+ checkTrue( !any(is.na(coef(y))), 'default call: no NAs in coef anymore')
+ checkTrue( max( max(abs(basis(y)-basis(x))), max(abs(coef(y)-coef(x))) ) <= 1
+ , "default call: max difference is <= 1")
+
+ set.seed(123)
+ y <- rmatrix(x)
+ set.seed(123)
+ ref <- matrix(runif(nrow(x)*ncol(x)), nrow(x))
+ checkIdentical(ref, y - fitted(x), "default call: add uniform random noise to fitted matrix")
+
+ set.seed(123)
+ ref <- matrix(rnorm(nrow(x)*ncol(x)), nrow(x))
+ set.seed(123)
+ y <- rmatrix(x, rnorm)
+ checkIdentical(ref, y - fitted(x), "dist is taken into account: add normal random noise to fitted matrix")
+ set.seed(123)
+ y <- rmatrix(x, dist=rnorm)
+ checkIdentical(ref, y - fitted(x), "dist is taken into account: add normal random noise to fitted matrix")
+
+ set.seed(123)
+ checTrue(is.matrix(y <- rmatrix(x, max=10)), "call with arg max=10: no error")
+ checkTrue( max( max(abs(basis(y)-basis(x))), max(abs(coef(y)-coef(x))) ) <= 10
+ , "call with arg max=10: max difference is 10")
+ checkTrue( max( max(abs(basis(y)-basis(x))), max(abs(coef(y)-coef(x))) ) >= 5
+ , "call with arg max=10: max difference is >= 5")
+
+})
+
+###% Produces different kind of plots.
+#setGeneric('plot', package='graphics')
+#setMethod('plot', signature( x='NMF', y='missing'),
+# function(x, y, type=c('hist', 'heatmap'), ...)
+# {
+# # retrieve what to plot
+# type = match.arg(type)
+#
+# # save graphical parameters
+# oldpar = par(no.readonly=TRUE)
+# on.exit( {par(oldpar)} ) # reset the graphical parameters on exit
+#
+# if( what == 'heatmap' ){
+# #basicHM(metaprofiles(x), ...)
+# heatmap.2(metaprofiles(x), trace='none', ...)
+# }
+# else if( what == 'hist' ) hist(x, ...)
+#
+# }
+#)
+
+#setGeneric('hist', package='graphics')
+#setMethod('hist', signature(x='NMF'),
+# function(x, ref=1, alpha=20, ...)
+# {
+# stopifnot( ref >= 1 && ref <= ncol(metagenes(x)) )
+# alpha = sprintf("%02d", alpha) #add leading zero to alpha if nessecary
+#
+# # save graphical parameters
+# oldpar = par(no.readonly=TRUE)
+# on.exit( {par(oldpar)} ) # reset the graphical parameters on exit
+#
+# # order genes by decreasing contribution to the reference factor
+# M = metagenes(x)[order(metagenes(x)[,ref], decreasing=T), ]
+#
+# #plot the contributions to the reference factor
+# par(lwd = 0.5)
+# x = seq(nrow(M))
+# html.colors = apply( col2rgb( seq(ncol(M))+1 ), 2, function(x) paste("#", paste(intToHex(x), collapse=''), alpha, sep='') )
+# plot(x=x, y=M[,ref], type='h'
+# , col=html.colors[ref], ylim=c(min(M), max(M))
+# , main='Contribution to metagenes', xlab=paste('Genes ordered based on factor', ref), ylab='Contribution')
+#
+# # plot the remaining metagenes
+# remaining.factor = seq(ncol(M))[seq(ncol(M)) != ref]
+# sapply(remaining.factor,
+# function(f){
+# lines(x=x, M[,f], type='h', col=html.colors[f])
+# }
+# )
+#
+# #put the legend
+# legend('top', legend=paste('Factor', seq(ncol(M))), fill=sub("^(#[a-f0-9]{6}).*", "\\1", html.colors, ignore.case=TRUE) )
+#
+# invisible()
+# }
+#)
+
+###% Utility function used to sets default elements in a list if they are
+###% not already set
+###% The default values are given in argument ...
+.set.list.defaults <- function(input.list, ...){
+ expand_list(input.list, ..., .exact=FALSE)
+}
+
+###% Partially match arguments for a given function
+.match.call.args <- function(x, fun, in.fun=NULL, call=NULL){
+ stopifnot( is.character(fun) && length(fun) == 1 )
+ if( length(x) == 0 ) return(x)
+ x.ind <- charmatch(x, args <- formalArgs(getFunction(fun)))
+
+ sapply(seq(length(x)), function(i){
+ ind <- x.ind[i]
+ # the argument is not part of the call: keep it unchanged
+ if( is.na(ind) ) return(x[i])
+ # multiple matches: error
+ if( ind == 0 ){
+ alt <- paste(grep(paste('^', x[i], sep=''), args, value=TRUE), collapse=', ')
+ stop(if( !is.null(call) ) c(call, ' - '), "Multiple match for argument '", x[i], "' of function '"
+ , if( is.null(in.fun) ) fun else in.fun, "' [use one of: ", alt, "]"
+ , call.=FALSE)
+ }
+ # return the matched full names
+ args[ind]
+ })
+}
+
+
+###% Computes a set of measures usefull to assess the factorization's quality.
+###%
+###%
+###% @param object a \code{NMF} object
+###% @return a numeric vector of the measures.
+###%
+#' Assessing and Comparing NMF Models
+#'
+#' @description
+#' The NMF package defines \code{summary} methods for different classes of objects,
+#' which helps assessing and comparing the quality of NMF models by computing a set
+#' of quantitative measures, e.g. with respect to their ability to recover known
+#' classes and/or the original target matrix.
+#'
+#' The most useful methods are for classes \code{\linkS4class{NMF}}, \code{\linkS4class{NMFfit}},
+#' \code{\linkS4class{NMFfitX}} and \code{\linkS4class{NMFList}}, which compute summary measures
+#' for, respectively, a single NMF model, a single fit, a multiple-run fit and a list of heterogenous
+#' fits performed with the function \code{\link{nmf}}.
+#'
+#' @details
+#' Due to the somehow hierarchical structure of the classes mentionned in \emph{Description},
+#' their respective \code{summary} methods call each other in chain, each super-class adding some
+#' extra measures, only relevant for objects of a specific class.
+#'
+#' @param object an NMF object. See available methods in section \emph{Methods}.
+#' @param ... extra arguments passed to the next \code{summary} method.
+#'
+#' @export
+#' @rdname assess
+#' @aliases summary-NMF
+#'
+#' @family assess Assessment measures for NMF models
+#'
+setGeneric('summary', package='base')
+
+#' Computes summary measures for a single NMF model.
+#'
+#' The following measures are computed:
+#'
+#' \describe{
+#' \item{sparseness}{Sparseness of the factorization computed by the
+#' function \code{\link{sparseness}}.}
+#' \item{entropy}{Purity of the clustering, with respect to known classes,
+#' computed by the function \code{\link{purity}}.}
+#' \item{entropy}{Entropy of the clustering, with respect to known classes,
+#' computed by the function \code{\link{entropy}}.}
+#' \item{RSS}{Residual Sum of Squares computed by the function \code{\link{rss}}.}
+#' \item{evar}{Explained variance computed by the function \code{\link{evar}}.}
+#' }
+#'
+#' @param class known classes/cluster of samples specified in one of the formats
+#' that is supported by the functions \code{\link{entropy}} and \code{\link{purity}}.
+#' @param target target matrix specified in one of the formats supported by the
+#' functions \code{\link{rss}} and \code{\link{evar}}
+#'
+#' @rdname assess
+#'
+#' @examples
+#'
+#' # random NMF model
+#' x <- rnmf(3, 20, 12)
+#' summary(x)
+#' summary(x, gl(3, 4))
+#' summary(x, target=rmatrix(x))
+#' summary(x, gl(3,4), target=rmatrix(x))
+#'
+setMethod('summary', signature(object='NMF'),
+ function(object, class, target){
+
+ res <- numeric()
+
+ ## IMPORTANT: if adding a summary measure also add it in the sorting
+ ## schema of method NMFList::summary to allow ordering on it
+
+ # rank
+ res <- c(res, rank=nbasis(object))
+ # compute sparseness
+ res <- c(res, sparseness=sparseness(object))
+
+ # if class is provided: also computes entropy and purity
+ if( !missing(class) ){
+ # compute purity
+ res <- c(res, purity=purity(object, class))
+ # compute entropy
+ res <- c(res, entropy=entropy(object, class))
+ }
+
+ # if the target is provided compute the RSS
+ if( !missing(target) ){
+ RSS <- rss(object, target)
+ res <- c(res, rss=RSS)
+ # explained variance
+ res <- c(res, evar=evar(object, target))
+ }
+
+ # compute mean silhouette width
+ siS <- silhouette(object, what = 'samples')
+ siF <- silhouette(object, what = 'features')
+ res <- c(res, silhouette.coef = if( !is_NA(siS) ) summary(siS)$avg.width else NA
+ , silhouette.basis = if( !is_NA(siF) ) summary(siF)$avg.width else NA)
+
+ # return result
+ return(res)
+ }
+)
+
+
+#' Sparseness
+#'
+#' Generic function that computes the \emph{sparseness} of an object, as defined
+#' by \cite{Hoyer2004}.
+#' The sparseness quantifies how much energy of a vector is packed into only few components.
+#'
+#' In \cite{Hoyer2004}, the sparseness is defined for a real vector \eqn{x} as:
+#' \deqn{Sparseness(x) = \frac{\sqrt{n} - \frac{\sum |x_i|}{\sqrt{\sum x_i^2}}}{\sqrt{n}-1}}{
+#' (srqt(n) - ||x||_1 / ||x||_2) / (sqrt(n) - 1)}
+#'
+#' , where \eqn{n} is the length of \eqn{x}.
+#'
+#' The sparseness is a real number in \eqn{[0,1]}.
+#' It is equal to 1 if and only if \code{x} contains a single nonzero component,
+#' and is equal to 0 if and only if all components of \code{x} are equal.
+#' It interpolates smoothly between these two extreme values.
+#' The closer to 1 is the sparseness the sparser is the vector.
+#'
+#' The basic definition is for a \code{numeric} vector, and is extended for matrices as the
+#' mean sparseness of its column vectors.
+#'
+#' @param x an object whose sparseness is computed.
+#' @param ... extra arguments to allow extension
+#'
+#' @return usually a single numeric value -- in [0,1], or a numeric vector.
+#' See each method for more details.
+#'
+#' @export
+#' @family assess
+setGeneric('sparseness', function(x, ...) standardGeneric('sparseness') )
+#' Base method that computes the sparseness of a numeric vector.
+#'
+#' It returns a single numeric value, computed following the definition
+#' given in section \emph{Description}.
+setMethod('sparseness', signature(x='numeric'),
+ function(x){
+ # get length of x
+ n <- length(x)
+ # compute and return the sparseness
+ ( sqrt(n) - sum(abs(x)) / sqrt(sum(x^2)) ) / (sqrt(n)-1)
+ }
+)
+#' Computes the sparseness of a matrix as the mean sparseness of its column vectors.
+#' It returns a single numeric value.
+setMethod('sparseness', signature(x='matrix'),
+ function(x){
+ # compute the sparseness of each column
+ s <- apply(x, 2, sparseness)
+
+ # return the mean sparseness
+ mean(s)
+ }
+)
+#' Compute the sparseness of an object of class \code{NMF}, as the sparseness of
+#' the basis and coefficient matrices computed separately.
+#'
+#' It returns the two values in a numeric vector with names \sQuote{basis} and \sQuote{coef}.
+setMethod('sparseness', signature(x='NMF'),
+ function(x){
+ # return the sparseness of the basis and coef matrix
+ c(basis=sparseness(basis(x)), coef=sparseness(coef(x)))
+ }
+)
+
+#' Purity and Entropy of a Clustering
+#'
+#' The functions \code{purity} and \code{entropy} respectively compute the purity and the entropy
+#' of a clustering given \emph{a priori} known classes.
+#'
+#' The purity and entropy measure the ability of a clustering method, to recover
+#' known classes (e.g. one knows the true class labels of each sample), that are
+#' applicable even when the number of cluster is different from the number of known classes.
+#' \cite{KimH2007} used these measures to evaluate the performance of their alternate least-squares
+#' NMF algorithm.
+#'
+#' @details
+#' Suppose we are given \eqn{l} categories, while the clustering method generates
+#' \eqn{k} clusters.
+#'
+#' The purity of the clustering with respect to the known categories is given by:
+#' \deqn{Purity = \frac{1}{n} \sum_{q=1}^k \max_{1 \leq j \leq l} n_q^j} ,
+#'
+#' where:
+#' \itemize{
+#' \item \eqn{n} is the total number of samples;
+#' \item \eqn{n_q^j} is the number of samples in cluster \eqn{q} that belongs to
+#' original class \eqn{j} (\eqn{1 \leq j \leq l}).
+#' }
+#'
+#' The purity is therefore a real number in \eqn{[0,1]}.
+#' The larger the purity, the better the clustering performance.
+#'
+#' @param x an object that can be interpreted as a factor or can generate such an object, e.g. via
+#' a suitable method \code{\link{predict}}, which gives the cluster membership for each sample.
+#' @param y a factor or an object coerced into a factor that gives the true class labels for each sample.
+#' It may be missing if \code{x} is a contingency table.
+#' @param ... extra arguments to allow extension, and usually passed to the next method.
+#'
+#' @return a single numeric value
+#' @family assess
+#' @export
+#'
+#' @examples
+#' # generate a synthetic dataset with known classes: 50 features, 18 samples (5+5+8)
+#' n <- 50; counts <- c(5, 5, 8);
+#' V <- syntheticNMF(n, counts)
+#' cl <- unlist(mapply(rep, 1:3, counts))
+#'
+#' # perform default NMF with rank=2
+#' x2 <- nmf(V, 2)
+#' purity(x2, cl)
+#' entropy(x2, cl)
+#' # perform default NMF with rank=2
+#' x3 <- nmf(V, 3)
+#' purity(x3, cl)
+#' entropy(x3, cl)
+#'
+setGeneric('purity', function(x, y, ...) standardGeneric('purity') )
+#' Computes the purity directly from the contingency table \code{x}
+setMethod('purity', signature(x='table', y='missing'),
+ function(x, y){
+ #for each cluster: compute maximum number of samples common to a class
+ t <- apply(x, 1, max)
+ # average and return the result
+ sum(t) / sum(x)
+ }
+)
+#' Computes the purity on the contingency table of \code{x} and \code{y}, that is
+#' coerced into a factor if necessary.
+setMethod('purity', 'factor',
+ function(x, y, ...){
+
+ # coerce `y` into a factor if necessary
+ if( !is.factor(y) ) y <- as.factor(y)
+ #compute the purity on the contingency table between clusters and true classes (clusters are in rows)
+ purity(table(x, y), ...)
+ }
+)
+#' Default method that should work for results of clustering algorithms, that have a
+#' suitable \code{predict} method that returns the cluster membership vector:
+#' the purity is computed between \code{x} and \code{predict{y}}
+setMethod('purity', 'ANY',
+ function(x, y, ...){
+ # compute the purity for the samples clusters defined by the profiles
+ purity(predict(x), y, ...)
+ }
+)
+
+#' Entropy of a Clustering
+#'
+#' @details
+#' The entropy of the clustering with respect to the known categories is given by:
+#' \deqn{Entropy = - \frac{1}{n \log_2 l} \sum_{q=1}^k \sum_{j=1}^l n_q^j
+#' \log_2 \frac{n_q^j}{n_q}}{
+#' - 1/(n log2(l) ) sum_q sum_j n(q,j) log2( n(q,j) / n_q )},
+#'
+#' where:
+#' \itemize{
+#' \item \eqn{n} is the total number of samples;
+#' \item \eqn{n}{n_q} is the total number of samples in cluster \eqn{q} (\eqn{1 \leq q \leq k});
+#' \item \eqn{n_q^j}{n(q,j)} is the number of samples in cluster \eqn{q} that belongs to
+#' original class \eqn{j} (\eqn{1 \leq j \leq l}).
+#' }
+#'
+#' The smaller the entropy, the better the clustering performance.
+#' @inheritParams purity
+#'
+#' @return the entropy (i.e. a single numeric value)
+#' @family assess
+#' @rdname purity
+#' @export
+#'
+setGeneric('entropy', function(x, y, ...) standardGeneric('entropy') )
+#' Computes the purity directly from the contingency table \code{x}.
+#'
+#' This is the workhorse method that is eventually called by all other methods.
+setMethod('entropy', signature(x='table', y='missing'),
+ function(x, y, ...){
+ #for each cluster: compute the inner sum
+ t <- apply(x, 1, function(n){ c.size <- sum(n); n %*% ifelse( n!=0, log2(n/c.size), 0)} )
+
+ # weight and return the result
+ - sum(t) / ( sum(x) * log2(ncol(x)) )
+ }
+)
+#' Computes the purity on the contingency table of \code{x} and \code{y}, that is
+#' coerced into a factor if necessary.
+setMethod('entropy', 'factor',
+ function(x, y, ...){
+ # coerce `y` into a factor if necessary
+ if( !is.factor(y) ) y <- as.factor(y)
+ #copmute entropy on contingency table between clusters and true classes (clusters are in rows)
+ entropy(table(x, y))
+ }
+)
+#' Default method that should work for results of clustering algorithms, that have a
+#' suitable \code{predict} method that returns the cluster membership vector:
+#' the purity is computed between \code{x} and \code{predict{y}}
+setMethod('entropy', 'ANY',
+ function(x, y, ...){
+ # compute the entropy for the samples clusters defined by the metagenes expression matrix
+ entropy(predict(x), y)
+ }
+)
+
+###% Extract the genes that characterize each factor.
+###%
+###% For each factor the genes are first sorted by decreasing contribution. The first successive ones whose contribution to the factor
+###% is greater than their contribution to all other metagenes are selected.
+###%
+###% @param x the matrix of metagenes. That is a matrix with metagenes in column, genes in row, contain the genes' contribution to each factor
+###% @return a list with number of metagenes elements, each being a vector containing the indexes of the characterizing genes
+#setGeneric('computeContrib', function(x, ...) standardGeneric('computeContrib') )
+#setMethod('computeContrib', signature(x='matrix'),
+# function(x, ...){
+# # determine the specific genes for each factor
+# lapply(1:ncol(x),
+# function(i){
+# g <- x[,i]
+# #order by decreasing contribution to factor i
+# index.sort <- order(g, decreasing=TRUE)
+#
+# for( k in seq_along(index.sort) )
+# {
+# index <- index.sort[k]
+# #if the gene contributes more to any other factor then return the genes above it
+# if( any(x[index,-i] >= g[index]) )
+# {
+# if( k == 1 ) return(NULL)
+# else return(rownames(x)[index.sort[1:(k-1)]])
+# }
+# }
+#
+# # all genes are meeting the criteria
+# rownames(x)
+# })
+# }
+#)
+#
+
+
+#' Apply Function for NMF Objects
+#'
+#' The function \code{nmfApply} provides exteneded \code{apply}-like
+#' functionality for objects of class \code{NMF}.
+#' It enables to easily apply a function over different margins of
+#' NMF models.
+#'
+#' The function \code{FUN} is applied via a call to \code{\link{apply}}
+#' or \code{\link{sapply}} according to the value of argument \code{MARGIN}
+#' as follows:
+#'
+#' \describe{
+#' \item{MARGIN=1}{ apply \code{FUN} to each \emph{row} of the basis matrix:
+#' \code{apply(basis(X), 1L, FUN, ...)}.}
+#'
+#' \item{MARGIN=2}{ apply \code{FUN} to each \emph{column} of the coefficient matrix:
+#' \code{apply(coef(X), 2L, FUN, ...)}.}
+#'
+#' \item{MARGIN=3}{ apply \code{FUN} to each \emph{pair} of associated basis component
+#' and basis profile:
+#' more or less \code{sapply(seq(nbasis(X)), function(i, ...) FUN(basis(X)[,i], coef(X)[i, ], ...), ...)}.
+#'
+#' In this case \code{FUN} must be have at least two arguments, to which are passed
+#' each basis components and basis profiles respectively -- as numeric vectors.}
+#'
+#' \item{MARGIN=4}{ apply \code{FUN} to each \emph{column} of the basis matrix, i.e. to each
+#' basis component:
+#' \code{apply(basis(X), 2L, FUN, ...)}.}
+#'
+#' \item{MARGIN=5}{ apply \code{FUN} to each \emph{row} of the coefficient matrix:
+#' \code{apply(coef(X), 1L, FUN, ...)}.}
+#'
+#' }
+#'
+#'
+#' @param X an object that has suitable \code{\link{basis}} and \code{coef} methods,
+#' e.g. an NMF model.
+#' @param MARGIN a single numeric (integer) value that specifies over which margin(s)
+#' the function \code{FUN} is applied.
+#' See section \emph{Details} for a list of possible values.
+#' @param FUN a function to apply over the specified margins.
+#' @param ... extra arguments passed to \code{FUN}
+#' @param simplify a logical only used when \code{MARGIN=3}, that indicates if \code{sapply}
+#' should try to simplify result if possible.
+#' Since this argument follows \sQuote{...} its name cannot be abbreviated.
+#' @param USE.NAMES a logical only used when \code{MARGIN=3}, that indicates if \code{sapply}
+#' should use the names of the basis components to name the results if present.
+#' Since this argument follows \sQuote{...} its name cannot be abbreviated.
+#'
+#' @return a vector or a list.
+#' See \code{\link[base]{apply}} and \code{\link[base]{sapply}} for more details on
+#' the output format.
+#'
+#' @export
+#setGeneric('nmfApply', function(object, ...) standardGeneric('nmfApply') )
+nmfApply <- function(X, MARGIN, FUN, ..., simplify = TRUE, USE.NAMES = TRUE){
+ if( MARGIN == 1L )
+ apply(basis(X), 1L, FUN, ...)
+ else if( MARGIN == 4L )
+ apply(basis(X), 2L, FUN, ...)
+ else if( MARGIN == 2L )
+ apply(coef(X), 2L, FUN, ...)
+ else if( MARGIN == 5L )
+ apply(coef(X), 1L, FUN, ...)
+ else if( MARGIN == 3L ){
+ b <- basis(X)
+ p <- coef(X)
+ sapply(setNames(seq(nbasis(X), basisnames(X)))
+ , function(i, ...) FUN(b[,i], p[i,], ...)
+ , simplify = simplify, USE.NAMES = USE.NAMES)
+ }else stop("invalid argument 'MARGIN' (expected values are: 1-basis rows, 2-coef columns, 3-(basis columns, coef rows), or 4-basis columns or 5-coef rows)")
+}
+
+###% Utility function to compute the dominant column for each row for a matrix.
+.predict.nmf <- function(x, prob=FALSE){
+
+ if( !is.matrix(x) ) stop('NMF:::.predict.nmf : only works on matrices')
+ if( !prob ){
+ #for each column return the (row) index of the maximum
+ return( as.factor(apply(x, 1L, function(v) which.max(abs(v)))) )
+ }
+ else{
+ #for each column return the (row) index of the maximum AND the associated probaility
+ res <- apply(x, 1L,
+ function(p){
+ p <- abs(p)
+ i <- which.max(p)
+ c(i, p[i]/sum(p))
+ }
+ )
+ # return the result as a list of two elements
+ return( list(predict=as.factor(res[1,]), prob=res[2,]) )
+ }
+}
+
+#' Clustering and Prediction
+#'
+#' The methods \code{predict} for NMF models return the cluster membership
+#' of each sample or each feature.
+#' Currently the classification/prediction of new data is not implemented.
+#'
+#' The cluster membership is computed as the index of the dominant basis
+#' component for each sample (\code{what='samples' or 'columns'}) or each feature
+#' (\code{what='features' or 'rows'}), based on their corresponding
+#' entries in the coefficient matrix or basis matrix respectively.
+#'
+#' For example, if \code{what='samples'}, then the dominant basis component
+#' is computed for each column of the coefficient matrix as the row index
+#' of the maximum within the column.
+#'
+#' If argument \code{prob=FALSE} (default), the result is a \code{factor}.
+#' Otherwise a list with two elements is returned: element \code{predict}
+#' contains the cluster membership index (as a \code{factor}) and element
+#' \code{prob} contains the relative contribution of
+#' the dominant component to each sample (resp. the relative contribution of
+#' each feature to the dominant basis component):
+#'
+#' \itemize{
+#' \item Samples: \deqn{p_j = x_{k_0} / \sum_k x_k}{p(j) = x(k0) / sum_k x(k)},
+#' for each sample \eqn{1\leq j \leq p}, where \eqn{x_k}{x(k)} is the contribution
+#' of the \eqn{k}-th basis component to \eqn{j}-th sample (i.e. \code{H[k ,j]}), and
+#' \eqn{x_{k_0}}{x(k0)} is the maximum of these contributions.
+#'
+#' \item Features: \deqn{p_i = y_{k_0} / \sum_k y_k}{p(i) = y(k0) / sum_k y(k)},
+#' for each feature \eqn{1\leq i \leq p}, where \eqn{y_k}{y(k)} is the contribution
+#' of the \eqn{k}-th basis component to \eqn{i}-th feature (i.e. \code{W[i, k]}), and
+#' \eqn{y_{k_0}}{y(k0)} is the maximum of these contributions.
+#'
+#' }
+#'
+#' @param object an NMF model
+#'
+#' @family stats Methods for the Interface Defined in Package stats
+#'
+#' @cite Brunet2004,Pascual-Montano2006
+#' @inline
+#' @export
+setGeneric('predict', package='stats')
+
+#' Default method for NMF models
+#'
+#' @param what a character string that indicates the type of cluster membership should
+#' be returned: \sQuote{columns} or \sQuote{rows} for clustering the colmuns or the
+#' rows of the target matrix respectively.
+#' The values \sQuote{samples} and \sQuote{features} are aliases for \sQuote{colmuns}
+#' and \sQuote{rows} respectively.
+#' @param prob logical that indicates if the relative contributions of/to the dominant
+#' basis component should be computed and returned. See \emph{Details}.
+#' @param dmatrix logical that indicates if a dissimiliarity matrix should be
+#' attached to the result.
+#' This is notably used internally when computing NMF clustering silhouettes.
+#'
+#' @examples
+#'
+#' # random target matrix
+#' v <- rmatrix(20, 10)
+#' # fit an NMF model
+#' x <- nmf(v, 5)
+#'
+#' # predicted column and row clusters
+#' predict(x)
+#' predict(x, 'rows')
+#'
+#' # with relative contributions of each basis component
+#' predict(x, prob=TRUE)
+#' predict(x, 'rows', prob=TRUE)
+#'
+setMethod('predict', 'NMF',
+ function(object, what=c('columns', 'rows', 'samples', 'features'), prob=FALSE, dmatrix = FALSE){
+ # determine which matrix to use for the prediction
+ what <- match.arg(what)
+ x <- if( what %in% c('features', 'rows') ) basis(object, all=FALSE) else t(coef(object, all=FALSE))
+
+ # compute the indice of the dominant row for each column
+ res <- .predict.nmf(x, prob)
+ # attach dissimilarity matrix if requested
+ if( dmatrix ){
+ attr(res, 'dmatrix') <- 1 - cor(t(x))
+ }
+ return( res )
+ }
+)
+
+####% Compute the dominant column for each row.
+####%
+####% @param x a matrix containing the mixture coefficients (basis vector in rows, samples in columns)
+####% @return a factor of length the number of columns, giving the dominant column for each row
+####% @note This function is now deprecated
+#setGeneric('clusters', function(object, newdata, ...) standardGeneric('clusters') )
+####% Compute the dominant metagene for each sample.
+####%
+####% @param x a NMF object
+####% @return a factor of length the number of samples, giving the dominant metagene for each sample
+####% @note This function is now deprecated
+#setMethod('clusters', signature(object='NMF', newdata='missing'),
+# function(object, newdata, ...){
+# predict(object, ...)
+# }
+#)
+
+#' Correlations in NMF Models
+#'
+#' \code{basiscor} computes the correlation matrix between basis vectors, i.e.
+#' the \emph{columns} of its basis matrix -- which is the model's first matrix factor.
+#'
+#' @details
+#' Each generic has methods defined for computing correlations between NMF models
+#' and/or compatible matrices.
+#' The computation is performed by the base function \code{\link{cor}}.
+#'
+#' @param x a matrix or an object with suitable methods \code{\link{basis}}
+#' or \code{\link{coef}}.
+#' @param y a matrix or an object with suitable methods \code{\link{basis}}
+#' or \code{\link{coef}}, and dimensions compatible with \code{x}.
+#' If missing the correlations are computed between \code{x} and \code{y=x}.
+#' @param ... extra arguments passed to \code{\link{cor}}.
+#'
+#' @export
+#' @family NMFplots Plotting functions for NMF objects
+#'
+#' @examples
+#'
+#' # generate two random NMF models
+#' a <- rnmf(3, 100, 20)
+#' b <- rnmf(3, 100, 20)
+#'
+#' # Compute auto-correlations
+#' basiscor(a)
+#' profcor(a)
+#' # Compute correlations with b
+#' basiscor(a, b)
+#' profcor(a, b)
+#'
+#' # try to recover the underlying NMF model 'a' from noisy data
+#' res <- nmf(fitted(a) + rmatrix(a), 3)
+#'
+#' # Compute correlations with the true model
+#' basiscor(a, res)
+#' profcor(a, res)
+#'
+#' # Compute correlations with a random compatible matrix
+#' W <- rmatrix(basis(a))
+#' basiscor(a, W)
+#' identical(basiscor(a, W), basiscor(W, a))
+#'
+#' H <- rmatrix(coef(a))
+#' profcor(a, H)
+#' identical(profcor(a, H), profcor(H, a))
+#'
+setGeneric('basiscor', function(x, y, ...) standardGeneric('basiscor') )
+#' Computes the correlations between the basis vectors of \code{x} and
+#' the columns of \code{y}.
+setMethod('basiscor', signature(x='NMF', y='matrix'),
+ function(x, y, ...){
+ cor(basis(x), y, ...)
+ }
+)
+#' Computes the correlations between the columns of \code{x}
+#' and the the basis vectors of \code{y}.
+setMethod('basiscor', signature(x='matrix', y='NMF'),
+ function(x, y, ...){
+ cor(x, basis(y), ...)
+ }
+)
+#' Computes the correlations between the basis vectors of \code{x} and \code{y}.
+setMethod('basiscor', signature(x='NMF', y='NMF'),
+ function(x, y, ...){
+ basiscor(x, basis(y), ...)
+ }
+)
+#' Computes the correlations between the basis vectors of \code{x}.
+setMethod('basiscor', signature(x='NMF', y='missing'),
+ function(x, y, ...){
+ basiscor(x, x, ...)
+ }
+)
+
+#' Correlations of Basis Profiles
+#'
+#' \code{profcor} computes the correlation matrix between basis profiles,
+#' i.e. the \emph{rows} of the coefficient matrix -- which is the model's second
+#' matrix factor.
+#'
+#' @rdname basiscor
+#' @export
+#'
+setGeneric('profcor', function(x, y, ...) standardGeneric('profcor') )
+#' Computes the correlations between the basis profiles of \code{x} and
+#' the rows of \code{y}.
+setMethod('profcor', signature(x='NMF', y='matrix'),
+ function(x, y, ...){
+ cor(t(coef(x)), t(y), ...)
+ }
+)
+#' Computes the correlations between the rows of \code{x} and the basis
+#' profiles of \code{y}.
+setMethod('profcor', signature(x='matrix', y='NMF'),
+ function(x, y, ...){
+ cor(t(x), t(coef(y)), ...)
+ }
+)
+#' Computes the correlations between the basis profiles of \code{x} and \code{y}.
+setMethod('profcor', signature(x='NMF', y='NMF'),
+ function(x, y, ...){
+ profcor(x, coef(y), ...)
+ }
+)
+#' Computes the correlations between the basis profiles of \code{x}.
+setMethod('profcor', signature(x='NMF', y='missing'),
+ function(x, y, ...){
+ profcor(x, x, ...)
+ }
+)
+
+#' Clustering Connectivity and Consensus Matrices
+#'
+#' \code{connectivity} is an S4 generic that computes the connectivity matrix
+#' based on the clustering of samples obtained from a model's \code{\link{predict}}
+#' method.
+#'
+#' The connectivity matrix of a given partition of a set of samples (e.g. given
+#' as a cluster membership index) is the matrix \eqn{C} containing only 0 or 1
+#' entries such that:
+#' \deqn{C_{ij} = \left\{\begin{array}{l}
+#' 1\mbox{ if sample }i\mbox{ belongs to the same cluster as sample }j\\
+#' 0\mbox{ otherwise}
+#' \end{array}\right..}{
+#' C_{ij} = 1 if sample i belongs to the same cluster as sample j, 0 otherwise}
+#'
+#' @param object an object with a suitable \code{\link{predict}} method.
+#' @param ... extra arguments to allow extension.
+#' They are passed to \code{\link{predict}}, except for the \code{vector} and
+#' \code{factor} methods.
+#'
+#' @return a square matrix of dimension the number of samples in the model, full
+#' of 0s or 1s.
+#'
+#' @seealso \code{\link{predict}}
+#'
+#' @export
+#'
+setGeneric('connectivity', function(object, ...) standardGeneric('connectivity') )
+#' Default method which computes the connectivity matrix
+#' using the result of \code{predict(x, ...)} as cluster membership index.
+#'
+#' @examples
+#'
+#' # clustering of random data
+#' h <- hclust(dist(rmatrix(10,20)))
+#' connectivity(cutree(h, 2))
+#'
+setMethod('connectivity', 'ANY',
+ function(object, ...){
+ c <- predict(object, ...);
+ outer(c, c, function(x,y) ifelse(x==y, 1,0));
+ }
+)
+
+#' Computes the connectivity matrix using \code{x} as cluster membership index.
+#'
+#' @examples
+#' connectivity(gl(2, 4))
+#'
+setMethod('connectivity', 'factor',
+ function(object, ...){
+ outer(object, object, function(x,y) ifelse(x==y, 1,0));
+ }
+)
+#' Equivalent to \code{connectivity(as.factor(x))}.
+setMethod('connectivity', 'numeric',
+ function(object, ...){
+ connectivity(as.factor(object), ...)
+ }
+)
+#' Computes the connectivity matrix for an NMF model, for which cluster
+#' membership is given by the most contributing basis component in each sample.
+#' See \code{\link{predict,NMF-method}}.
+#'
+#' @inline
+#' @param no.attrib a logical that indicates if attributes containing information
+#' about the NMF model should be attached to the result (\code{TRUE}) or not
+#' (\code{FALSE}).
+#'
+setMethod('connectivity', 'NMF',
+ function(object, no.attrib=FALSE){
+ C <- callNextMethod(object=object, what='samples');
+ if( !no.attrib ){
+ class(C) <- c(class(C), 'NMF.consensus')
+ attr(C, 'model') <- object
+ attr(C, 'nrun') <- 1
+ attr(C, 'nbasis') <- nbasis(object)
+ }
+ C
+ }
+)
+
+# Unit test
+unit.test(connectivity,{
+
+ # build reference matrix
+ n <- 10
+ ref <- matrix(0, 2*n, 2*n)
+ ref[1:n,1:n] <- 1
+ ref[(n+1):(2*n),(n+1):(2*n)] <- 1
+
+ checkIdentical(connectivity(gl(2, n)), ref, 'Factor')
+ checkIdentical(connectivity(as.numeric(gl(2, n))), ref, 'Vector')
+ # test with NMF model
+ i <- gl(2, n)
+ x <- nmfModel(H=matrix(c(rev(i), i), 2, byrow=TRUE))
+ checkEquals(connectivity(x), ref, 'NMF model', check.attributes = FALSE)
+ s <- sample.int(2*n)
+ checkEquals(connectivity(x[,s]), ref[s,s], 'NMF model (shuffled)', check.attributes = FALSE)
+
+})
+
+#' Residual Sum of Squares and Explained Variance
+#'
+#' \code{rss} and \code{evar} are S4 generic functions that respectively computes
+#' the Residual Sum of Squares (RSS) and explained variance achieved by a model.
+#'
+#' @param object an R object with a suitable \code{\link{fitted}}, \code{rss} or
+#' \code{evar} method.
+#' @param ... extra arguments to allow extension, e.g. passed to \code{rss}
+#' in \code{evar} calls.
+#'
+#' @return a single numeric value
+#' @inline
+#' @export
+#'
+setGeneric('rss', function(object, ...) standardGeneric('rss'))
+#' Computes the RSS between a target matrix and its estimate \code{object},
+#' which must be a matrix of the same dimensions as \code{target}.
+#'
+#' The RSS between a target matrix \eqn{V} and its estimate \eqn{v} is computed as:
+#' \deqn{RSS = \sum_{i,j} (v_{ij} - V_{ij})^2}
+#'
+#' Internally, the computation is performed using an optimised C++ implementation,
+#' that is light in memory usage.
+#'
+#' @param target target matrix
+#'
+#' @examples
+#' # RSS bewteeen random matrices
+#' x <- rmatrix(20,10, max=50)
+#' y <- rmatrix(20,10, max=50)
+#' rss(x, y)
+#' rss(x, x + rmatrix(x, max=0.1))
+#'
+setMethod('rss', 'matrix',
+ function(object, target){
+ # make sure the target is provided
+ if( missing(target) ) stop("NMF::rss - Argument 'target' is missing and required to compute the residual sum of squares.")
+
+ # use the expression matrix if necessary
+ if( inherits(target, 'ExpressionSet') ){
+ # requires Biobase
+ if( !require.quiet(Biobase) )
+ stop("NMF::rss - The 'Biobase' package is required to extract expression data from 'ExpressionSet' objects [see ?'nmf-bioc']")
+
+ target <- Biobase::exprs(target)
+ }else if( is.data.frame(target) )
+ target <- as.matrix(target)
+
+ # return rss using the optimized C function
+ .rss(object,target)
+ }
+)
+#' Residual sum of square between a given target matrix and a model that has a
+#' suitable \code{\link{fitted}} method.
+#' It is equivalent to \code{rss(fitted(object), ...)}
+#'
+#' In the context of NMF, \cite{Hutchins2008} used the variation of the RSS
+#' in combination with the algorithm from \cite{Lee1999} to estimate the
+#' correct number of basis vectors.
+#' The optimal rank is chosen where the graph of the RSS first shows an inflexion
+#' point, i.e. using a screeplot-type criterium.
+#' See section \emph{Rank estimation} in \code{\link{nmf}}.
+#'
+#' Note that this way of estimation may not be suitable for all models.
+#' Indeed, if the NMF optimisation problem is not based on the Frobenius norm,
+#' the RSS is not directly linked to the quality of approximation of the NMF model.
+#' However, it is often the case that it still decreases with the rank.
+#'
+#' @examples
+#' # RSS between an NMF model and a target matrix
+#' x <- rmatrix(20, 10)
+#' y <- rnmf(3, x) # random compatible model
+#' rss(y, x)
+#'
+#' # fit a model with nmf(): one should do better
+#' y2 <- nmf(x, 3) # default minimizes the KL-divergence
+#' rss(y2, x)
+#' y2 <- nmf(x, 3, 'lee') # 'lee' minimizes the RSS
+#' rss(y2, x)
+#'
+setMethod('rss', 'ANY',
+ function(object, ...){
+ rss(fitted(object), ...)
+ }
+)
+
+
+unit.test(rss, {
+
+ x <- rmatrix(20,10, max=50)
+ y <- rmatrix(20,10, max=50)
+ checkIdentical(rss(x, y), sum((x-y)^2), "Random matrices")
+
+ y <- rnmf(3, x) # random compatible model
+ r1 <- rss(y, x)
+ checkIdentical(r, sum((x-fitted(y))^2), 'NMF model')
+ checkIdentical(rss(y, ExpressionSet(x)), sum((x-fitted(y))^2), 'NMF model (ExpressionSet)')
+ y <- nmf(x, 3)
+ r2 <- rss(y, x)
+ checkIdentical(r2, sum((x-fitted(y))^2), 'Fitted NMF model')
+ checkTrue(r2 < r1, 'Fitted NMF model has better RSS')
+ y <- nmf(x, 3, 'lee')
+ checkTrue(rss(y, x) < r2, "Fitted NMF model with 'lee' has better RSS than 'brunet'")
+
+})
+
+#' Explained Variance
+#'
+#' The explained variance for a target \eqn{V} is computed as:
+#' \deqn{evar = 1 - \frac{RSS}{\sum_{i,j} v_{ij}^2} }{evar = 1 - RSS/sum v_{ij}^2},
+#'
+#' where RSS is the residual sum of squares.
+#'
+#' The explained variance is usefull to compare the performance of different
+#' models and their ability to accurately reproduce the original target matrix.
+#' Note, however, that a possible caveat is that some models explicitly aim at
+#' minimizing the RSS (i.e. maximizing the explained variance), while others do not.
+#'
+#' @rdname rss
+#' @inline
+#' @export
+#'
+setGeneric('evar', function(object, ...) standardGeneric('evar'))
+#' Default method for \code{evar}.
+#'
+#' It requires a suitable \code{rss} method to be defined
+#' for \code{object}, as it internally calls \code{rss(object, target, ...)}.
+setMethod('evar', 'ANY',
+ function(object, target, ...){
+
+ # make sure the target is provided
+ if( missing(target) ) stop("NMF::evar - Argument 'target' is missing and required to compute the explained variance.")
+
+ # use the expression matrix if necessary
+ if( inherits(target, 'ExpressionSet') ){
+ # requires Biobase
+ if( !require.quiet(Biobase) )
+ stop("NMF::evar - The 'Biobase' package is required to extract expression data from 'ExpressionSet' objects [see ?'nmf-bioc']")
+
+ target <- Biobase::exprs(target)
+ }
+
+ t <- as.numeric(target)
+ 1 - rss(object, target, ...) / sum(t^2)
+ }
+)
+
+#' Distances and Objective Functions
+#'
+#' The NMF package defines methods for the generic \code{deviance} from the package \code{stats},
+#' to compute approximation errors between NMF models and matrices, using a variety of
+#' objective functions.
+#'
+#' @return \code{deviance} returns a nonnegative numerical value
+#' @family stats
+#'
+#' @export
+setGeneric('deviance', package='stats')
+#' Computes the distance between a matrix and the estimate of an \code{NMF} model.
+#'
+#' @param y a matrix compatible with the NMF model \code{object}, i.e. \code{y}
+#' must have the same dimension as \code{fitted(object)}.
+#' @param method a character string or a function with signature
+#' \code{(x="NMF", y="matrix", ...)} that implements a distance measure between
+#' an NMF model \code{x} and a target matrix \code{y}, i.e. an objective function
+#' to use to compute the deviance.
+#' In \code{deviance}, it is passed to \code{nmfDistance} to get the function
+#' that effectively computes the deviance.
+#' @param ... extra parameters passed to the objective function.
+#'
+#' @inline
+#' @family stats
+#'
+setMethod('deviance', 'NMF',
+ function(object, y, method=c('', 'KL', 'euclidean'), ...){
+
+ fun <- nmfDistance(method)
+
+ if( is.null(fun) ){
+ warning('Undefined distance method: distance cannot be computed [returned NA]')
+ return(as.numeric(NA))
+ }
+
+ # extract expression data from ExpressionSet objects
+ if( is(y, 'ExpressionSet') )
+ y <- Biobase::exprs(y)
+
+ # apply the function and return the result
+ fun(object, y, ...)
+
+ }
+)
+
+#' \code{nmfDistance} returns a function that computes the distance between an NMF model and a
+#' compatible matrix.
+#'
+#' @return \code{nmfDistance} returns a function with least two arguments:
+#' an NMF model and a matrix.
+#'
+#' @export
+#' @rdname deviance
+nmfDistance <- function(method=c('', 'KL', 'euclidean')){
+
+ #message('compute distance')
+ # determinate the distance measure to use
+ if( is.null(method) ) return(NULL)
+
+ if( is.character(method) ){
+ errMeth <- try(method <- match.arg(method), silent=TRUE)
+ # if the method is not predefined, try to find a function with the given name
+ if( inherits(errMeth, 'try-error') ){
+ #TODO: this is not working with local functions
+ if( is.character(method) ){
+ errFun <- try(fun <- match.fun(method), silent=TRUE)
+ if( inherits(errFun, 'try-error') )
+ stop("Could not find distance measure '", method, "':\n\t- not a predefined measures -> ", errMeth,"\t- not a function -> ", errFun)
+ }
+ else fun <- method
+
+ if( !is.function(fun) )
+ stop('Invalid distance measure: should be a character string or a valid function definition')
+ }
+ else{
+ # compute and return the distance measure
+ fun <- switch(method,
+ euclidean = function(x, y, ...){
+ # call optimized C function
+ .rss(y, fitted(x))/2
+ },
+ KL = function(x, y, ...){
+ # call optimized C function
+ .KL(y, fitted(x))
+ }
+ )
+ }
+ }
+ else if( is.function(method) )
+ fun <- method
+ else
+ stop('Invalid distance measure: should be a character string or a valid function definition')
+
+ # return the distance function
+ fun
+
+ }
+
+
+
+#' Testing Equality of NMF Models
+#'
+#' The function \code{nmf.equal} tests if two NMF models are the same, i.e. they
+#' contain -- almost -- identical data: same basis and coefficient matrices, as
+#' well as same extra parameters.
+#'
+#' @details
+#' \code{nmf.equal} compares two NMF models, and return \code{TRUE} iff they are
+#' identical acording to the function \code{\link{identical}} when \code{identical=TRUE},
+#' or equal up to some tolerance acording to the function \code{\link{all.equal}}.
+#' This means that all data contained in the objects are compared, which includes
+#' at least the basis and coefficient matrices, as well as the extra parameters
+#' stored in slot \sQuote{misc}.
+#'
+#' If extra arguments are specified in \code{...}, then the comparison is performed
+#' using \code{\link{all.equal}}, irrespective of the value of argument \code{identical}.
+#'
+#' @param x an NMF model or an object that is associated with an NMF model, e.g.
+#' the result from a fit with \code{\link{nmf}}.
+#' @param y an NMF model or an object that is associated with an NMF model, e.g.
+#' the result from a fit with \code{\link{nmf}}.
+#' @param identical a logical that indicates if the comparison should be made
+#' using the function \code{\link{identical}} (\code{TRUE}) or \code{\link{all.equal}}
+#' (\code{FALSE}). See description for method \code{nmf.equal,NMF,NMF}.
+#' @param ... extra arguments to allow extension, and passed to subsequent calls
+#'
+#' @export
+#'
+setGeneric('nmf.equal', function(x, y, ...) standardGeneric('nmf.equal') )
+#' Compares two NMF models.
+#'
+#' Arguments in \code{...} are used only when \code{identical=FALSE} and are
+#' passed to \code{all.equal}.
+#' @inline
+setMethod('nmf.equal', signature(x='NMF', y='NMF'),
+ function(x, y, identical=TRUE, ...){
+
+ dots <- list(...)
+ if( identical && length(dots) == 0 )
+ identical(x, y)
+ else
+ all.equal(x, y, ...)
+ }
+)
+
+# Match and Order Basis Components
+#
+#
+match.basis <- function(object, return.table=FALSE){
+
+ # compute the contingency table
+ #pcmap <- predict(object, 'cmap')
+ # build the tree from consensus matrix
+ h <- hclust(as.dist(1-consensus(object)), method='average')
+ # extract membership from the tree
+ cl <- cutree(h, k=nbasis(object))
+ # change the class indexed to match the order of the consensus clusters
+ cl <- match(cl, unique(cl[h$order]))
+ pcmap <- as.factor(cl)
+ occ <- table(consensus=pcmap, fit=predict(object))
+
+ # add names if present
+# if( !is.null(basisnames(object)) ){
+# rownames(occ) <- colnames(occ) <- basisnames(object)
+# }
+
+ # for each estimated component look for the maximum agreement
+ T.tmp <- occ
+ res <- rep(0, ncol(T.tmp))
+ for( i in 1:ncol(T.tmp) ){
+ # get the row and column index of the maximum over the remaining entries
+ xm <- which.max(T.tmp)-1
+ jm <- xm %/% nrow(T.tmp) + 1
+ im <- xm - (jm-1) * nrow(T.tmp) + 1
+
+ # assign the estimate row to the inferred reference column
+ stopifnot( res[im]==0 )
+ res[im] <- jm
+
+ # erase the assigned estimate row
+ T.tmp[im,] <- NA
+ # erase the assigned reference column
+ T.tmp[,jm] <- NA
+ }
+
+ # return the mapping as an integer vector
+ res <- as.integer(res)
+ if( return.table )
+ res <- list(match=res, table=occ)
+
+ # return result
+ res
+}
diff --git a/R/NMFOffset-class.R b/R/NMFOffset-class.R
new file mode 100644
index 0000000..b5a417e
--- /dev/null
+++ b/R/NMFOffset-class.R
@@ -0,0 +1,165 @@
+#' @include NMFstd-class.R
+NULL
+
+#' NMF Model - Nonnegative Matrix Factorization with Offset
+#'
+#' This class implements the \emph{Nonnegative Matrix Factorization with
+#' Offset} model, required by the NMF with Offset algorithm.
+#'
+#' The NMF with Offset algorithm is defined by \cite{Badea2008} as a modification
+#' of the euclidean based NMF algorithm from \code{Lee2001} (see section Details and
+#' references below).
+#' It aims at obtaining 'cleaner' factor matrices, by the introduction of an
+#' offset matrix, explicitly modelling a feature specific baseline
+#' -- constant across samples.
+#'
+#' @section Creating objects from the Class:
+#'
+#' Object of class \code{NMFOffset} can be created using the standard way with
+#' operator \code{\link{new}}
+#'
+#' However, as for all NMF model classes -- that extend class
+#' \code{\linkS4class{NMF}}, objects of class \code{NMFOffset} should be
+#' created using factory method \code{\link{nmfModel}} :
+#'
+#' \code{new('NMFOffset')}
+#'
+#' \code{nmfModel(model='NMFOffset')}
+#'
+#' \code{nmfModel(model='NMFOffset', W=w, offset=rep(1, nrow(w)))}
+#'
+#' See \code{\link{nmfModel}} for more details on how to use the factory
+#' method.
+#'
+#' @export
+#' @family NMF-model
+#' @examples
+#'
+#' # create a completely empty NMF object
+#' new('NMFOffset')
+#'
+#' # create a NMF object based on random (compatible) matrices
+#' n <- 50; r <- 3; p <- 20
+#' w <- rmatrix(n, r)
+#' h <- rmatrix(r, p)
+#' nmfModel(model='NMFOffset', W=w, H=h, offset=rep(0.5, nrow(w)))
+#'
+#' # apply Nonsmooth NMF algorithm to a random target matrix
+#' V <- rmatrix(n, p)
+#' \dontrun{nmf(V, r, 'offset')}
+#'
+#' # random NMF model with offset
+#' rnmf(3, 10, 5, model='NMFOffset')
+#'
+setClass('NMFOffset'
+ , representation(
+ offset = 'numeric' # offset vector
+ )
+ , contains = 'NMFstd'
+ , prototype=prototype(
+ offset = numeric()
+ )
+
+)
+
+#' Show method for objects of class \code{NMFOffset}
+#' @export
+setMethod('show', 'NMFOffset',
+ function(object)
+ {
+ callNextMethod()
+ cat("offset: ")
+ if( length(object at offset) > 0 ){
+ cat('[', head(object at offset, 5)
+ , if( length(object at offset) > 5 ) "..." else NULL
+ , ']')
+ }
+ else cat('none')
+ cat("\n")
+ }
+)
+
+#' @section Initialize method:
+#' The initialize method for \code{NMFOffset} objects tries to correct the initial
+#' value passed for slot \code{offset}, so that it is consistent with the dimensions
+#' of the \code{NMF} model:
+#' it will pad the offset vector with NA values to get the length equal to the
+#' number of rows in the basis matrix.
+#'
+#' @param offset optional numeric vector used to initialise slot \sQuote{offset}.
+#'
+#' @rdname NMFOffset-class
+setMethod("initialize", 'NMFOffset',
+ function(.Object, ..., offset){
+ .Object <- callNextMethod()
+ # correct the offset slot if possible
+ if( missing(offset) ) offset <- numeric()
+ if( !is.numeric(offset) ) stop("Unvalid value for parameter 'offset': a numeric vector is expected")
+
+ # force length to be consistent with the factorization's dimension
+ n <- nrow(.Object)
+ if( n > 0 ) .Object at offset <- c( offset, rep(NA, max(0, n - length(offset))) )[1:n]
+
+ # return the initialized valid object
+ .Object
+ }
+)
+
+#' @export
+setGeneric('offset', package='stats')
+#' Offsets in NMF Models with Offset
+#'
+#' The function \code{offset} returns the offset vector from an NMF model
+#' that has an offset, e.g. an \code{NMFOffset} model.
+#' @param object an instance of class \code{NMFOffset}.
+#'
+setMethod('offset', signature(object='NMFOffset'),
+ function(object){
+ object at offset
+ }
+)
+
+#' Computes the target matrix estimate for an NMFOffset object.
+#'
+#' The estimate is computed as:
+#' \deqn{ W H + offset }
+#'
+#' @param offset offset vector
+#' @inline
+setMethod('fitted', signature(object='NMFOffset'),
+ function(object, W, H, offset=object at offset){
+ if( missing(W) ) W <- object at W
+ if( missing(H) ) H <- object at H
+ object at W %*% object at H + offset
+ }
+)
+
+#' Generates a random NMF model with offset, from class \code{NMFOffset}.
+#'
+#' The offset values are drawn from a uniform distribution between 0 and
+#' the maximum entry of the basis and coefficient matrices, which are drawn
+#' by the next suitable \code{\link{rnmf}} method, which is the workhorse
+#' method \code{rnmf,NMF,numeric}.
+#'
+#' @examples
+#'
+#' # random NMF model with offset
+#' x <- rnmf(2, 3, model='NMFOffset')
+#' x
+#' offset(x)
+#' # from a matrix
+#' x <- rnmf(2, rmatrix(5,3, max=10), model='NMFOffset')
+#' offset(x)
+#'
+setMethod('rnmf', signature(x='NMFOffset', target='numeric'),
+function(x, target, ...){
+
+ # call the parent's 'rnmf' method to build a standard random NMF factorization
+ res <- callNextMethod()
+
+ #Vc# Initialize a random offset of length the number of genes
+ res at offset <- runif(nrow(res), min=0, max=max(basis(res), coef(res)));
+
+ # return the initialized NMFOffset object
+ res
+})
diff --git a/R/NMFSeed-class.R b/R/NMFSeed-class.R
new file mode 100644
index 0000000..2b77c40
--- /dev/null
+++ b/R/NMFSeed-class.R
@@ -0,0 +1,90 @@
+#' @include registry.R
+#' @include NMFStrategy-class.R
+NULL
+
+#' Base class that defines the interface for NMF seeding methods.
+#'
+#' This class implements a simple wrapper strategy object that defines a unified
+#' interface to seeding methods, that are used to initialise NMF models before
+#' fitting them with any NMF algorithm.
+#'
+#' @slot name character string giving the name of the seeding strategy
+#' @slot method workhorse function that implements the seeding strategy.
+#' It must have signature \code{(object="NMF", x="matrix", ...)} and initialise
+#' the NMF model \code{object} with suitable values for fitting the target
+#' matrix \code{x}.
+#'
+setClass('NMFSeed'
+ , representation(
+ method = 'function' # the method actual definition
+ )
+ , contains = 'Strategy'
+)
+
+#' Show method for objects of class \code{NMFSeed}
+setMethod('show', 'NMFSeed',
+ function(object){
+ cat('<object of class: ', class(object), ">\n")
+ cat("name:\t", name(object), "\n")
+ svalue <- algorithm(object)
+ svalue <- if( is.function(svalue) ) '<function>' else paste("'", svalue,"'", sep='')
+ cat("method:\t", svalue, "\n")
+ return(invisible())
+ }
+)
+
+#' Returns the workhorse function of the seeding method described by \code{object}.
+setMethod('algorithm', signature(object='NMFSeed'),
+ function(object){
+ slot(object, 'method')
+ }
+)
+#' Sets the workhorse function of the seeding method described by \code{object}.
+setReplaceMethod('algorithm', signature(object='NMFSeed', value='function'),
+ function(object, value){
+ slot(object, 'method') <- value
+ validObject(object)
+ object
+ }
+)
+
+#' \code{NMFSeed} is a constructor method that instantiate
+#' \code{\linkS4class{NMFSeed}} objects.
+#'
+#' @param key access key as a single character string
+#' @param method specification of the seeding method, as a function that takes
+#' at least the following arguments:
+#' \describe{
+#' \item{object}{uninitialised/empty NMF model, i.e. that it has 0 rows and
+#' columns, but has already the rank requested in the call to \code{\link{nmf}}
+#' or \code{\link{seed}}.}
+#' \item{x}{target matrix}
+#' \item{...}{extra arguments}
+#' }
+#'
+#' @export
+#' @rdname setNMFSeed
+#' @inline
+setGeneric('NMFSeed', function(key, method, ...) standardGeneric('NMFSeed') )
+#' Default method simply calls \code{\link{new}} with the same arguments.
+setMethod('NMFSeed', signature(key='character', method='ANY'),
+ function(key, method, ...){
+ # wrap function method into a new NMFSeed object
+ new('NMFSeed', name=key, method=method, ..., package=topns_name())
+ }
+)
+
+#' Creates an \code{NMFSeed} based on a template object (Constructor-Copy),
+#' in particular it uses the \strong{same} name.
+setMethod('NMFSeed', signature(key='NMFSeed', method='ANY'),
+ function(key, method, ...){
+
+ # do not change the object if single argument
+ if( nargs() == 1L ) return(key)
+
+ # build an object based on template object
+ new(class(method), key, method=method, ..., package=topns_name())
+
+ }
+)
+
diff --git a/R/NMFSet-class.R b/R/NMFSet-class.R
new file mode 100644
index 0000000..39ba32c
--- /dev/null
+++ b/R/NMFSet-class.R
@@ -0,0 +1,1943 @@
+#' @include NMFfit-class.R
+#' @include heatmaps.R
+NULL
+
+#' \code{isNMFfit} tells if an object results from an NMF fit.
+#'
+#' @details \emph{isNMFfit} checks if \code{object} inherits from class
+#' \code{\linkS4class{NMFfit}} or \code{\linkS4class{NMFfitX}}, which are
+#' the two types of objects returned by the function \code{\link{nmf}}.
+#' If \code{object} is a plain \code{list} and \code{recursive=TRUE}, then
+#' the test is performed on each element of the list, and the return value
+#' is a logical vector (or a list if \code{object} is a list of list) of
+#' the same length as \code{object}.
+#'
+#' @export
+#' @rdname types
+#' @param object any R object.
+#' @param recursive if \code{TRUE} and \code{object} is a plain list then
+#' \code{isNMFfit} tests each element of the list.
+#' Note that the recursive test only applies in the case of lists that are
+#' not themselves NMFfit objects, like \code{NMFfitXn} objects for which
+#' the result of \code{isNMFfit} will always be \code{TRUE}, although they are
+#' list objects (a single logical value).
+#'
+#' @return \code{isNMFfit} returns a \code{logical} vector (or a list if
+#' \code{object} is a list of list) of the same length as \code{object}.
+#'
+#' @seealso \code{\linkS4class{NMFfit}}, \code{\linkS4class{NMFfitX}},
+#' \code{\linkS4class{NMFfitXn}}
+#' @examples
+#'
+#' ## Testing results of fits
+#' # generate a random
+#' V <- rmatrix(20, 10)
+#'
+#' # single run -- using very low value for maxIter to speed up the example
+#' res <- nmf(V, 3, maxIter=3L)
+#' isNMFfit(res)
+#'
+#' # multiple runs - keeping single fit
+#' resm <- nmf(V, 3, nrun=3, maxIter=3L)
+#' isNMFfit(resm)
+#'
+#' # multiple runs - keeping all fits
+#' resM <- nmf(V, 3, nrun=3, .opt='k', maxIter=3L)
+#' isNMFfit(resM)
+#'
+#' # with a list of results
+#' isNMFfit(list(res, resm, resM, 'not a result'))
+#' isNMFfit(list(res, list(resm, resM), 'not a result')) # list of list
+#' isNMFfit(list(res, resm, resM, 'not a result'), recursive=FALSE)
+#'
+isNMFfit <- function(object, recursive=TRUE){
+ res <- is(object, 'NMFfit') || is(object, 'NMFfitX')
+ # if the object is not a NMF result: apply to each element if a list (only in recursive mode)
+ if( !res && recursive && is.list(object) )
+ sapply(object, isNMFfit)
+ else
+ res
+}
+
+#' Class for Storing Heterogeneous NMF fits
+#'
+#' @description
+#' This class wraps a list of NMF fit objects, which may come from different
+#' runs of the function \code{\link{nmf}}, using different parameters, methods, etc..
+#' These can be either from a single run (NMFfit) or multiple runs (NMFfitX).
+#'
+#' Note that its definition/interface is very likely to change in the future.
+#' @export
+#'
+setClass('NMFList'
+ , representation(
+ runtime='proc_time'
+ )
+ , contains='namedList'
+ , validity=function(object){
+
+ # the list must only contains NMFfit objects of the same dimensions
+ ok <- isNMFfit(object)
+ if( !is.logical(ok) )
+ return("Could not validate elements in list: input is probably a complex structure of lists.")
+ pb <- which(!ok)
+ if( length(pb) ){
+ return(paste("invalid class for element(s)"
+ , str_out(i)
+ , "of input list [all elements must be fitted NMF models]"))
+ }
+ }
+)
+
+#' Show method for objects of class \code{NMFList}
+#' @export
+setMethod('show', 'NMFList',
+ function(object)
+ {
+ cat("<Object of class:", class(object), ">\n")
+ cat("Length:", length(object), "\n")
+ if( length(object) > 0 ) cat("Method(s):", algorithm(object, string=TRUE), "\n")
+ # show totaltime if present
+ tt <- runtime(object)
+ if( length(tt) > 0 ){
+ cat("Total timing:\n"); show(tt);
+ }
+ }
+)
+
+#' Returns the method names used to compute the NMF fits in the list.
+#' It returns \code{NULL} if the list is empty.
+#'
+#' @param string a logical that indicate whether the names should be collapsed
+#' into a comma-separated string.
+#' @param unique a logical that indicates whether the result should contain the
+#' set of method names, removing duplicated names.
+#' This argument is forced to \code{TRUE} when \code{string=TRUE}.
+#'
+setMethod('algorithm', 'NMFList',
+ function(object, string=FALSE, unique=TRUE){
+ l <- length(object)
+
+ if( string ) unique <- TRUE
+
+ if( l == 0 ) NULL
+ else if( l == 1 ) algorithm(object[[1]])
+ else{
+ # build the vector of the algorithm names (with no repeat)
+ m <- sapply(object, algorithm)
+ if( unique ) m <- unique(m)
+ if( string ) m <- paste(m, collapse=', ')
+ m
+ }
+ }
+)
+
+.seqtime <- function(object){
+
+ if( length(object) == 0 ) return(NULL)
+ # sum up the time across the runs
+ t.mat <- sapply(object, function(x){
+ if( is(x, 'NMFfitXn') ) runtime.all(x)
+ else runtime(x)
+ })
+ res <- rowSums(t.mat)
+ class(res) <- 'proc_time'
+ res
+}
+
+#' Returns the CPU time that would be required to sequentially compute all NMF
+#' fits stored in \code{object}.
+#'
+#' This method calls the function \code{runtime} on each fit and sum up the
+#' results.
+#' It returns \code{NULL} on an empty object.
+setMethod('seqtime', 'NMFList',
+ function(object){
+ if( length(object) == 0 ) return(NULL)
+ # sum up the time across the runs
+ .seqtime(object)
+ }
+)
+
+#' Returns the CPU time required to compute all NMF fits in the list.
+#' It returns \code{NULL} if the list is empty.
+#' If no timing data are available, the sequential time is returned.
+#'
+#' @param all logical that indicates if the CPU time of each fit should be
+#' returned (\code{TRUE}) or only the total CPU time used to compute all
+#' the fits in \code{object}.
+setMethod('runtime', 'NMFList',
+ function(object, all=FALSE){
+ if( !all ){
+ t <- slot(object, 'runtime')
+ if( length(t)==0 ) seqtime(object) else t
+ }else
+ sapply(object, runtime)
+ }
+)
+
+as.NMFList <- function(..., unlist=FALSE){
+ arg.l <- list(...)
+ if( length(arg.l) == 1L && is.list(arg.l[[1]]) && !is(arg.l[[1]], 'NMFfitX') )
+ arg.l <- arg.l[[1]]
+
+ # unlist if required
+ if( unlist )
+ arg.l <- unlist(arg.l)
+
+ # create a NMFList object from the input list
+ new('NMFList', arg.l)
+}
+
+
+#' Virtual Class to Handle Results from Multiple Runs of NMF Algorithms
+#'
+#' This class defines a common interface to handle the results from multiple
+#' runs of a single NMF algorithm, performed with the \code{\link{nmf}} method.
+#'
+#' Currently, this interface is implemented by two classes,
+#' \code{\linkS4class{NMFfitX1}} and \code{\linkS4class{NMFfitXn}}, which
+#' respectively handle the case where only the best fit is kept, and the case
+#' where the list of all the fits is returned.
+#'
+#' See \code{\link{nmf}} for more details on the method arguments.
+#'
+#' @slot runtime.all Object of class \code{\link[=proc.time]{proc_time}} that
+#' contains CPU times required to perform all the runs.
+#'
+#' @export
+#' @family multipleNMF
+#' @examples
+#'
+#' # generate a synthetic dataset with known classes
+#' n <- 20; counts <- c(5, 2, 3);
+#' V <- syntheticNMF(n, counts)
+#'
+#' # perform multiple runs of one algorithm (default is to keep only best fit)
+#' res <- nmf(V, 3, nrun=3)
+#' res
+#'
+#' # plot a heatmap of the consensus matrix
+#' \dontrun{ consensusmap(res) }
+#'
+#' # perform multiple runs of one algorithm (keep all the fits)
+#' res <- nmf(V, 3, nrun=3, .options='k')
+#' res
+#'
+setClass('NMFfitX'
+ , representation(
+ runtime.all = 'proc_time' # running time to perform all the NMF runs
+ )
+ , contains='VIRTUAL'
+)
+
+#' Returns the CPU time required to compute all the NMF runs.
+#' It returns \code{NULL} if no CPU data is available.
+setMethod('runtime.all', 'NMFfitX',
+ function(object){
+ t <- slot(object, 'runtime.all')
+ if( length(t) > 0 ) t else NULL
+ }
+)
+
+#' Returns the number of NMF runs performed to create \code{object}.
+#'
+#' It is a pure virtual method defined to ensure \code{nrun} is defined
+#' for sub-classes of \code{NMFfitX}, which throws an error if called.
+#'
+#' Note that because the \code{\link{nmf}} function allows to run the NMF
+#' computation keeping only the best fit, \code{nrun} may return a value
+#' greater than one, while only the result of the best run is stored in
+#' the object (cf. option \code{'k'} in method \code{\link{nmf}}).
+setMethod('nrun', 'NMFfitX',
+ function(object){
+ stop("NMF::NMFfitX - missing definition for pure virtual method 'nrun' in class '", class(object), "'")
+ }
+)
+#' This method always returns 1, since an \code{NMFfit} object is obtained
+#' from a single NMF run.
+setMethod('nrun', 'NMFfit',
+ function(object){
+ 1L
+ }
+)
+
+#' \code{consensus} is an S4 generic that computes/returns the consensus matrix
+#' from a model object, which is the mean connectivity matrix of all the runs.
+#'
+#' The consensus matrix has been proposed by \cite{Brunet2004} to help
+#' visualising and measuring the stability of the clusters obtained by
+#' NMF approaches.
+#' For objects of class \code{NMF} (e.g. results of a single NMF run, or NMF
+#' models), the consensus matrix reduces to the connectivity matrix.
+#'
+#' @rdname connectivity
+#' @export
+setGeneric('consensus', function(object, ...) standardGeneric('consensus') )
+#' Pure virtual method defined to ensure \code{consensus} is defined for sub-classes of \code{NMFfitX}.
+#' It throws an error if called.
+setMethod('consensus', 'NMFfitX',
+ function(object, ...){
+ stop("NMF::NMFfitX - missing definition for pure virtual method 'consensus' in class '", class(object), "'")
+ }
+)
+
+#' This method is provided for completeness and is identical to
+#' \code{\link{connectivity}}, and returns the connectivity matrix,
+#' which, in the case of a single NMF model, is also the consensus matrix.
+setMethod('consensus', 'NMF',
+ function(object, ...){
+ connectivity(object, ...)
+ }
+)
+
+#' Hierarchical Clustering of a Consensus Matrix
+#'
+#' The function \code{consensushc} computes the hierarchical clustering of
+#' a consensus matrix, using the matrix itself as a similarity matrix and
+#' average linkage.
+#' It is
+#'
+#' @param object a matrix or an \code{NMFfitX} object, as returned by multiple
+#' NMF runs.
+#' @param ... extra arguments passed to next method calls
+#'
+#' @return an object of class \code{dendrogram} or \code{hclust} depending on the
+#' value of argument \code{dendrogram}.
+#'
+#' @inline
+#' @export
+setGeneric('consensushc', function(object, ...) standardGeneric('consensushc'))
+#' Workhorse method for matrices.
+#'
+#' @param method linkage method passed to \code{\link{hclust}}.
+#' @param dendrogram a logical that specifies if the result of the hierarchical
+#' clustering (en \code{hclust} object) should be converted into a dendrogram.
+#' Default value is \code{TRUE}.
+setMethod('consensushc', 'matrix',
+ function(object, method='average', dendrogram=TRUE){
+
+ # hierachical clustering based on the connectivity matrix
+ hc <- hclust(as.dist(1-object), method=method)
+
+ # convert into a dendrogram if requested
+ if( dendrogram ) as.dendrogram(hc)
+ else hc
+ }
+)
+#' Compute the hierarchical clustering on the connectivity matrix of \code{object}.
+setMethod('consensushc', 'NMF',
+ function(object, ...){
+ # hierachical clustering based on the connectivity matrix
+ consensushc(connectivity(object), ...)
+ }
+)
+#' Compute the hierarchical clustering on the consensus matrix of \code{object},
+#' or on the connectivity matrix of the best fit in \code{object}.
+#'
+#' @param what character string that indicates which matrix to use in the
+#' computation.
+#'
+setMethod('consensushc', 'NMFfitX',
+ function(object, what=c('consensus', 'fit'), ...){
+
+ what <- match.arg(what)
+ if( what == 'consensus' ){
+ # hierachical clustering on the consensus matrix
+ consensushc(consensus(object), ...)
+
+ }else if( what == 'fit' )
+ consensushc(fit(object), ...)
+
+ }
+)
+
+#' Returns the cluster membership index from an NMF model fitted with multiple
+#' runs.
+#'
+#' Besides the type of clustering available for any NMF models
+#' (\code{'columns', 'rows', 'samples', 'features'}), this method can return
+#' the cluster membership index based on the consensus matrix, computed from
+#' the multiple NMF runs.
+#'
+#' Argument \code{what} accepts the following extra types:
+#' \describe{
+#' \item{\code{'chc'}}{ returns the cluster membership based on the
+#' hierarchical clustering of the consensus matrix, as performed by
+#' \code{\link{consensushc}}.}
+#' \item{\code{'consensus'}}{ same as \code{'chc'} but the levels of the membership
+#' index are re-labeled to match the order of the clusters as they would be displayed on the
+#' associated dendrogram, as re-ordered on the default annotation track in consensus
+#' heatmap produced by \code{\link{consensusmap}}.}
+#' }
+#'
+setMethod('predict', signature(object='NMFfitX'),
+ function(object, what=c('columns', 'rows', 'samples', 'features', 'consensus', 'chc'), dmatrix = FALSE, ...){
+ # determine which prediction to do
+ what <- match.arg(what)
+ res <- if( what %in% c('consensus', 'chc') ){
+ # build the tree from consensus matrix
+ h <- consensushc(object, what='consensus', dendrogram=FALSE)
+ # extract membership from the tree
+ cl <- cutree(h, k=nbasis(object))
+
+ # rename the cluster ids in the case of a consensus map
+ if( what != 'chc' ){
+ dr <- as.dendrogram(h)
+ o <- order.dendrogram(reorder(dr, rowMeans(consensus(object), na.rm=TRUE)))
+ cl <- setNames(match(cl, unique(cl[o])), names(cl))
+ }
+
+ res <- as.factor(cl)
+ # add dissimilarity matrix if requested
+ if( dmatrix ){
+ attr(res, 'dmatrix') <- 1 - consensus(object)
+ }
+ if( what != 'chc' ) attr(res, 'iOrd') <- o
+
+ # return
+ res
+ }
+ else predict(fit(object), what=what, ..., dmatrix = dmatrix)
+ attr(res, 'what') <- what
+ res
+ }
+)
+
+#' Returns the model object that achieves the lowest residual approximation
+#' error across all the runs.
+#'
+#' It is a pure virtual method defined to ensure \code{fit} is defined
+#' for sub-classes of \code{NMFfitX}, which throws an error if called.
+setMethod('fit', 'NMFfitX',
+ function(object){
+ stop("NMF::NMFfitX - missing definition for pure virtual method 'fit' in class '", class(object), "'")
+ }
+)
+
+#' Returns the fit object that achieves the lowest residual approximation
+#' error across all the runs.
+#'
+#' It is a pure virtual method defined to ensure \code{minfit} is defined
+#' for sub-classes of \code{NMFfitX}, which throws an error if called.
+setMethod('minfit', 'NMFfitX',
+ function(object){
+ stop("NMF::NMFfitX - missing definition for pure virtual method 'minfit' in class '", class(object), "'")
+ }
+)
+
+#' Show method for objects of class \code{NMFfitX}
+#' @export
+setMethod('show', 'NMFfitX',
+ function(object){
+ cat("<Object of class:", class(object), ">\n")
+ # name of the algorithm
+ cat(" Method:", algorithm(object), "\n")
+ # number of runs
+ cat(" Runs: ", nrun(object),"\n");
+ # initial state
+ cat(" RNG:\n ", RNGstr(getRNG1(object)),"\n");
+ if( nrun(object) > 0 ){
+ # show total timing
+ cat(" Total timing:\n"); show(runtime.all(object));
+ }
+ }
+)
+
+#' Extracting RNG Data from NMF Objects
+#'
+#' The \code{\link{nmf}} function returns objects that contain embedded RNG data,
+#' that can be used to exactly reproduce any computation.
+#' These data can be extracted using dedicated methods for the S4 generics
+#' \code{\link[rngtools]{getRNG}} and \code{\link[rngtools]{getRNG1}}.
+#'
+#' @inheritParams rngtools::getRNG
+#' @inheritParams rngtools::getRNG1
+#'
+#' @inline
+#' @rdname RNG
+#' @export
+setGeneric('getRNG1', package='rngtools')
+
+#' Returns the RNG settings used for the first NMF run of multiple NMF runs.
+#'
+#' @examples
+#' # For multiple NMF runs, the RNG settings used for the first run is also stored
+#' V <- rmatrix(20,10)
+#' res <- nmf(V, 3, nrun=4)
+#' # RNG used for the best fit
+#' getRNG(res)
+#' # RNG used for the first of all fits
+#' getRNG1(res)
+#' # they may differ if the best fit is not the first one
+#' rng.equal(res, getRNG1(res))
+#'
+setMethod('getRNG1', signature(object='NMFfitX'),
+ function(object){
+ stop("NMF::getRNG1(", class(object), ") - Unimplemented pure virtual method: could not extract initial RNG settings.")
+ }
+)
+
+#' Compares two NMF models when at least one comes from multiple NMF runs.
+setMethod('nmf.equal', signature(x='NMFfitX', y='NMF'),
+ function(x, y, ...){
+ nmf.equal(fit(x), y, ...)
+ }
+)
+#' Compares two NMF models when at least one comes from multiple NMF runs.
+setMethod('nmf.equal', signature(x='NMF', y='NMFfitX'),
+ function(x, y, ...){
+ nmf.equal(x, fit(y), ...)
+ }
+)
+
+#' Returns the residuals achieved by the best fit object, i.e. the lowest
+#' residual approximation error achieved across all NMF runs.
+setMethod('residuals', signature(object='NMFfitX'),
+ function(object, ...){
+ residuals(minfit(object), ...)
+ }
+)
+#' Returns the deviance achieved by the best fit object, i.e. the lowest
+#' deviance achieved across all NMF runs.
+setMethod('deviance', signature(object='NMFfitX'),
+ function(object, ...){
+ deviance(minfit(object), ...)
+ }
+)
+
+#########################################################
+# END_NMFfitX
+#########################################################
+
+
+#' Structure for Storing the Best Fit Amongst Multiple NMF Runs
+#'
+#' This class is used to return the result from a multiple run of a single NMF
+#' algorithm performed with function \code{nmf} with the -- default -- option
+#' \code{keep.all=FALSE} (cf. \code{\link{nmf}}).
+#'
+#' It extends both classes \code{\linkS4class{NMFfitX}} and
+#' \code{\linkS4class{NMFfit}}, and stores a the result of the best fit in its
+#' \code{NMFfit} structure.
+#'
+#' Beside the best fit, this class allows to hold data about the computation of
+#' the multiple runs, such as the number of runs, the CPU time used to perform
+#' all the runs, as well as the consensus matrix.
+#'
+#' Due to the inheritance from class \code{NMFfit}, objects of class
+#' \code{NMFfitX1} can be handled exactly as the results of single NMF run --
+#' as if only the best run had been performed.
+#'
+#'
+#' @slot consensus object of class \code{matrix} used to store the
+#' consensus matrix based on all the runs.
+#'
+#' @slot nrun an \code{integer} that contains the number of runs
+#' performed to compute the object.
+#'
+#' @slot rng1 an object that contains RNG settings used for the first
+#' run. See \code{\link{getRNG1}}.
+#'
+#' @export
+#' @family multipleNMF
+#' @examples
+#'
+#' # generate a synthetic dataset with known classes
+#' n <- 20; counts <- c(5, 2, 3);
+#' V <- syntheticNMF(n, counts)
+#'
+#' # get the class factor
+#' groups <- V$pData$Group
+#'
+#' # perform multiple runs of one algorithm, keeping only the best fit (default)
+#' #i.e.: the implicit nmf options are .options=list(keep.all=FALSE) or .options='-k'
+#' res <- nmf(V, 3, nrun=3)
+#' res
+#'
+#' # compute summary measures
+#' summary(res)
+#' # get more info
+#' summary(res, target=V, class=groups)
+#'
+#' # show computational time
+#' runtime.all(res)
+#'
+#' # plot the consensus matrix, as stored (pre-computed) in the object
+#' \dontrun{ consensusmap(res, annCol=groups) }
+#'
+setClass('NMFfitX1'
+ , representation(
+ #fit = 'NMFfit' # holds the best fit from all the runs
+ consensus = 'matrix' # average connectivity matrix of all the NMF runs
+ , nrun = 'integer'
+ , rng1 = 'ANY'
+ )
+ , contains=c('NMFfitX', 'NMFfit')
+ , prototype=prototype(
+ consensus = matrix(as.numeric(NA),0,0)
+ , nrun = as.integer(0)
+ )
+)
+
+
+
+#' Show method for objects of class \code{NMFfitX1}
+#' @export
+setMethod('show', 'NMFfitX1',
+ function(object){
+ callNextMethod(object)
+
+ # show details of the best fit
+ #cat(" # Best fit:\n ")
+ #s <- capture.output(show(fit(object)))
+ #cat(s, sep="\n |")
+ }
+)
+
+#' Returns the number of NMF runs performed, amongst which \code{object} was
+#' selected as the best fit.
+setMethod('nrun', 'NMFfitX1',
+ function(object){
+ slot(object,'nrun')
+ }
+)
+
+#' Returns the consensus matrix computed while performing all NMF runs,
+#' amongst which \code{object} was selected as the best fit.
+#'
+#' The result is the matrix stored in slot \sQuote{consensus}.
+#' This method returns \code{NULL} if the consensus matrix is empty.
+setMethod('consensus', signature(object='NMFfitX1'),
+ function(object, no.attrib = FALSE){
+
+ C <- slot(object, 'consensus')
+ if( length(C) > 0 ){
+ if( !no.attrib ){
+ class(C) <- c(class(C), 'NMF.consensus')
+ attr(C, 'nrun') <- nrun(object)
+ attr(C, 'nbasis') <- nbasis(object)
+ }
+ C
+ }else NULL
+
+ }
+)
+
+#' Returns the fit object associated with the best fit, amongst all the
+#' runs performed when fitting \code{object}.
+#'
+#' Since \code{NMFfitX1} objects only hold the best fit, this method simply
+#' returns \code{object} coerced into an \code{NMFfit} object.
+setMethod('minfit', 'NMFfitX1',
+ function(object){
+ # coerce the object into a NMFfit object
+ as(object, 'NMFfit')
+ }
+)
+
+#' Returns the model object associated with the best fit, amongst all the
+#' runs performed when fitting \code{object}.
+#'
+#' Since \code{NMFfitX1} objects only hold the best fit, this method simply
+#' returns the NMF model fitted by \code{object} -- that is stored in slot
+#' \sQuote{fit}.
+setMethod('fit', signature(object='NMFfitX1'),
+ function(object){
+ slot(object, 'fit')
+ }
+)
+
+#' Returns the RNG settings used to compute the first of all NMF runs, amongst
+#' which \code{object} was selected as the best fit.
+setMethod('getRNG1', signature(object='NMFfitX1'),
+ function(object){
+ object at rng1
+ }
+)
+
+#' Compares the NMF models fitted by multiple runs, that only kept the best fits.
+setMethod('nmf.equal', signature(x='NMFfitX1', y='NMFfitX1'),
+ function(x, y, ...){
+ nmf.equal(fit(x), fit(y), ...)
+ }
+)
+
+#########################################################
+# END_NMFfitX1
+#########################################################
+
+
+#' Structure for Storing All Fits from Multiple NMF Runs
+#'
+#' This class is used to return the result from a multiple run of a single NMF
+#' algorithm performed with function \code{nmf} with option
+#' \code{keep.all=TRUE} (cf. \code{\link{nmf}}).
+#'
+#' It extends both classes \code{\linkS4class{NMFfitX}} and \code{list}, and
+#' stores the result of each run (i.e. a \code{NMFfit} object) in its
+#' \code{list} structure.
+#'
+#' IMPORTANT NOTE: This class is designed to be \strong{read-only}, even though
+#' all the \code{list}-methods can be used on its instances. Adding or removing
+#' elements would most probably lead to incorrect results in subsequent calls.
+#' Capability for concatenating and merging NMF results is for the moment only
+#' used internally, and should be included and supported in the next release of
+#' the package.
+#'
+#'
+#' @slot .Data standard slot that contains the S3 \code{list} object data.
+#' See R documentation on S3/S4 classes for more details (e.g., \code{\link{setOldClass}}).
+#'
+#' @export
+#' @family multipleNMF
+#' @examples
+#'
+#' # generate a synthetic dataset with known classes
+#' n <- 20; counts <- c(5, 2, 3);
+#' V <- syntheticNMF(n, counts)
+#'
+#' # get the class factor
+#' groups <- V$pData$Group
+#'
+#' # perform multiple runs of one algorithm, keeping all the fits
+#' res <- nmf(V, 3, nrun=3, .options='k') # .options=list(keep.all=TRUE) also works
+#' res
+#'
+#' summary(res)
+#' # get more info
+#' summary(res, target=V, class=groups)
+#'
+#' # compute/show computational times
+#' runtime.all(res)
+#' seqtime(res)
+#'
+#' # plot the consensus matrix, computed on the fly
+#' \dontrun{ consensusmap(res, annCol=groups) }
+#'
+setClass('NMFfitXn'
+ , contains=c('NMFfitX', 'list')
+ , validity=function(object){
+
+ # the list must only contains NMFfit objects of the same dimensions
+ ref.dim <- NULL
+ ref.algo <- NULL
+ for(i in seq_along(object)){
+ # check class of the element
+ item <- object[[i]]
+ if( !(is(item, 'NMFfit') && !is(item, 'NMFfitX')) )
+ return(paste("invalid class for element", i, "of input list [all elements must be a NMFfit object]"))
+
+ # check dimensions
+ if( is.null(ref.dim) ) ref.dim <- dim(item)
+ if( !identical(ref.dim, dim(item)) )
+ return(paste("invalid dimension for element", i, "of input list [all elements must have the same dimensions]"))
+
+ # check algorithm names
+ if( is.null(ref.algo) ) ref.algo <- algorithm(item)
+ if( !identical(ref.algo, algorithm(item)) )
+ return(paste("invalid algorithm for element", i, "of input list [all elements must result from the same algorithm]"))
+
+ }
+
+ }
+)
+
+# Updater for slot .Data
+#objectUpdater('NMFfitXn', '0.5.06'
+# , vfun=function(object){ !.hasSlot(object, 'rng1') }
+# , function(x, y){
+# y at .Data <- lapply(x at .Data, nmfObject)
+# }
+#)
+
+#' Show method for objects of class \code{NMFfitXn}
+#' @export
+setMethod('show', 'NMFfitXn',
+ function(object){
+ callNextMethod(object)
+
+ # if the object is not empty and slot runtime.all is not null then show
+ # the sequential time, as it might be different from runtime.all
+ if( length(object) > 0 && !is.null(runtime.all(object, null=TRUE)) ){
+ # show total sequential timing
+ cat(" Sequential timing:\n"); show(seqtime(object));
+ }
+ }
+)
+
+#' Returns the number of basis components common to all fits.
+#'
+#' Since all fits have been computed using the same rank, it returns the
+#' factorization rank of the first fit.
+#' This method returns \code{NULL} if the object is empty.
+setMethod('nbasis', signature(x='NMFfitXn'),
+ function(x, ...){
+ if( length(x) == 0 ) return(NULL)
+ return( nbasis(x[[1]]) )
+ }
+)
+#' Returns the dimension common to all fits.
+#'
+#' Since all fits have the same dimensions, it returns the dimension of the
+#' first fit.
+#' This method returns \code{NULL} if the object is empty.
+#'
+#' @rdname dims
+setMethod('dim', signature(x='NMFfitXn'),
+ function(x){
+ if( length(x) == 0 ) return(NULL)
+ return( dim(x[[1L]]) )
+ }
+)
+
+#' Returns the coefficient matrix of the best fit amongst all the fits stored in
+#' \code{object}.
+#' It is a shortcut for \code{coef(fit(object))}.
+setMethod('coef', signature(object='NMFfitXn'),
+ function(object, ...){
+ coef(fit(object), ...)
+ }
+)
+
+#' Returns the basis matrix of the best fit amongst all the fits stored in
+#' \code{object}.
+#' It is a shortcut for \code{basis(fit(object))}.
+setMethod('basis', signature(object='NMFfitXn'),
+ function(object, ...){
+ basis(fit(object), ...)
+ }
+)
+
+#' Method for multiple NMF fit objects, which returns the indexes of fixed basis
+#' terms from the best fitted model.
+setMethod('ibterms', 'NMFfitX',
+ function(object){
+ ibterms(fit(object))
+ }
+)
+#' Method for multiple NMF fit objects, which returns the indexes of fixed
+#' coefficient terms from the best fitted model.
+setMethod('icterms', 'NMFfit',
+ function(object){
+ icterms(fit(object))
+ }
+)
+
+
+#' Returns the number of runs performed to compute the fits stored in the list
+#' (i.e. the length of the list itself).
+setMethod('nrun', 'NMFfitXn',
+ function(object){
+ length(object)
+ }
+)
+
+#' Returns the name of the common NMF algorithm used to compute all fits
+#' stored in \code{object}
+#'
+#' Since all fits are computed with the same algorithm, this method returns the
+#' name of algorithm that computed the first fit.
+#' It returns \code{NULL} if the object is empty.
+setMethod('algorithm', 'NMFfitXn',
+ function(object){
+ if( length(object) == 0 ) return(NULL)
+ return( algorithm(object[[1]]) )
+ }
+)
+#' Returns the name of the common seeding method used the computation of all fits
+#' stored in \code{object}
+#'
+#' Since all fits are seeded using the same method, this method returns the
+#' name of the seeding method used for the first fit.
+#' It returns \code{NULL} if the object is empty.
+setMethod('seeding', 'NMFfitXn',
+ function(object){
+ if( length(object) == 0 ) return(NULL)
+ return( seeding(object[[1]]) )
+ }
+)
+#' Returns the common type NMF model of all fits stored in \code{object}
+#'
+#' Since all fits are from the same NMF model, this method returns the
+#' model type of the first fit.
+#' It returns \code{NULL} if the object is empty.
+setMethod('modelname', signature(object='NMFfitXn'),
+ function(object){
+ if( length(object) == 0 ) return(NULL)
+ return( modelname(object[[1]]) )
+ }
+)
+
+#' Returns the CPU time that would be required to sequentially compute all NMF
+#' fits stored in \code{object}.
+#'
+#' This method calls the function \code{runtime} on each fit and sum up the
+#' results.
+#' It returns \code{NULL} on an empty object.
+setMethod('seqtime', 'NMFfitXn',
+ function(object){
+ if( length(object) == 0 ) return(NULL)
+ # sum up the time across the runs
+ .seqtime(object)
+ }
+)
+
+#' Returns the CPU time used to perform all the NMF fits stored in \code{object}.
+#'
+#' If no time data is available from in slot \sQuote{runtime.all} and argument
+#' \code{null=TRUE}, then the sequential time as computed by
+#' \code{\link{seqtime}} is returned, and a warning is thrown unless \code{warning=FALSE}.
+#'
+#' @param null a logical that indicates if the sequential time should be returned
+#' if no time data is available in slot \sQuote{runtime.all}.
+#' @param warning a logical that indicates if a warning should be thrown if the
+#' sequential time is returned instead of the real CPU time.
+#'
+setMethod('runtime.all', 'NMFfitXn',
+ function(object, null=FALSE, warning=TRUE){
+
+ if( length(object) == 0 ) return(NULL)
+ stored.time <- slot(object, 'runtime.all')
+ # if there is some time stored, return it
+ if( length(stored.time) > 0 ) stored.time
+ else if( null ) NULL
+ else{
+ if( warning )
+ warning("NMFfitXn::runtime.all - computation time data not available [sequential time was used instead]")
+ seqtime(object) # otherwise total sequential time
+ }
+
+ }
+)
+
+#' Returns the best NMF model in the list, i.e. the run that achieved the lower
+#' estimation residuals.
+#'
+#' The model is selected based on its \code{deviance} value.
+#'
+setMethod('minfit', 'NMFfitXn',
+ function(object){
+
+ b <- which.best(object, deviance)
+ # test for length 0
+ if( length(b) == 0 ) return(NULL)
+
+ # return the run with the lower
+ object[[ b ]]
+ }
+)
+
+#' \code{which.best} returns the index of the best fit in a list of NMF fit,
+#' according to some quantitative measure.
+#' The index of the fit with the lowest measure is returned.
+#'
+#' @param object an NMF model fitted by multiple runs.
+#' @param FUN the function that computes the quantitative measure.
+#' @param ... extra arguments passed to \code{FUN}.
+#'
+#' @export
+#' @rdname advanced
+which.best <- function(object, FUN=deviance, ...){
+
+ # test for length 0
+ if( length(object) == 0 )
+ return(integer())
+
+ # retrieve the measure for each run
+ e <- sapply(object, FUN, ...)
+
+ # return the run with the lower
+ which.min(e)
+}
+
+#' Returns the RNG settings used for the first run.
+#'
+#' This method throws an error if the object is empty.
+setMethod('getRNG1', signature(object='NMFfitXn'),
+ function(object){
+ if( length(object) == 0 )
+ stop("NMF::getRNG1 - Could not extract RNG data from empty object [class:", class(object), "]")
+
+ getRNG(object[[1]])
+ }
+)
+
+#' @inline
+#' @rdname RNG
+#' @export
+setGeneric('.getRNG', package='rngtools')
+
+#' Returns the RNG settings used for the best fit.
+#'
+#' This method throws an error if the object is empty.
+setMethod('.getRNG', signature(object='NMFfitXn'),
+ function(object, ...){
+ if( length(object) == 0 )
+ stop("NMF::getRNG - Could not extract RNG data from empty object [class:", class(object), "]")
+
+ getRNG(minfit(object), ...)
+ }
+)
+
+
+#' Returns the best NMF fit object amongst all the fits stored in \code{object},
+#' i.e. the fit that achieves the lowest estimation residuals.
+setMethod('fit', signature(object='NMFfitXn'),
+ function(object){
+ fit( minfit(object) )
+ }
+)
+
+#' Compares the results of multiple NMF runs.
+#'
+#' This method either compare the two best fit, or all fits separately.
+#' All extra arguments in \code{...} are passed to each internal call to
+#' \code{nmf.equal}.
+#'
+#' @param all a logical that indicates if all fits should be compared separately
+#' or only the best fits
+#' @param vector a logical, only used when \code{all=TRUE}, that indicates if
+#' all fits must be equal for \code{x} and \code{y} to be declared equal, or
+#' if one wants to return the result of each comparison in a vector.
+#'
+#' @inline
+setMethod('nmf.equal', signature(x='list', y='list'),
+ function(x, y, ..., all=FALSE, vector=FALSE){
+ if( !all )
+ nmf.equal(x[[ which.best(x) ]], y[[ which.best(y) ]], ...)
+ else{
+ if( length(x) != length(y) )
+ FALSE
+ else
+ res <- mapply(function(a,b,...) isTRUE(nmf.equal(a,b,...)), x, y, MoreArgs=list(...))
+ if( !vector )
+ res <- all( res )
+ res
+ }
+ }
+)
+
+#' Compare all elements in \code{x} to \code{x[[1]]}.
+setMethod('nmf.equal', signature(x='list', y='missing'),
+ function(x, y, ...){
+
+ if( length(x) == 0L ){
+ warning("Empty list argument `x`: returning NA")
+ return(NA)
+ }
+ if( length(x) == 1L ){
+ warning("Only one element in list argument `x`: returning TRUE")
+ return(TRUE)
+ }
+ for( a in x ){
+ if( !nmf.equal(x[[1]], a, ...) ) return(FALSE)
+ }
+ return(TRUE)
+ }
+)
+
+#' Computes the consensus matrix of the set of fits stored in \code{object}, as
+#' the mean connectivity matrix across runs.
+#'
+#' This method returns \code{NULL} on an empty object.
+#' The result is a matrix with several attributes attached, that are used by
+#' plotting functions such as \code{\link{consensusmap}} to annotate the plots.
+#'
+#' @aliases plot.NMF.consensus
+setMethod('consensus', signature(object='NMFfitXn'),
+ function(object, ..., no.attrib = FALSE){
+ if( length(object) == 0 ) return(NULL)
+
+ # init empty consensus matrix
+ con <- matrix(0, ncol(object), ncol(object))
+ # name the rows and columns appropriately: use the sample names of the first fit
+ dimnames(con) <- list(colnames(object[[1]]), colnames(object[[1]]))
+
+ # compute mean connectivity matrix
+ sapply(object
+ , function(x, ...){
+ con <<- con + connectivity(x, ..., no.attrib = TRUE)
+ NULL
+ }
+ , ...
+ )
+ con <- con / nrun(object)
+
+ # return result
+ if( !no.attrib ){
+ class(con) <- c(class(con), 'NMF.consensus')
+ attr(con, 'nrun') <- nrun(object)
+ attr(con, 'nbasis') <- nbasis(object)
+ }
+ con
+ }
+)
+
+#' @S3method plot NMF.consensus
+plot.NMF.consensus <- function(x, ...){
+ consensusmap(x, ...)
+}
+
+#' Dispersion of a Matrix
+#'
+#' Computes the dispersion coefficient of a -- consensus -- matrix
+#' \code{object}, generally obtained from multiple NMF runs.
+#'
+#' The dispersion coefficient is based on the consensus matrix (i.e. the
+#' average of connectivity matrices) and was proposed by \cite{KimH2007} to
+#' measure the reproducibility of the clusters obtained from NMF.
+#'
+#' It is defined as:
+#' \deqn{\rho = \sum_{i,j=1}^n 4 (C_{ij} - \frac{1}{2})^2 , }
+#' where \eqn{n} is the total number of samples.
+#'
+#' By construction, \eqn{0 \leq \rho \leq 1} and \eqn{\rho = 1} only for a perfect
+#' consensus matrix, where all entries 0 or 1.
+#' A perfect consensus matrix is obtained only when all the connectivity matrices
+#' are the same, meaning that the algorithm gave the same clusters at each run.
+#' See \cite{KimH2007}.
+#'
+#' @param object an object from which the dispersion is computed
+#' @param ... extra arguments to allow extension
+#'
+#' @export
+setGeneric('dispersion', function(object, ...) standardGeneric('dispersion') )
+#' Workhorse method that computes the dispersion on a given matrix.
+setMethod('dispersion', 'matrix',
+ function(object, ...){
+ stopifnot( nrow(object) == ncol(object) )
+ sum( 4 * (object-1/2)^2 ) / nrow(object)^2
+ }
+)
+#' Computes the dispersion on the consensus matrix obtained from multiple NMF
+#' runs.
+setMethod('dispersion', 'NMFfitX',
+ function(object, ...){
+ dispersion(consensus(object), ...)
+ }
+)
+
+#' Factory Method for Multiple NMF Run Objects
+#'
+#' @param object an object from which is created an \code{NMFfitX} object
+#' @param ... extra arguments used to pass values for slots
+#'
+#' @inline
+#' @keywords internal
+setGeneric('NMFfitX', function(object, ...) standardGeneric('NMFfitX') )
+#' Create an \code{NMFfitX} object from a list of fits.
+#'
+#' @param .merge a logical that indicates if the fits should be aggregated, only
+#' keeping the best fit, and return an \code{NMFfitX1} object.
+#' If \code{FALSE}, an \code{NMFfitXn} object containing the data of all the fits
+#' is returned.
+#'
+setMethod('NMFfitX', 'list',
+ function(object, ..., .merge=FALSE){
+
+ if( length(object) == 0 )
+ return(new('NMFfitXn'))
+ else if( is(object, 'NMFfitXn') && !.merge)
+ return(object)
+
+ # retrieve the extra arguments
+ extra <- list(...)
+
+ # if runtime.all is provided: be sure it's of the right class
+ tt <- extra$runtime.all
+ compute.tt <- TRUE
+ if( !is.null(tt) ){
+ if( !is(tt, 'proc_time') ){
+ if( !is.numeric(tt) || length(tt) != 5 )
+ stop("NMF::NMFfitX - invalid value for 'runtime.all' [5-length numeric expected]")
+ class(extra$runtime.all) <- 'proc_time'
+ }
+ compute.tt <- FALSE
+ }else{
+ extra$runtime.all <- rep(0,5)
+ class(extra$runtime.all) <- 'proc_time'
+ }
+
+ # check validity and aggregate if required
+ ref.algo <- NULL
+ ref.class <- NULL
+ nrun <- 0
+ lapply( seq_along(object)
+ , function(i){
+ item <- object[[i]]
+
+ # check the type of each element
+ if( !(is(item, 'NMFfitX') || is(item, 'NMFfit')) )
+ stop("NMF::NMFfitX - invalid class for element ", i, " of input list [all elements must be NMFfit or NMFfitX objects]")
+
+ # check that all elements result from the same algorithm
+ if( is.null(ref.algo) ) ref.algo <<- algorithm(item)
+ if( !identical(algorithm(item), ref.algo) )
+ stop("NMF::NMFfitX - invalid algorithm for element ", i, " of input list [cannot join results from different algorithms]")
+
+ # check if simple join is possible: only Ok if all elements are from the same class (NMFfit or NMFfitXn)
+ if( length(ref.class) <= 1 ) ref.class <<- unique(c(ref.class, class(item)))
+
+ # sum up the number of runs
+ nrun <<- nrun + nrun(item)
+
+ # compute total running time if necessary
+ if( compute.tt )
+ extra$runtime.all <<- extra$runtime.all + runtime.all(item)
+
+ }
+ )
+
+ # force merging if the input list is hetergeneous or if it only contains NMFfitX1 objects
+ if( length(ref.class) > 1 || ref.class == 'NMFfitX1' ){
+ nmf.debug('NMFfitX', ".merge is forced to TRUE")
+ .merge <- TRUE
+ }
+
+ # unpack all the NMFfit objects
+ object.list <- unlist(object)
+ nmf.debug('NMFfitX', "Number of fits to join = ", length(object.list))
+
+ # one wants to keep only the best result
+ if( .merge ){
+
+ warning("NMF::NMFfitX - The method for merging lists is still in development")
+
+ # set the total number of runs
+ extra$nrun <- as.integer(nrun)
+
+ # consensus matrix
+ if( !is.null(extra$consensus) )
+ warning("NMF::NMFfitX - the value of 'consensus' was discarded as slot 'consensus' is computed internally")
+ extra$consensus <- NULL
+
+ consensus <- matrix(as.numeric(NA), 0, 0)
+ best.res <- Inf
+ best.fit <- NULL
+ sapply(object.list, function(x){
+ if( !is(x, 'NMFfit') )
+ stop("NMF::NMFfitX - all inner-elements of '",substitute(object),"' must inherit from class 'NMFfit'")
+
+ # merge consensus matrices
+ consensus <<- if( sum(dim(consensus)) == 0 ) nrun(x) * consensus(x)
+ else consensus + nrun(x) * consensus(x)
+
+ temp.res <- residuals(x)
+ if( temp.res < best.res ){
+ # keep best result
+ best.fit <<- minfit(x)
+ best.res <<- temp.res
+ }
+ })
+ # finalize consensus matrix
+ consensus <- consensus/extra$nrun
+ extra$consensus <- consensus
+
+ # return merged result
+ return( do.call(NMFfitX, c(list(best.fit), extra)) )
+ }
+ else{
+ # create a NMFfitXn object that holds the whole list
+ do.call('new', c(list('NMFfitXn', object.list), extra))
+ }
+ }
+)
+#' Creates an \code{NMFfitX1} object from a single fit.
+#' This is used in \code{\link{nmf}} when only the best fit is kept in memory or
+#' on disk.
+#'
+setMethod('NMFfitX', 'NMFfit',
+ function(object, ...){
+
+ extra <- list(...)
+
+ # default value for nrun is 1
+ if( is.null(extra$nrun) ) extra$nrun = as.integer(1)
+
+ # a consensus matrix is required (unless nrun is 1)
+ if( is.null(extra$consensus) ){
+ if( extra$nrun == 1 )
+ extra$consensus <- connectivity(object)
+ else
+ stop("Slot 'consensus' is required to create a 'NMFfitX1' object where nrun > 1")
+ }
+
+ # slot runtime.all is inferred if missing and nrun is 1
+ if( is.null(extra$runtime.all) && extra$nrun == 1 )
+ extra$runtime.all <- runtime(object)
+
+ # create the NMFfitX1 object
+ do.call('new', c(list('NMFfitX1', object), extra))
+ }
+)
+#' Provides a way to aggregate \code{NMFfitXn} objects into an \code{NMFfitX1}
+#' object.
+setMethod('NMFfitX', 'NMFfitX',
+ function(object, ...){
+
+ # nothing to do in the case of NMFfitX1 objects
+ if( is(object, 'NMFfitX1') ) return(object)
+
+ # retrieve extra arguments
+ extra <- list(...)
+
+ # take runtime.all from the object itself
+ if( !is.null(extra$runtime.all) )
+ warning("NMF::NMFfitX - argument 'runtime.all' was discarded as it is computed from argument 'object'")
+ extra$runtime.all <- runtime.all(object)
+
+ # create the NMFfitX1 object
+ f <- selectMethod(NMFfitX, 'list')
+ do.call(f, c(list(object), extra))
+ }
+)
+
+#' Computes the best or mean purity across all NMF fits stored in \code{x}.
+#'
+#' @param method a character string that specifies how the value is computed.
+#' It may be either \code{'best'} or \code{'mean'} to compute the best or mean
+#' purity respectively.
+#'
+#' @inline
+setMethod('purity', signature(x='NMFfitXn', y='ANY'),
+ function(x, y, method='best', ...){
+ c <- sapply(x, purity, y=y, ...)
+
+ # aggregate the results if a method is provided
+ if( is.null(method) ) c
+ else aggregate.measure(c, method, decreasing=TRUE)
+ }
+)
+
+#' Computes the best or mean entropy across all NMF fits stored in \code{x}.
+#'
+#' @inline
+setMethod('entropy', signature(x='NMFfitXn', y='ANY'),
+ function(x, y, method='best', ...){
+ c <- sapply(x, entropy, y=y, ...)
+
+ # aggregate the results if a method is provided
+ if( is.null(method) ) c
+ else aggregate.measure(c, method)
+ }
+)
+
+###% Utility function to aggregate numerical quality measures from \code{NMFfitXn} objects.
+###%
+###% Given a numerical vector, this function computes an aggregated value using one of the following methods:
+###% - mean: the mean of the measures
+###% - best: the best measure according to the specified sorting order (decreasing or not)
+###%
+aggregate.measure <- function(measure, method=c('best', 'mean'), decreasing=FALSE){
+ # aggregate the results
+ method <- match.arg(method)
+ res <- switch(method
+ , mean = mean(measure)
+ , best = if( decreasing ) max(measure) else min(measure)
+ )
+
+ # set the name to
+ names(res) <- method
+
+ # return result
+ res
+}
+
+#' Computes a set of measures to help evaluate the quality of the \emph{best
+#' fit} of the set.
+#' The result is similar to the result from the \code{summary} method of
+#' \code{NMFfit} objects.
+#' See \code{\linkS4class{NMF}} for details on the computed measures.
+#' In addition, the cophenetic correlation (\code{\link{cophcor}}) and
+#' \code{\link{dispersion}} coefficients of the consensus matrix are returned,
+#' as well as the total CPU time (\code{\link{runtime.all}}).
+#'
+setMethod('summary', signature(object='NMFfitX'),
+ function(object, ...){
+
+ # compute summary measures for the best fit
+ best.fit <- minfit(object)
+ s <- summary(best.fit, ...)
+ # get totaltime
+ t <- runtime.all(object)
+
+ # replace cpu.all and nrun in the result (as these are set by the summary method of class NMFfit)
+ s[c('cpu.all', 'nrun')] <- c(as.numeric(t['user.self']+t['user.child']), nrun(object))
+
+ # compute cophenetic correlation coeff and dispersion
+ C <- consensus(object)
+ s <- c(s, cophenetic=cophcor(C), dispersion=dispersion(C))
+
+ # compute mean consensus silhouette width
+ si <- silhouette(object, what = 'consensus')
+ s <- c(s, silhouette.consensus = if( !is_NA(si) ) summary(si)$avg.width else NA)
+
+ # return result
+ s
+ }
+)
+
+
+#' Comparing Results from Different NMF Runs
+#'
+#' The functions documented here allow to compare the fits computed in
+#' different NMF runs.
+#' The fits do not need to be from the same algorithm, nor have the same
+#' dimension.
+#'
+#' The methods \code{compare} enables to compare multiple NMF fits either
+#' passed as arguments or as a list of fits.
+#' These methods eventually call the method \code{summary,NMFList}, so that
+#' all its arguments can be passed \strong{named} in \code{...}.
+#'
+#' @param ... extra arguments passed by \code{compare} to \code{summary,NMFList}
+#' or to the \code{summary} method of each fit.
+#'
+#' @name compare-NMF
+#' @rdname nmf-compare
+NULL
+
+.compare_NMF <- function(...){
+ args <- list(...)
+
+ iargs <-
+ if( is.null(names(args)) ){
+ names(args) <- rep("", length(args))
+ seq(args)
+ }else{
+ iargs <- which(names(args)=='')
+ if( length(iargs) != length(args) )
+ iargs <- iargs[ iargs < which(names(args)!='')[1L] ]
+ iargs
+ }
+
+ lfit <- args[iargs]
+ lfit <- unlist(lfit, recursive=FALSE)
+
+ # wrap up into an NMFList object
+ object <- as.NMFList(lfit)
+ do.call('summary', c(list(object), args[-iargs]))
+}
+
+#' Compare multiple NMF fits passed as arguments.
+#'
+#' @rdname nmf-compare
+#'
+#' @examples
+#'
+#' x <- rmatrix(20,10)
+#' res <- nmf(x, 3)
+#' res2 <- nmf(x, 2, 'lee')
+#'
+#' # compare arguments
+#' compare(res, res2, target=x)
+#'
+setMethod('compare', signature(object='NMFfit'),
+ function(object, ...){
+ .compare_NMF(object, ...)
+ }
+)
+#' Compares the fits obtained by separate runs of NMF, in a single
+#' call to \code{\link{nmf}}.
+#'
+#' @rdname nmf-compare
+#'
+#' # compare each fits in a multiple runs
+#' res3 <- nmf(x, 2, nrun=3, .opt='k')
+#' compare(res3)
+#' compare(res3, res, res2)
+#' compare(list(res3), res, res2, target=x)
+#'
+setMethod('compare', signature(object='NMFfitXn'),
+ function(object, ...){
+ do.call(.compare_NMF, c(unlist(object), list(...)))
+ }
+)
+#' Compares multiple NMF fits passed as a standard list.
+#'
+#' @rdname nmf-compare
+#'
+#' @examples
+#' # compare elements of a list
+#' compare(list(res, res2), target=x)
+setMethod('compare', signature(object='list'),
+ function(object, ...){
+ do.call(.compare_NMF, c(list(object), list(...)))
+ }
+)
+
+#' @details
+#' \code{summary,NMFList} computes summary measures for each NMF result in the list
+#' and return them in rows in a \code{data.frame}.
+#' By default all the measures are included in the result, and \code{NA} values
+#' are used where no data is available or the measure does not apply to the
+#' result object (e.g. the dispersion for single' NMF runs is not meaningful).
+#' This method is very useful to compare and evaluate the performance of
+#' different algorithms.
+#'
+#' @param select the columns to be output in the result \code{data.frame}. The
+#' column are given by their names (partially matched). The column names are
+#' the names of the summary measures returned by the \code{summary} methods of
+#' the corresponding NMF results.
+#' @param sort.by the sorting criteria, i.e. a partial match of a column name,
+#' by which the result \code{data.frame} is sorted. The sorting direction
+#' (increasing or decreasing) is computed internally depending on the chosen
+#' criteria (e.g. decreasing for the cophenetic coefficient, increasing for the
+#' residuals).
+#'
+#' @rdname nmf-compare
+setMethod('summary', signature(object='NMFList'),
+ function(object, sort.by=NULL, select=NULL, ...){
+
+ if( length(object) == 0L ) return()
+
+ # define the sorting schema for each criteria (TRUE for decreasing, FALSE for increasing)
+ sorting.schema <- list(method=FALSE, seed=FALSE, rng=FALSE, metric=FALSE
+ , residuals=FALSE, cpu=FALSE, purity=TRUE, nrun=FALSE, cpu.all=FALSE
+ , cophenetic=TRUE, dispersion=TRUE #NMFfitX only
+ , entropy=FALSE, sparseness.basis=TRUE, sparseness.coef=TRUE, rank=FALSE, rss=FALSE
+ , niter=FALSE, evar=TRUE
+ , silhouette.coef = TRUE, silhouette.basis = TRUE
+ , silhouette.consensus = TRUE)
+
+ # for each result compute the summary measures
+ measure.matrix <- sapply(object, summary, ...)
+
+ # the results from 'summary' might not have the same length => generate NA where necessary
+ if( is.list(measure.matrix) ){
+ name.all <- unique(unlist(sapply(measure.matrix, names)))
+ measure.matrix <- sapply(seq_along(measure.matrix),
+ function(i){
+ m <- measure.matrix[[i]][name.all]
+ names(m) <- name.all
+ m
+ }
+ )
+ }
+
+ # transpose the results so that methods are in lines, measures are in columns
+ measure.matrix <- t(measure.matrix)
+
+ # set up the resulting data.frame
+ methods <- sapply(object, function(x, ...){
+ x <- minfit(x)
+ m <- algorithm(x)
+ s <- seeding(x)
+ svalue <- objective(x)
+ svalue <- if( is.function(svalue) ) '<function>' else svalue
+ c(method=m, seed=s, rng=RNGdigest(x), metric=svalue)
+ }
+ )
+ methods <- t(methods)
+ res <- as.data.frame(methods, stringsAsFactors=FALSE)
+
+ # add the measures to the result
+ res <- cbind(res, measure.matrix)
+ res$rng <- as.numeric(factor(res$rng))
+
+ # sort according to the user's preference
+ # ASSERT FOR DEV: all columns measure must have a defined sorting schema
+ #if( !all( no.schema <- is.element(colnames(res), names(sorting.schema))) )
+ # warning("ASSERT: missing sorting schema for criteria(e): ", paste(paste("'", colnames(res)[!no.schema], "'", sep=''), collapse=', '))
+
+ if( !is.null(sort.by) ){
+ sorting.criteria <- intersect(colnames(res), names(sorting.schema))
+ sort.by.ind <- pmatch(sort.by, sorting.criteria)
+ if( is.na(sort.by.ind) )
+ stop("NMF::summary[NMFList] : argument 'sort.by' must be NULL or partially match one of "
+ , paste( paste("'", names(sorting.schema), "'", sep=''), collapse=', ')
+ , call.=FALSE)
+ sort.by <- sorting.criteria[sort.by.ind]
+ res <- res[order(res[[sort.by]], decreasing=sorting.schema[[sort.by]]) , ]
+
+ # add an attribute to the result to show the sorting criteria that was used
+ attr(res, 'sort.by') <- sort.by
+ }
+
+ # limit the output to the required measures
+ if( !is.null(select) || !missing(select) ){
+ select.full <- match.arg(select, colnames(res), several.ok=TRUE)
+ if( length(select.full) < length(select) )
+ stop("NMF::summary[NMFList] - the elements of argument 'select' must partially match one of "
+ , paste(paste("'", colnames(res),"'", sep=''), collapse=', ')
+ , call.=FALSE)
+ res <- subset(res, select=select.full)
+ }
+
+ # return result
+ res
+ }
+)
+
+#' @details
+#' \code{plot} plot on a single graph the residuals tracks for each fit in \code{x}.
+#' See function \code{\link{nmf}} for details on how to enable the tracking of residuals.
+#'
+#' @param x an \code{NMFList} object that contains fits from separate NMF runs.
+#' @param y missing
+#' @inheritParams plot,NMFfit,missing-method
+#'
+#' @rdname nmf-compare
+setMethod('plot', signature(x='NMFList', y='missing'),
+ function(x, y, skip=-1L, ...){
+
+ # retrieve normalized residuals tracks
+ max.iter <- 0
+ tracks <- lapply( x,
+ function(res){
+ res <- minfit(res)
+ t <- residuals(res, track=TRUE)
+ # skip some residuals(s) if requested
+ if( skip == -1L && !is.null(names(t)) ) t <- t[names(t)!='0'] # remove initial residual
+ else if( skip > 0 ) t <- t[-(1:skip)]
+ #print(t)
+ # update max iteration
+ max.iter <<- max(max.iter, as.numeric(names(t)))
+ # return normalized track
+ t/t[1]
+ }
+ )
+ minT <- min(sapply(tracks, min))
+ maxT <- max(sapply(tracks, max))
+
+ #print(tracks)
+ # create an empty plot
+ # set default graphical parameters (those can be overriden by the user)
+ params <- .set.list.defaults(list(...)
+ , xlab='Iterations', ylab='Normalised objective values'
+ , main='NMF Residuals')
+
+ # setup the plot
+ do.call('plot',
+ c(list(0, xlim=c(0,max.iter+100), ylim=c(minT, maxT)), col='#00000000'
+ , params)
+ )
+
+ # add legend
+ cols <- seq_along(tracks)
+ legend('topright', legend=names(tracks), fill=cols
+ , title='Algorithm')
+
+ # plot each tracks
+ lapply( seq_along(tracks),
+ function(i){
+ t <- tracks[[i]]
+ points(names(t), t, col=cols[i], type='p', cex=0.5)
+ points(names(t), t, col=cols[i], type='l', lwd=1.4)
+ })
+
+
+ # return invisible
+ return(invisible())
+ }
+)
+
+#' Deprecated method subsituted by \code{\link{consensusmap}}.
+setMethod('metaHeatmap', signature(object='NMFfitX'),
+ function(object, ...){
+ # send deprecated warning
+ .Deprecated('metaHeatmap', 'NMF', "Direct use of the S4-Method 'metaHeatmap' for 'NMFfitX' objects is deprecated, use 'consensusmap' instead.")
+
+ # call the new function 'consmap'
+ return( consensusmap(object, ...) )
+
+ }
+)
+
+#' \code{consensusmap} plots heatmaps of consensus matrices.
+#'
+#' @details
+#' \code{consensusmap} redefines default values for the following arguments of
+#' \code{\link{aheatmap}}:
+#' \itemize{
+#' \item the colour palette;
+#' \item the column ordering which is set equal to the row ordering, since
+#' a consensus matrix is symmetric;
+#' \item the distance and linkage methods used to order the rows (and columns).
+#' The default is to use 1 minus the consensus matrix itself as distance, and
+#' average linkage.
+#' \item the addition of two special named annotation tracks, \code{'basis:'} and
+#' \code{'consensus:'}, that show, for each column (i.e. each sample),
+#' the dominant basis component in the best fit and the hierarchical clustering
+#' of the consensus matrix respectively (using 1-consensus as distance and average
+#' linkage).
+#'
+#' These tracks are specified in argument \code{tracks}, which behaves as in
+#' \code{\link{basismap}}.
+#'
+#' \item a suitable title and extra information like the type of NMF model or the
+#' fitting algorithm, when \code{object} is a fitted NMF model.
+#' }
+#'
+#' @rdname heatmaps
+#'
+#' @examples
+#'
+#' \dontrun{
+#' res <- nmf(x, 3, nrun=3)
+#' consensusmap(res)
+#' }
+#'
+#' @inline
+#' @export
+setGeneric('consensusmap', function(object, ...) standardGeneric('consensusmap') )
+#' Plots a heatmap of the consensus matrix obtained when fitting an NMF model with multiple runs.
+setMethod('consensusmap', 'NMFfitX',
+ function(object, annRow=NA, annCol=NA
+ , tracks=c('basis:', 'consensus:', 'silhouette:')
+ , main = 'Consensus matrix', info = FALSE
+ , ...){
+
+ # add side information if requested
+ info <- if( isTRUE(info) ){
+ paste("NMF model: '", modelname(object)
+ , "'\nAlgorithm: '", algorithm(object)
+ , "'\nbasis: ", nbasis(object)
+ ,"\nnrun: ", nrun(object), sep='')
+ }else if( isFALSE(info) ) NULL
+ else info
+
+ x <- consensus(object)
+
+ # process annotation tracks
+ ptracks <- process_tracks(x, tracks, annRow, annCol)
+ annRow <- ptracks$row
+ annCol <- ptracks$col
+ # set special annotation handler
+ ahandlers <- list(
+ basis = function() predict(object)
+ , consensus = function() predict(object, what='consensus')
+ , silhouette = function(){
+ si <- silhouette(object, what='consensus', order = NA)
+ if( is_NA(si) ) NA
+ else si[, 'sil_width']
+ }
+ )
+ specialAnnotation(1L, ahandlers)
+ specialAnnotation(2L, ahandlers)
+ #
+
+ consensusmap(x, ..., annRow=annRow, annCol=annCol, main = main, info = info)
+ }
+)
+#' Plots a heatmap of the connectivity matrix of an NMF model.
+setMethod('consensusmap', 'NMF',
+ function(object, ...){
+ consensusmap(connectivity(object), ...)
+ }
+)
+#' Main method that redefines default values for arguments of \code{\link{aheatmap}}.
+setMethod('consensusmap', 'matrix',
+ function(object, color='-RdYlBu'
+ , distfun = function(x) as.dist(1-x), hclustfun = 'average'
+ , Rowv = TRUE, Colv = "Rowv"
+ , main = if( is.null(nr) || nr > 1 ) 'Consensus matrix' else 'Connectiviy matrix'
+ , info = FALSE
+ , ...){
+
+ nr <- nrun(object)
+ nb <- nbasis(object)
+ info <- if( isTRUE(info) ){
+ info <- NULL
+ if( !is.null(nr) ) info <- c(info, paste("nrun:", nr))
+ if( !is.null(nb) ) info <- c(info, paste("nbasis:", nb))
+ info <- c(info, paste("cophcor:", round(cophcor(object), 3)))
+ }else if( isFALSE(info) ) NULL
+ else info
+
+ aheatmap(object, color = color, ...
+ , distfun = distfun, hclustfun = hclustfun
+ , Rowv = Rowv, Colv = Colv
+ , main = main
+ , info = info)
+ }
+)
+
+setOldClass('NMF.rank')
+#' Draw a single plot with a heatmap of the consensus matrix obtained for each value of the rank,
+#' in the range tested with \code{\link{nmfEstimateRank}}.
+#'
+#' @rdname nmf-compare
+setMethod('consensusmap', 'NMF.rank',
+ function(object, ...){
+
+ # plot the list of consensus matrix (set names to be used as default main titles)
+ consensusmap(setNames(object$fit, paste("rank = ", lapply(object$fit, nbasis))), ...)
+ }
+)
+#' Draw a single plot with a heatmap of the consensus matrix of each element in the list \code{object}.
+#'
+#' @param layout specification of the layout.
+#' It may be a single numeric or a numeric couple, to indicate a square or rectangular layout
+#' respectively, that is filled row by row.
+#' It may also be a matrix that is directly passed to the function \code{\link[graphics]{layout}}
+#' from the package \code{graphics}.
+#'
+#' @rdname nmf-compare
+setMethod('consensusmap', 'list',
+ function(object, layout
+ , Rowv = FALSE, main = names(object)
+ , ...){
+
+ opar <- par(no.readonly=TRUE)
+ on.exit(par(opar))
+
+ # define default layout
+ if (missing(layout) ){
+ n <- length(object)
+ nr <- nc <- floor(sqrt(n))
+ if( nr^2 != n ){
+ nc <- nr + 1
+ if( nr == 1 && nr*nc < n )
+ nr <- nr + 1
+ }
+
+ layout <- c(nr, nc)
+ }
+ if( !is.matrix(layout) ){
+ if( !is.numeric(layout) )
+ stop("invalid layout specification: must be a matrix or a numeric")
+ if( length(layout) == 1 )
+ layout <- c(layout, layout)
+ layout <- matrix(1:(layout[1]*layout[2]), layout[1], byrow=TRUE)
+ }
+
+ graphics::layout(layout)
+ res <- sapply(seq_along(object), function(i, ...){
+ x <- object[[i]]
+
+ # set main title
+ main <- if( !is.null(main) && length(main) > 1 ){
+ if( length(main) != length(object) )
+ stop("consensusmap - Invalid length for argument `main`: should be either a single character string, or a list or vector of same length as ", deparse(substitute(object)))
+ main[[i]]
+ }
+
+ # call method for the fit
+ consensusmap(x, ..., Rowv=Rowv, main=main)
+ }, ...)
+ invisible(res)
+ }
+)
+
+#' Plots a heatmap of the basis matrix of the best fit in \code{object}.
+setMethod('basismap', signature(object='NMFfitX'),
+ function(object, ...){
+ # call the method on the best fit
+ basismap(minfit(object), ...)
+ }
+)
+
+#' Plots a heatmap of the coefficient matrix of the best fit in \code{object}.
+#'
+#' This method adds:
+#' \itemize{
+#' \item an extra special column annotation track for multi-run NMF fits,
+#' \code{'consensus:'}, that shows the consensus cluster associated to each sample.
+#' \item a column sorting schema \code{'consensus'} that can be passed
+#' to argument \code{Colv} and orders the columns using the hierarchical clustering of the
+#' consensus matrix with average linkage, as returned by \code{\link{consensushc}(object)}.
+#' This is also the ordering that is used by default for the heatmap of the consensus matrix
+#' as ploted by \code{\link{consensusmap}}.
+#' }
+setMethod('coefmap', signature(object='NMFfitX'),
+ function(object
+ , Colv=TRUE
+ , annRow=NA, annCol=NA
+ , tracks=c('basis', 'consensus:')
+ , ...){
+
+ x <- minfit(object)
+
+ # process annotation tracks
+ ptracks <- process_tracks(x, tracks, annRow, annCol)
+ annRow <- ptracks$row
+ annCol <- ptracks$col
+ # set special annotation handler
+ specialAnnotation(2L, 'consensus', function() predict(object, what='consensus'))
+ # row track handler is added in coefmap,NMF
+ #
+
+ ## process ordering
+ if( isString(Colv) ){
+ if( Colv %in% c('consensus', 'cmap') )
+ Colv <- consensushc(object, 'consensus')
+ }
+ ##
+ # call the method on the best fit
+ coefmap(x, ..., Colv=Colv, annRow=annRow, annCol=annCol, tracks=NA)
+ }
+)
+
+#' Cophenetic Correlation Coefficient
+#'
+#' The function \code{cophcor} computes the cophenetic correlation coefficient
+#' from consensus matrix \code{object}, e.g. as obtained from multiple NMF runs.
+#'
+#' The cophenetic correlation coeffificient is based on the consensus matrix
+#' (i.e. the average of connectivity matrices) and was proposed by
+#' \cite{Brunet2004} to measure the stability of the clusters obtained from NMF.
+#'
+#' It is defined as the Pearson correlation between the samples' distances
+#' induced by the consensus matrix (seen as a similarity matrix) and their
+#' cophenetic distances from a hierachical clustering based on these very
+#' distances (by default an average linkage is used).
+#' See \cite{Brunet2004}.
+#'
+#' @param object an object from which is extracted a consensus matrix.
+#' @param ... extra arguments to allow extension and passed to subsequent calls.
+#'
+#' @inline
+#' @seealso \code{\link{cophenetic}}
+#' @export
+setGeneric('cophcor', function(object, ...) standardGeneric('cophcor') )
+#' Workhorse method for matrices.
+#'
+#' @param linkage linkage method used in the hierarchical clustering.
+#' It is passed to \code{\link{hclust}}.
+#'
+setMethod('cophcor', signature(object='matrix'),
+ function(object, linkage='average'){
+
+ # check for empty matrix
+ if( nrow(object)==0 || ncol(object)==0 )
+ {
+ warning("NMF::cophcor - NA produced [input matrix is of dimension ", nrow(object), "x", ncol(object), "]"
+ , call.=FALSE)
+ return(NA)
+ }
+
+ # safe-guard for diagonal matrix: to prevent error in 'cor'
+ if( all(object[upper.tri(object)]==0) && all(diag(object)==object[1,1]) )
+ return(1)
+ # convert consensus matrix into dissimilarities
+ d.consensus <- as.dist(1 - object)
+ # compute cophenetic distance based on these dissimilarities
+ hc <- hclust(d.consensus, method=linkage)
+ d.coph <- cophenetic(hc)
+
+ # return correlation between the two distances
+ res <- cor(d.consensus, d.coph, method='pearson')
+ return(res)
+ }
+)
+#' Computes the cophenetic correlation coefficient on the consensus matrix
+#' of \code{object}.
+#' All arguments in \code{...} are passed to the method \code{cophcor,matrix}.
+setMethod('cophcor', signature(object='NMFfitX'),
+ function(object, ...){
+ # compute the consensus matrix
+ C <- consensus(object)
+
+ return( cophcor(C, ...))
+ }
+)
+
+# TODO: uncomment this and make it compute the mean or best rss
+#setMethod('rss', 'NMFfitXn',
+# function(object, target, ...){
+# rss(fit(object, ...), target)
+# }
+#)
+
diff --git a/R/NMFStrategy-class.R b/R/NMFStrategy-class.R
new file mode 100644
index 0000000..3873061
--- /dev/null
+++ b/R/NMFStrategy-class.R
@@ -0,0 +1,419 @@
+# S4 class for NMG algorithms
+#
+# Author: Renaud Gaujoux
+###############################################################################
+
+
+#' @include algorithmic.R
+#' @include NMFSet-class.R
+NULL
+
+#' Generic Strategy Class
+#'
+#' This class defines a common interface for generic algorithm strategies
+#' (e.g., \code{\linkS4class{NMFStrategy}}).
+#'
+#' @slot name character string giving the name of the algorithm
+#' @slot package name of the package that defined the strategy.
+#' @slot defaults default values for some of the algorithm's arguments.
+#'
+#' @keywords internal
+setClass('Strategy'
+ , contains = 'VIRTUAL'
+ , representation = representation(
+ name = 'character' # the strategy name
+ , package = 'character' # the package that defines the strategy
+ , defaults = 'list'
+ )
+ , prototype = prototype(
+ package = character()
+ , name = character()
+ )
+ , validity=function(object){
+
+ # slot 'name' must be a non-empty character string
+ obj <- name(object)
+ if( !length(obj) || (length(obj)>1L || obj=='') )
+ return(str_c("Slot 'name' must be a single non-empty character string [", obj, ']'))
+ TRUE
+ }
+)
+
+#' Accessing Strategy Names
+#'
+#' \code{name} and \code{name<-} gets and sets the name associated with an object.
+#' In the case of \code{Strategy} objects it is the the name of the algorithm.
+#'
+#' @param object an R object with a defined \code{name} method
+#' @param ... extra arguments to allow extension
+#' @param value replacement value
+#'
+#' @export
+#' @inline
+#' @rdname Strategy-class
+setGeneric('name', function(object, ...) standardGeneric('name'))
+#' Returns the name of an algorithm
+#' @param all a logical that indicates if all the names associated with a strategy
+#' should be returned (\code{TRUE}), or only the first (primary) one (\code{FALSE}).
+setMethod('name', signature(object='Strategy'),
+ function(object, all=FALSE){
+ n <- slot(object, 'name')
+ if( length(n) && !all ) n[1L] else n
+ }
+)
+#' @export
+#' @inline
+#' @rdname Strategy-class
+setGeneric('name<-', function(object, ..., value) standardGeneric('name<-'))
+#' Sets the name(s) of an NMF algorithm
+setReplaceMethod('name', signature(object='Strategy', value='character'),
+ function(object, value){
+ slot(object, 'name') <- value
+ validObject(object)
+ object
+ }
+)
+
+defaultArgument <- function(name, object, value, force=FALSE){
+
+ # taken from methods::hasArg
+ aname <- as.character(substitute(name))
+ miss <- eval(substitute(missing(name)), sys.frame(sys.parent()))
+ defaults <- attr(object, 'defaults')
+
+ if( !miss && !force ) eval(substitute(name), sys.frame(sys.parent()))
+ else if( aname %in% names(defaults) ) defaults[[aname]]
+ else value
+}
+
+#' Virtual Interface for NMF Algorithms
+#'
+#' This class partially implements the generic interface defined for general
+#' algorithms defined in the \pkg{NMF} package (see \code{\link{algorithmic-NMF}}).
+#'
+#' @slot objective the objective function associated with the algorithm (Frobenius, Kullback-Leibler, etc...).
+#' It is either an access key of a registered objective function or a function definition.
+#' In the latter case, the given function must have the following signature \code{(x="NMF", y="matrix")}
+#' and return a nonnegative real value.
+#'
+#' @slot model a character string giving either the (sub)class name of the NMF-class instance used
+#' and returned by the strategy, or a function name.
+#'
+#' @slot mixed a logical that indicates if the algorithm works on mixed-sign data.
+#'
+#' @keywords internal
+setClass('NMFStrategy'
+ , representation(
+ objective = '.functionSlot' # the objective function used to compute the error (defined by name or function)
+ , model = 'character' # NMF model to use
+ , mixed = 'logical' # can the input data be negative?
+ )
+ , prototype=prototype(objective='euclidean', model='NMFstd', mixed=FALSE)
+ , validity=function(object){
+
+ # slot 'objective' must either be a non-empty character string or a function
+ obj <- objective(object)
+ if( is.character(obj) && obj == '' )
+ return("Slot 'objective' must either be a non-empty character string or a function definition.")
+
+ # slot 'model' must be the name of a class that extends class 'NMF'
+ obj <- modelname(object)
+ if( !is.character(obj) )
+ return("Slot 'model' must be a character vector")
+ if( any(inv <- !sapply(obj, isNMFclass)) )
+ return(paste("Slot 'model' must contain only names of a class that extends class 'NMF' [failure on class(es) "
+ , paste( paste("'", obj[inv], "'", sep=''), collapse=', ')
+ ,"]"
+ , sep=''))
+
+ # slot 'mixed' must be a single logical
+ obj <- slot(object, 'mixed')
+ if( length(obj) != 1 )
+ return( paste("Slot 'mixed' must be a single logical [length=", length(obj), "]", sep='') )
+ }
+ , contains = c('VIRTUAL', 'Strategy')
+)
+
+#' @export
+#' @rdname NMFStrategy-class
+setMethod('show', 'NMFStrategy',
+ function(object){
+ cat('<object of class: ', class(object), ">\n", sep='')
+ cat(" name: ", name(object), " [", packageSlot(object), "]\n", sep='')
+ svalue <- objective(object)
+ svalue <- if( is.function(svalue) ) str_args(svalue, exdent=10) else paste("'", svalue,"'", sep='')
+ cat(" objective:", svalue, "\n")
+ cat(" model:", modelname(object), "\n")
+ if( length(object at defaults) > 0L ){
+ cat(" defaults:", str_desc(object at defaults, exdent=10L), "\n")
+ }
+ return(invisible())
+ }
+)
+
+# Coerce method for 'NMFStrategy' objects into 'character': give the main name
+setAs('NMFStrategy', 'character'
+ , def = function(from) name(from)
+)
+
+#' Factory Method for NMFStrategy Objects
+#'
+#' Creates NMFStrategy objects that wraps implementation of NMF algorithms into
+#' a unified interface.
+#'
+#' @param name name/key of an NMF algorithm.
+#' @param method definition of the algorithm
+#' @param ... extra arguments passed to \code{\link{new}}.
+#'
+#' @export
+#' @inline
+setGeneric('NMFStrategy', function(name, method, ...) standardGeneric('NMFStrategy') )
+#' Creates an \code{NMFStrategyFunction} object that wraps the function \code{method}
+#' into a unified interface.
+#'
+#' \code{method} must be a function with signature \code{(y="matrix", x="NMFfit", ...)},
+#' and return an object of class \code{\linkS4class{NMFfit}}.
+setMethod('NMFStrategy', signature(name='character', method='function'),
+ function(name, method, ...){
+
+ # build a NMFStrategyFunction object on the fly to wrap function 'method'
+ NMFStrategy(name=name, algorithm=method, ...)
+
+ }
+)
+
+#' Creates an \code{NMFStrategy} object based on a template object (Constructor-Copy).
+setMethod('NMFStrategy', signature(name='character', method='NMFStrategy'),
+ function(name, method, ...){
+
+ package <- topns_name()
+ # build an NMFStrategy object based on template object
+ strategy <- new(class(method), method, name=name, ..., package=package)
+
+ # valid the new strategy
+ validObject(strategy)
+
+ # add trace of inheritance from parent NMF algorithm
+ attr(strategy, 'parent') <- name(method)[1]
+
+ # return new object
+ strategy
+ }
+)
+
+#' Creates an \code{NMFStrategy} based on a template object (Constructor-Copy),
+#' in particular it uses the \strong{same} name.
+setMethod('NMFStrategy', signature(name='NMFStrategy', method='missing'),
+ function(name, method, ...){
+
+ # do not change the object if single argument
+ if( nargs() == 1L ) return(name)
+
+ # use the name as a key
+ # NB: need special trick to avoid conflict between argument and function
+ mname <- match.fun('name')(name)
+
+ NMFStrategy(name=mname, method=name, ...)
+ }
+)
+
+#' Creates an \code{NMFStrategy} based on a registered NMF algorithm that is used
+#' as a template (Constructor-Copy), in particular it uses the \strong{same} name.
+#'
+#' It is a shortcut for \code{NMFStrategy(nmfAlgorithm(method, exact=TRUE), ...)}.
+setMethod('NMFStrategy', signature(name='missing', method='character'),
+ function(name, method, ...){
+ NMFStrategy(nmfAlgorithm(method, exact=TRUE), ...)
+ }
+)
+
+
+#' Creates an \code{NMFStrategy} based on a template object (Constructor-Copy)
+#' but using a randomly generated name.
+setMethod('NMFStrategy', signature(name='NULL', method='NMFStrategy'),
+ function(name, method, ...){
+
+ # use the name as a key
+ # NB: need special trick to avoid conflict between argument and function
+ mname <- match.fun('name')(method)
+ mname <- basename(tempfile(str_c(mname, '_')))
+
+ NMFStrategy(name=mname, method=method, ...)
+ }
+)
+
+#' Creates an \code{NMFStrategy} based on a registered NMF algorithm that is used
+#' as a template.
+setMethod('NMFStrategy', signature(name='character', method='character'),
+ function(name, method, ...){
+ NMFStrategy(name=name, method=nmfAlgorithm(method, exact=TRUE), ...)
+ }
+)
+#' Creates an \code{NMFStrategy} based on a registered NMF algorithm (Constructor-Copy)
+#' using a randomly generated name.
+#'
+#' It is a shortcut for \code{NMFStrategy(NULL, nmfAlgorithm(method), ...)}.
+setMethod('NMFStrategy', signature(name='NULL', method='character'),
+ function(name, method, ...){
+ NMFStrategy(NULL, method=nmfAlgorithm(method, exact=TRUE), ...)
+ }
+)
+#' Creates an NMFStrategy, determining its type from the extra arguments passed
+#' in \code{...}: if there is an argument named \code{Update} then an
+#' \code{NMFStrategyIterative} is created, or if there is an argument
+#' named \code{algorithm} then an \code{NMFStrategyFunction} is created.
+#' Calls other than these generates an error.
+#'
+setMethod('NMFStrategy', signature(name='character', method='missing'),
+ function(name, method, ...){
+
+ package <- topns_name()
+ # check iterative strategy
+ if( hasArg2('Update') ){ # create a new NMFStrategyIterative object
+ new('NMFStrategyIterative', name=name, ..., package=package)
+ }else if( hasArg2('mcode') ){
+ new('NMFStrategyOctave', name=name, ..., package=package)
+ }else if( hasArg2('algorithm') ){
+ new('NMFStrategyFunction', name=name, ..., package=package)
+ }else{
+ stop('NMFStrategy - Could not infer the type of NMF strategy to instantiate.')
+ }
+
+ }
+)
+
+#' Pure virtual method defined for all NMF algorithms to ensure
+#' that a method \code{run} is defined by sub-classes of \code{NMFStrategy}.
+#'
+#' It throws an error if called directly.
+#' @rdname NMFStrategy
+setMethod('run', signature(object='NMFStrategy', y='matrix', x='NMFfit'),
+ function(object, y, x, ...){
+ stop("NMFStrategy::run is a pure virtual method that should be overloaded in class '", class(object),"'.")
+ }
+)
+#' Method to run an NMF algorithm directly starting from a given NMF model.
+#' @rdname NMFStrategy
+setMethod('run', signature(object='NMFStrategy', y='matrix', x='NMF'),
+ function(object, y, x, ...){
+ run(object, y, NMFfit(fit=x, seed='none', method=name(object)), ...)
+ }
+)
+
+#' Computes the value of the objective function between the estimate \code{x}
+#' and the target \code{y}.
+#'
+#' @param x an NMF model that estimates \code{y}.
+#'
+#' @inline
+setMethod('deviance', 'NMFStrategy',
+ function(object, x, y, ...){
+
+ obj.fun <- slot(object, 'objective')
+
+ # return the distance computed using the strategy's objective function
+ if( !is.function(obj.fun) )
+ deviance(x, y, method=obj.fun, ...)
+ else # directly compute the objective function
+ obj.fun(x, y, ...)
+
+ }
+)
+
+#' Gets the objective function associated with an NMF algorithm.
+#'
+#' It is used in \code{\link[=deviance,NMFStrategy-method]{deviance}}
+#' to compute the objective value for an NMF model with respect to
+#' a given target matrix.
+#'
+#' @export
+#' @rdname NMFStrategy-class
+setMethod('objective', 'NMFStrategy',
+ function(object){
+ slot(object, 'objective')
+ }
+)
+#' Sets the objective function associated with an NMF algorithm, with a character string
+#' that must be a registered objective function.
+#' @export
+#' @rdname NMFStrategy-class
+setReplaceMethod('objective', signature(object='NMFStrategy', value='character'),
+ function(object, value){
+ #TODO: test for the existence of objective method
+ slot(object, 'objective') <- value
+ validObject(object)
+ object
+ }
+)
+#' Sets the objective function associated with an NMF algorithm, with a function
+#' that computes the approximation error between an NMF model and a target matrix.
+#' @export
+#' @rdname NMFStrategy-class
+setReplaceMethod('objective', signature(object='NMFStrategy', value='function'),
+ function(object, value){
+ slot(object, 'objective') <- value
+ validObject(object)
+ object
+ }
+)
+
+#' Returns the model(s) that an NMF algorithm can fit.
+#'
+#' @examples
+#' # get the type of model(s) associated with an NMF algorithm
+#' modelname( nmfAlgorithm('brunet') )
+#' modelname( nmfAlgorithm('nsNMF') )
+#' modelname( nmfAlgorithm('offset') )
+#'
+setMethod('modelname', signature(object='NMFStrategy'),
+ function(object){
+ slot(object, 'model')
+ }
+)
+#' \code{is.mixed} tells if an NMF algorithm works on mixed-sign data.
+#' @export
+#' @rdname NMFStrategy-class
+is.mixed <- function(object){
+ return( slot(object, 'mixed') )
+}
+
+#' Showing Arguments of NMF Algorithms
+#'
+#' This function returns the extra arguments that can be passed
+#' to a given NMF algorithm in call to \code{\link{nmf}}.
+#'
+#' @param x algorithm specification
+#' @param ... extra argument to allow extension
+#'
+#' @export
+nmfFormals <- function(x, ...){
+ UseMethod('nmfFormals')
+}
+
+#' @S3method nmfFormals character
+nmfFormals.character <- function(x, ...){
+ s <- nmfAlgorithm(x)
+ nmfFormals(s, ...)
+}
+
+#' @S3method nmfFormals NMFStrategy
+nmfFormals.NMFStrategy <- function(x, ...){
+ m <- getMethod('run', signature(object='NMFStrategy', y='matrix', x='NMFfit'))
+ args <- allFormals(m)
+ # prepend registered default arguments
+ expand_list(x at defaults, args)
+}
+
+#' \code{nmfArgs} is a shortcut for \code{args(nmfWrapper(x))}, to
+#' display the arguments of a given NMF algorithm.
+#'
+#' @rdname nmfFormals
+#' @export
+#' @examples
+#'
+#' # show arguments of an NMF algorithm
+#' nmfArgs('brunet')
+#' nmfArgs('snmf/r')
+nmfArgs <- function(x){
+ args(nmfWrapper(x))
+}
diff --git a/R/NMFStrategyFunction-class.R b/R/NMFStrategyFunction-class.R
new file mode 100644
index 0000000..e194546
--- /dev/null
+++ b/R/NMFStrategyFunction-class.R
@@ -0,0 +1,69 @@
+#' @include NMFStrategy-class.R
+NULL
+
+#' Interface for Single Function NMF Strategies
+#'
+#' This class implements the virtual interface \code{\link{NMFStrategy}} for
+#' NMF algorithms that are implemented by a single workhorse R function.
+#'
+#' @slot algorithm a function that implements an NMF algorithm.
+#' It must have signature \code{(y='matrix', x='NMFfit')}, where \code{y} is the
+#' target matrix to approximate and \code{x} is the NMF model assumed to be
+#' seeded with an appropriate initial value -- as it is done internally by
+#' function \code{\link{nmf}}.
+#'
+#' Note that argument names currently do not matter, but it is recommended to
+#' name them as specified above.
+#'
+setClass('NMFStrategyFunction'
+ , representation(
+ algorithm = 'function' # the function that implements the algorithm
+ )
+ , contains = 'NMFStrategy'
+)
+#' Runs the NMF algorithms implemented by the single R function -- and stored in slot \code{'algorithm'}
+#' of \code{object}, on the data object \code{y}, using \code{x} as starting point.
+#' It is equivalent to calling \code{object@@algorithm(y, x, ...)}.
+#'
+#' This method is usually not called directly, but only via the function \code{\link{nmf}}, which
+#' takes care of many other details such as seeding the computation, handling RNG settings, or setting up
+#' parallelisation.
+#'
+#' @rdname NMFStrategy
+setMethod('run', signature(object='NMFStrategyFunction', y='matrix', x='NMFfit'),
+ function(object, y, x, ...){
+ if( !is.function(fun <- algorithm(object)) )
+ stop("NMFStrategyFunction '", name(object), "': algorithm is not defined.")
+
+ # run the function that defines the algorithm and return the result
+ fun(y, x, ...)
+ }
+)
+
+#' @S3method nmfFormals NMFStrategyFunction
+nmfFormals.NMFStrategyFunction <- function(x, ...){
+ args <- formals(x at algorithm)
+ args[-(1:2)]
+}
+
+
+#' Returns the single R function that implements the NMF algorithm -- as stored in
+#' slot \code{algorithm}.
+setMethod('algorithm', signature(object='NMFStrategyFunction'),
+ function(object){
+ slot(object, 'algorithm')
+ }
+)
+#setReplaceMethod('algorithm', signature(object='NMFStrategyFunction', value='character'),
+# function(object, value){
+# slot(object, 'algorithm') <- value
+# object
+# }
+#)
+#' Sets the function that implements the NMF algorithm, stored in slot \code{algorithm}.
+setReplaceMethod('algorithm', signature(object='NMFStrategyFunction', value='function'),
+ function(object, value){
+ slot(object, 'algorithm') <- value
+ object
+ }
+)
diff --git a/R/NMFStrategyIterative-class.R b/R/NMFStrategyIterative-class.R
new file mode 100644
index 0000000..6704ec9
--- /dev/null
+++ b/R/NMFStrategyIterative-class.R
@@ -0,0 +1,960 @@
+#' @include NMFStrategy-class.R
+#' @include NMFfit-class.R
+NULL
+
+# Define union class for generalised function slots, e.g., slot 'NMFStrategyIterative::Stop'
+setClassUnion('.GfunctionSlotNULL', c('character', 'integer', 'numeric', 'function', 'NULL'))
+
+#' Interface for Algorithms: Implementation for Iterative NMF Algorithms
+#'
+#' @description
+#' This class provides a specific implementation for the generic function \code{run}
+#' -- concretising the virtual interface class \code{\linkS4class{NMFStrategy}},
+#' for NMF algorithms that conform to the following iterative schema (starred numbers
+#' indicate mandatory steps):
+#'
+#' \itemize{
+#' \item 1. Initialisation
+#' \item 2*. Update the model at each iteration
+#' \item 3. Stop if some criterion is satisfied
+#' \item 4. Wrap up
+#' }
+#'
+#' This schema could possibly apply to all NMF algorithms, since these are essentially optimisation algorithms,
+#' almost all of which use iterative methods to approximate a solution of the optimisation problem.
+#' The main advantage is that it allows to implement updates and stopping criterion separately, and combine them
+#' in different ways.
+#' In particular, many NMF algorithms are based on multiplicative updates, following the approach from
+#' \cite{Lee2001}, which are specially suitable to be cast into this simple schema.
+#'
+#' @slot onInit optional function that performs some initialisation or pre-processing on
+#' the model, before starting the iteration loop.
+#' @slot Update mandatory function that implement the update step, which computes new values for the model, based on its
+#' previous value.
+#' It is called at each iteration, until the stopping criterion is met or the maximum number of iteration is
+#' achieved.
+#' @slot Stop optional function that implements the stopping criterion.
+#' It is called \strong{before} each Update step.
+#' If not provided, the iterations are stopped after a fixed number of updates.
+#' @slot onReturn optional function that wraps up the result into an NMF object.
+#' It is called just before returning the
+#'
+setClass('NMFStrategyIterative'
+ , representation(
+ onInit = '.functionSlotNULL',
+ Update = '.functionSlot', # update method
+ Stop = '.GfunctionSlotNULL', # method called just after the update
+ onReturn = '.functionSlotNULL' # method called just before returning the resulting NMF object
+ )
+ , prototype=prototype(
+ onInit = NULL
+ , Update = ''
+ , Stop = NULL
+ , onReturn = NULL
+ )
+ , contains = 'NMFStrategy'
+ , validity = function(object){
+
+ if( is.character(object at Update) && object at Update == '' )
+ return("Slot 'Update' is required")
+
+ # check the arguments of methods 'Update' and 'Stop'
+ # (except for the 3 mandatory ones)
+ n.update <- names(formals(object at Update))
+
+ # at least 3 arguments for 'Update'
+ if( length(n.update) < 3 ){
+ return(str_c("Invalid 'Update' method - must have at least 3 arguments: ",
+ "current iteration number [i], ",
+ "target matrix [y], ",
+ "current NMF model iterate [x]"))
+ }
+
+ n.update <- n.update[-seq(3)]
+ # argument '...' must be present in method 'Update'
+ if( !is.element('...', n.update) )
+ return("Invalid 'Update' method: must have argument '...' (even if not used)")
+
+ # at least 3 arguments for 'Stop'
+ if( !is.null(object at Stop) ){
+
+ # retrieve the stopping criterion and check its intrinsic validity
+ .stop <- tryCatch( NMFStop(object at Stop, check=TRUE),
+ error = function(e) return(message(e)))
+
+ # Update and Stop methods cannot have overlapping arguments
+ n.stop <- names(formals(.stop))
+ overlap <- intersect(n.update, n.stop)
+ overlap <- overlap[which(overlap!='...')]
+ if( length(overlap) > 0 ){
+ return(str_c("Invalid 'Update' and 'Stop' methods: conflicting arguments ",
+ str_out(overlap, Inf)))
+ }
+ }
+
+ TRUE
+ }
+)
+
+
+#' Show method for objects of class \code{NMFStrategyIterative}
+#' @export
+setMethod('show', 'NMFStrategyIterative',
+ function(object){
+
+ #cat('<object of class: NMFStrategyIterative>')
+ callNextMethod()
+ cat(" <Iterative schema>\n")
+ # go through the slots
+ s.list <- names(getSlots('NMFStrategyIterative'))
+ s.list <- setdiff(s.list, names(getSlots('NMFStrategy')))
+ #s.list <- s.list[s.list=='ANY']
+# s.list <- c('Update', 'Stop', 'WrapNMF')
+ out <-
+ sapply(s.list, function(sname){
+ svalue <- slot(object,sname)
+ svalue <-
+ if( is.function(svalue) ) {
+ str_args(svalue, exdent=12)
+ } else if( is.null(svalue) ){
+ 'none'
+ } else {
+ paste("'", svalue,"'", sep='')
+ }
+ str_c(sname, ": ", svalue)
+ })
+ cat(str_c(' ', out, collapse='\n'), "\n", sep='')
+ return(invisible())
+ }
+)
+###% This class is an auxiliary class that defines the strategy's methods by directly callable functions.
+setClass('NMFStrategyIterativeX'
+ , contains = 'NMFStrategyIterative'
+ , representation = representation(
+ workspace = 'environment' # workspace to use persistent variables accross methods
+ )
+)
+
+
+###% Creates a NMFStrategyIterativeX object from a NMFStrategyIterative object.
+xifyStrategy <- function(strategy, workspace=new.env(emptyenv())){
+
+ # do nothing if already executable
+ if( is(strategy, 'NMFStrategyIterativeX') ) return(strategy)
+
+ # first check the strategy's validity
+ if( is.character(err <- validObject(strategy, test=TRUE)) ){
+ stop("Invalid strategy definition:\n\t- ", err)
+ }
+
+ # intanciate the NMFStrategyIterativeX, creating the strategy's workspace
+ strategyX <- new('NMFStrategyIterativeX', strategy, workspace=workspace)
+
+ # define auxiliary function to preload the 'function' slots in class NMFStrategyIterativeX
+ preload.slot <- function(strategy, sname, default){
+
+ # get the content of the slot
+ svalue <- slot(strategy,sname)
+
+ # if the slot is valid (i.e. it's a non-empty character string), then process the name into a valid function
+ fun <-
+ if( is.null(svalue) && !missing(default) ) default
+ else if( sname == 'Stop' ) NMFStop(svalue)
+ else if( is.character(svalue) && nchar(svalue) > 0 ){
+ # set the slot with the executable version of the function
+ getFunction(svalue)
+ }else if( is.function(svalue) ) svalue
+ else
+ stop("NMFStrategyIterativeX - could not pre-load slot '", sname, "'")
+
+ # return the loaded function
+ fun
+ }
+
+ # preload the function slots
+ slot(strategyX, 'Update') <- preload.slot(strategyX, 'Update')
+ slot(strategyX, 'Stop') <- preload.slot(strategyX, 'Stop', function(strategy, i, target, data, ...){FALSE})
+ slot(strategyX, 'onReturn') <- preload.slot(strategyX, 'onReturn', identity)
+
+ # load the objective function
+ objective(strategyX) <- nmfDistance(objective(strategy))
+
+ # valid the preloaded object
+ validObject(strategyX)
+
+ # return the executable strategy
+ strategyX
+}
+
+#
+#setGeneric('Update', function(object, v, ...) standardGeneric('Update') )
+#setMethod('Update', signature(object='NMFStrategyIterative', v='matrix'), function(object, v, ...){ object at data <- object at Update(v, object at data, ...) })
+#
+#setGeneric('Stop', function(object, i) standardGeneric('Stop') )
+#setMethod('Stop', signature(object='NMFStrategyIterative', i='integer'), function(object, i){ object at Stop(i, object at data) })
+#
+#setGeneric('WrapNMF', function(object) standardGeneric('WrapNMF') )
+#setMethod('WrapNMF', signature(object='NMFStrategyIterative'), function(object){ object at WrapNMF(object at data) })
+
+###% Hook to initialize built-in iterative methods when the package is loaded
+
+
+###% Hook to initialize old R version built-in iterative methods
+
+#' Get/Set a Static Variable in NMF Algorithms
+#'
+#' @description
+#' This function is used in iterative NMF algorithms to manage variables
+#' stored in a local workspace, that are accessible to all functions that
+#' define the iterative schema described in \code{\linkS4class{NMFStrategyIterative}}.
+#'
+#' It is specially useful for computing stopping criteria, which often require model data from
+#' different iterations.
+#'
+#' @param name Name of the static variable (as a single character string)
+#' @param value New value of the static variable
+#' @param init a logical used when a \code{value} is provided, that specifies
+#' if the variable should be set to the new value only if it does not exist yet
+#' (\code{init=TRUE}).
+#' @return The value of the static variable
+#' @export
+staticVar <- local({
+
+ .Workspace <- NULL
+ function(name, value, init=FALSE){
+
+ # return last workspace
+ if( missing(name) ) return(.Workspace)
+ else if( is.null(name) ){ # reset workspace
+ .Workspace <<- NULL
+ return()
+ } else if( is.environment(name) ){ # setup up static environment
+ nmf.debug('Strategy Workspace', "initialize static workspace: ", capture.output(.Workspace), "=", capture.output(name))
+ .Workspace <<- name
+ }else if( isString(name) && is.environment(.Workspace) ){
+ if( missing(value) ){
+ get(name, envir=.Workspace, inherits=FALSE)
+ }else{
+ if( !init || !exists(name, envir=.Workspace, inherits=FALSE) )
+ {
+ if( init ) nmf.debug('Strategy Workspace', "initialize variable '", name, "'")
+ assign(name, value, envir=.Workspace)
+ }
+ # return current value
+ get(name, envir=.Workspace, inherits=FALSE)
+ }
+ }else{
+ stop("Invalid NMF workspace query: .Workspace=", class(.Workspace), '| name=', name
+ , if( !missing(value) ) paste0(' | value=', class(value)))
+ }
+
+ }
+})
+
+#' Runs an NMF iterative algorithm on a target matrix \code{y}.
+#'
+#' @param .stop specification of a stopping criterion, that is used instead of the
+#' one associated to the NMF algorithm.
+#' It may be specified as:
+#' \itemize{
+#' \item the access key of a registered stopping criterion;
+#' \item a single integer that specifies the exact number of iterations to perform, which will
+#' be honoured unless a lower value is explicitly passed in argument \code{maxIter}.
+#' \item a single numeric value that specifies the stationnarity threshold for the
+#' objective function, used in with \code{\link{nmf.stop.stationary}};
+#' \item a function with signature \code{(object="NMFStrategy", i="integer", y="matrix", x="NMF", ...)},
+#' where \code{object} is the \code{NMFStrategy} object that describes the algorithm being run,
+#' \code{i} is the current iteration, \code{y} is the target matrix and \code{x} is the current value of
+#' the NMF model.
+#' }
+#' @param maxIter maximum number of iterations to perform.
+#'
+#' @rdname NMFStrategy
+setMethod('run', signature(object='NMFStrategyIterative', y='matrix', x='NMFfit'),
+ function(object, y, x, .stop=NULL, maxIter = nmf.getOption('maxIter') %||% 2000L, ...){
+
+ method <- object
+ # override the stop method on runtime
+ if( !is.null(.stop) ){
+ method at Stop <- NMFStop(.stop)
+ # honour maxIter unless .stop is an integer and maxIter is not passed
+ # either directly or from initial call
+ # NB: maxIter may be not missing in the call to run() due to the application
+ # of default arguments from the Strategy within nmf(), in which case one does not
+ # want to honour it, since it is effectively missing in the original call.
+ if( is.integer(.stop) && (missing(maxIter) || !('maxIter' %in% names(x at call))) )
+ maxIter <- .stop[1]
+ }
+
+ # debug object in debug mode
+ if( nmf.getOption('debug') ) show(method)
+
+ #Vc# Define local workspace for static variables
+ # this function can be called in the methods to get/set/initialize
+ # variables that are persistent within the strategy's workspace
+ .Workspace <- new.env()
+ staticVar(.Workspace)
+ on.exit( staticVar(NULL) )
+
+ # runtime resolution of the strategy's functions by their names if necessary
+ strategyX = xifyStrategy(method, .Workspace)
+ run(strategyX, y, x, maxIter=maxIter, ...)
+})
+
+#' @rdname NMFStrategy
+setMethod('run', signature(object='NMFStrategyIterativeX', y='matrix', x='NMFfit'),
+ function(object, y, x, maxIter, ...){
+
+ strategy <- object
+ v <- y
+ seed <- x
+ #V!# NMFStrategyIterativeX::run
+
+ #Vc# Define workspace accessor function
+ # this function can be called in the methods to get/set/initialize
+ # variables that are persistent within the strategy's workspace
+# .Workspace <- strategy at workspace
+# assign('staticVar', function(name, value, init=FALSE){
+# if( missing(value) ){
+# get(name, envir=.Workspace, inherits=FALSE)
+# }else{
+# if( !init || !exists(name, envir=.Workspace, inherits=FALSE) )
+# {
+# if( init ) nmf.debug('Strategy Workspace', "initialize variable '", name, "'")
+# assign(name, value, envir=.Workspace)
+# }
+# }
+# }
+# , envir=.Workspace)
+
+ #Vc# initialize the strategy
+ # check validity of arguments if possible
+ method.args <- nmfFormals(strategy, runtime=TRUE)
+ internal.args <- method.args$internals
+ expected.args <- method.args$defaults
+ passed.args <- names(list(...))
+ forbidden.args <- is.element(passed.args, c(internal.args))
+ if( any(forbidden.args) ){
+ stop("NMF::run - Update/Stop method : formal argument(s) "
+ , paste( paste("'", passed.args[forbidden.args],"'", sep=''), collapse=', ')
+ , " already set internally.", call.=FALSE)
+ }
+ # !is.element('...', expected.args) &&
+ if( any(t <- !pmatch(passed.args, names(expected.args), nomatch=FALSE)) ){
+ stop("NMF::run - onInit/Update/Stop method for algorithm '", name(strategy),"': unused argument(s) "
+ , paste( paste("'", passed.args[t],"'", sep=''), collapse=', '), call.=FALSE)
+ }
+ # check for required arguments
+ required.args <- sapply(expected.args, function(x){ x <- as.character(x); length(x) == 1 && nchar(x) == 0 } )
+ required.args <- names(expected.args[required.args])
+ required.args <- required.args[required.args!='...']
+
+ if( any(t <- !pmatch(required.args, passed.args, nomatch=FALSE)) )
+ stop("NMF::run - Update/Stop method for algorithm '", name(strategy),"': missing required argument(s) "
+ , paste( paste("'", required.args[t],"'", sep=''), collapse=', '), call.=FALSE)
+
+ #Vc# Start iterations
+ nmfData <- seed
+ # cache verbose level
+ verbose <- verbose(nmfData)
+
+ # clone the object to allow the updates to work in place
+ if( verbose > 1L )
+ message("# Cloning NMF model seed ... ", appendLF=FALSE)
+ nmfFit <- clone(fit(nmfData))
+ if( verbose > 1L )
+ message("[", C.ptr(fit(nmfData)), " -> ", C.ptr(nmfFit), "]")
+
+ ## onInit
+ if( is.function(strategy at onInit) ){
+ if( verbose > 1L ) message("# Step 1 - onInit ... ", appendLF=TRUE)
+ nmfFit <- strategy at onInit(strategy, v, nmfFit, ...)
+ if( verbose > 1L ) message("OK")
+ }
+ ##
+
+ # pre-load slots
+ updateFun <- strategy at Update
+ stopFun <- strategy at Stop
+
+ showNIter.step <- 50L
+ showNIter <- verbose && maxIter >= showNIter.step
+ if( showNIter ){
+ ndIter <- nchar(as.character(maxIter))
+ itMsg <- paste0('Iterations: %', ndIter, 'i', "/", maxIter)
+ cat(itMsgBck <- sprintf(itMsg, 0))
+ itMsgBck <- nchar(itMsgBck)
+ }
+ i <- 0L
+ while( TRUE ){
+
+ #Vc# Stopping criteria
+ # check convergence (generally do not stop for i=0L, but only initialise static variables
+ stop.signal <- stopFun(strategy, i, v, nmfFit, ...)
+
+ # if the strategy ask for stopping, then stop the iteration
+ if( stop.signal || i >= maxIter ) break;
+
+ # increment i
+ i <- i+1L
+
+ if( showNIter && (i==1L || i %% showNIter.step == 0L) ){
+ cat(paste0(rep("\r", itMsgBck), sprintf(itMsg, i)))
+ }
+
+ #Vc# update the matrices
+ nmfFit <- updateFun(i, v, nmfFit, ...)
+
+ # every now and then track the error if required
+ nmfData <- trackError(nmfData, deviance(strategy, nmfFit, v, ...), niter=i)
+
+ }
+ if( showNIter ){
+ ended <- if( stop.signal ) 'converged' else 'stopped'
+ cat("\nDONE (", ended, " at ",i,'/', maxIter," iterations)\n", sep='')
+ }
+
+ # force to compute last error if not already done
+ nmfData <- trackError(nmfData, deviance(strategy, nmfFit, v, ...), niter=i, force=TRUE)
+
+ # store the fitted model
+ fit(nmfData) <- nmfFit
+
+ #Vc# wrap up
+ # let the strategy build the result
+ nmfData <- strategy at onReturn(nmfData)
+ if( !inherits(nmfData, 'NMFfit') ){
+ stop('NMFStrategyIterative[', name(strategy), ']::onReturn did not return a "NMF" instance [returned: "', class(nmfData), '"]')
+ }
+
+ # set the number of iterations performed
+ niter(nmfData) <- i
+
+ #return the result
+ nmf.debug('NMFStrategyIterativeX::run', 'Done')
+ invisible(nmfData)
+})
+
+
+#' @S3method nmfFormals NMFStrategyIterative
+nmfFormals.NMFStrategyIterative <- function(x, runtime=FALSE, ...){
+
+ strategy <- xifyStrategy(x)
+ # from run method
+ m <- getMethod('run', signature(object='NMFStrategyIterative', y='matrix', x='NMFfit'))
+ run.args <- allFormals(m)[-(1:3)]
+ # onInit
+ init.args <- if( is.function(strategy at onInit) ) formals(strategy at onInit)
+ # Update
+ update.args <- formals(strategy at Update)
+ # Stop
+ stop.args <- formals(strategy at Stop)
+ # spplit internals and
+ internal.args <- names(c(init.args[1:3], update.args[1:3], stop.args[1:4]))
+ expected.args <- c(init.args[-(1:3)], update.args[-(1:3)], stop.args[-(1:4)])
+
+ if( runtime ){
+ # prepend registered default arguments
+ expected.args <- expand_list(strategy at defaults, expected.args)
+ list(internal=internal.args, defaults=expected.args)
+ }else{
+ args <- c(run.args, expected.args)
+ # prepend registered default arguments
+ expand_list(strategy at defaults, args)
+ }
+}
+
+################################################################################################
+# INITIALIZATION METHODS
+################################################################################################
+
+################################################################################################
+# UPDATE METHODS
+################################################################################################
+
+#' NMF Multiplicative Updates for Kullback-Leibler Divergence
+#'
+#' Multiplicative updates from \cite{Lee2001} for standard Nonnegative Matrix Factorization
+#' models \eqn{V \approx W H}, where the distance between the target matrix and its NMF
+#' estimate is measured by the Kullback-Leibler divergence.
+#'
+#' \code{nmf_update.KL.w} and \code{nmf_update.KL.h} compute the updated basis and coefficient
+#' matrices respectively.
+#' They use a \emph{C++} implementation which is optimised for speed and memory usage.
+#'
+#' @details
+#' The coefficient matrix (\code{H}) is updated as follows:
+#' \deqn{
+#' H_{kj} \leftarrow H_{kj} \frac{\left( sum_i \frac{W_{ik} V_{ij}}{(WH)_{ij}} \right)}{ sum_i W_{ik} }.
+#' }{
+#' H_kj <- H_kj ( sum_i [ W_ik V_ij / (WH)_ij ] ) / ( sum_i W_ik )
+#' }
+#'
+#' These updates are used in built-in NMF algorithms \code{\link[=KL-nmf]{KL}} and
+#' \code{\link[=brunet-nmf]{brunet}}.
+#'
+#' @param v target matrix
+#' @param w current basis matrix
+#' @param h current coefficient matrix
+#' @param nbterms number of fixed basis terms
+#' @param ncterms number of fixed coefficient terms
+#' @param copy logical that indicates if the update should be made on the original
+#' matrix directly (\code{FALSE}) or on a copy (\code{TRUE} - default).
+#' With \code{copy=FALSE} the memory footprint is very small, and some speed-up may be
+#' achieved in the case of big matrices.
+#' However, greater care should be taken due the side effect.
+#' We recommend that only experienced users use \code{copy=TRUE}.
+#'
+#' @return a matrix of the same dimension as the input matrix to update
+#' (i.e. \code{w} or \code{h}).
+#' If \code{copy=FALSE}, the returned matrix uses the same memory as the input object.
+#'
+#' @author
+#' Update definitions by \cite{Lee2001}.
+#'
+#' C++ optimised implementation by Renaud Gaujoux.
+#'
+#' @rdname nmf_update_KL
+#' @aliases nmf_update.KL
+#' @export
+nmf_update.KL.h <- std.divergence.update.h <- function(v, w, h, nbterms=0L, ncterms=0L, copy=TRUE)
+{
+ .Call("divergence_update_H", v, w, h, nbterms, ncterms, copy, PACKAGE='NMF')
+}
+#' \code{nmf_update.KL.w_R} and \code{nmf_update.KL.h_R} implement the same updates
+#' in \emph{plain R}.
+#'
+#' @param wh already computed NMF estimate used to compute the denominator term.
+#'
+#' @rdname nmf_update_KL
+#' @export
+nmf_update.KL.h_R <- R_std.divergence.update.h <- function(v, w, h, wh=NULL)
+{
+ # compute WH if necessary
+ if( is.null(wh) ) wh <- w %*% h
+
+ # divergence-reducing NMF iterations
+ # H_au = H_au ( sum_i [ W_ia V_iu / (WH)_iu ] ) / ( sum_k W_ka ) -> each row of H is divided by a the corresponding colSum of W
+ h * crossprod(w, v / wh) / colSums(w)
+}
+
+#' @details
+#' The basis matrix (\code{W}) is updated as follows:
+#' \deqn{
+#' W_{ik} \leftarrow W_{ik} \frac{ sum_j [\frac{H_{kj} A_{ij}}{(WH)_{ij}} ] }{sum_j H_{kj} }
+#' }{
+#' W_ik <- W_ik ( sum_u [H_kl A_il / (WH)_il ] ) / ( sum_l H_kl )
+#' }
+#' @rdname nmf_update_KL
+#' @export
+nmf_update.KL.w <- std.divergence.update.w <- function(v, w, h, nbterms=0L, ncterms=0L, copy=TRUE)
+{
+ .Call("divergence_update_W", v, w, h, nbterms, ncterms, copy, PACKAGE='NMF')
+}
+#' @rdname nmf_update_KL
+#' @export
+nmf_update.KL.w_R <- R_std.divergence.update.w <- function(v, w, h, wh=NULL)
+{
+ # compute WH if necessary
+ if( is.null(wh) ) wh <- w %*% h
+
+ # W_ia = W_ia ( sum_u [H_au A_iu / (WH)_iu ] ) / ( sum_v H_av ) -> each column of W is divided by a the corresponding rowSum of H
+ #x2 <- matrix(rep(rowSums(h), nrow(w)), ncol=ncol(w), byrow=TRUE);
+ #w * tcrossprod(v / wh, h) / x2;
+ sweep(w * tcrossprod(v / wh, h), 2L, rowSums(h), "/", check.margin = FALSE) # optimize version?
+
+}
+
+
+
+#' NMF Multiplicative Updates for Euclidean Distance
+#'
+#' Multiplicative updates from \cite{Lee2001} for standard Nonnegative Matrix Factorization
+#' models \eqn{V \approx W H}, where the distance between the target matrix and its NMF
+#' estimate is measured by the -- euclidean -- Frobenius norm.
+#'
+#' \code{nmf_update.euclidean.w} and \code{nmf_update.euclidean.h} compute the updated basis and coefficient
+#' matrices respectively.
+#' They use a \emph{C++} implementation which is optimised for speed and memory usage.
+#'
+#' @details
+#' The coefficient matrix (\code{H}) is updated as follows:
+#' \deqn{
+#' H_{kj} \leftarrow \frac{\max(H_{kj} W^T V)_{kj}, \varepsilon) }{(W^T W H)_{kj} + \varepsilon}
+#' }{
+#' H_kj <- max(H_kj (W^T V)_kj, eps) / ( (W^T W H)_kj + eps )
+#' }
+#'
+#' These updates are used by the built-in NMF algorithms \code{\link[=Frobenius-nmf]{Frobenius}} and
+#' \code{\link[=lee-nmf]{lee}}.
+#'
+#' @inheritParams nmf_update.KL.h
+#' @param eps small numeric value used to ensure numeric stability, by shifting up
+#' entries from zero to this fixed value.
+#'
+#' @return a matrix of the same dimension as the input matrix to update
+#' (i.e. \code{w} or \code{h}).
+#' If \code{copy=FALSE}, the returned matrix uses the same memory as the input object.
+#'
+#' @author
+#' Update definitions by \cite{Lee2001}.
+#'
+#' C++ optimised implementation by Renaud Gaujoux.
+#'
+#' @rdname nmf_update_euclidean
+#' @aliases nmf_update.euclidean
+#' @export
+nmf_update.euclidean.h <- std.euclidean.update.h <-
+function(v, w, h, eps=10^-9, nbterms=0L, ncterms=0L, copy=TRUE){
+ .Call("euclidean_update_H", v, w, h, eps, nbterms, ncterms, copy, PACKAGE='NMF')
+}
+#' \code{nmf_update.euclidean.w_R} and \code{nmf_update.euclidean.h_R} implement the same updates
+#' in \emph{plain R}.
+#'
+#' @param wh already computed NMF estimate used to compute the denominator term.
+#'
+#' @rdname nmf_update_euclidean
+#' @export
+nmf_update.euclidean.h_R <- R_std.euclidean.update.h <- function(v, w, h, wh=NULL, eps=10^-9){
+ # compute WH if necessary
+ den <- if( is.null(wh) ) crossprod(w) %*% h
+ else{ t(w) %*% wh}
+
+ # H_au = H_au (W^T V)_au / (W^T W H)_au
+ pmax(h * crossprod(w,v),eps) / (den + eps);
+}
+
+#' @details
+#' The basis matrix (\code{W}) is updated as follows:
+#' \deqn{
+#' W_ik \leftarrow \frac{\max(W_ik (V H^T)_ik, \varepsilon) }{ (W H H^T)_ik + \varepsilon}
+#' }{
+#' W_ik <- max(W_ik (V H^T)_ik, eps) / ( (W H H^T)_ik + eps )
+#' }
+#'
+#' @param weight numeric vector of sample weights, e.g., used to normalise samples
+#' coming from multiple datasets.
+#' It must be of the same length as the number of samples/columns in \code{v}
+#' -- and \code{h}.
+#'
+#' @rdname nmf_update_euclidean
+#' @export
+nmf_update.euclidean.w <- std.euclidean.update.w <-
+function(v, w, h, eps=10^-9, nbterms=0L, ncterms=0L, weight=NULL, copy=TRUE){
+ .Call("euclidean_update_W", v, w, h, eps, weight, nbterms, ncterms, copy, PACKAGE='NMF')
+}
+#' @rdname nmf_update_euclidean
+#' @export
+nmf_update.euclidean.w_R <- R_std.euclidean.update.w <- function(v, w, h, wh=NULL, eps=10^-9){
+ # compute WH if necessary
+ den <- if( is.null(wh) ) w %*% tcrossprod(h)
+ else{ wh %*% t(h)}
+
+ # W_ia = W_ia (V H^T)_ia / (W H H^T)_ia and columns are rescaled after each iteration
+ pmax(w * tcrossprod(v, h), eps) / (den + eps);
+}
+
+
+################################################################################################
+# AFTER-UPDATE METHODS
+################################################################################################
+
+#' Stopping Criteria for NMF Iterative Strategies
+#'
+#' The function documented here implement stopping/convergence criteria
+#' commonly used in NMF algorithms.
+#'
+#' \code{NMFStop} acts as a factory method that creates stopping criterion functions
+#' from different types of values, which are subsequently used by
+#' \code{\linkS4class{NMFStrategyIterative}} objects to determine when to stop their
+#' iterative process.
+#'
+#' @details
+#' \code{NMFStop} can take the following values:
+#' \describe{
+#' \item{function}{ is returned unchanged, except when it has no arguments,
+#' in which case it assumed to be a generator, which is immediately called and should return
+#' a function that implements the actual stopping criterion;}
+#' \item{integer}{ the value is used to create a stopping criterion that stops at
+#' that exact number of iterations via \code{nmf.stop.iteration};}
+#' \item{numeric}{ the value is used to create a stopping criterion that stops when
+#' at that stationary threshold via \code{nmf.stop.threshold};}
+#' \item{character}{ must be a single string which must be an access key
+#' for registered criteria (currently available: \dQuote{connectivity} and \dQuote{stationary}),
+#' or the name of a function in the global environment or the namespace of the loading package.}
+#' }
+#'
+#' @param s specification of the stopping criterion.
+#' See section \emph{Details} for the supported formats and how they are processed.
+#' @param check logical that indicates if the validity of the stopping criterion
+#' function should be checked before returning it.
+#'
+#' @return a function that can be passed to argument \code{.stop} of function
+#' \code{\link{nmf}}, which is typically used when the algorith is implemented as
+#' an iterative strategy.
+#'
+#' @aliases stop-NMF
+#' @rdname stop-NMF
+#' @export
+NMFStop <- function(s, check=TRUE){
+
+ key <- s
+
+ fun <-
+ if( is.integer(key) ) nmf.stop.iteration(key)
+ else if( is.numeric(key) ) nmf.stop.threshold(key)
+ else if( is.function(key) ) key
+ else if( is.character(key) ){
+ # update .stop for back compatibility:
+ if( key == 'nmf.stop.consensus') key <- 'connectivity'
+
+ # first lookup for a `nmf.stop.*` function
+ key2 <- paste('nmf.stop.', key, sep='')
+ e <- pkgmaker::packageEnv()
+ sfun <- getFunction(key2, mustFind=FALSE, where = e)
+ if( is.null(sfun) ) # lookup for the function as such
+ sfun <- getFunction(key, mustFind = FALSE, where = e)
+ if( is.null(sfun) )
+ stop("Invalid key ['", key,"']: could not find functions '",key2, "' or '", key, "'")
+ sfun
+ }else if( identical(key, FALSE) ) # create a function that does not stop
+ function(strategy, i, target, data, ...){FALSE}
+ else
+ stop("Invalid key: should be a function, a character string or a single integer/numeric value. See ?NMFStop.")
+
+ # execute if generator (i.e. no arguments)
+ if( length(formals(fun)) == 0L ) fun <- fun()
+
+ # check validity if requested
+ if( check ){
+ n.stop <- names(formals(fun))
+ if( length(n.stop) < 4 ){
+ stop("Invalid 'Stop' method - must have at least 4 arguments: ",
+ "NMF strategy object [strategy], ",
+ "current iteration number [i], ",
+ "target matrix [y], ",
+ "current NMF model iterate [x]")
+ }
+
+ n.stop <- n.stop[-seq(4)]
+ # argument '...' must be present in method 'Stop'
+ if( !is.element('...', n.stop) )
+ stop("Invalid 'Stop' method: must have argument '...' (even if not used)")
+ }
+
+ # return function
+ fun
+}
+
+#' \code{nmf.stop.iteration} generates a function that implements the stopping
+#' criterion that limits the number of iterations to a maximum of \code{n}),
+#' i.e. that returns \code{TRUE} if \code{i>=n}, \code{FALSE} otherwise.
+#'
+#' @param n maximum number of iteration to perform.
+#'
+#' @return a function that can be used as a stopping criterion for NMF algorithms
+#' defined as \code{\linkS4class{NMFStrategyIterative}} objects.
+#' That is a function with arguments \code{(strategy, i, target, data, ...)}
+#' that returns \code{TRUE} if the stopping criterion is satisfied -- which in
+#' turn stops the iterative process, and \code{FALSE} otherwise.
+#'
+#' @export
+#' @family NMFStrategyIterative
+#' @rdname stop-NMF
+nmf.stop.iteration <- function(n){
+
+ nmf.debug("Using stopping criterion - Fixed number of iterations: ", n)
+ if( !is.numeric(n) )
+ stop("Invalid argument `n`: must be an integer value")
+ if( length(n) > 1 )
+ warning("NMF::nmf - Argument `n` [", deparse(substitute(n)), "] has length > 1: only using the first element.")
+
+ .max <- n[1]
+ function(object, i, y, x, ...) i >= .max
+}
+
+#' \code{nmf.stop.threshold} generates a function that implements the stopping
+#' criterion that stops when a given stationarity threshold is achieved by
+#' successive iterations.
+#' The returned function is identical to \code{nmf.stop.stationary}, but with
+#' the default threshold set to \code{threshold}.
+#'
+#' @param threshold default stationarity threshold
+#'
+#' @export
+#' @rdname stop-NMF
+nmf.stop.threshold <- function(threshold){
+
+ nmf.debug("Using stopping criterion - Stationarity threshold: ", threshold)
+ if( !is.numeric(threshold) )
+ stop("Invalid argument `threshold`: must be a numeric value")
+ if( length(threshold) > 1 )
+ warning("NMF::nmf - Argument `threshold` [", deparse(substitute(threshold)), "] has length > 1: only using the first element.")
+
+ eval(parse(text=paste("function(strategy, i, target, data, stationary.th=", threshold, ", ...){
+ nmf.stop.stationary(strategy, i, target, data, stationary.th=stationary.th, ...)
+ }")))
+}
+
+
+#' \code{nmf.stop.stationary} implements the stopping criterion of stationarity
+#' of the objective value, which stops when the gradient of the objective function
+#' is uniformly small over a certain number of iterations.
+#'
+#' More precisely, the objective function is computed over \eqn{n} successive iterations (specified
+#' in argument \code{check.niter}), every \code{check.interval} iterations.
+#' The criterion stops when the absolute difference between the maximum and the minimum
+#' objective values over these iterations is lower than a given threshold \eqn{\alpha}
+#' (specified in \code{stationary.th}):
+#'
+#' \deqn{
+#' \left| \frac{\max_{i- N_s + 1 \leq k \leq i} D_k - \min_{i - N_s +1 \leq k \leq i} D_k}{n} \right| \leq \alpha,
+#' }{
+#' | [max( D(i- N_s + 1), ..., D(i) ) - min( D(i- N_s + 1), ..., D(i) )] / n | <= alpha
+#' }
+#'
+#' @param object an NMF strategy object
+#' @param i the current iteration
+#' @param y the target matrix
+#' @param x the current NMF model
+#' @param stationary.th maximum absolute value of the gradient, for the objective
+#' function to be considered stationary.
+#' @param check.interval interval (in number of iterations) on which the stopping
+#' criterion is computed.
+#' @param check.niter number of successive iteration used to compute the stationnary
+#' criterion.
+#' @param ... extra arguments passed to the function \code{\link{objective}},
+#' which computes the objective value between \code{x} and \code{y}.
+#'
+#' @export
+#' @rdname stop-NMF
+nmf.stop.stationary <- local({
+
+ # static variable
+ .last.objective.value <- c(-Inf, Inf)
+ .niter <- 0L
+
+ .store_value <- function(value){
+ .niter <<- .niter + 1L
+ .last.objective.value <<- c(max(.last.objective.value[1L], value)
+ , min(.last.objective.value[2L], value))
+ }
+
+ .reset_value <- function(){
+ .last.objective.value <<- c(-Inf, Inf)
+ .niter <<- 0L
+ }
+
+ function(object, i, y, x, stationary.th=.Machine$double.eps, check.interval=5*check.niter, check.niter=10L, ...){
+
+ # check validity
+ if( check.interval < check.niter ){
+ stop("Invalid argument values: `check.interval` must always be greater than `check.niter`")
+ }
+ # initialisation call: compute initial objective value
+ if( i == 0L || (i == 1L && is.null(.last.objective.value)) ){
+ .reset_value()
+
+ # give the chance to update once and estimate from a partial model
+ if( is.partial.nmf(x) ) return( FALSE )
+
+ # compute initial deviance
+ current.value <- deviance(object, x, y, ...)
+ # check for NaN, i.e. probably infinitely small value (cf. bug reported by Nadine POUKEN SIEWE)
+ if( is.nan(current.value) ) return(TRUE)
+
+ # store value in static variable for next calls
+ .store_value(current.value)
+
+ return(FALSE)
+ }
+
+ # test convergence only every 10 iterations
+ if( .niter==0L && i %% check.interval != 0 ) return( FALSE );
+
+ # get last objective value from static variable
+ current.value <- deviance(object, x, y, ...)
+ # check for NaN, i.e. probably infinitely small value (cf. bug reported by Nadine POUKEN SIEWE)
+ if( is.nan(current.value) ) return(TRUE)
+
+ # update static variables
+ .store_value(current.value)
+
+ # once values have been computed for check.niter iterations:
+ # check if the difference in the extreme objective values is small enough
+ if( .niter == check.niter+1 ){
+ crit <- abs(.last.objective.value[1L] - .last.objective.value[2L]) / check.niter
+ if( crit <= stationary.th ){
+ if( nmf.getOption('verbose') ){
+ message(crit)
+ }
+ return( TRUE )
+ }
+ .reset_value()
+ }
+
+ # do NOT stop
+ FALSE
+ }
+})
+
+#' \code{nmf.stop.connectivity} implements the stopping criterion that is based
+#' on the stationarity of the connectivity matrix.
+#'
+#' @inheritParams nmf.stop.stationary
+#' @param stopconv number of iterations intervals over which the connectivity
+#' matrix must not change for stationarity to be achieved.
+#'
+#' @export
+#' @rdname stop-NMF
+nmf.stop.connectivity <- local({
+
+ # static variables
+ .consold <- NULL
+ .inc <- NULL
+
+ function(object, i, y, x, stopconv=40, check.interval=10, ...){
+
+ if( i == 0L ){ # initialisation call
+ # Initialize consensus variables
+ # => they are static variables within the strategy's workspace so that
+ # they are persistent and available throughout across the calls
+ p <- ncol(x)
+ .consold <<- matrix(0, p, p)
+ .inc <<- 0
+ return(FALSE)
+ }
+
+ # test convergence only every 10 iterations
+ if( i %% check.interval != 0 ) return( FALSE );
+
+ # retrieve metaprofiles
+ h <- coef(x, all=FALSE)
+
+ # construct connectivity matrix
+ index <- apply(h, 2, function(x) which.max(x) )
+ cons <- outer(index, index, function(x,y) ifelse(x==y, 1,0));
+
+ changes <- cons != .consold
+ if( !any(changes) ) .inc <<- .inc + 1 # connectivity matrix has not changed: increment the count
+ else{
+ .consold <<- cons;
+ .inc <<- 0; # else restart counting
+ }
+
+ # prints number of changing elements
+ #if( verbose(x) ) cat( sprintf('%d ', sum(changes)) )
+ #cat( sprintf('%d ', sum(changes)) )
+
+ # assume convergence is connectivity stops changing
+ if( .inc > stopconv ) return( TRUE );
+
+ # do NOT stop
+ FALSE
+ }
+})
+
+
+################################################################################################
+# WRAP-UP METHODS
+################################################################################################
diff --git a/R/NMFStrategyOctave-class.R b/R/NMFStrategyOctave-class.R
new file mode 100644
index 0000000..b01cff3
--- /dev/null
+++ b/R/NMFStrategyOctave-class.R
@@ -0,0 +1,150 @@
+# S4 class for NMF strategies implemented in Octave/Matlab
+# Algorithms are run via RcppOctave
+#
+# Author: Renaud Gaujoux
+# Created: 23 Nov 2012
+###########################################################
+#' @include NMFStrategy-class.R
+NULL
+
+#' S4 Interface for Octave-Matlab NMF Algorithms
+#'
+#' This class implements the virtual interface \code{\linkS4class{NMFStrategy}}
+#' for NMF algorithms that are implemented in Octave/Matlab, and provided as
+#' a set of .m files or as plain code.
+#'
+#' The \code{run} method for this class runs the algorithms via the
+#' \code{\link[RcppOctave]{RcppOctave}} package.
+#'
+#' @slot algorithm character string that gives the name of the main Octave/Matlab
+#' function that implements the algorithm.
+#' The function must take at least two arguments: the target matrix and the initial
+#' NMF model, converted into an Octave list object, with elements corresponding to
+#' slots of the corresponding S4 class.
+#' @slot mcode character vector that contains a set of path to .m files.
+#' These files are (re-)sourced every time the strategy is called, and must be
+#' present at runtime in the current directory or in a directory from Octave path.
+#'
+setClass('NMFStrategyOctave'
+ , representation(
+ algorithm = '.functionSlot' # the function that implements the algorithm
+ , mcode = 'character'
+ , onReturn = 'function' # method called just before returning the resulting NMF object
+ )
+ , prototype(
+ onReturn = function(object, x){
+ if( !isNMFfit(object, recursive = FALSE) ){
+
+ if( !is.nmf(object) && !is.list(object) ){
+ stop("Result object should be an NMF object or a list")
+ }
+ fit(x) <- new2(modelname(x), object)
+ if( !is.null(object$runtime) )
+ x at runtime <- structure(unlist(object$runtime), class='proc_time')
+ }
+ x
+ }
+ )
+ , contains = 'NMFStrategy'
+)
+
+#' Runs the NMF algorithms implemented by the Octave/Matlab function associated with the
+#' strategy -- and stored in slot \code{'algorithm'} of \code{object}.
+#'
+#' This method is usually not called directly, but only via the function \code{\link{nmf}}, which
+#' takes care of many other details such as seeding the computation, handling RNG settings,
+#' or setting up parallel computations.
+#'
+#' @rdname NMFStrategy
+setMethod('run', signature(object='NMFStrategyOctave', y='matrix', x='NMFfit'),
+ function(object, y, x, ...){
+
+ fstop <- function(...) stop("NMFStrategyOctave[", name(object), "]: ", ...)
+
+ # first thing check for RcppOctave
+ if( !require.quiet('RcppOctave', character.only=TRUE) )
+ fstop("The package RcppOctave is required to run this algorithm.\n"
+ , " Try installing it with: install.packages('RcppOctave')")
+
+ # add path to all mfiles
+ mdirs <- character()
+ ## add package mfiles directory if possible
+ if( nzchar(pkg <- packageSlot(object)) ){
+ if( nzchar(pkg_mfiles <- RcppOctave::system.mfile(package=pkg)) )
+ mdirs <- c(mdirs, pkg_mfiles)
+ }
+ ## add path to specified mfiles
+ mfiles <- object at mcode
+ if( length(mfiles) && any(nzchar(mfiles)) ){
+ mfiles <- RcppOctave::as.mfile(mfiles)
+ mdirs <- c(mdirs, dirname(mfiles))
+ }
+ ## add to path
+ if( length(mdirs) ){
+ mdirs <- unique(mdirs)
+ # check which dirs were already in Octave path
+ in_path <- sapply(mdirs, RcppOctave::o_inpath)
+ sapply(mdirs[!in_path], RcppOctave::o_addpath)
+ # on exit: cleanup Octave path
+ on.exit({
+ rmpath <- RcppOctave::.O$rmpath
+ sapply(mdirs[!in_path], rmpath)
+ })
+ }
+ #
+
+ # load algorithm
+ main <- algorithm(object, load=TRUE)
+
+ # convert matrix storage mode if necessary
+ if( storage.mode(y) != 'double' ){
+ storage.mode(y) <- 'double'
+ }
+ # call main function
+ res <- main(y, x, ...)
+ # wrap result
+ object at onReturn(res, x)
+ }
+)
+
+#' Returns the name of the Octave/Matlab function that implements the NMF algorithm -- as stored in
+#' slot \code{algorithm}.
+#'
+#' @param load logical that indicates if the algorithm should be loaded as an
+#' R function.
+#'
+setMethod('algorithm', signature(object='NMFStrategyOctave'),
+ function(object, load=FALSE){
+ f <- slot(object, 'algorithm')
+ if( !load || is.function(f) ) return(f)
+
+ if( !length(f) || !nchar(f) )
+ fstop("Main function is not defined for NMF algorithm '", name(object), "'.")
+
+ # return wrapped into a function
+ .main <- RcppOctave::o_get(f)
+ function(y, x, ...){
+ .main(y, r=as.numeric(nbasis(x)), W=basis(x), H=coef(x), ...)
+ }
+ }
+)
+#' Sets the name of the Octave/Matlab function that implements the NMF algorithm.
+#' It is stored in slot \code{algorithm}.
+setReplaceMethod('algorithm', signature(object='NMFStrategyOctave', value='character'),
+ function(object, value){
+ slot(object, 'algorithm') <- head(value, 1L)
+ object
+ }
+)
+
+#' @export
+#' @rdname NMFStrategyOctave-class
+setMethod('show', 'NMFStrategyOctave', function(object){
+ callNextMethod()
+ f <- algorithm(object)
+ cat(" main: "
+ , if( is.function(f) ) str_fun(f) else str_c(f, ' <Octave function>')
+ , "\n", sep='')
+ cat(" mcode: ", str_out(object at mcode, Inf), "\n", sep='')
+ }
+)
diff --git a/R/NMFfit-class.R b/R/NMFfit-class.R
new file mode 100644
index 0000000..1b8b531
--- /dev/null
+++ b/R/NMFfit-class.R
@@ -0,0 +1,734 @@
+# Implementation of class NMFfit
+#
+# This class manages the result of a single run of a NMF algorithm.
+#
+# Author: Renaud Gaujoux
+###############################################################################
+
+#' @include fixed-terms.R
+#' @include nmfModel.R
+NULL
+
+#' Base Class for to store Nonnegative Matrix Factorisation results
+#'
+#' Base class to handle the results of general \strong{Nonnegative Matrix
+#' Factorisation} algorithms (NMF).
+#'
+#' It provides a general structure and generic functions to manage the results
+#' of NMF algorithms. It contains a slot with the fitted NMF model (see slot
+#' \code{fit}) as well as data about the methods and parameters used to compute
+#' the factorization.
+#'
+#' The purpose of this class is to handle in a generic way the results of NMF
+#' algorithms. Its slot \code{fit} contains the fitted NMF model as an object
+#' of class \code{\linkS4class{NMF}}.
+#'
+#' Other slots contains data about how the factorization has been computed,
+#' such as the algorithm and seeding method, the computation time, the final
+#' residuals, etc\dots{}
+#'
+#' Class \code{NMFfit} acts as a wrapper class for its slot \code{fit}. It
+#' inherits from interface class \code{\linkS4class{NMF}} defined for generic
+#' NMF models. Therefore, all the methods defined by this interface can be
+#' called directly on objects of class \code{NMFfit}. The calls are simply
+#' dispatched on slot \code{fit}, i.e. the results are the same as if calling
+#' the methods directly on slot \code{fit}.
+#'
+#' @slot fit An object that inherits from class \code{\linkS4class{NMF}}, and
+#' contains the fitted NMF model.
+#'
+#' NB: class \code{NMF} is a virtual class. The default class for this
+#' slot is \code{NMFstd}, that implements the standard NMF model.
+#'
+#' @slot residuals A \code{numeric} vector that contains the final
+#' residuals or the residuals track between the target matrix and its NMF
+#' estimate(s). Default value is \code{numeric()}.
+#'
+#' See method \code{\link{residuals}} for details on accessor methods and main
+#' interface \code{\link{nmf}} for details on how to compute NMF with residuals
+#' tracking.
+#'
+#' @slot method a single \code{character} string that contains the
+#' name of the algorithm used to fit the model.
+#' Default value is \code{''}.
+#'
+#' @slot seed a single \code{character} string that contains the
+#' name of the seeding method used to seed the algorithm that fitted the NMF
+#' model.
+#' Default value is \code{''}. See \code{\link{nmf}} for more details.
+#'
+#' @slot rng an object that contains the RNG settings used for the
+#' fit.
+#' Currently the settings are stored as an integer vector, the value of
+#' \code{\link{.Random.seed}} at the time the object is created.
+#' It is initialized by the \code{initialized} method.
+#' See \code{\link{getRNG}} for more details.
+#'
+#' @slot distance either a single \code{"character"} string that
+#' contains the name of the built-in objective function, or a \code{function}
+#' that measures the residuals between the target matrix and its NMF estimate.
+#' See \code{\link{objective}} and \code{\link{deviance,NMF-method}}.
+#'
+#' @slot parameters a \code{list} that contains the extra parameters
+#' -- usually specific to the algorithm -- that were used to fit the model.
+#'
+#' @slot runtime object of class \code{"proc_time"} that contains
+#' various measures of the time spent to fit the model.
+#' See \code{\link[base]{system.time}}
+#'
+#' @slot options a \code{list} that contains the options used to
+#' compute the object.
+#'
+#' @slot extra a \code{list} that contains extra miscellaneous data
+#' for internal usage only.
+#' For example it can be used to store extra parameters or temporary data,
+#' without the need to explicitly extend the \code{NMFfit} class.
+#' Currently built-in algorithms only use this slot to
+#' store the number of iterations performed to fit the object.
+#'
+#' Data that need to be easily accessible by the end-user should rather be set
+#' using the methods \code{$<-} that sets elements in the \code{list} slot
+#' \code{misc} -- that is inherited from class \code{\linkS4class{NMF}}.
+#'
+#' @slot call stored call to the last \code{nmf} method that generated the
+#' object.
+#'
+#' @export
+#' @examples
+#' # run default NMF algorithm on a random matrix
+#' n <- 50; r <- 3; p <- 20
+#' V <- rmatrix(n, p)
+#' res <- nmf(V, r)
+#'
+#' # result class is NMFfit
+#' class(res)
+#' isNMFfit(res)
+#'
+#' # show result
+#' res
+#'
+#' # compute summary measures
+#' summary(res, target=V)
+#'
+setClass('NMFfit'
+ , representation(
+ fit = 'NMF', # NMF model
+ residuals = 'numeric', # residuals from the target matrix
+ method = 'character', # method used to compute the factorization
+ seed = 'character', # seeding method used to compute the factorization
+ rng = 'ANY', # numerical random seed
+ distance = '.functionSlotNULL', # method used to compute the distance between the target matrix and its NMF estimate
+ parameters = 'list', # method used to compute the factorization
+ runtime = 'proc_time', # running time to perform the NMF
+ options = 'list', # run options
+ extra = 'list' # extra list of results output by the method
+ , call = 'call' # store last call to nmf()
+ )
+
+ , prototype = prototype(
+ residuals = numeric(),
+ method = '',
+ seed = '',
+ parameters = list(),
+ extra = list()
+ )
+
+ , validity = function(object){
+
+ # slot 'objective' must either be a non-empty character string or a function
+ obj <- objective(object)
+ if( is.character(obj) && obj == '')
+ return(paste("Slot 'objective' must either be a non-empty character string or a function definition", sep=''))
+
+
+ # everything went fine: return TRUE
+ TRUE
+ }
+ , contains = 'NMF'
+)
+
+#' The function \code{NMFfit} is a factory method for NMFfit objects, that should
+#' not need to be called by the user.
+#' It is used internally by the functions \code{\link{nmf}} and \code{seed} to
+#' instantiate the starting point of NMF algorithms.
+#'
+#' @param fit an NMF model
+#' @param ... extra argument used to initialise slots in the instantiating
+#' \code{NMFfit} object.
+#' @param rng RNG settings specification (typically a suitable value for
+#' \code{\link{.Random.seed}}).
+#'
+#' @rdname NMFfit-class
+NMFfit <- function(fit=nmfModel(), ..., rng=NULL){
+
+ # use current RNG settings if not otherwise provided
+ if( is.null(rng) )
+ rng <- getRNG()
+
+ new('NMFfit', fit=fit, ..., rng=rng)
+}
+
+#' Computes and return the estimated target matrix from an NMF model fitted with
+#' function \code{\link{nmf}}.
+#'
+#' It is a shortcut for \code{fitted(fit(object), ...)}, dispatching the call to
+#' the \code{fitted} method of the actual NMF model.
+setMethod('fitted', signature(object='NMFfit'),
+ function(object, ...){
+ fitted(fit(object), ...)
+ }
+)
+
+#' Returns the basis matrix from an NMF model fitted with
+#' function \code{\link{nmf}}.
+#'
+#' It is a shortcut for \code{.basis(fit(object), ...)}, dispatching the call to
+#' the \code{.basis} method of the actual NMF model.
+setMethod('.basis', signature(object='NMFfit'),
+ function(object, ...){
+ .basis(fit(object), ...)
+ }
+)
+#' Sets the the basis matrix of an NMF model fitted with
+#' function \code{\link{nmf}}.
+#'
+#' It is a shortcut for \code{.basis(fit(object)) <- value}, dispatching the call to
+#' the \code{.basis<-} method of the actual NMF model.
+#' It is not meant to be used by the user, except when developing
+#' NMF algorithms, to update the basis matrix of the seed object before
+#' returning it.
+#'
+setReplaceMethod('.basis', signature(object='NMFfit', value='matrix'),
+ function(object, value){
+ .basis(fit(object)) <- value
+ object
+ }
+)
+
+#' Returns the the coefficient matrix from an NMF model fitted with
+#' function \code{\link{nmf}}.
+#'
+#' It is a shortcut for \code{.coef(fit(object), ...)}, dispatching the call to
+#' the \code{.coef} method of the actual NMF model.
+setMethod('.coef', signature(object='NMFfit'),
+ function(object, ...){
+ .coef(fit(object), ...)
+ }
+)
+#' Sets the the coefficient matrix of an NMF model fitted with
+#' function \code{\link{nmf}}.
+#'
+#' It is a shortcut for \code{.coef(fit(object)) <- value}, dispatching the call to
+#' the \code{.coef<-} method of the actual NMF model.
+#' It is not meant to be used by the user, except when developing
+#' NMF algorithms, to update the coefficient matrix in the seed object before
+#' returning it.
+#'
+setReplaceMethod('.coef', signature(object='NMFfit', value='matrix'),
+ function(object, value){
+ .coef(fit(object)) <- value
+ object
+ }
+)
+
+#' Method for single NMF fit objects, which returns the indexes of fixed
+#' basis terms from the fitted model.
+setMethod('ibterms', 'NMFfit',
+ function(object){
+ ibterms(fit(object))
+ }
+)
+#' Method for single NMF fit objects, which returns the indexes of fixed
+#' coefficient terms from the fitted model.
+setMethod('icterms', 'NMFfit',
+ function(object){
+ icterms(fit(object))
+ }
+)
+
+
+#' Returns the offset from the fitted model.
+setMethod('offset', signature(object='NMFfit'),
+ function(object){
+ offset(fit(object))
+ }
+)
+
+#' Returns the number of iteration performed to fit an NMF model, typically
+#' with function \code{\link{nmf}}.
+#'
+#' Currently this data is stored in slot \code{'extra'}, but this might change
+#' in the future.
+setMethod('niter', signature(object='NMFfit'),
+ function(object, ...){
+ object at extra$iteration
+ }
+)
+#' Sets the number of iteration performed to fit an NMF model.
+#'
+#' This function is used internally by the function \code{\link{nmf}}.
+#' It is not meant to be called by the user, except when developing
+#' new NMF algorithms implemented as single function, to set the number
+#' of iterations performed by the algorithm on the seed, before returning it
+#' (see \code{\linkS4class{NMFStrategyFunction}}).
+#'
+setReplaceMethod('niter', signature(object='NMFfit', value='numeric'),
+ function(object, value){
+ if( (length(value) != 1) || value < 0 )
+ stop("NMF::niter - invalid value for 'niter': single non-negative value is required.", call.=FALSE)
+ object at extra$iteration <- value
+ object
+ }
+)
+
+#' Show method for objects of class \code{NMFfit}
+setMethod('show', 'NMFfit',
+ function(object)
+ {
+ cat("<Object of class: ", class(object), ">\n", sep='')
+ cat(" # Model:\n ")
+ s <- capture.output(show(fit(object)))
+ cat(s, sep="\n ")
+ cat(" # Details:\n ")
+ .local <- function(){
+ if( algorithm(object) != '' ) cat("algorithm: ", algorithm(object), "\n")
+ if( seeding(object) != '' ) cat("seed: ", seeding(object), "\n")
+
+ # initial RNG stream
+ cat("RNG: ", RNGstr(object), "\n", sep='')
+
+ # distance/objective function
+ svalue <- objective(object)
+ svalue <- if( is.function(svalue) ) '<function>' else paste("'", svalue,"'", sep='')
+ cat("distance metric: ", svalue, "\n")
+ if( length(residuals(object)) !=0 ) cat("residuals: ", residuals(object), "\n");
+ # show the miscellaneous result values
+ if( length(object at misc) > 0L )
+ cat("miscellaneous:", str_desc(object at misc, exdent=12L), ". (use 'misc(object)')\n")
+ # show the parameters specific to the method
+ if( length(object at parameters) > 0 ){
+ cat("parameters:", str_desc(object at parameters, exdent=12L), "\n")
+# p <- sapply(object at parameters, function(x){
+# if( is.vector(x) && length(x) == 1L ) x
+# else paste("<", class(x), ">", sep='')
+# })
+# cat(str_wrap(str_out(p, NA, use.names=TRUE, quote=FALSE), exdent=12), "\n")
+ }
+ # show number of iterations if present
+ if( !is.null(i <- niter(object)) ) cat("Iterations:", i, "\n")
+ # show elapsed time if present
+ if( length(runtime(object)) > 0 ){ cat("Timing:\n"); show(runtime(object));}
+ }
+ s <- capture.output(.local())
+ cat(s, sep="\n ")
+ }
+)
+
+
+
+#' Extracting Fitted Models
+#'
+#' The functions \code{fit} and \code{minfit} are S4 genetics that extract
+#' the best model object and the best fit object respectively, from a collection
+#' of models or from a wrapper object.
+#'
+#' @details
+#' A fit object differs from a model object in that it contains data about the
+#' fit, such as the initial RNG settings, the CPU time used, etc\ldots, while
+#' a model object only contains the actual modelling data such as regression
+#' coefficients, loadings, etc\ldots
+#'
+#' That best model is generally defined as the one that achieves the
+#' maximum/minimum some quantitative measure, amongst all models in a collection.
+#'
+#' In the case of NMF models, the best model is the one that achieves the best
+#' approximation error, according to the objective function associated with the
+#' algorithm that performed the fit(s).
+#'
+#' @param object an object fitted by some algorithm, e.g. as returned by the
+#' function \code{\link{nmf}}.
+#' @param value replacement value
+#' @param ... extra arguments to allow extension
+#'
+#' @rdname fit
+#' @export
+setGeneric('fit', function(object, ...) standardGeneric('fit'))
+#' Returns the NMF model object stored in slot \code{'fit'}.
+setMethod('fit', 'NMFfit', function(object) slot(object, 'fit'))
+
+#' \code{fit<-} sets the fitted model in a fit object.
+#' It is meant to be called only when developing new NMF algorithms, e.g. to update
+#' the value of the model stored in the starting point.
+#'
+#' @rdname fit
+#' @export
+setGeneric('fit<-', function(object, value) standardGeneric('fit<-'))
+#' Updates the NMF model object stored in slot \code{'fit'} with a new value.
+setReplaceMethod('fit', signature(object='NMFfit', value='NMF'),
+ function(object, value){
+ slot(object, 'fit') <- value
+ object # TODO: valid object before returning it (+param check=TRUE or FALSE)
+ }
+)
+
+#' @rdname fit
+#' @export
+setGeneric('minfit', function(object, ...) standardGeneric('minfit') )
+#' Returns the object its self, since there it is the result of a single NMF run.
+setMethod('minfit', 'NMFfit', function(object) object)
+
+
+#' Returns the type of a fitted NMF model.
+#' It is a shortcut for \code{modelname(fit(object)}.
+setMethod('modelname', signature(object='NMFfit'),
+ function(object)
+ {
+ modelname(fit(object))
+ }
+)
+
+#' Residuals in NMF Models
+#'
+#' The package NMF defines methods for the function \code{\link[stats]{residuals}}
+#' that returns the final residuals of an NMF fit or the track of the residuals
+#' along the fit process, computed according to the objective function
+#' associated with the algorithm that fitted the model.
+#'
+#' When called with \code{track=TRUE}, the whole residuals track is returned,
+#' if available.
+#' Note that method \code{\link{nmf}} does not compute the residuals track,
+#' unless explicitly required.
+#'
+#' It is a S4 methods defined for the associated generic functions from package
+#' \code{stats} (See \link[stats]{residuals}).
+#'
+#' @note Stricly speaking, the method \code{residuals,NMFfit} does not fulfill
+#' its contract as defined by the package \code{stats}, but rather acts as function
+#' \code{deviance}.
+#' The might be changed in a later release to make it behave as it should.
+#'
+#' @param object an \code{NMFfit} object as fitted by function \code{\link{nmf}},
+#' in single run mode.
+#' @param ... extra parameters (not used)
+#'
+#' @return \code{residuals} returns a single numeric value if \code{track=FALSE}
+#' or a numeric vector containing the residual values at some iterations.
+#' The names correspond to the iterations at which the residuals were computed.
+#'
+#' @family stats
+#' @inline
+#' @rdname residuals
+#' @export
+#'
+setGeneric('residuals', package='stats')
+#' Returns the residuals -- track -- between the target matrix and the NMF
+#' fit \code{object}.
+#'
+#' @param track a logical that indicates if the complete track of residuals
+#' should be returned (if it has been computed during the fit), or only the last
+#' value.
+#'
+#' @param niter specifies the iteration number for which one wants
+#' to get/set/test a residual value. This argument is used only if not \code{NULL}
+#'
+setMethod('residuals', 'NMFfit',
+ function(object, track=FALSE, niter=NULL, ...){
+ ## IMPORTANT: keep this '...' and do not add a 'method' argument as this
+ ## one is passed by NMFfitX::fit (see bug #159) and is not supposed to be
+ ## used
+ res <- slot(object, 'residuals')
+ if( track ) res
+ else if( is.null(niter) ) tail(res, n=1)
+ else res[as.character(niter)]
+ }
+)
+
+#' \code{residuals<-} sets the value of the last residuals, or, optionally,
+#' of the complete residual track.
+#'
+#' @param value residual value
+#'
+#' @export
+#' @inline
+#' @rdname residuals
+setGeneric('residuals<-', function(object, ..., value) standardGeneric('residuals<-') )
+#' @inline
+setReplaceMethod('residuals', 'NMFfit',
+ function(object, ..., niter=NULL, track=FALSE, value){
+ if( track ) slot(object, 'residuals') <- value
+ else{
+ if( !is.null(niter) ) value <- setNames(value, niter)
+ slot(object, 'residuals') <- c(slot(object, 'residuals'), value)
+ }
+ object
+ }
+)
+
+#' Tells if an \code{NMFfit} object contains a recorded residual track.
+#'
+#' @export
+#' @rdname residuals
+hasTrack <- function(object, niter=NULL){
+ if( is.null(niter) ) length( slot(object, 'residuals') ) > 1
+ else !is.na(slot(object, 'residuals')[as.character(niter)])
+}
+
+#' \code{trackError} adds a residual value to the track of residuals.
+#'
+#' @param force logical that indicates if the value should be added to the track
+#' even if there already is a value for this iteration number or if the iteration
+#' does not conform to the tracking interval \code{nmf.getOption('track.interval')}.
+#'
+#' @rdname residuals
+#' @export
+trackError <- function(object, value, niter, force=FALSE){
+ track <- run.options(object, 'error.track')
+ track.interval <- run.options(object, 'track.interval')
+
+ if( force || (track && niter %% track.interval == 0) ){
+ # add the new value to the error track
+ last.iter <- names(residuals(object))
+ duplicate <- if( !is.null(last.iter) ) niter == last.iter else FALSE
+ if( !duplicate ){
+ iter <- if( niter >= 0 ) niter
+ residuals(object, niter=iter) <- value
+ }
+ }
+ object
+}
+
+#' Returns the deviance of a fitted NMF model.
+#'
+#' This method returns the final residual value if the target matrix \code{y} is
+#' not supplied, or the approximation error between the fitted NMF model stored
+#' in \code{object} and \code{y}.
+#' In this case, the computation is performed using the objective function
+#' \code{method} if not missing, or the objective of the algorithm that
+#' fitted the model (stored in slot \code{'distance'}).
+#'
+#' If not computed by the NMF algorithm itself, the value is automatically
+#' computed at the end of the fitting process by the function \code{\link{nmf}},
+#' using the objective function associated with the NMF algorithm, so that it
+#' should always be available.
+#'
+#' @inline
+setMethod('deviance', 'NMFfit',
+ function(object, y, method, ...){
+
+ if( missing(y) ) setNames(residuals(object), NULL)
+ else{
+ # if missing retrieve the actual distance measure from the NMF object
+ if( missing(method) ) method = object at distance
+
+ # compute the distance between the target and the fitted NMF model
+ deviance(fit(object), y, method=method, ...)
+ }
+ }
+)
+
+#' Returns the name of the algorithm that fitted the NMF model \code{object}.
+setMethod('algorithm', 'NMFfit', function(object){ object at method } )
+#' @inline
+setReplaceMethod('algorithm', 'NMFfit',
+ function(object, value){
+ object at method <- value
+ object
+ }
+)
+
+#' Returns the name of the seeding method that generated the starting point
+#' for the NMF algorithm that fitted the NMF model \code{object}.
+setMethod('seeding', 'NMFfit', function(object){ object at seed } )
+#' @inline
+setReplaceMethod('seeding', 'NMFfit',
+ function(object, value){
+ object at seed <- value
+ object
+ }
+)
+
+#' Returns the objective function associated with the algorithm that computed the
+#' fitted NMF model \code{object}, or the objective value with respect to a given
+#' target matrix \code{y} if it is supplied.
+#'
+#' @param y optional target matrix used to compute the objective value.
+#'
+setMethod('objective', signature(object='NMFfit'),
+ function(object, y){
+
+ # when both x and y are missing then returns slot objective
+ if( missing(y) ) return(slot(object, 'distance'))
+
+ # return the distance computed using the strategy's objective function
+ deviance(fit(object), y, method=slot(object, 'distance'))
+
+ }
+)
+#' @inline
+setReplaceMethod('objective', signature(object='NMFfit', value='ANY'),
+ function(object, value){
+ slot(object, 'distance') <- value
+ validObject(object)
+ object
+ }
+)
+
+#' Returns the CPU time required to compute a single NMF fit.
+setMethod('runtime', 'NMFfit',
+ function(object, ...){
+ object at runtime
+ }
+)
+
+#' Identical to \code{runtime}, since their is a single fit.
+setMethod('runtime.all', 'NMFfit', getMethod('runtime', 'NMFfit'))
+
+###% Access methods to run options.
+setGeneric('run.options', function(object, ...) standardGeneric('run.options') )
+setMethod('run.options', 'NMFfit',
+ function(object, name){
+ if( missing(name) ) object at options
+ else object at options[[name]]
+ }
+)
+setGeneric('run.options<-', function(object, ..., value) standardGeneric('run.options<-') )
+setReplaceMethod('run.options', 'NMFfit',
+ function(object, ..., value){
+
+ params <- list(...)
+ baseError <- 'Setting NMF runtime options: '
+ if ( length(params) == 0 ){
+ if( !is.list(value) ) stop(baseError, 'options must be given as a list')
+ object at options <- value
+ return(object)
+ }
+ else if ( length(params) > 1 ) stop(baseError, 'options cannot set more than one option at a time')
+ name <- params[[1]]
+ if( !is.character(name) ) stop(baseError, 'option name must be given as a character string')
+ # check if the option exists
+ #if( !is.element(name, names(nmf.options.runtime())) ) stop(baseError, "option '", name, "' is not defined.")
+
+ object at options[[name]] <- value
+ object
+ }
+)
+setGeneric('verbose', function(object, ...) standardGeneric('verbose') )
+setMethod('verbose', 'NMFfit',
+ function(object){
+ return(run.options(object, 'verbose') || nmf.getOption('debug'))
+ }
+)
+
+setGeneric('plot', package='graphics' )
+#' Plots the residual track computed at regular interval during the fit of
+#' the NMF model \code{x}.
+#'
+#' @param skip an integer that indicates the number of points to skip/remove from the beginning
+#' of the curve.
+#' If \code{skip=1L} (default) only the initial residual -- that is computed before any iteration, is
+#' skipped, if present in the track (it associated with iteration 0).
+#'
+#' @export
+setMethod('plot', signature(x='NMFfit', y='missing'),
+ function(x, y, skip=-1L, ...){
+
+ # retrieve the residuals track
+ track <- residuals(x, track=TRUE)
+ if( length(track) <= 1 ){
+ warning(class(x), ' object has no residuals track')
+ return(invisible())
+ }
+ # skip part of the track
+ if( skip == -1L && !is.null(names(track)) ) track <- track[names(track)!='0'] # remove initial residual
+ else if( skip > 0 ) track <- track[-(1:skip)]
+
+ # set default graphical parameters (those can be overriden by the user)
+ params <- .set.list.defaults(list(...)
+ , xlab='Iterations'
+ , ylab=paste('Objective value ('
+ , if( is.character(x at distance) ) x at distance else algorithm(x), ')'
+ , sep='' )
+ , main=paste("NMF Residuals\nMethod: ", algorithm(x), " - Rank: ", nbasis(x), sep='')
+ , cex.main = 1
+ , col='#5555ff', lwd=1.4, type='l', cex=0.5)
+
+ do.call('plot', c(list(names(track), track), params))
+ points(names(track), track, type='p', cex=0.6, col=params$col)
+ }
+)
+
+#' Computes summary measures for a single fit from \code{\link{nmf}}.
+#'
+#' This method adds the following measures to the measures computed by the method
+#' \code{summary,NMF}:
+#'
+#' \describe{
+#' \item{residuals}{Residual error as measured by the objective function associated
+#' to the algorithm used to fit the model.}
+#' \item{niter}{Number of iterations performed to achieve convergence of the algorithm.}
+#' \item{cpu}{Total CPU time required for the fit.}
+#' \item{cpu.all}{Total CPU time required for the fit. For \code{NMFfit} objects, this element is
+#' always equal to the value in \dQuote{cpu}, but will be different for multiple-run fits.}
+#' \item{nrun}{Number of runs performed to fit the model. This is always equal to 1 for
+#' \code{NMFfit} objects, but will vary for multiple-run fits.}
+#' }
+#'
+#' @inline
+#'
+#' @examples
+#' # generate a synthetic dataset with known classes: 50 features, 18 samples (5+5+8)
+#' n <- 50; counts <- c(5, 5, 8);
+#' V <- syntheticNMF(n, counts)
+#' cl <- unlist(mapply(rep, 1:3, counts))
+#'
+#' # perform default NMF with rank=2
+#' x2 <- nmf(V, 2)
+#' summary(x2, cl, V)
+#' # perform default NMF with rank=2
+#' x3 <- nmf(V, 3)
+#' summary(x2, cl, V)
+#'
+setMethod('summary', signature(object='NMFfit'),
+ function(object, ...){
+
+ res <- summary(fit(object), ...)
+
+ ## IMPORTANT: if adding a summary measure also add it in the sorting
+ ## schema of method NMFfitX::compare to allow ordering on it
+
+ # retreive final residuals
+ res <- c(res, residuals=as.numeric(residuals(object)))
+ # nb of iterations
+ res <- c(res, niter=as.integer(niter(object)) )
+ # runtime
+ t <- runtime(object)
+ utime <- as.numeric(t['user.self'] + t['user.child'])
+ res <- c(res, cpu=utime, cpu.all=utime, nrun=1)
+
+ # return result
+ return(res)
+ }
+)
+
+#' Compares two NMF models when at least one comes from a NMFfit object,
+#' i.e. an object returned by a single run of \code{\link{nmf}}.
+setMethod('nmf.equal', signature(x='NMFfit', y='NMF'),
+ function(x, y, ...){
+ nmf.equal(fit(x), y, ...)
+ }
+)
+#' Compares two NMF models when at least one comes from a NMFfit object,
+#' i.e. an object returned by a single run of \code{\link{nmf}}.
+setMethod('nmf.equal', signature(x='NMF', y='NMFfit'),
+ function(x, y, ...){
+ nmf.equal(x, fit(y), ...)
+ }
+)
+#' Compares two fitted NMF models, i.e. objects returned by single runs of
+#' \code{\link{nmf}}.
+setMethod('nmf.equal', signature(x='NMFfit', y='NMFfit'),
+ function(x, y, ...){
+ nmf.equal(fit(x), fit(y), ...)
+ }
+)
+
diff --git a/R/NMFns-class.R b/R/NMFns-class.R
new file mode 100644
index 0000000..32ee0cb
--- /dev/null
+++ b/R/NMFns-class.R
@@ -0,0 +1,174 @@
+#' @include NMFstd-class.R
+NULL
+
+#' NMF Model - Nonsmooth Nonnegative Matrix Factorization
+#'
+#' This class implements the \emph{Nonsmooth Nonnegative Matrix Factorization}
+#' (nsNMF) model, required by the Nonsmooth NMF algorithm.
+#'
+#' The Nonsmooth NMF algorithm is defined by \cite{Pascual-Montano2006} as a
+#' modification of the standard divergence based NMF algorithm (see section
+#' Details and references below). It aims at obtaining sparser factor
+#' matrices, by the introduction of a smoothing matrix.
+#'
+#' @details
+#' The Nonsmooth NMF algorithm is a modification of the standard divergence
+#' based NMF algorithm (see \code{\linkS4class{NMF}}).
+#' Given a non-negative \eqn{n \times p}{n x p} matrix \eqn{V} and a
+#' factorization rank \eqn{r}, it fits the following model:
+#'
+#' \deqn{V \equiv W S(\theta) H,}{V ~ W S(theta) H,}
+#' where:
+#' \itemize{
+#'
+#' \item \eqn{W} and \eqn{H} are such as in the standard model, i.e.
+#' non-negative matrices of dimension \eqn{n \times r}{n x r}
+#' and \eqn{r \times p}{r x p} respectively;
+#'
+#' \item \eqn{S} is a \eqn{r \times r} square matrix whose entries depends on
+#' an extra parameter \eqn{0\leq \theta \leq 1} in the following way:
+#' \deqn{S = (1-\theta)I + \frac{\theta}{r} 11^T ,}
+#' where \eqn{I} is the identity matrix and \eqn{1}
+#' is a vector of ones.
+#'
+#' }
+#'
+#' The interpretation of S as a smoothing matrix can be explained as follows:
+#' Let \eqn{X} be a positive, nonzero, vector. Consider the transformed vector
+#' \eqn{Y = S X}. If \eqn{\theta = 0}, then \eqn{Y = X} and no smoothing on
+#' \eqn{X} has occurred. However, as \eqn{\theta \to 1}{theta tends to 1}, the
+#' vector \eqn{Y} tends to the constant vector with all elements almost equal
+#' to the average of the elements of \eqn{X}. This is the smoothest possible
+#' vector in the sense of non-sparseness because all entries are equal to the
+#' same nonzero value, instead of having some values close to zero and others
+#' clearly nonzero.
+#'
+#' @section Creating objects from the Class:
+#'
+#' Object of class \code{NMFns} can be created using the standard way with
+#' operator \code{\link{new}}
+#'
+#' However, as for all NMF model classes -- that extend class
+#' \code{\linkS4class{NMF}}, objects of class \code{NMFns} should be
+#' created using factory method \code{\link{nmfModel}} :
+#'
+#' \code{new('NMFns')}
+#'
+#' \code{nmfModel(model='NMFns')}
+#'
+#' \code{nmfModel(model='NMFns', W=w, theta=0.3}
+#'
+#' See \code{\link{nmfModel}} for more details on how to use the factory
+#' method.
+#'
+#' @section Algorithm:
+#'
+#' The Nonsmooth NMF algorithm uses a modified version of the multiplicative
+#' update equations in Lee & Seung's method for Kullback-Leibler divergence
+#' minimization.
+#' The update equations are modified to take into account the --
+#' constant -- smoothing matrix.
+#' The modification reduces to using matrix \eqn{W S} instead of matrix \eqn{W}
+#' in the update of matrix \eqn{H}, and similarly using matrix \eqn{S H}
+#' instead of matrix \eqn{H} in the update of matrix \eqn{W}.
+#'
+#' After the matrix \eqn{W} has been updated, each of its columns is scaled so
+#' that it sums up to 1.
+#'
+#' @export
+#' @family NMF-model
+#' @examples
+#'
+#' # create a completely empty NMFns object
+#' new('NMFns')
+#'
+#' # create a NMF object based on random (compatible) matrices
+#' n <- 50; r <- 3; p <- 20
+#' w <- rmatrix(n, r)
+#' h <- rmatrix(r, p)
+#' nmfModel(model='NMFns', W=w, H=h)
+#'
+#' # apply Nonsmooth NMF algorithm to a random target matrix
+#' V <- rmatrix(n, p)
+#' \dontrun{nmf(V, r, 'ns')}
+#'
+#' # random nonsmooth NMF model
+#' rnmf(3, 10, 5, model='NMFns', theta=0.3)
+#'
+setClass('NMFns'
+ , representation(
+ theta = 'numeric' # smoothing matrix
+ )
+ , contains = 'NMFstd'
+ , prototype = prototype(
+ theta = 0.5
+ )
+ , validity = function(object){
+ if( object at theta < 0 || object at theta > 1 )
+ return(paste("Invalid value for theta (",object at theta,"): must be between 0 and 1", sep=''))
+ TRUE
+ }
+)
+
+#' Show method for objects of class \code{NMFns}
+#' @export
+setMethod('show', 'NMFns',
+ function(object)
+ {
+ callNextMethod()
+ cat("theta:", object at theta, "\n")
+ }
+)
+
+#' Compute estimate for an NMFns object, according to the Nonsmooth NMF model
+#' (cf. \code{\link{NMFns-class}}).
+#'
+#' Extra arguments in \code{...} are passed to method \code{smoothing}, and are
+#' typically used to pass a value for \code{theta}, which is used to compute
+#' the smoothing matrix instead of the one stored in \code{object}.
+#'
+#' @param S smoothing matrix to use instead of \code{smoothing(object)}
+#' It must be a square matrix compatible with the basis and coefficient matrices
+#' used in the computation.
+#' @inline
+#'
+setMethod('fitted', signature(object='NMFns'),
+ function(object, W, H, S, ...){
+ if( missing(W) ) W <- object at W
+ if( missing(H) ) H <- object at H
+ if( missing(S) ) S <- smoothing(object, ...)
+ W %*% (S %*% H)
+ }
+)
+
+#' Smoothing Matrix in Nonsmooth NMF Models
+#'
+#' The function \code{smoothing} builds a smoothing matrix for using in Nonsmooth
+#' NMF models.
+#'
+#' For a \eqn{r}-rank NMF, the smoothing matrix of parameter \eqn{\theta} is
+#' built as follows:
+#' \deqn{S = (1-\theta)I + \frac{\theta}{r} 11^T ,}
+#' where \eqn{I} is the identity matrix and \eqn{1} is a vector of ones
+#' (cf. \code{\link{NMFns-class}} for more details).
+#'
+#' @param x a object of class \code{NMFns}.
+#' @param theta the smoothing parameter (numeric) between 0 and 1.
+#' @param ... extra arguments to allow extension (not used)
+#'
+#' @return if \code{x} estimates a \eqn{r}-rank NMF,
+#' then the result is a \eqn{r \times r} square matrix.
+#' @export
+#'
+#' @examples
+#' x <- nmfModel(3, model='NMFns')
+#' smoothing(x)
+#' smoothing(x, 0.1)
+#'
+smoothing <- function(x, theta=x at theta, ...){
+ # check validity of theta
+ if( theta < 0 || theta > 1 )
+ stop("Invalid smoothing parameter theta [",theta,"]: theta must be susch that 0 <= theta <=1")
+ diag(1-theta, nbasis(x)) + theta / nbasis(x)
+}
+
diff --git a/R/NMFplots.R b/R/NMFplots.R
new file mode 100644
index 0000000..39ec8a8
--- /dev/null
+++ b/R/NMFplots.R
@@ -0,0 +1,645 @@
+# Plotting functions for NMF objects
+#
+# Author: Renaud Gaujoux
+# Creation: 16 Aug 2011
+###############################################################################
+
+#' @include NMFSet-class.R
+NULL
+
+# Scales a matrix so that its columns sum up to one.
+sum2one <- function(x){
+ sweep(x, 2L, colSums(x), '/')
+}
+
+#' @import grDevices
+corplot <- function(x, y, legend=TRUE, confint=TRUE, scales = 'fixed', ..., add=FALSE){
+
+ cols <- rainbow(ncol(x))
+
+ # set default arguments
+ gpar <- .set.list.defaults(list(...)
+ , ylab=quote(substitute(y))
+ , xlab=quote(substitute(x))
+ , main="Correlation plot"
+ , type='p'
+ , pch=19
+ , cex=0.8
+ , col=alphacol(cols, alpha=90))
+
+ if( is.null(colnames(x)) )
+ colnames(x) <- paste("column", 1:ncol(x), sep='_')
+
+ # draw plot using matplot
+ pfun <- if( add ) matpoints else matplot
+ #do.call(pfun, c(list(x, y), gpar))
+ # add perfect match line
+ #abline(a=0, b=1)
+
+ # initialise result
+ res <- list(global=list())
+ gco <- lm(as.numeric(y) ~ as.numeric(x))
+ res$global$lm <- gco
+ grsq <- CI.Rsqlm(gco)
+ res$global$cortest <- cor.test( as.numeric(x), as.numeric(y) )
+ grsq$rho <- res$global$cortest$estimate
+ grsq$alpha <- res$global$lm$coef[2L]
+
+ # add legend if requested
+ x <- provideDimnames(x, base = list(as.character(1:max(dim(x)))))
+ y <- provideDimnames(y, base = list(as.character(1:max(dim(y)))))
+ ct.labs <- colnames(x)
+ if( legend ){
+ # separate correlations
+ res$local <- list(lm=list(), cortest=list())
+ lco <- t(sapply(1:ncol(x), function(i){
+ co <- lm(y[,i] ~ x[,i])
+ res$local$lm[[i]] <<- co
+ cotest <- cor.test( as.numeric(x[, i]), as.numeric(y[, i]) )
+ res$local$cortest[[i]] <<- cotest
+ rsq <- CI.Rsqlm(co)
+ return(round(c(Rsq=rsq$Rsq
+ , confint=rsq$UCL - rsq$Rsq
+ , rho=cotest$estimate
+ , alpha=co$coef[2L]), 2))
+# z <- as.numeric(cor.test(x[,i], y[,i])[c('estimate', 'p.value')])
+# z[1] <- round.pretty(z[1], 2)
+# z[2] <- round.pretty(z[2], 3)
+# z
+ }
+ ))
+ #
+ ct.labs <- sapply(seq_along(ct.labs), function(i){
+ ci <- if( confint ) str_c(' +/- ', lco[i,2]) else ''
+ bquote(.(sprintf('%s (', colnames(y)[i]))
+ ~ alpha == .(sprintf(' %0.2f | ', lco[i,4]))
+ ~ rho == .(sprintf(' %.02f | ', lco[i,3]))
+ ~ R^2 == .(sprintf(' %0.2f %s)', lco[i,1], ci)))
+ })
+ }
+
+ df <- data.frame(x = melt(x), y = melt(y))
+ df[[5L]] <- factor(df[[5L]], levels = colnames(y))
+ ct <- colnames(df)[5L]
+ ct.title <- gsub('y.', '', ct, fixed = TRUE)
+ p <- ggplot(df, aes_string(x='x.value', y='y.value'
+ , color = ct)) +
+ geom_point() +
+ xlab(gpar$xlab) + ylab(gpar$ylab) +
+ scale_color_discrete(labels = ct.labs) +
+ stat_smooth(method = lm) +
+ geom_abline(slope = 1, linetype = 3) +
+ facet_grid(paste0('~ ', ct), scales = scales) +
+ labs(color = ct.title)
+ if( legend ){
+ p <- p + theme(legend.position = 'bottom') +
+ guides(color = guide_legend(ncol = 1))
+ }else{
+ p <- p + theme(legend.position = 'none')
+ }
+
+ p$correlations <- res
+ p
+}
+
+#setMethod('corplot', signature(x='NMFfitXn', y='NMF')
+# , function(x, y, pch=19, ...){
+#
+# i <- 1
+# i0 <- which.best(x)
+# i2 <- which.best(x, maxAD, y)
+# .local <- function(f, skip, order, ...){
+#
+# # reorder if necessary
+# if( !missing(order) && !is.null(order) )
+# f <- match.nmf(f, order)
+#
+# # skip if needed
+# if( i == skip )
+# return()
+#
+# # compute correlations between profiles
+# co <- diag(cor(t(scoef(f)), t(scoef(y))))
+# if( i == 1 ){
+# mp <- plot(co, ylim=c(-1,1), xaxt='n', ...)
+# mtext(side = 1, basisnames(y), at= 1:nbasis(y), line = 1)
+# }
+# else
+# lines(co, ...)
+# i <<- i+1
+#
+# }
+# lapply(x, .local, skip=i0, col="#00000010", type='l', ...)
+# .local(x[[i0]], 0, col="red", type='o', pch=19, ...)
+# .local(x[[i2]], 0, col="red", type='o', pch=19, lty='dashed', ...)
+# invisible()
+#
+# }
+#)
+
+#' Plotting Expression Profiles
+#'
+#' @export
+profplot <- function(x, ...){
+ UseMethod('profplot')
+}
+
+#'
+#' The function \code{profplot} draws plots of the basis profiles, i.e. the rows
+#' of the coefficient matrix of NMF models.
+#' A given profile is composed of the contribution of the corresponding
+#' basis to each sample.
+#'
+#' When using NMF for clustering in particular, one looks for strong
+#' associations between the basis and a priori known groups of samples.
+#' Plotting the profiles may highlight such patterns.
+#'
+#' The function can also be used to compare the profiles from two NMF models or
+#' mixture coefficient matrices. In this case, it draws a scatter plot of the
+#' paired profiles.
+#'
+#' @param x a matrix or an NMF object from which is extracted the mixture
+#' coefficient matrix. It is extracted from the best fit if \code{x} is the
+#' results from multiple NMF runs.
+#' @param y a matrix or an NMF object from which is extracted the mixture
+#' coefficient matrix.
+#' It is extracted from the best fit if \code{y} is the results from multiple NMF runs.
+#' @param scale specifies how the data should be scaled before plotting.
+#' If \code{'none'} or \code{NA}, then no scaling is applied and the "raw" data is plotted.
+#' If \code{TRUE} or \code{'max'} then each row of both matrices
+#' are normalised with their respective maximum values.
+#' If \code{'c1'}, then each column of both matrix is scaled into proportions (i.e. to sum up to one).
+#' Default is \code{'none'}.
+#' @param match.names a logical that indicates if the profiles in \code{y}
+#' should be subset and/or re-ordered to match the profile names in \code{x}
+#' (i.e. the rownames). This is attempted only when both \code{x} and \code{y}
+#' have names.
+#' @param legend a logical that specifies whether drawing the legend or not, or
+#' coordinates specifications passed to argument \code{x} of
+#' \code{\link{legend}}, that specifies the position of the legend.
+#' @param confint logical that indicates if confidence intervals for the
+#' R-squared should be shown in legend.
+#' @param Colv specifies the way the columns of \code{x} are ordered before
+#' plotting. It is used only when \code{y} is missing. It can be: \itemize{
+#' \item a single numeric value, specifying the index of a row of \code{x},
+#' that is used to order the columns by \code{x[, order(x[abs(Colv),])]}.
+#' Decreasing order is specified with a negative index. \item an integer
+#' vector directly specifying the order itself, in which case the columns are
+#' ordered by \code{x[, Colv]} \item a factor used to order the columns by
+#' \code{x[, order(Colv)]} and as argument \code{annotation} if this latter is
+#' missing or not \code{NA}. \item any other object with a suitable
+#' \code{order} method. The columns are by \code{x[, order(Colv)]} }
+#' @param labels a character vector containing labels for each sample (i.e.
+#' each column of \code{x}). These are used for labelling the x-axis.
+#' @param annotation a factor annotating each sample (i.e. each column of
+#' \code{x}). If not missing, a coloured raw is plotted under the x-axis and
+#' annotates each sample accordingly. If argument \code{Colv} is a factor, then
+#' it is used to annotate the plot, unless \code{annotation=NA}.
+#' @param ... graphical parameters passed to \code{\link{matplot}} or \code{\link{matpoints}}.
+#' @param add logical that indicates if the plot should be added as points to a previous plot
+#'
+#' @seealso \code{\link{profcor}}
+#' @keywords aplot
+#' @rdname profplot
+#' @export
+#' @S3method profplot default
+#' @examples
+#'
+#' # create a random target matrix
+#' v <- rmatrix(50, 10)
+#'
+#' # fit a single NMF model
+#' res <- nmf(v, 3)
+#' profplot(res)
+#'
+#' # ordering according to first profile
+#' profplot(res, Colv=1) # increasing
+#' profplot(res, Colv=-1) # decreasing
+#'
+#' # fit a multi-run NMF model
+#' res2 <- nmf(v, 3, nrun=3)
+#' profplot(res2)
+#'
+#' # draw a profile correlation plot: this show how the basis components are
+#' # returned in an unpredictable order
+#' profplot(res, res2)
+#'
+#' # looking at all the correlations allow to order the components in a "common" order
+#' profcor(res, res2)
+#'
+profplot.default <- function(x, y, scale=c('none', 'max', 'c1'), match.names=TRUE
+ , legend=TRUE, confint=TRUE
+ , Colv, labels, annotation, ..., add = FALSE){
+
+ # initialise result list
+ res <- list()
+ # get extra graphical parameters
+ gpar <- list(...)
+
+ # plot a correlation plot of y is not missing
+ if( !missing(y) ){
+ xvar <- deparse(substitute(x))
+ # extract mixture coefficient from x
+ if( isNMFfit(x) ){
+ gpar <- .set.list.defaults(gpar
+ , xlab=paste("NMF model", xvar, "- Method:", algorithm(x)))
+ x <- fit(x)
+ }
+ if( is.nmf(x) ){
+ gpar <- .set.list.defaults(gpar
+ , main="Mixture coefficient profile correlations"
+ , xlab=paste("NMF model", xvar))
+ x <- coef(x)
+
+ if( is.null(rownames(x)) )
+ rownames(x) <- paste("basis", 1:nrow(x), sep='_')
+ }else if( is(x, 'ExpressionSet') ){
+ x <- Biobase::exprs(x)
+ gpar <- .set.list.defaults(gpar
+ , main="Expression profile correlations"
+ , xlab=paste("ExpressionSet", xvar))
+ }else{
+ gpar <- .set.list.defaults(gpar
+ , xlab=paste("Matrix ", xvar))
+ }
+ # at this stage x must be a matrix
+ if( !is.matrix(x) )
+ stop("NMF::profplot - Invalid argument `x`: could not extract mixture coefficient matrix")
+
+ # extract mixture coefficient from y
+ yvar <- deparse(substitute(y))
+ if( isNMFfit(y) ){
+ gpar <- .set.list.defaults(gpar
+ , ylab=paste("NMF model", yvar, "- Method:", algorithm(y)))
+ y <- fit(y)
+ }
+ if( is.nmf(y) ){
+ gpar <- .set.list.defaults(gpar
+ , main="Mixture coefficient profile correlations"
+ , ylab=paste("NMF model", yvar))
+ y <- coef(y)
+ }else if( is(y, 'ExpressionSet') ){
+ y <- Biobase::exprs(y)
+ gpar <- .set.list.defaults(gpar
+ , main="Expression profile correlations"
+ , ylab=paste("ExpressionSet", yvar))
+ }else{
+ gpar <- .set.list.defaults(gpar
+ , ylab=paste("Matrix ", yvar))
+ }
+ # at this stage y must be a matrix
+ if( !is.matrix(y) )
+ stop("NMF::profplot - Invalid argument `y`: could not extract profile matrix")
+
+ # match names if requested
+ if( match.names && !is.null(rownames(x)) && !is.null(rownames(y)) ){
+ # match the row in x to the rows in y
+ y.idx <- match(rownames(x), rownames(y), nomatch=0L)
+ x.idx <- which(y.idx!=0L)
+ # subset and reorder if possible
+ if( length(x.idx) > 0L ){
+ res$y.idx <- y.idx[x.idx]
+ y <- y[y.idx, , drop = FALSE]
+ res$x.idx <- x.idx
+ x <- x[x.idx, , drop = FALSE]
+ }
+ }
+
+ # scale to proportions if requested
+ if( missing(scale) ) scale <- NULL
+ else if( isTRUE(scale) ) scale <- 'max'
+ else if( isFALSE(scale) ) scale <- 'none'
+ scale <- match.arg(scale)
+ scales <- 'free'
+ if( scale == 'max' ){
+ gpar <- .set.list.defaults(gpar
+ , xlim=c(0,1), ylim=c(0,1))
+ # scale x
+ iscale <- (xm <- apply(abs(x), 1L, max)) > 0
+ x[iscale, ] <- sweep(x[iscale, , drop = FALSE], 1L, xm[iscale], '/')
+ # scale y
+ iscale <- (ym <- apply(abs(y), 1L, max)) > 0
+ y[iscale, ] <- sweep(y[iscale, , drop = FALSE], 1L, ym[iscale], '/')
+ scales <- 'fixed'
+ } else if( scale == 'c1' ){
+ gpar <- .set.list.defaults(gpar
+ , xlim=c(0,1), ylim=c(0,1))
+ x <- sum2one(x)
+ y <- sum2one(y)
+ }else{
+ Mx <- max(x, y); mx <- min(x, y)
+ # extend default limits by a 0.25 factor
+ Mx <- Mx * 1.25
+ mx <- mx * 0.75
+ gpar <- .set.list.defaults(gpar
+ , xlim=c(mx,Mx), ylim=c(mx,Mx))
+ }
+
+
+ gpar <- .set.list.defaults(gpar
+ , main="Profile correlations")
+ # plot the correlation plot
+ p <- do.call(corplot, c(list(x=t(x), y=t(y), scales = scales, legend=legend, confint=confint, add=add), gpar))
+ p <- expand_list(p, list(idx.map = res))
+
+ # return result list
+ return( p )
+ }
+
+ # extract mixture coefficient
+ xvar <- deparse(substitute(x))
+ if( isNMFfit(x) ){
+ gpar <- .set.list.defaults(gpar, main=paste("Mixture coefficient profiles\nNMF method:", algorithm(x), "- runs:", nrun(x)))
+ x <- fit(x)
+ }
+ if( is.nmf(x) ){
+ gpar <- .set.list.defaults(gpar, main="Mixture coefficient profiles")
+ x <- coef(x)
+ }else if( is(x, 'ExpressionSet') ){
+ x <- Biobase::exprs(x)
+ gpar <- .set.list.defaults(gpar, main="Expression profiles")
+ }
+
+ # at this stage x must be a matrix
+ if( !is.matrix(x) )
+ stop("NMF::profplot - Invalid argument `x`: could not extract profile matrix")
+
+ # scale to proportions if requested
+ if( missing(scale) || !isTRUE(scale) ) scale <- FALSE
+ if( scale ){
+ gpar <- .set.list.defaults(gpar, ylim=c(0,1))
+ x <- sum2one(x)
+ }
+
+ # reorder the samples if requested
+ if( missing(labels) ){
+ labels <-
+ if( !is.null(colnames(x)) ) colnames(x)
+ else 1:ncol(x)
+ } else if( length(labels) != ncol(x) ){
+ labels <- rep(labels, length.out=ncol(x))
+# stop("NMF::profplot - Invalid argument `labels`: length should be equal to the number of columns in ", xvar, " [=", ncol(x),"]")
+ }
+
+ # check annotation
+ if( !missing(annotation) && length(annotation) != ncol(x) )
+ stop("NMF::profplot - Invalid argument `annotation`:: length should be equal to the number of columns in ", xvar, " [=", ncol(x),"]")
+
+ # reorder the columns if requested
+ if( !missing(Colv) && !is_NA(Colv) ){
+
+ ord <- if( length(Colv) == 1 ){
+ if( !is.numeric(Colv) || abs(Colv) > nrow(x) )
+ stop("NMF::profplot - Invalid singel argument `Colv`: should be an integer between -nrow(x) and nrow(", xvar,") (i.e. [[-", nrow(x),",", nrow(x),"]])")
+ order(x[abs(Colv),], decreasing=Colv<0)
+ }else{
+ if( length(Colv) != ncol(x) )
+ stop("NMF::profplot - Invalid length for argument `Colv`: should be of length ncol(", xvar, ") [=", nrow(x),"]")
+
+ if( is.integer(Colv) && length(setdiff(Colv, 1:ncol(x)))==0 ) Colv
+ else order(Colv)
+ }
+
+ # use Colv as annotation if not requested otherwise
+ if( missing(annotation) && is.factor(Colv) )
+ annotation <- Colv
+
+ # reorder all relevant quantities
+ x <- x[,ord]
+ labels <- labels[ord]
+ if( !missing(annotation) && !is_NA(annotation) )
+ annotation <- annotation[ord]
+ }
+
+ # set default arguments
+ cols <- rainbow(nrow(x))
+ gpar <- .set.list.defaults(gpar
+ , xlab="Samples"
+ , ylab="Mixture coefficient value"
+ , main="Profile plot"
+ , type='o'
+ , lty=1
+ , pch=19
+ , cex=0.8
+ , col=cols)
+
+ # plot using matplot
+ do.call(matplot, c(list(x=t(x)), gpar, xaxt='n'))
+
+ # add legend if requested
+ if( !isFALSE(legend) ){
+ if( isTRUE(legend) )
+ legend <- 'topleft'
+
+ # use the rownames for the legend
+ leg <- rownames(x)
+ if( is.null(leg) )
+ leg <- paste('basis', 1:nrow(x), sep='_')
+ legend(legend, legend=leg, col=gpar$col, lwd=1, pch=gpar$pch)
+ }
+
+ # axis ticks
+ px <- 1:ncol(x)
+ axis(1, at = px, labels = FALSE)
+
+ # setup grid-base mixed graphic
+ vps <- baseViewports()
+ pushViewport(vps$inner, vps$figure, vps$plot)
+ # clean up on exit
+ on.exit(popViewport(3), add=TRUE)
+
+ voffset <- 1
+ # add sample annotation
+ if( !missing(annotation) && !is_NA(annotation) && is.factor(annotation) ){
+
+ grid.rect(x = unit(px, "native"), unit(-voffset, "lines")
+ , width = unit(1, 'native'), height = unit(1, "lines")
+ , gp = gpar(fill=alphacol(rainbow(nlevels(annotation))[annotation], 50), col = 'gray'))
+ voffset <- voffset+1
+ }
+
+ # add labels
+ if( !is_NA(labels) ){
+ # setup grid-base mixed graphic
+ #library(gridBase)
+ #vps <- baseViewports()
+ #pushViewport(vps$inner, vps$figure, vps$plot)
+
+ # add axis
+ adj <- if( is.character(labels) && max(nchar(labels)) >= 7 ) list(just='right', rot=45)
+ else list(just='center', rot=0)
+ grid.text(labels
+ , x = unit(px, "native"), y = unit(-voffset,"lines")
+ , just = adj$just, rot = adj$rot)
+ voffset <- voffset+1
+ # clean up on exit
+ #popViewport(3)
+ }
+
+ invisible(nrow(x))
+ # add xlab
+ #if( nchar(xlab) > 0 )
+ # grid.text(xlab, x = unit(length(px)/2, "native"), y = unit(-voffset,"lines"), just = 'center')
+
+}
+
+#setGeneric('profplot', function(x, y, ...) standardGeneric('profplot'))
+#setMethod('profplot', signature(x='matrix', y='missing')
+# , function(x, y, ...){
+#
+# gpar <- .set.list.defaults(list(...)
+# , xlim=c(0,1), ylim=c(0,1)
+# , main="Profile plot"
+# , type='b'
+# , pch=19)
+#
+# do.call(matplot, c(gpar, x=t(sum2one(x)), y=t(sum2one(y))))
+# }
+#)
+#setMethod('profplot', signature(x='matrix', y='matrix')
+# , function(x, y, scale=FALSE, ...){
+#
+# # x is the reference, y the estimation
+# if( scale ){
+# gpar <- .set.list.defaults(list(...)
+# , xlim=c(0,1), ylim=c(0,1)
+# , main="Profile correlation plot")
+# do.call(corplot, c(gpar, x=t(sum2one(x)), y=t(sum2one(y))))
+# }else
+# corplot(t(x), t(y), ...)
+#
+# }
+#)
+#setMethod('profplot', signature(x='matrix', y='NMF')
+# , function(x, y, ...){
+# profplot(x, coef(y), ...)
+# }
+#)
+#setMethod('profplot', signature(x='NMF', y='ANY')
+# , function(x, y, ...){
+# profplot(coef(x), y, ...)
+# }
+#)
+#setMethod('profplot', signature(x='matrix', y='NMFfit')
+# , function(x, y, ...){
+#
+# if( !missing(y) ){ # x is the reference, y the estimation
+#
+# # map components to the references
+# title <- paste("Profile correlation plot - Method:", algorithm(y))
+# gpar <- .set.list.defaults(list(...),
+# list(main=title))
+# do.call(profplot, c(gpar, x=x, y=fit(y)))
+# }
+# }
+#)
+#setMethod('profplot', signature(x='matrix', y='NMFfitXn')
+# , function(x, y, ...){
+# profplot(x, minfit(y), ...)
+# }
+#)
+#setMethod('profplot', signature(x='NMFfitXn', y='ANY')
+# , function(x, y, ...){
+# profplot(minfit(x), y, ...)
+# }
+#)
+
+#' Silhouette of NMF Clustering
+#'
+#' @param x an NMF object, as returned by \code{\link{nmf}}.
+#' @param what defines the type of clustering the computed silhouettes are
+#' meant to assess: \code{'samples'} for the clustering of samples
+#' (i.e. the columns of the target matrix),
+#' \code{'features'} for the clustering of features (i.e. the rows of the
+#' target matrix), and \code{'chc'} for the consensus clustering of samples as
+#' defined by hierarchical clustering dendrogram, \code{'consensus'} for the
+#' consensus clustering of samples, with clustered ordered as in the
+#' \strong{default} hierarchical clustering used by
+#' \code{\link{consensusmap}} when plotting the heatmap of the consensus matrix
+#' (for multi-run NMF fits).
+#' That is \code{dist = 1 - consensus(x)}, average linkage and reordering based
+#' on row means.
+#' @param order integer indexing vector that can be used to force the silhouette
+#' order.
+#' @param ... extra arguments not used.
+#'
+#' @seealso \code{\link[NMF]{predict}}
+#' @S3method silhouette NMF
+#' @import cluster
+#' @examples
+#'
+#' x <- rmatrix(100, 20, dimnames = list(paste0('a', 1:100), letters[1:20]))
+#' # NB: using low value for maxIter for the example purpose only
+#' res <- nmf(x, 4, nrun = 5, maxIter = 50)
+#'
+#' # sample clustering from best fit
+#' plot(silhouette(res))
+#'
+#' # from consensus
+#' plot(silhouette(res, what = 'consensus'))
+#'
+#' # feature clustering
+#' plot(silhouette(res, what = 'features'))
+#'
+#' # average silhouette are computed in summary measures
+#' summary(res)
+#'
+#' # consensus silhouettes are ordered as on default consensusmap heatmap
+#' \dontrun{ op <- par(mfrow = c(1,2)) }
+#' consensusmap(res)
+#' si <- silhouette(res, what = 'consensus')
+#' plot(si)
+#' \dontrun{ par(op) }
+#'
+#' # if the order is based on some custom numeric weights
+#' \dontrun{ op <- par(mfrow = c(1,2)) }
+#' cm <- consensusmap(res, Rowv = runif(ncol(res)))
+#' # NB: use reverse order because silhouettes are plotted top-down
+#' si <- silhouette(res, what = 'consensus', order = rev(cm$rowInd))
+#' plot(si)
+#' \dontrun{ par(op) }
+#'
+#' # do the reverse: order the heatmap as a set of silhouettes
+#' si <- silhouette(res, what = 'features')
+#' \dontrun{ op <- par(mfrow = c(1,2)) }
+#' basismap(res, Rowv = si)
+#' plot(si)
+#' \dontrun{ par(op) }
+#'
+silhouette.NMF <- function(x, what = NULL, order = NULL, ...){
+
+ # compute prediction
+ p <- predict(x, what = what, dmatrix = TRUE)
+ # compute silhouette
+ si <- silhouette(as.numeric(p), dmatrix = attr(p, 'dmatrix'))
+ attr(si, 'call') <- match.call(call = sys.call(-1))
+ if( is_NA(si) ) return(NA)
+ # fix rownames if necessary
+ if( is.null(rownames(si)) ){
+ rownames(si) <- names(p)
+ if( is.null(rownames(si)) )
+ rownames(si) <- 1:nrow(si)
+ }
+
+ if( is.null(order) && !is.null(attr(p, 'iOrd')) ){
+ # reorder as defined in prediction
+ order <- attr(p, 'iOrd')
+ }
+
+ # order the silhouette
+ if( !is.null(order) && !is_NA(order) ){
+ si[1:nrow(si), ] <- si[order, , drop = FALSE]
+ rownames(si) <- rownames(si)[order]
+ attr(si, 'iOrd') <- order
+ attr(si, 'Ordered') <- TRUE
+ }
+
+ si
+}
+
+#' @S3method silhouette NMFfitX
+silhouette.NMFfitX <- function(x, ...){
+ si <- silhouette.NMF(x, ...)
+ attr(si, 'call') <- match.call(call = sys.call(-1))
+ si
+}
diff --git a/R/NMFstd-class.R b/R/NMFstd-class.R
new file mode 100644
index 0000000..91e3869
--- /dev/null
+++ b/R/NMFstd-class.R
@@ -0,0 +1,227 @@
+# Class that implements the standard NMF model
+#
+# Author: Renaud Gaujoux \email{renaud@@cbio.uct.ac.za}
+###############################################################################
+
+#' @include NMF-class.R
+NULL
+
+#' NMF Model - Standard model
+#'
+#' This class implements the standard model of Nonnegative Matrix
+#' Factorization.
+#' It provides a general structure and generic functions to manage
+#' factorizations that follow the standard NMF model, as defined by
+#' \cite{Lee2001}.
+#'
+#' Let \eqn{V} be a \eqn{n \times m} non-negative matrix and \eqn{r} a positive
+#' integer. In its standard form (see references below), a NMF of \eqn{V} is
+#' commonly defined as a pair of matrices \eqn{(W, H)} such that:
+#'
+#' \deqn{V \equiv W H,}
+#'
+#' where:
+#' \itemize{
+#' \item \eqn{W} and \eqn{H} are \eqn{n \times r} and \eqn{r
+#' \times m} matrices respectively with non-negative entries;
+#' \item \eqn{\equiv} is to be understood with respect to some loss function.
+#' Common choices of loss functions are based on Frobenius norm or Kullback-Leibler
+#' divergence.
+#' }
+#'
+#' Integer \eqn{r} is called the \emph{factorization rank}.
+#' Depending on the context of application of NMF, the columns of \eqn{W}
+#' and \eqn{H} are given different names:
+#' \describe{
+#' \item{columns of \code{W}}{basis vector, metagenes, factors, source, image basis}
+#' \item{columns of \code{H}}{mixture coefficients, metagene sample expression profiles, weights}
+#' \item{rows of \code{H}}{basis profiles, metagene expression profiles}
+#' }
+#'
+#' NMF approaches have been successfully applied to several fields.
+#' The package NMF was implemented trying to use names as generic as possible
+#' for objects and methods.
+#'
+#' The following terminology is used:
+#' \describe{
+#' \item{samples}{the columns of the target matrix \eqn{V}}
+#' \item{features}{the rows of the target matrix \eqn{V}}
+#' \item{basis matrix}{the first matrix factor \eqn{W}}
+#' \item{basis vectors}{the columns of first matrix factor \eqn{W}}
+#' \item{mixture matrix}{the second matrix factor \eqn{H}} \item{mixtures
+#' coefficients}{the columns of second matrix factor \eqn{H}}
+#' }
+#'
+#' However, because the package NMF was primarily implemented to work with gene
+#' expression microarray data, it also provides a layer to easily and
+#' intuitively work with objects from the Bioconductor base framework.
+#' See \link{bioc-NMF} for more details.
+#'
+#' @slot W A \code{matrix} that contains the basis matrix, i.e. the \emph{first}
+#' matrix factor of the factorisation
+#' @slot H A \code{matrix} that contains the coefficient matrix, i.e. the
+#' \emph{second} matrix factor of the factorisation
+#' @slot bterms a \code{data.frame} that contains the primary data that
+#' define fixed basis terms. See \code{\link{bterms}}.
+#' @slot ibterms integer vector that contains the indexes of the basis components
+#' that are fixed, i.e. for which only the coefficient are estimated.
+#'
+#' IMPORTANT: This slot is set on construction of an NMF model via
+#' \code{\link[=nmfModel,formula,ANY-method]{nmfModel}} and is not recommended to
+#' not be subsequently changed by the end-user.
+#' @slot cterms a \code{data.frame} that contains the primary data that
+#' define fixed coefficient terms. See \code{\link{cterms}}.
+#' @slot icterms integer vector that contains the indexes of the basis components
+#' that have fixed coefficients, i.e. for which only the basis vectors are estimated.
+#'
+#' IMPORTANT: This slot is set on construction of an NMF model via
+#' \code{\link[=nmfModel,formula,ANY-method]{nmfModel}} and is not recommended to
+#' not be subsequently changed by the end-user.
+#'
+#' @export
+#' @family NMF-model
+#' @examples
+#' # create a completely empty NMFstd object
+#' new('NMFstd')
+#'
+#' # create a NMF object based on one random matrix: the missing matrix is deduced
+#' # Note this only works when using factory method NMF
+#' n <- 50; r <- 3;
+#' w <- rmatrix(n, r)
+#' nmfModel(W=w)
+#'
+#' # create a NMF object based on random (compatible) matrices
+#' p <- 20
+#' h <- rmatrix(r, p)
+#' nmfModel(W=w, H=h)
+#'
+#' # create a NMF object based on incompatible matrices: generate an error
+#' h <- rmatrix(r+1, p)
+#' try( new('NMFstd', W=w, H=h) )
+#' try( nmfModel(w, h) )
+#'
+#' # Giving target dimensions to the factory method allow for coping with dimension
+#' # incompatibilty (a warning is thrown in such case)
+#' nmfModel(r, W=w, H=h)
+#'
+setClass('NMFstd'
+ , representation(
+ W = 'matrix' # basis matrix
+ , H = 'matrix' # mixture coefficients matrix
+ , bterms = 'data.frame' # fixed basis terms: nrow(bterms) = nrow(x)
+ , ibterms = 'integer' # index of the fixed basis terms
+ , cterms = 'data.frame' # fixed coef terms: ncol(cterms) = ncol(x)
+ , icterms = 'integer' # index of the fixed coefficient terms
+ )
+
+ , prototype = prototype(
+ W = matrix(as.numeric(NA), 0, 0),
+ H = matrix(as.numeric(NA), 0, 0)
+ )
+
+ , validity = function(object){
+
+ # dimension compatibility: W and H must be compatible for matrix multiplication
+ if( ncol(object at W) != nrow(object at H) ){
+ return(paste('Dimensions of W and H are not compatible [ncol(W)=', ncol(object at W) , '!= nrow(H)=', nrow(object at H), ']'))
+ }
+ # give a warning if the dimensions look strange: rank greater than the number of samples
+ if( !is.empty.nmf(object) && ncol(object at H) && ncol(object at W) > ncol(object at H) ){
+ warning(paste('Dimensions of W and H look strange [ncol(W)=', ncol(object at W) , '> ncol(H)=', ncol(object at H), ']'))
+ }
+
+ # everything went fine: return TRUE
+ return(TRUE)
+ }
+ , contains = 'NMF'
+)
+
+
+#' Get the basis matrix in standard NMF models
+#'
+#' This function returns slot \code{W} of \code{object}.
+#'
+#' @examples
+#' # random standard NMF model
+#' x <- rnmf(3, 10, 5)
+#' basis(x)
+#' coef(x)
+#'
+#' # set matrix factors
+#' basis(x) <- matrix(1, nrow(x), nbasis(x))
+#' coef(x) <- matrix(1, nbasis(x), ncol(x))
+#' # set random factors
+#' basis(x) <- rmatrix(basis(x))
+#' coef(x) <- rmatrix(coef(x))
+#'
+#' # incompatible matrices generate an error:
+#' try( coef(x) <- matrix(1, nbasis(x)-1, nrow(x)) )
+#' # but the low-level method allow it
+#' .coef(x) <- matrix(1, nbasis(x)-1, nrow(x))
+#' try( validObject(x) )
+#'
+setMethod('.basis', 'NMFstd',
+ function(object){
+ object at W
+ }
+)
+#' Set the basis matrix in standard NMF models
+#'
+#' This function sets slot \code{W} of \code{object}.
+setReplaceMethod('.basis', signature(object='NMFstd', value='matrix'),
+ function(object, value){
+ object at W <- value
+ object
+ }
+)
+
+#' Get the mixture coefficient matrix in standard NMF models
+#'
+#' This function returns slot \code{H} of \code{object}.
+setMethod('.coef', 'NMFstd',
+ function(object){
+ object at H
+ }
+)
+#' Set the mixture coefficient matrix in standard NMF models
+#'
+#' This function sets slot \code{H} of \code{object}.
+setReplaceMethod('.coef', signature(object='NMFstd', value='matrix'),
+ function(object, value){
+ object at H <- value
+ object
+ }
+)
+
+#' Compute the target matrix estimate in \emph{standard NMF models}.
+#'
+#' The estimate matrix is computed as the product of the two matrix slots
+#' \code{W} and \code{H}:
+#' \deqn{\hat{V} = W H}{V ~ W H}
+#'
+#' @param W a matrix to use in the computation as the basis matrix in place of
+#' \code{basis(object)}.
+#' It must be compatible with the coefficient matrix used
+#' in the computation (i.e. number of columns in \code{W} = number of rows in \code{H}).
+#' @param H a matrix to use in the computation as the coefficient matrix in place of
+#' \code{coef(object)}.
+#' It must be compatible with the basis matrix used
+#' in the computation (i.e. number of rows in \code{H} = number of columns in \code{W}).
+#'
+#' @export
+#' @inline
+#'
+#' @examples
+#' # random standard NMF model
+#' x <- rnmf(3, 10, 5)
+#' all.equal(fitted(x), basis(x) %*% coef(x))
+#'
+#'
+setMethod('fitted', signature(object='NMFstd'),
+ function(object, W, H, ...){
+ if( missing(W) ) W <- object at W
+ if( missing(H) ) H <- object at H
+ return(W %*% H)
+ }
+)
+
diff --git a/R/aheatmap.R b/R/aheatmap.R
new file mode 100644
index 0000000..0882f98
--- /dev/null
+++ b/R/aheatmap.R
@@ -0,0 +1,2168 @@
+#' @include atracks.R
+#' @include grid.R
+#' @include colorcode.R
+NULL
+
+library(grid)
+library(gridBase)
+
+# extends gpar objects
+c_gpar <- function(gp, ...){
+ x <- list(...)
+ do.call(gpar, c(gp, x[!names(x) %in% names(gp)]))
+}
+
+
+lo <- function (rown, coln, nrow, ncol, cellheight = NA, cellwidth = NA
+, treeheight_col, treeheight_row, legend, main = NULL, sub = NULL, info = NULL
+, annTracks, annotation_legend
+, fontsize, fontsize_row, fontsize_col, gp = gpar()){
+
+ annotation_colors <- annTracks$colors
+ row_annotation <- annTracks$annRow
+ annotation <- annTracks$annCol
+
+ gp0 <- gp
+ coln_height <- unit(10, "bigpts")
+ if(!is.null(coln)){
+ longest_coln = which.max(nchar(coln))
+ coln_height <- coln_height + unit(1.1, "grobheight", textGrob(coln[longest_coln], rot = 90, gp = c_gpar(gp, fontsize = fontsize_col)))
+ }
+
+ rown_width <- rown_width_min <- unit(10, "bigpts")
+ if(!is.null(rown)){
+ longest_rown = which.max(nchar(rown))
+ rown_width <- rown_width_min + unit(1.2, "grobwidth", textGrob(rown[longest_rown], gp = c_gpar(gp, fontsize = fontsize_row)))
+ }
+
+ gp = c_gpar(gp, fontsize = fontsize)
+ # Legend position
+ if( !is_NA(legend) ){
+ longest_break = which.max(nchar(as.character(legend)))
+ longest_break = unit(1.1, "grobwidth", textGrob(as.character(legend)[longest_break], gp = gp))
+ # minimum fixed width: plan for 2 decimals and a sign
+ min_lw = unit(1.1, "grobwidth", textGrob("-00.00", gp = gp))
+ longest_break = max(longest_break, min_lw)
+ title_length = unit(1.1, "grobwidth", textGrob("Scale", gp = c_gpar(gp0, fontface = "bold")))
+ legend_width = unit(12, "bigpts") + longest_break * 1.2
+ legend_width = max(title_length, legend_width)
+ }
+ else{
+ legend_width = unit(0, "bigpts")
+ }
+
+ .annLegend.dim <- function(annotation, fontsize){
+ # Width of the corresponding legend
+ longest_ann <- unlist(lapply(annotation, names))
+ longest_ann <- longest_ann[which.max(nchar(longest_ann))]
+ annot_legend_width = unit(1, "grobwidth", textGrob(longest_ann, gp = gp)) + unit(10, "bigpts")
+
+ # width of the legend title
+ annot_legend_title <- names(annotation)[which.max(nchar(names(annotation)))]
+ annot_legend_title_width = unit(1, "grobwidth", textGrob(annot_legend_title, gp = c_gpar(gp, fontface = "bold")))
+
+ # total width
+ max(annot_legend_width, annot_legend_title_width) + unit(5, "bigpts")
+ }
+
+ # Column annotations
+ if( !is_NA(annotation) ){
+ # Column annotation height
+ annot_height = unit(ncol(annotation) * (8 + 2) + 2, "bigpts")
+ }
+ else{
+ annot_height = unit(0, "bigpts")
+ }
+
+ # add a viewport for the row annotations
+ if ( !is_NA(row_annotation) ) {
+ # Row annotation width
+ row_annot_width = unit(ncol(row_annotation) * (8 + 2) + 2, "bigpts")
+ }
+ else {
+ row_annot_width = unit(0, "bigpts")
+ }
+
+ # Width of the annotation legend
+ annot_legend_width <-
+ if( annotation_legend && !is_NA(annotation_colors) ){
+ .annLegend.dim(annotation_colors, fontsize)
+ }else unit(0, "bigpts")
+
+ # Tree height
+ treeheight_col = unit(treeheight_col, "bigpts") + unit(5, "bigpts")
+ treeheight_row = unit(treeheight_row, "bigpts") + unit(5, "bigpts")
+
+ # main title
+ main_height <- if(!is.null(main)) unit(1, "grobheight", main) + unit(20, "bigpts") else unit(0, "bigpts")
+ # sub title
+ sub_height <- if(!is.null(sub)) unit(1, "grobheight", sub) + unit(10, "bigpts") else unit(0, "bigpts")
+ # info panel
+ if( !is.null(info) ){
+ info_height <- unit(1, "grobheight", info) + unit(20, "bigpts")
+ info_width <- unit(1, "grobwidth", info) + unit(10, "bigpts")
+ }else{
+ info_height <- unit(0, "bigpts")
+ info_width <- unit(0, "bigpts")
+ }
+
+ # Set cell sizes
+ if(is.na(cellwidth)){
+ matwidth = unit(1, "npc") - rown_width - legend_width - row_annot_width - treeheight_row - annot_legend_width
+ }
+ else{
+ matwidth = unit(cellwidth * ncol, "bigpts")
+ }
+
+ if(is.na(cellheight)){
+ matheight = unit(1, "npc") - treeheight_col - annot_height - main_height - coln_height - sub_height - info_height
+
+ # recompute the cell width depending on the automatic fontsize
+ if( is.na(cellwidth) && !is.null(rown) ){
+ cellheight <- convertHeight(unit(1, "grobheight", rectGrob(0,0, matwidth, matheight)), "bigpts", valueOnly = T) / nrow
+ fontsize_row <- convertUnit(min(unit(fontsize_row, 'points'), unit(0.6*cellheight, 'bigpts')), 'points')
+
+ rown_width <- rown_width_min + unit(1.2, "grobwidth", textGrob(rown[longest_rown], gp = c_gpar(gp0, fontsize = fontsize_row)))
+ matwidth <- unit(1, "npc") - rown_width - legend_width - row_annot_width - treeheight_row - annot_legend_width
+ }
+ }
+ else{
+ matheight = unit(cellheight * nrow, "bigpts")
+ }
+
+ # HACK:
+ # - use 6 instead of 5 column for the row_annotation
+ # - take into account the associated legend's width
+ # Produce layout()
+ unique.name <- vplayout(NULL)
+ lo <- grid.layout(nrow = 7, ncol = 6
+ , widths = unit.c(treeheight_row, row_annot_width, matwidth, rown_width, legend_width, annot_legend_width)
+ , heights = unit.c(main_height, treeheight_col, annot_height, matheight, coln_height, sub_height, info_height))
+ hvp <- viewport( name=paste('aheatmap', unique.name, sep='-'), layout = lo)
+ pushViewport(hvp)
+
+ #grid.show.layout(lo); stop('sas')
+ # Get cell dimensions
+ vplayout('mat')
+ cellwidth = convertWidth(unit(1, "npc"), "bigpts", valueOnly = T) / ncol
+ cellheight = convertHeight(unit(1, "npc"), "bigpts", valueOnly = T) / nrow
+ upViewport()
+
+ height <- as.numeric(convertHeight(sum(lo$height), "inches"))
+ width <- as.numeric(convertWidth(sum(lo$width), "inches"))
+ # Return minimal cell dimension in bigpts to decide if borders are drawn
+ mindim = min(cellwidth, cellheight)
+ return( list(width=width, height=height, vp=hvp, mindim=mindim, cellwidth=cellwidth, cellheight=cellheight) )
+}
+
+draw_dendrogram = function(hc, horizontal = T){
+
+# .draw.dendrodram <- function(hc){
+#
+# # convert into an hclust if necessary
+# if( is(hc, 'dendrogram') ){
+# hca <- attr(hc, 'hclust')
+# hc <- if( !is.null(hca) ) hca else as.hclust(hc)
+# }
+#
+# h = hc$height / max(hc$height) / 1.05
+# m = hc$merge
+# o = hc$order
+# n = length(o)
+#
+# m[m > 0] = n + m[m > 0]
+# m[m < 0] = abs(m[m < 0])
+#
+# dist = matrix(0, nrow = 2 * n - 1, ncol = 2, dimnames = list(NULL, c("x", "y")))
+# dist[1:n, 1] = 1 / n / 2 + (1 / n) * (match(1:n, o) - 1)
+#
+# for(i in 1:nrow(m)){
+# dist[n + i, 1] = (dist[m[i, 1], 1] + dist[m[i, 2], 1]) / 2
+# dist[n + i, 2] = h[i]
+# }
+#
+# draw_connection = function(x1, x2, y1, y2, y){
+# grid.lines(x = c(x1, x1), y = c(y1, y))
+# grid.lines(x = c(x2, x2), y = c(y2, y))
+# grid.lines(x = c(x1, x2), y = c(y, y))
+# }
+#
+# # create a rotating viewport for vertical dendrogram
+# if(!horizontal){
+# gr = rectGrob()
+# pushViewport(viewport(height = unit(1, "grobwidth", gr), width = unit(1, "grobheight", gr), angle = 90))
+# on.exit(upViewport())
+# }
+#
+# for(i in 1:nrow(m)){
+# draw_connection(dist[m[i, 1], 1], dist[m[i, 2], 1], dist[m[i, 1], 2], dist[m[i, 2], 2], h[i])
+# }
+#
+# }
+
+ .draw.dendrodram <- function(hc, ...){
+# suppressWarnings( opar <- par(plt = gridPLT(), new = TRUE) )
+ ( opar <- par(plt = gridPLT(), new = TRUE) )
+ on.exit(par(opar))
+ if( getOption('verbose') ) grid.rect(gp = gpar(col = "blue", lwd = 2))
+ if( !is(hc, 'dendrogram') )
+ hc <- as.dendrogram(hc)
+ plot(hc, horiz=!horizontal, xaxs="i", yaxs="i", axes=FALSE, leaflab="none", ...)
+ }
+
+
+ # create a margin viewport
+ if(!horizontal)
+ pushViewport( viewport(x=0,y=0,width=0.9,height=1,just=c("left", "bottom")) )
+ else
+ pushViewport( viewport(x=0,y=0.1,width=1,height=0.9,just=c("left", "bottom")) )
+ on.exit(upViewport())
+
+ .draw.dendrodram(hc)
+
+}
+
+# draw a matrix first row at bottom, last at top
+draw_matrix = function(matrix, border_color, txt = NULL, gp = gpar()){
+ n = nrow(matrix)
+ m = ncol(matrix)
+ x = (1:m)/m - 1/2/m
+ y = (1:n)/n - 1/2/n
+
+ # substitute NA values with empty strings
+ if( !is.null(txt) ) txt[is.na(txt)] <- ''
+
+ for(i in 1:m){
+ grid.rect(x = x[i], y = y, width = 1/m, height = 1/n, gp = gpar(fill = matrix[,i], col = border_color))
+ if( !is.null(txt) ){
+ grid.text(label=txt[, i],
+ x=x[i],
+ y=y,
+# just=just,
+# hjust=hjust,
+# vjust=vjust,
+ rot=0,
+ check.overlap= FALSE, #check.overlap,
+ default.units= 'npc', #default.units,
+# name=name,
+ gp=gp,
+# draw=draw,
+# vp=vp
+ )
+ }
+ }
+}
+
+draw_colnames = function(coln, gp = gpar()){
+
+ m = length(coln)
+
+ # decide on the label orientation
+ width <- m * unit(1, "grobwidth", textGrob(coln[i <- which.max(nchar(coln))], gp = gp))
+ width <- as.numeric(convertWidth(width, "inches"))
+ gwidth <- as.numeric(convertWidth(unit(1, 'npc'), "inches"))
+ y <- NULL
+ if( gwidth < width ){
+ rot <- 270
+ vjust <- 0.5
+ hjust <- 0
+ y <- unit(1, 'npc') - unit(5, 'bigpts')
+ }else{
+ rot <- 0
+ vjust <- 0.5
+ hjust <- 0.5
+ }
+ if( is.null(y) ){
+ height <- unit(1, "grobheight", textGrob(coln[i], vjust = vjust, hjust = hjust, rot=rot, gp = gp))
+ y <- unit(1, 'npc') - height
+ }
+
+ x = (1:m)/m - 1/2/m
+ grid.text(coln, x = x, y = y, vjust = vjust, hjust = hjust, rot=rot, gp = gp)
+}
+
+# draw rownames first row at bottom, last on top
+draw_rownames = function(rown, gp = gpar()){
+ n = length(rown)
+ y = (1:n)/n - 1/2/n
+ grid.text(rown, x = unit(5, "bigpts"), y = y, vjust = 0.5, hjust = 0, gp = gp)
+}
+
+draw_legend = function(color, breaks, legend, gp = gpar()){
+ height = min(unit(1, "npc"), unit(150, "bigpts"))
+ pushViewport(viewport(x = 0, y = unit(1, "npc"), just = c(0, 1), height = height))
+ legend_pos = (legend - min(breaks)) / (max(breaks) - min(breaks))
+ breaks = (breaks - min(breaks)) / (max(breaks) - min(breaks))
+ h = breaks[-1] - breaks[-length(breaks)]
+ grid.rect(x = 0, y = breaks[-length(breaks)], width = unit(10, "bigpts"), height = h, hjust = 0, vjust = 0, gp = gpar(fill = color, col = "#FFFFFF00"))
+ grid.text(legend, x = unit(12, "bigpts"), y = legend_pos, hjust = 0, gp = gp)
+ upViewport()
+}
+
+convert_annotations = function(annotation, annotation_colors){
+
+ #new = annotation
+ x <- sapply(seq_along(annotation), function(i){
+ #for(i in 1:length(annotation)){
+ a = annotation[[i]]
+ b <- attr(a, 'color')
+ if( is.null(b) )
+ b = annotation_colors[[names(annotation)[i]]]
+ if(class(a) %in% c("character", "factor")){
+ a = as.character(a)
+ #print(names(b))
+ #print(unique(a))
+ if ( FALSE && length(setdiff(names(b), a)) > 0){
+ stop(sprintf("Factor levels on variable %s do not match with annotation_colors", names(annotation)[i]))
+ }
+ #new[, i] = b[a]
+ b[match(a, names(b))]
+ }
+ else{
+ a = cut(a, breaks = 100)
+ #new[, i] = colorRampPalette(b)(100)[a]
+ ccRamp(b, 100)[a]
+ }
+ })
+
+ colnames(x) <- names(annotation)
+ return(x)
+ #return(as.matrix(new))
+}
+
+draw_annotations = function(converted_annotations, border_color, horizontal=TRUE){
+ n = ncol(converted_annotations)
+ m = nrow(converted_annotations)
+ if( horizontal ){
+ x = (1:m)/m - 1/2/m
+ y = cumsum(rep(8, n)) - 4 + cumsum(rep(2, n))
+ for(i in 1:m){
+ grid.rect(x = x[i], unit(y[n:1], "bigpts"), width = 1/m, height = unit(8, "bigpts"), gp = gpar(fill = converted_annotations[i, ], col = border_color))
+ }
+ }else{
+ x = cumsum(rep(8, n)) - 4 + cumsum(rep(2, n))
+ y = (1:m)/m - 1/2/m
+ for (i in 1:m) {
+ grid.rect(x = unit(x[1:n], "bigpts"), y=y[i], width = unit(8, "bigpts"),
+ height = 1/m, gp = gpar(fill = converted_annotations[i,]
+ , col = border_color))
+ }
+ }
+}
+
+draw_annotation_legend = function(annotation_colors, border_color, gp = gpar()){
+
+ y = unit(1, "npc")
+
+ text_height = convertHeight(unit(1, "grobheight", textGrob("FGH", gp = gp)), "bigpts")
+ for(i in names(annotation_colors)){
+ grid.text(i, x = 0, y = y, vjust = 1, hjust = 0, gp = c_gpar(gp, fontface = "bold"))
+ y = y - 1.5 * text_height
+ #if(class(annotation[[i]]) %in% c("character", "factor")){
+ acol <- annotation_colors[[i]]
+ if( attr(acol, 'afactor') ){
+ sapply(seq_along(acol), function(j){
+ grid.rect(x = unit(0, "npc"), y = y, hjust = 0, vjust = 1, height = text_height, width = text_height, gp = gpar(col = border_color, fill = acol[j]))
+ grid.text(names(acol)[j], x = text_height * 1.3, y = y, hjust = 0, vjust = 1, gp = gp)
+ y <<- y - 1.5 * text_height
+ })
+ }
+ else{
+ yy = y - 4 * text_height + seq(0, 1, 0.01) * 4 * text_height
+ h = 4 * text_height * 0.02
+ grid.rect(x = unit(0, "npc"), y = yy, hjust = 0, vjust = 1, height = h, width = text_height, gp = gpar(col = "#FFFFFF00", fill = ccRamp(acol, 100)))
+ txt = c(tail(names(acol),1), head(names(acol))[1])
+ yy = y - c(0, 3) * text_height
+ grid.text(txt, x = text_height * 1.3, y = yy, hjust = 0, vjust = 1, gp = gp)
+ y = y - 4.5 * text_height
+ }
+ y = y - 1.5 * text_height
+ }
+}
+
+vplayout <- function ()
+{
+ graphic.name <- NULL
+ .index <- 0L
+ function(x, y, verbose = getOption('verbose') ){
+ # initialize the graph name
+ if( is.null(x) ){
+ .index <<- .index + 1L
+ graphic.name <<- paste0("AHEATMAP.VP.", .index) #grid:::vpAutoName()
+ return(graphic.name)
+ }
+ name <- NULL
+ if( !is.numeric(x) ){
+
+ name <- paste(graphic.name, x, sep='-')
+
+ if( !missing(y) && is(y, 'viewport') ){
+ y$name <- name
+ return(pushViewport(y))
+ }
+ if( !is.null(tryViewport(name, verbose=verbose)) )
+ return()
+
+ switch(x
+ , main={x<-1; y<-3;}
+ , ctree={x<-2; y<-3;}
+ , cann={x<-3; y<-3;}
+ , rtree={x<-4; y<-1;}
+ , rann={x<-4; y<-2;}
+ , mat={x<-4; y<-3;}
+ , rnam={x<-4; y<-4;}
+ , leg={x<-4; y<-5;}
+ , aleg={x<-4; y<-6;}
+ , cnam={x<-5; y<-3;}
+ , sub={x<-6; y<-3;}
+ , info={x<-7; y<-3;}
+ , stop("aheatmap - invalid viewport name")
+ )
+ }
+ if( verbose ) message("vp - create ", name)
+ pushViewport(viewport(layout.pos.row = x, layout.pos.col = y, name=name))
+ }
+}
+vplayout <- vplayout()
+
+#' Open a File Graphic Device
+#'
+#' Opens a graphic device depending on the file extension
+#'
+#' @keywords internal
+gfile <- function(filename, width, height, ...){
+ # Get file type
+ r = regexpr("\\.[a-zA-Z]*$", filename)
+ if(r == -1) stop("Improper filename")
+ ending = substr(filename, r + 1, r + attr(r, "match.length"))
+
+ f = switch(ending,
+ pdf = function(x, ...) pdf(x, ...),
+ svg = function(x, ...) svg(x, ...),
+ png = function(x, ...) png(x, ...),
+ jpeg = function(x, ...) jpeg(x, ...),
+ jpg = function(x, ...) jpeg(x, ...),
+ tiff = function(x, ...) tiff(x, compression = "lzw", ...),
+ bmp = function(x, ...) bmp(x, ...),
+ stop("File type should be: pdf, svg, png, bmp, jpg, tiff")
+ )
+
+ args <- c(list(filename), list(...))
+ if( !missing(width) ){
+ args$width <- as.numeric(width)
+ args$height <- as.numeric(height)
+ if( !ending %in% c('pdf','svg') && is.null(args[['res']]) ){
+ args$units <- "in"
+ args$res <- 300
+ }
+ }
+ do.call('f', args)
+}
+
+#gt <- function(){
+#
+# x <- rmatrix(20, 10)
+# z <- unit(0.1, "npc")
+# w <- unit(0.4, "npc")
+# h <- unit(0.3, "npc")
+# lo <- grid.layout(nrow = 7, ncol = 6
+# , widths = unit.c(z, z, w, z, z, z)
+# , heights = unit.c(z, z, z, h, z, z, z))
+#
+# nvp <- 0
+# on.exit( upViewport(nvp) )
+#
+# u <- vplayout(NULL)
+# vname <- function(x) basename(tempfile(x))
+#
+# hvp <- viewport( name=u, layout = lo)
+# pushViewport(hvp)
+# nvp <- nvp + 1
+#
+# pushViewport(viewport(layout.pos.row = 4, layout.pos.col = 3, name='test'))
+# #vplayout('mat')
+# nvp <- nvp + 1
+#
+# grid.rect()
+# NULL
+#}
+
+#gt2 <- function(){
+#
+# x <- rmatrix(10, 5)
+# lo(NULL, NULL, nrow(x), ncol(x), cellheight = NA, cellwidth = NA
+# , treeheight_col=0, treeheight_row=0, legend=FALSE, main = NULL, sub = NULL, info = NULL
+# , annTracks=list(colors=NA, annRow=NA, annCol=NA), annotation_legend=FALSE
+# , fontsize=NULL, fontsize_row=NULL, fontsize_col=NULL)
+#
+# #vplayout('mat')
+# vname <- function(x) basename(tempfile(x))
+# pushViewport(viewport(layout.pos.row = 4, layout.pos.col = 3, name=vname('test')))
+# print(current.vpPath())
+# grid.rect()
+# upViewport(2)
+# NULL
+#}
+
+d <- function(x){
+
+ if( is.character(x) ) x <- rmatrix(dim(x))
+
+ nvp <- 0
+ on.exit(upViewport(nvp), add=TRUE)
+ lo <- grid.layout(nrow = 4, ncol = 3)
+ hvp <- viewport( name=basename(tempfile()), layout = lo)
+ pushViewport(hvp)
+ nvp <- nvp + 1
+
+ pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 1))
+ nvp <- nvp + 1
+ w = convertWidth(unit(1, "npc"), "bigpts", valueOnly = T) / 10
+ h = convertHeight(unit(1, "npc"), "bigpts", valueOnly = T) / 10
+ grid.rect()
+ upViewport()
+ nvp <- nvp - 1
+
+ pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 2))
+ nvp <- nvp + 1
+ # add inner padding viewport
+ pushViewport( viewport(x=0,y=0,width=0.9,height=0.9,just=c("left", "bottom")) )
+ nvp <- nvp + 1
+
+ ( opar <- par(plt = gridPLT(), new = TRUE) )
+ on.exit(par(opar), add=TRUE)
+
+ hc <- hclust(dist(x))
+ plot(as.dendrogram(hc), xaxs="i", yaxs="i", axes=FALSE, leaflab="none")
+
+ invisible(basename(tempfile()))
+}
+
+heatmap_motor = function(matrix, border_color, cellwidth, cellheight
+ , tree_col, tree_row, treeheight_col, treeheight_row
+ , filename=NA, width=NA, height=NA
+ , breaks, color, legend, txt = NULL
+ , annTracks, annotation_legend=TRUE
+ , new=TRUE, fontsize, fontsize_row, fontsize_col
+ , main=NULL, sub=NULL, info=NULL
+ , verbose=getOption('verbose')
+ , gp = gpar()){
+
+ annotation_colors <- annTracks$colors
+ row_annotation <- annTracks$annRow
+ annotation <- annTracks$annCol
+ writeToFile <- !is.na(filename)
+
+ # open graphic device (dimensions will be changed after computation of the correct height)
+ if( writeToFile ){
+ gfile(filename)
+ on.exit(dev.off())
+ }
+
+ # identify the plotting context: base or grid
+ #NB: use custom function current.vpPath2 instead of official
+ # grid::current.vpPath as this one creates a new page when called
+ # on a fresh graphic device
+ vpp <- current.vpPath_patched()
+ if( is.null(vpp) ){ # we are at the root viewport
+ if( verbose ) message("Detected path: [ROOT]")
+ mf <- par('mfrow')
+ #print(mf)
+ # if in in mfrow/layout context: setup fake-ROOT viewports with gridBase
+ # and do not call plot.new as it is called in grid.base.mix.
+ new <- if( !identical(mf, c(1L,1L)) ){
+ if( verbose ) message("Detected mfrow: ", mf[1], " - ", mf[2], ' ... MIXED')
+ opar <- grid.base.mix(trace=verbose>1)
+ on.exit( grid.base.mix(opar) )
+ FALSE
+ }
+ else{
+ if( verbose ){
+ message("Detected mfrow: ", mf[1], " - ", mf[2])
+ message("Honouring ", if( missing(new) ) "default "
+ ,"argument `new=", new, '` ... '
+ , if( new ) "NEW" else "OVERLAY")
+ }
+ new
+ }
+ }else{
+ if( verbose ) message("Detected path: ", vpp)
+ # if new is not specified: change the default behaviour by not calling
+ # plot.new so that drawing occurs in the current viewport
+ if( missing(new) ){
+ if( verbose ) message("Missing argument `new` ... OVERLAY")
+ new <- FALSE
+ }else if( verbose ) message("Honouring argument `new=", new, '` ... '
+ , if( new ) "NEW" else "OVERLAY")
+ }
+ # reset device if necessary or requested
+ if( new ){
+ if( verbose ) message("Call: plot.new")
+ #grid.newpage()
+ plot.new()
+ }
+
+ # define grob for main
+ mainGrob <- if( !is.null(main) && !is.grob(main) ) textGrob(main, gp = c_gpar(gp, fontsize = 1.2 * fontsize, fontface="bold"))
+ subGrob <- if( !is.null(sub) && !is.grob(sub) ) textGrob(sub, gp = c_gpar(gp, fontsize = 0.8 * fontsize))
+ infoGrob <- if( !is.null(info) && !is.grob(info) ){
+# infotxt <- paste(strwrap(paste(info, collapse=" | "), width=20), collapse="\n")
+ grobTree(gList(rectGrob(gp = gpar(fill = "grey80"))
+ ,textGrob(paste(info, collapse=" | "), x=unit(5, 'bigpts'), y=0.5, just='left', gp = c_gpar(gp, fontsize = 0.8 * fontsize))))
+ }
+
+ # Set layout
+ glo = lo(coln = colnames(matrix), rown = rownames(matrix), nrow = nrow(matrix), ncol = ncol(matrix)
+ , cellwidth = cellwidth, cellheight = cellheight
+ , treeheight_col = treeheight_col, treeheight_row = treeheight_row
+ , legend = legend
+ , annTracks = annTracks, annotation_legend = annotation_legend
+ , fontsize = fontsize, fontsize_row = fontsize_row, fontsize_col = fontsize_col
+ , main = mainGrob, sub = subGrob, info = infoGrob, gp = gp)
+
+ # resize the graphic file device if necessary
+ if( writeToFile ){
+ if( verbose ) message("Compute size for file graphic device")
+ m <- par('mar')
+ if(is.na(height))
+ height <- glo$height
+ if(is.na(width))
+ width <- glo$width
+
+ dev.off()
+ if( verbose ) message("Resize file graphic device to: ", width, " - ", height)
+ gfile(filename, width=width, height=height)
+ # re-call plot.new if it was called before
+ if( new ){
+ if( verbose ) message("Call again plot.new")
+ op <- par(mar=c(0,0,0,0))
+ plot.new()
+ par(op)
+ }
+ if( verbose ) message("Push again top viewport")
+ # repush the layout
+ pushViewport(glo$vp)
+ if( verbose ) grid.rect(width=unit(glo$width, 'inches'), height=unit(glo$height, 'inches'), gp = gpar(col='blue'))
+ }
+
+ #grid.show.layout(glo$layout); return()
+ mindim <- glo$mindim
+ # Omit border color if cell size is too small
+ if(mindim < 3) border_color = NA
+
+ # Draw tree for the columns
+ if (!is_NA(tree_col) && treeheight_col != 0){
+ #vplayout(1, 2)
+ vplayout('ctree')
+ draw_dendrogram(tree_col, horizontal = T)
+ upViewport()
+ }
+
+ # Draw tree for the rows
+ if(!is_NA(tree_row) && treeheight_row !=0){
+ #vplayout(3, 1)
+ vplayout('rtree')
+ draw_dendrogram(tree_row, horizontal = F)
+ upViewport()
+ }
+
+ # recompute margin fontsizes
+ fontsize_row <- convertUnit(min(unit(fontsize_row, 'points'), unit(0.6*glo$cellheight, 'bigpts')), 'points')
+ fontsize_col <- convertUnit(min(unit(fontsize_col, 'points'), unit(0.6*glo$cellwidth, 'bigpts')), 'points')
+
+ # Draw matrix
+ #vplayout(3, 2)
+ vplayout('mat')
+ draw_matrix(matrix, border_color, txt = txt, gp = gpar(fontsize = fontsize_row))
+ #d(matrix)
+ #grid.rect()
+ upViewport()
+
+ # Draw colnames
+ if(length(colnames(matrix)) != 0){
+ #vplayout(4, 2)
+ vplayout('cnam')
+ draw_colnames(colnames(matrix), gp = c_gpar(gp, fontsize = fontsize_col))
+ upViewport()
+ }
+
+ # Draw rownames
+ if(length(rownames(matrix)) != 0){
+ #vplayout(3, 3)
+ vplayout('rnam')
+ draw_rownames(rownames(matrix), gp = c_gpar(gp, fontsize = fontsize_row))
+ upViewport()
+ }
+
+ # Draw annotation tracks
+ if( !is_NA(annotation) ){
+ #vplayout(2, 2)
+ vplayout('cann')
+ draw_annotations(annotation, border_color)
+ upViewport()
+ }
+
+ # add row annotations if necessary
+ if ( !is_NA(row_annotation) ) {
+ vplayout('rann')
+ draw_annotations(row_annotation, border_color, horizontal=FALSE)
+ upViewport()
+ }
+
+ # Draw annotation legend
+ if( annotation_legend && !is_NA(annotation_colors) ){
+ #vplayout(3, 5)
+ vplayout('aleg')
+ draw_annotation_legend(annotation_colors, border_color, gp = c_gpar(gp, fontsize = fontsize))
+ upViewport()
+ }
+
+ # Draw legend
+ if(!is_NA(legend)){
+ #vplayout(3, 4)
+ vplayout('leg')
+ draw_legend(color, breaks, legend, gp = c_gpar(gp, fontsize = fontsize))
+ upViewport()
+ }
+
+ # Draw main
+ if(!is.null(mainGrob)){
+ vplayout('main')
+ grid.draw(mainGrob)
+ upViewport()
+ }
+
+ # Draw subtitle
+ if(!is.null(subGrob)){
+ vplayout('sub')
+ grid.draw(subGrob)
+ upViewport()
+ }
+
+ # Draw info
+ if(!is.null(infoGrob)){
+ vplayout('info')
+ grid.draw(infoGrob)
+ upViewport()
+ }
+
+ # return current vp tree
+ #ct <- current.vpTree()
+ #print(current.vpPath())
+ upViewport()
+ #popViewport()
+
+ # grab current grob and return
+# gr <- grid.grab()
+# grid.draw(gr)
+ #ct
+ NULL
+}
+
+generate_breaks = function(x, n, center=NA){
+ if( missing(center) || is_NA(center) )
+ seq(min(x, na.rm = T), max(x, na.rm = T), length.out = n + 1)
+ else{ # center the breaks on the requested value
+ n2 <- ceiling((n+0.5)/2)
+ M <- max(abs(center - min(x, na.rm = TRUE)), abs(center - max(x, na.rm = TRUE)))
+ lb <- seq(center-M, center, length.out = n2)
+ rb <- seq(center, center+M, length.out = n2)
+ c(lb, rb[-1])
+ }
+}
+
+scale_vec_colours = function(x, col = rainbow(10), breaks = NA){
+ return(col[as.numeric(cut(x, breaks = breaks, include.lowest = T))])
+}
+
+scale_colours = function(mat, col = rainbow(10), breaks = NA){
+ mat = as.matrix(mat)
+ return(matrix(scale_vec_colours(as.vector(mat), col = col, breaks = breaks), nrow(mat), ncol(mat), dimnames = list(rownames(mat), colnames(mat))))
+}
+
+cutheight <- function(x, n){
+
+ # exit early if n <=1: nothing to do
+ if( n <=1 ) return( attr(x, 'height') )
+
+ res <- NULL
+ .heights <- function(subtree, n){
+ if( is.leaf(subtree) ) return()
+ if (!(K <- length(subtree)))
+ stop("non-leaf subtree of length 0")
+ # extract heights from each subtree
+ for( k in 1:K){
+ res <<- c(res, attr(subtree[[k]], 'height'))
+ }
+
+ # continue only if there is not yet enough subtrees
+ if( length(res) < n ){
+ for( k in 1:K){
+ .heights(subtree[[k]], n)
+ }
+ }
+ }
+
+ # extract at least the top h heights
+ .heights(x, n)
+
+ # sort by decreasing order
+ res <- sort(res, decreasing=TRUE)
+
+ res[n-1]
+}
+
+#' Fade Out the Upper Branches from a Dendrogram
+#'
+#' @param x a dendrogram
+#' @param n the number of groups
+#'
+#' @import digest
+#' @keywords internal
+cutdendro <- function(x, n){
+
+ # exit early if n <=1: nothing to do
+ if( n <= 1 ) return(x)
+
+ # add node digest ids to x
+ x <- dendrapply(x, function(n){
+ attr(n, 'id') <- digest(attributes(n))
+ n
+ })
+
+ # cut x in n groups
+ # find the height where to cut
+ h <- cutheight(x, n)
+ cfx <- cut(x, h)
+ # get the ids of the upper nodes
+ ids <- sapply(cfx$lower, function(sub) attr(sub, 'id'))
+
+ # highlight the upper branches with dot lines
+ dts <- c(lty=2, lwd=1.2, col=8)
+ a <- dendrapply(x, function(node){
+ a <- attributes(node)
+ if( a$id %in% ids || (!is.leaf(node) && any(c(attr(node[[1]], 'id'), attr(node[[2]], 'id')) %in% ids)) )
+ attr(node, 'edgePar') <- dts
+ node
+ })
+}
+
+# internal class definition for
+as_treedef <- function(x, ...){
+ res <- if( is(x, 'hclust') )
+ list(dendrogram=as.dendrogram(x), dist.method=x$dist.method, method=x$method)
+ else list(dendrogram=x, ...)
+ class(res) <- "aheatmap_treedef"
+ res
+}
+rev.aheatmap_treedef <- function(x){
+ x$dendrogram <- rev(x$dendrogram)
+ x
+}
+
+is_treedef <- function(x) is(x, 'aheatmap_treedef')
+
+isLogical <- function(x) isTRUE(x) || identical(x, FALSE)
+
+
+# Convert an index vector usable on the subset data into one usable on the
+# original data
+subset2orginal_idx <- function(idx, subset){
+ if( is.null(subset) || is.null(idx) ) idx
+ else{
+ res <- subset[idx]
+ attr(res, 'subset') <- idx
+ res
+ }
+}
+
+#' Cluster Matrix Rows in Annotated Heatmaps
+#'
+#' @param mat original input matrix that has already been appropriately subset in
+#' the caller function (\code{aheatmap})
+#' @param param clustering specifications
+#' @param distfun Default distance method/function
+#' @param hclustfun Default clustering (linkage) method/function
+#' @param reorderfun Default reordering function
+#' @param na.rm Logical that specifies if NA values should be removed
+#' @param subset index (integer) vector specifying the subset indexes used to
+#' subset mat. This is required to be able to return the original indexes.
+#'
+#' @keywords internal
+cluster_mat = function(mat, param, distfun, hclustfun, reorderfun, na.rm=TRUE, subset=NULL, verbose = FALSE){
+
+ # do nothing if an hclust object is passed
+ parg <- deparse(substitute(param))
+
+ Rowv <-
+ if( is(param, 'hclust') || is(param, 'dendrogram') ){ # hclust or dendrograms are honoured
+ res <- as_treedef(param)
+
+ # subset if requested: convert into an index vector
+ # the actuval subsetting is done by first case (index vector)
+ if( !is.null(subset) ){
+ warning("Could not directly subset dendrogram/hclust object `", parg
+ ,"`: using subset of the dendrogram's order instead.")
+ # use dendrogram order instead of dendrogram itself
+ param <- order.dendrogram(res$dendrogram)
+
+ }else # EXIT: return treedef
+ return(res)
+ }else if( is(param, 'silhouette') ){ # use silhouette order
+ si <- sortSilhouette(param)
+ param <- attr(si, 'iOrd')
+ }
+
+ # index vectors are honoured
+ if( is.integer(param) && length(param) > 1 ){
+
+ # subset if requested: reorder the subset indexes as in param
+ if( !is.null(subset) )
+ param <- order(match(subset, param))
+
+ param
+ }else{ # will compute dendrogram (NB: mat was already subset before calling cluster_mat)
+
+ param <-
+ if( is.integer(param) )
+ param
+ else if( is.null(param) || isLogical(param) ) # use default reordering by rowMeans
+ rowMeans(mat, na.rm=na.rm)
+ else if( is.numeric(param) ){ # numeric reordering weights
+ # subset if necessary
+ if( !is.null(subset) )
+ param <- param[subset]
+ param
+ }else if( is.character(param) || is.list(param) ){
+
+ if( length(param) == 0 )
+ stop("aheatmap - Invalid empty character argument `", parg, "`.")
+
+ # set default names if no names were provided
+ if( is.null(names(param)) ){
+ if( length(param) > 3 ){
+ warning("aheatmap - Only using the three first elements of `", parg, "` for distfun and hclustfun respectively.")
+ param <- param[1:3]
+ }
+ n.allowed <- c('distfun', 'hclustfun', 'reorderfun')
+ names(param) <- head(n.allowed, length(param))
+ }
+
+ # use the distance passed in param
+ if( 'distfun' %in% names(param) ) distfun <- param[['distfun']]
+ # use the clustering function passed in param
+ if( 'hclustfun' %in% names(param) ) hclustfun <- param[['hclustfun']]
+ # use the reordering function passed in param
+ if( 'reorderfun' %in% names(param) ) reorderfun <- param[['reorderfun']]
+
+ TRUE
+ }else
+ stop("aheatmap - Invalid value for argument `", parg, "`. See ?aheatmap.")
+
+ # compute distances
+ d <- if( isString(distfun) ){
+ distfun <- distfun[1]
+
+ corr.methods <- c("pearson", "kendall", "spearman")
+ av <- c("correlation", corr.methods, "euclidean", "maximum", "manhattan", "canberra", "binary", "minkowski")
+ i <- pmatch(distfun, av)
+ if( is_NA(i) )
+ stop("aheatmap - Invalid dissimilarity method, must be one of: ", str_out(av, Inf))
+
+ distfun <- av[i]
+ if(distfun == "correlation") distfun <- 'pearson'
+ if(distfun %in% corr.methods){ # distance from correlation matrix
+ if( verbose ) message("Using distance method: correlation (", distfun, ')')
+ d <- dist(1 - cor(t(mat), method = distfun))
+ attr(d, 'method') <- distfun
+ d
+ }else{
+ if( verbose ) message("Using distance method: ", distfun)
+ dist(mat, method = distfun)
+ }
+
+ }else if( is(distfun, "dist") ){
+ if( verbose ) message("Using dist object: ", distfun)
+ distfun
+ }else if( is.function(distfun) ){
+ if( verbose ) message("Using custom dist function")
+ distfun(mat)
+ }else
+ stop("aheatmap - Invalid dissimilarity function: must be a character string, an object of class 'dist', or a function")
+
+ # do hierarchical clustering
+ hc <- if( is.character(hclustfun) ){
+
+ av <- c('ward', 'single', 'complete', 'average', 'mcquitty', 'median', 'centroid')
+ i <- pmatch(hclustfun, av)
+ if( is.na(i) )
+ stop("aheatmap - Invalid clustering method, must be one of: ", paste("'", av, "'", sep='', collapse=', '))
+
+ hclustfun <- av[i]
+ if( verbose ) message("Using clustering method: ", hclustfun)
+ hclust(d, method=hclustfun)
+
+ }else if( is.function(hclustfun) )
+ hclustfun(d)
+ else
+ stop("aheatmap - Invalid clustering function: must be a character string or a function")
+
+ #convert into a dendrogram
+ dh <- as.dendrogram(hc)
+
+ # customize the dendrogram plot: highlight clusters
+ if( is.integer(param) )
+ dh <- cutdendro(dh, param)
+ else if( is.numeric(param) && length(param)==nrow(mat) ) # reorder the dendrogram if necessary
+ dh <- reorderfun(dh, param)
+
+ # wrap up into a aheatmap_treedef object
+ as_treedef(dh, dist.method=hc$dist.method, method=hc$method)
+ }
+}
+
+#scale_rows = function(x){
+# m = apply(x, 1, mean)
+# s = apply(x, 1, sd)
+# return((x - m) / s)
+#}
+
+scale_mat = function(x, scale, na.rm=TRUE){
+
+ av <- c("none", "row", "column", 'r1', 'c1')
+ i <- pmatch(scale, av)
+ if( is_NA(i) )
+ stop("scale argument shoud take values: 'none', 'row' or 'column'")
+ scale <- av[i]
+
+ switch(scale, none = x
+ , row = {
+ x <- sweep(x, 1L, rowMeans(x, na.rm = na.rm), check.margin = FALSE)
+ sx <- apply(x, 1L, sd, na.rm = na.rm)
+ sweep(x, 1L, sx, "/", check.margin = FALSE)
+ }
+ , column = {
+ x <- sweep(x, 2L, colMeans(x, na.rm = na.rm), check.margin = FALSE)
+ sx <- apply(x, 2L, sd, na.rm = na.rm)
+ sweep(x, 2L, sx, "/", check.margin = FALSE)
+ }
+ , r1 = sweep(x, 1L, rowSums(x, na.rm = na.rm), '/', check.margin = FALSE)
+ , c1 = sweep(x, 2L, colSums(x, na.rm = na.rm), '/', check.margin = FALSE)
+ )
+}
+
+.Rd.seed <- new.env()
+
+round.pretty <- function(x, min=2){
+
+ if( is.null(x) ) return(NULL)
+ n <- 0
+ y <- round(sort(x), n)
+ if( all(diff(y)==0) ) return( round(x, min) )
+ while( any(diff(y)==0) ){
+ n <- n+1
+ y <- round(sort(x), n)
+ }
+ dec <- max(min,n)
+ round(x, dec)
+}
+
+generate_annotation_colours = function(annotation, annotation_colors, seed=TRUE){
+ if( is_NA(annotation_colors) ){
+ annotation_colors = list()
+ }
+ # use names from annotations if necessary/possible
+ if( length(annotation_colors) > 0L
+ && length(annotation_colors) <= length(annotation)
+ && is.null(names(annotation_colors)) ){
+ names(annotation_colors) <- head(names(annotation), length(annotation_colors))
+ }
+
+ count = 0
+ annotationLevels <- list()
+ anames <- names(annotation)
+ sapply(seq_along(annotation), function(i){
+ a <- annotation[[i]]
+ if( class(annotation[[i]]) %in% c("character", "factor")){
+ # convert to character vector
+ a <- if( is.factor(a) ) levels(a) else unique(a)
+ count <<- count + nlevels(a)
+ # merge if possible
+ if( !is.null(anames) && anames[i]!='' )
+ annotationLevels[[anames[i]]] <<- unique(c(annotationLevels[[anames[i]]], a))
+ else
+ annotationLevels <<- c(annotationLevels, list(a))
+ }else
+ annotationLevels <<- c(annotationLevels, annotation[i])
+ })
+ annotation <- annotationLevels
+ #str(annotationLevels)
+
+ factor_colors = hcl(h = seq(1, 360, length.out = max(count+1,20)), 100, 70)
+
+ # get random seeds to restore/update on exit
+ rs <- RNGseed()
+ on.exit({
+ # update local random seed on exit
+ .Rd.seed$.Random.seed <- getRNG()
+ # restore global random seed
+ RNGseed(rs)
+ })
+ # restore local random seed if it exists
+ if( !is.null(.Rd.seed$.Random.seed) )
+ setRNG(.Rd.seed$.Random.seed)
+ # set seed and restore on exit
+ if( isTRUE(seed) ){
+ # reset .Random.seed to a dummy RNG in case the current kind is user-supplied:
+ # we do not want to draw even once from the current RNG
+ setRNG(c(401L, 0L, 0L))
+ set.seed(12345, 'default', 'default')
+ }
+ factor_colors <- sample(factor_colors)
+# pal(factor_colors); stop("sasa")
+
+ res_colors <- list()
+ for(i in 1:length(annotation)){
+ ann <- annotation[[i]]
+ aname <- names(annotation)[i]
+ # skip already generated colors
+ acol_def <- res_colors[[aname]]
+ if( !is.null(acol_def) ) next;
+ acol <- annotation_colors[[aname]]
+ if( is.null(acol) ){
+ res_colors[[aname]] <-
+ if( class(annotation[[i]]) %in% c("character", "factor")){
+ lev <- ann
+ ind = 1:length(lev)
+ acol <- setNames(factor_colors[ind], lev)
+ factor_colors = factor_colors[-ind]
+ # conserve NA value
+ acol[which(is.na(names(acol)))] <- NA
+ acol
+ }
+ else{
+ h = round(runif(1) * 360)
+ rg <- range(ann, na.rm=TRUE)
+ if( rg[1] == rg[2] ) rg <- sort(c(0, rg[1]))
+ setNames(rev(sequential_hcl(2, h, l = c(50, 95))), round.pretty(rg))
+ }
+
+ }else{
+
+ acol <-
+ if( length(acol) == 1 && grepl("^\\$", acol) ) # copy colors from other columns if the spec starts with '$'
+ annotation_colors[[substr(acol, 2, nchar(acol))]]
+ else if( !is.numeric(ann) ){
+ local({ #do this locally so that it does not affect `ann`
+
+ # subset to the levels for which no colour has already been defined
+ lev <- ann
+ # subset to the levels for which no colour has already been defined
+# idx <- which(!lev %in% names(acol_def) & !is.na(lev))
+# lev <- lev[idx]
+# #idx <- idx + length(acol_def)
+#
+# if( length(lev) == 0L ) acol_def # nothing to add
+# else
+ {
+ # convert to a palette of the number of levels if necessary
+ nl <- length(lev)
+ acol <- ccPalette(acol, nl)
+ if( is.null(names(acol)) )
+ names(acol) <- lev
+ c(acol_def, acol)
+ }
+ })
+ }else{
+ acol <- ccPalette(acol)
+ if( is.null(names(acol)) )
+ names(acol) <- round.pretty(seq(min(ann, na.rm=TRUE), max(ann, na.rm=TRUE), length.out=length(acol)))
+
+ acol
+ }
+
+ # update the colors if necessary
+ if( !is.null(acol) )
+ res_colors[[aname]] <- acol
+ }
+
+ # store type information
+ attr(res_colors[[aname]], 'afactor') <- !is.numeric(ann)
+
+ }
+
+ # return ordered colors as the annotations
+ res_colors[names(annotation)[!duplicated(names(annotation))]]
+}
+
+# Create row/column names
+generate_dimnames <- function(x, n, ref){
+ if( is_NA(x) ) NULL
+ else if( length(x) == n ) x
+ else if( identical(x, 1) || identical(x, 1L) ) 1L:n
+ else if( isString(x) ){
+ regexp <- "^/(.+)/([0-9]+)?$"
+ if( grepl(regexp, x) ){
+ x <- str_match(x, regexp)
+ p <- x[1,2]
+ n <- if( x[1, 3] != '' ) as.numeric(x[1, 2]) else 2L
+ s <- str_match(ref, p)[, n]
+ ifelse(is.na(s), ref, s)
+ }
+ else paste(x, 1L:n, sep='')
+ #print(str_match_all(x, "^/(([^%]*)(%[in])?)+/$"))
+ }
+ else stop("aheatmap - Invalid row/column label. Possible values are:"
+ , " NA, a vector of correct length, value 1 (or 1L) or single character string.")
+}
+
+
+.make_annotation <- function(x, ord=NULL){
+ # convert into a data.frame if necessary
+ if( !is.data.frame(x) ){
+ x <- if( is(x, 'ExpressionSet') ) Biobase::pData(x)
+ else if( is.factor(x) || is.character(x) ) data.frame(Factor=x)
+ else if( is.numeric(x) ) data.frame(Variable=x)
+ else
+ stop("aheatmap - Invalid annotation argument `", substitute(x), "`: must be a data.frame, a factor or a numeric vector")
+ }
+ # reorder if necessary
+ if( !is.null(ord) )
+ x <- x[ord, , drop = F]
+
+ # return modifed object
+ x
+}
+
+renderAnnotations <- function(annCol, annRow, annotation_colors, verbose=getOption('verbose')){
+
+ # concatenate both col and row annotation
+ annotation <- list()
+ if( is_NA(annotation_colors) ) annotation_colors <- list()
+ nc <- length(annCol)
+ nr <- length(annRow)
+ flag <- function(x, f){ if( missing(f) ) attr(x, 'flag') else{ attr(x, 'flag') <- f; x} }
+ if( !is_NA(annCol) ) annotation <- c(annotation, sapply(as.list(annCol), flag, 'col', simplify=FALSE))
+ if( !is_NA(annRow) ) annotation <- c(annotation, sapply(as.list(annRow), flag, 'row', simplify=FALSE))
+
+ if( length(annotation) == 0 ) return( list(annCol=NA, annRow=NA, colors=NA) )
+
+ # generate the missing name
+ n <- names(annotation)
+ xnames <- paste('X', 1:length(annotation), sep='')
+ if( is.null(n) ) names(annotation) <- xnames
+ else names(annotation)[n==''] <- xnames[n=='']
+
+ # preprocess the annotation color links
+ if( !is.null(cnames <- names(annotation_colors)) ){
+ m <- str_match(cnames, "^@([^{]+)\\{([^}]+)\\}")
+ apply(m, 1L, function(x){
+ # skip unmatched names
+ if( is_NA(x[1]) ) return()
+
+ acol <- annotation_colors[[x[1]]]
+ # rename both annotation and annotation_colors if necessary
+ if( x[2] != x[3] ){
+ annotation[[x[3]]] <<- annotation[[x[2]]]
+ annotation[[x[2]]] <<- NULL
+ if( !is_NA(acol) )
+ annotation_colors[[x[3]]] <<- acol
+ annotation_colors[[x[1]]] <<- NULL
+ }
+ })
+ }
+
+# message("### ANNOTATION ###"); print(annotation)
+# message("### ANNOTATION COLORS ###"); print(annotation_colors)
+
+ if( verbose ) message("Generate column annotation colours")
+ annotation_colors <- generate_annotation_colours(annotation, annotation_colors)
+ if( verbose > 2 ){
+ message("### Annotation colors ###")
+ print(annotation_colors)
+ message("#########################")
+ }
+
+ # bind each annotation with its respective color and regroup into column and row annotation
+ res <- list()
+ lapply(seq_along(annotation), function(i){
+ aname <- names(annotation)[i]
+ acol <- annotation_colors[[aname]]
+ if( is.null(acol) )
+ stop("aheatmap - No color was defined for annotation '", aname, "'.")
+ attr(annotation[[i]], 'color') <- acol
+
+ # put into the right annotation list
+ if( flag(annotation[[i]]) == 'col' ) res$annCol <<- c(res$annCol, annotation[i])
+ else res$annRow <<- c(res$annRow, annotation[i])
+ })
+
+ res$annCol <- if( !is.null(res$annCol) ) convert_annotations(res$annCol, annotation_colors) else NA
+ res$annRow <- if( !is.null(res$annRow) ) convert_annotations(res$annRow, annotation_colors) else NA
+ res$colors <- annotation_colors
+
+ # return result list
+ res
+
+}
+
+# set/get special annotation handlers
+specialAnnotation <- local({
+ .empty <- list(list(), list())
+ .cache <- .empty
+ function(margin, name, fun, clear=FALSE){
+
+ if( isTRUE(clear) ){
+ if( nargs() > 1L )
+ stop("Invalid call: no other argument can be passed when `clear=TRUE`")
+ .cache <<- .empty
+ return()
+ }
+
+ if( missing(name) && missing(fun) ){
+ return(.cache[[margin]])
+ }else if( is.list(name) ){
+ .cache[[margin]] <<- c(.cache[[margin]], name)
+ }else if( missing(fun) ){
+ return(.cache[[margin]][[name]])
+ }else{
+ .cache[[margin]][[name]] <<- fun
+ }
+ }
+})
+
+# Converts Subset Specification into Indexes
+subset_index <- function(x, margin, subset){
+
+ # if null then do nothing
+ if( is.null(subset) ) return( NULL )
+
+ # get dimension
+ n <- dim(x)[margin]
+ dn <- dimnames(x)[[margin]]
+ dt <- if( margin == 1L ) "rows" else "columns"
+
+ so <- deparse(substitute(subset))
+ if( length(subset) == 0 )
+ stop("Invalid empty subset object `", so, "`")
+
+ subIdx <-
+ if( is.logical(subset) ){
+ if( length(subset) != n ){
+ if( n %% length(subset) == 0 )
+ subset <- rep(subset, n / length(subset))
+ else
+ stop("Invalid length for logical subset argument `", so, "`: number of ", dt, " ["
+ , n, "] is not a multiple of subset length [",length(subset),"].")
+ }
+
+ # convert into indexes
+ which(subset)
+ }
+ else if( is.integer(subset) || is.character(subset) ){
+ if( length(subset) > n )
+ stop("Invalid too long integer/character subset argument `", so
+ , "`: length must not exceed the number of ", dt, " [", n, "].")
+
+ if( anyDuplicated(subset) )
+ warning("Duplicated index or name in subset argument `", so, "`.")
+
+ # for character argument: match against dimname to convert into indexes
+ if( is.character(subset) ){
+ if( is.null(dn) )
+ stop("Could not subset the ", dt, " with a character subset argument `", so, "`: no "
+ , if( margin == 1L ) "rownames" else "colnames"
+ , " are available.")
+ msubset <- match(subset, dn)
+ nas <- is.na(msubset)
+ if( any(nas) ){
+ warning("Mismatch in character subset argument `", so
+ ,"`: Could not find ", sum(nas), " out of ", length(subset), " names ("
+ , paste("'", head(subset[nas], 5), "'", sep='', collapse=', ')
+ , if( sum(nas) > 5 ) ", ... ", ").")
+ msubset <- msubset[!nas]
+ }
+ subset <- msubset
+ }
+ subset
+ }else
+ stop("Invalid subset argument `", so, "`: should be a logical, integer or character vector.")
+
+ # return the indexes sorted
+ sort(subIdx)
+}
+
+#' Annotated Heatmaps
+#'
+#' The function \code{aheatmap} plots high-quality heatmaps, with a detailed legend
+#' and unlimited annotation tracks for both columns and rows.
+#' The annotations are coloured differently according to their type
+#' (factor or numeric covariate).
+#' Although it uses grid graphics, the generated plot is compatible with base
+#' layouts such as the ones defined with \code{'mfrow'} or \code{\link{layout}},
+#' enabling the easy drawing of multiple heatmaps on a single a plot -- at last!.
+#'
+#' The development of this function started as a fork of the function
+#' \code{pheatmap} from the \pkg{pheatmap} package, and provides
+#' several enhancements such as:
+#' \itemize{
+#' \item argument names match those used in the base function \code{\link{heatmap}};
+#' \item unlimited number of annotation for \strong{both} columns and rows,
+#' with simplified and more flexible interface;
+#' \item easy specification of clustering methods and colors;
+#' \item return clustering data, as well as grid grob object.
+#' }
+#'
+#' Please read the associated vignette for more information and sample code.
+#'
+#' @section PDF graphic devices: if plotting on a PDF graphic device -- started with \code{\link{pdf}},
+#' one may get generate a first blank page, due to internals of standard functions from
+#' the \pkg{grid} package that are called by \code{aheatmap}.
+#' The \pkg{NMF} package ships a custom patch that fixes this issue.
+#' However, in order to comply with CRAN policies, the patch is \strong{not} applied by default
+#' and the user must explicitly be enabled it.
+#' This can be achieved on runtime by either setting the NMF specific option 'grid.patch'
+#' via \code{nmf.options(grid.patch=TRUE)}, or on load time if the environment variable
+#' 'R_PACKAGE_NMF_GRID_PATCH' is defined and its value is something that is not equivalent
+#' to \code{FALSE} (i.e. not '', 'false' nor 0).
+#'
+#' @param x numeric matrix of the values to be plotted.
+#' An \code{\link[Biobase:ExpressionSet-class]{ExpressionSet}} objects can also
+#' be passed, in which case the expression values are plotted (\code{exprs(x)}).
+#'
+#' @param color colour specification for the heatmap. Default to palette
+#' '-RdYlBu2:100', i.e. reversed palette 'RdYlBu2' (a slight modification of
+#' RColorBrewer's palette 'RdYlBu') with 100 colors.
+#' Possible values are:
+#' \itemize{
+#' \item a character/integer vector of length greater than 1 that is directly used
+#' and assumed to contain valid R color specifications.
+#' \item a single color/integer (between 0 and 8)/other numeric value
+#' that gives the dominant colors. Numeric values are converted into a pallete
+#' by \code{rev(sequential_hcl(2, h = x, l = c(50, 95)))}. Other values are
+#' concatenated with the grey colour '#F1F1F1'.
+#' \item one of RColorBrewer's palette name (see \code{\link[RColorBrewer]{display.brewer.all}})
+#' , or one of 'RdYlBu2', 'rainbow', 'heat', 'topo', 'terrain', 'cm'.
+#' }
+#' When the coluor palette is specified with a single value, and is negative or
+#' preceded a minus ('-'), the reversed palette is used.
+#' The number of breaks can also be specified after a colon (':'). For example,
+#' the default colour palette is specified as '-RdYlBu2:100'.
+#'
+#' @param breaks a sequence of numbers that covers the range of values in \code{x} and is one
+#' element longer than color vector. Used for mapping values to colors. Useful, if needed
+#' to map certain values to certain colors. If value is NA then the
+#' breaks are calculated automatically. If \code{breaks} is a single value,
+#' then the colour palette is centered on this value.
+#'
+#' @param border_color color of cell borders on heatmap, use NA if no border should be
+#' drawn.
+#'
+#' @param cellwidth individual cell width in points. If left as NA, then the values
+#' depend on the size of plotting window.
+#'
+#' @param cellheight individual cell height in points. If left as NA,
+#' then the values depend on the size of plotting window.
+#'
+#' @param scale character indicating how the values should scaled in
+#' either the row direction or the column direction. Note that the scaling is
+#' performed after row/column clustering, so that it has no effect on the
+#' row/column ordering.
+#' Possible values are:
+#' \itemize{
+#' \item \code{"row"}: center and standardize each row separately to row Z-scores
+#' \item \code{"column"}: center and standardize each column separately to column Z-scores
+#' \item \code{"r1"}: scale each row to sum up to one
+#' \item \code{"c1"}: scale each column to sum up to one
+#' \item \code{"none"}: no scaling
+#' }
+#'
+#' @param Rowv clustering specification(s) for the rows. It allows to specify
+#' the distance/clustering/ordering/display parameters to be used for the
+#' \emph{rows only}.
+#' Possible values are:
+#' \itemize{
+#' \item \code{TRUE} or \code{NULL} (to be consistent with \code{\link{heatmap}}):
+#' compute a dendrogram from hierarchical clustering using the distance and
+#' clustering methods \code{distfun} and \code{hclustfun}.
+#'
+#' \item \code{NA}: disable any ordering. In this case, and if not otherwise
+#' specified with argument \code{revC=FALSE}, the heatmap shows the input matrix
+#' with the rows in their original order, with the first row on top to the last
+#' row at the bottom. Note that this differ from the behaviour or \code{\link{heatmap}},
+#' but seemed to be a more sensible choice when vizualizing a matrix without
+#' reordering.
+#'
+#' \item an integer vector of length the number of rows of the input matrix
+#' (\code{nrow(x)}), that specifies the row order. As in the case \code{Rowv=NA},
+#' the ordered matrix is shown first row on top, last row at the bottom.
+#'
+#' \item a character vector or a list specifying values to use instead of arguments
+#' \code{distfun}, \code{hclustfun} and \code{reorderfun} when clustering the
+#' rows (see the respective argument descriptions for a list of accepted
+#' values).
+#' If \code{Rowv} has no names, then the first element is used for \code{distfun},
+#' the second (if present) is used for \code{hclustfun}, and the third
+#' (if present) is used for \code{reorderfun}.
+#'
+#' \item a numeric vector of weights, of length the number of rows of the input matrix,
+#' used to reorder the internally computed dendrogram \code{d}
+#' by \code{reorderfun(d, Rowv)}.
+#'
+#' \item \code{FALSE}: the dendrogram \emph{is} computed using methods \code{distfun},
+#' \code{hclustfun}, and \code{reorderfun} but is not shown.
+#'
+#' \item a single integer that specifies how many subtrees (i.e. clusters)
+#' from the computed dendrogram should have their root faded out.
+#' This can be used to better highlight the different clusters.
+#'
+#' \item a single double that specifies how much space is used by the computed
+#' dendrogram. That is that this value is used in place of \code{treeheight}.
+#' }
+#'
+#' @param Colv clustering specification(s) for the columns. It accepts the same
+#' values as argument \code{Rowv} (modulo the expected length for vector specifications),
+#' and allow specifying the distance/clustering/ordering/display parameters to
+#' be used for the \emph{columns only}.
+#' \code{Colv} may also be set to \code{"Rowv"}, in which case the dendrogram
+#' or ordering specifications applied to the rows are also applied to the
+#' columns. Note that this is allowed only for square input matrices,
+#' and that the row ordering is in this case by default reversed
+#' (\code{revC=TRUE}) to obtain the diagonal in the standard way
+#' (from top-left to bottom-right).
+#' See argument \code{Rowv} for other possible values.
+#'
+#' @param revC a logical that specify if the \emph{row order} defined by
+#' \code{Rowv} should be reversed. This is mainly used to get the rows displayed
+#' from top to bottom, which is not the case by default. Its default value is
+#' computed at runtime, to suit common situations where natural ordering is a
+#' more sensible choice: no or fix ordering of the rows (\code{Rowv=NA} or an
+#' integer vector of indexes -- of length > 1), and when a symmetric ordering is
+#' requested -- so that the diagonal is shown as expected.
+#' An argument in favor of the "odd" default display (bottom to top) is that the
+#' row dendrogram is plotted from bottom to top, and reversing its reorder may
+#' take a not too long but non negligeable time.
+#'
+#' @param distfun default distance measure used in clustering rows and columns.
+#' Possible values are:
+#' \itemize{
+#' \item all the distance methods supported by \code{\link{dist}}
+#' (e.g. "euclidean" or "maximum").
+#'
+#' \item all correlation methods supported by \code{\link{cor}},
+#' such as \code{"pearson"} or \code{"spearman"}.
+#' The pairwise distances between rows/columns are then computed as
+#' \code{d <- dist(1 - cor(..., method = distfun))}.
+#'
+#' One may as well use the string "correlation" which is an alias for "pearson".
+#'
+#' \item an object of class \code{dist} such as returned by \code{\link{dist}} or
+#' \code{\link{as.dist}}.
+#' }
+#'
+#' @param hclustfun default clustering method used to cluster rows and columns.
+#' Possible values are:
+#' \itemize{
+#' \item a method name (a character string) supported by \code{\link{hclust}}
+#' (e.g. \code{'average'}).
+#' \item an object of class \code{hclust} such as returned by \code{\link{hclust}}
+#' \item a dendrogram
+#' }
+#'
+#' @param reorderfun default dendrogram reordering function, used to reorder the
+#' dendrogram, when either \code{Rowv} or \code{Colv} is a numeric weight vector,
+#' or provides or computes a dendrogram. It must take 2 parameters: a dendrogram,
+#' and a weight vector.
+#'
+#' @param subsetRow Specification of subsetting the rows before drawing the
+#' heatmap.
+#' Possible values are:
+#' \itemize{
+#' \item an integer vector of length > 1 specifying the indexes of the rows to
+#' keep;
+#' \item a character vector of length > 1 specyfing the names of the rows to keep.
+#' These are the original rownames, not the names specified in \code{labRow}.
+#' \item a logical vector of length > 1, whose elements are recycled if the
+#' vector has not as many elements as rows in \code{x}.
+#' }
+#' Note that in the case \code{Rowv} is a dendrogram or hclust object, it is first
+#' converted into an ordering vector, and cannot be displayed -- and a warning is thrown.
+#'
+#' @param subsetCol Specification of subsetting the columns before drawing the
+#' heatmap. It accepts the similar values as \code{subsetRow}. See details above.
+#'
+#' @param txt character matrix of the same size as \code{x}, that contains text to
+#' display in each cell.
+#' \code{NA} values are allowed and are not displayed.
+#' See demo for an example.
+#'
+#' @param treeheight how much space (in points) should be used to display
+#' dendrograms. If specified as a single value, it is used for both dendrograms.
+#' A length-2 vector specifies separate values for the row and
+#' column dendrogram respectively.
+#' Default value: 50 points.
+#'
+#' @param legend boolean value that determines if a colour ramp for the heatmap's
+#' colour palette should be drawn or not.
+#' Default is \code{TRUE}.
+#'
+#' @param annCol specifications of column annotation tracks displayed as coloured
+#' rows on top of the heatmaps. The annotation tracks are drawn from bottom to top.
+#' A single annotation track can be specified as a single vector; multiple tracks
+#' are specified as a list, a data frame, or an
+#' \code{\link[Biobase:ExpressionSet-class]{ExpressionSet}} object, in
+#' which case the phenotypic data is used (\code{pData(eset)}).
+#' Character or integer vectors are converted and displayed as factors.
+#' Unnamed tracks are internally renamed into \code{Xi}, with i being incremented for
+#' each unamed track, across both column and row annotation tracks.
+#' For each track, if no corresponding colour is specified in argument
+#' \code{annColors}, a palette or a ramp is automatically computed and named
+#' after the track's name.
+#'
+#' @param annRow specifications of row annotation tracks displayed as coloured
+#' columns on the left of the heatmaps. The annotation tracks are drawn from
+#' left to right. The same conversion, renaming and colouring rules as for argument
+#' \code{annCol} apply.
+#'
+#' @param annColors list for specifying annotation track colors manually. It is
+#' possible to define the colors for only some of the annotations. Check examples for
+#' details.
+#'
+#' @param annLegend boolean value specifying if the legend for the annotation tracks
+#' should be drawn or not.
+#' Default is \code{TRUE}.
+#'
+#' @param labRow labels for the rows.
+#' @param labCol labels for the columns. See description for argument \code{labRow}
+#' for a list of the possible values.
+#'
+#' @param fontsize base fontsize for the plot
+#' @param cexRow fontsize for the rownames, specified as a fraction of argument
+#' \code{fontsize}.
+#' @param cexCol fontsize for the colnames, specified as a fraction of argument
+#' \code{fontsize}.
+#'
+#' @param main Main title as a character string or a grob.
+#' @param sub Subtitle as a character string or a grob.
+#' @param info (experimental) Extra information as a character vector or a grob.
+#' If \code{info=TRUE}, information about the clustering methods is displayed
+#' at the bottom of the plot.
+#'
+#' @param filename file path ending where to save the picture. Currently following
+#' formats are supported: png, pdf, tiff, bmp, jpeg. Even if the plot does not fit into
+#' the plotting window, the file size is calculated so that the plot would fit there,
+#' unless specified otherwise.
+#' @param width manual option for determining the output file width in
+#' @param height manual option for determining the output file height in inches.
+#'
+#' @param verbose if \code{TRUE} then verbose messages are displayed and the
+#' borders of some viewports are highlighted. It is entended for debugging
+#' purposes.
+#'
+#' @param gp graphical parameters for the text used in plot. Parameters passed to
+#' \code{\link{grid.text}}, see \code{\link{gpar}}.
+#'
+#' @author
+#' Original version of \code{pheatmap}: Raivo Kolde
+#'
+#' Enhancement into \code{aheatmap}: Renaud Gaujoux
+#'
+#' @examples
+#'
+#' ## See the demo 'aheatmap' for more examples:
+#' \dontrun{
+#' demo('aheatmap')
+#' }
+#'
+#' # Generate random data
+#' n <- 50; p <- 20
+#' x <- abs(rmatrix(n, p, rnorm, mean=4, sd=1))
+#' x[1:10, seq(1, 10, 2)] <- x[1:10, seq(1, 10, 2)] + 3
+#' x[11:20, seq(2, 10, 2)] <- x[11:20, seq(2, 10, 2)] + 2
+#' rownames(x) <- paste("ROW", 1:n)
+#' colnames(x) <- paste("COL", 1:p)
+#'
+#' ## Default heatmap
+#' aheatmap(x)
+#'
+#' ## Distance methods
+#' aheatmap(x, Rowv = "correlation")
+#' aheatmap(x, Rowv = "man") # partially matched to 'manhattan'
+#' aheatmap(x, Rowv = "man", Colv="binary")
+#'
+#' # Generate column annotations
+#' annotation = data.frame(Var1 = factor(1:p %% 2 == 0, labels = c("Class1", "Class2")), Var2 = 1:10)
+#' aheatmap(x, annCol = annotation)
+#'
+#' @demo Annotated heatmaps
+#'
+#' # Generate random data
+#' n <- 50; p <- 20
+#' x <- abs(rmatrix(n, p, rnorm, mean=4, sd=1))
+#' x[1:10, seq(1, 10, 2)] <- x[1:10, seq(1, 10, 2)] + 3
+#' x[11:20, seq(2, 10, 2)] <- x[11:20, seq(2, 10, 2)] + 2
+#' rownames(x) <- paste("ROW", 1:n)
+#' colnames(x) <- paste("COL", 1:p)
+#'
+#' ## Scaling
+#' aheatmap(x, scale = "row")
+#' aheatmap(x, scale = "col") # partially matched to 'column'
+#' aheatmap(x, scale = "r1") # each row sum up to 1
+#' aheatmap(x, scale = "c1") # each colum sum up to 1
+#'
+#' ## Heatmap colors
+#' aheatmap(x, color = colorRampPalette(c("navy", "white", "firebrick3"))(50))
+#' # color specification as an integer: use R basic colors
+#' aheatmap(x, color = 1L)
+#' # color specification as a negative integer: use reverse basic palette
+#' aheatmap(x, color = -1L)
+#' # color specification as a numeric: use HCL color
+#' aheatmap(x, color = 1)
+#' # do not cluster the rows
+#' aheatmap(x, Rowv = NA)
+#' # no heatmap legend
+#' aheatmap(x, legend = FALSE)
+#' # cell and font size
+#' aheatmap(x, cellwidth = 10, cellheight = 5)
+#'
+#' # directly write into a file
+#' aheatmap(x, cellwidth = 15, cellheight = 12, fontsize = 8, filename = "aheatmap.pdf")
+#' unlink('aheatmap.pdf')
+#'
+#' # Generate column annotations
+#' annotation = data.frame(Var1 = factor(1:p %% 2 == 0, labels = c("Class1", "Class2")), Var2 = 1:10)
+#'
+#' aheatmap(x, annCol = annotation)
+#' aheatmap(x, annCol = annotation, annLegend = FALSE)
+#'
+#'
+#' # Specify colors
+#' Var1 = c("navy", "darkgreen")
+#' names(Var1) = c("Class1", "Class2")
+#' Var2 = c("lightgreen", "navy")
+#'
+#' ann_colors = list(Var1 = Var1, Var2 = Var2)
+#'
+#' aheatmap(x, annCol = annotation, annColors = ann_colors)
+#'
+#' # Specifying clustering from distance matrix
+#' drows = dist(x, method = "minkowski")
+#' dcols = dist(t(x), method = "minkowski")
+#' aheatmap(x, Rowv = drows, Colv = dcols)
+#'
+#' # Display text in each cells
+#' t <- outer(as.character(outer(letters, letters, paste0)), letters, paste0)[1:n, 1:p]
+#' aheatmap(x, txt = t)
+#' # NA values are shown as empty cells
+#' t.na <- t
+#' t.na[sample(length(t.na), 500)] <- NA # half of the cells
+#' aheatmap(x, txt = t.na)
+#'
+#' @export
+aheatmap = function(x
+, color = '-RdYlBu2:100'
+, breaks = NA, border_color=NA, cellwidth = NA, cellheight = NA, scale = "none"
+, Rowv=TRUE, Colv=TRUE
+, revC = identical(Colv, "Rowv") || is_NA(Rowv) || (is.integer(Rowv) && length(Rowv) > 1)
+ || is(Rowv, 'silhouette')
+, distfun = "euclidean", hclustfun = "complete", reorderfun = function(d,w) reorder(d,w)
+, treeheight = 50
+, legend = TRUE, annCol = NA, annRow = NA, annColors = NA, annLegend = TRUE
+, labRow = NULL, labCol = NULL
+, subsetRow = NULL, subsetCol = NULL
+, txt = NULL
+, fontsize=10, cexRow = min(0.2 + 1/log10(nr), 1.2), cexCol = min(0.2 + 1/log10(nc), 1.2)
+, filename = NA, width = NA, height = NA
+, main = NULL, sub = NULL, info = NULL
+, verbose=getOption('verbose'), gp = gpar()){
+
+ # set verbosity level
+ ol <- lverbose(verbose)
+ on.exit( lverbose(ol) )
+
+ # convert ExpressionSet into
+ if( is(x, 'ExpressionSet') ){
+
+ requireNamespace('Biobase')
+ #library(Biobase)
+ if( isTRUE(annCol) ) annCol <- atrack(x)
+ x <- Biobase::exprs(x)
+ }
+
+ # rename to old parameter name
+ mat <- x
+ if( !is.null(txt) ){
+ if( !all(dim(mat), dim(x)) ){
+ stop("Incompatible data and text dimensions: arguments x and txt must have the same size.")
+ }
+ }
+
+ # init result list
+ res <- list()
+
+ # treeheight: use common or separate spec for rows and columns
+ if( length(treeheight) == 1 )
+ treeheight <- c(treeheight, treeheight)
+ treeheight_row <- treeheight[1]
+ treeheight_col <- treeheight[2]
+
+ ## SUBSET: process subset argument for rows/columsn if requested.
+ # this has to be done before relabelling and clustering
+ # but the actual subsetting has to be done after relabelling and before
+ # clustering.
+ # Here one convert a subset argument into an interger vector with the indexes
+ if( !is.null(subsetRow) ){
+ if( verbose ) message("Compute row subset indexes")
+ subsetRow <- subset_index(mat, 1L, subsetRow)
+ }
+ if( !is.null(subsetCol) ){
+ if( verbose ) message("Compute column subset indexes")
+ subsetCol <- subset_index(mat, 2L, subsetCol)
+ }
+
+ ## LABELS: set the row/column labels
+ # label row numerically if no rownames
+ if( is.null(labRow) && is.null(rownames(mat)) )
+ labRow <- 1L
+ if( !is.null(labRow) ){
+ if( verbose ) message("Process labRow")
+ rownames(mat) <- generate_dimnames(labRow, nrow(mat), rownames(mat))
+ }
+ # label columns numerically if no colnames
+ if( is.null(labCol) && is.null(colnames(mat)) )
+ labCol <- 1L
+ if( !is.null(labCol) ){
+ if( verbose ) message("Process labCol")
+ colnames(mat) <- generate_dimnames(labCol, ncol(mat), colnames(mat))
+ }
+
+ ## DO SUBSET
+ if( !is.null(subsetRow) ){
+ mat <- mat[subsetRow, ]
+ }
+ if( !is.null(subsetCol) ){
+ mat <- mat[, subsetCol]
+ }
+
+ ## CLUSTERING
+ # Do row clustering
+ tree_row <- if( !is_NA(Rowv) ){
+ if( verbose ) message("Cluster rows")
+ # single numeric Rowv means treeheight
+ if( isReal(Rowv) ){
+ # treeheight
+ treeheight_row <- Rowv
+ # do cluster the rows
+ Rowv <- TRUE
+ }
+ cluster_mat(mat, Rowv
+ , distfun=distfun, hclustfun=hclustfun
+ , reorderfun=reorderfun, subset=subsetRow
+ , verbose = verbose)
+ }
+ else NA
+
+ # do not show the tree if Rowv=FALSE or not a tree
+ if( identical(Rowv, FALSE) || !is_treedef(tree_row) )
+ treeheight_row <- 0
+
+ # Do col clustering
+ tree_col <- if( !is_NA(Colv) ){
+ if( identical(Colv,"Rowv") ){ # use row indexing if requested
+ if( ncol(mat) != nrow(mat) )
+ stop("aheatmap - Colv='Rowv' but cannot treat columns and rows symmetrically: input matrix is not square.")
+ treeheight_col <- treeheight_row
+ tree_row
+ }else{
+ # single numeric Colv means treeheight
+ if( isReal(Colv) ){
+ # tree height
+ treeheight_col <- Colv
+ # do cluster the columns
+ Colv <- TRUE
+ }
+ if( verbose ) message("Cluster columns")
+ cluster_mat(t(mat), Colv
+ , distfun=distfun, hclustfun=hclustfun
+ , reorderfun=reorderfun, subset=subsetCol
+ , verbose = verbose)
+ }
+ }
+ else NA
+
+ # do not show the tree if Colv=FALSE
+ if( identical(Colv, FALSE) || !is_treedef(tree_col) )
+ treeheight_col <- 0
+
+ ## ORDER THE DATA
+ if( !is_NA(tree_row) ){
+
+ # revert the row order if requested
+ if( revC ){
+ if( verbose ) message("Reverse row clustering")
+ tree_row <- rev(tree_row)
+ }
+
+ # store the order and row tree if possible
+ if( is_treedef(tree_row) ){
+ res$Rowv <- tree_row$dendrogram
+ res$rowInd <- order.dendrogram(tree_row$dendrogram)
+ if( length(res$rowInd) != nrow(mat) )
+ stop("aheatmap - row dendrogram ordering gave index of wrong length (", length(res$rowInd), ")")
+ }
+ else{
+ res$rowInd <- tree_row
+ tree_row <- NA
+ }
+
+ }else if( revC ){ # revert the row order if requested
+ res$rowInd <- nrow(mat):1L
+ }
+ # possibly map the index to the original data index
+ res$rowInd <- subset2orginal_idx(res$rowInd, subsetRow)
+
+ # order the rows if necessary
+ if( !is.null(res$rowInd) ){
+ # check validity of ordering
+ if( !is.integer(res$rowInd) || length(res$rowInd) != nrow(mat) )
+ stop("aheatmap - Invalid row ordering: should be an integer vector of length nrow(mat)=", nrow(mat))
+
+ if( verbose ) message("Order rows")
+ subInd <- attr(res$rowInd, 'subset')
+ ri <- if( is.null(subInd) ) res$rowInd else subInd
+ mat <- mat[ri, , drop=FALSE] # data
+ if( !is.null(txt) ) txt <- txt[ri, , drop = FALSE] # text
+ }
+
+ if( !is_NA(tree_col) ){
+ # store the column order and tree if possible
+ if( is_treedef(tree_col) ){
+ res$Colv <- tree_col$dendrogram
+ res$colInd <- order.dendrogram(tree_col$dendrogram)
+ if( length(res$colInd) != ncol(mat) )
+ stop("aheatmap - column dendrogram ordering gave index of wrong length (", length(res$colInd), ")")
+ }else{
+ res$colInd <- tree_col
+ tree_col <- NA
+ }
+ }
+ # possibly map the index to the original data index
+ res$colInd <- subset2orginal_idx(res$colInd, subsetCol)
+
+ # order the columns if necessary
+ if( !is.null(res$colInd) ){
+ # check validity of ordering
+ if( !is.integer(res$colInd) || length(res$colInd) != ncol(mat) )
+ stop("aheatmap - Invalid column ordering: should be an integer vector of length ncol(mat)=", ncol(mat))
+
+ if( verbose ) message("Order columns")
+ subInd <- attr(res$colInd, 'subset')
+ ci <- if( is.null(subInd) ) res$colInd else subInd
+ mat <- mat[, ci, drop=FALSE] # data
+ if( !is.null(txt) ) txt <- txt[, ci, drop = FALSE] # text
+ }
+
+ # adding clustering info
+ if( isTRUE(info) || is.character(info) ){
+
+ if( verbose ) message("Compute info")
+ if( !is.character(info) ) info <- NULL
+ linfo <- NULL
+ if( is_treedef(tree_row) && !is.null(tree_row$dist.method) )
+ linfo <- paste("rows:", tree_row$dist.method, '/', tree_row$method)
+ if( is_treedef(tree_col) && !is.null(tree_col$dist.method) )
+ linfo <- paste(linfo, paste(" - cols:", tree_col$dist.method, '/', tree_col$method))
+ info <- c(info, linfo)
+ }
+
+ # drop extra info except dendrograms for trees
+ if( is_treedef(tree_col) )
+ tree_col <- tree_col$dendrogram
+ if( is_treedef(tree_row) )
+ tree_row <- tree_row$dendrogram
+
+ # Preprocess matrix
+ if( verbose ) message("Scale matrix")
+ mat = as.matrix(mat)
+ mat = scale_mat(mat, scale)
+
+ ## Colors and scales
+ # load named palette if necessary
+ color <- ccRamp(color)
+
+ # generate breaks if necessary
+ if( is_NA(breaks) || isNumber(breaks) ){
+ if( verbose ) message("Generate breaks")
+ # if a single number: center the breaks on this value
+ cbreaks <- if( isNumber(breaks) ) breaks else NA
+ breaks = generate_breaks(as.vector(mat), length(color), center=cbreaks)
+ }
+ if( isTRUE(legend) ){
+ if( verbose ) message("Generate data legend breaks")
+ legend = grid.pretty(range(as.vector(breaks)))
+ }
+ else {
+ legend = NA
+ }
+ mat = scale_colours(mat, col = color, breaks = breaks)
+
+ annotation_legend <- annLegend
+ annotation_colors <- annColors
+
+ # render annotation tracks for both rows and columns
+ annCol_processed <- atrack(annCol, order=res$colInd, .SPECIAL=specialAnnotation(2L), .DATA=amargin(x,2L), .CACHE=annRow)
+ annRow_processed <- atrack(annRow, order=res$rowInd, .SPECIAL=specialAnnotation(1L), .DATA=amargin(x,1L), .CACHE=annCol)
+ specialAnnotation(clear=TRUE)
+ annTracks <- renderAnnotations(annCol_processed, annRow_processed
+ , annotation_colors = annotation_colors
+ , verbose=verbose)
+ #
+
+ # retrieve dimension for computing cexRow and cexCol (evaluated from the arguments)
+ nr <- nrow(mat); nc <- ncol(mat)
+ # Draw heatmap
+ res$vp <- heatmap_motor(mat, border_color = border_color, cellwidth = cellwidth, cellheight = cellheight
+ , treeheight_col = treeheight_col, treeheight_row = treeheight_row, tree_col = tree_col, tree_row = tree_row
+ , filename = filename, width = width, height = height, breaks = breaks, color = color, legend = legend
+ , annTracks = annTracks, annotation_legend = annotation_legend
+ , txt = txt
+ , fontsize = fontsize, fontsize_row = cexRow * fontsize, fontsize_col = cexCol * fontsize
+ , main = main, sub = sub, info = info
+ , verbose = verbose
+ , gp = gp)
+
+ # return info about the plot
+ invisible(res)
+}
+
+#' @import gridBase
+grid.base.mix <- function(opar, trace = getOption('verbose')){
+
+ if( !missing(opar) ){
+ if( !is.null(opar) ){
+ if( trace ) message("grid.base.mix - restore")
+ upViewport(2)
+ par(opar)
+ }
+ return(invisible())
+ }
+
+ if( trace ) message("grid.base.mix - init")
+ if( trace ) grid.rect(gp=gpar(lwd=40, col="blue"))
+ opar <- par(xpd=NA)
+ if( trace ) grid.rect(gp=gpar(lwd=30, col="green"))
+ if( trace ) message("grid.base.mix - plot.new")
+ plot.new()
+ if( trace ) grid.rect(gp=gpar(lwd=20, col="black"))
+ vps <- baseViewports()
+ pushViewport(vps$inner)
+ if( trace ) grid.rect(gp=gpar(lwd=10, col="red"))
+ pushViewport(vps$figure)
+# if( trace ) grid.rect(gp=gpar(lwd=3, col="green"))
+# pushViewport(vps$plot)
+# upViewport(2)
+# if( trace ) grid.rect(gp=gpar(lwd=3, col="pink"))
+# pushViewport(viewport(x=unit(0.5, "npc"), y=unit(0, "npc"), width=unit(0.5, "npc"), height=unit(1, "npc"), just=c("left","bottom")))
+ if( trace ) grid.rect(gp=gpar(lwd=3, col="yellow"))
+ opar
+}
+
+if( FALSE ){
+ testmix <- function(){
+ opar <- mixplot.start(FALSE)
+ profplot(curated$data$model, curated$fits[[1]])
+ mixplot.add(TRUE)
+ basismarker(curated$fits[[1]], curated$data$markers)
+ mixplot.end()
+ par(opar)
+ }
+
+ dd <- function(d, horizontal = TRUE, ...){
+ grid.rect(gp = gpar(col = "blue", lwd = 2))
+ opar <- par(plt = gridPLT(), new = TRUE)
+ on.exit(par(opar))
+ plot(d, horiz=horizontal, xaxs="i", yaxs="i", axes=FALSE, leaflab="none", ...)
+ }
+
+ toto <- function(new=FALSE){
+
+ library(RGraphics)
+ set.seed(123456)
+ x <- matrix(runif(30*20), 30)
+ x <- crossprod(x)
+ d <- as.dendrogram(hclust(dist(x)))
+
+ #grid.newpage()
+ if( new ) plot.new()
+ lo <- grid.layout(nrow=2, ncol=2)
+ pushViewport(viewport(layout=lo))
+
+ pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 1))
+ dd(d)
+ upViewport()
+ pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 2))
+ dd(d, FALSE)
+ upViewport()
+ pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 2))
+ grid.imageGrob(nrow(x), ncol(x), x)
+ upViewport()
+
+ popViewport()
+ stop("END toto")
+
+ }
+
+ test <- function(){
+ pdf('aheatmap.pdf')
+ #try(v <- aheatmap(consensus(res), color='grey:100', Colv=2L, verbose=TRUE))
+ try(v <- consensusmap(res, color='grey:100', Colv=2L, verbose=TRUE))
+ dev.off()
+ }
+
+ test2 <- function(){
+ op <- par(mfrow=c(1,2))
+ on.exit(par(op))
+ #try(v <- aheatmap(consensus(res), color='grey:100', Colv=2L, verbose=TRUE))
+ try(v <- consensusmap(res, verbose=TRUE))
+ try(v <- consensusmap(res, color='grey:100', Colv=2L, verbose=TRUE))
+ }
+
+ testsw <- function(file=TRUE){
+ if(file ){
+ pdf('asweave.pdf', width=20, height=7)
+ on.exit(dev.off())
+ }
+ opar <- par(mfrow=c(1,2))
+# removing all automatic annotation tracks
+ coefmap(res, tracks=NA, verbose=TRUE)
+# customized plot
+ coefmap(res, Colv = 'euclidean', Rowv='max', verbose=TRUE)
+# , main = "Metagene contributions in each sample", labCol = NULL
+# , tracks = c(Metagene='basis'), annCol = list(Class=a, Index=c)
+# , annColors = list(Metagene='Set2')
+# , info = TRUE)
+ par(opar)
+ }
+
+ testvp <- function(file=TRUE){
+ if(file ){
+ pdf('avp.pdf', width=20, height=7)
+ on.exit(dev.off())
+ }
+
+ plot.new()
+ lo <- grid.layout(nrow=1, ncol=2)
+ pushViewport(viewport(layout=lo))
+
+ pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 1))
+ basismap(res, Colv='eucl', verbose=TRUE)
+ upViewport()
+ pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 2))
+ coefmap(res, tracks=NA, verbose=TRUE)
+ upViewport()
+
+ popViewport()
+
+ }
+
+}
diff --git a/R/algorithmic.R b/R/algorithmic.R
new file mode 100644
index 0000000..11bd1f4
--- /dev/null
+++ b/R/algorithmic.R
@@ -0,0 +1,191 @@
+# Definition of a generic interface for algorithms
+#
+# Author: Renaud Gaujoux
+###############################################################################
+
+
+#' Generic Interface for Algorithms
+#'
+#' @description
+#' The functions documented here are S4 generics that define an general interface for
+#' -- optimisation -- algorithms.
+#'
+#' This interface builds upon the broad definition of an algorithm as a workhorse function
+#' to which is associated auxiliary objects such as an underlying model or an objective function
+#' that measures the adequation of the model with observed data.
+#' It aims at complementing the interface provided by the \code{\link{stats}} package.
+#'
+#' @section Interface fo NMF algorithms:
+#' This interface is implemented for NMF algorithms by the classes \code{\link{NMFfit}},
+#' \code{\link{NMFfitX}} and \code{\link{NMFStrategy}}, and their respective sub-classes.
+#' The examples given in this documentation page are mainly based on this implementation.
+#'
+#' @param object an object computed using some algorithm, or that describes an algorithm
+#' itself.
+#' @param value replacement value
+#' @param ... extra arguments to allow extension
+#'
+#' @name algorithmic-NMF
+#' @rdname algorithmic
+NULL
+
+#' @details
+#' \code{algorithm} and \code{algorithm<-} get/set an object that describes the
+#' algorithm used to compute another object, or with which it is associated.
+#' It may be a simple character string that gives the algorithm's names, or an object that
+#' includes the algorithm's definition itself (e.g. an \code{\link{NMFStrategy}} object).
+#'
+#' @export
+#' @rdname algorithmic
+setGeneric('algorithm', function(object, ...) standardGeneric('algorithm') )
+#' @export
+#' @rdname algorithmic
+setGeneric('algorithm<-', function(object, ..., value) standardGeneric('algorithm<-') )
+
+#' @details
+#' \code{seeding} get/set the seeding method used to initialise the computation of an object,
+#' i.e. usually the function that sets the starting point of an algorithm.
+#'
+#' @export
+#' @rdname algorithmic
+setGeneric('seeding', function(object, ...) standardGeneric('seeding') )
+#' @export
+#' @rdname algorithmic
+setGeneric('seeding<-', function(object, ..., value) standardGeneric('seeding<-') )
+
+#' @details
+#' \code{niter} and \code{niter<-} get/set the number of iterations performed
+#' to compute an object.
+#' The function \code{niter<-} would usually be called just before returning the result
+#' of an algorithm, when putting together data about the fit.
+#'
+#' @export
+#' @rdname algorithmic
+setGeneric('niter', function(object, ...) standardGeneric('niter'))
+#' @rdname algorithmic
+#' @export
+setGeneric('niter<-', function(object, ..., value) standardGeneric('niter<-'))
+
+
+#' @details
+#' \code{nrun} returns the number of times the algorithm has been run to compute
+#' an object.
+#' Usually this will be 1, but may be be more if the algorithm involves multiple
+#' starting points.
+#'
+#' @export
+#' @rdname algorithmic
+setGeneric('nrun', function(object, ...) standardGeneric('nrun') )
+#' Default method that returns the value of attribute \sQuote{nrun}.
+#'
+#' Such an attribute my be attached to objects to keep track of data about
+#' the parent fit object (e.g. by method \code{\link{consensus}}), which
+#' can be used by subsequent function calls such as plot functions
+#' (e.g. see \code{\link{consensusmap}}).
+#' This method returns \code{NULL} if no suitable data was found.
+setMethod('nrun', 'ANY',
+ function(object){
+ attr(object, 'nrun')
+ }
+)
+
+#' @details
+#' \code{objective} and \code{objective<-} get/set the objective function associated
+#' with an object.
+#' Some methods for \code{objective} may also compute the objective value with respect to
+#' some target/observed data.
+#'
+#' @export
+#' @rdname algorithmic
+setGeneric('objective', function(object, ...) standardGeneric('objective'))
+#' @export
+#' @rdname algorithmic
+setGeneric('objective<-', function(object, ..., value) standardGeneric('objective<-'))
+
+#' @details
+#' \code{runtime} returns the CPU time required to compute an object.
+#' This would generally be an object of class \code{\link[=proc.time]{proc_time}}.
+#'
+#' @export
+#' @rdname algorithmic
+setGeneric('runtime', function(object, ...) standardGeneric('runtime') )
+#' @details
+#' \code{runtime.all} returns the CPU time required to compute a collection of
+#' objects, e.g. a sequence of independent fits.
+#'
+#' @export
+#' @rdname algorithmic
+setGeneric('runtime.all', function(object, ...) standardGeneric('runtime.all') )
+
+#' @details
+#' \code{seqtime} returns the sequential CPU time -- that would be -- required
+#' to compute a collection of objects.
+#' It would differ from \code{runtime.all} if the computations were performed
+#' in parallel.
+#'
+#' @export
+#' @rdname algorithmic
+setGeneric('seqtime', function(object, ...) standardGeneric('seqtime') )
+
+#' @details
+#' \code{modelname} returns a the type of model associated with an object.
+#'
+#' @rdname algorithmic
+#' @export
+setGeneric('modelname', function(object, ...) standardGeneric('modelname'))
+
+#' Default method which returns the class name(s) of \code{object}.
+#' This should work for objects representing models on their own.
+#'
+#' For NMF objects, this is the type of NMF model, that corresponds to the
+#' name of the S4 sub-class of \code{\linkS4class{NMF}}, inherited by \code{object}.
+#'
+#' @examples
+#' # get the type of an NMF model
+#' modelname(nmfModel(3))
+#' modelname(nmfModel(3, model='NMFns'))
+#' modelname(nmfModel(3, model='NMFOffset'))
+#'
+setMethod('modelname', 'ANY',
+ function(object)
+ {
+ as.character(class(object))
+ }
+)
+
+#' @details
+#' \code{run} calls the workhorse function that actually implements a strategy/algorithm,
+#' and run it on some data object.
+#'
+#' @param y data object, e.g. a target matrix
+#' @param x a model object used as a starting point by the algorithm,
+#' e.g. a non-empty NMF model.
+#'
+#' @export
+#' @rdname algorithmic
+setGeneric('run', function(object, y, x, ...) standardGeneric('run'))
+
+#' @details
+#' \code{logs} returns the log messages output during the computation of an
+#' object.
+#' @export
+#' @rdname algorithmic
+setGeneric('logs', function(object, ...) standardGeneric('logs'))
+#' Default method that returns the value of attribute/slot \code{'logs'} or, if this latter
+#' does not exists, the value of element \code{'logs'} if \code{object} is a \code{list}.
+#' It returns \code{NULL} if no logging data was found.
+setMethod('logs', 'ANY',
+ function(object)
+ {
+ res <- attr(object, 'logs')
+ if( !is.null(res) ) res
+ else if( is.list(object) ) object$logs
+ }
+)
+
+#' @details
+#' \code{compare} compares objects obtained from running separate algorithms.
+#'
+#' @export
+#' @rdname algorithmic
+setGeneric('compare', function(object, ...) standardGeneric('compare') )
diff --git a/R/algorithms-base.R b/R/algorithms-base.R
new file mode 100644
index 0000000..3fb6023
--- /dev/null
+++ b/R/algorithms-base.R
@@ -0,0 +1,514 @@
+# Standard NMF algorithms
+#
+# Author: Renaud Gaujoux
+# Creation: 30 Apr 2012
+###############################################################################
+
+#' @include NMFstd-class.R
+#' @include NMFOffset-class.R
+#' @include NMFns-class.R
+#' @include registry-algorithms.R
+NULL
+
+
+################################################################################
+# BRUNET (standard KL-based NMF)
+################################################################################
+
+#' NMF Algorithm/Updates for Kullback-Leibler Divergence
+#'
+#' The built-in NMF algorithms described here minimise
+#' the Kullback-Leibler divergence (KL) between an NMF model and a target matrix.
+#' They use the updates for the basis and coefficient matrices (\eqn{W} and \eqn{H})
+#' defined by \cite{Brunet2004}, which are essentially those from \cite{Lee2001},
+#' with an stabilisation step that shift up all entries from zero every 10 iterations,
+#' to a very small positive value.
+#'
+#' @param i current iteration number.
+#' @param v target matrix.
+#' @param x current NMF model, as an \code{\linkS4class{NMF}} object.
+#' @param eps small numeric value used to ensure numeric stability, by shifting up
+#' entries from zero to this fixed value.
+#' @param ... extra arguments. These are generally not used and present
+#' only to allow other arguments from the main call to be passed to the
+#' initialisation and stopping criterion functions (slots \code{onInit} and
+#' \code{Stop} respectively).
+#' @inheritParams nmf_update.KL.h
+#'
+#' @author
+#' Original implementation in MATLAB: Jean-Philippe Brunet \email{brunet@@broad.mit.edu}
+#'
+#' Port to R and optimisation in C++: Renaud Gaujoux
+#'
+#' @source
+#'
+#' Original MATLAB files and references can be found at:
+#'
+#' \url{http://www.broadinstitute.org/mpr/publications/projects/NMF/nmf.m}
+#'
+#' \url{http://www.broadinstitute.org/publications/broad872}
+#'
+#' Original license terms:
+#'
+#' This software and its documentation are copyright 2004 by the
+#' Broad Institute/Massachusetts Institute of Technology. All rights are reserved.
+#' This software is supplied without any warranty or guaranteed support whatsoever.
+#' Neither the Broad Institute nor MIT can not be responsible for its use, misuse,
+#' or functionality.
+#'
+#' @details
+#' \code{nmf_update.brunet_R} implements in pure R a single update step, i.e. it updates
+#' both matrices.
+#'
+#' @export
+#' @rdname KL-nmf
+#' @aliases KL-nmf
+nmf_update.brunet_R <- function(i, v, x, eps=.Machine$double.eps, ...)
+{
+ # retrieve each factor
+ w <- .basis(x); h <- .coef(x);
+
+ # standard divergence-reducing NMF update for H
+ h <- R_std.divergence.update.h(v, w, h)
+
+ # standard divergence-reducing NMF update for W
+ w <- R_std.divergence.update.w(v, w, h)
+
+ #every 10 iterations: adjust small values to avoid underflow
+ if( i %% 10 == 0 ){
+ #precision threshold for numerical stability
+ #eps <- .Machine$double.eps
+ h[h<eps] <- eps;
+ w[w<eps] <- eps;
+ }
+
+ #return the modified model
+ .basis(x) <- w; .coef(x) <- h;
+ return(x)
+
+}
+
+#' \code{nmf_update.brunet} implements in C++ an optimised version of the single update step.
+#'
+#' @export
+#' @rdname KL-nmf
+nmf_update.brunet <- function(i, v, x, copy=FALSE, eps=.Machine$double.eps, ...)
+{
+ # retrieve each factor
+ w <- .basis(x); h <- .coef(x);
+ # fixed terms
+ nb <- nbterms(x); nc <- ncterms(x)
+
+ # standard divergence-reducing NMF update for H
+ h <- std.divergence.update.h(v, w, h, nbterms=nb, ncterms=nc, copy=copy)
+
+ # standard divergence-reducing NMF update for W
+ w <- std.divergence.update.w(v, w, h, nbterms=nb, ncterms=nc, copy=copy)
+
+ #every 10 iterations: adjust small values to avoid underflow
+ # NB: one adjusts in place even when copy=TRUE, as 'h' and 'w' are local variables
+ if( i %% 10 == 0 ){
+ #eps <- .Machine$double.eps
+ h <- pmax.inplace(h, eps, icterms(x))
+ w <- pmax.inplace(w, eps, ibterms(x))
+ }
+
+ # update object if the updates duplicated the model
+ if( copy ){
+ #return the modified model
+ .basis(x) <- w;
+ .coef(x) <- h;
+ }
+ return(x)
+
+}
+
+#' Algorithms \sQuote{brunet} and \sQuote{.R#brunet} provide the complete NMF algorithm from \cite{Brunet2004},
+#' using the C++-optimised and pure R updates \code{\link{nmf_update.brunet}} and \code{\link{nmf_update.brunet_R}}
+#' respectively.
+#'
+#' @inheritParams run,NMFStrategyIterative,matrix,NMFfit-method
+#' @inheritParams nmf.stop.connectivity
+#'
+#' @rdname KL-nmf
+#' @aliases brunet_R-nmf
+nmfAlgorithm.brunet_R <- setNMFMethod('.R#brunet'
+ , objective='KL'
+ , Update=nmf_update.brunet_R
+ , Stop='connectivity')
+
+# Optimised version
+#' @rdname KL-nmf
+#' @aliases brunet-nmf
+nmfAlgorithm.brunet <- setNMFMethod('brunet', '.R#brunet', Update=nmf_update.brunet)
+
+#' Algorithm \sQuote{KL} provides an NMF algorithm based on the C++-optimised version of
+#' the updates from \cite{Brunet2004}, which uses the stationarity of the objective value
+#' as a stopping criterion \code{\link{nmf.stop.stationary}}, instead of the
+#' stationarity of the connectivity matrix \code{\link{nmf.stop.connectivity}} as used by
+#' \sQuote{brunet}.
+#'
+#' @inheritParams nmf.stop.stationary
+#'
+#' @rdname KL-nmf
+nmfAlgorithm.KL <- setNMFMethod('KL'
+ , objective='KL'
+ , Update=nmf_update.brunet
+ , Stop='stationary')
+
+################################################################################
+# LEE (standard Euclidean-based NMF)
+################################################################################
+
+#' NMF Algorithm/Updates for Frobenius Norm
+#'
+#' The built-in NMF algorithms described here minimise
+#' the Frobenius norm (Euclidean distance) between an NMF model and a target matrix.
+#' They use the updates for the basis and coefficient matrices (\eqn{W} and \eqn{H})
+#' defined by \cite{Lee2001}.
+#'
+#' @inheritParams nmf_update.brunet
+#' @inheritParams nmf_update.euclidean.h
+#' @param rescale logical that indicates if the basis matrix \eqn{W} should be
+#' rescaled so that its columns sum up to one.
+#'
+#' @author
+#' Original update definition: D D Lee and HS Seung
+#'
+#' Port to R and optimisation in C++: Renaud Gaujoux
+#'
+#' @details
+#' \code{nmf_update.lee_R} implements in pure R a single update step, i.e. it updates
+#' both matrices.
+#'
+#' @export
+#' @rdname Frobenius-nmf
+#' @aliases Frobenius-nmf
+nmf_update.lee_R <- function(i, v, x, rescale=TRUE, eps=10^-9, ...)
+{
+ # retrieve each factor
+ w <- .basis(x); h <- .coef(x);
+
+ #precision threshold for numerical stability
+ #eps <- 10^-9
+
+ # compute the estimate WH
+ #wh <- estimate(x)
+
+ # euclidean-reducing NMF iterations
+ # H_au = H_au (W^T V)_au / (W^T W H)_au
+ #h <- pmax(h * (t(w) %*% v),eps) / ((t(w) %*% w) %*% h + eps);
+ h <- R_std.euclidean.update.h(v, w, h, eps=eps)
+
+ # update H and recompute the estimate WH
+ #metaprofiles(x) <- h
+ #wh <- estimate(x)
+
+ # W_ia = W_ia (V H^T)_ia / (W H H^T)_ia and columns are rescaled after each iteration
+ #w <- pmax(w * (v %*% t(h)), eps) / (w %*% (h %*% t(h)) + eps);
+ w <- R_std.euclidean.update.w(v, w, h, eps=eps)
+ #rescale columns TODO: effect of rescaling? the rescaling makes the update with offset fail
+ if( rescale ) w <- sweep(w, 2L, colSums(w), "/", check.margin=FALSE)
+
+ #return the modified model
+ .basis(x) <- w; .coef(x) <- h;
+ return(x)
+}
+
+#' \code{nmf_update.lee} implements in C++ an optimised version of the single update step.
+#'
+#' @export
+#' @rdname Frobenius-nmf
+nmf_update.lee <- function(i, v, x, rescale=TRUE, copy=FALSE, eps=10^-9, weight=NULL, ...)
+{
+ # retrieve each factor
+ w <- .basis(x); h <- .coef(x);
+ # fixed terms
+ nb <- nbterms(x); nc <- ncterms(x)
+
+ #precision threshold for numerical stability
+ #eps <- 10^-9
+
+ # compute the estimate WH
+ #wh <- estimate(x)
+
+ # euclidean-reducing NMF iterations
+ # H_au = H_au (W^T V)_au / (W^T W H)_au
+ h <- std.euclidean.update.h(v, w, h, eps=eps, nbterms=nb, ncterms=nc, copy=copy)
+ # update original object if not modified in place
+ if( copy ) .coef(x) <- h
+
+ # W_ia = W_ia (V H^T)_ia / (W H H^T)_ia and columns are rescaled after each iteration
+ w <- std.euclidean.update.w(v, w, h, eps=eps, weight=weight, nbterms=nb, ncterms=nc, copy=copy)
+ #rescale columns TODO: effect of rescaling? the rescaling makes the update with offset fail
+ if( rescale ){
+ w <- sweep(w, 2L, colSums(w), "/", check.margin=FALSE)
+ }
+
+ #return the modified model
+ .basis(x) <- w;
+ return(x)
+}
+
+#' Algorithms \sQuote{lee} and \sQuote{.R#lee} provide the complete NMF algorithm from \cite{Lee2001},
+#' using the C++-optimised and pure R updates \code{\link{nmf_update.lee}} and \code{\link{nmf_update.lee_R}}
+#' respectively.
+#'
+#' @inheritParams run,NMFStrategyIterative,matrix,NMFfit-method
+#' @inheritParams nmf.stop.connectivity
+#'
+#' @rdname Frobenius-nmf
+#' @aliases lee_R-nmf
+nmfAlgorithm.lee_R <- setNMFMethod('.R#lee', objective='euclidean'
+ , Update=nmf_update.lee_R
+ , Stop='connectivity')
+
+# Optimised version
+#' @rdname Frobenius-nmf
+#' @aliases lee-nmf
+nmfAlgorithm.lee <- setNMFMethod('lee', '.R#lee', Update=nmf_update.lee)
+
+#' Algorithm \sQuote{Frobenius} provides an NMF algorithm based on the C++-optimised version of
+#' the updates from \cite{Lee2001}, which uses the stationarity of the objective value
+#' as a stopping criterion \code{\link{nmf.stop.stationary}}, instead of the
+#' stationarity of the connectivity matrix \code{\link{nmf.stop.connectivity}} as used by
+#' \sQuote{lee}.
+#'
+#' @inheritParams nmf.stop.stationary
+#'
+#' @rdname Frobenius-nmf
+nmfAlgorithm.Frobenius <- setNMFMethod('Frobenius', objective='euclidean'
+ , Update=nmf_update.lee
+ , Stop='stationary')
+
+################################################################################
+# OFFSET (Euclidean-based NMF with offset) [Badea (2008)]
+################################################################################
+
+
+#' NMF Multiplicative Update for NMF with Offset Models
+#'
+#' These update rules proposed by \cite{Badea2008} are modified version of
+#' the updates from \cite{Lee2001}, that include an offset/intercept vector,
+#' which models a common baseline for each feature accross all samples:
+#' \deqn{V \approx W H + I}
+#'
+#' \code{nmf_update.euclidean_offset.h} and \code{nmf_update.euclidean_offset.w}
+#' compute the updated NMFOffset model, using the optimized \emph{C++} implementations.
+#'
+#' @details
+#' The associated model is defined as an \code{\linkS4class{NMFOffset}} object.
+#' The details of the multiplicative updates can be found in \cite{Badea2008}.
+#' Note that the updates are the ones defined for a single datasets, not the
+#' simultaneous NMF model, which is fit by algorithm \sQuote{siNMF} from
+#' formula-based NMF models.
+#'
+#' @inheritParams nmf_update.brunet
+#' @inheritParams nmf_update.euclidean.h
+#'
+#' @param offset current value of the offset/intercept vector.
+#' It must be of length equal to the number of rows in the target matrix.
+#'
+#' @author
+#' Original update definition: Liviu Badea
+#'
+#' Port to R and optimisation in C++: Renaud Gaujoux
+#'
+#' @return an \code{\linkS4class{NMFOffset}} model object.
+#'
+#' @export
+#' @rdname offset-nmf
+nmf_update.euclidean_offset.h <- function(v, w, h, offset, eps=10^-9, copy=TRUE){
+ .Call("offset_euclidean_update_H", v, w, h, offset, eps, copy, PACKAGE='NMF')
+}
+#' @export
+#' @rdname offset-nmf
+nmf_update.euclidean_offset.w <- function(v, w, h, offset, eps=10^-9, copy=TRUE){
+ .Call("offset_euclidean_update_W", v, w, h, offset, eps, copy, PACKAGE='NMF')
+}
+#' \code{nmf_update.offset_R} implements a complete single update step,
+#' using plain R updates.
+#' @export
+#' @rdname offset-nmf
+nmf_update.offset_R <- function(i, v, x, eps=10^-9, ...)
+{
+ # retrieve each factor
+ w <- .basis(x); h <- .coef(x);
+ # retrieve offset and fill it if necessary (with mean of rows)
+ off <- offset(x)
+ if( i == 1 && length(off) == 0 )
+ off <- rowMeans(v)
+
+ #precision threshold for numerical stability
+ #eps <- 10^-9
+
+ # compute standard lee update (it will take the offset into account) without rescaling W's columns
+
+ h <- R_std.euclidean.update.h(v, w, h, wh=w%*%h + off, eps=eps)
+ w <- R_std.euclidean.update.w(v, w, h, wh=w%*%h + off, eps=eps)
+ #x <- nmf_update.lee(i, v, x, rescale=FALSE, ...)
+
+ # update the offset
+ # V0_i = V0_i ( sum_j V_ij ) / ( sum_j (V.off + W H)_ij )
+ x at offset <- off * pmax(rowSums(v), eps) / (rowSums(w%*%h + off) + eps)
+
+ #return the modified model
+ .basis(x) <- w; .coef(x) <- h;
+ return(x)
+}
+#' \code{nmf_update.offset} implements a complete single update step,
+#' using C++-optimised updates.
+#' @export
+#' @rdname offset-nmf
+nmf_update.offset <- function(i, v, x, copy=FALSE, eps=10^-9, ...)
+{
+ # retrieve each factor
+ w <- .basis(x); h <- .coef(x);
+ # retrieve offset and fill it if necessary (with mean of rows)
+ off <- offset(x)
+ if( i == 1 && length(off) == 0 )
+ off <- rowMeans(v)
+
+ #precision threshold for numerical stability
+ #eps <- 10^-9
+
+ # compute standard offset updates
+ h <- nmf_update.euclidean_offset.h(v, w, h, off, eps=eps, copy=copy)
+ w <- nmf_update.euclidean_offset.w(v, w, h, off, eps=eps, copy=copy)
+
+ # update the offset
+ # V0_i = V0_i ( sum_j V_ij ) / ( sum_j (V.off + W H)_ij )
+ x at offset <- off * pmax(rowSums(v), eps) / (rowSums(w%*%h + off) + eps)
+
+ # update the original object if not modified in place
+ if( copy ){
+ .basis(x) <- w;
+ .coef(x) <- h;
+ }
+ return(x)
+}
+
+#' Algorithms \sQuote{offset} and \sQuote{.R#offset} provide the complete NMF-with-offset algorithm
+#' from \cite{Badea2008}, using the C++-optimised and pure R updates \code{\link{nmf_update.offset}}
+#' and \code{\link{nmf_update.offset_R}} respectively.
+#'
+#' @inheritParams run,NMFStrategyIterative,matrix,NMFfit-method
+#' @inheritParams nmf.stop.connectivity
+#'
+#' @rdname offset-nmf
+#' @aliases offset_R-nmf
+nmfAlgorithm.offset_R <- setNMFMethod('.R#offset', objective='euclidean'
+ , model = 'NMFOffset'
+ , Update=nmf_update.offset_R
+ , Stop='connectivity')
+
+# NMF with offset (optimised version)
+#' @rdname offset-nmf
+nmfAlgorithm.offset <- setNMFMethod('offset', '.R#offset', Update=nmf_update.offset)
+
+################################################################################
+# Non-smooth NMF (KL-based NMF) [Pascual-Montano (2006)]
+################################################################################
+
+#' NMF Multiplicative Update for Nonsmooth Nonnegative Matrix Factorization (nsNMF).
+#'
+#' These update rules, defined for the \code{\linkS4class{NMFns}} model \eqn{V \approx W S H} from
+#' \cite{Pascual-Montano2006}, that introduces an intermediate smoothing matrix to enhance
+#' sparsity of the factors.
+#'
+#' \code{nmf_update.ns} computes the updated nsNMF model.
+#' It uses the optimized \emph{C++} implementations \code{\link{nmf_update.KL.w}} and
+#' \code{\link{nmf_update.KL.h}} to update \eqn{W} and \eqn{H} respectively.
+#'
+#' @details
+#' The multiplicative updates are based on the updates proposed by \cite{Brunet2004},
+#' except that the NMF estimate \eqn{W H} is replaced by \eqn{W S H} and \eqn{W}
+#' (resp. \eqn{H}) is replaced by \eqn{W S} (resp. \eqn{S H}) in the update of
+#' \eqn{H} (resp. \eqn{W}).
+#'
+#' See \code{\link{nmf_update.KL}} for more details on the update formula.
+#'
+#' @inheritParams nmf_update.brunet
+#'
+#' @return an \code{\linkS4class{NMFns}} model object.
+#'
+#' @export
+#' @rdname nsNMF-nmf
+nmf_update.ns <- function(i, v, x, copy=FALSE, ...)
+{
+ # retrieve and alter the factors for updating H
+ S <- smoothing(x)
+ w <- .basis(x)
+ h <- .coef(x);
+
+ # standard divergence-reducing update for H with modified W
+ h <- std.divergence.update.h(v, w %*% S, h, copy=copy)
+
+ # update H if not modified in place
+ if( copy ) .coef(x) <- h
+
+ # standard divergence-reducing update for W with modified H
+ w <- std.divergence.update.w(v, w, S %*% h, copy=copy)
+
+ # rescale columns of W
+ w <- sweep(w, 2L, colSums(w), '/', check.margin=FALSE)
+
+ #return the modified model
+ .basis(x) <- w;
+ return(x)
+}
+#' \code{nmf_update.ns_R} implements the same updates in \emph{plain R}.
+#'
+#' @export
+#' @rdname nsNMF-nmf
+nmf_update.ns_R <- function(i, v, x, ...)
+{
+ # retrieve and alter the factors for updating H
+ S <- smoothing(x)
+ w <- .basis(x)
+ #w <- metagenes(x) %*% smoothing(fit(x)); # W <- WS
+ h <- .coef(x);
+
+ # compute the estimate WH
+ #wh <- estimate(x, W=w.init, H=h, S=S)
+
+ # standard divergence-reducing update for H with modified W
+ h <- R_std.divergence.update.h(v, w %*% S, h)
+
+ # update H and recompute the estimate WH
+ .coef(x) <- h
+ # retrieve and alter the factors for updating W
+ #w <- tmp;
+ #h <- smoothing(fit(x)) %*% metaprofiles(x); # H <- SH
+ #h <- S %*% h; # H <- SH
+
+ # standard divergence-reducing update for W with modified H
+ w <- R_std.divergence.update.w(v, w, S %*% h)
+
+ # rescale columns of W
+ w <- sweep(w, 2L, colSums(w), '/', check.margin=FALSE)
+
+ #return the modified model
+ .basis(x) <- w; #metaprofiles(x) <- h;
+ return(x)
+}
+
+## REGISTRATION
+#' Algorithms \sQuote{nsNMF} and \sQuote{.R#nsNMF} provide the complete NMF algorithm from \cite{Pascual-Montano2006},
+#' using the C++-optimised and plain R updates \code{\link{nmf_update.brunet}} and \code{\link{nmf_update.brunet_R}}
+#' respectively.
+#' The stopping criterion is based on the stationarity of the connectivity matrix.
+#'
+#' @inheritParams run,NMFStrategyIterative,matrix,NMFfit-method
+#' @inheritParams nmf.stop.connectivity
+#'
+#' @rdname nsNMF-nmf
+#' @aliases nsNMF_R-nmf
+nmfAlgorithm.nsNMF_R <- setNMFMethod('.R#nsNMF', objective='KL'
+ , model='NMFns'
+ , Update=nmf_update.ns_R
+ , Stop='connectivity')
+
+# Optmized version
+#' @rdname nsNMF-nmf
+nmfAlgorithm.nsNMF <- setNMFMethod('nsNMF', '.R#nsNMF', Update=nmf_update.ns)
diff --git a/R/algorithms-brunet.R b/R/algorithms-brunet.R
new file mode 100644
index 0000000..0f5aa92
--- /dev/null
+++ b/R/algorithms-brunet.R
@@ -0,0 +1,29 @@
+# Original Matlab algorithm from Brunet et al. (2004)
+#
+# Author: Renaud Gaujoux
+# Created: 23 Nov 2012
+###############################################################################
+
+#' @include registry-algorithms.R
+NULL
+
+#' The algorithm \sQuote{.M#brunet} provide access to the \emph{original} Matlab
+#' algorithm from \cite{Brunet2004}, through the \pkg{RcppOctave} package.
+#' The Matlab code used can be found in the \pkg{NMF} package's 'm-files/'
+#' sub-directory:
+#'
+#' \samp{
+#' library(RcppOctave)
+#' file.show(system.mfile('brunet.m', package='NMF'))
+#' }
+#'
+#' @rdname KL-nmf
+#' @aliases brunet_M-nmf
+nmfAlgorithm.brunet_M <- setNMFMethod('.M#brunet',
+ , objective= 'KL'
+ , mcode = 'brunet.m'
+ , algorithm = function (y, x, verbose=nmf.getOption('verbose')
+ , maxIter = nmf.getOption('maxIter') %||% 2000L){
+ RcppOctave::.CallOctave('brunet', y, nbasis(x), verbose, basis(x), coef(x), maxIter);
+ }
+)
diff --git a/R/algorithms-lnmf.R b/R/algorithms-lnmf.R
new file mode 100644
index 0000000..321c1e7
--- /dev/null
+++ b/R/algorithms-lnmf.R
@@ -0,0 +1,87 @@
+# Algorithm for Nonnegative Matrix Factorization: Local NMF (LNMF)
+#
+# @author Renaud Gaujoux
+# @created 21 Jul 2009
+
+#' @include registry-algorithms.R
+NULL
+
+###% \item{\sQuote{lnmf}}{ Local Nonnegative Matrix Factorization. Based on a
+###% regularized Kullback-Leibler divergence, it uses a modified version of
+###% Lee and Seung's multiplicative updates.
+###% See \emph{Li et al. (2001)}.}
+
+###% Algorithm for Nonnegative Matrix Factorization: Local NMF (LNMF).
+###%
+###% The local NMF algorithm is minimizes use the following Kullback-Leibler divergence based objective function:
+###% $$
+###% \sum_{i=1}^m\sum_{j=1}^n\left(X_{ij} \log\frac{X_{ij}}{(WH)_{ij}} - X_{ij} + (WH)_{ij} + \alpha U_{ij}\right) - \beta \sum_i V_{ij},
+###% $$
+###% where $\alpha, \beta > 0$ are some constants, $U = W^TW$ and $V = HH^T$.
+###%
+###% TODO: add explaination for each terms (see Wild 2002)
+###%
+###% @references Learning spatially localized, parts-based representation
+###% , S.Z. Li, X.W. Hou, and H.J. Zhang.
+###% , In Proceedings of IEEE International Conference on Computer Vision and Pattern Recognition
+###% , December 2001
+nmf_update_R.lnmf <- function(i, v, data, ...){
+
+ # retrieve each factor
+ w <- .basis(data); h <- .coef(data);
+
+ # update H
+ h <- sqrt( h * crossprod(w, v / (w %*% h)) )
+
+ # update W using the standard divergence based update
+ w <- R_std.divergence.update.w(v, w, h, w %*% h)
+
+ # scale columns of W
+ w <- sweep(w, 2L, colSums(w), "/", check.margin=FALSE)
+
+ #every 10 iterations: adjust small values to avoid underflow
+ if( i %% 10 == 0 ){
+ #precision threshold for numerical stability
+ eps <- .Machine$double.eps
+ h[h<eps] <- eps;
+ w[w<eps] <- eps;
+ }
+
+ # return updated data
+ .basis(data) <- w; .coef(data) <- h
+ return(data)
+}
+
+nmf_update.lnmf <- function(i, v, data, ...){
+
+ # retrieve each factor
+ w <- .basis(data); h <- .coef(data);
+
+ # update H
+ h <- sqrt( h * crossprod(w, v / (w %*% h)) )
+
+ # update W using the standard divergence based update
+ w <- std.divergence.update.w(v, w, h)
+
+ # scale columns of W
+ w <- apply(w, 2, function(x) x/sum(x))
+
+ #every 10 iterations: adjust small values to avoid underflow
+ if( i %% 10 == 0 ){
+ #precision threshold for numerical stability
+ eps <- .Machine$double.eps
+ h[h<eps] <- eps;
+ w[w<eps] <- eps;
+ }
+
+ # return updated data
+ .basis(data) <- w; .coef(data) <- h
+ return(data)
+}
+
+# register the LNMF algorithm
+#nmfAlgorithm.lnmf_R <- setNMFMethod('.R#lnmf', objective='KL'
+# , Update=nmf_update_R.lnmf
+# , Stop='connectivity')
+#
+#nmfAlgorithm.lnmf <- setNMFMethod('lnmf', '.R#lnmf', Update=nmf_update.lnmf)
diff --git a/R/algorithms-lsnmf.R b/R/algorithms-lsnmf.R
new file mode 100644
index 0000000..1fbc5ea
--- /dev/null
+++ b/R/algorithms-lsnmf.R
@@ -0,0 +1,94 @@
+# Implementations of LS-NMF
+#
+# Reference:
+# LS-NMF: a modified non-negative matrix factorization algorithm utilizing uncertainty estimates.
+# Wang, Guoli, Andrew V Kossenkov, and Michael F Ochs.
+# BMC bioinformatics 7 (January 2006): 175. http://www.ncbi.nlm.nih.gov/pubmed/16569230.
+#
+# Author: Renaud Gaujoux
+# Creation: 09 Nov 2011
+###############################################################################
+
+#' @include registry-algorithms.R
+NULL
+
+#' Multiplicative Updates for LS-NMF
+#'
+#' Implementation of the updates for the LS-NMF algorithm from \cite{Wang2006}.
+#'
+#' @param i current iteration
+#' @param X target matrix
+#' @param object current NMF model
+#' @param weight value for \eqn{\Sigma}{S}, i.e. the weights that are applied to each
+#' entry in \code{X} by \code{X * weight} (= entry wise product).
+#' Weights are usually specified as a matrix of the same dimension as \code{X}
+#' (e.g. uncertainty estimates for each measurement), but may also be passed as a vector,
+#' in which case the standard rules for entry wise product between matrices and vectors apply
+#' (e.g. recylcing elements).
+#' @param eps small number passed to the standard euclidean-based NMF updates
+#' (see \code{\link{nmf_update.euclidean}}).
+#' @param ... extra arguments (not used)
+#'
+#' @return updated object \code{object}
+#' @rdname lsNMF-nmf
+nmf_update.lsnmf <- function(i, X, object, weight, eps=10^-9, ...)
+{
+ if( i == 1 ){# pre-compute weighted target matrix
+ staticVar('wX', X * weight, init=TRUE)
+ }
+
+ # retrieve weighted target matrix
+ wX <- staticVar('wX')
+
+ # retrieve each factor
+ w <- .basis(object); h <- .coef(object);
+
+ # compute the estimate WH
+ wh <- fitted(object) * weight
+
+ # euclidean-reducing NMF iterations
+ # H_au = H_au (W^T V/sigma)_au / (W^T (W H)/sigma)_au
+ h <- nmf_update.euclidean.h_R(wX, w, h, wh=wh, eps=eps)
+
+ # update H and recompute the estimate WH
+ .coef(object) <- h;
+ wh <- fitted(object) * weight
+
+ # W_ia = W_ia (V/sigma H^T)_ia / ((W H)/sigma H^T)_ia and columns are rescaled after each iteration
+ w <- nmf_update.euclidean.w_R(wX, w, h, wh=wh, eps=eps)
+
+ #return the modified data
+ .basis(object) <- w
+ return(object)
+}
+
+#' \code{wrss} implements the objective function used by the LS-NMF algorithm.
+#'
+#' @rdname lsNMF-nmf
+wrss <- function(object, X, weight){
+ sum( ((X - fitted(object)) * weight)^2 )/2
+}
+
+# Registration of LS-NMF
+#' @inheritParams run,NMFStrategyIterative,matrix,NMFfit-method
+#' @inheritParams nmf.stop.stationary
+#'
+#' @aliases lsNMF-nmf
+#' @rdname lsNMF-nmf
+nmfAlgorithm.lsNMF <- setNMFMethod('ls-nmf', objective=wrss
+ , Update=nmf_update.lsnmf
+ , Stop='stationary')
+
+# Unit test for the LS-NMF algorithm
+runit.lsnmf <- function(){
+
+ requireNamespace('RUnit')
+ set.seed(12345)
+ X <- rmatrix(100,20)
+
+ res <- nmf(X, 3, 'ls-nmf', weight=1, seed=1)
+ res2 <- nmf(X, 3, '.R#lee', rescale=FALSE, seed=1, .stop=nmf.stop.stationary)
+ tol <- 10^-14
+ RUnit::checkTrue( nmf.equal(res, res2, identical=FALSE, tol=tol ), paste("LS-NMF with weight = 1 and .R#Lee (no scale + stationary) give identical results at tolerance=", tol))
+
+}
diff --git a/R/algorithms-pe-nmf.R b/R/algorithms-pe-nmf.R
new file mode 100644
index 0000000..5b70b31
--- /dev/null
+++ b/R/algorithms-pe-nmf.R
@@ -0,0 +1,68 @@
+#' @include registry-algorithms.R
+NULL
+
+###% NMF Algorithm: Pattern Expression NMF
+###%
+###% Implements the PE-NMF algorithm from Zhang et al (2008).
+###%
+###% It is implemented using the iterative schema defined by the
+###% NMFStrategyIterative class.
+###% The algorithm minimizes the Frobenius norm, with two regularization terms
+###% (one for each matrix factor) parametrized by two parameters:
+###%
+###% min_{W,H} 1/2 ||V - WH||^2
+###% + alpha \sum_{i<>j} W_i^T W_j
+###% + beta \sum_{i,j} H_{ij}
+###%
+###% So there is two parameters: alpha and beta.
+###% The updates for the matrix factors are (in R notations):
+###%
+###% H_{i+1} = H_i ( W_i^T %*% V ) / ( W_i^T %*% W_i %*% H_i + beta)
+###% W_{i+1} = W_i ( V %*% H_i^T ) / ( W_i %*% H_i %*% H_i^T + alpha W_i %*% M )
+###%
+###% with matrix M is full of one with diagonal zero.
+###%
+###% @author Renaud Gaujoux
+###% @creation 17 Jan 2010
+###%
+
+penmf.objective <- function(fit, x, alpha, beta, ...)
+{
+ w <- .basis(fit)
+ 1/2 * sum( (x - fitted(fit))^2 )
+ + alpha * ( crossprod(w) - sum(w^2) )
+ + beta * sum(.coef(fit))
+}
+
+nmf_update.penmf <- function(i, x, data, alpha, beta, ...){
+
+ # retrieve each factor
+ w <- .basis(data); h <- .coef(data);
+
+ # At the first iteration initialise matrix M
+ if( TRUE || i == 1 ){
+ r <- ncol(w)
+ M <- matrix(1, nrow=r, ncol=r) - diag(1, r)
+ #staticVar('M', M, init=TRUE)
+ }
+ #else M <- staticVar('M')
+
+ #precision threshold for numerical stability
+ eps <- 10^-9
+
+ # H_{i+1} = H_i ( W_i^T %*% V ) / ( W_i^T %*% W_i %*% H_i + beta)
+ h <- h * crossprod(w, x) / ( crossprod(w) %*% h + beta)
+
+ # W_{i+1} = W_i ( V %*% H_i^T ) / ( W_i %*% H_i %*% H_i^T + alpha W_i %*% M )
+ w <- w * tcrossprod(x, h) / ( w %*% tcrossprod(h) + alpha * w %*% M )
+
+ #return the modified data
+ .basis(data) <- w; .coef(data) <- h;
+ data
+}
+
+# register PE-NMF
+nmfAlgorithm.peNMF <- setNMFMethod('pe-nmf', objective = penmf.objective
+ , model='NMFstd'
+ , Update= nmf_update.penmf
+ , Stop='stationary')
diff --git a/R/algorithms-siNMF.R b/R/algorithms-siNMF.R
new file mode 100644
index 0000000..76bd412
--- /dev/null
+++ b/R/algorithms-siNMF.R
@@ -0,0 +1,122 @@
+# Implementation of siNMF from Badea (2008)
+#
+# Author: Renaud Gaujoux
+# Creation: 09 Jul 2012
+###############################################################################
+
+#' @include registry-algorithms.R
+NULL
+
+siNMF_R <- function(i, v, data, beta0=1, scale=TRUE, ...){
+
+ # retrieve each factor
+ w <- basis(data); h <- coef(data);
+ # fixed terms
+ nb <- nbterms(data); nc <- ncterms(data)
+
+ if( i == 1 ){
+ if( !nc )
+ stop("Method 'siNMF' requires a formula based model")
+
+ if( !is.na(beta0) ){
+ # compute beta
+ gr <- as.numeric(cterms(data)[[1L]])
+ beta <- beta0 * (norm(v[,gr==1], 'F') / norm(v[,gr==2], 'F'))^2
+ # make sweeping vector
+ vbeta <- rep(1, ncol(v))
+ vbeta[gr==2] <- sqrt(beta)
+ staticVar('vbeta', vbeta, init=TRUE)
+ # sweep data
+ staticVar('v', sweep(v, 2L, vbeta, '*', check.margin=FALSE), init=TRUE)
+ }
+ # store non-fixed coef indexes
+ staticVar('icoef', icoef(data), init=TRUE)
+ }
+
+ #precision threshold for numerical stability
+ eps <- 10^-9
+
+ sh <- h
+ if( !is.na(beta0) ){
+ # retrieved swept matrix
+ sv <- staticVar('v')
+ vbeta <- staticVar('vbeta')
+ # sweep h with beta
+ sh <- sweep(h, 2L, vbeta, '*', check.margin=FALSE)
+ }
+
+ # compute standard euclidean updates
+ w <- nmf_update.euclidean.w(sv, w, sh, eps=eps, nbterms=nb, ncterms=nc, copy=TRUE)
+ h <- nmf_update.euclidean.h(v, w, h, eps=eps, nbterms=nb, ncterms=nc, copy=TRUE)
+
+ # normalize columns of w
+ if( scale ){
+ icoef <- staticVar('icoef')
+ wb <- w[, icoef]
+ d <- sqrt(colSums(wb^2))
+ w[, icoef] <- sweep(wb, 2L, d, '/')
+ h[icoef, ] <- sweep(h[icoef, ], 1L, d, '*')
+ }
+
+ .coef(data) <- h
+ .basis(data) <- w
+ data
+}
+
+setNMFMethod('.siNMF', 'lee', Update=siNMF_R)
+
+siNMF <- function(i, v, data, beta0=1, scale=TRUE, eps=10^-9, ...){
+
+ # retrieve each factor
+ w <- basis(data); h <- coef(data);
+ # fixed terms
+ nb <- nbterms(data); nc <- ncterms(data)
+
+ if( i == 1 ){
+ if( !nc )
+ stop("Method 'siNMF' requires a formula based model")
+
+ vbeta <- NULL
+ if( !is.na(beta0) ){
+ # compute beta
+ gr <- cterms(data)[[1L]]
+ gr <- droplevels(gr)
+ # make sweeping vector
+ vbeta <- rep(1, ncol(v))
+ idx <- split(1:ncol(v), gr)
+ # compute base value from first level
+ beta <- beta0 * norm(v[,idx[[1]]], 'F')^2
+ vbeta <- lapply(idx[-1], function(j){
+ rep(beta / norm(v[,j], 'F')^2, length(j))
+ })
+ vbeta <- c(rep(1, length(idx[[1]])), unlist(vbeta, use.names=FALSE))
+ vbeta <- vbeta[order(unlist(idx))]
+ }
+ # store weights
+ staticVar('beta', vbeta, init=TRUE)
+ # store non-fixed coef indexes
+ staticVar('icoef', icoef(data), init=TRUE)
+ }
+
+ # retrieve weights
+ beta <- staticVar('beta')
+
+ # compute standard euclidean updates
+ w <- nmf_update.euclidean.w(v, w, h, eps=eps, weight=beta, nbterms=nb, ncterms=nc, copy=FALSE)
+ h <- nmf_update.euclidean.h(v, w, h, eps=eps, nbterms=nb, ncterms=nc, copy=FALSE)
+
+ # normalize columns of w
+ if( scale ){
+ icoef <- staticVar('icoef')
+ wb <- w[, icoef]
+ d <- sqrt(colSums(wb^2))
+ w[, icoef] <- sweep(wb, 2L, d, '/', check.margin=FALSE)
+ h[icoef, ] <- sweep(h[icoef, ], 1L, d, '*', check.margin=FALSE)
+ }
+
+ .coef(data) <- h
+ .basis(data) <- w
+ data
+}
+
+nmfAlgorithm.siNMF <- setNMFMethod('siNMF', 'lee', Update=siNMF)
diff --git a/R/algorithms-snmf.R b/R/algorithms-snmf.R
new file mode 100644
index 0000000..adbee1e
--- /dev/null
+++ b/R/algorithms-snmf.R
@@ -0,0 +1,678 @@
+#' @include registry-algorithms.R
+NULL
+
+#' Fast Combinatorial Nonnegative Least-Square
+#'
+#' This function solves the following nonnegative least square linear problem
+#' using normal equations and the fast combinatorial strategy from \cite{VanBenthem2004}:
+#'
+#' \deqn{
+#' \begin{array}{l}
+#' \min \|Y - X K\|_F\\
+#' \mbox{s.t. } K>=0
+#' \end{array}
+#' }{min ||Y - X K||_F, s.t. K>=0}
+#'
+#' where \eqn{Y} and \eqn{X} are two real matrices of dimension \eqn{n \times p}{n x p}
+#' and \eqn{n \times r}{n x r} respectively,
+#' and \eqn{\|.\|_F}{|.|_F} is the Frobenius norm.
+#'
+#' The algorithm is very fast compared to other approaches, as it is optimised
+#' for handling multiple right-hand sides.
+#'
+#' @details
+#' Within the \code{NMF} package, this algorithm is used internally by the
+#' SNMF/R(L) algorithm from \cite{KimH2007} to solve general Nonnegative
+#' Matrix Factorization (NMF) problems, using alternating nonnegative
+#' constrained least-squares.
+#' That is by iteratively and alternatively estimate each matrix factor.
+#'
+#' The algorithm is an active/passive set method, which rearrange the
+#' right-hand side to reduce the number of pseudo-inverse calculations.
+#' It uses the unconstrained solution \eqn{K_u} obtained from the
+#' unconstrained least squares problem,
+#' i.e. \eqn{\min \|Y - X K\|_F^2}{min ||Y - X K||_F^2} , so as to determine
+#' the initial passive sets.
+#'
+#' The function \code{fcnnls} is provided separately so that it can be
+#' used to solve other types of nonnegative least squares problem.
+#' For faster computation, when multiple nonnegative least square fits
+#' are needed, it is recommended to directly use the function \code{\link{.fcnnls}}.
+#'
+#' The code of this function is a port from the original MATLAB code
+#' provided by \cite{KimH2007}.
+#'
+#' @inheritParams .fcnnls
+#' @param ... extra arguments passed to the internal function \code{.fcnnls}.
+#' Currently not used.
+#' @return A list containing the following components:
+#'
+#' \item{x}{ the estimated optimal matrix \eqn{K}.} \item{fitted}{ the fitted
+#' matrix \eqn{X K}.} \item{residuals}{ the residual matrix \eqn{Y - X K}.}
+#' \item{deviance}{ the residual sum of squares between the fitted matrix
+#' \eqn{X K} and the target matrix \eqn{Y}. That is the sum of the square
+#' residuals.} \item{passive}{ a \eqn{r x p} logical matrix containing the
+#' passive set, that is the set of entries in \eqn{K} that are not null (i.e.
+#' strictly positive).} \item{pseudo}{ a logical that is \code{TRUE} if the
+#' computation was performed using the pseudoinverse. See argument
+#' \code{pseudo}.}
+#'
+#' @seealso \code{\link{nmf}}
+#' @references
+#'
+#' Original MATLAB code from Van Benthem and Keenan, slightly modified by H.
+#' Kim:\cr \url{http://www.cc.gatech.edu/~hpark/software/fcnnls.m}
+#'
+#' @author
+#' Original MATLAB code : Van Benthem and Keenan
+#'
+#' Adaption of MATLAB code for SNMF/R(L): H. Kim
+#'
+#' Adaptation to the NMF package framework: Renaud Gaujoux
+#'
+#' @keywords optimize multivariate regression
+#' @export
+#' @inline
+#' @examples
+#'
+#' ## Define a random nonnegative matrix matrix
+#' n <- 200; p <- 20; r <- 3
+#' V <- rmatrix(n, p)
+#'
+#' ## Compute the optimal matrix K for a given X matrix
+#' X <- rmatrix(n, r)
+#' res <- fcnnls(X, V)
+#'
+#' ## Compute the same thing using the Moore-Penrose generalized pseudoinverse
+#' res <- fcnnls(X, V, pseudo=TRUE)
+#'
+#' ## It also works in the case of single vectors
+#' y <- runif(n)
+#' res <- fcnnls(X, y)
+#' # or
+#' res <- fcnnls(X[,1], y)
+#'
+#'
+setGeneric('fcnnls', function(x, y, ...) standardGeneric('fcnnls') )
+#' This method wraps a call to the internal function \code{.fcnnls}, and
+#' formats the results in a similar way as other lest-squares methods such
+#' as \code{\link{lm}}.
+#'
+#' @param verbose toggle verbosity (default is \code{FALSE}).
+#'
+setMethod('fcnnls', signature(x='matrix', y='matrix'),
+ function(x, y, verbose=FALSE, pseudo=TRUE, ...){
+ # load corpcor if necessary
+ if( isTRUE(pseudo) ){
+ library(corpcor)
+ }
+
+ # call the internal function
+ res <- .fcnnls(x, y, verbose=verbose, pseudo=pseudo, ...)
+
+ # process the result
+ f <- x %*% res$coef
+ resid <- y - f
+ # set dimnames
+ if( is.null(rownames(res$coef)) ) rownames(res$coef) <- colnames(x)
+
+ # wrap up the result
+ out <- list(x=res$coef, fitted=f, residuals=resid, deviance=norm(resid, 'F')^2, passive=res$Pset, pseudo=pseudo)
+ class(out) <- 'fcnnls'
+ out
+ }
+)
+#' Shortcut for \code{fcnnls(as.matrix(x), y, ...)}.
+setMethod('fcnnls', signature(x='numeric', y='matrix'),
+ function(x, y, ...){
+ fcnnls(as.matrix(x), y, ...)
+ }
+)
+#' Shortcut for \code{fcnnls(x, as.matrix(y), ...)}.
+setMethod('fcnnls', signature(x='ANY', y='numeric'),
+ function(x, y, ...){
+ fcnnls(x, as.matrix(y), ...)
+ }
+)
+
+#' @S3method print fcnnls
+print.fcnnls <- function(x, ...){
+ cat("<object of class 'fcnnls': Fast Combinatorial Nonnegative Least Squares>\n")
+ cat("Dimensions:", nrow(x$x)," x ", ncol(x$x), "\n")
+ cat("Residual sum of squares:", x$deviance,"\n")
+ cat("Active constraints:", length(x$passive)-sum(x$passive),"/", length(x$passive), "\n")
+ cat("Inverse method:",
+ if( isTRUE(x$pseudo) ) 'pseudoinverse (corpcor)'
+ else if( is.function(x$pseudo) ) str_fun(x$pseudo)
+ else 'QR (solve)', "\n")
+ invisible(x)
+}
+
+
+###% M. H. Van Benthem and M. R. Keenan, J. Chemometrics 2004; 18: 441-450
+###%
+###% Given A and C this algorithm solves for the optimal
+###% K in a least squares sense, using that
+###% A = C*K
+###% in the problem
+###% min ||A-C*K||, s.t. K>=0, for given A and C.
+###%
+###%
+###% @param C the matrix of coefficients
+###% @param A the target matrix of observations
+###%
+###% @return [K, Pset]
+###%
+#' Internal Routine for Fast Combinatorial Nonnegative Least-Squares
+#'
+#' @description
+#' This is the workhorse function for the higher-level function
+#' \code{\link{fcnnls}}, which implements the fast nonnegative least-square
+#' algorithm for multiple right-hand-sides from \cite{VanBenthem2004} to solve
+#' the following problem:
+#'
+#' \deqn{
+#' \begin{array}{l}
+#' \min \|Y - X K\|_F\\
+#' \mbox{s.t. } K>=0
+#' \end{array}
+#' }{min ||Y - X K||_F, s.t. K>=0}
+#'
+#' where \eqn{Y} and \eqn{X} are two real matrices of dimension \eqn{n \times p}{n x p}
+#' and \eqn{n \times r}{n x r} respectively,
+#' and \eqn{\|.\|_F}{|.|_F} is the Frobenius norm.
+#'
+#' The algorithm is very fast compared to other approaches, as it is optimised
+#' for handling multiple right-hand sides.
+#'
+#' @param x the coefficient matrix
+#' @param y the target matrix to be approximated by \eqn{X K}.
+#' @param verbose logical that indicates if log messages should be shown.
+#' @param pseudo By default (\code{pseudo=FALSE}) the algorithm uses Gaussian
+#' elimination to solve the successive internal linear problems, using the
+#' \code{\link{solve}} function. If \code{pseudo=TRUE} the algorithm uses
+#' Moore-Penrose generalized \code{\link[corpcor]{pseudoinverse}} from the
+#' \code{corpcor} package instead of \link{solve}.
+#' @param eps threshold for considering entries as nonnegative.
+#' This is an experimental parameter, and it is recommended to
+#' leave it at 0.
+#'
+#' @return A list with the following elements:
+#'
+#' \item{coef}{the fitted coefficient matrix.}
+#' \item{Pset}{the set of passive constraints, as a logical matrix of
+#' the same size as \code{K} that indicates which element is positive.}
+#'
+#' @export
+.fcnnls <- function(x, y, verbose=FALSE, pseudo=FALSE, eps=0){
+
+ # check arguments
+ if( any(dim(y) == 0L) ){
+ stop("Empty target matrix 'y' [", paste(dim(y), collapse=' x '), "]")
+ }
+ if( any(dim(x) == 0L) ){
+ stop("Empty regression variable matrix 'x' [", paste(dim(x), collapse=' x '), "]")
+ }
+
+ # map arguments
+ C <- x
+ A <- y
+# NNLS using normal equations and the fast combinatorial strategy
+ #
+ # I/O: [K, Pset] = fcnnls(C, A);
+ # K = fcnnls(C, A);
+ #
+ # C is the nObs x lVar coefficient matrix
+ # A is the nObs x pRHS matrix of observations
+ # K is the lVar x pRHS solution matrix
+ # Pset is the lVar x pRHS passive set logical array
+ #
+ # M. H. Van Benthem and M. R. Keenan
+ # Sandia National Laboratories
+ #
+ # Pset: set of passive sets, one for each column
+ # Fset: set of column indices for solutions that have not yet converged
+ # Hset: set of column indices for currently infeasible solutions
+ # Jset: working set of column indices for currently optimal solutions
+ #
+ # Check the input arguments for consistency and initializeerror(nargchk(2,2,nargin))
+ nObs = nrow(C); lVar = ncol(C);
+ if ( nrow(A)!= nObs ) stop('C and A have imcompatible sizes')
+ pRHS = ncol(A);
+ W = matrix(0, lVar, pRHS);
+ iter=0; maxiter=3*lVar;
+ # Precompute parts of pseudoinverse
+ #CtC = t(C)%*%C; CtA = t(C)%*%A;
+ CtC = crossprod(C); CtA = crossprod(C,A);
+
+ # Obtain the initial feasible solution and corresponding passive set
+ K = .cssls(CtC, CtA, pseudo=pseudo);
+ Pset = K > 0;
+ K[!Pset] = 0;
+ D = K;
+ # which columns of Pset do not have all entries TRUE?
+ Fset = which( colSums(Pset) != lVar );
+ #V+# Active set algorithm for NNLS main loop
+ oitr=0; # HKim
+ while ( length(Fset)>0 ) {
+
+ oitr=oitr+1; if ( verbose && oitr > 5 ) cat(sprintf("%d ",oitr));# HKim
+
+ #Vc# Solve for the passive variables (uses subroutine below)
+ K[,Fset] = .cssls(CtC, CtA[,Fset, drop=FALSE], Pset[,Fset, drop=FALSE], pseudo=pseudo);
+
+ # Find any infeasible solutions
+ # subset Fset on the columns that have at least one negative entry
+ Hset = Fset[ colSums(K[,Fset, drop=FALSE] < eps) > 0 ];
+ #V+# Make infeasible solutions feasible (standard NNLS inner loop)
+ if ( length(Hset)>0 ){
+ nHset = length(Hset);
+ alpha = matrix(0, lVar, nHset);
+ while ( nHset>0 && (iter < maxiter) ){
+ iter = iter + 1;
+ alpha[,1:nHset] = Inf;
+ #Vc# Find indices of negative variables in passive set
+ ij = which( Pset[,Hset, drop=FALSE] & (K[,Hset, drop=FALSE] < eps) , arr.ind=TRUE);
+ i = ij[,1]; j = ij[,2]
+ if ( length(i)==0 ) break;
+ hIdx = (j - 1) * lVar + i; # convert array indices to indexes relative to a lVar x nHset matrix
+ negIdx = (Hset[j] - 1) * lVar + i; # convert array indices to index relative to the matrix K (i.e. same row index but col index is stored in Hset)
+
+ alpha[hIdx] = D[negIdx] / (D[negIdx] - K[negIdx]);
+ alpha.inf <- alpha[,1:nHset, drop=FALSE]
+ minIdx = max.col(-t(alpha.inf)) # get the indce of the min of each row
+ alphaMin = alpha.inf[minIdx + (0:(nHset-1) * lVar)]
+ alpha[,1:nHset] = matrix(alphaMin, lVar, nHset, byrow=TRUE);
+ D[,Hset] = D[,Hset, drop=FALSE] - alpha[,1:nHset, drop=FALSE] * (D[,Hset, drop=FALSE]-K[,Hset, drop=FALSE]);
+ idx2zero = (Hset - 1) * lVar + minIdx; # convert array indices to index relative to the matrix D
+ D[idx2zero] = 0;
+ Pset[idx2zero] = FALSE;
+ K[, Hset] = .cssls(CtC, CtA[,Hset, drop=FALSE], Pset[,Hset, drop=FALSE], pseudo=pseudo);
+ # which column of K have at least one negative entry?
+ Hset = which( colSums(K < eps) > 0 );
+ nHset = length(Hset);
+ }
+ }
+ #V-#
+
+ #Vc# Make sure the solution has converged
+ #if iter == maxiter, error('Maximum number iterations exceeded'), end
+ # Check solutions for optimality
+ W[,Fset] = CtA[,Fset, drop=FALSE] - CtC %*% K[,Fset, drop=FALSE];
+ # which columns have all entries non-positive
+ Jset = which( colSums( (ifelse(!(Pset[,Fset, drop=FALSE]),1,0) * W[,Fset, drop=FALSE]) > eps ) == 0 );
+ Fset = setdiff(Fset, Fset[Jset]);
+
+ if ( length(Fset) > 0 ){
+ #Vc# For non-optimal solutions, add the appropriate variable to Pset
+ # get indice of the maximum in each column
+ mxidx = max.col( t(ifelse(!Pset[,Fset, drop=FALSE],1,0) * W[,Fset, drop=FALSE]) )
+ Pset[ (Fset - 1) * lVar + mxidx ] = TRUE;
+ D[,Fset] = K[,Fset, drop=FALSE];
+ }
+ }
+ #V-#
+
+ # return K and Pset
+ list(coef=K, Pset=Pset)
+}
+# ****************************** Subroutine****************************
+#library(corpcor)
+.cssls <- function(CtC, CtA, Pset=NULL, pseudo=FALSE){
+
+ # use provided function
+ if( is.function(pseudo) ){
+ pseudoinverse <- pseudo
+ pseudo <- TRUE
+ }
+
+ # Solve the set of equations CtA = CtC*K for the variables in set Pset
+ # using the fast combinatorial approach
+ K = matrix(0, nrow(CtA), ncol(CtA));
+ if ( is.null(Pset) || length(Pset)==0 || all(Pset) ){
+ K <- (if( !pseudo ) solve(CtC) else pseudoinverse(CtC)) %*% CtA;
+ # K = pseudoinverse(CtC) %*% CtA;
+ #K=pinv(CtC)*CtA;
+ }else{
+ lVar = nrow(Pset); pRHS = ncol(Pset);
+ codedPset = as.numeric(2.^(seq(lVar-1,0,-1)) %*% Pset);
+ sortedPset = sort(codedPset)
+ sortedEset = order(codedPset)
+ breaks = diff(sortedPset);
+ breakIdx = c(0, which(breaks > 0 ), pRHS);
+ for( k in seq(1,length(breakIdx)-1) ){
+ cols2solve = sortedEset[ seq(breakIdx[k]+1, breakIdx[k+1])];
+ vars = Pset[,sortedEset[breakIdx[k]+1]];
+ K[vars,cols2solve] <- (if( !pseudo ) solve(CtC[vars,vars, drop=FALSE]) else pseudoinverse(CtC[vars,vars, drop=FALSE])) %*% CtA[vars,cols2solve, drop=FALSE];
+ #K[vars,cols2solve] <- pseudoinverse(CtC[vars,vars, drop=FALSE])) %*% CtA[vars,cols2solve, drop=FALSE];
+ #TODO: check if this is the right way or needs to be reversed
+ #K(vars,cols2solve) = pinv(CtC(vars,vars))*CtA(vars,cols2solve);
+ }
+ }
+
+ # return K
+ K
+}
+
+###%
+###% SNMF/R
+###%
+###% Author: Hyunsoo Kim and Haesun Park, Georgia Insitute of Technology
+###%
+###% Reference:
+###%
+###% Sparse Non-negative Matrix Factorizations via Alternating
+###% Non-negativity-constrained Least Squares for Microarray Data Analysis
+###% Hyunsoo Kim and Haesun Park, Bioinformatics, 2007, to appear.
+###%
+###% This software requires fcnnls.m, which can be obtained from
+###% M. H. Van Benthem and M. R. Keenan, J. Chemometrics 2004; 18: 441-450
+###%
+###% NMF: min_{W,H} (1/2) || A - WH ||_F^2 s.t. W>=0, H>=0
+###% SNMF/R: NMF with additional sparsity constraints on H
+###%
+###% min_{W,H} (1/2) (|| A - WH ||_F^2 + eta ||W||_F^2
+###% + beta (sum_(j=1)^n ||H(:,j)||_1^2))
+###% s.t. W>=0, H>=0
+###%
+###% A: m x n data matrix (m: features, n: data points)
+###% W: m x k basis matrix
+###% H: k x n coefficient matrix
+###%
+###% function [W,H,i]=nmfsh_comb(A,k,param,verbose,bi_conv,eps_conv)
+###%
+###% input parameters:
+###% A: m x n data matrix (m: features, n: data points)
+###% k: desired positive integer k
+###% param=[eta beta]:
+###% eta (for supressing ||W||_F)
+###% if eta < 0, software uses maxmum value in A as eta.
+###% beta (for sparsity control)
+###% Larger beta generates higher sparseness on H.
+###% Too large beta is not recommended.
+###% verbos: verbose = 0 for silence mode, otherwise print output
+###% eps_conv: KKT convergence test (default eps_conv = 1e-4)
+###% bi_conv=[wminchange iconv] biclustering convergence test
+###% wminchange: the minimal allowance of the change of
+###% row-clusters (default wminchange=0)
+###% iconv: decide convergence if row-clusters (within wminchange)
+###% and column-clusters have not changed for iconv convergence
+###% checks. (default iconv=10)
+###%
+###% output:
+###% W: m x k basis matrix
+###% H: k x n coefficient matrix
+###% i: the number of iterations
+###%
+###% sample usage:
+###% [W,H]=nmfsh_comb(amlall,3,[-1 0.01],1);
+###% [W,H]=nmfsh_comb(amlall,3,[-1 0.01],1,[3 10]);
+###% -- in the convergence check, the change of row-clusters to
+###% at most three rows is allowed.
+###%
+###%
+#function [W,H,i]
+nmf_snmf <- function(A, x, maxIter= nmf.getOption('maxIter') %||% 20000L, eta=-1, beta=0.01, bi_conv=c(0, 10), eps_conv=1e-4, version=c('R', 'L'), verbose=FALSE){
+#nmfsh_comb <- function(A, k, param, verbose=FALSE, bi_conv=c(0, 10), eps_conv=1e-4, version=c('R', 'L')){
+
+ # depending on the version:
+ # in version L: A is transposed while W and H are swapped and transposed
+ version <- match.arg(version)
+ if( version == 'L' ) A <- t(A)
+ #if( missing(param) ) param <- c(-1, 0.01)
+
+ m = nrow(A); n = ncol(A); erravg1 = numeric();
+
+ #eta=param[1]; beta=param[2];
+ maxA=max(A); if ( eta<0 ) eta=maxA;
+ eta2=eta^2;
+
+ # bi_conv
+ if( length(bi_conv) != 2 )
+ stop("SNMF/", version, "::Invalid argument 'bi_conv' - value should be a 2-length numeric vector")
+ wminchange=bi_conv[1]; iconv=bi_conv[2];
+
+ ## VALIDITY of parameters
+ # eps_conv
+ if( eps_conv <= 0 )
+ stop("SNMF/", version, "::Invalid argument 'eps_conv' - value should be positive")
+ # wminchange
+ if( wminchange < 0 )
+ stop("SNMF/", version, "::Invalid argument 'bi_conv' - bi_conv[1] (i.e 'wminchange') should be non-negative")
+ # iconv
+ if( iconv < 0 )
+ stop("SNMF/", version, "::Invalid argument 'bi_conv' - bi_conv[2] (i.e 'iconv') should be non-negative")
+ # beta
+ if( beta <=0 )
+ stop("SNMF/", version, "::Invalid argument 'beta' - value should be positive")
+ ##
+
+ # initialize random W if no starting point is given
+ if( isNumber(x) ){
+ # rank is given by x
+ k <- x
+ message('# NOTE: Initialise W internally (runif)')
+ W <- matrix(runif(m*k), m,k);
+ x <- NULL
+ } else if( is.nmf(x) ){
+ # rank is the number of basis components in x
+ k <- nbasis(x)
+ # seed the method (depends on the version to run)
+ start <- if( version == 'R' ) basis(x) else t(coef(x))
+ # check compatibility of the starting point with the target matrix
+ if( any(dim(start) != c(m,k)) )
+ stop("SNMF/", version, " - Invalid initialization - incompatible dimensions [expected: ", paste(c(m,k), collapse=' x '),", got: ", paste(dim(start), collapse=' x '), " ]")
+ # use the supplied starting point
+ W <- start
+ }else{
+ stop("SNMF/", version, ' - Invalid argument `x`: must be a single numeric or an NMF model [', class(x), ']')
+ }
+
+ if ( verbose )
+ cat(sprintf("--\nAlgorithm: SNMF/%s\nParameters: k=%d eta=%.4e beta (for sparse H)=%.4e wminchange=%d iconv=%d\n",
+ version, k,eta,beta,wminchange,iconv));
+
+ idxWold=rep(0, m); idxHold=rep(0, n); inc=0;
+
+ # check validity of seed
+ if( any(NAs <- is.na(W)) )
+ stop("SNMF/", version, "::Invalid initialization - NAs found in the ", if(version=='R') 'basis (W)' else 'coefficient (H)' , " matrix [", sum(NAs), " NAs / ", length(NAs), " entries]")
+
+ # normalize columns of W
+ W= apply(W, 2, function(x) x / sqrt(sum(x^2)) );
+
+ I_k=diag(eta, k); betavec=rep(sqrt(beta), k); nrestart=0;
+ i <- 0L
+ while( i < maxIter){
+ i <- i + 1L
+
+ # min_h ||[[W; 1 ... 1]*H - [A; 0 ... 0]||, s.t. H>=0, for given A and W.
+ res = .fcnnls(rbind(W, betavec), rbind(A, rep(0, n)));
+ H = res[[1]]
+
+ if ( any(rowSums(H)==0) ){
+ if( verbose ) cat(sprintf("iter%d: 0 row in H eta=%.4e restart!\n",i,eta));
+ nrestart=nrestart+1;
+ if ( nrestart >= 10 ){
+ warning("NMF::snmf - Too many restarts due to too big 'beta' value [Computation stopped after the 9th restart]");
+ break;
+ }
+
+ # re-initialize random W
+ idxWold=rep(0, m); idxHold=rep(0, n); inc=0;
+ erravg1 <- numeric();# re-initialize base average error
+ W=matrix(runif(m*k), m,k);
+ W= apply(W, 2, function(x) x / sqrt(sum(x^2)) ); # normalize columns of W
+ next;
+ }
+
+ # min_w ||[H'; I_k]*W' - [A'; 0]||, s.t. W>=0, for given A and H.
+ res = .fcnnls(rbind(t(H), I_k), rbind(t(A), matrix(0, k,m)));
+ Wt = res[[1]]
+ W= t(Wt);
+
+ # track the error (not computed unless tracking option is enabled in x)
+ if( !is.null(x) )
+ x <- trackError(x, .snmf.objective(A, W, H, eta, beta), niter=i)
+
+ # test convergence every 5 iterations OR if the base average error has not been computed yet
+ if ( (i %% 5==0) || (length(erravg1)==0) ){
+ # indice of maximum for each row of W
+ idxW = max.col(W)
+ # indice of maximum for each column of H
+ idxH = max.col(t(H))
+ changedW=sum(idxW != idxWold); changedH=sum(idxH != idxHold);
+ if ( (changedW<=wminchange) && (changedH==0) ) inc=inc+1
+ else inc=0
+
+ resmat=pmin(H, crossprod(W) %*% H - t(W) %*% A + matrix(beta, k , k) %*% H); resvec=as.numeric(resmat);
+ resmat=pmin(W, W %*% tcrossprod(H) - A %*% t(H) + eta2 * W); resvec=c(resvec, as.numeric(resmat));
+ conv=sum(abs(resvec)); #L1-norm
+ convnum=sum(abs(resvec)>0);
+ erravg=conv/convnum;
+ # compute base average error if necessary
+ if ( length(erravg1)==0 )
+ erravg1=erravg;
+
+ if ( verbose && (i %% 1000==0) ){ # prints number of changing elements
+ if( i==1000 ) cat("Track:\tIter\tInc\tchW\tchH\t---\terravg1\terravg\terravg/erravg1\n")
+ cat(sprintf("\t%d\t%d\t%d\t%d\t---\terravg1: %.4e\terravg: %.4e\terravg/erravg1: %.4e\n",
+ i,inc,changedW,changedH,erravg1,erravg,erravg/erravg1));
+ }
+
+ #print(list(inc=inc, iconv=iconv, erravg=erravg, eps_conv=eps_conv, erravg1=erravg1))
+ if ( (inc>=iconv) && (erravg<=eps_conv*erravg1) ) break;
+ idxWold=idxW; idxHold=idxH;
+ }
+
+ }
+
+ if( verbose ) cat("--\n")
+
+ # force to compute last error if not already done
+ if( !is.null(x) )
+ x <- trackError(x, .snmf.objective(A, W, H, eta, beta), niter=i, force=TRUE)
+
+ # transpose and reswap the roles
+ if( !is.null(x) ){
+ if( version == 'L' ){
+ .basis(x) <- t(H)
+ .coef(x) <- t(W)
+ }
+ else{
+ .basis(x) <- W
+ .coef(x) <- H
+ }
+ # set number of iterations performed
+ niter(x) <- i
+
+ return(x)
+ }else{
+ res <- list(W=W, H=H)
+ if( version == 'L' ){
+ res$W <- t(H)
+ res$H <- t(W)
+ }
+ return(invisible(res))
+ }
+}
+
+
+###% Computes the objective value for the SNMF algorithm
+.snmf.objective <- function(target, w, h, eta, beta){
+
+ 1/2 * ( sum( (target - (w %*% h))^2 )
+ + eta * sum(w^2)
+ + beta * sum( colSums( h )^2 )
+ )
+}
+
+snmf.objective <- function(x, y, eta=-1, beta=0.01){
+ .snmf.objective(y, .basis(x), .coef(x), eta, beta)
+}
+
+###% Wrapper function to use the SNMF/R algorithm with the NMF package.
+###%
+.snmf <- function(target, seed, maxIter=20000L, eta=-1, beta=0.01, bi_conv=c(0, 10), eps_conv=1e-4, ...){
+
+ # retrieve the version of SNMF algorithm from its name:
+ # it is defined by the last letter in the method's name (in upper case)
+ name <- algorithm(seed)
+ version <- toupper(substr(name, nchar(name), nchar(name)))
+
+ # perform factorization using Kim and Park's algorithm
+ ca <- match.call()
+ ca[[1L]] <- as.name('nmf_snmf')
+ # target
+ ca[['A']] <- ca[['target']]
+ ca[['target']] <- NULL
+ # seed
+ ca[['x']] <- ca[['seed']]
+ ca[['seed']] <- NULL
+ # version
+ ca[['version']] <- version
+ # verbose
+ ca[['verbose']] <- verbose(seed)
+ e <- parent.frame()
+ sol <- eval(ca, envir=e)
+# nmf_snmf(target, seed, ..., version = version, verbose = verbose(seed))
+
+ # return solution
+ return(sol)
+}
+
+#' NMF Algorithm - Sparse NMF via Alternating NNLS
+#'
+#' NMF algorithms proposed by \cite{KimH2007} that enforces sparsity
+#' constraint on the basis matrix (algorithm \sQuote{SNMF/L}) or the
+#' mixture coefficient matrix (algorithm \sQuote{SNMF/R}).
+#'
+#' The algorithm \sQuote{SNMF/R} solves the following NMF optimization problem on
+#' a given target matrix \eqn{A} of dimension \eqn{n \times p}{n x p}:
+#' \deqn{
+#' \begin{array}{ll}
+#' & \min_{W,H} \frac{1}{2} \left(|| A - WH ||_F^2 + \eta ||W||_F^2
+#' + \beta (\sum_{j=1}^p ||H_{.j}||_1^2)\right)\\
+#' s.t. & W\geq 0, H\geq 0
+#' \end{array}
+#' }{
+#' min_{W,H} 1/2 (|| A - WH ||_F^2 + eta ||W||_F^2
+#' + beta (sum_j ||H[,j]||_1^2))
+#'
+#' s.t. W>=0, H>=0
+#' }
+#'
+#' The algorithm \sQuote{SNMF/L} solves a similar problem on the transposed target matrix \eqn{A},
+#' where \eqn{H} and \eqn{W} swap roles, i.e. with sparsity constraints applied to \code{W}.
+#'
+#' @param maxIter maximum number of iterations.
+#' @param eta parameter to suppress/bound the L2-norm of \code{W} and in
+#' \code{H} in \sQuote{SNMF/R} and \sQuote{SNMF/L} respectively.
+#'
+#' If \code{eta < 0}, then it is set to the maximum value in the target matrix is used.
+#' @param beta regularisation parameter for sparsity control, which
+#' balances the trade-off between the accuracy of the approximation and the
+#' sparseness of \code{H} and \code{W} in \sQuote{SNMF/R} and \sQuote{SNMF/L} respectively.
+#'
+#' Larger beta generates higher sparseness on \code{H} (resp. \code{W}).
+#' Too large beta is not recommended.
+#' @param bi_conv parameter of the biclustering convergence test.
+#' It must be a size 2 numeric vector \code{bi_conv=c(wminchange, iconv)},
+#' with:
+#' \describe{
+#' \item{\code{wminchange}:}{the minimal allowance of change in row-clusters.}
+#' \item{\code{iconv}:}{ decide convergence if row-clusters
+#' (within the allowance of \code{wminchange})
+#' and column-clusters have not changed for \code{iconv} convergence checks.}
+#' }
+#'
+#' Convergence checks are performed every 5 iterations.
+#' @param eps_conv threshold for the KKT convergence test.
+#' @param ... extra argument not used.
+#'
+#' @rdname SNMF-nmf
+#' @aliases SNMF/R-nmf
+nmfAlgorithm.SNMF_R <- setNMFMethod('snmf/r', .snmf, objective=snmf.objective)
+#' @aliases SNMF/L-nmf
+#' @rdname SNMF-nmf
+nmfAlgorithm.SNMF_L <- setNMFMethod('snmf/l', .snmf, objective=snmf.objective)
diff --git a/R/atracks.R b/R/atracks.R
new file mode 100644
index 0000000..010b3f7
--- /dev/null
+++ b/R/atracks.R
@@ -0,0 +1,536 @@
+# Generic framework for handling annotation tracks in plots, specifically in
+# in heatmaps generated by the function aheatmap.
+#
+# Author: Renaud Gaujoux
+# Creation: 24 Jan 2012
+###############################################################################
+setOldClass('annotationTrack')
+
+#' Annotation Tracks
+#'
+#' \code{.atrack} is an S4 generic method that converts an object into
+#' an annotation track object.
+#' It provides a general and flexible annotation framework that is used
+#' by \code{\link{aheatmap}} to annotates heatmap rows and columns.
+#'
+#' Methods for \code{.atrack} exist for common type of objects, which
+#' should provide enough options for new methods to define how annotation
+#' track are extracted from more complex objects, by coercing/filtering
+#' them into a supported type.
+#'
+#' @param object an object from which is extracted annotation tracks
+#' @param ... extra arguments to allow extensions and passed to the next method
+#' call.
+#' For \code{atrack}, arguments in \code{...} are concatenated into a single
+#' \code{annotationTrack} object.
+#'
+#' @rdname atrack
+#' @export
+#' @inline
+#' @keywords internal
+setGeneric('.atrack', function(object, ...) standardGeneric('.atrack'))
+
+#' \code{is.atrack} tests if an object is an \code{annotationTrack} object.
+#'
+#' @param x an R object
+#'
+#' @rdname atrack
+is.atrack <- function(x) is(x, 'annotationTrack')
+
+aname <- function(x, name){
+ return(x)
+ if( missing(name) ){
+ cn <- colnames(x)
+ an <- attr(x, 'aname')
+ name <-
+ if( !is.null(cn) ) cn
+ else if( !is.null(an) ) an
+ else class(x)[1]
+ attr(x, 'aname') <- name
+ }else{
+ attr(x, 'aname') <- name
+ x
+ }
+}
+
+#' \code{adata} get/sets the annotation parameters on an object
+#'
+#' @param value replacement value for the complete annotation data list
+#'
+#' @rdname atrack
+adata <- function(x, value, ...){
+ if( missing(value) ){
+ ad <- attr(x, 'annotationData')
+ if( is.null(ad) ) ad <- list()
+
+ # either return the annotationData itself or set values and return the object
+ if( nargs() == 1L ) ad
+ else{
+ ad <- c(list(...), ad)
+ ad <- ad[!duplicated(names(ad))]
+ adata(x, ad)
+ }
+ }else{
+ if( !is.list(value) )
+ stop("Annotation data must be a list.")
+ attr(x, 'annotationData') <- value
+ x
+ }
+}
+
+#' \code{amargin} get/sets the annotation margin, i.e. along which dimension of
+#' the data the annotations are to be considered.
+#'
+#' @rdname atrack
+amargin <- function(x, value){
+ if( missing(value) ) adata(x)$margin
+ else adata(x, margin=value)
+}
+
+#' \code{anames} returns the reference margin names for annotation tracks,
+#' from their embedded annotation data object.
+#'
+#' @rdname atrack
+anames <- function(x, default.margin){
+
+ if( is.numeric(x) && length(x) == 1L ) NULL
+ else if( is.vector(x) ) names(x)
+ else{
+ m <- amargin(x)
+ if( is.null(m) && !missing(default.margin) ) m <- default.margin
+
+ # special case for ExpressionSet objects whose dimnames method returns NULL
+ if( is(x, 'ExpressionSet') ) x <- Biobase::exprs(x)
+
+ if( !is.null(m) ) dimnames(x)[[m]]
+ else NULL
+ }
+}
+
+#' \code{alength} returns the reference length for annotation tracks,
+#' from their embedded annotation data object
+#'
+#' @param default.margin margin to use if no margin data is stored in the
+#' \code{x}.
+#'
+#' @rdname atrack
+alength <- function(x, default.margin){
+
+ if( is.numeric(x) && length(x) == 1L ) as.integer(x)
+ else if( is.vector(x) ) length(x)
+ else{
+ m <- amargin(x)
+ if( is.null(m) && !missing(default.margin) ) m <- default.margin
+ if( !is.null(m) ) dim(x)[m]
+ else NULL
+ }
+
+}
+
+test.match_atrack <- function(){
+
+ requireNamespace('RUnit')
+ na <- paste("name_", 1:10, sep='')
+ mat <- as.matrix(setNames(1:10, na))
+ checkEquals <- RUnit::checkEquals
+
+ .check <- function(x){
+ cat(class(x), " [", str_out(x, Inf, use.names=TRUE), "] :\n")
+ y <- match_atrack(x, mat)
+ print(y)
+ checkEquals( class(y), class(x), "Same class as input")
+ checkEquals( length(y), nrow(mat), "Correct length")
+ checkEquals( names(y), rownames(mat), "Correct names")
+ }
+ .test <- function(x){
+
+ .check(x)
+ .check(sample(x))
+ .check(x[1:5])
+ .check(sample(x)[1:5])
+
+ .check(setNames(x, na))
+ .check(sample(setNames(x, na)))
+ .check(setNames(x, rev(na)))
+ .check(setNames(x, na)[1:5])
+ .check(setNames(x, na)[3:6])
+ .check(setNames(x, na)[c(3,2,6)])
+
+ x2 <- setNames(c(x[1:5], x[1:3]), c(na[1:5], paste("not_in_", 1:3, sep='')))
+ .check(x2)
+ }
+
+ .test(letters[1:10])
+ .test(1:10)
+ .test(as.numeric(1:10) + 0.5)
+ .test(c(rep(TRUE, 5), rep(FALSE, 5)))
+ .test(factor(gl(2,5,labels=c("A", "B"))))
+}
+
+#' Extending Annotation Vectors
+#'
+#' Extends a vector used as an annotation track to match the number of rows
+#' and the row names of a given data.
+#'
+#' @param x annotation vector
+#' @param data reference data
+#' @return a vector of the same type as \code{x}
+#' @export
+#'
+match_atrack <- function(x, data=NULL){
+
+ if( is.null(data) || length(x) == 0L ) return(x)
+
+ # reorder and extend if a reference data matrix is provided
+ refnames <- anames(data, default.margin=1L)
+ reflength <- alength(data, default.margin=1L)
+
+ # if no ref length (=> no refnames either): do nothing
+ if( is.null(reflength) ) return(x)
+
+ # special handling of character vectors
+ if( is.character(x) && is.null(names(x)) && !is.null(refnames) ){
+# if( !any(names(x) %in% refnames) && any(x %in% refnames) ){
+ if( any(x %in% refnames) ){
+ vmessage("match_atrack - Annotation track [", str_out(x, 3, use.names=TRUE), "] has some values matching data names: converting into a logical using values as names.")
+ x <- setNames(rep(TRUE, length(x)), x)
+ }
+ }
+
+ # reorder based on names
+ .hasNames <- FALSE
+ if( !is.null(names(x)) && !is.null(refnames) ){
+ inref <- names(x) %in% refnames
+ if( !all(inref) ){
+ vmessage("match_atrack - Annotation track [", str_out(x, 3, use.names=TRUE), "] has partially matching names: subsetting track to match data")
+ x <- x[inref]
+ if( length(x) == 0L )
+ vmessage("match_atrack - Subset annotation track is empty")
+ }else
+ vmessage("match_atrack - Annotation track [", str_out(x, 3, use.names=TRUE), "] using names as identifiers")
+ .hasNames <- TRUE
+
+ if( anyDuplicated(names(x)) ){
+ dups <- duplicated(names(x))
+ vmessage("match_atrack - Annotation track [", str_out(x, 3, use.names=TRUE), "]: removing duplicated names [", str_out(x[dups], 3, use.names=TRUE),"]")
+ x <- x[!dups]
+ }
+ }
+
+ lx <- length(x)
+ if( lx > reflength ){
+ stop("match_atrack - Invalid annotation track [", str_out(x, 3, use.names=TRUE), "]: more elements [", lx, "] than rows in data [", reflength, "].")
+ }
+ if( lx == reflength ){
+ # reorder if necessary
+ res <-
+ if( !.hasNames ) x
+ else x[match(refnames, names(x))]
+ return(res)
+ }
+
+ # build similar vector of correct size
+ res <-
+ if( is.factor(x) ) setNames(factor(c(x, rep(NA, reflength-lx)), levels=c(levels(x), NA)), refnames)
+ else setNames(c(x, rep(NA, reflength-lx)), refnames)
+ res[1:lx] <- NA
+
+ # if not using names
+ if( !.hasNames ){
+ if( is.integer(x) ) res[x] <- x
+ else res[1:lx] <- x
+ }else{
+ # put the values of x at the write place
+ res[match(names(x), refnames)] <- x
+ }
+ res
+}
+
+#' The default method converts character or integer vectors into factors.
+#' Numeric vectors, factors, a single NA or \code{annotationTrack} objects are
+#' returned unchanged (except from reordering by argument \code{order}).
+#' Data frames are not changed either, but class 'annotationTrack' is appended
+#' to their original class set.
+#'
+#' @param data object used to extend the annotation track within a given data
+#' context.
+#' It is typically a matrix-like object, against which annotation specifications
+#' are matched using \code{\link{match_atrack}}.
+#'
+#'
+setMethod('.atrack', signature(object='ANY'),
+ function(object, data=NULL, ...){
+
+ # recursive on list
+ if( is.list(object) ){
+ object <- object[!sapply(object, function(x) length(x) == 0 || is_NA(x) )]
+ res <-
+ if( length(object) == 0 ) NULL
+ else{
+ # convert into a list of tracks
+ sapply(object, .atrack, data=data, ..., simplify=FALSE)
+ }
+ return(res)
+
+ }else if( is.null(object) || is_NA(object) || is.atrack(object) ) object
+ else{
+ # extend to match the data
+ object <- match_atrack(object, data)
+
+ # apply convertion rules for standard classes
+ if( is.logical(object) ) aname(as.factor(ifelse(object, 1, NA)), "Flag")
+ else if( is.integer(object) ){
+ if( any(wna <- is.na(object)) )
+ aname(as.factor(ifelse(!wna, 1,NA)), "Flag")
+ else
+ aname(as.numeric(object), "Level")
+ }
+ else if( is.character(object) ) aname(as.factor(object), "Group")
+ else if( is.factor(object) ) aname(object, "Factor")
+ else if( is.numeric(object) ) aname(object, "Variable")
+ else stop("atrack - Invalid annotation item `"
+ , substitute(object)
+ , "`: must be a factor, or a logical, character, numeric or integer vector")
+ }
+
+ }
+)
+
+setMethod('.atrack', 'character',
+ function(object, ...){
+
+ # check for special escaped track code
+ if( length(i <- atrack_code(object)) ){
+ if( length(object) == 1L ) object
+ else if( length(i) == length(object) ) as.list(object)
+ else{
+# spe <- object[i]
+# object <- sub("^\\\\:", ":", object[-i])
+# t <- callNextMethod()
+# c(list(t), spe)
+ callNextMethod()
+ }
+ }else{
+# object <- sub("^\\\\:", ":", object)
+ callNextMethod()
+ }
+ }
+)
+setMethod('.atrack', 'matrix', function(object, ...) .atrack(as.data.frame(object), ...) )
+setMethod('.atrack', 'data.frame', function(object, ...) .atrack(as.list(object), ...) )
+
+# tells if an object is a special annotation track code
+is_track_code <- function(x) isString(x) && grepl("^[:$]", x)
+
+atrack_code <- function(x, value=FALSE){
+
+ # check each track item
+ ac <- sapply(x, is_track_code)
+ i <- which(ac)
+
+ if( !value ) i # return indexes
+ else if( length(i) ) unlist(x[i]) # return values
+
+}
+
+
+match_atrack_code <- function(x, table, ...){
+ # pre-pend ':'
+ table.plain <- sub("^:", '', table)
+ table <- str_c(':', table.plain)
+
+ # convert into an annotation track
+ if( !is.atrack(x) ) x <- atrack(x, ...)
+
+ m <- sapply(x, function(x){
+ if( isString(x) ) charmatch(x, table, nomatch=0L)
+ else 0L
+ })
+
+ if( length(i <- which(m!=0L)) ){
+ if( is.null(names(m)) ) names(m) <- rep('', length(m))
+ names(m)[i] <- table.plain[m[i]]
+ }
+ m
+}
+
+#' \code{atrack} creates/concatenates \code{annotationTrack} objects
+#'
+#' @param order an integer vector that indicates the order of the annotation
+#' tracks in the result list
+#' @param enforceNames logical that indicates if missing track names should
+#' be generated as \code{X<i>}
+#' @param .SPECIAL an optional list of functions (with no arguments) that are
+#' called to generate special annotation tracks defined by codes of the form
+#' \code{':NAME'}.
+#' e.g., the function \code{link{consensusmap}} defines special tracks
+#' \code{':basis'} and \code{':consensus'}.
+#'
+#' If \code{.SPECIAL=FALSE}, then any special tracks is discarded and a warning
+#' is thrown.
+#'
+#' @param .DATA data used to match and extend annotation specifications.
+#' It is passed to argument \code{data} of the \code{.atrack} methods, which
+#' in turn use pass it to \code{\link{match_atrack}}.
+#'
+#' @param .CACHE an \code{annotationTrack} object with which the generated
+#' annotation track should be consistent.
+#' This argument is more for internal/advanced usage and should not be used
+#' by the end-user.
+#'
+#' @return \code{atrack} returns a list, decorated with class
+#' \code{'annotationTrack'}, where each element contains the description
+#' of an annotation track.
+#'
+#' @rdname atrack
+#' @export
+atrack <- function(..., order = NULL, enforceNames=FALSE, .SPECIAL=NA, .DATA = NULL, .CACHE = NULL){
+
+ # cbind object with the other arguments
+ l <- list(...)
+ if( length(l) == 1L && is.atrack(l[[1]]) )
+ object <- l[[1L]]
+ else if( length(l) > 0 ){
+
+ object <- list()
+ #print(l)
+ lapply(seq_along(l), function(i){
+ x <- l[[i]]
+ if( is_NA(x) || is.null(x) )
+ return()
+
+ xa <- .atrack(x, data=.DATA)
+
+ if( is_NA(xa) || is.null(xa) )
+ return()
+
+ n <- names(object)
+ # convert into a list
+ if( !is.list(xa) )
+ xa <- setNames(list(xa), names(l)[i])
+
+ # remove NA and NULL elements
+ if( is.null(xa) || is_NA(xa) ) return()
+ # cbind with previous tracks
+ if( is.null(object) ) object <<- xa
+ else object <<- c(object, xa)
+
+ })
+ }
+
+ # exit now if object is NULL
+ if( is.null(object) ) return()
+ if( !length(object) ) return( annotationTrack() )
+
+ # add class 'annotationTrack' if not already there
+ # (needed before calling match_atrack_code)
+ object <- annotationTrack(object)
+
+ # substitute special tracks
+ if( is.list(.SPECIAL) ){
+
+# str(object)
+ m <- match_atrack_code(object, names(.SPECIAL))
+ i_spe <- which(m!=0L)
+ if( length(i_spe) ){
+ # add names where needed
+ if( is.null(names(object)) ) names(object) <- rep('', length(object))
+
+ # remove duplicated special tracks
+ if( anyDuplicated(m[i_spe]) ){
+ # enforce name consistency if necessary
+ g <- split(i_spe, m[i_spe])
+ sapply(g, function(i){
+ n <- names(object)[i]
+ if( length(n <- n[n!='']) )
+ names(object)[i] <<- n[1L]
+ })
+ #
+ idup <- which(duplicated(m) & m!=0L)
+ object <- object[-idup]
+ m <- m[-idup]
+ i_spe <- which(m!=0L)
+ }
+ #
+
+ # enforce names consistent with the CACHE
+ if( anyValue(.CACHE) ){
+ if( !is.atrack(.CACHE) )
+ stop("Argument .CACHE should be an annotation track object. [", class(.CACHE), ']')
+ i_spe_cache <- atrack_code(.CACHE)
+ if( length(i_spe_cache) ){
+ .CACHE_SPE <- unlist(.CACHE[i_spe_cache])
+ if( !is.null(names(.CACHE_SPE)) ){
+ sapply(i_spe, function(i){
+ x <- object[[i]]
+ if( names(object)[i] == ''
+ && !is_NA(j <- match(x, .CACHE_SPE))
+ && names(.CACHE_SPE)[j] != ''){
+ names(object)[i] <<- names(.CACHE_SPE)[j]
+ }
+ })
+ }
+ }
+ }
+ # compute value
+ a <- sapply(m[i_spe], function(i) .SPECIAL[[i]](), simplify=FALSE)
+ object[i_spe] <- a # NB: this does not change the names
+ # reset names
+ nm <- names(object)[i_spe]
+ names(object)[i_spe] <- ifelse(nm!='', nm, names(a))
+ }
+
+ # remove special tracks if necessary
+ if( length(i <- atrack_code(object)) ){
+ warning("Discarding unresolved special annotation tracks: "
+ , str_out(unlist(object[i]), use.names=TRUE))
+ object <- object[-i]
+ }
+ }
+
+ # generate names
+ if( enforceNames ){
+ n <- names(object)
+ xnames <- paste('X', 1:length(object), sep='')
+ if( is.null(n) ) names(object) <- xnames
+ else names(object)[n==''] <- xnames[n=='']
+ }
+
+ # reorder if necessary
+ if( !is.null(order) ){
+ object <- sapply(object, function(x) x[order], simplify=FALSE)
+ #lapply(seq_along(object), function(i) object[[i]] <<- object[[i]][order])
+ }
+
+ #print(object)
+ # return object
+ annotationTrack(object)
+}
+
+#' \code{annotationTrack} is constructor function for \code{annotationTrack} object
+#'
+#' @rdname atrack
+annotationTrack <- function(x = list()){
+ if( !is.atrack(x) )
+ class(x) <- c('annotationTrack', if( nargs() ) class(x))
+ x
+}
+
+#setGeneric('atrack<-', function(object, value) standardGeneric('atrack<-'))
+#setReplaceMethod('atrack', signature(object='ANY', value='ANY'),
+# function(object, value){
+# # if the annotation track is not NA: convert it into a atrack
+# # and set the value
+# if( !is_NA(object) && length(value) > 0 ){
+# object <- atrack(object, value)
+# }
+# object
+# }
+#)
+#setReplaceMethod('atrack', signature(object='annotationTrack'),
+# function(object, value, replace = FALSE){
+# if( !replace && length(value) > 0 ) atrack(object, value)
+# else if( replace ) atrack(value)
+# else object
+# }
+#)
diff --git a/R/colorcode.R b/R/colorcode.R
new file mode 100644
index 0000000..e8c5679
--- /dev/null
+++ b/R/colorcode.R
@@ -0,0 +1,238 @@
+# Functions to define/extract compact colour specifications
+#
+# Author: "Renaud Gaujoux"
+# Creation: 19 Sep 2011
+###############################################################################
+
+#' @import RColorBrewer
+#' @import colorspace
+#' @import grDevices
+NULL
+
+col2hex <- function (cname)
+{
+ colMat <- col2rgb(cname)
+ rgb(red = colMat[1, ]/255, green = colMat[2, ]/255, blue = colMat[3,]/255)
+}
+
+#cc <- function(x, cval=80, lval=30){
+#
+# sapply(x, function(co){
+# if( is.integer(co) ) col2hex(if( co <= 8 ) co else colors()[co])
+# else if( is.numeric(co) ) hcl(co, c=cval, l=lval)
+# else if( !grepl("^#") )
+# else co
+# })
+#
+#}
+
+
+#' Flags a Color Palette Specification for Reversion
+#' @keywords internal
+revPalette <- function(x){
+ attr(x, 'revPalette') <- TRUE
+ x
+}
+
+#' Builds a Color Palette from Compact Color Specification
+#' @keywords internal
+ccPalette <- function(x, n=NA, verbose=FALSE){
+
+ if( length(x)==1 ){
+
+ # shortcut for single colors
+ if( (is_NA(n) || n==1) && length(x) > 1L && all(grepl("^#", x)) ) return(x)
+
+ sp <- ccSpec(x)
+ x <- sp$palette
+ if( is_NA(n) )
+ n <- sp$n
+
+ a <- attributes(x)
+
+ if( is.integer(x) ) # integer code between 1 and 8: R basic colour
+ x <- c("#F1F1F1", col2hex(x))
+ else if( is.numeric(x) ) # numeric: hcl colour
+ x <- rev(sequential_hcl(2, h = x, l = c(50, 95)))
+ else if( is.character(x) ){ # Palette name:
+
+ if( require.quiet('RColorBrewer') && x %in% rownames(brewer.pal.info) ){
+ if( verbose ) message("Load and generate ramp from RColorBrewer colour palette '", x, "'")
+ x <- brewer.pal(brewer.pal.info[x, 'maxcolors'], x)
+ }else{
+ cpal <- c('RdYlBu2', 'rainbow', 'heat', 'topo', 'terrain', 'cm', 'gray', 'grey')
+ i <- pmatch(x, cpal)
+ if( is.na(i) && (x %in% colours() || grepl("^#[0-9a-fA-F]+$", x)) ){
+ x <- c("#F1F1F1", x)
+ }else{
+
+ if( is.na(i) ){
+
+ stop("Invalid palette name '", x, "': should be an RColorBrewer palette or one of "
+ , paste("'", cpal ,"'", sep='', collapse=', ')
+ , ".\n Available RColorBrewer palettes: ", str_out(rownames(brewer.pal.info), Inf), '.')
+ }
+ x <- cpal[i]
+
+ # use default value of 10 for n if not specified
+ np <- if( is_NA(n) ) 10 else n
+
+ x <- switch(x
+ , RdYlBu2 = c("#D73027", "#FC8D59", "#FEE090", "#FFFFBF", "#E0F3F8", "#91BFDB", "#4575B4")
+ , rainbow = rainbow(np)
+ , gray = rev(gray.colors(np))
+ , grey = rev(grey.colors(np))
+ , heat = heat.colors(np)
+ , topo = topo.colors(np)
+ , terrain = terrain.colors(np)
+ , cm = cm.colors(np)
+ , stop("Unknown colour palette name: '", x, "'")
+ )
+ }
+ }
+ }
+ else
+ stop("Invalid colour palette specification :", x)
+
+ attributes(x) <- a
+ }
+
+ # revert the palette if requested
+ if( !is.null(attr(x, 'revPalette')) ){
+ x <- rev(x)
+ attr(x, 'revPalette') <- NULL
+ }
+
+ # limit to the requested length
+ if( !is_NA(n) )
+ x <- x[1:n]
+
+ # return converted palette
+ x
+}
+
+#' Generate Break Intervals from Numeric Variables
+#'
+#' Implementation is borrowed from the R core function \code{\link{cut.default}}.
+#'
+#' @keywords internal
+ccBreaks <- function(x, breaks){
+
+ if (!is.numeric(x))
+ stop("'x' must be numeric")
+
+ if (length(breaks) == 1L) {
+ if (is.na(breaks) | breaks < 2L)
+ stop("Invalid number of intervals: should be >= 2")
+ nb <- as.integer(breaks + 1)
+ dx <- diff(rx <- range(x, na.rm = TRUE))
+ if (dx == 0)
+ dx <- abs(rx[1L])
+ breaks <- seq.int(rx[1L] - dx/1000, rx[2L] + dx/1000,
+ length.out = nb)
+ }
+ else nb <- length(breaks <- sort.int(as.double(breaks)))
+ if (anyDuplicated(breaks))
+ stop("'breaks' are not unique")
+
+ breaks
+}
+
+#' Extract Colour Palette Specification
+#'
+#' @param a character string that specify a colour palette.
+#' @return a list with elements: palette, n and rev
+#'
+#' @keywords internal
+ccSpec <- function(x){
+
+ n <- NA
+ rv <- FALSE
+
+ if( length(x) == 1 ){
+ if( is.character(x) ){
+
+ # flag as reversed if it starts with a '-'
+ if( grepl('^-', x) ){
+ x <- substr(x, 2, nchar(x))
+ rv <- TRUE
+ }
+
+ # extract length for string
+ sm <- str_match(x, "([^:]+):([0-9]+).*")[1,]
+ if( !is_NA(sm[1]) ){
+ n <- as.integer(sm[3])
+ x <- sm[2]
+ }
+
+ # convert to a colour code if possible
+ # use maximum colour number of brewer sets
+ if( is_NA(n) && isString(x) && require.quiet('RColorBrewer') && x %in% rownames(brewer.pal.info) ){
+ n <- brewer.pal.info[x,'maxcolors']
+ }else if( grepl("^[1-8]$", x) ){# integer code between 1 and 8: R basic colour
+ x <- palette()[as.integer(x)]
+ }else if( grepl("^[0-9.]+$", x) ) # numeric: hcl colour
+ x <- as.numeric(x)
+
+ }else if( is.numeric(x) ){
+ if( x < 0 ){
+ x <- -x
+ rv<- TRUE
+ }
+ # single integer specification: use R default colours
+ if( isInteger(x) ){
+ if( x <= 8 ) x <- palette()[x]
+ else x <- colours()[x]
+ }
+ }
+
+ }
+
+ if( rv )
+ x <- revPalette(x)
+
+ res <- list(palette=x, n=n, rev=rv)
+# print(res)
+ res
+}
+
+#' Builds a Color Ramp from Compact Color Specification
+#'
+#' @keywords internal
+ccRamp <- function(x, n=NA, ...){ #breaks, data, ...){
+
+ # generate random color specification if necessary
+ if( missing(x) )
+ x <- round(runif(1) * 360)
+
+ # extract specifications
+ sp <- ccSpec(x)
+ x <- sp$palette
+ if( missing(n) ){
+ n <- sp$n
+ if( is_NA(n) ) n <- 50
+ }
+
+ # create a palette from specification x
+ x <- ccPalette(x, ...)
+
+# # compute breaks
+# breaks <-
+# if( !missing(breaks) ){
+# breaks <- ccBreaks(x, breaks)
+# if( missing(n) )
+# n <- length(breaks)
+# breaks
+# }
+# else if( !missing(data) ){
+# if( missing(n) )
+# n <- length(x)
+# ccBreaks(data, n)
+# }
+
+ if( is_NA(n) )
+ n <- length(x)
+
+ # return ramp from palette
+ colorRampPalette(x)(n+1)
+}
diff --git a/R/data.R b/R/data.R
new file mode 100644
index 0000000..cd34d9e
--- /dev/null
+++ b/R/data.R
@@ -0,0 +1,61 @@
+# Description and generation of data
+#
+# Author: Renaud Gaujoux
+###############################################################################
+
+#' Golub ExpressionSet
+#'
+#' This data comes originally from the gene expression data from \cite{Golub1999}.
+#' The version included in the package is the one used and referenced in \cite{Brunet2004}.
+#' The samples are from 27 patients with acute lymphoblastic leukemia (ALL) and
+#' 11 patients with acute myeloid leukemia (AML).
+#'
+#' The samples were assayed using Affymetrix Hgu6800 chips and the original
+#' data on the expression of 7129 genes (Affymetrix probes) are available on
+#' the Broad Institute web site (see references below).
+#'
+#' The data in \code{esGolub} were obtained from the web page related to
+#' the paper from \cite{Brunet2004}, which describes an application of
+#' Nonnegative Matrix Factorization to gene expression clustering.
+#' (see link in section \emph{Source}).
+#'
+#' They contain the 5,000 most highly varying genes according to their
+#' coefficient of variation, and were installed in an object of class
+#' \code{\link[Biobase]{ExpressionSet-class}}.
+#'
+#' @format There are 3 covariates listed.
+#'
+#' \itemize{
+#'
+#' \item Samples: The original sample labels. \item ALL.AML: Whether the
+#' patient had AML or ALL. It is a \code{\link{factor}} with levels
+#' \code{c('ALL', 'AML')}. \item Cell: ALL arises from two different types of
+#' lymphocytes (T-cell and B-cell). This specifies which for the ALL patients;
+#' There is no such information for the AML samples. It is a
+#' \code{\link{factor}} with levels \code{c('T-cell', 'B-cell', NA)}.
+#'
+#' }
+#'
+#' @source
+#' Web page for \cite{Brunet2004}:\cr
+#' \url{http://www.broadinstitute.org/publications/broad872}
+#'
+#' Original data from Golub et al.:\cr
+#' \url{http://www-genome.wi.mit.edu/mpr/data_set_ALL_AML.html}
+#'
+#' @name esGolub
+#' @docType data
+#' @keywords datasets
+#' @examples
+#'
+#' # requires package Biobase to be installed
+#' if( require(Biobase) ){
+#'
+#' data(esGolub)
+#' esGolub
+#' \dontrun{pData(esGolub)}
+#'
+#' }
+#'
+NULL
+
diff --git a/R/extractFeatures.R b/R/extractFeatures.R
new file mode 100644
index 0000000..6eb546e
--- /dev/null
+++ b/R/extractFeatures.R
@@ -0,0 +1,389 @@
+# Feature selection functions
+#
+# Author: Renaud Gaujoux
+# Created: Mar 18, 2013
+###############################################################################
+
+#' @include NMF-class.R
+NULL
+
+#' Feature Selection in NMF Models
+#'
+#' The function \code{featureScore} implements different methods to computes
+#' basis-specificity scores for each feature in the data.
+#'
+#' One of the properties of Nonnegative Matrix Factorization is that is tend to
+#' produce sparse representation of the observed data, leading to a natural
+#' application to bi-clustering, that characterises groups of samples by
+#' a small number of features.
+#'
+#' In NMF models, samples are grouped according to the basis
+#' components that contributes the most to each sample, i.e. the basis
+#' components that have the greatest coefficient in each column of the coefficient
+#' matrix (see \code{\link{predict,NMF-method}}).
+#' Each group of samples is then characterised by a set of features selected
+#' based on basis-specifity scores that are computed on the basis matrix.
+#'
+#' @section Feature scores:
+#' The function \code{featureScore} can compute basis-specificity scores using
+#' the following methods:
+#'
+#' \describe{
+#'
+#' \item{\sQuote{kim}}{ Method defined by \cite{KimH2007}.
+#'
+#' The score for feature \eqn{i} is defined as:
+#' \deqn{S_i = 1 + \frac{1}{\log_2 k} \sum_{q=1}^k p(i,q) \log_2 p(i,q)}{
+#' S_i = 1 + 1/log2(k) sum_q [ p(i,q) log2( p(i,q) ) ] },
+#'
+#' where \eqn{p(i,q)} is the probability that the \eqn{i}-th feature contributes
+#' to basis \eqn{q}: \deqn{p(i,q) = \frac{W(i,q)}{\sum_{r=1}^k W(i,r)} }{
+#' p(i,q) = W(i,q) / (sum_r W(i,r)) }
+#'
+#' The feature scores are real values within the range [0,1].
+#' The higher the feature score the more basis-specific the corresponding feature.
+#' }
+#'
+#' \item{\sQuote{max}}{Method defined by \cite{Carmona-Saez2006}.
+#'
+#' The feature scores are defined as the row maximums.
+#' }
+#'
+#' }
+#'
+#' @param object an object from which scores/features are computed/extracted
+#' @param ... extra arguments to allow extension
+#'
+#' @return \code{featureScore} returns a numeric vector of the length the number
+#' of rows in \code{object} (i.e. one score per feature).
+#'
+#' @export
+#' @rdname scores
+#' @inline
+#'
+setGeneric('featureScore', function(object, ...) standardGeneric('featureScore') )
+#' Computes feature scores on a given matrix, that contains the basis component in columns.
+setMethod('featureScore', 'matrix',
+ function(object, method=c('kim', 'max')){
+
+ method <- match.arg(method)
+ score <- switch(method,
+
+ kim = {
+ #for each row compute the score
+ s <- apply(object, 1, function(g){
+ g <- abs(g)
+ p_i <- g/sum(g)
+ crossprod(p_i, log2(p_i))
+ })
+ # scale, translate and return the result
+ 1 + s / log2(ncol(object))
+ }
+ , max = {
+ apply(object, 1L, function(x) max(abs(x)))
+ }
+ )
+
+ # return the computed score
+ return(score)
+ }
+)
+#' Computes feature scores on the basis matrix of an NMF model.
+setMethod('featureScore', 'NMF',
+ function(object, ...){
+ featureScore(basis(object), ...)
+ }
+)
+
+
+#' The function \code{extractFeatures} implements different methods to select the
+#' most basis-specific features of each basis component.
+#'
+#' @section Feature selection:
+#' The function \code{extractFeatures} can select features using the following
+#' methods:
+#' \describe{
+#' \item{\sQuote{kim}}{ uses \cite{KimH2007} scoring schema and
+#' feature selection method.
+#'
+#' The features are first scored using the function
+#' \code{featureScore} with method \sQuote{kim}.
+#' Then only the features that fulfil both following criteria are retained:
+#'
+#' \itemize{
+#' \item score greater than \eqn{\hat{\mu} + 3 \hat{\sigma}}, where \eqn{\hat{\mu}}
+#' and \eqn{\hat{\sigma}} are the median and the median absolute deviation
+#' (MAD) of the scores respectively;
+#'
+#' \item the maximum contribution to a basis component is greater than the median
+#' of all contributions (i.e. of all elements of W).
+#' }
+#'
+#' }
+#'
+#' \item{\sQuote{max}}{ uses the selection method used in the \code{bioNMF}
+#' software package and described in \cite{Carmona-Saez2006}.
+#'
+#' For each basis component, the features are first sorted by decreasing
+#' contribution.
+#' Then, one selects only the first consecutive features whose highest
+#' contribution in the basis matrix is effectively on the considered basis.
+#' }
+#'
+#' }
+#'
+#' @return \code{extractFeatures} returns the selected features as a list of indexes,
+#' a single integer vector or an object of the same class as \code{object}
+#' that only contains the selected features.
+#'
+#' @rdname scores
+#' @inline
+#' @export
+#'
+setGeneric('extractFeatures', function(object, ...) standardGeneric('extractFeatures') )
+
+# internal functio to trick extractFeatures when format='subset'
+.extractFeaturesObject <- local({
+ .object <- NULL
+ function(object){
+ # first call resets .object
+ if( missing(object) ){
+ res <- .object
+ .object <<- NULL
+ res
+ }else # set .object for next call
+ .object <<- object
+ }
+})
+
+#' Select features on a given matrix, that contains the basis component in columns.
+#'
+#' @param method scoring or selection method.
+#' It specifies the name of one of the method described in sections \emph{Feature scores}
+#' and \emph{Feature selection}.
+#'
+#' Additionally for \code{extractFeatures}, it may be an integer vector that
+#' indicates the number of top most contributing features to
+#' extract from each column of \code{object}, when ordered in decreasing order,
+#' or a numeric value between 0 and 1 that indicates the minimum relative basis
+#' contribution above which a feature is selected (i.e. basis contribution threshold).
+#' In the case of a single numeric value (integer or percentage), it is used for all columns.
+#'
+#' Note that \code{extractFeatures(x, 1)} means relative contribution threshold of
+#' 100\%, to select the top contributing features one must explicitly specify
+#' an integer value as in \code{extractFeatures(x, 1L)}.
+#' However, if all elements in methods are > 1, they are automatically treated as
+#' if they were integers: \code{extractFeatures(x, 2)} means the top-2 most
+#' contributing features in each component.
+#' @param format output format.
+#' The following values are accepted:
+#' \describe{
+#' \item{\sQuote{list}}{(default) returns a list with one element per column in
+#' \code{object}, each containing the indexes of the selected features, as an
+#' integer vector.
+#' If \code{object} has row names, these are used to name each index vector.
+#' Components for which no feature were selected are assigned a \code{NA} value.}
+#'
+#' \item{\sQuote{combine}}{ returns all indexes in a single vector.
+#' Duplicated indexes are made unique if \code{nodups=TRUE} (default).}
+#'
+#' \item{\sQuote{subset}}{ returns an object of the same class as \code{object},
+#' but subset with the selected indexes, so that it contains data only from
+#' basis-specific features.}
+#' }
+#'
+#' @param nodups logical that indicates if duplicated indexes,
+#' i.e. features selected on multiple basis components (which should in
+#' theory not happen), should be only appear once in the result.
+#' Only used when \code{format='combine'}.
+#'
+#' @examples
+#'
+#' # random NMF model
+#' x <- rnmf(3, 50,20)
+#'
+#' # probably no feature is selected
+#' extractFeatures(x)
+#' # extract top 5 for each basis
+#' extractFeatures(x, 5L)
+#' # extract features that have a relative basis contribution above a threshold
+#' extractFeatures(x, 0.5)
+#' # ambiguity?
+#' extractFeatures(x, 1) # means relative contribution above 100%
+#' extractFeatures(x, 1L) # means top contributing feature in each component
+#'
+setMethod('extractFeatures', 'matrix',
+ function(object, method=c('kim', 'max')
+ , format=c('list', 'combine', 'subset'), nodups=TRUE){
+
+ res <-
+ if( is.numeric(method) ){
+ # repeat single values
+ if( length(method) == 1L ) method <- rep(method, ncol(object))
+
+ # float means percentage, integer means count
+ # => convert into an integer if values > 1
+ if( all(method > 1L) ) method <- as.integer(method)
+
+ if( is.integer(method) ){ # extract top features
+
+ # only keep the specified number of feature for each column
+ mapply(function(i, l) head(order(object[,i], decreasing=TRUE), l)
+ , seq(ncol(object)), method, SIMPLIFY=FALSE)
+
+ }else{ # extract features with contribution > threshold
+
+ # compute relative contribution
+ so <- sweep(object, 1L, rowSums(object), '/')
+ # only keep features above threshold for each column
+ mapply(function(i, l) which(so[,i] >= l)
+ , seq(ncol(object)), method, SIMPLIFY=FALSE)
+
+ }
+ }else{
+ method <- match.arg(method)
+ switch(method,
+ kim = { # KIM & PARK method
+
+ # first score the genes
+ s <- featureScore(object, method='kim')
+
+ # filter for the genes whose score is greater than \mu + 3 \sigma
+ th <- median(s) + 3 * mad(s)
+ sel <- s >= th
+ #print( s[sel] )
+ #print(sum(sel))
+
+ # build a matrix with:
+ #-> row#1=max column index, row#2=max value in row, row#3=row index
+ temp <- 0;
+ g.mx <- apply(object, 1L,
+ function(x){
+ temp <<- temp +1
+ i <- which.max(abs(x));
+ #i <- sample(c(1,2), 1)
+ c(i, x[i], temp)
+ }
+ )
+
+ # test the second criteria
+ med <- median(abs(object))
+ sel2 <- g.mx[2,] >= med
+ #print(sum(sel2))
+
+ # subset the indices
+ g.mx <- g.mx[, sel & sel2, drop=FALSE]
+ # order by decreasing score
+ g.mx <- g.mx[,order(s[sel & sel2], decreasing=TRUE)]
+
+ # return the indexes of the features that fullfil both criteria
+ cl <- factor(g.mx[1,], levels=seq(ncol(object)))
+ res <- split(g.mx[3,], cl)
+
+ # add the threshold used
+ attr(res, 'threshold') <- th
+
+ # return result
+ res
+
+ },
+ max = { # MAX method from bioNMF
+
+ # determine the specific genes for each basis vector
+ res <- lapply(1:ncol(object),
+ function(i){
+ mat <- object
+ vect <- mat[,i]
+ #order by decreasing contribution to factor i
+ index.sort <- order(vect, decreasing=TRUE)
+
+ for( k in seq_along(index.sort) )
+ {
+ index <- index.sort[k]
+ #if the feature contributes more to any other factor then return the features above it
+ if( any(mat[index,-i] >= vect[index]) )
+ {
+ if( k == 1 ) return(as.integer(NA))
+ else return( index.sort[1:(k-1)] )
+ }
+ }
+
+ # all features meet the criteria
+ seq_along(vect)
+ }
+ )
+
+ # return res
+ res
+ }
+ )
+ }
+
+ #Note: make sure there is an element per basis (possibly NA)
+ res <- lapply(res, function(ind){ if(length(ind)==0) ind<-NA; as.integer(ind)} )
+
+ # add names if possible
+ if( !is.null(rownames(object)) ){
+ noNA <- sapply(res, is_NA)
+ res[noNA] <- lapply(res[noNA], function(x){
+ setNames(x, rownames(object)[x])
+ })
+ }
+
+ # apply the desired output format
+ format <- match.arg(format)
+ res <- switch(format
+ #combine: return all the indices in a single vector
+ , combine = {
+ # ensure that there is no names: for unlist no to mess up feature names
+ names(res) <- NULL
+ ind <- na.omit(unlist(res))
+ if( nodups ) unique(ind)
+ else ind
+ }
+ #subset: return the object subset with the selected indices
+ , subset = {
+ ind <- na.omit(unique(unlist(res)))
+ sobject <- .extractFeaturesObject()
+ {if( is.null(sobject) ) object else sobject}[ind, , drop=FALSE]
+ }
+ #else: leave as a list
+ ,{
+ # add component names if any
+ names(res) <- colnames(object)
+ res
+ }
+ )
+
+ # add attribute method to track the method used
+ attr(res, 'method') <- method
+ # return result
+ return( res )
+ }
+)
+#' Select basis-specific features from an NMF model, by applying the method
+#' \code{extractFeatures,matrix} to its basis matrix.
+#'
+#'
+setMethod('extractFeatures', 'NMF',
+ function(object, ...){
+ # extract features from the basis matrix, but subset the NMF model itself
+ .extractFeaturesObject(object)
+ extractFeatures(basis(object), ...)
+ }
+)
+
+unit.test(extractFeatures, {
+
+ .check <- function(x){
+ msg <- function(...) paste(class(x), ':', ...)
+ checkTrue( is.list(extractFeatures(x)), msg("default returns list"))
+ checkTrue( is.list(extractFeatures(x, format='list')), msg("format='list' returns list"))
+ checkTrue( is.integer(extractFeatures(x, format='combine')), msg("format='combine' returns an integer vector"))
+ checkTrue( is(extractFeatures(x, format='subset'), class(x)), msg("format='subset' returns same class as object"))
+ }
+
+ .check(rmatrix(50, 5))
+ .check(rnmf(3, 50, 5))
+
+})
diff --git a/R/fixed-terms.R b/R/fixed-terms.R
new file mode 100644
index 0000000..89926a8
--- /dev/null
+++ b/R/fixed-terms.R
@@ -0,0 +1,376 @@
+# Interface for NMF models that contain fixed terms
+#
+# Author: Renaud Gaujoux
+# Creation: 03 Jul 2012
+###############################################################################
+
+#' @include NMF-class.R
+#' @include NMFstd-class.R
+NULL
+
+#' Concatenating NMF Models
+#'
+#' Binds compatible matrices and NMF models together.
+#'
+#' @param x an NMF model
+#' @param ... other objects to concatenate. Currently only two objects at a time
+#' can be concatenated (i.e. \code{x} and \code{..1}).
+#' @param margin integer that indicates the margin along which to concatenate
+#' (only used when \code{..1} is a matrix):
+#' \describe{
+#' \item{1L}{}
+#' \item{2L}{}
+#' \item{3L}{}
+#' \item{4L}{}
+#' }
+#' If missing the margin is heuristically determined by looking at common
+#' dimensions between the objects.
+#'
+#' @keywords internal
+setMethod('c', 'NMF',
+ function(x, ..., margin=3L, recursive=FALSE){
+
+ y <- ..1
+ if( is.matrix(y) ){
+
+ if( missing(margin) ){
+ if( nrow(y) == nrow(x) ){
+ if( ncol(y) == ncol(x) ){
+ warning("NMF::`c` - Right argument match both target dimensions: concatenating basis columns."
+ , " Use `margin=4L` to concatenate coefficient rows.")
+ }
+ margin <- 3L
+ }else if( ncol(y) == ncol(x) ){
+ margin <- 4L
+ }else{
+ stop("NMF::`c` - Incompatible argument dimensions: could not infer concatenation margin.")
+ }
+ }
+
+ if( margin == 1L ){ # extend basis vectors
+
+ if( nbterms(x) ){ # cannot extend models with fixed basis terms
+ stop("NMF::`c` - Could not extend basis vectors:"
+ , " NMF model has fixed basis terms [", nbterms(x), "]")
+ }
+ if( ncol(y) != nbasis(x) ){
+ stop("NMF::`c` - Could not extend basis vectors:"
+ , " incompatible number of columns [", nbasis(x), '!=', ncol(y), "].")
+ }
+
+ # extend basis vectors
+ basis(x) <- rbind(basis(x), y)
+
+ } else if( margin == 2L ){ # extend basis profiles
+
+ if( ncterms(x) ){ # cannot extend models with fixed coef terms
+ stop("NMF::`c` - Could not extend basis profiles:"
+ , " NMF model has fixed coefficient terms [", ncterms(x), "]")
+ }
+ if( nrow(y) != nbasis(x) ){
+ stop("NMF::`c` - Could not extend basis profiles:"
+ , " incompatible number of rows [", nbasis(x), '!=', nrow(y), "].")
+ }
+
+ # extend basis profiles
+ coef(x) <- cbind(coef(x), y)
+
+ } else if( margin == 3L ){ # add basis vectors
+
+ if( nrow(y) != nrow(x) ){
+ stop("NMF::`c` - Could not concatenate basis vectors:"
+ , " incompatible number of rows [", nrow(x), '!=', nrow(y), "].")
+ }
+
+ # bind basis terms
+ .basis(x) <- cbind(basis(x), y)
+ dn <- colnames(.basis(x))
+ # bind dummy coef
+ .coef(x) <- rbind(coef(x), matrix(NA, ncol(y), ncol(x)))
+ basisnames(x) <- dn
+
+ } else if( margin == 4L ){ # add basis profiles
+
+ if( ncol(y) != ncol(x) ){
+ stop("NMF::`c` - Could not concatenate basis profiles:"
+ , " incompatible number of columns [", ncol(x), '!=', ncol(y), "].")
+ }
+
+ # bind coef terms
+ .coef(x) <- rbind(coef(x), y)
+ dn <- rownames(.coef(x))
+ # bind dummy basis
+ .basis(x) <- cbind(basis(x), matrix(NA, nrow(x), nrow(y)))
+ basisnames(x) <- dn
+
+ }else{
+ stop("NMF::`c` - Invalid concatenation margin: should be either"
+ , " 1L (basis rows), 2L (coef columns), 3L (basis vectors/columns) or 4L (basis profiles/coef rows).")
+ }
+ }else if( is.nmf(y) ){
+ # check dimensions
+ if( nrow(x) != nrow(y) )
+ stop("NMF::`c` - Could not concatenate NMF objects:"
+ , " incompatible number of rows [", nrow(x), '!=', nrow(y), "]")
+ if( ncol(x) != ncol(y) )
+ stop("NMF::`c` - Could not concatenate NMF objects:"
+ , " incompatible number of columns [", ncol(x), '!=', ncol(y), "]")
+ .basis(x) <- cbind(basis(x), basis(y))
+ .coef(x) <- rbind(coef(x), coef(y))
+ }else{
+ stop("NMF::`c` - Concatenation of an NMF object with objects of class '", class(y), "' is not supported.")
+ }
+
+ # return augmented object
+ x
+ }
+)
+
+
+fterms <- function(value){
+
+ res <- list(n=0L, terms=NULL, df=NULL, i=integer())
+ if( !length(value) ) return(res)
+
+ # convert into a data.frame
+ if( is.factor(value) ) value <- data.frame(Group=value)
+ else if( is.numeric(value) ) value <- data.frame(Var=value)
+ else if( !is.data.frame(value) ) value <- as.data.frame(value)
+
+ res$n <- length(value)
+ res$df <- value
+ # generate fixed term matrix
+ terms <- model.matrix(~ -1 + ., data=value)
+ res$terms <- terms
+ # build indexes
+ res$i <- 1:ncol(terms)
+
+ res
+}
+
+## #' Annotations in NMF Models
+## #'
+## #' NMF models may contain annotations for columns/rows and/or rows/features, in
+## #' a similar way gene expression data are annotated
+## #' \code{\linkS4class{ExpressionSet}} objects in Bioconductor.
+## #'
+## NULL
+
+#' Fixed Terms in NMF Models
+#'
+#' These functions are for internal use and should not be called by the end-user.
+#'
+#' They use \code{\link{model.matrix}(~ -1 + ., data=value)} to generate suitable
+#' term matrices.
+#'
+#' @param object NMF object to be updated.
+#' @param value specification of the replacement value for fixed-terms.
+#'
+#' @rdname terms-internal
+#' @keywords internal
+#' @inline
+setGeneric('bterms<-', function(object, value) standardGeneric('bterms<-'))
+#' Default method tries to coerce \code{value} into a \code{data.frame} with
+#' \code{\link{as.data.frame}}.
+setReplaceMethod('bterms', signature('NMFstd', 'ANY'),
+ function(object, value){
+
+ if( nterms(object) ){
+ stop("Cannot set fixed basis terms on an object that already has fixed terms:",
+ " these can be set only once and before setting any fixed coefficient term",
+ " [coef=", ncterms(object), ", basis=", nbterms(object), "].")
+ }
+ # build terms
+ t <- fterms(value)
+
+ if( !t$n ) return(object)
+
+ # check dimension
+ if( nrow(t$terms) != nrow(object) ){
+ stop("Invalid fixed basis terms: all terms should have length the number of target rows"
+ , "[terms=", nrow(t$terms), " != ", nrow(object), "=target]")
+ }
+
+ # set data
+ object at bterms <- t$df
+ # set indexes
+ i <- t$i
+ nv <- nbasis(object)
+ object at ibterms <- nv + i
+ # set terms
+ object <- c(object, t$terms, margin=3L)
+
+ object
+ }
+)
+#' \code{cterms<-} sets fixed coefficient terms or indexes and should only be
+#' called on a newly created NMF object, i.e. in the constructor/factory generic
+#' \code{\link{nmfModel}}.
+#'
+#' @rdname terms-internal
+#' @inline
+setGeneric('cterms<-', function(object, value) standardGeneric('cterms<-'))
+#' Default method tries to coerce \code{value} into a \code{data.frame} with
+#' \code{\link{as.data.frame}}.
+setReplaceMethod('cterms', signature('NMFstd', 'ANY'),
+ function(object, value){
+
+ if( ncterms(object) ){
+ stop("Cannot set fixed coef terms on an object that already has fixed coef terms:",
+ " these can be set only once",
+ " [coef=", ncterms(object), ", basis=", nbterms(object), "].")
+ }
+ # build terms
+ t <- fterms(value)
+
+ if( !t$n ) return(object)
+
+ # check dimension
+ if( nrow(t$terms) != ncol(object) ){
+ stop("Invalid fixed coefficient terms: all terms should have length the number of target columns"
+ , "[terms=", nrow(t$terms), " != ", ncol(object), "=target]")
+ }
+
+ # transpose term matrix
+ t$terms <- t(t$terms)
+ # set data
+ object at cterms <- t$df
+ # set indexes
+ i <- t$i
+ nv <- nbasis(object)
+ object at icterms <- nv + i
+ # set terms
+ object <- c(object, t$terms, margin=4L)
+
+ object
+ }
+)
+
+#' Fixed Terms in NMF Models
+#'
+#' @description
+#' Formula-based NMF models may contain fixed basis and/or coefficient terms.
+#' The functions documented here provide access to these data, which are
+#' read-only and defined when the model object is instantiated
+#' (e.g., see \code{\link[=nmfModel,formula,ANY-method]{nmfModel,formula-method}}).
+#'
+#' \code{ibterms}, \code{icterms} and \code{iterms} respectively return the
+#' indexes of the fixed basis terms, the fixed coefficient terms and all fixed
+#' terms, within the basis and/or coefficient matrix of an NMF model.
+#'
+#' @param object NMF object
+#' @param ... extra parameters to allow extension (currently not used)
+#'
+#' @export
+#' @rdname terms
+setGeneric('ibterms', function(object, ...) standardGeneric('ibterms') )
+#' Default pure virtual method that ensure a method is defined for concrete
+#' NMF model classes.
+setMethod('ibterms', 'NMF',
+ function(object, ...){
+ stop("NMF::ibterms is a pure virtual method of interface 'NMF'."
+ ," It should be overloaded in class '", class(object),"'.")
+ }
+)
+#' Method for standard NMF models, which returns the integer vector that is
+#' stored in slot \code{ibterms} when a formula-based NMF model is instantiated.
+setMethod('ibterms', 'NMFstd',
+ function(object){
+ object at ibterms
+ }
+)
+#' @export
+#' @rdname terms
+setGeneric('icterms', function(object, ...) standardGeneric('icterms') )
+#' Default pure virtual method that ensure a method is defined for concrete
+#' NMF model classes.
+setMethod('icterms', 'NMF',
+ function(object, ...){
+ stop("NMF::icterms is a pure virtual method of interface 'NMF'."
+ ," It should be overloaded in class '", class(object),"'.")
+ }
+)
+#' Method for standard NMF models, which returns the integer vector that is
+#' stored in slot \code{icterms} when a formula-based NMF model is instantiated.
+setMethod('icterms', 'NMFstd',
+ function(object){
+ object at icterms
+ }
+)
+#' @export
+#' @rdname terms
+iterms <- function(object, ...){
+ c(ibterms(object), icterms(object))
+}
+
+#' \code{nterms}, \code{nbterms}, and \code{ncterms} return, respectively,
+#' the number of all fixed terms, fixed basis terms and fixed coefficient terms
+#' in an NMF model.
+#' In particular: i.e. \code{nterms(object) = nbterms(object) + ncterms(object)}.
+#' @export
+#' @rdname terms
+nterms <- function(object){
+ length(ibterms(object)) + length(icterms(object))
+}
+#' @export
+#' @rdname terms
+nbterms <- function(object){
+ length(ibterms(object))
+}
+#' @export
+#' @rdname terms
+ncterms <- function(object){
+ length(icterms(object))
+}
+
+#' \code{bterms} and \code{cterms} return, respectively, the primary data for
+#' fixed basis and coefficient terms in an NMF model -- as stored in slots
+#' \code{bterms} and \code{cterms} .
+#' These are factors or numeric vectors which define fixed basis components,
+#' e.g., used for defining separate offsets for different \emph{a priori} groups
+#' of samples, or to incorporate/correct for some known covariate.
+#'
+#' @export
+#' @rdname terms
+bterms <- function(object){
+ object at bterms
+}
+#' @export
+#' @rdname terms
+cterms <- function(object){
+ object at cterms
+}
+
+#' \code{ibasis} and \code{icoef} return, respectively, the
+#' indexes of all latent basis vectors and estimated coefficients within the
+#' basis or coefficient matrix of an NMF model.
+#' @export
+#' @rdname terms
+ibasis <- function(object, ...){
+ i <- 1:nbasis(object)
+ if( length(idx <- ibterms(object, ...)) ) i[-idx]
+ else i
+}
+#' @export
+#' @rdname terms
+icoef <- function(object, ...){
+ i <- 1:nbasis(object)
+ if( length(idx <- icterms(object, ...)) ) i[-idx]
+ else i
+}
+
+#' @S3method t NMFstd
+t.NMFstd <- function(x){
+ # transpose and swap factors
+ x <- t.NMF(x)
+ # swap fixed terms
+ bt <- bterms(x)
+ ibt <- ibterms(x)
+ x at bterms <- cterms(x)
+ x at ibterms <- icterms(x)
+ x at cterms <- bt
+ x at icterms <- ibt
+
+ # returns
+ x
+}
diff --git a/R/grid.R b/R/grid.R
new file mode 100644
index 0000000..22e8f83
--- /dev/null
+++ b/R/grid.R
@@ -0,0 +1,72 @@
+# Grid related functions
+#
+# Mainly functions that duplicate grid functions but do not create a new plot
+# if none is present.
+#
+# Author: Renaud Gaujoux
+# Creation: 04 Jun 2012
+###############################################################################
+
+#' @include options.R
+#' @import grid
+NULL
+
+#' Internal Grid Extension
+#'
+#' These functions enable mixing base and grid graphics in \code{\link{aheatmap}},
+#' by avoiding calls to the grid internal function \code{'L_gridDirty'}.
+#' They are not exported (i.e. not tampering core functions) and are only meant for internal
+#' use within the \pkg{NMF} package.
+#'
+#' \code{tryViewport} tries to go down to a viewport in the current tree,
+#' given its name.
+#'
+#' @details
+#' \code{tryViewport} uses \code{\link[grid]{grid.ls}} and not
+#' \code{\link{seekViewport}} as the latter would reset the graphic device
+#' and break the mix grid/base graphic capability.
+#'
+#' @param name viewport name
+#' @param verbose toggle verbosity
+#'
+#' @rdname grid
+#' @keywords internal
+tryViewport <- function(name, verbose=FALSE){
+
+ if( verbose ) message("vp - lookup for ", name)
+ l <- grid.ls(viewports=TRUE, grobs=FALSE, print=FALSE)
+ if( name %in% l$name ){
+ downViewport(name)
+ }
+}
+
+#' \code{current.vpPath_patched} aims at substituting \code{\link[grid]{current.vpPath}},
+#' so that the graphic engine is not reset.
+#' This is essentially to prevent outputting a blank page at the beginning of PDF
+#' graphic engines.
+#'
+#' @rdname grid
+current.vpPath_patched <- local({
+ .current.vpPath <- NULL
+ function(){
+
+ f_current.vpPath <- .current.vpPath
+ if( !.use.grid.patch() ) f_current.vpPath <- grid::current.vpPath
+ else if( is.null(f_current.vpPath) ){ # load patch from installed file
+ patch <- source(packagePath('scripts', 'grid.R', package = 'NMF'), local = TRUE)
+ .current.vpPath <<- patch$value
+ f_current.vpPath <- .current.vpPath
+ }
+ # call
+ f_current.vpPath()
+ }
+})
+
+# Add new option to enable/disable grid patch
+.OPTIONS$newOptions(grid.patch = FALSE)
+
+#' \code{.use.grid.patch} tells if the user enabled patching grid.
+#' @rdname grid
+.use.grid.patch <- function(){
+ !isCHECK() && nmf.getOption('grid.patch')
+}
diff --git a/R/heatmaps.R b/R/heatmaps.R
new file mode 100644
index 0000000..4ba17b1
--- /dev/null
+++ b/R/heatmaps.R
@@ -0,0 +1,541 @@
+# Heatmap functions
+#
+# Author: Renaud Gaujoux
+###############################################################################
+
+#' @include NMF-class.R
+#' @include aheatmap.R
+NULL
+
+#' @param object an R object
+#' @param ... other arguments
+#'
+#' @export
+#' @inline
+#' @rdname NMF-defunct
+setGeneric('metaHeatmap', function(object, ...) standardGeneric('metaHeatmap') )
+#' Defunct method substituted by \code{\link{aheatmap}}.
+setMethod('metaHeatmap', signature(object='matrix'),
+ function(object, ...){
+ local <- function(object, type=c('plain', 'consensus'), class
+ , unit.scaling=c('none', 'row', 'column'), palette="YlOrRd"
+ , rev.palette=FALSE, show.prediction=TRUE, ...){
+
+ .Defunct('metaHeatmap', 'NMF', "The S4 method 'metaHeatmap,matrix' is defunct, use 'aheatmap' instead.")
+
+# # load libary RColorBrewer
+# library(RColorBrewer)
+#
+# # retreive the graphical parameters and match them to the sub-sequent call to 'heatmap.plus.2'
+# graphical.params <- list(...)
+# names(graphical.params) <- .match.call.args(names(graphical.params), 'heatmap.plus.2', in.fun='metaHeatmap', call='NMF::metaHeatmap')
+#
+# type <- match.arg(type)
+# if( type == 'consensus' ){
+# # set default graphical parameters for type 'consensus'
+# graphical.params <- .set.list.defaults(graphical.params
+# , distfun = function(x){ as.dist(1-x) }
+# , main='Consensus matrix'
+# , symm=TRUE
+# , Rowv=TRUE
+# , revC=TRUE
+# )
+#
+# if( missing(palette) ) palette <- 'RdYlBu'
+# if( missing(rev.palette) ) rev.palette <- TRUE
+# if( missing(unit.scaling) ) unit.scaling <- 'none'
+# show.prediction <- FALSE # not used for consensus matrices
+# }
+#
+# # apply unit scaling if necessary
+# unit.scaling <- match.arg(unit.scaling)
+# if( unit.scaling == 'column' )
+# object <- apply(object, 2, function(x) x/sum(x))
+# else if ( unit.scaling == 'row' )
+# object <- t(apply(object, 1, function(x) x/sum(x)))
+#
+# # check validity of palette
+# col.palette <- brewer.pal(brewer.pal.info[palette,'maxcolors'],palette)
+# if( rev.palette ) col.palette <- rev(col.palette)
+#
+# # set default graphical parameters (if those are not already set)
+# graphical.params <- .set.list.defaults(graphical.params
+# , cexRow=0.8, cexCol=0.8
+# , hclustfun = function(m) hclust(m,method="average")
+# , dendrogram='none'
+# , col=col.palette
+# , scale='none', trace="none"
+# , keysize=1, margins=c(5,10)
+# )
+#
+# # if a known class is provided, add a side color over the top row
+# if( !missing(class) ){
+# if( !is.factor(class) ) class <- as.factor(class)
+# class.num <- as.numeric(class)
+# legend.pal <- palette(rainbow(max(2,nlevels(class))))[1:nlevels(class)]
+# col.matrix <- matrix(legend.pal[class.num], ncol(object), 1)
+#
+# # show association with metagenes
+# if( show.prediction ){
+# # only if there is less than 9 metagenes
+# # cf. limitation of brewer color palette
+# if( nrow(object) <= 9 ){
+# prediction <- .predict.nmf(object)
+# prediction.num <- as.numeric(prediction)
+# pal.pred <- brewer.pal(max(3,nrow(object)),'Set2')[1:nrow(object)]
+# col.matrix <- cbind(pal.pred[prediction.num], col.matrix)
+# graphical.params <- .set.list.defaults(graphical.params
+# , RowSideColors=pal.pred
+# )
+# }
+# else warning("NMF::metaHeatmap - cannot not show prediction for more than 9 metagenes.")
+# }
+# # do that otherwise heatmap.plus complains
+# if( ncol(col.matrix) < 2 )
+# col.matrix <- cbind(col.matrix, col.matrix)
+#
+# # add the ColSideColors
+# graphical.params <- .set.list.defaults(graphical.params
+# , ColSideColors=col.matrix
+# )
+# }
+#
+#
+# res.heatmap <- do.call('heatmap.plus.2', c(list(object), graphical.params))
+#
+# if( !missing(class) ){
+# # order properly the legend boxes
+# class.num <- as.numeric(class[res.heatmap$colInd])
+#
+# occ <- NA # will store the current number of occurences
+# class.max.occ <- rep(0, nlevels(class)) # will store the current maximum number of occurences per class
+# class.start <- rep(NA, nlevels(class)) # will store the current start of the longer stretch per class
+# last.l <- ''
+# sapply( seq(length(class.num), 1, -1),
+# function(i){
+# l <- class.num[i]
+# if(l==last.l){
+# occ <<- occ + 1
+# }else{
+# occ <<- 1
+# }
+# if(occ > class.max.occ[l]){
+# class.max.occ[l] <<- occ
+# class.start[l] <<- i
+# }
+# last.l <<- l
+# }
+# )
+#
+# class.ord <- order(class.start)
+# l.names <- levels(class)[class.ord]
+# l.color <- legend.pal[class.ord]
+# legend('top', title='Classes'
+# , legend=l.names, fill=l.color
+# , horiz=TRUE, bty='n')
+# }
+#
+# # return invisible
+# invisible(res.heatmap)
+ }
+ local(object, ...)
+ }
+)
+#' Deprecated method that is substituted by \code{\link{coefmap}} and \code{\link{basismap}}.
+setMethod('metaHeatmap', signature(object='NMF'),
+ function(object, ...){
+ local <- function(object, what=c('samples', 'features'), filter=FALSE, ...){
+
+ what <- match.arg(what)
+ if( what == 'samples' ){
+ # send deprecated warning
+ .Defunct('coefmap', 'NMF', "Direct use of the S4-Method 'metaHeatmap' for 'NMF' objects is defunct, use 'coefmap' instead.")
+
+ # call the new function 'coefmap'
+ return( coefmap(object, ...) )
+
+ }else if( what == 'features' ){
+ # send deprecated warning
+ .Defunct('basismap', 'NMF', "Direct use of the S4-Method 'metaHeatmap' for 'NMF' objects is defunct, use 'basismap' instead.")
+
+ # call the new function 'basismap'
+ return( basismap(object, subsetRow=filter, ...) )
+
+ }
+ }
+ local(object, ...)
+ }
+)
+
+# match an annotation track against list of supported tracks
+match_named_track <- function(annotation, tracks, msg, optional=FALSE){
+
+ idx <-
+ if( is.character(annotation) ){
+ i <- match(annotation, tracks, nomatch=if(optional) 0L else NA )
+ if( any(!is.na(i)) ){
+ if( !optional && any(is.na(i)) ){
+ stop(msg, "invalid track(s) [", str_out(annotation[is.na(i)])
+ , "]: should be one of ", str_out(tracks))
+ }
+ }
+ i
+ }else if( is.list(annotation) ){
+ sapply(annotation, function(x){
+ if( isString(x) ) match(x, tracks, nomatch=if(optional) 0L else NA )
+ else NA
+ })
+ }
+
+ if( is.null(idx) ) return()
+ ok <- !is.na(idx)
+ # result
+ # remaining annotations
+ ann <- annotation[!ok]
+ if( length(ann) == 0L ) ann <- NULL
+ # track annotations
+ tr <- unlist(annotation[which(ok)])
+ idx <- idx[which(ok)]
+ if( is.null(names(annotation)) ) names(tr) <- tr
+ else{
+ mn <- names(tr) == ''
+ names(tr)[mn] <- tr[mn]
+ }
+ others <- tr[idx==0L]
+ #
+# list(ann=ann, tracks=tr[idx>0L], others=if(length(others)) others else NULL)
+ list(ann=as.list(ann), tracks=tr)
+}
+
+#' Heatmaps of NMF Factors
+#'
+#' The NMF package ships an advanced heatmap engine implemented by the function
+#' \code{\link{aheatmap}}.
+#' Some convenience heatmap functions have been implemented for NMF models,
+#' which redefine default values for some of the arguments of \code{\link{aheatmap}},
+#' hence tuning the output specifically for NMF models.
+#'
+#' \strong{IMPORTANT:} although they essentially have the same set of arguments,
+#' their order sometimes differ between them, as well as from \code{\link{aheatmap}}.
+#' We therefore strongly recommend to use fully named arguments when calling these functions.
+#'
+#' @rdname heatmaps
+#' @name heatmap-NMF
+#'
+#' @examples
+#'
+#' ## More examples are provided in demo `heatmaps`
+#' \dontrun{
+#' demo(heatmaps)
+#' }
+#' ##
+#'
+#' # random data with underlying NMF model
+#' v <- syntheticNMF(20, 3, 10)
+#' # estimate a model
+#' x <- nmf(v, 3)
+#'
+#' @demo Heatmaps of NMF objects
+#'
+#' #' # random data with underlying NMF model
+#' v <- syntheticNMF(20, 3, 10)
+#' # estimate a model
+#' x <- nmf(v, 3)
+#'
+NULL
+
+#' \code{basimap} draws an annotated heatmap of the basis matrix.
+#'
+#' @details
+#' \code{basimap} default values for the following arguments of \code{\link{aheatmap}}:
+#' \itemize{
+#' \item the color palette;
+#' \item the scaling specification, which by default scales each
+#' row separately so that they sum up to one (\code{scale='r1'});
+#' \item the column ordering which is disabled;
+#' \item allowing for passing feature extraction methods in argument
+#' \code{subsetRow}, that are passed to \code{\link{extractFeatures}}.
+#' See argument description here and therein.
+#' \item the addition of a default named annotation track, that shows
+#' the dominant basis component for each row (i.e. each feature).
+#'
+#' This track is specified in argument \code{tracks} (see its argument description).
+#' By default, a matching column annotation track is also displayed, but may be
+#' disabled using \code{tracks=':basis'}.
+#'
+#' \item a suitable title and extra information like the fitting algorithm,
+#' when \code{object} is a fitted NMF model.
+#' }
+#'
+#' @param object an object from which is extracted NMF factors or a consensus
+#' matrix
+#' @param ... extra arguments passed to \code{\link{aheatmap}}.
+#'
+#' @rdname heatmaps
+#' @inline
+#' @export
+#'
+#' @examples
+#'
+#' # show basis matrix
+#' basismap(x)
+#' \dontrun{
+#' # without the default annotation tracks
+#' basismap(x, tracks=NA)
+#' }
+#'
+#' @demo
+#'
+#' # highligh row only (using custom colors)
+#' basismap(x, tracks=':basis', annColor=list(basis=1:3))
+#'
+#' ## character annotation vector: ok if it does not contain 'basis'
+#' # annotate first and second row + automatic special track
+#' basismap(x, annRow=c('alpha', 'beta'))
+#' # no special track here
+#' basismap(x, annRow=c('alpha', 'beta', ':basis'), tracks=NA)
+#' # with special track `basis`
+#' basismap(x, annRow=list(c('alpha', 'beta'), ':basis'), tracks=NA)
+#' # highligh columns only (using custom colors)
+#' basismap(x, tracks='basis:')
+#'
+#' # changing the name of the basis annotation track
+#' basismap(x, annRow=list(new_name=':basis'))
+#'
+setGeneric('basismap', function(object, ...) standardGeneric('basismap') )
+#' Plots a heatmap of the basis matrix of the NMF model \code{object}.
+#' This method also works for fitted NMF models (i.e. \code{NMFfit} objects).
+#'
+#' @inheritParams aheatmap
+#' @param subsetRow Argument that specifies how to filter the rows that
+#' will appear in the heatmap.
+#' When \code{FALSE} (default), all rows are used.
+#' Besides the values supported by argument \code{subsetRow} of
+#' \code{\link{aheatmap}}, other possible values are:
+#'
+#' \itemize{
+#' \item \code{TRUE}: only the rows that are basis-specific are used.
+#' The default selection method is from \cite{KimH2007}.
+#' This is equivalent to \code{subsetRow='kim'}.
+#'
+#' \item a single \code{character} string or numeric value that specifies
+#' the method to use to select the basis-specific rows, that should appear in the
+#' heatmap (cf. argument \code{method} for function \code{\link{extractFeatures}}).
+#'
+#' Note \code{\link{extractFeatures}} is called with argument \code{nodups=TRUE},
+#' so that features that are selected for multiple components only appear once.
+#' }
+#' @param tracks Special additional annotation tracks to highlight associations between
+#' basis components and sample clusters:
+#' \describe{
+#' \item{basis}{matches each row (resp. column) to the most contributing basis component
+#' in \code{basismap} (resp. \code{coefmap}).
+#' In \code{basismap} (resp. \code{coefmap}), adding a track \code{':basis'} to
+#' \code{annCol} (resp. \code{annRow}) makes the column (resp. row) corresponding to
+#' the component being also highlited using the mathcing colours.}
+#' }
+#' @param info if \code{TRUE} then the name of the algorithm that fitted the NMF
+#' model is displayed at the bottom of the plot, if available.
+#' Other wise it is passed as is to \code{aheatmap}.
+#'
+#'
+setMethod('basismap', signature(object='NMF'),
+ function(object, color = 'YlOrRd:50'
+ , scale = 'r1'
+ , Rowv=TRUE, Colv=NA, subsetRow=FALSE
+ , annRow=NA, annCol=NA, tracks = 'basis'
+ , main="Basis components", info = FALSE
+ , ...){
+
+ # resolve subsetRow if its a single value
+ if( is.atomic(subsetRow) && length(subsetRow) == 1 ){
+ subsetRow <-
+ if( isFALSE(subsetRow) )
+ NULL
+ else if( isTRUE(subsetRow) ) # use Kim and Park scoring scheme for filtering
+ extractFeatures(object, format='combine')
+ else if( is.character(subsetRow) || is.numeric(subsetRow) ) # use subsetRow as a filtering method
+ extractFeatures(object, method=subsetRow, format='combine')
+ else stop("NMF::basismap - invalid single value for argument 'subsetRow' [logical, numeric or character expected]")
+ }
+
+ # extract the basis vector matrix
+ x <- basis(object)
+
+ # add side information if requested
+ info <- if( isTRUE(info) && isNMFfit(object) )
+ paste("Method:", algorithm(object))
+ else if( isFALSE(info) ) NULL
+ else info
+
+ # process annotation tracks
+ ptracks <- process_tracks(x, tracks, annRow, annCol)
+ annRow <- ptracks$row
+ annCol <- ptracks$col
+ # set special annotation handler
+ specialAnnotation(1L, 'basis', function() predict(object, what='features'))
+ specialAnnotation(2L, 'basis', function() as.factor(1:nbasis(object)))
+ #
+
+ # call aheatmap on matrix
+ aheatmap(x, color = color, ...
+ , scale = scale, Rowv=Rowv, Colv = Colv, subsetRow = subsetRow
+ , annRow = annRow, annCol = annCol
+ , main = main, info = info)
+ }
+)
+
+# check if an object contains some value
+anyValue <- function(x){
+ length(x) > 0L && !is_NA(x)
+}
+
+grep_track <- function(x){
+ list(
+ both = grepl("^[^:].*[^:]$", x) | grepl("^:.*:$", x)
+ , row = grepl("^:.*[^:]$", x)
+ , col = grepl("^[^:].*:$", x)
+ )
+}
+
+# process extra annotation tracks
+process_tracks <- function(data, tracks, annRow=NA, annCol=NA){
+
+ if( anyValue(tracks) ){
+
+ # extract choices from caller function
+ formal.args <- formals(sys.function(sys.parent()))
+ choices <- eval(formal.args[[deparse(substitute(tracks))]])
+ if( isTRUE(tracks) ) tracks <- choices
+ else{
+ if( !is.character(tracks) )
+ stop("Special annotation tracks must be specified either as NA, TRUE or a character vector [", class(tracks), "].")
+
+ # check validity
+ pattern <- "^(:)?([^:]*)(:)?$"
+ basech <- str_match(choices, pattern)
+ basetr <- str_match(tracks, pattern)
+ tr <- basetr[, 3L]
+ # print(basetr)
+ # print(basech)
+ # extend base track name
+ i <- charmatch(tr, basech[,3L])
+ tr[!is.na(i)] <- basech[i[!is.na(i)],3L]
+ tracks_long <- str_c(basetr[,2L], tr, basetr[,4L])
+ # extend choices
+ tty_choice <- grep_track(choices)
+ if( any(tty_choice$both) )
+ choices <- c(choices, str_c(':', choices[tty_choice$both]), str_c(choices[tty_choice$both], ':'))
+ # look for exact match
+ itr <- charmatch(tracks_long, choices)
+ if( length(err <- which(is.na(itr))) ){
+ stop("Invalid special annotation track name [", str_out(tracks[err], Inf)
+ ,"]. Should partially match one of ", str_out(choices, Inf), '.')
+ }
+ tracks[!is.na(itr)] <- choices[itr]
+ }
+# print(tracks)
+ }
+ #
+ tty <- grep_track(tracks)
+ # create result object
+ build <- function(x, ann, data, margin){
+ t <-
+ if( anyValue(x) ) as.list(setNames(str_c(':', sub("(^:)|(:$)","",x)), names(x)))
+ else NA
+ # build annotations
+ atrack(ann, t, .DATA=amargin(data,margin))
+ }
+
+ res <- list()
+ res$row <- build(tracks[tty$both | tty$row], annRow, data, 1L)
+ res$col <- build(tracks[tty$both | tty$col], annCol, data, 2L)
+ #str(res)
+ res
+}
+
+#' \code{coefmap} draws an annotated heatmap of the coefficient matrix.
+#'
+#' @details
+#' \code{coefmap} redefines default values for the following arguments of
+#' \code{\link{aheatmap}}:
+#' \itemize{
+#' \item the color palette;
+#' \item the scaling specification, which by default scales each
+#' column separately so that they sum up to one (\code{scale='c1'});
+#' \item the row ordering which is disabled;
+#' \item the addition of a default annotation track, that shows the most
+#' contributing basis component for each column (i.e. each sample).
+#'
+#' This track is specified in argument \code{tracks} (see its argument description).
+#' By default, a matching row annotation track is also displayed, but can be disabled
+#' using \code{tracks='basis:'}.
+#' \item a suitable title and extra information like the fitting algorithm,
+#' when \code{object} is a fitted NMF model.
+#' }
+#'
+#' @rdname heatmaps
+#' @inline
+#' @export
+#'
+#' @examples
+#'
+#' # coefficient matrix
+#' coefmap(x)
+#' \dontrun{
+#' # without the default annotation tracks
+#' coefmap(x, tracks=NA)
+#' }
+#'
+#' @demo
+#'
+#' # coefficient matrix
+#' coefmap(x, annCol=c('alpha', 'beta')) # annotate first and second sample
+#' coefmap(x, annCol=list('basis', Greek=c('alpha', 'beta'))) # annotate first and second sample + basis annotation
+#' coefmap(x, annCol=c(new_name='basis'))
+#'
+setGeneric('coefmap', function(object, ...) standardGeneric('coefmap') )
+#' The default method for NMF objects has special default values for
+#' some arguments of \code{\link{aheatmap}} (see argument description).
+setMethod('coefmap', signature(object='NMF'),
+ function(object, color = 'YlOrRd:50'
+ , scale = 'c1'
+ , Rowv = NA, Colv = TRUE
+ , annRow = NA, annCol = NA, tracks='basis'
+ , main="Mixture coefficients", info = FALSE
+ , ...){
+
+ # use the mixture coefficient matrix
+ x <- coef(object)
+
+ # add side information if requested
+ info <- if( isTRUE(info) && isNMFfit(object) )
+ paste("Method: ", algorithm(object))
+ else if( isFALSE(info) ) NULL
+ else info
+
+ # process annotation tracks
+ ptracks <- process_tracks(x, tracks, annRow, annCol)
+ annRow <- ptracks$row
+ annCol <- ptracks$col
+ # set special annotation handler
+ specialAnnotation(1L, 'basis', function() as.factor(1:nbasis(object)))
+ specialAnnotation(2L, 'basis', function() predict(object))
+ #
+
+ ## process ordering
+ if( isString(Colv) ){
+ if( Colv == 'basis' ) Colv <- 'samples'
+ if( Colv == 'samples' )
+ Colv <- order(as.numeric(predict(object, Colv)))
+ }
+ ##
+
+ # call aheatmap on matrix
+ aheatmap(x, ..., color = color
+ , scale = scale, Rowv = Rowv, Colv=Colv
+ , annRow=annRow, annCol = annCol
+ , main=main, info = info)
+ }
+)
+
diff --git a/R/nmf-package.R b/R/nmf-package.R
new file mode 100644
index 0000000..832b119
--- /dev/null
+++ b/R/nmf-package.R
@@ -0,0 +1,178 @@
+#' @import graphics
+#' @import rngtools
+#' @import digest
+#' @import stringr
+#' @import stats
+#' @import methods
+NULL
+#library(digest)
+
+#' Defunct Functions and Classes in the NMF Package
+#'
+#' @name NMF-defunct
+#' @rdname NMF-defunct
+NULL
+
+#' Deprecated Functions in the Package NMF
+#'
+#' @param object an R object
+#' @param ... extra arguments
+#'
+#' @name NMF-deprecated
+#' @rdname NMF-deprecated
+NULL
+
+
+
+#' Algorithms and framework for Nonnegative Matrix Factorization (NMF).
+#'
+#' This package provides a framework to perform Non-negative Matrix Factorization (NMF).
+#' It implements a set of already published algorithms and seeding methods, and provides a framework
+#' to test, develop and plug new/custom algorithms.
+#' Most of the built-in algorithms have been optimized in C++, and the main interface function provides
+#' an easy way of performing parallel computations on multicore machines.
+#'
+#' \code{\link{nmf}} Run a given NMF algorithm
+#'
+#' @author Renaud Gaujoux \email{renaud@@cbio.uct.ac.za}
+#' @name NMF-package
+#' @aliases NMF
+#' @docType package
+#' @useDynLib NMF
+#'
+#' @bibliography ~/Documents/articles/library.bib
+#' @references
+#' \url{http://cran.r-project.org/}
+#'
+#' \url{http://nmf.r-forge.project.org}
+#' @keywords package
+#' @seealso \code{\link{nmf}}
+#' @examples
+#' # generate a synthetic dataset with known classes
+#' n <- 50; counts <- c(5, 5, 8);
+#' V <- syntheticNMF(n, counts)
+#'
+#' # perform a 3-rank NMF using the default algorithm
+#' res <- nmf(V, 3)
+#'
+#' basismap(res)
+#' coefmap(res)
+#'
+NA
+
+devnmf <- function(){
+ .LOCAL_PKG_NAME <- 'NMF'
+ requireNamespace('devtools')
+ devtools::load_all(.LOCAL_PKG_NAME)
+ compile_src(.LOCAL_PKG_NAME)
+}
+
+# local config info
+nmfConfig <- mkoptions()
+
+.onLoad <- function(libname, pkgname) {
+
+ # set default number of cores
+ if( pkgmaker::isCHECK() ){
+ options(cores=2)
+ }else{
+ if( nchar(nc <- Sys.getenv('R_PACKAGE_NMF_CORES')) > 0 ){
+ try({
+ nmf.options(cores=as.numeric(nc))
+ })
+ }
+ }
+ # use grid patch?
+ nmf.options(grid.patch = !isFALSE(Sys.getenv_value('R_PACKAGE_NMF_GRID_PATCH')))
+
+ pkgEnv <- pkgmaker::packageEnv()
+ .init.sequence <- function(){
+
+ ## 0. INITIALIZE PACKAGE SPECFIC OPTIONS
+ #.init.nmf.options()
+
+ ## 1. INITIALIZE THE NMF MODELS
+ .init.nmf.models()
+
+ ## 2. INITIALIZE BIOC LAYER
+ b <- body(.onLoad.nmf.bioc)
+ bioc.loaded <- eval(b, envir=pkgEnv)
+ nmfConfig(bioc=bioc.loaded)
+
+ # 3. SHARED MEMORY
+ if( .Platform$OS.type != 'windows' ){
+ msg <- if( !require.quiet('bigmemory', character.only=TRUE) ) 'bigmemory'
+ else if( !require.quiet('synchronicity', character.only=TRUE) ) 'synchronicity'
+ else TRUE
+
+ nmfConfig(shared.memory=msg)
+ }
+ #
+ }
+
+ # run intialization sequence suppressing messages or not depending on verbosity options
+ .init.sequence()
+ if( getOption('verbose') ) .init.sequence()
+ else suppressMessages(.init.sequence())
+
+
+ return(invisible())
+}
+
+.onUnload <- function(libpath) {
+
+ # unload compiled library
+ dlls <- names(base::getLoadedDLLs())
+ if ( 'NMF' %in% dlls )
+ library.dynam.unload("NMF", libpath);
+}
+
+.onAttach <- function(libname, pkgname){
+
+ # build startup message
+ msg <- NULL
+ details <- NULL
+ ## 1. CHECK BIOC LAYER
+ bioc.loaded <- nmfConfig('bioc')[[1L]]
+ msg <- paste0(msg, 'BioConductor layer')
+ if( is(bioc.loaded, 'try-error') ) msg <- paste0(msg, ' [ERROR]')
+ else if ( isTRUE(bioc.loaded) ) msg <- paste0(msg, ' [OK]')
+ else{
+ msg <- paste0(msg, ' [NO: missing Biobase]')
+ details <- c(details, " To enable the Bioconductor layer, try: install.extras('", pkgname, "') [with Bioconductor repository enabled]")
+ }
+
+ # 2. SHARED MEMORY
+ msg <- paste0(msg, ' | Shared memory capabilities')
+ if( .Platform$OS.type != 'windows' ){
+ conf <- nmfConfig('shared.memory')[[1L]]
+ if( isTRUE(conf) ) msg <- paste0(msg, ' [OK]')
+ else{
+ msg <- paste0(msg, ' [NO: ', conf, ']')
+ details <- c(details, " To enable shared memory capabilities, try: install.extras('", pkgname, "')")
+ }
+ }else msg <- paste0(msg, ' [NO: windows]')
+ #
+
+ # 3. NUMBER OF CORES
+ msg <- paste0(msg, ' | Cores ', getMaxCores(), '/', getMaxCores(limit=FALSE))
+ #
+
+ # FINAL. CRAN FLAG
+ if( pkgmaker::isCHECK() ){
+ msg <- paste0(msg, ' | CRAN check')
+ }
+ #
+
+ # print startup message
+ ver <- if( isDevNamespace() ){
+ paste0(' [', utils::packageVersion(pkgname), '-devel', ']')
+ }#else{
+# utils::packageVersion(pkgname, lib.loc = libname)
+# }
+ packageStartupMessage(pkgname, ver, ' - ', msg)
+ if( !is.null(details) ){
+ packageStartupMessage(paste(details, collapse="\n"))
+ }
+}
+
diff --git a/R/nmf.R b/R/nmf.R
new file mode 100644
index 0000000..7515b98
--- /dev/null
+++ b/R/nmf.R
@@ -0,0 +1,2898 @@
+#' @include NMFstd-class.R
+#' @include NMFSet-class.R
+#' @include registry-seed.R
+#' @include registry-algorithms.R
+#' @include parallel.R
+NULL
+
+#' Running NMF algorithms
+#'
+#' @description
+#' The function \code{nmf} is a S4 generic defines the main interface to run NMF
+#' algorithms within the framework defined in package \code{NMF}.
+#' It has many methods that facilitates applying, developing and testing NMF
+#' algorithms.
+#'
+#' The package vignette \code{vignette('NMF')} contains an introduction to the
+#' interface, through a sample data analysis.
+#'
+#' @details
+#'
+#' The \code{nmf} function has multiple methods that compose a very flexible
+#' interface allowing to:
+#' \itemize{
+#' \item combine NMF algorithms with seeding methods and/or stopping/convergence
+#' criterion at runtime;
+#'
+#' \item perform multiple NMF runs, which are computed in parallel whenever the host
+#' machine allows it;
+#'
+#' \item run multiple algorithms with a common set of parameters, ensuring a
+#' consistent environment (notably the RNG settings).
+#' }
+#'
+#' The workhorse method is \code{nmf,matrix,numeric,NMFStrategy}, which is eventually
+#' called by all other methods.
+#' The other methods provides convenient ways of specifying the NMF algorithm(s),
+#' the factorization rank, or the seed to be used.
+#' Some allow to directly run NMF algorithms on different types of objects, such
+#' as \code{data.frame} or \code{\link[Biobase]{ExpressionSet}} objects.
+#'
+#' @section Optimized C++ vs. plain R:
+#' Lee and Seung's multiplicative updates are used by several NMF algorithms. To improve
+#' speed and memory usage, a C++ implementation of the specific matrix products is used
+#' whenever possible. It directly computes the updates for each entry in the updated matrix,
+#' instead of using multiple standard matrix multiplication.
+#'
+#' The algorithms that benefit from this optimization are: 'brunet', 'lee', 'nsNMF' and 'offset'. % and 'lnmf'
+#' However there still exists plain R versions for these methods, which implement the updates
+#' as standard matrix products. These are accessible by adding the prefix '.R#' to their name:
+#' '.R#brunet', '.R#lee', '.R#nsNMF' and '.R#offset'.
+#'
+#' @param x target data to fit, i.e. a matrix-like object
+#' @param rank specification of the factorization rank.
+#' It is usually a single numeric value, but other type of values are possible
+#' (e.g. matrix), for which specific methods are implemented.
+#' See for example methods \code{nmf,matrix,matrix,ANY}.
+#'
+#' If \code{rank} is a numeric vector with more than one element, e.g. a range of ranks,
+#' then \code{\link{nmf}} performs the estimation procedure described in
+#' \code{\link{nmfEstimateRank}}.
+#'
+#' @param method specification of the NMF algorithm.
+#' The most common way of specifying the algorithm is to pass the access key
+#' (i.e. a character string) of an algorithm stored in the package's dedicated registry,
+#' but methods exists that handle other types of values, such as \code{function} or \code{list}
+#' object. See their descriptions in section \emph{Methods}.
+#'
+#' If \code{method} is missing the algorithm to use is obtained from the option
+#' \code{nmf.getOption('default.algorithm')}, unless it can be infer from the type of NMF model
+#' to fit, if this later is available from other arguments.
+#' Factory fresh default value is \sQuote{brunet}, which corresponds to the standard NMF
+#' algorithm from \cite{Brunet2004} (see section \emph{Algorithms}).
+#'
+#' Cases where the algorithm is inferred from the call are when an NMF model is passed in arguments \code{rank}
+#' or \code{seed} (see description for \code{nmf,matrix,numeric,NULL} in section \emph{Methods}).
+#'
+#' @param ... extra arguments to allow extension of the generic.
+#' Arguments that are not used in the chain of internal calls to \code{nmf} methods
+#' are passed to the function that effectively implements the algorithm that fits
+#' an NMF model on \code{x}.
+#'
+#' @export
+#' @inline
+#'
+#' @examples
+#'
+#' # Only basic calls are presented in this manpage.
+#' # Many more examples are provided in the demo file nmf.R
+#' \dontrun{
+#' demo('nmf')
+#' }
+#'
+#' # random data
+#' x <- rmatrix(20,10)
+#'
+#' # run default algorithm with rank 2
+#' res <- nmf(x, 2)
+#'
+#' # specify the algorithm
+#' res <- nmf(x, 2, 'lee')
+#'
+#' # get verbose message on what is going on
+#' res <- nmf(x, 2, .options='v')
+#' \dontrun{
+#' # more messages
+#' res <- nmf(x, 2, .options='v2')
+#' # even more
+#' res <- nmf(x, 2, .options='v3')
+#' # and so on ...
+#' }
+#'
+#' @demo Using the main function nmf()
+#'
+#' # generate a synthetic dataset with known classes: 50 features, 23 samples (10+5+8)
+#' n <- 20; counts <- c(5, 3, 2);
+#' p <- sum(counts)
+#' x <- syntheticNMF(n, counts)
+#' dim(x)
+#'
+#' # build the true cluster membership
+#' groups <- unlist(mapply(rep, seq(counts), counts))
+#'
+setGeneric('nmf', function(x, rank, method, ...) standardGeneric('nmf') )
+#' Fits an NMF model on a \code{data.frame}.
+#'
+#' The target \code{data.frame} is coerced into a matrix with \code{\link{as.matrix}}.
+#'
+#' @demo
+#'
+#' # run on a data.frame
+#' res <- nmf(data.frame(x), 3)
+#'
+setMethod('nmf', signature(x='data.frame', rank='ANY', method='ANY'),
+ function(x, rank, method, ...)
+ {
+ # replace missing values by NULL values for correct dispatch
+ if( missing(method) ) method <- NULL
+ if( missing(rank) ) rank <- NULL
+
+ # apply NMF to the the data.frame converted into a matrix
+ nmf(as.matrix(x), rank, method, ...)
+ }
+)
+#' Fits an NMF model using an appropriate algorithm when \code{method} is not supplied.
+#'
+#' This method tries to select an appropriate algorithm amongst the NMF algorithms
+#' stored in the internal algorithm registry, which contains the type of NMF models
+#' each algorithm can fit.
+#' This is possible when the type of NMF model to fit is available from argument \code{seed},
+#' i.e. if it is an NMF model itself.
+#' Otherwise the algorithm to use is obtained from \code{nmf.getOption('default.algorithm')}.
+#'
+#' This method is provided for internal usage, when called from other \code{nmf} methods
+#' with argument \code{method} missing in the top call (e.g. \code{nmf,matrix,numeric,missing}).
+#'
+#' @demo
+#'
+#' # missing method: use algorithm suitable for seed
+#' res <- nmf(x, 2, seed=rnmf(2, x))
+#' algorithm(res)
+#' res <- nmf(x, 2, seed=rnmf(2, x, model='NMFns'))
+#' algorithm(res)
+#'
+setMethod('nmf', signature(x='matrix', rank='numeric', method='NULL'),
+ function(x, rank, method, seed=NULL, model=NULL, ...)
+ {
+
+ # a priori the default method will be used
+ method <- nmf.getOption('default.algorithm')
+
+ # use default seeding method if seed is missing
+ if( is.null(seed) ){
+# seed <- nmf.getOption('default.seed')
+ }else{
+ # get reference object from which to infer model type
+ refobj <- if( is.nmf(seed) ) seed else if( is.nmf(model) ) model
+
+ if( !is.null(refobj) ){
+ mtype <- modelname(refobj)
+ # try to find the algorithm suitable for the seed's NMF model
+ method.potential <- selectNMFMethod(model=mtype, exact=TRUE, quiet=TRUE)
+ if( is.null(method.potential) )
+ stop("NMF::nmf - Found no algorithm defined for model '", mtype, "'")
+
+ if( length(method.potential) == 1 ) # only one to choose
+ method <- method.potential
+ else if( !is.element(method, method.potential) ){# several options, none is default
+ method <- method.potential[1]
+ warning("NMF::nmf - Selected algorithm '", method, "' to fit model '", mtype, "'."
+ , "\n Alternatives are: "
+ , str_out(method.potential[-1], Inf)
+ , call.=FALSE, immediate.=TRUE)
+ }
+ }
+ }
+
+ nmf(x, rank, method, seed=seed, model=model, ...)
+ }
+)
+
+
+#' Fits multiple NMF models on a common matrix using a list of algorithms.
+#'
+#' The models are fitted sequentially with \code{nmf} using the same options
+#' and parameters for all algorithms.
+#' In particular, irrespective of the way the computation is seeded, this method
+#' ensures that all fits are performed using the same initial RNG settings.
+#'
+#' This method returns an object of class \code{\linkS4class{NMFList}}, that is
+#' essentially a list containing each fit.
+#'
+#' @param .parameters list of method-specific parameters.
+#' Its elements must have names matching a single method listed in \code{method},
+#' and be lists of named values that are passed to the corresponding method.
+#'
+#' @demo
+#' # compare some NMF algorithms (tracking the approximation error)
+#' res <- nmf(x, 2, list('brunet', 'lee', 'nsNMF'), .options='t')
+#' res
+#' summary(res, class=groups)
+#'
+#' # plot the track of the residual errors
+#' plot(res)
+#'
+setMethod('nmf', signature(x='matrix', rank='numeric', method='list'),
+ function(x, rank, method, ..., .parameters = list())
+ {
+ # apply each NMF algorithm
+ k <- 0
+ n <- length(method)
+
+ # setup/check method specific parameters
+ ARGS <- NULL
+ .used.parameters <- character()
+ if( !is.list(.parameters) )
+ stop("NMF::nmf - Invalid value for argument `.parameters`: must be a named list.")
+ if( length(.parameters) && (is.null(names(.parameters)) || any(names(.parameters) == '')) )
+ stop("NMF::nmf - Invalid value for argument `.parameters`: all elements must be named.")
+
+ t <- system.time({
+ res <- lapply(method,
+ function(meth, ...){
+ k <<- k+1
+ methname <- if( isString(meth) ) meth else name(meth)
+ cat("Compute NMF method '", methname, "' [", k, "/", n, "] ... ", sep='')
+ # restore RNG on exit (except after last method)
+ # => this ensures the methods use the same stochastic environment
+ orng <- RNGseed()
+ if( k < n ) on.exit( RNGseed(orng), add = TRUE)
+
+ # look for method-specific arguments
+ i.param <- 0L
+ if( length(.parameters) ){
+ i.param <- charmatch(names(.parameters), methname)
+ if( !length(i.param <- seq_along(.parameters)[!is.na(i.param)]) )
+ i.param <- 0L
+ else if( length(i.param) > 1L ){
+ stop("Method name '", methname, "' matches multiple method-specific parameters "
+ , "[", str_out(names(.parameters)[i.param], Inf), "]")
+ }
+ }
+ #o <- capture.output(
+ if( !i.param ){
+ res <- try( nmf(x, rank, meth, ...) , silent=TRUE)
+ }else{
+ if( is.null(ARGS) ) ARGS <<- list(x, rank, ...)
+ .used.parameters <<- c(.used.parameters, names(.parameters)[i.param])
+ res <- try( do.call(nmf, c(ARGS, method = meth, .parameters[[i.param]]))
+ , silent=TRUE)
+ }
+ #)
+ if( is(res, 'try-error') )
+ cat("ERROR\n")
+ else
+ cat("OK\n")
+ return(res)
+ }
+ , ...)
+ })
+
+ # filter out bad results
+ ok <- sapply(res, function(x){
+ if( is(x, 'NMF.rank') ) all(sapply(x$fit, isNMFfit))
+ else isNMFfit(x)
+ })
+ if( any(!ok) ){ # throw warning if some methods raised an error
+ err <- lapply(which(!ok), function(i){ paste("'", method[[i]],"': ", res[[i]], sep='')})
+ warning("NMF::nmf - Incomplete results due to ", sum(!ok), " errors: \n- ", paste(err, collapse="- "), call.=FALSE)
+ }
+ res <- res[ok]
+ # TODO error if ok is empty
+
+ # not-used parameters
+ if( length(.used.parameters) != length(.parameters) ){
+ warning("NMF::nmf - Did not use methods-specific parameters ", str_out(setdiff(names(.parameters), .used.parameters), Inf))
+ }
+
+ # add names to the result list
+ names(res) <- sapply(res, function(x){
+ if( is(x, 'NMF.rank') ) x <- x$fit[[1]]
+ algorithm(x)
+ })
+
+ # return list as is if surveying multiple ranks
+ if( length(rank) > 1 ) return(res)
+
+ # wrap the result in a NMFList object
+ # DO NOT WRAP anymore here: NMFfitX objects are used only for results of multiple runs (single method)
+ # the user can still join on the result if he wants to
+ #res <- join(res, runtime=t)
+ res <- new('NMFList', res, runtime=t)
+
+ # return result
+ return(res)
+ }
+)
+#' Fits an NMF model on \code{x} using an algorithm registered with access key
+#' \code{method}.
+#'
+#' Argument \code{method} is partially match against the access keys of all
+#' registered algorithms (case insensitive).
+#' Available algorithms are listed in section \emph{Algorithms} below or the
+#' introduction vignette.
+#' A vector of their names may be retrieved via \code{nmfAlgorithm()}.
+#'
+#' @section Algorithms:
+#' All algorithms are accessible by their respective access key as listed below.
+#' The following algorithms are available:
+#' \describe{
+#'
+#' \item{\sQuote{brunet}}{ Standard NMF, based on the Kullback-Leibler divergence,
+#' from \cite{Brunet2004}.
+#' It uses simple multiplicative updates from \cite{Lee2001}, enhanced to avoid
+#' numerical underflow.
+#'
+#' Default stopping criterion: invariance of the connectivity matrix
+#' (see \code{\link{nmf.stop.connectivity}}).
+#' }
+#'
+#' \item{\sQuote{lee}}{ Standard NMF based on the Euclidean distance from \cite{Lee2001}.
+#' It uses simple multiplicative updates.
+#'
+#' Default stopping criterion: invariance of the connectivity matrix
+#' (see \code{\link{nmf.stop.connectivity}}).
+#' }
+#'
+#' \item{ls-nmf}{ Least-Square NMF from \cite{Wang2006}.
+#' It uses modified versions of Lee and Seung's multiplicative updates for the
+#' Euclidean distance, which incorporates weights on each entry of the target
+#' matrix, e.g. to reflect measurement uncertainty.
+#'
+#' Default stopping criterion: stationarity of the objective function
+#' (see \code{\link{nmf.stop.stationary}}).
+#' }
+#'
+#' \item{\sQuote{nsNMF}}{ Nonsmooth NMF from \cite{Pascual-Montano2006}.
+#' It uses a modified version of Lee and Seung's multiplicative updates for the
+#' Kullback-Leibler divergence \cite{Lee2001}, to fit a extension of the standard
+#' NMF model, that includes an intermediate smoothing matrix, meant meant to produce
+#' sparser factors.
+#'
+#' Default stopping criterion: invariance of the connectivity matrix
+#' (see \code{\link{nmf.stop.connectivity}}).
+#' }
+#'
+#' \item{\sQuote{offset}}{ NMF with offset from \cite{Badea2008}.
+#' It uses a modified version of Lee and Seung's multiplicative
+#' updates for Euclidean distance \cite{Lee2001}, to fit an NMF model that includes
+#' an intercept, meant to capture a common baseline and shared patterns, in
+#' order to produce cleaner basis components.
+#'
+#' Default stopping criterion: invariance of the connectivity matrix
+#' (see \code{\link{nmf.stop.connectivity}}).
+#' }
+#'
+#' \item{\sQuote{pe-nmf}}{ Pattern-Expression NMF from \emph{Zhang2008}.
+#' It uses multiplicative updates to minimize an objective function based on the
+#' Euclidean distance, that is regularized for effective expression of patterns
+#' with basis vectors.
+#'
+#' Default stopping criterion: stationarity of the objective function
+#' (see \code{\link{nmf.stop.stationary}}).
+#' }
+#'
+#' \item{\sQuote{snmf/r}, \sQuote{snmf/l}}{ Alternating Least Square (ALS) approach
+#' from \cite{KimH2007}.
+#' It applies the nonnegative least-squares algorithm from \cite{VanBenthem2004}
+#' (i.e. fast combinatorial nonnegative least-squares for multiple right-hand),
+#' to estimate the basis and coefficient matrices alternatively
+#' (see \code{\link{fcnnls}}).
+#' It minimises an Euclidean-based objective function, that is regularized to
+#' favour sparse basis matrices (for \sQuote{snmf/l}) or sparse coefficient matrices
+#' (for \sQuote{snmf/r}).
+#'
+#' Stopping criterion: built-in within the internal workhorse function \code{nmf_snmf},
+#' based on the KKT optimality conditions.
+#' }
+#'
+#' }
+#'
+#' @section Seeding methods:
+#' The purpose of seeding methods is to compute initial values for the factor
+#' matrices in a given NMF model.
+#' This initial guess will be used as a starting point by the chosen NMF algorithm.
+#'
+#' The seeding method to use in combination with the algorithm can be passed
+#' to interface \code{nmf} through argument \code{seed}.
+#' The seeding seeding methods available in registry are listed by the function
+#' \code{\link{nmfSeed}} (see list therein).
+#'
+#' Detailed examples of how to specify the seeding method and its parameters can
+#' be found in the \emph{Examples} section of this man page and in the package's
+#' vignette.
+#'
+#' @seealso \code{\link{nmfAlgorithm}}
+#'
+#' @demo
+#'
+#' # specify algorithm by its name
+#' res <- nmf(x, 3, 'nsNMF', seed=123) # nonsmooth NMF
+#' # names are partially matched so this also works
+#' identical(res, nmf(x, 3, 'ns', seed=123))
+#'
+#' res <- nmf(x, 3, 'offset') # NMF with offset
+#'
+#'
+setMethod('nmf', signature(x='matrix', rank='numeric', method='character'),
+function(x, rank, method, ...)
+{
+ # if there is more than one methods then treat the vector as a list
+ if( length(method) > 1 ){
+ return( nmf(x, rank, as.list(method), ...) )
+ }
+
+ # create the NMFStrategy from its name
+ strategy <- nmfAlgorithm(method)
+ # apply nmf using the retrieved strategy
+ nmf(x, rank, method=strategy, ...)
+}
+)
+#' Fits an NMF model on \code{x} using a custom algorithm defined the function
+#' \code{method}.
+#'
+#' The supplied function must have signature \code{(x=matrix, start=NMF, ...)}
+#' and return an object that inherits from class \code{\linkS4class{NMF}}.
+#' It will be called internally by the workhorse \code{nmf} method, with an NMF model
+#' to be used as a starting point passed in its argument \code{start}.
+#'
+#' Extra arguments in \code{...} are passed to \code{method} from the top
+#' \code{nmf} call.
+#' Extra arguments that have no default value in the definition of the function
+#' \code{method} are required to run the algorithm (e.g. see argument \code{alpha}
+#' of \code{myfun} in the examples).
+#'
+#' If the algorithm requires a specific type of NMF model, this can be specified
+#' in argument \code{model} that is handled as in the workhorse \code{nmf}
+#' method (see description for this argument).
+#'
+#' @param name name associated with the NMF algorithm implemented by the function
+#' \code{method} [only used when \code{method} is a function].
+#' @param objective specification of the objective function associated with the
+#' algorithm implemented by the function \code{method}
+#' [only used when \code{method} is a function].
+#'
+#' It may be either \code{'euclidean'} or \code{'KL'} for specifying the euclidean
+#' distance (Frobenius norm) or the Kullback-Leibler divergence respectively,
+#' or a function with signature \code{(x="NMF", y="matrix", ...)} that computes
+#' the objective value for an NMF model \code{x} on a target matrix \code{y},
+#' i.e. the residuals between the target matrix and its NMF estimate.
+#' Any extra argument may be specified, e.g. \code{function(x, y, alpha, beta=2, ...)}.
+#'
+#' @param mixed a logical that indicates if the algorithm implemented by the function
+#' \code{method} support mixed-sign target matrices, i.e. that may contain negative
+#' values [only used when \code{method} is a function].
+#'
+#' @demo
+#'
+#' # run a custom algorithm defined as a standard function
+#' myfun <- function(x, start, alpha){
+#' # update starting point
+#' # ...
+#' basis(start) <- 3 * basis(start)
+#' # return updated point
+#' start
+#' }
+#'
+#' res <- nmf(x, 2, myfun, alpha=3)
+#' algorithm(res)
+#' # error: alpha missing
+#' try( nmf(x, 2, myfun) )
+#'
+#' # possibly the algorithm fits a non-standard NMF model, e.g. NMFns model
+#' res <- nmf(x, 2, myfun, alpha=3, model='NMFns')
+#' modelname(res)
+#'
+setMethod('nmf', signature(x='matrix', rank='numeric', method='function'),
+ function(x, rank, method, seed, model='NMFstd', ..., name, objective='euclidean', mixed=FALSE){
+
+ model_was_a_list <- is.list(model)
+ if( is.character(model) )
+ model <- list(model=model)
+ if( !is.list(model) ){
+ stop("nmf - Invalid argument `model`: must be NULL or a named list of initial values for slots in an NMF model.")
+ }
+
+
+ # arguments passed to the call to NMFStrategyFunction
+ strat <- list('NMFStrategyFunction'
+ , algorithm = method
+ , objective = objective
+ , mixed = mixed[1]
+ )
+
+ ## Determine type of NMF model associated with the NMFStrategy
+ # All elements of `model` (except the model class) will be passed to
+ # argument `model` of the workhorse `nmf` method, which will use them
+ # to create the NMF model in a call to `nmfModel`
+ if( length(model) > 0L ){
+ if( !is.null(model$model) ){
+ strat$model <- model$model
+ model$model <- NULL
+ }else if( isNMFclass(model[[1]]) ){
+ strat$model <- model[[1]]
+ # use the remaining elements to instanciate the NMF model
+ model <- model[-1]
+ }
+ # all elements must be named
+ if( !hasNames(model, all=TRUE) ){
+ stop("NMF::nmf - Invalid argument `model`: all elements must be named, except the first one which must then be an NMF model class name")
+ }
+ }
+ ##
+
+ # if name is missing: generate a temporary unique name
+ if( missing(name) ) name <- basename(tempfile("nmf_"))
+ # check that the name is not a registered name
+ if( existsNMFMethod(name) )
+ stop("Invalid name for custom NMF algorithm: '",name,"' is already a registered NMF algorithm")
+ strat$name <- name
+
+ # create NMFStrategy
+ strategy <- do.call('new', strat)
+ # full validation of the strategy
+ validObject(strategy, complete=TRUE)
+
+ if( missing(seed) ) seed <- NULL
+ if( !model_was_a_list && length(model) == 0L ) model <- NULL
+ # call method 'nmf' with the new object
+ nmf(x, rank, strategy, seed=seed, model=model, ...)
+ }
+)
+
+#' Fits an NMF model using the NMF model \code{rank} to seed the computation,
+#' i.e. as a starting point.
+#'
+#' This method is provided for convenience as a shortcut for
+#' \code{nmf(x, nbasis(object), method, seed=object, ...)}
+#' It discards any value passed in argument \code{seed} and uses the NMF model passed
+#' in \code{rank} instead.
+#' It throws a warning if argument \code{seed} not missing.
+#'
+#' If \code{method} is missing, this method will call the method
+#' \code{nmf,matrix,numeric,NULL}, which will infer an algorithm suitable for fitting an
+#' NMF model of the class of \code{rank}.
+#'
+#' @demo
+#'
+#' # assume a known NMF model compatible with the matrix `x`
+#' y <- rnmf(3, x)
+#' # fits an NMF model (with default method) on some data using y as a starting point
+#' res <- nmf(x, y)
+#' # the fit can be reproduced using the same starting point
+#' nmf.equal(nmf(x, y), res)
+#'
+setMethod('nmf', signature(x='matrix', rank='NMF', method='ANY'),
+ function(x, rank, method, seed, ...){
+
+ if( !missing(seed) ){
+ if( isNumber(seed) ){
+ set.seed(seed)
+ }else if( !is.null(seed) ){
+ warning("NMF::nmf - Discarding value of argument `seed`: directly using NMF model supplied in `rank` instead.\n"
+ , " If seeding is necessary, please use argument `model` pass initial model slots, which will be filled by the seeding method.")
+ }
+# # pass the model via a one-off global variable
+# .nmf_InitModel(rank)
+ }
+
+ # replace missing method by NULL for correct dispatch
+ if( missing(method) ) method <- NULL
+
+ nmf(x, nbasis(rank), method, seed=rank, ...)
+ }
+)
+.nmf_InitModel <- oneoffVariable()
+
+#' Fits an NMF model using the NMF model supplied in \code{seed}, to seed the computation,
+#' i.e. as a starting point.
+#'
+#' This method is provided for completeness and is equivalent to
+#' \code{nmf(x, seed, method, ...)}.
+#'
+setMethod('nmf', signature(x='matrix', rank='NULL', method='ANY'),
+ function(x, rank, method, seed, ...){
+
+ if( missing(seed) || !is.nmf(seed) )
+ stop("NMF::nmf - Argument `seed` must be an NMF model when argument `rank` is missing.")
+
+ # replace missing method by NULL for correct dispatch
+ if( missing(method) ) method <- NULL
+
+ nmf(x, nbasis(seed), method, seed=seed, ...)
+ }
+)
+#' Method defined to ensure the correct dispatch to workhorse methods in case
+#' of argument \code{rank} is missing.
+setMethod('nmf', signature(x='matrix', rank='missing', method='ANY'),
+ function(x, rank, method, ...){
+ # replace missing method by NULL for correct dispatch
+ if( missing(method) ) method <- NULL
+ nmf(x, NULL, method, ...)
+ }
+)
+#' Method defined to ensure the correct dispatch to workhorse methods in case
+#' of argument \code{method} is missing.
+#'
+#' @demo
+#' # missing method: use default algorithm
+#' res <- nmf(x, 3)
+#'
+setMethod('nmf', signature(x='matrix', rank='numeric', method='missing'),
+ function(x, rank, method, ...){
+ nmf(x, rank, NULL, ...)
+ }
+)
+#' Fits an NMF model partially seeding the computation with a given matrix passed
+#' in \code{rank}.
+#'
+#' The matrix \code{rank} is used either as initial value for the basis or mixture
+#' coefficient matrix, depending on its dimension.
+#'
+#' Currently, such partial NMF model is directly used as a seed, meaning that
+#' the remaining part is left uninitialised, which is not accepted by all NMF algorithm.
+#' This should change in the future, where the missing part of the model will be
+#' drawn from some random distribution.
+#'
+#' Amongst built-in algorithms, only \sQuote{snmf/l} and \sQuote{snmf/r} support
+#' partial seeds, with only the coefficient or basis matrix initialised
+#' respectively.
+#'
+#' @demo
+#'
+#' # Fit a 3-rank model providing an initial value for the basis matrix
+#' nmf(x, rmatrix(nrow(x), 3), 'snmf/r')
+#'
+#' # Fit a 3-rank model providing an initial value for the mixture coefficient matrix
+#' nmf(x, rmatrix(3, ncol(x)), 'snmf/l')
+#'
+setMethod('nmf', signature(x='matrix', rank='matrix', method='ANY'),
+ function(x, rank, method, seed, model=list(), ...)
+ {
+ if( is.character(model) )
+ model <- list(model=model)
+ if( !is.list(model) )
+ stop("nmf - Invalid argument `model`: must be NULL or a named list of initial values for slots in an NMF object.")
+ if( !hasNames(model, all=TRUE) )
+ stop("nmf - Invalid argument `model`: all elements must be named")
+
+ # remove rank specification if necessary
+ if( !is.null(model$rank) ){
+ warning("nmf - Discarding rank specification in argument `model`: use value inferred from matrix supplied in argument `rank`")
+ model$rank <- NULL
+ }
+ # check compatibility of dimensions
+ newseed <-
+ if( nrow(rank) == nrow(x) ){
+ # rank is the initial value for the basis vectors
+ if( length(model)==0L ) nmfModel(W=rank)
+ else{
+ model$W <- rank
+ do.call('nmfModel', model)
+ }
+ }else if( ncol(rank) == ncol(x) ){
+ # rank is the initial value for the mixture coefficients
+ if( length(model)==0L ) nmfModel(H=rank)
+ else{
+ model$H <- rank
+ do.call('nmfModel', model)
+ }
+ }else
+ stop("nmf - Invalid argument `rank`: matrix dimensions [",str_out(dim(x),sep=' x '),"]"
+ , " are incompatible with the target matrix [", str_out(dim(x),sep=' x '),"].\n"
+ , " When `rank` is a matrix it must have the same number of rows or columns as the target matrix `x`.")
+
+ # replace missing values by NULL values for correct dispatch
+ if( missing(method) ) method <- NULL
+ if( missing(seed) ) seed <- NULL
+ #nmf(x, nbasis(newseed), method, seed=seed, model=newseed, ...)
+ nmf(x, newseed, method, seed=seed, ...)
+ }
+)
+#' Shortcut for \code{nmf(x, as.matrix(rank), method, ...)}.
+setMethod('nmf', signature(x='matrix', rank='data.frame', method='ANY'),
+ function(x, rank, method, ...){
+ # replace missing values by NULL values for correct dispatch
+ if( missing(method) ) method <- NULL
+
+ nmf(x, as.matrix(rank), method, ...)
+ }
+)
+
+#' This method implements the interface for fitting formula-based NMF models.
+#' See \code{\link{nmfModel}}.
+#'
+#' Argument \code{rank} target matrix or formula environment.
+#' If not missing, \code{model} must be a \code{list}, a \code{data.frame} or
+#' an \code{environment} in which formula variables are searched for.
+#'
+setMethod('nmf', signature(x='formula', rank='ANY', method='ANY'),
+ function(x, rank, method, ..., model=NULL){
+ # replace missing values by NULL values for correct dispatch
+ if( missing(method) ) method <- NULL
+ if( missing(rank) ) rank <- NULL
+
+ # if multiple numeric rank: use nmfRestimateRank
+ if( is.vector(rank) && is.numeric(rank) ){
+ if( length(rank) > 1L ){
+ return( nmfEstimateRank(x, rank, method, ..., model=model) )
+ }
+ }
+
+ # build formula based model
+ model <- nmfModel(x, rank, data=model)
+ nmf(attr(model, 'target'), nbasis(model), method, ..., model=model)
+ }
+)
+
+.as.numeric <- function(x){
+ suppressWarnings( as.numeric(x) )
+}
+
+.translate.string <- function(string, dict){
+
+ res <- list()
+ dict <- as.list(dict)
+ if( nchar(string) == 0 ) return(res)
+ opt.val <- TRUE
+ last.key <- NULL
+ buffer <- ''
+ lapply(strsplit(string, '')[[1]],
+ function(c){
+ if( c=='-' ) opt.val <<- FALSE
+ else if( c=='+' ) opt.val <<- TRUE
+ else if( opt.val && !is.na(.as.numeric(c)) )
+ buffer <<- paste(buffer, c, sep='')
+ else if( !is.null(dict[[c]]) ){
+ # flush the buffer into the last key if necessary
+ if( nchar(buffer) > 0 && !is.null(last.key) && !is.na(buffer <- .as.numeric(buffer)) ){
+ res[[dict[[last.key]]]] <<- buffer
+ buffer <<- ''
+ }
+
+ res[[dict[[c]]]] <<- opt.val
+ last.key <<- c
+ }
+ }
+ )
+
+ # flush the buffer into the last key
+ if( nchar(buffer) > 0 && !is.null(last.key) && !is.na(buffer <- .as.numeric(buffer)) )
+ res[[dict[[last.key]]]] <- buffer
+
+ # return result
+ return(res)
+}
+
+#' Error Checks in NMF Runs
+#'
+#' Auxiliary function for internal error checks in nmf results.
+#'
+#' @param object a list of lists
+#' @param element name of an element of the inner lists
+#'
+#' @keywords internal
+checkErrors <- function(object, element=NULL){
+
+ # extract error messages
+ errors <-
+ if( is.null(element) ){
+ lapply(seq_along(object), function(i){
+ x <- object[[i]]
+ if( is(x, 'error') ) c(i, x)
+ else NA
+ })
+ }else{
+ lapply(seq_along(object), function(i){
+ x <- object[[i]][[element, exact=TRUE]]
+ if( is(x, 'error') ) c(i, x)
+ else NA
+ })
+ }
+ errors <- errors[!is.na(errors)]
+ nerrors <- length(errors)
+ res <- list(n = nerrors)
+
+ # format messages
+ if( nerrors ){
+ ierrors <- sapply(errors, '[[', 1L)
+ msg <- sapply(errors, '[[', 2L)
+ ierrors_unique <- ierrors[!duplicated(msg)]
+ res$msg <- str_c(" - ", str_c("run #", ierrors_unique, ': ', msg[ierrors_unique], collapse="\n - "))
+ }
+
+ # return error data
+ res
+}
+
+###% Performs NMF on a matrix using a given NMF method.
+###%
+###% This method is the entry point for NMF. It is eventually called by any definition of the \code{nmf} function.
+
+#' @param seed specification of the starting point or seeding method, which will
+#' compute a starting point, usually using data from the target matrix in order to
+#' provide a good guess.
+#'
+#' The seeding method may be specified in the following way:
+#'
+#' \describe{
+#'
+#' \item{a \code{character} string:}{ giving the name of a \emph{registered}
+#' seeding method. The corresponding method will be called to compute
+#' the starting point.
+#'
+#' Available methods can be listed via \code{nmfSeed()}.
+#' See its dedicated documentation for details on each available registered methods
+#' (\code{\link{nmfSeed}}).
+#' }
+#'
+#' \item{a \code{list}:}{ giving the name of a \emph{registered}
+#' seeding method and, optionally, extra parameters to pass to it.}
+#'
+#' \item{a single \code{numeric}:}{ that is used to seed the random number
+#' generator, before generating a random starting point.
+#'
+#' Note that when performing multiple runs, the L'Ecuyer's RNG is used in order to
+#' produce a sequence of random streams, that is used in way that ensures
+#' that parallel computation are fully reproducible.
+#' }
+#'
+#' \item{an object that inherits from \code{\linkS4class{NMF}}:}{ it should
+#' contain the data of an initialised NMF model, i.e. it must contain valid
+#' basis and mixture coefficient matrices, directly usable by the algorithm's
+#' workhorse function.}
+#'
+#' \item{a \code{function}:}{ that computes the starting point. It must have
+#' signature \code{(object="NMF", target="matrix", ...)} and return an object that
+#' inherits from class \code{NMF}.
+#' It is recommended to use argument \code{object} as a template for the returned object,
+#' by only updating the basis and coefficient matrices, using \code{\link{basis<-}} and
+#' \code{\link{coef<-}} respectively.
+#' }
+#'
+#' }
+#'
+#' @param rng rng specification for the run(s).
+#' This argument should be used to set the the RNG seed, while still specifying the seeding
+#' method argument \var{seed}.
+#'
+#' @param model specification of the type of NMF model to use.
+#'
+#' It is used to instantiate the object that inherits from class \code{\linkS4class{NMF}},
+#' that will be passed to the seeding method.
+#' The following values are supported:
+#' \itemize{
+#'
+#' \item \code{NULL}, the default model associated to the NMF algorithm is
+#' instantiated and \code{...} is looked-up for arguments with names that
+#' correspond to slots in the model class, which are passed to the function
+#' \code{\link{nmfModel}} to instantiate the model.
+#' Arguments in \code{...} that do not correspond to slots are passed to the
+#' algorithm.
+#'
+#' \item a single \code{character} string, that is the name of the NMF model
+#' class to be instantiate.
+#' In this case, arguments in \code{...} are handled in the same way as
+#' when \code{model} is \code{NULL}.
+#'
+#' \item a \code{list} that contains named values that are passed to the
+#' function \code{\link{nmfModel}} to instantiate the model.
+#' In this case, \code{...} is not looked-up at all, and passed entirely to
+#' the algorithm.
+#' This means that all necessary model parameters must be specified in
+#' \code{model}.
+#'
+#' }
+#'
+#' \strong{Argument/slot conflicts:}
+#' In the case a parameter of the algorithm has the same name as a model slot,
+#' then \code{model} MUST be a list -- possibly empty --, if one wants this
+#' parameter to be effectively passed to the algorithm.
+#'
+#' If a variable appears in both arguments \code{model} and \code{\dots},
+#' the former will be used to initialise the NMF model, the latter will be
+#' passed to the NMF algorithm.
+#' See code examples for an illustration of this situation.
+#'
+#' @param nrun number of runs to perform.
+#' It specifies the number of runs to perform.
+#' By default only one run is performed, except if \code{rank} is a numeric vector
+#' with more than one element, in which case a default of 30 runs per value of the
+#' rank are performed, allowing the computation of a consensus matrix that is used
+#' in selecting the appropriate rank (see \code{\link{consensus}}).
+#'
+#' When using a random seeding method, multiple runs are generally required to
+#' achieve stability and avoid \emph{bad} local minima.
+#'
+#' @param .options this argument is used to set runtime options.
+#'
+#' It can be a \code{list} containing named options with their values, or, in
+#' the case only boolean/integer options need to be set, a character string
+#' that specifies which options are turned on/off or their value, in a unix-like
+#' command line argument way.
+#'
+#' The string must be composed of characters that correspond to a given option
+#' (see mapping below), and modifiers '+' and '-' that toggle options on and off respectively.
+#' E.g. \code{.options='tv'} will toggle on options \code{track} and \code{verbose},
+#' while \code{.options='t-v'} will toggle on option \code{track} and toggle off
+#' option \code{verbose}.
+#'
+#' Modifiers '+' and '-' apply to all option character found after them:
+#' \code{t-vp+k} means \code{track=TRUE}, \code{verbose=parallel=FALSE},
+#' and \code{keep.all=TRUE}.
+#' The default behaviour is to assume that \code{.options} starts with a '+'.
+#'
+#' for options that accept integer values, the value may be appended to the
+#' option's character e.g. \code{'p4'} for asking for 4 processors or \code{'v3'}
+#' for showing verbosity message up to level 3.
+#'
+#' The following options are available (the characters after \dQuote{-} are those
+#' to use to encode \code{.options} as a string):
+#' \describe{
+#'
+#' \item{debug - d}{ Toggle debug mode (default: \code{FALSE}).
+#' Like option \code{verbose} but with more information displayed.}
+#'
+#' \item{keep.all - k}{ used when performing multiple runs (\code{nrun}>1): if
+#' \code{TRUE}, all factorizations are saved and returned (default: \code{FALSE}).
+#' Otherwise only the factorization achieving the minimum residuals is returned.}
+#'
+#' \item{parallel - p}{ this option is useful on multicore *nix or Mac machine
+#' only, when performing multiple runs (\code{nrun} > 1) (default: \code{TRUE}).
+#' If \code{TRUE}, the runs are performed using the parallel foreach backend
+#' defined in argument \code{.pbackend}.
+#' If this is set to \code{'mc'} or \code{'par'} then \code{nmf} tries to
+#' perform the runs using multiple cores with package
+#' \code{link[doParallel]{doParallel}} -- which therefore needs to be installed.
+#'
+#' If equal to an integer, then \code{nmf} tries to perform the computation on
+#' the specified number of processors.
+#' When passing options as a string the number is appended to the option's character
+#' e.g. \code{'p4'} for asking for 4 processors.
+#'
+#' If \code{FALSE}, then the computation is performed sequentially using the base
+#' function \code{\link{sapply}}.
+#'
+#' Unlike option 'P' (capital 'P'), if the computation cannot be performed in
+#' parallel, then it will still be carried on sequentially.
+#'
+#' \strong{IMPORTANT NOTE FOR MAC OS X USERS:} The parallel computation is
+#' based on the \code{doMC} and \code{multicore} packages, so the same care
+#' should be taken as stated in the vignette of \code{doMC}: \emph{\dQuote{it
+#' is not safe to use doMC from R.app on Mac OS X. Instead, you should use doMC
+#' from a terminal session, starting R from the command line.}} }
+#'
+#' \item{parallel.required - P}{ Same as \code{p}, but an error is thrown if
+#' the computation cannot be performed in parallel or with the specified number
+#' of processors.}
+#'
+#' \item{shared.memory - m}{ toggle usage of shared memory (requires the
+#' \pkg{synchronicity} package).
+#' Default is as defined by \code{nmf.getOption('shared.memory')}.}
+#'
+#' \item{restore.seed - r}{ deprecated option since version 0.5.99.
+#' Will throw a warning if used.}
+#'
+#' \item{simplifyCB - S}{ toggle simplification of the callback results.
+#' Default is \code{TRUE}}
+#'
+#' \item{track - t}{ enables error tracking (default: FALSE).
+#' If \code{TRUE}, the returned object's slot \code{residuals} contains the
+#' trajectory of the objective values, which can be retrieved via
+#' \code{residuals(res, track=TRUE)}
+#' This tracking functionality is available for all built-in algorithms.
+#' }
+#'
+#' \item{verbose - v}{ Toggle verbosity (default: \code{FALSE}).
+#' If \code{TRUE}, messages about the configuration and the state of the
+#' current run(s) are displayed.
+#' The level of verbosity may be specified with an integer value, the greater
+#' the level the more messages are displayed.
+#' Value \code{FALSE} means no messages are displayed, while value \code{TRUE}
+#' is equivalent to verbosity level 1.
+#' }
+#'
+#' }
+#'
+#' @param .pbackend specification of the \code{\link{foreach}} parallel backend
+#' to register and/or use when running in parallel mode.
+#' See options \code{p} and \code{P} in argument \code{.options} for how to
+#' enable this mode.
+#' Note that any backend that is internally registered is cleaned-up on exit,
+#' so that the calling foreach environment should not be affected by a call to
+#' \code{nmf} -- except when \code{.pbackend=NULL}.
+#'
+#' Currently it accepts the following values:
+#' \describe{
+#'
+#' \item{\sQuote{par}}{ use the backend(s) defined by the package
+#' \code{\link{doParallel}};}
+#' \item{a numeric value}{ use the specified number of cores with \code{doParallel}
+#' backend;}
+#' \item{\sQuote{seq}}{ use the foreach sequential backend \code{doSEQ};}
+#' \item{\code{NULL}}{ use currently registered backend;}
+#' \item{\code{NA}}{ do not compute using a foreach loop -- and therefore not in
+#' parallel -- but rather use a call to standard \code{\link{sapply}}.
+#' This is useful for when developing/debugging NMF algorithms, as foreach loop
+#' handling may sometime get in the way.
+#'
+#' Note that this is equivalent to using \code{.options='-p'} or \code{.options='p0'},
+#' but takes precedence over any option specified in \code{.options}:
+#' e.g. \code{nmf(..., .options='P10', .pbackend=NA)} performs all runs sequentially
+#' using \code{sapply}.
+#' Use \code{nmf.options(pbackend=NA)} to completely disable foreach/parallel computations
+#' for all subsequent \code{nmf} calls.}
+#'
+#' \item{\sQuote{mc}}{ identical to \sQuote{par} and defined to ensure backward
+#' compatibility.}
+#' }
+#'
+#' @param .callback Used when option \code{keep.all=FALSE} (default). It
+#' allows to pass a callback function that is called after each run when
+#' performing multiple runs (i.e. with \code{nrun>1}).
+#' This is useful for example if one is also interested in saving summary
+#' measures or process the result of each NMF fit before it gets discarded.
+#' After each run, the callback function is called with two arguments, the
+#' \code{\linkS4class{NMFfit}} object that as just been fitted and the run
+#' number: \code{.callback(res, i)}.
+#' For convenience, a function that takes only one argument or has
+#' signature \code{(x, ...)} can still be passed in \code{.callback}.
+#' It is wrapped internally into a dummy function with two arguments,
+#' only the first of which is passed to the actual callback function (see example
+#' with \code{summary}).
+#'
+#' The call is wrapped into a tryCatch so that callback errors do not stop the
+#' whole computation (see below).
+#'
+#' The results of the different calls to the callback function are stored in a
+#' miscellaneous slot accessible using the method \code{$} for \code{NMFfit}
+#' objects: \code{res$.callback}.
+#' By default \code{nmf} tries to simplify the list of callback result using
+#' \code{sapply}, unless option \code{'simplifyCB'} is \code{FASE}.
+#'
+#' If no error occurs \code{res$.callback} contains the list of values that
+#' resulted from the calling the callback function --, ordered as the fits.
+#' If any error occurs in one of the callback calls, then the whole computation is
+#' \strong{not} stopped, but the error message is stored in \code{res$.callback},
+#' in place of the result.
+#'
+#' See the examples for sample code.
+#'
+#' @return The returned value depends on the run mode:
+#'
+#' \item{Single run:}{An object of class \code{\linkS4class{NMFfit}}.}
+#'
+#' \item{Multiple runs, single method:}{When \code{nrun > 1} and \code{method}
+#' is not \code{list}, this method returns an object of class \code{\linkS4class{NMFfitX}}.}
+#'
+#' \item{Multiple runs, multiple methods:}{When \code{nrun > 1} and \code{method}
+#' is a \code{list}, this method returns an object of class \code{\linkS4class{NMFList}}.}
+#'
+#' @demo
+#'
+#' # default fit
+#' res <- nmf(x, 2)
+#' summary(res, class=groups)
+#'
+#' # run default algorithm multiple times (only keep the best fit)
+#' res <- nmf(x, 3, nrun=10)
+#' res
+#' summary(res, class=groups)
+#'
+#' # run default algorithm multiple times keeping all the fits
+#' res <- nmf(x, 3, nrun=10, .options='k')
+#' res
+#' summary(res, class=groups)
+#'
+#' ## Note: one could have equivalently done
+#' # res <- nmf(V, 3, nrun=10, .options=list(keep.all=TRUE))
+#'
+#' # use a method that fit different model
+#' res <- nmf(x, 2, 'nsNMF')
+#' fit(res)
+#'
+#' # pass parameter theta to the model via `...`
+#' res <- nmf(x, 2, 'nsNMF', theta=0.2)
+#' fit(res)
+#'
+#' ## handling arguments in `...` and model parameters
+#' myfun <- function(x, start, theta=100){ cat("theta in myfun=", theta, "\n\n"); start }
+#' # no conflict: default theta
+#' fit( nmf(x, 2, myfun) )
+#' # no conlfict: theta is passed to the algorithm
+#' fit( nmf(x, 2, myfun, theta=1) )
+#' # conflict: theta is used as model parameter
+#' fit( nmf(x, 2, myfun, model='NMFns', theta=0.1) )
+#' # conflict solved: can pass different theta to model and algorithm
+#' fit( nmf(x, 2, myfun, model=list('NMFns', theta=0.1), theta=5) )
+#'
+#' ## USING SEEDING METHODS
+#'
+#' # run default algorithm with the Non-negative Double SVD seeding method ('nndsvd')
+#' res <- nmf(x, 3, seed='nndsvd')
+#'
+#' ## Note: partial match also works
+#' identical(res, nmf(x, 3, seed='nn'))
+#'
+#' # run nsNMF algorithm, fixing the seed of the random number generator
+#' res <- nmf(x, 3, 'nsNMF', seed=123456)
+#' nmf.equal(nmf(x, 3, 'nsNMF', seed=123456), res)
+#'
+#' # run default algorithm specifying the starting point following the NMF standard model
+#' start.std <- nmfModel(W=matrix(0.5, n, 3), H=matrix(0.2, 3, p))
+#' nmf(x, start.std)
+#'
+#' # to run nsNMF algorithm with an explicit starting point, this one
+#' # needs to follow the 'NMFns' model:
+#' start.ns <- nmfModel(model='NMFns', W=matrix(0.5, n, 3), H=matrix(0.2, 3, p))
+#' nmf(x, start.ns)
+#' # Note: the method name does not need to be specified as it is infered from the
+#' # when there is only one algorithm defined for the model.
+#'
+#' # if the model is not appropriate (as defined by the algorihtm) an error is thrown
+#' # [cf. the standard model doesn't include a smoothing parameter used in nsNMF]
+#' try( nmf(x, start.std, method='nsNMF') )
+#'
+#' ## Callback functions
+#' # Pass a callback function to only save summary measure of each run
+#' res <- nmf(x, 3, nrun=3, .callback=summary)
+#' # the callback results are simplified into a matrix
+#' res$.callback
+#' res <- nmf(x, 3, nrun=3, .callback=summary, .opt='-S')
+#' # the callback results are simplified into a matrix
+#' res$.callback
+#'
+#' # Pass a custom callback function
+#' cb <- function(obj, i){ if( i %% 2 ) sparseness(obj) >= 0.5 }
+#' res <- nmf(x, 3, nrun=3, .callback=cb)
+#' res$.callback
+#'
+#' # Passs a callback function which throws an error
+#' cb <- function(){ i<-0; function(object){ i <<- i+1; if( i == 1 ) stop('SOME BIG ERROR'); summary(object) }}
+#' res <- nmf(x, 3, nrun=3, .callback=cb())
+#'
+#' ## PARALLEL COMPUTATIONS
+#' # try using 3 cores, but use sequential if not possible
+#' res <- nmf(x, 3, nrun=3, .options='p3')
+#'
+#' # force using 3 cores, error if not possible
+#' res <- nmf(x, 3, nrun=3, .options='P3')
+#'
+#' # use externally defined cluster
+#' library(parallel)
+#' cl <- makeCluster(6)
+#' res <- nmf(x, 3, nrun=3, .pbackend=cl)
+#'
+#' # use externally registered backend
+#' registerDoParallel(cl)
+#' res <- nmf(x, 3, nrun=3, .pbackend=NULL)
+#'
+setMethod('nmf', signature(x='matrix', rank='numeric', method='NMFStrategy'),
+#function(x, rank, method, seed='random', nrun=1, keep.all=FALSE, optimized=TRUE, init='NMF', track, verbose, ...)
+function(x, rank, method
+ , seed=nmf.getOption('default.seed'), rng = NULL
+ , nrun=if( length(rank) > 1L ) 30 else 1, model=NULL, .options=list()
+ , .pbackend=nmf.getOption('pbackend')
+ , .callback=NULL #callback function called after a run
+ , ...)
+{
+ fwarning <- function(...) nmf_warning('nmf', ...)
+ fstop <- function(...) nmf_stop('nmf', ...)
+
+ # if options are given as a character string, translate it into a list of booleans
+ if( is.character(.options) ){
+ .options <- .translate.string(.options,
+ c(t='track', v='verbose', d='debug'
+ , p='parallel', P='parallel.required'
+ , k='keep.all', r='restore.seed', f='dry.run'
+ , g='garbage.collect'
+ , c='cleanup', S='simplifyCB'
+ , R='RNGstream', m='shared.memory'))
+ }
+
+ # get seeding method from the strategy's defaults if needed
+ seed <- defaultArgument(seed, method, nmf.getOption('default.seed'), force=is.null(seed))
+ .method_defaults <- method at defaults
+ .method_defaults$seed <- NULL
+ #
+ # RNG specification
+ if( isRNGseed(seed) ){
+ if( !is.null(rng) )
+ warning("Discarding RNG specification in argument `rng`: using those passed in argument `seed`.")
+ rng <- seed
+ seed <- 'random'
+ }
+ #
+
+ # setup verbosity options
+ debug <- if( !is.null(.options$debug) ) .options$debug else nmf.getOption('debug')
+ verbose <- if( debug ) Inf
+ else if( !is.null(.options$verbose) ) .options$verbose
+ else nmf.getOption('verbose')
+
+ # show call in debug mode
+ if( debug ){
+ .ca <- match.call()
+ message('# NMF call: ', paste(capture.output(print(.ca)), collapse="\n "))
+ }
+ # nmf over a range of values: pass the call to nmfEstimateRank
+ if( length(rank) > 1 ){
+ if( verbose <= 1 )
+ .options$verbose <- FALSE
+ return( nmfEstimateRank(x, range = rank, method = method, nrun = nrun
+ , seed = seed, rng = rng, model = model
+ , .pbackend = .pbackend, .callback = .callback
+ , verbose=verbose, .options=.options, ...) )
+ }
+
+ .OPTIONS <- list()
+ # cleanup on exit
+ .CLEANUP <- .options$cleanup %||% TRUE
+
+ # tracking of objective value
+ .OPTIONS$track <- if( !is.null(.options$track) ) .options$track
+ else nmf.getOption('track')
+ # dry run
+ dry.run <- .options$dry.run %||% FALSE
+ # call the garbage collector regularly
+ opt.gc <- if( !is.null(.options$garbage.collect) ) .options$garbage.collect
+ else nmf.getOption('gc')
+ if( is.logical(opt.gc) && opt.gc )
+ opt.gc <- ceiling(max(nrun,50) / 3)
+ .options$garbage.collect <- opt.gc
+
+ # keep results from all runs?
+ keep.all <- .options$keep.all %||% FALSE
+ # shared memory?
+ shared.memory <- if( !is.null(.options$shared.memory) ) .options$shared.memory else nmf.getOption('shared.memory')
+ # use RNG stream
+ .options$RNGstream <- .options$RNGstream %||% TRUE
+
+ # discard .callback when not used
+ if( is.function(.callback) ){
+ w <- if( nrun==1 ) "discarding argument `.callback`: not used when `nrun=1`."
+ else if( keep.all )
+ "discarding argument `.callback`: not used when option `keep.all=TRUE`."
+ if( !is.null(w) ){
+ .callback <- NULL
+ fwarning(w, immediate.=TRUE)
+ }
+
+ # wrap into another function if necessary
+ if( is.function(.callback) ){
+ # default is to simplify
+ .options$simplifyCB <- .options$simplifyCB %||% TRUE
+ args <- formals(.callback)
+ if( length(args) <= 2L ){
+ if( length(args) < 2L || '...' %in% names(args) ){
+ .CALLBACK <- .callback
+ .callback <- function(object, i) .CALLBACK(object)
+ }
+ }
+
+ # define post-processing function
+ processCallback <- function(res){
+ # check errors
+ errors <- checkErrors(res, '.callback')
+ if( errors$n > 0 ){
+ fwarning("All NMF fits were successful but ", errors$n, "/", nrun, " callback call(s) threw an error.\n"
+ ,"# ", if(errors$n>10) "First 10 c" else "C", "allback error(s) thrown:\n"
+ , errors$msg
+ )
+ }
+ # add callback values to result list
+ sapply(res, '[[', '.callback'
+ , simplify=.options$simplifyCB && errors$n == 0L)
+ }
+ }
+ }
+
+ ## ROLLBACK PROCEDURE
+ exitSuccess <- exitCheck()
+ on.exit({
+ if( verbose > 1 ) message("# NMF computation exit status ... ", if( exitSuccess() ) 'OK' else 'ERROR')
+ if( verbose > 2 ){
+ if( exitSuccess() ){
+ message('\n## Running normal exit clean up ... ')
+ }else{
+ message('\n## Running rollback clean up ... ')
+ }
+ }
+ }, add=TRUE)
+ # RNG restoration on error
+ .RNG_ORIGIN <- getRNG()
+ on.exit({
+ if( !exitSuccess() ){
+ if( verbose > 2 ) message("# Restoring RNG settings ... ", appendLF=verbose>3)
+ setRNG(.RNG_ORIGIN)
+ if( verbose > 3 ) showRNG(indent=' #')
+ if( verbose > 2 ) message("OK")
+ }
+ }, add=TRUE)
+
+ # Set debug/verbosity option just for the time of the run
+ old.opt <- nmf.options(debug=debug, verbose=verbose, shared.memory = shared.memory);
+ on.exit({
+ if( verbose > 2 ) message("# Restoring NMF options ... ", appendLF=FALSE)
+ nmf.options(old.opt)
+ if( verbose > 2 ) message("OK")
+ }, add=TRUE)
+
+ # make sure rank is an integer
+ rank <- as.integer(rank)
+ if( length(rank) != 1 ) fstop("invalid argument 'rank': must be a single numeric value")
+ if( rank < 1 ) fstop("invalid argument 'rank': must be greater than 0")
+
+ # option 'restore.seed' is deprecated
+ if( !is.null(.options$restore.seed) )
+ fwarning("Option 'restore.seed' is deprecated and discarded since version 0.5.99.")
+
+ if( verbose ){
+ if( dry.run ) message("*** fake/dry-run ***")
+ message("NMF algorithm: '", name(method), "'")
+ }
+
+ ##START_MULTI_RUN
+ # if the number of run is more than 1, then call itself recursively
+ if( nrun > 1 )
+ {
+ if( verbose ) message("Multiple runs: ", nrun)
+
+ if( verbose > 3 ){
+ cat("## OPTIONS:\n")
+ sapply(seq_along(.options)
+ , function(i){
+ r <- i %% 4
+ cat(if(r!=1) '\t| ' else "# ", names(.options)[i],': ', .options[[i]], sep='')
+ if(r==0) cat("\n# ")
+ })
+ if( length(.options) %% 4 != 0 )cat("\n")
+ }
+
+ ## OPTIONS: parallel computations
+ # option require-parallel: parallel computation is required if TRUE or numeric != 0
+ opt.parallel.required <- !is.null(.options$parallel.required) && .options$parallel.required
+ # determine specification for parallel computations
+ opt.parallel.spec <-
+ if( opt.parallel.required ){ # priority over try-parallel
+ # option require-parallel implies and takes precedence over option try-parallel
+ .options$parallel.required
+ }else if( !is.null(.options$parallel) ) .options$parallel # priority over .pbackend
+ else !is_NA(.pbackend) # required only if backend is not trivial
+
+ # determine if one should run in parallel at all: TRUE or numeric != 0, .pbackend not NA
+ opt.parallel <- !is_NA(.pbackend) && (isTRUE(opt.parallel.spec) || opt.parallel.spec)
+ ##
+ if( opt.parallel ){
+ if( verbose > 1 )
+ message("# Setting up requested `foreach` environment: "
+ , if( opt.parallel.required ) 'require-parallel' else 'try-parallel'
+ , ' [', quick_str(.pbackend) , ']')
+
+
+ # switch doMC backend to doParallel
+ if( isString(.pbackend, 'MC', ignore.case=TRUE) ){
+ .pbackend <- 'par'
+ }
+ # try setting up parallel foreach backend
+ oldBackend <- setupBackend(opt.parallel.spec, .pbackend, !opt.parallel.required, verbose=verbose)
+ opt.parallel <- !isFALSE(oldBackend)
+ # setup backend restoration if using one different from the current one
+ if( opt.parallel && !is_NA(oldBackend) ){
+ on.exit({
+ if( verbose > 2 ){
+ message("# Restoring previous foreach backend '", getDoBackendName(oldBackend) ,"' ... ", appendLF=FALSE)
+ }
+ setDoBackend(oldBackend, cleanup=TRUE)
+ if( verbose > 2 ) message('OK')
+ }, add=TRUE)
+ }#
+
+ # From this point, the backend is registered
+ # => one knows if we'll run a sequential or parallel foreach loop
+ .MODE_SEQ <- is.doSEQ()
+ MODE_PAR <- .MODE_PAR <- !.MODE_SEQ
+
+ }
+
+ # check seed method: fixed values are not sensible -> warning
+ .checkRandomness <- FALSE
+ if( is.nmf(seed) && !is.empty.nmf(seed) ){
+ .checkRandomness <- TRUE
+ }
+ # start_RNG_all
+ # if the seed is numerical or a rstream object, then use it to set the
+ # initial state of the random number generator:
+ # build a sequence of RNGstreams: if no suitable seed is provided
+ # then the sequence use a random seed generated with a single draw
+ # of the current active RNG. If the seed is valid, then the
+ #
+ # setup the RNG sequence
+
+ # override with standard RNG if .options$RNGstream=FALSE
+ resetRNG <- NULL
+ if( !.options$RNGstream && (!opt.parallel || .MODE_SEQ) ){
+
+ .RNG.seed <- rep(list(NULL), nrun)
+ if( isNumber(rng) ){
+ resetRNG <- getRNG()
+ if( verbose > 2 ) message("# Force using current RNG settings seeded with: ", rng)
+ set.seed(rng)
+ }else if( verbose > 2 )
+ message("# Force using current RNG settings")
+
+ }else{
+ .RNG.seed <- setupRNG(rng, n = nrun, verbose=verbose)
+ # restore the RNG state on exit as after RNGseq:
+ # - if no seeding occured then the RNG has still been drawn once in RNGseq
+ # which must be reflected so that different unseeded calls use different RNG states
+ # - one needs to restore the RNG because it switched to L'Ecuyer-CMRG.
+ resetRNG <- getRNG()
+ }
+ stopifnot( length(.RNG.seed) == nrun )
+ # update RNG settings on exit if necessary
+ # and only if no error occured
+ if( !is.null(resetRNG) ){
+ on.exit({
+ if( exitSuccess() ){
+ if( verbose > 2 ) message("# Updating RNG settings ... ", appendLF=FALSE)
+ setRNG(resetRNG)
+ if( verbose > 2 ) message("OK")
+ if( verbose > 3 ) showRNG()
+ }
+ }, add=TRUE)
+ }
+ #end_RNG_all
+
+ ####FOREACH_NMF
+ if( opt.parallel ){
+
+ if( verbose ){
+ if( verbose > 1 )
+ message("# Using foreach backend: ", getDoParName()
+ ," [version ", getDoParVersion(),"]")
+ # show number of processes
+ if( getDoParWorkers() == 1 ) message("Mode: sequential [foreach:",getDoParName(),"]")
+ else message("Mode: parallel ", str_c("(", getDoParWorkers(), '/', parallel::detectCores()," core(s))"))
+ }
+
+ # check shared memory capability
+ .MODE_SHARED <- !keep.all && setupSharedMemory(verbose)
+
+ # setup temporary directory when not keeping all fits
+ if( !keep.all || verbose ){
+ NMF_TMPDIR <- setupTempDirectory(verbose)
+ # delete on exit
+ if( .CLEANUP ){
+ on.exit({
+ if( verbose > 2 ) message("# Deleting temporary directory '", NMF_TMPDIR, "' ... ", appendLF=FALSE)
+ unlink(NMF_TMPDIR, recursive=TRUE)
+ if( verbose > 2 ) message('OK')
+ }, add=TRUE)
+ }
+ }
+
+ run.all <- function(x, rank, method, seed, model, .options, ...){
+
+ ## 1. SETUP
+ # load some variables from parent environment to ensure they
+ # are exported in the foreach loop
+ MODE_SEQ <- .MODE_SEQ
+ MODE_SHARED <- .MODE_SHARED
+ verbose <- verbose
+ keep.all <- keep.all
+ opt.gc <- .options$garbage.collect
+ CALLBACK <- .callback
+ .checkRandomness <- .checkRandomness
+
+ # check if single or multiple host(s)
+ hosts <- unique(getDoParHosts())
+ if( verbose > 2 ) message("# Running on ", length(hosts), " host(s): ", str_out(hosts))
+ SINGLE_HOST <- length(hosts) <= 1L
+ MODE_SHARED <- MODE_SHARED && SINGLE_HOST
+ if( verbose > 2 ) message("# Using shared memory ... ", MODE_SHARED)
+
+ # setup mutex evaluation function
+ mutex_eval <- if( MODE_SHARED ) ts_eval(verbose = verbose > 4) else force
+
+ # Specific thing only if one wants only the best result
+ if( !keep.all ){
+ NMF_TMPDIR <- NMF_TMPDIR
+ # - Define the shared memory objects
+ vOBJECTIVE <- gVariable(as.numeric(NA), MODE_SHARED)
+ # the consensus matrix is computed only if not all the results are kept
+ vCONSENSUS <- gVariable(matrix(0, ncol(x), ncol(x)), MODE_SHARED)
+ }
+
+ ## 2. RUN
+ # ensure that the package NMF is in each worker's search path
+ .packages <- setupLibPaths('NMF', verbose>3)
+
+ # export all packages that contribute to NMF registries,
+ # e.g., algorithms or seeding methods.
+ # This is important so that these can be found in worker nodes
+ # for non-fork clusters.
+ if( !is.null(contribs <- registryContributors(package = 'NMF')) ){
+ .packages <- c(.packages, contribs)
+ }
+
+ # export dev environment if in dev mode
+# .export <- if( isDevNamespace('NMF') && !is.doSEQ() ) ls(asNamespace('NMF'))
+
+ # in parallel mode: verbose message from each run are only shown in debug mode
+ .options$verbose <- FALSE
+ if( verbose ){
+ if( debug || (.MODE_SEQ && verbose > 1) )
+ .options$verbose <- verbose
+
+ if( (!.MODE_SEQ && !debug) || (.MODE_SEQ && verbose == 1) ){
+ if( verbose == 1 ){
+ # create progress bar
+ pbar <- txtProgressBar(0, nrun+1, width=50, style=3, title='Runs:'
+ , shared=NMF_TMPDIR)
+ }else{
+ cat("Runs: ")
+ }
+ }
+ }
+
+ # get options from master process to pass to workers
+ nmf.opts <- nmf.options()
+
+ # load extra required packages for shared mode
+ if( MODE_SHARED )
+ .packages <- c(.packages, 'bigmemory', 'synchronicity')
+
+ res.runs <- foreach(n=1:nrun
+ , RNGobj = .RNG.seed
+ , .verbose = debug
+ , .errorhandling = 'pass'
+ , .packages = .packages
+# , .export = .export
+# , .options.RNG=.RNG.seed
+ ) %dopar% { #START_FOREACH_LOOP
+
+ # Pass options from master process
+ nmf.options(nmf.opts)
+
+ # in mode sequential or debug: show details for each run
+ if( MODE_SEQ && verbose > 1 )
+ cat("\n## Run: ",n, "/", nrun, "\n", sep='')
+
+ # set the RNG if necessary and restore after each run
+ if( MODE_SEQ && verbose > 2 )
+ message("# Setting up loop RNG ... ", appendLF=FALSE)
+ setRNG(RNGobj, verbose=verbose>3 && MODE_SEQ)
+ if( MODE_SEQ && verbose > 2 )
+ message("OK")
+
+ # limited verbosity in simple mode
+ if( verbose && !(MODE_SEQ && verbose > 1)){
+ if( verbose >= 2 ) mutex_eval( cat('', n) )
+ else{
+ # update progress bar (in mutex)
+ mutex_eval(setTxtProgressBar(pbar, n))
+ #
+ }
+ }
+
+ # check RNG changes
+ if( n == 1 && .checkRandomness ){
+ .RNGinit <- getRNG()
+ }
+
+ # fit a single NMF model
+ res <- nmf(x, rank, method, nrun=1, seed=seed, model=model, .options=.options, ...)
+
+ if( n==1 && .checkRandomness && rng.equal(.RNGinit) ){
+ warning("NMF::nmf - You are running multiple non-random NMF runs with a fixed seed")
+ }
+
+ # if only the best fit must be kept then update the shared objects
+ if( !keep.all ){
+
+ # initialise result list
+ resList <- list(filename=NA, residuals=NA, .callback=NULL)
+
+ ##LOCK_MUTEX
+ mutex_eval({
+
+ # check if the run found a better fit
+ .STATIC.err <- vOBJECTIVE()
+
+ # retrieve approximation error
+ err <- deviance(res)
+
+ if( is.na(.STATIC.err) || err < .STATIC.err ){
+
+ if( n>1 && verbose ){
+ if( MODE_SEQ && verbose > 1 ) cat("## Better fit found [err=", err, "]\n")
+ else if( verbose >= 2 ) cat('*')
+ }
+
+ # update residuals
+ vOBJECTIVE(err)
+
+ # update best fit on disk: use pid if not using shared memory
+ resfile <- hostfile("fit", tmpdir=NMF_TMPDIR, fileext='.rds', pid=!MODE_SHARED)
+ if( MODE_SEQ && verbose > 2 )
+ message("# Serializing fit object in '", resfile, "' ... ", appendLF=FALSE)
+ saveRDS(res, file=resfile, compress=FALSE)
+ if( MODE_SEQ && verbose > 2 ){
+ message(if( file.exists(resfile) ) 'OK' else 'ERROR')
+ }
+ # store the filename and achieved objective value in the result list
+ resList$filename <- resfile
+ resList$residuals <- err
+
+ }
+
+ ## CONSENSUS
+ # update the consensus matrix
+ if( MODE_SHARED && SINGLE_HOST ){
+ # on single host: shared memory already contains consensus
+ vCONSENSUS(vCONSENSUS() + connectivity(res, no.attrib=TRUE))
+ }else{
+ # on multiple hosts: must return connectivity and aggregate at the end
+ resList$connectivity <- connectivity(res, no.attrib=TRUE)
+ }
+
+ ## CALLBACK
+ # call the callback function if necessary (return error as well)
+ if( is.function(CALLBACK) ){
+ resList$.callback <- tryCatch(CALLBACK(res, n), error=function(e) e)
+ }
+
+ })
+ ##END_LOCK_MUTEX
+
+ # discard result object
+ res <- NULL
+ # return description list
+ res <- resList
+ }
+
+ # garbage collection if requested
+ if( opt.gc && n %% opt.gc == 0 ){
+ if( verbose > 2 ){
+ if( MODE_SEQ )
+ message("# Call garbage collector")
+ else{
+ mutex_eval( cat('%') )
+ }
+ }
+
+ gc(verbose= MODE_SEQ && verbose > 3)
+ }
+
+ # return the result
+ res
+ }
+ ## END_FOREACH_LOOP
+
+ if( verbose && !debug ){
+ if( verbose >= 2 ) cat(" ... DONE\n")
+ else{
+ setTxtProgressBar(pbar, nrun+1)
+ pbar$kill(.CLEANUP)
+ }
+ }
+
+ ## 3. CHECK FIT ERRORS
+ errors <- checkErrors(res.runs)
+ if( errors$n > 0 ){
+ fstop(errors$n,"/", nrun, " fit(s) threw an error.\n"
+ ,"# Error(s) thrown:\n", errors$msg)
+ }
+
+ ## 4. WRAP UP
+ if( keep.all ){ # result is a list of fits
+ # directly return the list of fits
+ res <- res.runs
+
+ }else{ # result is a list of lists: filename, .callback
+ # loop over the result files to find the best fit
+ if( verbose > 2 ) message("# Processing partial results ... ", appendLF=FALSE)
+ ffstop <- function(...){ message('ERROR'); fstop(...) }
+ # get best fit index
+ idx <- which.min(sapply(res.runs, '[[', 'residuals'))
+ if( length(idx) == 0L )
+ ffstop("Unexpected error: no partial result seem to have been saved.")
+ resfile <- res.runs[[idx]]$filename
+ # check existence of the result file
+ if( !file_test('-f', resfile) )
+ ffstop("could not find temporary result file '", resfile, "'")
+
+ # update res with a better fit
+ res <- readRDS(resfile)
+ if( !isNMFfit(res) )
+ ffstop("invalid object found in result file '", resfile, "'")
+ if( verbose > 2 ) message('OK')
+ # wrap the result in a list: fit + consensus
+ res <- list(fit=res, consensus=NA)
+
+ # CONSENSUS MATRIX
+ if( !is.null(res.runs[[1]]$connectivity) ){ # not MODE_SHARED
+ # aggregate connectivity matrices
+ con <- matrix(0, ncol(x), ncol(x))
+ sapply(res.runs, function(x){
+ con <<- con + x$connectivity
+ })
+ res$consensus <- con
+
+ }else{ # in MODE_SHARED: get consensus from global shared variable
+ res$consensus <- vCONSENSUS()
+ cn <- colnames(x)
+ if( is.null(cn) ) dimnames(res$consensus) <- NULL
+ else dimnames(res$consensus) <- list(cn, cn)
+ }
+
+ # CALLBACKS
+ if( !is.null(.callback) ){
+ res$.callback <- processCallback(res.runs)
+ }
+ }
+ ##
+
+ if( MODE_SEQ && verbose>1 ) cat("## DONE\n")
+
+ # return result
+ res
+ }
+ }####END_FOREACH_NMF
+ else{####SAPPLY_NMF
+
+ run.all <- function(x, rank, method, seed, model, .options, ...){
+
+ # by default force no verbosity from the runs
+ .options$verbose <- FALSE
+ if( verbose ){
+ message("Mode: sequential [sapply]")
+ if( verbose > 1 ){
+ # pass verbosity options in this case
+ .options$verbose <- verbose
+ }
+ }
+
+ ## 1. SETUP
+ # define static variables for the case one only wants the best result
+ if( !keep.all ){
+ # statis list with best result: fit, residual, consensus
+ best.static <- list(fit=NULL, residuals=NA, consensus=matrix(0, ncol(x), ncol(x)))
+ }
+
+ ## 2. RUN:
+ # perform a single run `nrun` times
+ if( verbose == 2 ){
+ showRNG()
+ }
+ if( verbose && !debug ) cat('Runs:')
+ res.runs <- mapply(1:nrun, .RNG.seed, FUN=function(n, RNGobj){
+
+ #start_verbose
+ if( verbose ){
+ # in mode verbose > 1: show details for each run
+ if( verbose > 1 ){
+ cat("\n## Run: ",n, "/", nrun, "\n", sep='')
+ }else{
+ # otherwise only some details for the first run
+ cat('', n)
+ }
+ }#end_verbose
+
+ # set the RNG for each run
+ if( verbose > 2 ) message("# Setting up loop RNG ... ", appendLF=FALSE)
+ setRNG(RNGobj, verbose=verbose>3)
+ if( verbose > 2 ) message("OK")
+
+ # check RNG changes
+ if( n == 1 && .checkRandomness ){
+ .RNGinit <- getRNG()
+ }
+
+ # fit a single NMF model
+ res <- nmf(x, rank, method, nrun=1, seed=seed, model=model, .options=.options, ...)
+
+ if( n==1 && .checkRandomness && rng.equal(.RNGinit) ){
+ warning("NMF::nmf - You are running multiple non-random NMF runs with a fixed seed"
+ , immediate.=TRUE)
+ }
+
+ if( !keep.all ){
+
+ # initialise result list
+ resList <- list(residuals=NA, .callback=NULL)
+
+ # check if the run found a better fit
+ err <- residuals(res)
+ best <- best.static$residuals
+ if( is.na(best) || err < best ){
+ if( verbose ){
+ if( verbose > 1L ) cat("## Updating best fit [deviance =", err, "]\n", sep='')
+ else cat('*')
+ }
+
+ # update best fit (only if necessary)
+ best.static$fit <<- res
+ best.static$residuals <<- err
+
+ resList$residuals <- err
+ }
+
+ # update the static consensus matrix (only if necessary)
+ best.static$consensus <<- best.static$consensus + connectivity(res, no.attrib=TRUE)
+
+ # call the callback function if necessary
+ if( !is.null(.callback) ){
+ resList$.callback <- tryCatch(.callback(res, n), error=function(e) e)
+ }
+
+ # reset the result to NULL
+ res <- resList
+
+ }
+
+ # garbage collection if requested
+ if( opt.gc && n %% opt.gc == 0 ){
+ if( verbose > 1 )
+ message("# Call garbage collection NOW")
+ else if( verbose )
+ cat('%')
+
+ gc(verbose = verbose > 3)
+ }
+
+ if( verbose > 1 ) cat("## DONE\n")
+
+ # return the result
+ res
+ }, SIMPLIFY=FALSE)
+ ##
+
+ if( verbose && !debug ) cat(" ... DONE\n")
+
+ ## 3. ERROR CHECK / WRAP UP
+
+ if( keep.all ){
+ res <- res.runs
+ }else{
+ res <- list(fit=best.static$fit, consensus=best.static$consensus)
+
+ # CALLBACKS
+ if( !is.null(.callback) ){
+ res$.callback <- processCallback(res.runs)
+ }
+ }
+
+ res
+ }
+
+ }####END_SAPPLY_NMF
+
+ ####END_DEFINE_RUN
+
+ # perform all the NMF runs
+ t <- system.time({res <- run.all(x=x, rank=rank, method=method, seed=seed, model=model, .options, ...)})
+ if( verbose && !debug ){
+ cat("System time:\n")
+ print(t)
+ }
+
+ if( keep.all ){
+
+ # when keeping all the fits: join the results into an NMFfitXn object
+ # TODO: improve memory management here
+ res <- NMFfitX(res, runtime.all=t)
+
+ return( exitSuccess(res) )
+
+ }else{# if one just want the best result only return the best
+ # ASSERT the presence of the result
+ stopifnot( !is.null(res$fit) )
+ # ASSERT the presence of the consensus matrix
+ stopifnot( !is.null(res$consensus) )
+
+ res.final <- NMFfitX(res$fit, consensus=res$consensus/nrun
+ , runtime.all=t, nrun=as.integer(nrun)
+ , rng1=.RNG.seed[[1]])
+
+ # ASSERT and add callback if necessary
+ if( !is.null(.callback) ){
+ stopifnot( !is.null(res$.callback) )
+ res.final$.callback <- res$.callback
+ }
+
+ return( exitSuccess(res.final) )
+ }
+
+ }##END_MULTI_RUN
+
+ # start_RNG
+ # show original RNG settings in verbose > 2
+ if( verbose > 3 ){
+ message("# ** Current RNG settings:")
+ showRNG()
+ }
+
+ # do something if the RNG was actually changed
+ newRNG <- getRNG()
+ .RNG.seed <- setupRNG(rng, 1, verbose=verbose-1)
+ # setup restoration
+ if( isRNGseed(rng) ){
+ if( verbose > 3 ) showRNG()
+
+ # restore RNG settings
+ on.exit({
+ if( verbose > 2 ) message("# Restoring RNG settings ... ", appendLF=FALSE)
+ setRNG(newRNG)
+ if( verbose > 2 ) message("OK")
+ if( verbose > 3 ) showRNG()
+ }, add=TRUE)
+ }
+ #end_RNG
+
+ # CHECK PARAMETERS:
+ # test for negative values in x only if the method is not mixed
+ if( !is.mixed(method) && min(x, na.rm = TRUE) < 0 )
+ fstop('Input matrix ', substitute(x),' contains some negative entries.');
+ # test if one row contains only zero entries
+ if( min(rowSums(x, na.rm = TRUE), na.rm = TRUE) == 0 )
+ fstop('Input matrix ', substitute(x),' contains at least one null or NA-filled row.');
+
+ # a priori the parameters for the run are all the one in '...'
+ # => expand with the strategy's defaults (e.g., maxIter)
+ parameters.method <- expand_list(list(...), .method_defaults)
+ #
+
+ if( is.nmf(seed) ){
+
+ if( !is.null(model) )
+ fwarning("Discarding argument `model`: directly using NMF model supplied in argument `seed`")
+
+ # if the seed is a NMFfit object then only use the fit (i.e. the NMF model)
+ # => we want a fresh and clean NMFfit object
+ if( isNMFfit(seed) )
+ seed <- fit(seed)
+
+ # Wrap up the seed into a NMFfit object
+ seed <- NMFfit(fit=seed, seed='NMF')
+ }
+ else if( !inherits(seed, 'NMFfit') ){
+
+ ## MODEL INSTANTIATION :
+
+ # default NMF model is retrieved from the NMF strategy
+ .modelClass <- modelname(method)
+ # if a character string then use this type of NMF model, but still look
+ # for slots in `...`
+ if( is.character(model) ){
+ .modelClass <- model
+ model <- NULL
+ }
+
+ # some of the instantiation parameters are set internally
+ # TODO: change target into x (=> impact on nmfModel ?
+ parameters.model.internal <- list(rank=rank, target=0)
+ parameters.model <- list()
+
+ init <-
+ if( is.nmf(model) ){
+ model
+ }else{
+ # if 'model' is NULL: initialization parameters are searched in '...'
+ if( is.null(model) ){
+
+ # extract the parameters from '...' that correspond to slots in the given class
+ stopifnot( isNMFclass(.modelClass) )
+ parameters <- .extract.slots.parameters(.modelClass, parameters.method)
+
+ # restrict parameters.method to the ones that won't be used to instantiate the model
+ overriden <- is.element(names(parameters$slots), names(parameters.model.internal))
+ parameters.method <- c(parameters$extra, parameters$slots[overriden])
+
+ #- the model parameters come from the remaining elements
+ parameters.model <- c(model=.modelClass, parameters$slots)
+
+ } else if( is.list(model) ){ # otherwise argument 'model' must be a list
+
+ # if the list is not empty then check all elements are named and
+ # not conflicting with the internally set values
+ if( length(model) > 0 ){
+ # all the elements must be named
+ if( !hasNames(model, all=TRUE) )
+ fstop("Invalid argument `model` [elements must all be named]. See ?nmf.")
+
+ # warn the user if some elements are conflicting and won't be used
+ overriden <- is.element(names(model), names(parameters.model.internal))
+ if( any(overriden) )
+ warning("NMF::nmf - Model parameter(s) ["
+ , str_out(model[overriden], use.names=TRUE, max=Inf)
+ , "] discarded. Used internally set value(s) ["
+ , str_out(parameters.model.internal[names(model[overriden])], use.names=TRUE, max=Inf)
+ , "]"
+ , call.=FALSE)
+ }
+
+ # add default model class if necessary
+ if( is.null(model$model) )
+ model$model <- .modelClass
+ # all the instantiation parameters come from argument 'model'
+ parameters.model <- model
+
+ }else{
+ fstop("Invalid argument 'model' [expected NULL, a character string, or a list to set slots in the NMF model class '",.modelClass,"']. See ?nmf.")
+ }
+
+
+ #- force the value of the internally set arguments for the instantiation of the model
+ parameters.model <- .merge.override(parameters.model, parameters.model.internal)
+
+ # at this point 'init' should be the list of the initialization parameters
+ if( !is.list(parameters.model) ){
+ fstop("Unexpected error: object 'parameters.model' must be a list")
+ }
+ if( !is.element('model', names(parameters.model)) ){
+ fstop("Unexpected error: object 'parameters.model' must contain an element named 'model'")
+ }
+
+ parameters.model
+ }
+ ## SEEDING:
+ # the seed must either be an instance of class 'NMF', the name of a seeding method as a character string
+ # or a list of parameters to pass to the 'seed' function.
+ parameters.seed <- list()
+ seed.method <- NULL
+ if( (is.character(seed) && length(seed) == 1)
+ || is.numeric(seed)
+ || is.null(seed)
+# || is(seed, 'rstream')
+ ) seed.method <- seed
+ else if( is.function(seed) ) seed.method <- seed
+ else if( is.list(seed) ){ # seed is a list...
+
+ if( !is.null(seed$method) ){ # 'seed' must contain an element giving the method...
+ seed.method <- seed$method
+ parameters.seed <- seed[-which(names(seed)=='method')]
+ }
+ else if ( is.null(names(seed)) || names(seed)[1] == '' ){ # ... or the first element must be a method
+ seed.method <- seed[[1]]
+ if( length(seed) > 1 ) parameters.seed <- seed[2:length(seed)]
+ }
+ else fstop("Invalid parameter: list 'seed' must contain the seeding method through its first element or through an element named 'method' [", str_desc(seed, 2L), "]")
+
+ # check validity of the method provided via the list
+ if( !is.function(seed.method) && !(is.character(seed.method) && length(seed.method)==1) )
+ fstop("The seeding method provided by parameter 'seed' [", str_desc(seed.method), "] is invalid: a valid function or a character string is expected")
+ }
+ else fstop("Invalid parameter 'seed'. Acceptable values are:\n\t- ",
+ paste("an object that inherits from class 'NMF'"
+ , "the name of a seeding method (see ?nmfSeed)"
+ , "a valid seed method definition"
+ , "a list containing the seeding method (i.e. a function or a character string) as its first element\n\tor as an element named 'method' [and optionnally extra arguments it will be called with]"
+ , "a numerical value used to set the seed of the random generator"
+ , "NULL to directly pass the model instanciated from arguments 'model' or '...'."
+ , sep="\n\t- "))
+
+ # call the 'seed' function passing the necessary parameters
+ if( verbose )
+ message("NMF seeding method: ",
+ if( is.character(seed.method) || is.numeric(seed.method) ) seed.method
+ else if( is.null(seed.method) ) 'NULL'
+ else if( !is.null(attr(seed.method, 'name')) ) attr(seed.method, 'name')
+ else if( is.function(seed.method) ) '<function>'
+ else NA)
+
+ #seed <- do.call(getGeneric('seed', package='NMF')
+ seed <- do.call(getGeneric('seed')
+ , c(list(x=x, model=init, method=seed.method), parameters.seed))
+
+ # check the validity of the seed
+ if( !inherits(seed, 'NMFfit') )
+ fstop("The seeding method function should return class 'NMF' ["
+ , if( is.character(seed.method) ) paste('method "', seed.method, "' ", sep='') else NULL
+ , "returned class: '", class(seed), "']")
+ }
+ # -> at this point the 'seed' object is an instance of class 'NMFfit'
+ nmf.debug('nmf', "Seed is of class: '", class(seed), "'")
+ # ASSERT just to be sure
+ if( !inherits(seed, 'NMFfit') )
+ fstop("Invalid class '", class(seed), "' for the computed seed: object that inherits from class 'NMFfit' expected.")
+
+ # check the consistency of the NMF model expected by the algorithm and
+ # the one defined by the seed
+ #if( none( sapply(model(method), function(c) extends(model(seed), c)) ) )
+ if( all( !inherits(fit(seed), modelname(method)) ) )
+ fstop("Invalid NMF model '", modelname(seed),"': algorithm '", name(method), "' expects model(s) "
+ , paste(paste("'", modelname(method),"'", sep=''), collapse=', ')
+ , " or extension.")
+
+ # get the complete seeding method's name
+ seed.method <- seeding(seed)
+
+ ## FINISH SETUP OF THE SEED OBJECT: store some data within the seed so
+ # that strategy methods can access them directly
+ algorithm(seed) <- name(method) # algorithm name
+ seed at distance <- objective(method) # distance name
+ seed at parameters <- parameters.method # extra parameters
+ run.options(seed) <- nmf.options() # set default run options
+ run.options(seed, 'error.track') <- .OPTIONS$track
+ if( is.numeric(.OPTIONS$track) )
+ run.options(seed, 'track.interval') <- .OPTIONS$track
+ run.options(seed, 'verbose') <- verbose
+ # store ultimate nmf() call
+ seed at call <- match.call()
+ ##
+
+ ## print options if in verbose > 3
+ if( verbose > 3 ){
+ cat("## OPTIONS:\n")
+ sapply(seq_along(.options)
+ , function(i){
+ r <- i %% 4
+ cat(if(r!=1) '\t| ' else "# ", names(.options)[i],': ', .options[[i]], sep='')
+ if(r==0) cat("\n")
+ })
+ if( length(.options) %% 4 != 0 )cat("\n")
+ }
+
+
+ ## run parameters:
+ parameters.run <- c(list(object=method, y=x, x=seed), parameters.method)
+ ## Compute the initial residuals if tracking is enabled
+ init.resid <- if( .OPTIONS$track && !is.partial.nmf(seed) ){
+ do.call('deviance', parameters.run)
+ }
+
+ ## RUN NMF METHOD:
+ # call the strategy's run method [and time it]
+ t <- system.time({
+ res <- if( !dry.run ){
+ do.call('run', parameters.run)
+
+ }else{
+ seed
+ }
+ })
+
+ ## WRAP/CHECK RESULT
+ res <- .wrapResult(x, res, seed, method=method, seed.method=seed.method, t)
+ if( !isNMFfit(res) ){ # stop if error
+ fstop(res)
+ }
+ ##
+
+ ## CLEAN-UP + EXTRAS:
+ # add extra information to the object
+ # slot 'parameters'
+ if( length(res at parameters) == 0L && length(parameters.method)>0L )
+ res at parameters <- parameters.method
+ # last residuals
+ if( length(residuals(res)) == 0 && !is.partial.nmf(seed) ){
+ parameters.run$x <- res
+ residuals(res, niter=niter(res)) <- do.call('deviance', parameters.run)
+ }
+ # first residual if tracking is enabled
+ if( .OPTIONS$track && !is.null(init.resid) ){
+ if( !hasTrack(res, niter=0) )
+ residuals(res, track=TRUE) <- c('0'=init.resid, residuals(res, track=TRUE))
+ }
+
+ if( length(residuals(res)) && is.na(residuals(res)) ) warning("NMF residuals: final objective value is NA")
+ res at runtime <- t
+
+ # return the result
+ exitSuccess(res)
+})
+
+# wrap result
+.wrapResult <- function(x, res, seed, method, seed.method, t){
+
+ ## wrap into an NMFfit object (update seed)
+ if( !isNMFfit(res) ){
+ # extract expression data if necessary
+ if( is(res, 'ExpressionSet') ) res <- exprs(res)
+ if( is(x, 'ExpressionSet') ) x <- exprs(x)
+ # wrap
+ if( is.matrix(res) ){
+ if( ncol(res) == ncol(x) ){# partial fit: coef
+ # force dimnames
+ colnames(res) <- colnames(x)
+ res <- nmfModel(H=res)
+ }else if( nrow(res) == nrow(x) ){# partial fit: basis
+ # force dimnames
+ rownames(res) <- rownames(x)
+ res <- nmfModel(W=res)
+ }
+ }else if( is.list(res) ){ # build NMF model from result list
+ res <- do.call('nmfModel', res)
+ }
+
+ # substitute model in fit object
+ if( is.nmf(res) ){
+ tmp <- seed
+ fit(tmp) <- res
+ tmp at runtime <- t
+ res <- tmp
+ }
+ }
+
+ ## check result
+ if( !isTRUE(err <- .checkResult(res, seed)) ) return(err)
+
+ ## Enforce some slot values
+ # slot 'method'
+ algorithm(res) <- name(method)
+ # slot 'distance'
+ res at distance <- objective(method)
+ # slot 'seed'
+ if( seed.method != '' ) seeding(res) <- seed.method
+ # set dimnames of the result only if necessary
+ if( is.null(dimnames(res)) )
+ dimnames(res) <- dimnames(seed)
+
+ res
+}
+
+# check result
+.checkResult <- function(fit, seed){
+ # check the result is of the right type
+ if( !inherits(fit, 'NMFfit') ){
+ return(str_c("NMF algorithms should return an instance of class 'NMFfit' [returned class:", class(fit), "]"))
+ }
+
+ # check that the model has been fully estimated
+ if( is.partial.nmf(fit) ){
+ warning("nmf - The NMF model was only partially estimated [dim = (", str_out(dim(fit), Inf),")].")
+ }
+ # check that the fit conserved all fixed terms (only warning)
+ if( nterms(seed) ){
+ if( length(i <- icterms(seed)) && !identical(coef(fit)[i,], coef(seed)[i,]) ){
+ warning("nmf - Fixed coefficient terms were not all conserved in the fit: the method might not support them.")
+ }
+ if( length(i <- ibterms(seed)) && !identical(basis(fit)[,i], basis(seed)[,i]) ){
+ warning("nmf - Fixed basis terms were not all conserved in the fit: the method might not support them.")
+ }
+ }
+ TRUE
+}
+
+#' Interface for NMF Seeding Methods
+#'
+#' @description
+#' The function \code{seed} provides a single interface for calling all seeding
+#' methods used to initialise NMF computations.
+#' These methods at least set the basis and coefficient matrices of the initial
+#' \code{object} to valid nonnegative matrices.
+#' They will be used as a starting point by any NMF algorithm that accept
+#' initialisation.
+#'
+#' IMPORTANT: this interface is still considered experimental and is subject
+#' to changes in future release.
+#'
+#' @param x target matrix one wants to approximate with NMF
+#' @param model specification of the NMF model, e.g., the factorization rank.
+#' @param method specification of a seeding method.
+#' See each method for details on the supported formats.
+#' @param ... extra to allow extensions and passed down to the actual seeding method.
+#'
+#' @return an \code{\linkS4class{NMFfit}} object.
+#'
+#' @inline
+#' @export
+setGeneric('seed', function(x, model, method, ...) standardGeneric('seed') )
+
+#' This is the workhorse method that seeds an NMF model object using a given
+#' seeding strategy defined by an \code{NMFSeed} object, to fit a given
+#' target matrix.
+#'
+#' @param rng rng setting to use.
+#' If not missing the RNG settings are set and restored on exit using
+#' \code{\link{setRNG}}.
+#'
+#' All arguments in \code{...} are passed to teh seeding strategy.
+#'
+setMethod('seed', signature(x='matrix', model='NMF', method='NMFSeed'),
+ function(x, model, method, rng, ...){
+
+ # debug message
+ nmf.debug('seed', "use seeding method: '", name(method), "'")
+
+ # temporarly set the RNG if provided
+ if( !missing(rng) ){
+ orng <- setRNG(rng)
+ on.exit(setRNG(orng))
+ }
+
+ # save the current RNG numerical seed
+ rng.s <- getRNG()
+ # create the result NMFfit object, storing the RNG numerical seed
+ res <- NMFfit()
+ # ASSERT: check that the RNG seed is correctly set
+ stopifnot( rng.equal(res,rng.s) )
+ # call the seeding function passing the extra parameters
+ f <- do.call(algorithm(method), c(list(model, x), ...))
+ # set the dimnames from the target matrix
+ dimnames(f) <- dimnames(x)
+ # set the basis names from the model if any
+ if( !is.null(basisnames(model)) )
+ basisnames(f) <- basisnames(model)
+ # store the result into the NMFfit object
+ fit(res) <- f
+
+ # if not already set: store the seeding method's name in the resulting object
+ if( seeding(res) == '' ) seeding(res) <- name(method)
+
+ # return the seeded object
+ res
+ }
+)
+#' Seeds an NMF model using a custom seeding strategy, defined by a function.
+#'
+#' \code{method} must have signature \code{(x='NMFfit', y='matrix', ...)}, where
+#' \code{x} is the unseeded NMF model and \code{y} is the target matrix to fit.
+#' It must return an \code{\linkS4class{NMF}} object, that contains the seeded
+#' NMF model.
+#'
+#' @param name optional name of the seeding method for custom seeding strategies.
+#'
+setMethod('seed', signature(x='ANY', model='ANY', method='function'),
+ function(x, model, method, name, ...){
+
+ # generate runtime name if necessary
+ if( missing(name) ) name <- basename(tempfile("NMF.seed."))
+ # check that the name is not a registered name
+ if( existsNMFSeed(name) )
+ stop("Invalid name for custom seeding method: '",name,"' is already a registered seeding method")
+
+ # wrap function method into a new NMFSeed object
+ seedObj <- new('NMFSeed', name=name, method=method)
+ # call version with NMFSeed
+ seed(x, model, seedObj, ...)
+ }
+)
+#' Seeds the model with the default seeding method given by
+#' \code{nmf.getOption('default.seed')}
+setMethod('seed', signature(x='ANY', model='ANY', method='missing'),
+ function(x, model, method, ...){
+ seed(x, model, nmf.getOption('default.seed'), ...)
+ }
+)
+#' Use NMF method \code{'none'}.
+setMethod('seed', signature(x='ANY', model='ANY', method='NULL'),
+ function(x, model, method, ...){
+ seed(x, model, 'none', ...)
+ }
+)
+#' Use \code{method} to set the RNG with \code{\link{setRNG}} and use method
+#' \dQuote{random} to seed the NMF model.
+#'
+#' Note that in this case the RNG settings are not restored.
+#' This is due to some internal technical reasons, and might change in future
+#' releases.
+setMethod('seed', signature(x='ANY', model='ANY', method='numeric'),
+ function(x, model, method, ...){
+
+ # set the seed using the numerical value by argument 'method'
+ orng <- setRNG(method)
+ #TODO: restore the RNG state?
+
+ # call seeding method 'random'
+ res <- seed(x, model, 'random', ...)
+
+ # return result
+ return(res)
+ }
+)
+#setMethod('seed', signature(x='ANY', model='ANY', method='rstream'),
+# function(x, model, method, ...){
+#
+# # set the seed using the numerical value by argument 'method'
+# orng <- setRNG(method)
+# #TODO: restore the RNG state?
+#
+# # call seeding method 'random'
+# res <- seed(x, model, 'random', ...)
+#
+# # return result
+# return(res)
+# }
+#)
+#' Use the registered seeding method whose access key is \code{method}.
+setMethod('seed', signature(x='ANY', model='ANY', method='character'),
+ function(x, model, method, ...){
+
+ # get the seeding method from the registry
+ seeding.fun <- nmfSeed(method)
+
+ #Vc#Use seeding method: '${method}'
+ # call 'seed' with the seeding.function
+ seed(x, model, method=seeding.fun, ...)
+
+ }
+)
+#' Seed a model using the elements in \code{model} to instantiate it with
+#' \code{\link{nmfModel}}.
+setMethod('seed', signature(x='ANY', model='list', method='NMFSeed'),
+ function(x, model, method, ...){
+
+ ## check validity of the list: there should be at least the NMF (sub)class name and the rank
+ if( length(model) < 2 )
+ stop("Invalid parameter: list 'model' must contain at least two elements giving the model's class name and the factorization rank")
+
+ # 'model' must contain an element giving the class to instanciate
+ if( is.null(model$model) ){
+
+ err.msg <- "Invalid parameter: list 'model' must contain a valid NMF model classname in an element named 'model' or in its first un-named element"
+ unamed <- if( !is.null(names(model)) ) which(names(model) %in% c('', NA)) else 1
+ if ( length(unamed) > 0 ){ # if not the first unamed element is taken as the class name
+ idx <- unamed[1]
+ val <- unlist(model[idx], recursive=FALSE)
+ if( is.character(val) && length(val)==1 && extends(val, 'NMF') )
+ names(model)[idx] <- 'model'
+ else stop(err.msg)
+ }else stop(err.msg)
+ }
+
+ # 'model' must contain an element giving the factorization rank
+ if( is.null(model$rank) ){
+ err.msg <- "Invalid parameter: list 'model' must contain the factorization rank in an element named 'rank' or in its second un-named element"
+ unamed <- if( !is.null(names(model)) ) which(names(model) %in% c('', NA)) else 1
+ if ( length(unamed) > 0 ){ # if not the second element is taken as the factorization rank
+ idx <- unamed[1]
+ val <- unlist(model[idx], recursive=FALSE)
+ if( is.numeric(val) && length(val)==1 )
+ names(model)[idx] <- 'rank'
+ else stop(err.msg)
+ }
+ else stop(err.msg)
+ }
+
+ nmf.debug('seed', "using model parameters:\n", capture.output(print(model)) )
+ # instantiate the object using the factory method
+ model <- do.call('nmfModel', model)
+ nmf.debug('seed', "using NMF model '", class(model), "'")
+
+ # check that model is from the right type, i.e. inherits from class NMF
+ if( !inherits(model, 'NMF') ) stop("Invalid object returned by model: object must inherit from class 'NMF'")
+
+ seed(x, model, method, ...)
+ }
+)
+#' Seeds a standard NMF model (i.e. of class \code{\linkS4class{NMFstd}}) of rank
+#' \code{model}.
+setMethod('seed', signature(x='ANY', model='numeric', method='NMFSeed'),
+ function(x, model, method, ...){
+
+ seed(x, nmfModel(model), method, ...)
+ }
+)
+
+
+###% Extract from a list the elements that can be used to initialize the slot of a class.
+###%
+###% This function only extract named elements.
+###%
+###% @param class.name Name of the class from whose slots will be search into '...'
+###% @param ... The parameters in which the slot names will be search for
+###%
+###% @return a list with two elements:
+###% - \code{slots}: is a list that contains the named parameters that can be used to instantiate an object of class \code{class.name}
+###% - \code{extra}: is a list of the remaining parameters from \code{parameters} (i.e. the ones that do not correspond to a slot).
+###%
+.extract.slots.parameters <- function(class.name, ...){
+
+ # check validity of class.name
+ if( !isClass(class.name) ) stop("Invalid class name: class '", class.name, "' dose not exist")
+
+ # transform '...' into a list
+ parameters <- list(...)
+
+ if( length(parameters) == 1L && is.null(names(parameters)) ){
+ parameters <- parameters[[1L]]
+ }
+
+ # get the slots from the class name
+ slots <- slotNames(class.name)
+ # get the named parameters that correspond to a slot
+ in.slots <- is.element(names(parameters), slots)
+ # return the two lists
+ list( slots=parameters[in.slots], extra=parameters[!in.slots])
+}
+
+###% Merges two lists, but overriding with the values of the second list in the case
+###% of duplicates.
+.merge.override <- function(l1, l2, warning=FALSE){
+ sapply(names(l2), function(name){
+ if( warning && !is.null(l1[[name]]) )
+ warning("overriding element '", name, "'")
+ l1[[name]] <<- l2[[name]]
+ })
+
+ # return updated list
+ return(l1)
+}
+
+#' Estimate Rank for NMF Models
+#'
+#' A critical parameter in NMF algorithms is the factorization rank \eqn{r}.
+#' It defines the number of basis effects used to approximate the target
+#' matrix.
+#' Function \code{nmfEstimateRank} helps in choosing an optimal rank by
+#' implementing simple approaches proposed in the literature.
+#'
+#' Note that from version \emph{0.7}, one can equivalently call the
+#' function \code{\link{nmf}} with a range of ranks.
+#'
+#' @details
+#' Given a NMF algorithm and the target matrix, a common way of estimating
+#' \eqn{r} is to try different values, compute some quality measures of the
+#' results, and choose the best value according to this quality criteria. See
+#' \cite{Brunet2004} and \cite{Hutchins2008}.
+#'
+#' The function \code{nmfEstimateRank} allows to perform this estimation
+#' procedure.
+#' It performs multiple NMF runs for a range of rank of
+#' factorization and, for each, returns a set of quality measures together with
+#' the associated consensus matrix.
+#'
+#' In order to avoid overfitting, it is recommended to run the same procedure on
+#' randomized data.
+#' The results on the original and the randomised data may be plotted on the
+#' same plots, using argument \code{y}.
+#'
+#' @param x For \code{nmfEstimateRank} a target object to be estimated, in one
+#' of the format accepted by interface \code{\link{nmf}}.
+#'
+#' For \code{plot.NMF.rank} an object of class \code{NMF.rank} as returned by
+#' function \code{nmfEstimateRank}.
+#' @param range a \code{numeric} vector containing the ranks of factorization
+#' to try.
+#' Note that duplicates are removed and values are sorted in increasing order.
+#' The results are notably returned in this order.
+#'
+#' @param method A single NMF algorithm, in one of the format accepted by
+#' the function \code{\link{nmf}}.
+#'
+#' @param nrun a \code{numeric} giving the number of run to perform for each
+#' value in \code{range}.
+#'
+#' @param model model specification passed to each \code{nmf} call.
+#' In particular, when \code{x} is a formula, it is passed to argument
+#' \code{data} of \code{\link{nmfModel}} to determine the target matrix -- and
+#' fixed terms.
+#'
+#' @param verbose toggle verbosity. This parameter only affects the verbosity
+#' of the outer loop over the values in \code{range}.
+#' To print verbose (resp. debug) messages from each NMF run, one can use
+#' \code{.options='v'} (resp. \code{.options='d'})
+#' that will be passed to the function \code{\link{nmf}}.
+#'
+#' @param stop logical flag for running the estimation process with fault
+#' tolerance. When \code{TRUE}, the whole execution will stop if any error is
+#' raised. When \code{FALSE} (default), the runs that raise an error will be
+#' skipped, and the execution will carry on. The summary measures for the runs
+#' with errors are set to NA values, and a warning is thrown.
+#'
+#' @param ... For \code{nmfEstimateRank}, these are extra parameters passed
+#' to interface \code{nmf}. Note that the same parameters are used for each
+#' value of the rank. See \code{\link{nmf}}.
+#'
+#' For \code{plot.NMF.rank}, these are extra graphical parameter passed to the
+#' standard function \code{plot}. See \code{\link{plot}}.
+#'
+#' @return
+#' \code{nmfEstimateRank} returns a S3 object (i.e. a list) of class
+#' \code{NMF.rank} with the following elements:
+#'
+#' \item{measures }{a \code{data.frame} containing the quality
+#' measures for each rank of factorizations in \code{range}. Each row
+#' corresponds to a measure, each column to a rank. }
+#' \item{consensus }{ a
+#' \code{list} of consensus matrices, indexed by the rank of factorization (as
+#' a character string).}
+#' \item{fit }{ a \code{list} of the fits, indexed by the rank of factorization
+#' (as a character string).}
+#'
+#' @export
+#' @examples
+#'
+#' if( !isCHECK() ){
+#'
+#' set.seed(123456)
+#' n <- 50; r <- 3; m <- 20
+#' V <- syntheticNMF(n, r, m)
+#'
+#' # Use a seed that will be set before each first run
+#' res <- nmfEstimateRank(V, seq(2,5), method='brunet', nrun=10, seed=123456)
+#' # or equivalently
+#' res <- nmf(V, seq(2,5), method='brunet', nrun=10, seed=123456)
+#'
+#' # plot all the measures
+#' plot(res)
+#' # or only one: e.g. the cophenetic correlation coefficient
+#' plot(res, 'cophenetic')
+#'
+#' # run same estimation on randomized data
+#' rV <- randomize(V)
+#' rand <- nmfEstimateRank(rV, seq(2,5), method='brunet', nrun=10, seed=123456)
+#' plot(res, rand)
+#' }
+#'
+nmfEstimateRank <- function(x, range, method=nmf.getOption('default.algorithm')
+ , nrun=30, model=NULL, ..., verbose=FALSE, stop=FALSE){
+
+ # fix method if passed NULL (e.g., from nmf('formula', 'numeric'))
+ if( is.null(method) )
+ method <- nmf.getOption('default.algorithm')
+
+ # special handling of formula: get target data from the formula
+ if( is(x, 'formula') ){
+ # dummy model to resolve formula
+ dummy <- nmfModel(x, 0L, data=model)
+ # retrieve target data
+ V <- attr(dummy, 'target')
+ }else{
+ V <- x
+ }
+
+ # remove duplicates and sort
+ range <- sort(unique(range))
+
+ # initiate the list of consensus matrices: start with single NA values
+ c.matrices <- setNames(lapply(range, function(x) NA), as.character(range))
+ fit <- setNames(lapply(range, function(x) NA), as.character(range))
+ bootstrap.measures <- list()
+
+ # combine function: take all the results at once and merge them into a big matrix
+ comb <- function(...){
+ measures <- list(...)
+
+ err <- which( sapply(measures, is.character) )
+ if( length(err) == length(measures) ){ # all runs produced an error
+
+ # build an warning using the error messages
+ msg <- paste(paste("#", seq_along(range),' ', measures, sep=''), collapse="\n\t-")
+ stop("All the runs produced an error:\n\t-", msg)
+
+ }else if( length(err) > 0 ){ # some of the runs returned an error
+
+ # simplify the results with no errors into a matrix
+ measures.ok <- sapply(measures[-err], function(x) x)
+
+ # build a NA matrix for all the results
+ n <- nrow(measures.ok)
+ tmp.res <- matrix(as.numeric(NA), n, length(range))
+ rownames(tmp.res) <- rownames(measures.ok)
+
+ # set the results that are ok
+ tmp.res[,-err] <- measures.ok
+ # set only the rank for the error results
+ tmp.res['rank', err] <- range[err]
+ # build an warning using the error messages
+ msg <- paste(paste("#", err, measures[err], ' ', sep=''), collapse="\n\t-")
+ warning("NAs were produced due to errors in some of the runs:\n\t-", msg)
+
+ # return full matrix
+ tmp.res
+ }
+ else # all the runs are ok
+ sapply(measures, function(x) x)
+ }
+
+# measures <- foreach(r = range, .combine=comb, .multicombine=TRUE, .errorhandling='stop') %do% {
+ k.rank <- 0
+ measures <- sapply(range, function(r, ...){
+ k.rank <<- k.rank + 1L
+ if( verbose ) cat("Compute NMF rank=", r, " ... ")
+
+ # restore RNG on exit (except after last rank)
+ # => this ensures the methods use the same stochastic environment
+ orng <- RNGseed()
+ if( k.rank < length(range) ) on.exit( RNGseed(orng), add = TRUE)
+
+ res <- tryCatch({ #START_TRY
+
+ res <- nmf(x, r, method, nrun=nrun, model=model, ...)
+ # directly return the result if a valid NMF result
+ if( !isNMFfit(res, recursive = FALSE) )
+ return(res)
+
+ # store the consensus matrix
+ c.matrices[[as.character(r)]] <<- consensus(res)
+ # store the fit
+ fit[[as.character(r)]] <<- res
+
+ # if confidence intervals must be computed then do it
+ # if( conf.interval ){
+ # # resample the tries
+ # samp <- sapply(seq(5*nrun), function(i){ sample(nrun, nrun, replace=TRUE) })
+ #
+ # bootstrap.measures[[as.character(r)]] <<- apply(samp, 2, function(s){
+ # res.sample <- join(res[s])
+ # summary(res.sample, target=x)
+ # })
+ # }
+
+ # compute quality measures
+ if( verbose ) cat('+ measures ... ')
+ measures <- summary(res, target=V)
+
+ if( verbose ) cat("OK\n")
+
+ # return the measures
+ measures
+ } #END_TRY
+
+ , error = function(e) {
+ mess <- if( is.null(e$call) ) e$message else paste(e$message, " [in call to '", e$call[1],"']", sep='')
+ mess <- paste('[r=', r, '] -> ', mess, sep='')
+ if( stop ){ # throw the error
+ if( verbose ) cat("\n")
+ stop(mess, call.=FALSE)
+ } # pass the error message
+ if( verbose ) message("ERROR")
+ return(mess)
+ }
+ )
+
+ # return the result
+ res
+ }
+ , ..., simplify=FALSE)
+
+ measures <- do.call(comb, measures)
+
+ # reformat the result into a data.frame
+ measures <- as.data.frame(t(measures))
+
+ # wrap-up result into a 'NMF.rank' S3 object
+ res <- list(measures=measures, consensus=c.matrices, fit=fit)
+ #if( conf.interval ) res$bootstrap.measure <- bootstrap.measures
+ class(res) <- 'NMF.rank'
+ return(res)
+
+}
+
+#' @S3method summary NMF.rank
+summary.NMF.rank <- function(object, ...){
+ s <- summary(new('NMFList', object$fit), ...)
+ # NB: sort measures in the same order as required in ...
+ i <- which(!names(s) %in% names(object$measures))
+ cbind(s[, i], object$measures[match(object$measures$rank, s$rank), ])
+}
+
+
+#' \code{plot.NMF.rank} plots the result of rank estimation survey.
+#'
+#' In the plot generated by \code{plot.NMF.rank}, each curve represents a
+#' summary measure over the range of ranks in the survey.
+#' The colours correspond to the type of data to which the measure is related:
+#' coefficient matrix, basis component matrix, best fit, or consensus matrix.
+#'
+#' @param y reference object of class \code{NMF.rank}, as returned by
+#' function \code{nmfEstimateRank}.
+#' The measures contained in \code{y} are used and plotted as a reference.
+#' It is typically used to plot results obtained from randomized data.
+#' The associated curves are drawn in \emph{red} (and \emph{pink}),
+#' while those from \code{x} are drawn in \emph{blue} (and \emph{green}).
+#' @param what a \code{character} vector whose elements partially match
+#' one of the following item, which correspond to the measures computed
+#' by \code{\link{summary}} on each -- multi-run -- NMF result:
+#' \sQuote{all}, \sQuote{cophenetic}, \sQuote{rss},
+#' \sQuote{residuals}, \sQuote{dispersion}, \sQuote{evar},
+#' \sQuote{silhouette} (and more specific *.coef, *.basis, *.consensus),
+#' \sQuote{sparseness} (and more specific *.coef, *.basis).
+#' It specifies which measure must be plotted (\code{what='all'} plots
+#' all the measures).
+#' @param na.rm single logical that specifies if the rank for which the
+#' measures are NA values should be removed from the graph or not (default to
+#' \code{FALSE}). This is useful when plotting results which include NAs due
+#' to error during the estimation process. See argument \code{stop} for
+#' \code{nmfEstimateRank}.
+#' @param xname,yname legend labels for the curves corresponding to measures from
+#' \code{x} and \code{y} respectively
+#' @param xlab x-axis label
+#' @param ylab y-axis label
+#' @param main main title
+#'
+#' @S3method plot NMF.rank
+#' @rdname nmfEstimateRank
+#' @import ggplot2
+#' @import reshape2
+plot.NMF.rank <- function(x, y=NULL, what=c('all', 'cophenetic', 'rss', 'residuals'
+ , 'dispersion', 'evar', 'sparseness'
+ , 'sparseness.basis', 'sparseness.coef'
+ , 'silhouette'
+ , 'silhouette.coef', 'silhouette.basis'
+ , 'silhouette.consensus')
+ , na.rm=FALSE
+ , xname = 'x'
+ , yname = 'y'
+ , xlab = 'Factorization rank'
+ , ylab = ''
+ , main = 'NMF rank survey'
+ , ... ){
+
+
+ # trick for convenience
+ if( is.character(y) && missing(what) ){
+ what <- y
+ y <- NULL
+ }
+
+ what <- match.arg(what, several.ok=TRUE)
+ if( 'all' %in% what ){
+ what <- c('cophenetic', 'rss', 'residuals', 'dispersion', 'evar', 'sparseness', 'silhouette')
+ }
+
+ .getvals <- function(x, xname){
+ measures <- x$measures
+ iwhat <- unlist(lapply(paste('^',what,sep=''), grep, colnames(measures)))
+
+ # remove NA values if required
+ if( na.rm )
+ measures <- measures[ apply(measures, 1, function(row) !any(is.na(row[iwhat]))), ]
+
+ vals <- measures[,iwhat, drop=FALSE]
+ x <- as.numeric(measures$rank)
+ xlim <- range(x)
+
+ # define measure type
+ measure.type <- setNames(rep('Best fit', ncol(measures)), colnames(measures))
+ cons.measures <- c('silhouette.consensus', 'cophenetic', 'cpu.all')
+ measure.type[match(cons.measures, names(measure.type))] <- 'Consensus'
+ measure.type[grep("\\.coef$", names(measure.type))] <- 'Coefficients'
+ measure.type[grep("\\.basis$", names(measure.type))] <- 'Basis'
+ measure.type <- factor(measure.type)
+
+ pdata <- melt(cbind(rank = x, vals), id.vars = 'rank')
+ # set measure type
+ pdata$Type <- measure.type[as.character(pdata$variable)]
+ # define measure groups
+ pdata$Measure <- gsub("^([^.]+).*", "\\1", pdata$variable)
+ pdata$Data <- xname
+ pdata
+ }
+
+ pdata <- .getvals(x, xname)
+
+ # add reference data
+ if( is(y, 'NMF.rank') ){
+ pdata.y <- .getvals(y, yname)
+ pdata <- rbind(pdata, pdata.y)
+ }
+
+ p <- ggplot(pdata, aes_string(x = 'rank', y = 'value')) +
+ geom_line( aes_string(linetype = 'Data', colour = 'Type') ) +
+ geom_point(size = 2, aes_string(shape = 'Data', colour = 'Type') ) +
+ theme_bw() +
+ scale_x_continuous(xlab, breaks = unique(pdata$rank)) +
+ scale_y_continuous(ylab) +
+ ggtitle(main)
+ # remove legend if not necessary
+ if( !is(y, 'NMF.rank') ){
+ p <- p + scale_shape(guide = 'none') + scale_linetype(guide = 'none')
+ }
+
+ # use fix set of colors
+ myColors <- brewer.pal(5,"Set1")
+ names(myColors) <- levels(pdata$Type)
+ p <- p + scale_colour_manual(name = "Measure type", values = myColors)
+
+ # add facet
+ p <- p + facet_wrap( ~ Measure, scales = 'free')
+
+ # return plot
+ p
+}
+
diff --git a/R/nmfModel.R b/R/nmfModel.R
new file mode 100644
index 0000000..d0288e6
--- /dev/null
+++ b/R/nmfModel.R
@@ -0,0 +1,765 @@
+# Factory/Constructor Methods for NMF models
+#
+# Author: Renaud Gaujoux
+# Creation: 03 Jul 2012
+###############################################################################
+
+#' @include NMFstd-class.R
+#' @include NMFns-class.R
+#' @include NMFOffset-class.R
+NULL
+
+#' Factory Methods NMF Models
+#'
+#' \code{nmfModel} is a S4 generic function which provides a convenient way to
+#' build NMF models.
+#' It implements a unified interface for creating \code{NMF} objects from any
+#' NMF models, which is designed to resolve potential dimensions inconsistencies.
+#'
+#' All \code{nmfModel} methods return an object that inherits from class \code{NMF},
+#' that is suitable for seeding NMF algorithms via arguments \code{rank} or
+#' \code{seed} of the \code{\link{nmf}} method, in which case the factorisation
+#' rank is implicitly set by the number of basis components in the seeding
+#' model (see \code{\link{nmf}}).
+#'
+#' For convenience, shortcut methods and internal conversions for working on
+#' \code{data.frame} objects directly are implemented.
+#' However, note that conversion of a \code{data.frame} into a \code{matrix}
+#' object may take some non-negligible time, for large datasets.
+#' If using this method or other NMF-related methods several times, consider
+#' converting your data \code{data.frame} object into a matrix once for good,
+#' when first loaded.
+#'
+#' @param rank specification of the target factorization rank
+#' (i.e. the number of components).
+#' @param target an object that specifies the dimension of the estimated target matrix.
+#' @param ... extra arguments to allow extension, that are passed down to the
+#' workhorse method \code{nmfModel,numeric.numeric}, where they are used to
+#' initialise slots specific to the instantiating NMF model class.
+#'
+#' @return an object that inherits from class \code{\linkS4class{NMF}}.
+#' @family NMF-interface
+#' @export
+#' @inline
+setGeneric('nmfModel', function(rank, target=0L, ...) standardGeneric('nmfModel'))
+
+#' Main factory method for NMF models
+#'
+#' This method is the workhorse method that is eventually called by all other methods.
+#' See section \emph{Main factory method} for more details.
+#'
+#' @param ncol a numeric value that specifies the number
+#' of columns of the target matrix, fitted the NMF model.
+#' It is used only if not missing and when argument \code{target} is a single
+#' numeric value.
+#' @param model the class of the object to be created.
+#' It must be a valid class name that inherits from class \code{NMF}.
+#' Default is the standard NMF model \code{\linkS4class{NMFstd}}.
+#' @param W value for the basis matrix.
+#' \code{data.frame} objects are converted into matrices with \code{\link{as.matrix}}.
+#' @param H value for the mixture coefficient matrix
+#' \code{data.frame} objects are converted into matrices with \code{\link{as.matrix}}.
+#' @param force.dim logical that indicates whether the method should try
+#' lowering the rank or shrinking dimensions of the input matrices to
+#' make them compatible
+#' @param order.basis logical that indicates whether the basis components should
+#' reorder the rows of the mixture coefficient matrix to match the order of the
+#' basis components, based on their respective names. It is only used if the
+#' basis and coefficient matrices have common unique column and row names
+#' respectively.
+#'
+#' @section Main factory method:
+#' The main factory engine of NMF models is implemented by the method with
+#' signature \code{numeric, numeric}.
+#' Other factory methods provide convenient ways of creating NMF models from e.g. a
+#' given target matrix or known basis/coef matrices (see section \emph{Other Factory Methods}).
+#'
+#' This method creates an object of class \code{model}, using the extra
+#' arguments in \code{...} to initialise slots that are specific to the given model.
+#'
+#' All NMF models implement get/set methods to access the matrix factors
+#' (see \code{\link{basis}}), which are called to initialise them from arguments
+#' \code{W} and \code{H}.
+#' These argument names derive from the definition of all built-in models that
+#' inherit derive from class \code{\linkS4class{NMFstd}}, which has two slots,
+#' \var{W} and \var{H}, to hold the two factors -- following the notations used
+#' in \cite{Lee1999}.
+#'
+#' If argument \code{target} is missing, the method creates a standard NMF
+#' model of dimension 0x\code{rank}x0.
+#' That is that the basis and mixture coefficient matrices, \var{W} and \var{H},
+#' have dimension 0x\code{rank} and \code{rank}x0 respectively.
+#'
+#' If target dimensions are also provided in argument \code{target} as a
+#' 2-length vector, then the method creates an \code{NMF} object compatible to
+#' fit a target matrix of dimension \code{target[1]}x\code{target[2]}.
+#' That is that the basis and mixture coefficient matrices, \var{W} and \var{H},
+#' have dimension \code{target[1]}x\code{rank} and \code{rank}x\code{target[2]}
+#' respectively.
+#' The target dimensions can also be specified using both arguments \code{target}
+#' and \code{ncol} to define the number of rows and the number of columns of the
+#' target matrix respectively.
+#' If no other argument is provided, these matrices are filled with NAs.
+#'
+#' If arguments \code{W} and/or \code{H} are provided, the method creates a NMF
+#' model where the basis and mixture coefficient matrices, \var{W} and \var{H},
+#' are initialised using the values of \code{W} and/or \code{H}.
+#'
+#' The dimensions given by \code{target}, \code{W} and \code{H}, must be compatible.
+#' However if \code{force.dim=TRUE}, the method will reduce the dimensions to the achieve
+#' dimension compatibility whenever possible.
+#'
+#' When \code{W} and \code{H} are both provided, the \code{NMF} object created is
+#' suitable to seed a NMF algorithm in a call to the \code{\link{nmf}} method.
+#' Note that in this case the factorisation rank is implicitly set by the number
+#' of basis components in the seed.
+#'
+#' @examples
+#'
+#' # data
+#' n <- 20; r <- 3; p <- 10
+#' V <- rmatrix(n, p) # some target matrix
+#'
+#' # create a r-ranked NMF model with a given target dimensions n x p as a 2-length vector
+#' nmfModel(r, c(n,p)) # directly
+#' nmfModel(r, dim(V)) # or from an existing matrix <=> nmfModel(r, V)
+#' # or alternatively passing each dimension separately
+#' nmfModel(r, n, p)
+#'
+#' # trying to create a NMF object based on incompatible matrices generates an error
+#' w <- rmatrix(n, r)
+#' h <- rmatrix(r+1, p)
+#' try( new('NMFstd', W=w, H=h) )
+#' try( nmfModel(w, h) )
+#' try( nmfModel(r+1, W=w, H=h) )
+#' # The factory method can be force the model to match some target dimensions
+#' # but warnings are thrown
+#' nmfModel(r, W=w, H=h)
+#' nmfModel(r, n-1, W=w, H=h)
+#'
+setMethod('nmfModel', signature(rank='numeric', target='numeric'),
+ function(rank, target, ncol=NULL, model='NMFstd', W, H, ..., force.dim=TRUE, order.basis=TRUE){
+
+ if( is.null(model) ) model <- 'NMFstd'
+ # check validity of the provided class
+ if( !isClass(model) ) stop("nmfModel - Invalid model name: class '", model,"' is not defined.")
+ if( !extends(model, 'NMF') ) stop("nmfModel - Invalid model name: class '", model,"' does not extend class 'NMF'.")
+
+ # check the validity of the target
+ if( length(target) == 0 ) stop('nmfModel - Invalid dimensions: `target` must be at least of length 1')
+ if( length(target) > 2 ) stop('nmfModel - Invalid dimensions: `target` must be at most of length 2')
+ if( !missing(ncol) && !is.null(ncol) && (!is.vector(ncol) || length(ncol) > 1 || !is.numeric(ncol) || ncol<0 ) )
+ stop('nmfModel - Invalid dimensions: `ncol` must be a single nonnegative integer')
+
+ # compute the target dimension
+ target <- as.integer(target)
+ n <- target[1]
+ m <- if( length(target) == 2 ) target[2]
+ else if( !missing(ncol) && !is.null(ncol) ) ncol
+ else if( !missing(H) ) ncol(H)
+ else n
+ if( n < 0 )
+ stop("nmfModel - Invalid target number of rows: nonnegative value expected")
+ if( m < 0 )
+ stop("nmfModel - Invalid target number of columns: nonnegative value expected")
+ # force rank to be an integer
+ r <- as.integer(rank)
+
+ # check the validity of the rank
+ if( length(r) != 1 ) stop("Invalid argument 'rank': single numeric expected")
+ if( r < 0 ) stop("nmfModel - Invalid argument 'rank': nonnegative value expected")
+
+ # do not allow dimension incompatibility if required
+ if( !force.dim && !missing(W) && !missing(H) && ncol(W) != nrow(H) ){
+ stop('nmfModel - Invalid number of columns in the basis matrix [', ncol(W), ']: '
+ , 'it should match the number of rows in the mixture coefficient matrix [', nrow(H), ']')
+ }
+
+ # build dummy compatible W and H if necessary
+ W.was.missing <- FALSE
+ if( missing(W) ){
+ W <- matrix(as.numeric(NA), n, r)
+ W.was.missing <- TRUE
+ }
+ else{
+ if( is.vector(W) ) # convert numerical vectors into a matrix
+ W <- matrix(W, n, r)
+ else if( is.data.frame(W) ) # convert data.frame into matrix
+ W <- as.matrix(W)
+
+ if( r == 0 ) r <- ncol(W)
+ else if( r < ncol(W) ){
+ if( !force.dim ){
+ stop('nmfModel - Invalid number of columns in the basis matrix [', ncol(W), ']: ',
+ 'it should match the factorization rank [', r, ']')
+ }
+ warning("Objective rank is [",r,"] lower than the number of columns in W [",ncol(W),"]: "
+ , "only the first ", r," columns of W will be used")
+ W <- W[,1:r, drop=FALSE]
+ }
+ else if( r > ncol(W) ){
+ stop("nmfModel - Objective rank [",r,"] is greater than the number of columns in W [",ncol(W),"]")
+ }
+
+ # resolve consistency with target
+ if( n == 0 ) n <- nrow(W)
+ else if( n < nrow(W) ){
+ if( !force.dim ){
+ stop('nmfModel - Invalid number of rows in the basis matrix [', nrow(W), ']: '
+ , 'it should match the target number of rows [', n, ']')
+ }
+
+ warning("nmfModel - Number of rows in target is lower than the number of rows in W [",nrow(W),"]: ",
+ "only the first ", n," rows of W will be used")
+ W <- W[1:n, , drop=FALSE]
+ }
+ else if( n > nrow(W) ){
+ stop("nmfModel - Number of rows in target [",n,"] is greater than the number of rows in W [",nrow(W),"]")
+ }
+ }
+
+ if( missing(H) )
+ H <- matrix(as.numeric(NA), ncol(W), m)
+ else{
+ # convert numerical vectors into a matrix
+ if( is.vector(H) )
+ H <- matrix(H, r, m)
+ else if( is.data.frame(H) ) # convert data.frame into matrix
+ H <- as.matrix(H)
+
+ if( r == 0 ) r <- nrow(H)
+ else if( r < nrow(H) ){
+ if( !force.dim ){
+ stop('nmfModel - Invalid number of rows in the mixture coefficient matrix [', nrow(H), ']: '
+ , 'it should match the factorization rank [', r, ']')
+ }
+ warning("nmfModel - Objective rank [",r,"] is lower than the number of rows in H [",nrow(H),"]: "
+ , "only the first ", r," rows of H will be used")
+ H <- H[1:r,, drop=FALSE]
+ }
+ else if( r > nrow(H) ) stop("nmfModel - Objective rank [",r,"] is greater than the number of rows in H [",nrow(H),"]")
+ # force dummy W to be at least compatible with H
+ if( W.was.missing ) W <- matrix(as.numeric(NA), n, r)
+
+ # resolve consistency with target
+ if( m == 0 ) m <- ncol(H)
+ else if( m < ncol(H) ){
+ if( !force.dim ){
+ stop('nmfModel - Invalid number of columns in the mixture coefficient matrix [', ncol(H), ']:'
+ , ' it should match the target number of columns [', m, ']')
+ }
+
+ warning("nmfModel - Number of columns in target is lower than the number of columns in H [",ncol(H),"]:"
+ , " only the first ", m," columns of H will be used")
+ H <- H[, 1:m, drop=FALSE]
+ }
+ else if( m > ncol(H) ){
+ stop("nmfModel - Number of columns in target [",m,"]"
+ ," is greater than the number of columns in H [",ncol(H),"]")
+ }
+ }
+
+ # check validity of matrices W and H (only if one of the target dimension is not null)
+ if( n + m > 0 ){
+ if( nrow(W) != n ) stop('nmfModel - Invalid number of rows for W: should match number of rows in target [', n, ']')
+ if( ncol(W) != r ) stop('nmfModel - Invalid number of columns for W: should match factorization rank [', r, ']')
+ if( nrow(H) != r ) stop('nmfModel - Invalid number of rows for H: should match factorization rank [', r, ']')
+ if( ncol(H) != m ) stop('nmfModel - Invalid number of columns for H: should match number of columns in target [', m, ']')
+ }
+
+ # build and return a dummy NMF object
+ nmf.debug('nmfModel', "Instantiate NMF model:", model)
+ res <- new(model, ...)
+ nmf.debug('nmfModel', "Set factors in model:", model)
+ # set the dimnames if possible
+ cW <- !is.null(colnames(W))
+ rH <- !is.null(rownames(H))
+ if( cW && !rH )# use colnames of W as basisnames
+ rownames(H) <- colnames(W)
+ else if( !cW && rH )# use rownames of H as basisnames
+ colnames(W) <- rownames(H)
+ else if( cW && rH ){# try to match names or use colnames of W (with a warning)
+
+ # reorder as in the basis matrix if it makes sense, i.e. if the names are the same
+ if( order.basis && !anyDuplicated(rownames(H)) && length(setdiff(rownames(H), colnames(W)))==0 ){
+ H <- H[match(rownames(H), colnames(W)),]
+ }
+ else{
+ rownames(H) <- colnames(W)
+ warning("nmfModel - The rownames of the mixture matrix were set to match the colnames of the basis matrix")
+ }
+
+ }
+ # set the basis and coef matrices
+ .basis(res) <- W; .coef(res) <- H
+ # check validity
+ validObject(res)
+
+ # return the model
+ res
+ }
+)
+
+#' Creates an empty NMF model of a given rank.
+#'
+#' This call is equivalent to \code{nmfModel(rank, 0L, ...)}, which
+#' creates \emph{empty} \code{NMF} object with a basis and mixture coefficient matrix
+#' of dimension 0 x \code{rank} and \code{rank} x 0 respectively.
+#'
+#' @seealso \code{\link{is.empty.nmf}}
+#' @examples
+#' ## Empty model of given rank
+#' nmfModel(3)
+#'
+setMethod('nmfModel', signature(rank='numeric', target='missing'),
+ function(rank, target, ...){
+ nmfModel(rank, 0L, ...)
+ }
+)
+
+#' Creates an empty NMF model of null rank and a given dimension.
+#'
+#' This call is equivalent to \code{nmfModel(0, target, ...)}.
+#'
+#' @examples
+#' nmfModel(target=10) #square
+#' nmfModel(target=c(10, 5))
+#'
+setMethod('nmfModel', signature(rank='missing', target='ANY'),
+ function(rank, target, ...){
+ nmfModel(0L, target, ...)
+ }
+)
+
+#' Creates an empty NMF model of null rank and given dimension.
+#'
+#' This call is equivalent to \code{nmfModel(0, target, ...)}, and is meant for
+#' internal usage only.
+setMethod('nmfModel', signature(rank='NULL', target='ANY'),
+ function(rank, target, ...){
+ nmfModel(0L, target, ...)
+ }
+)
+
+#' Creates an empty NMF model or from existing factors
+#'
+#' This method is equivalent to \code{nmfModel(0, 0, ..., force.dim=FALSE)}.
+#' This means that the dimensions of the NMF model will be taken from the optional
+#' basis and mixture coefficient arguments \code{W} and \code{H}.
+#' An error is thrown if their dimensions are not compatible.
+#'
+#' Hence, this method may be used to generate an NMF model from existing factor
+#' matrices, by providing the named arguments \code{W} and/or \code{H}:
+#'
+#' \code{nmfModel(W=w)} or \code{nmfModel(H=h)} or \code{nmfModel(W=w, H=h)}
+#'
+#' Note that this may be achieved using the more convenient interface is
+#' provided by the method \code{nmfModel,matrix,matrix} (see its dedicated description).
+#'
+#' See the description of the appropriate method below.
+#'
+#' @examples
+#'
+#' # Build an empty NMF model
+#' nmfModel()
+#'
+#' # create a NMF object based on one random matrix: the missing matrix is deduced
+#' # Note this only works when using factory method NMF
+#' n <- 50; r <- 3;
+#' w <- rmatrix(n, r)
+#' nmfModel(W=w)
+#'
+#' # create a NMF object based on random (compatible) matrices
+#' p <- 20
+#' h <- rmatrix(r, p)
+#' nmfModel(H=h)
+#'
+#' # specifies two compatible matrices
+#' nmfModel(W=w, H=h)
+#' # error if not compatible
+#' try( nmfModel(W=w, H=h[-1,]) )
+#'
+setMethod('nmfModel', signature(rank='missing', target='missing'),
+ function(rank, target, ...){
+ # build an a priori empty model (extra args may provide the true dimension)
+ # NB: do not allow dimension incompatibilities
+ nmfModel(0L, 0L, ..., force.dim=FALSE)
+ }
+)
+
+#' Creates an NMF model compatible with a target matrix.
+#'
+#' This call is equivalent to \code{nmfModel(rank, dim(target), ...)}.
+#' That is that the returned NMF object fits a target matrix of the same
+#' dimension as \code{target}.
+#'
+#' Only the dimensions of \code{target} are used to construct the \code{NMF} object.
+#' The matrix slots are filled with \code{NA} values if these are not specified
+#' in arguments \code{W} and/or \code{H}.
+#' However, dimension names are set on the return NMF model if present in
+#' \code{target} and argument \code{use.names=TRUE}.
+#'
+#' @param use.names a logical that indicates whether the dimension names of the
+#' target matrix should be set on the returned NMF model.
+#'
+#' @inline
+#' @examples
+#'
+#' # create a r-ranked NMF model compatible with a given target matrix
+#' obj <- nmfModel(r, V)
+#' all(is.na(basis(obj)))
+#'
+setMethod('nmfModel', signature(rank='numeric', target='matrix'),
+ function(rank, target, ..., use.names=TRUE){
+ # build an object compatible with the target's dimensions
+ res <- nmfModel(rank, dim(target), ...)
+
+ # try to set dimnames if it makes sense:
+ # set on target and not somehow already set on the result
+ if( use.names && !is.null(dimnames(target)) ){
+ dn <- dimnames(res)
+ if( is.null(dn) )
+ dn <- list(NULL, NULL, NULL)
+ if( is.null(rownames(res)) && !is.null(rownames(target)) )
+ dimnames(res) <- c(dimnames(target)[1], dn[2:3])
+ if( is.null(colnames(res)) && !is.null(colnames(target)) )
+ dimnames(res) <- c(dimnames(res)[1], dimnames(target)[2], dimnames(res)[3])
+ }
+ res
+ }
+)
+
+#' Creates an NMF model based on two existing factors.
+#'
+#' This method is equivalent to \code{nmfModel(0, 0, W=rank, H=target..., force.dim=FALSE)}.
+#' This allows for a natural shortcut for wrapping existing \strong{compatible}
+#' matrices into NMF models:
+#' \samp{nmfModel(w, h)}
+#'
+#' Note that an error is thrown if their dimensions are not compatible.
+#'
+#' @examples
+#' ## From two existing factors
+#'
+#' # allows a convenient call without argument names
+#' w <- rmatrix(n, 3); h <- rmatrix(3, p)
+#' nmfModel(w, h)
+#'
+#' # Specify the type of NMF model (e.g. 'NMFns' for non-smooth NMF)
+#' mod <- nmfModel(w, h, model='NMFns')
+#' mod
+#'
+#' # One can use such an NMF model as a seed when fitting a target matrix with nmf()
+#' V <- rmatrix(mod)
+#' res <- nmf(V, mod)
+#' nmf.equal(res, nmf(V, mod))
+#'
+#' # NB: when called only with such a seed, the rank and the NMF algorithm
+#' # are selected based on the input NMF model.
+#' # e.g. here rank was 3 and the algorithm "nsNMF" is used, because it is the default
+#' # algorithm to fit "NMFns" models (See ?nmf).
+#'
+setMethod('nmfModel', signature(rank='matrix', target='matrix'),
+ function(rank, target, ...){
+ # use rank and target as W and H respectively
+ # NB: do not allow dimension incompatibilities
+ nmfModel(0L, 0L, W=rank, H=target, ..., force.dim=FALSE)
+
+ }
+)
+
+#' Same as \code{nmfModel('matrix', 'matrix')} but for \code{data.frame} objects,
+#' which are generally produced by \code{\link{read.delim}}-like functions.
+#'
+#' The input \code{data.frame} objects are converted into matrices with
+#' \code{\link{as.matrix}}.
+setMethod('nmfModel', signature(rank='data.frame', target='data.frame'),
+ function(rank, target, ...){
+ nmfModel(as.matrix(rank), as.matrix(target), ...)
+ }
+)
+
+#' Creates an NMF model with arguments \code{rank} and \code{target} swapped.
+#'
+#' This call is equivalent to \code{nmfModel(rank=target, target=rank, ...)}.
+#' This allows to call the \code{nmfModel} function with arguments \code{rank}
+#' and \code{target} swapped.
+#' It exists for convenience:
+#' \itemize{
+#' \item allows typing \code{nmfModel(V)} instead of \code{nmfModel(target=V)} to create
+#' a model compatible with a given matrix \code{V} (i.e. of dimension \code{nrow(V), 0, ncol(V)})
+#' \item one can pass the arguments in any order (the one that comes to the user's mind first)
+#' and it still works as expected.
+#' }
+#'
+#' @examples
+#' ## swapped arguments `rank` and `target`
+#' V <- rmatrix(20, 10)
+#' nmfModel(V) # equivalent to nmfModel(target=V)
+#' nmfModel(V, 3) # equivalent to nmfModel(3, V)
+#'
+setMethod('nmfModel', signature(rank='matrix', target='ANY'),
+ function(rank, target, ...){
+ if( missing(target) ) target <- NULL
+ # call nmfModel with swapping the arguments
+ nmfModel(target, rank, ...)
+
+ }
+)
+
+#' Simple Parsing of Formula
+#'
+#' Formula parser for formula-based NMF models.
+#'
+#' @param x formula to parse
+#' @return a list with the following elements:
+#' \item{response}{ logical that indicates if the formula has a response term.}
+#' \item{y}{ name of the response variable.}
+#' \item{x}{ list of regressor variable names.}
+#' \item{n}{ number of regressor variables.}
+#'
+#' @keywords internal
+parse_formula <- function(x){
+
+ res <- list()
+ # parse formula
+ f <- as.character(x)
+ hasResponse <- length(f) == 3L
+ # response
+ res$response <- hasResponse
+ res$y <- if( hasResponse ) f[2L]
+ # regressors
+ reg <- if( hasResponse ) f[3L] else f[2L]
+ res$x <- strsplit(reg, ' ')[[1]]
+ res$n <- length(res$reg)
+ # as a tring
+ res$string <- paste(res$y, '~', reg, collapse='')
+
+ res
+}
+#' Build a formula-based NMF model, that can incorporate fixed basis or
+#' coefficient terms.
+#'
+#' @param data Optional argument where to look for the variables used in the
+#' formula.
+#' @param no.attrib logical that indicate if attributes containing data related
+#' to the formula should be attached as attributes.
+#' If \code{FALSE} attributes \code{'target'} and \code{'formula'} contain the
+#' target matrix, and a list describing each formula part (response, regressors,
+#' etc.).
+#'
+#' @inline
+#'
+#' @examples
+#'
+#' # empty 3-rank model
+#' nmfModel(~ 3)
+#'
+#' # 3-rank model that fits a given data matrix
+#' x <- rmatrix(20,10)
+#' nmfModel(x ~ 3)
+#'
+#' # add fixed coefficient term defined by a factor
+#' gr <- gl(2, 5)
+#' nmfModel(x ~ 3 + gr)
+#'
+#' # add fixed coefficient term defined by a numeric covariate
+#' nmfModel(x ~ 3 + gr + b, data=list(b=runif(10)))
+#'
+#' # 3-rank model that fits a given ExpressionSet (with fixed coef terms)
+#' e <- ExpressionSet(x)
+#' pData(e) <- data.frame(a=runif(10))
+#' nmfModel(e ~ 3 + gr + a) # `a` is looked up in the phenotypic data of x pData(x)
+#'
+setMethod('nmfModel', signature(rank='formula', target='ANY'),
+ function(rank, target, ..., data=NULL, no.attrib=FALSE){
+
+ # missing target is NULL
+ if( missing(target) ) target <- NULL
+
+ # data is a model class name (passed from nmf)
+ if( is.character(data) ){
+ model <- data
+ data <- NULL
+ }else model <- NULL
+
+ # parse formula
+ f <- parse_formula(rank)
+ enclos <- environment(rank)
+
+ rank <- 0L
+ if( is.vector(target) && is.numeric(target) ){
+ rank <- target
+ target <- NULL
+ }
+
+ # utility function to merge data and pData
+ merge_pdata <- function(x, data){
+ pd <- pData(x)
+ if( length(pd) ){
+ if( is.null(data) ) pd
+ else{
+ cbind(data, pd)
+ }
+ }else data
+ }
+
+ # determine formula data
+ if( is.null(data) ){
+ # target data.frame taken as data if a response variable if defined
+ if( is.data.frame(target) && f$response ){
+ data <- target
+ target <- NULL
+ }else if( is.environment(target) ){ # use target as enclosure
+ enclos <- target
+ target <- NULL
+ }
+ }
+
+ # determine target matrix:
+ X <- 0L
+ # if a response term is present, lookup target data in other arguments
+ if( f$response ){
+ X <- eval(parse(text=f$y), enclos)
+ if( is.eset(target) && !identical(X, target) ){
+ warning("Conflicting response term and target: the ExpressionSet in `target` will only be used for covariates.")
+ data <- merge_pdata(target, data)
+ }
+ }
+ else if( is.null(target) ){
+ # no response, no target: try ExpressionSet in data
+ if( is.eset(data) ){
+ X <- exprs(data)
+ }
+ }else{
+ X <- target
+ }
+
+ # merge data and pData from ExpressionSet target
+ if( is.eset(X) ){
+ data <- merge_pdata(X, data)
+ X <- exprs(X)
+ }
+
+ r <- rank
+ cterms <- bterms <- list()
+
+ # dimensions are also inferred from the formula
+ n <- if( identical(X, 0L) ) 0L else nrow(X)
+ p <- if( identical(X, 0L) ) 0L else ncol(X)
+
+ for( v in f$x ){
+ if( grepl("^[0-9]+$", v) ){
+ if( rank == 0L ){ # rank not specified in target
+ r <- as.numeric(v)
+ }else{
+ warning("NMF::nmfModel - Discarding rank specified in the formula [", v,"]:"
+ , " using value specified in target rank instead [", rank, "].")
+ }
+ }else if( grepl("^[+-]$", v) ) next
+ else {
+ val <- eval(parse(text=v), data, enclos)
+ .add_term <- function(v, val, type = NULL){
+ if( p==0L || length(val) == p || identical(type, 'coef') ){
+ cterms[[v]] <<- val
+ if( p==0L ) p <<- length(val)
+ }else if( n==0L || length(val) == n || identical(type, 'basis') ){
+ bterms[[v]] <<- val
+ if( n==0L ) n <<- length(val)
+ }else
+ stop("Invalid", type," term '", v, "' length [", length(val), "]:"
+ , " length must either be the number of target columns [", p, "]"
+ , " or rows [", n, "]")
+ }
+
+ if( is.null(dim(val)) ) .add_term(v, val)
+ else if( n == 0L || nrow(val) == n ){
+ lapply(1:ncol(val), function(i){
+ if( !is.null(cname <- colnames(val)[i]) && nzchar(cname) ) vname <- cname
+ else vname <- paste0(v, i)
+ .add_term(vname, val[, i], type = 'basis')
+ })
+ }else{
+ # special handling of data.frames:
+ # -> coef terms are passed as column variables
+ if( is.data.frame(val) && (p == 0L || nrow(val) == p)){
+ val <- t(val)
+ }
+ if( p == 0L || ncol(val) == p ){
+ lapply(1:nrow(val), function(i){
+ if( !is.null(cname <- rownames(val)[i]) && nzchar(cname) ) vname <- cname
+ else vname <- paste0(v, i)
+ .add_term(vname, val[i, ], type = 'coef')
+ })
+ }else{
+ stop("Incompatible matrix-like term '", v, "' dimensions [", str_dim(val), "]:"
+ , " number of rows or columns must match the ones of the target matrix [", str_dim(X, dims = c(n, p)) ,"]")
+ }
+ }
+ }
+ }
+ # try to fixup X if possible
+ if( identical(X, 0L) ) X <- c(n, p)
+
+ # call nmfModel with cterms
+ if( hasArg(model) || is.null(model) ) object <- nmfModel(r, X, ...)
+ else object <- nmfModel(r, X, ..., model=model)
+ # set fixed basis terms
+ if( length(bterms) ){
+ bterms(object) <- as.data.frame(bterms)
+ }
+ # set fixed coef terms
+ if( length(cterms) ){
+ cterms(object) <- as.data.frame(cterms)
+ }
+
+ # valid object
+ validObject(object)
+ # attach formula data
+ if( !no.attrib ){
+ attr(object, 'target') <- X
+ attr(object, 'formula') <- f
+ }
+ # return object
+ object
+ }
+)
+
+#' Listing NMF Models
+#'
+#' \code{nmfModels} lists all available NMF models currently defined that can be
+#' used to create NMF objects, i.e. -- more or less -- all S4 classes that
+#' inherit from class \code{\linkS4class{NMF}}.
+#'
+#' @param builtin.only logical that indicates whether only built-in NMF models,
+#' i.e. defined within the NMF package, should be listed.
+#'
+#' @return a list
+#'
+#' @export
+#' @family NMF-interface
+#' @rdname nmfModel
+#' @examples
+#'
+#' # show all the NMF models available (i.e. the classes that inherit from class NMF)
+#' nmfModels()
+#' # show all the built-in NMF models available
+#' nmfModels(builtin.only=TRUE)
+#'
+nmfModels <- function(builtin.only=FALSE){
+
+ if( builtin.only ) return( .nmf.Models.Builtin )
+
+ # return all subclasses of class 'NMF' (minus class 'NMFfit' and its subclasses)
+ models <- names(methods::getClass('NMF')@subclasses)
+ models.wraps <- c('NMFfit', names(methods::getClass('NMFfit')@subclasses))
+ return( models[!is.element(models, models.wraps)] )
+
+}
+
+###% Initialization function for NMF models
+.nmf.Models.Builtin <- NULL
+.init.nmf.models <- function(){
+ .nmf.Models.Builtin <<- nmfModels()
+}
+
diff --git a/R/options.R b/R/options.R
new file mode 100644
index 0000000..2d61c0f
--- /dev/null
+++ b/R/options.R
@@ -0,0 +1,162 @@
+###% Options management
+###%
+###%
+###% @author Renaud Gaujoux \email{renaud@@cbio.uct.ac.za}
+###%
+
+#.nmf.Options.Runtime <- character()
+
+# define functions nmf.options and nmf.getOptions
+#' NMF Package Specific Options
+#'
+#' @section Available options:
+#' \describe{
+#'
+#' \item{cores}{Default number of cores to use to perform parallel NMF computations.
+#' Note that this option is effectively used only if the global option \code{'cores'} is
+#' not set.
+#' Moreover, the number of cores can also be set at runtime, in the call to \code{\link{nmf}},
+#' via arguments \code{.pbackend} or \code{.options} (see \code{\link{nmf}} for more details).}
+#'
+#' \item{default.algorithm}{Default NMF algorithm used by the \code{nmf} function when argument
+#' \code{method} is missing.
+#' The value should the key of one of the registered NMF algorithms or a valid specification of an NMF algorithm.
+#' See \code{?nmfAlgorithm}.}
+#'
+#' \item{default.seed}{Default seeding method used by the \code{nmf} function when argument \code{seed} is missing.
+#' The value should the key of one of the registered seeding methods or a vallid specification of a seeding method.
+#' See \code{?nmfSeed}.}
+#'
+#' \item{track}{Toggle default residual tracking.
+#' When \code{TRUE}, the \code{nmf} function compute and store the residual track in the result -- if not otherwise specified in argument \code{.options}.
+#' Note that tracking may significantly slow down the computations.}
+#'
+#' \item{track.interval}{Number of iterations between two points in the residual track.
+#' This option is relevant only when residual tracking is enabled.
+#' See \code{?nmf}.}
+#'
+#' \item{error.track}{this is a symbolic link to option \code{track} for backward compatibility.}
+#'
+#' \item{pbackend}{Default loop/parallel foreach backend used by the \code{nmf} function when
+#' argument \code{.pbackend} is missing.
+#' Currently the following values are supported: \code{'par'} for multicore,
+#' \code{'seq'} for sequential, \code{NA} for standard \code{sapply} (i.e. do not use a foreach loop),
+#' \code{NULL} for using the currently registered foreach backend.}
+#'
+#' \item{parallel.backend}{this is a symbolic link to option \code{pbackend} for backward compatibility.}
+#'
+#' \item{gc}{Interval/frequency (in number of runs) at which garbage collection is performed.}
+#'
+#' \item{verbose}{Default level of verbosity.}
+#'
+#' \item{debug}{Toogles debug mode.
+#' In this mode the console output may be very -- very -- messy, and is aimed at debugging only.}
+#'
+#' \item{maxIter}{ Default maximum number of iteration to use (default NULL).
+#' This option is for internal/technical usage only, to globally speed up examples or tests
+#' of NMF algorithms. To be used with care at one's own risk...
+#' It is documented here so that advanced users are aware of its existence, and can avoid possible
+#' conflict with their own custom options.
+#' }
+#' } % end description
+#'
+#'
+#' @rdname options
+#' @name options-NMF
+NULL
+.OPTIONS <- setupPackageOptions(
+ # default algorithm
+ default.algorithm='brunet'
+ # default seeding method
+ , default.seed='random'
+ # track error during NMF updates
+ , error.track = option_symlink('track') # for backward compatibility
+ , track=FALSE
+ # define the tracking interval
+ , track.interval=30
+ # define garbage collection interval
+ , gc=50
+ # define default parallel backend
+ , parallel.backend= option_symlink('pbackend') # for backward compatibility
+ , pbackend= if( parallel::detectCores() > 1 ) 'par' else 'seq'
+ # toogle verbosity
+ , verbose=FALSE
+ # toogle debug mode
+ , debug=FALSE
+, RESET=TRUE)
+
+#' \code{nmf.options} sets/get single or multiple options, that are specific
+#' to the NMF package.
+#' It behaves in the same way as \code{\link[base]{options}}.
+#'
+#' @inheritParams base::options
+#' @param ... option specifications. For \code{nmf.options} this can be named arguments or
+#' a single unnamed argument that is a named list (see \code{\link{options}}.
+#'
+#' For \code{nmf.resetOptions}, this must be the names of the options to reset.
+#' Note that \pkg{pkgmaker} version >= 0.9.1 is required for this to work correctly,
+#' when options other than the default ones have been set after the package is loaded.
+#'
+#' @export
+#' @rdname options
+#' @examples
+#'
+#' # show all NMF specific options
+#' nmf.printOptions()
+#'
+#' # get some options
+#' nmf.getOption('verbose')
+#' nmf.getOption('pbackend')
+#' # set new values
+#' nmf.options(verbose=TRUE)
+#' nmf.options(pbackend='mc', default.algorithm='lee')
+#' nmf.printOptions()
+#'
+#' # reset to default
+#' nmf.resetOptions()
+#' nmf.printOptions()
+#'
+nmf.options <- .OPTIONS$options
+
+#' \code{nmf.getOption} returns the value of a single option, that is specific
+#' to the NMF package.
+#' It behaves in the same way as \code{\link[base]{getOption}}.
+#'
+#' @inheritParams base::getOption
+#'
+#' @export
+#' @rdname options
+nmf.getOption <- .OPTIONS$getOption
+
+#' \code{nmf.resetOptions} reset all NMF specific options to their default values.
+#'
+#' @param ALL logical that indicates if options that are not part of the default set
+#' of options should be removed.
+#' Note that in \pkg{pkgmaker <= 0.9} this argument is only taken into account when
+#' no other argument is present. This is fixed in version 0.9.1.
+#'
+#' @export
+#' @rdname options
+nmf.resetOptions <- .OPTIONS$resetOptions
+
+#' \code{nmf.printOptions} prints all NMF specific options along with their default values,
+#' in a relatively compact way.
+#' @export
+#' @rdname options
+nmf.printOptions <- .OPTIONS$printOptions
+
+#nmf.options.runtime <- function(){
+# nmf.options(.nmf.Options.Runtime)
+#}
+
+
+# debugging utility
+nmf.debug <- function(fun, ...){
+ if( nmf.getOption('debug') ){
+ call.stack <- sys.calls()
+ n <- length(call.stack)
+ if( is.null(fun) ) fun <- as.character(call.stack[[n-1]])
+ message('DEBUG::', fun, ' -> ', ...)
+ }
+ return(invisible())
+}
diff --git a/R/parallel.R b/R/parallel.R
new file mode 100644
index 0000000..490c2a3
--- /dev/null
+++ b/R/parallel.R
@@ -0,0 +1,1241 @@
+# Definitions used in the parallel computations of NMF
+#
+# - reproducible backend
+# - reproducible %dopar% operator: %dorng%
+#
+# Author: Renaud Gaujoux
+# Creation: 08-Feb-2011
+###############################################################################
+
+#' @include utils.R
+#' @import foreach
+#' @import doParallel
+NULL
+
+# returns the number of cores to use in all NMF computation when no number is
+# specified by the user
+getMaxCores <- function(limit=TRUE){
+ #ceiling(parallel::detectCores()/2)
+ nt <- n <- parallel::detectCores()
+ # limit to number of cores specified in options if asked for
+ if( limit ){
+ if( !is.null(nc <- getOption('cores')) ) n <- nc # global option
+ else if( !is.null(nc <- nmf.getOption('cores')) ) n <- nc # NMF-specific option
+ else if( n > 2 ) n <- n - 1L # leave one core free if possible
+ }
+ # forces limiting maximum number of cores to 2 during CRAN checks
+ if( n > 2 && isCHECK() ){
+ message("# NOTE - CRAN check detected: limiting maximum number of cores [2/", nt, "]")
+ n <- 2L
+ }
+ n
+}
+
+#' Utilities and Extensions for Foreach Loops
+#'
+#' \code{registerDoBackend} is a unified register function for foreach backends.
+#'
+#' @param object specification of a foreach backend, e.g. \sQuote{SEQ},
+#' \sQuote{PAR} (for doParallel), \sQuote{MPI}, etc\ldots
+#' @param ... extra arguments passed to the backend own registration function.
+#'
+#' @keywords internal
+#' @rdname foreach
+registerDoBackend <- function(object, ...){
+
+ # restore old backend data in case of an error
+ old <- getDoBackend()
+ on.exit( setDoBackend(old) )
+
+ # get old foreach backend object
+ ob <- ForeachBackend()
+
+ # register new backend: call the register method
+ b <- ForeachBackend(object, ...)
+ res <- register(b)
+
+ # cancel backend restoration
+ on.exit()
+ # call old backend cleanup method
+ doBackendCleanup(ob)
+
+ # return old backend
+ invisible(ob)
+}
+
+#' \code{getDoBackend} returns the internal data of the currently registered foreach \%dopar\% backend.
+#' @rdname foreach
+#' @export
+getDoBackend <- function(){
+ fe_ns <- asNamespace('foreach')
+ fe <- ns_get('.foreachGlobals', fe_ns)
+ if( !exists("fun", where = fe, inherits = FALSE) )
+ return(NULL)
+
+ getDoPar <- ns_get('getDoPar', fe_ns)
+ c(getDoPar() # this returns the registered %dopar% function + associated data
+ # -> add info function from foreach internal environment
+ , info= if( exists("info", where = fe, inherits = FALSE) ){
+ get('info', fe, inherits=FALSE)
+ }else{
+ function(data, item) NULL
+ }
+ , cleanup = if( exists("cleanup", where = fe, inherits = FALSE) ){
+ get('cleanup', fe, inherits=FALSE)
+ }
+ )
+}
+
+getDoBackendInfo <- function(x, item){
+ if( is.function(x$info) ) x$info(x$data, item)
+}
+getDoBackendName <- function(x){
+ getDoBackendInfo(x, 'name')
+}
+
+#' \code{setDoBackend} is identical to \code{\link[foreach]{setDoPar}}, but
+#' returns the internal of the previously registered backend.
+#'
+#' @param data internal data of a foreach \%dopar\% backend.
+#' @param cleanup logical that indicates if the previous
+#' backend's cleanup procedure should be run, \strong{before}
+#' setting the new backend.
+#'
+#' @export
+#' @rdname foreach
+setDoBackend <- function(data, cleanup=FALSE){
+
+ # get old backend data
+ ob <- getDoBackend()
+ ofb <- ForeachBackend()
+ # cleanup old backend if requested
+ if( cleanup ){
+ doBackendCleanup(ofb)
+ }
+
+ if( !is.null(data) ){
+ bdata <- data
+ if( is.backend(data) ) data <- data[!names(data) %in% c('name', 'cleanup')]
+ do.call('setDoPar', data)
+ setBackendCleanup(bdata)
+ }else{
+ do.call('setDoPar', list(NULL))
+ fe <- ns_get('.foreachGlobals', 'foreach')
+ if (exists("fun", envir = fe, inherits = FALSE))
+ remove("fun", envir = fe)
+ setBackendCleanup(NULL)
+ }
+ # return old backend
+ invisible(ob)
+}
+
+# setup cleanup procedure for the current backend
+setBackendCleanup <- function(object, fun, verbose=FALSE){
+
+ fe <- ns_get('.foreachGlobals', 'foreach')
+ name <- getDoParName()
+ if( !is.null(fun <- object$cleanup) ){
+ if( verbose ) message("# Registering cleaning up function for '", name, "'... ", appendLF=FALSE)
+ assign('cleanup', fun, fe)
+ if( verbose ) message("OK")
+ }else if (exists("cleanup", envir = fe, inherits = FALSE)){
+ if( verbose ) message("# Removing cleaning up function for '", name, "'... ", appendLF=FALSE)
+ remove("cleanup", envir = fe)
+ if( verbose ) message("OK")
+ }
+ invisible(object)
+}
+
+# run cleanup procedure for a given backend object
+doBackendCleanup <- function(object, ..., run=TRUE, verbose=FALSE){
+
+ name <- object$name
+ if( !is.null(fun <- object$cleanup) ){
+ if( verbose ) message("# Cleaning up '", name, "'... ", appendLF=FALSE)
+ res <- try(fun(), silent=TRUE)
+ if( verbose ) message(if( is(res, 'try-error') ) 'ERROR' else 'OK')
+ if( isTRUE(res) ) object$cleanup <- NULL
+ if( verbose ) message('OK', if( !is.null(res) ) str_c(' [', res,']'))
+ }
+ invisible(object)
+}
+
+#' \code{register} is a generic function that register objects.
+#' It is used to as a unified interface to register foreach backends.
+#'
+#' @param x specification of a foreach backend
+#'
+#' @rdname foreach
+#' @export
+register <- function(x, ...){
+ UseMethod('register', x)
+}
+#' @S3method register foreach_backend
+register.foreach_backend <- function(x, ...){
+
+ be <- x$name
+ # For everything except doSEQ:
+ # require definition package (it is safer to re-check)
+ if( be != 'doSEQ' ){
+ if( !require.quiet(be, character.only=TRUE) )
+ stop("Package '", be, "' is required to use foreach backend '", be, "'")
+ }
+
+ regfun <- .foreach_regfun(x$name)
+ res <-
+ if( length(formals(regfun)) > 0L ) do.call(regfun, c(x$data, ...))
+ else regfun()
+ # throw an error if not successful (foreach::setDoPar do not throw errors!!)
+ if( is(res, 'simpleError') ) stop(res)
+ # set cleanup procedure if any
+ setBackendCleanup(x)
+ # return result
+ invisible(res)
+}
+
+#' \code{ForeachBackend} is a factory method for foreach backend objects.
+#'
+#' @export
+#' @inline
+#' @rdname foreach
+setGeneric('ForeachBackend', function(object, ...) standardGeneric('ForeachBackend'))
+#' Default method defined to throw an informative error message, when no other
+#' method was found.
+setMethod('ForeachBackend', 'ANY',
+ function(object, ...){
+ if( is.backend(object) ){
+ # update arg list if necessary
+ if( nargs() > 1L ) object$data <- list(...)
+ object
+ }else if( is(object, 'cluster') )
+ selectMethod('ForeachBackend', 'cluster')(object, ...)
+ else
+ stop("Could not create foreach backend object with a specification of class '", class(object)[1L], "'")
+ }
+)
+
+formatDoName <- function(x){
+
+ # numeric values are resolved as doParallel
+ if( is.numeric(x) ) x <- 'PAR'
+ if( is.character(x) ){
+ # use upper case if not already specified as 'do*'
+ if( !grepl("^do", x) ){
+ x <- toupper(x)
+ # special treatment for doParallel
+ if( x %in% c('PAR', 'PARALLEL') ) x <- 'Parallel'
+ }
+ # stick prefix 'do' (removing leading 'do' if necessary)
+ str_c('do', sub('^do', '', x))
+ }else
+ ''
+}
+#' Creates a foreach backend object based on its name.
+setMethod('ForeachBackend', 'character',
+ function(object, ...){
+
+ object <- formatDoName(object)
+
+ # build S3 class name
+ s3class <- str_c(object, "_backend")
+
+ # create empty S3 object
+ obj <- structure(list(name=object, data=list(...))
+ , class=c(s3class, 'foreach_backend'))
+
+ # give a chance to a backend-specific ForeachBackend factory method
+ # => this will generally fill the object with the elements suitable
+ # to be used in a call to foreach::setDoPar: fun, data, info
+ # and possibly change the name or the object class, e.g. to allow
+ # subsequent argument-dependent dispatch.
+ obj <- ForeachBackend(obj, ...)
+
+ # check the registration routine is available
+ .foreach_regfun(obj$name)
+
+ # set data slot if not already set by the backend-specific method
+ if( is.null(obj$data) || (length(obj$data) == 0L && nargs()>1L) )
+ obj$data <- list(...)
+
+ # return object
+ obj
+ }
+)
+#' Creates a foreach backend object for the currently registered backend.
+setMethod('ForeachBackend', 'missing',
+ function(object, ...){
+ be <- getDoParName()
+ data <- getDoBackend()
+ bdata <- data$data
+ res <- if( !is.null(bdata) ) do.call(ForeachBackend, c(list(be, bdata), ...))
+ else ForeachBackend(be, ...)
+ if( !is.null(data$cleanup) ) res$cleanup <- data$cleanup
+ res
+ }
+)
+#' Dummy method that returns \code{NULL}, defined for correct dispatch.
+setMethod('ForeachBackend', 'NULL', function(object, ...){ NULL })
+
+setOldClass('cluster')
+#' Creates a doParallel foreach backend that uses the cluster described in
+#' \code{object}.
+setMethod('ForeachBackend', 'cluster',
+ function(object, ...){
+ ForeachBackend('doParallel', cl=object)
+ }
+)
+#' Creates a doParallel foreach backend with \code{object} processes.
+setMethod('ForeachBackend', 'numeric',
+ function(object, ...){
+ # check numeric specification
+ if( length(object) == 0L )
+ stop("invalid number of cores specified as a backend [empty]")
+ object <- object[1]
+ if( object <= 0 )
+ stop("invalid negative number of cores [", object, "] specified for backend 'doParallel'")
+
+ ForeachBackend('doParallel', cl=object, ...)
+ }
+)
+###############
+# doParallel
+###############
+setOldClass('doParallel_backend')
+#' doParallel-specific backend factory
+#'
+#' @param cl cluster specification: a cluster object or a numeric that indicates the
+#' number of nodes to use.
+#' @param type type of cluster, See \code{\link[parallel]{makeCluster}}.
+setMethod('ForeachBackend', 'doParallel_backend',
+ function(object, cl, type=NULL){
+
+ # set type of cluster if explicitly provided
+ if( !is.null(type) ) object$data$type <- type
+
+ # required registration data
+ # NB: a function doParallel:::doParallel should exist and do the same
+ # thing as parallel::registerDoParallel without registering the backend
+ #object$fun <- doParallel:::doParallel
+# object$info <- doParallel:::info
+ # doParallel:::info has been removed from doParallel since version 1.0.7
+ # Reported in Issue #7
+ object$info <- getDoParallelInfo(object)
+
+ # return object
+ object
+ }
+)
+
+setOldClass('doParallelMC_backend')
+#' doParallel-specific backend factory for multicore (fork) clusters
+#'
+#' This method is needed since version 1.0.7 of \pkg{doParallel}, which removed
+#' internal function \code{info} and defined separate backend names for mc and snow clusters.
+setMethod('ForeachBackend', 'doParallelMC_backend',
+ function(object, ...){
+
+ object$info <- getDoParallelInfo('mc')
+ object$name <- 'doParallel'
+ # return object
+ object
+ }
+)
+
+setOldClass('doParallelSNOW_backend')
+#' doParallel-specific backend factory for SNOW clusters.
+#'
+#' This method is needed since version 1.0.7 of \pkg{doParallel}, which removed
+#' internal function \code{info} and defined separate backend names for mc and snow clusters.
+setMethod('ForeachBackend', 'doParallelSNOW_backend',
+ function(object, ...){
+
+ object$info <- getDoParallelInfo('snow')
+ object$name <- 'doParallel'
+ # return object
+ object
+ }
+)
+
+getDoParallelType <- function(x){
+
+
+ cl <- x$data[['cl']]
+ if( is.null(cl) && length(x$data) && (is.null(names(x$data)) || names(x$data)[[1L]] == '') )
+ cl <- x$data[[1L]]
+ if ( is.null(cl) || is.numeric(cl) ) {
+ if (.Platform$OS.type == "windows" || (!is.null(x$data$type) && !identical(x$data$type, 'FORK')) ) 'snow'
+ else 'mc'
+ }
+ else 'snow'
+
+}
+
+getDoParallelInfo <- function(x, ...){
+ t <- if( isString(x) ) x else getDoParallelType(x, ...)
+# str(t)
+ ns <- asNamespace('doParallel')
+ if( t == 'mc' ) get('mcinfo', ns)
+ else get('snowinfo', ns)
+}
+
+######################################################
+# doPSOCK
+# Default snow-like cluster from parallel on Windows
+# but works on Unix as well
+######################################################
+
+setOldClass('doPSOCK_backend')
+#' doSNOW-specific backend factory
+setMethod('ForeachBackend', 'doPSOCK_backend',
+ function(object, cl){
+
+ # use all available cores if not otherwise specified
+ if( missing(cl) ) cl <- getMaxCores()
+
+ # return equivalent doParallel object
+ ForeachBackend('doParallel', cl, type='PSOCK')
+ }
+)
+
+.cl_cleanup <- function(gvar, envir=.GlobalEnv){
+ if( !exists(gvar, envir = envir) ) return()
+ cl <- get(gvar, envir = envir)
+ try( parallel::stopCluster(cl), silent=TRUE)
+ rm(list=gvar, envir = envir)
+ TRUE
+}
+
+cleanupCluster <- function(x, cl, stopFun=NULL){
+
+ function(){
+
+ if( is(x, 'doParallel_backend') ){
+
+ # On non-Windows machines registerDoParallel(numeric) will use
+ # parallel::mclapply with `object` cores (no cleanup required).
+ # On Windows doParallel::registerDoParallel(numeric) will create a
+ # SOCKcluster with `object` cores.
+ # => Windows needs a cleanup function that will stop the cluster
+ # when another backend is registered.
+ # Fortunately doParallel::registerDoParallel assign the cluster object
+ # to the global variable `.revoDoParCluster`
+ if( .Platform$OS.type == "windows" ){
+ .cl_cleanup(".revoDoParCluster")
+ }
+ }
+
+ if( is.null(stopFun) ) stopFun <- parallel::stopCluster
+ # stop cluster
+ stopFun(cl)
+ TRUE
+ }
+}
+
+#' @S3method register doParallel_backend
+register.doParallel_backend <- function(x, ...){
+
+ # start cluster if numeric specification and type is defined
+ cl <- x$data[[1]]
+ if( is.numeric(cl) && (.Platform$OS.type == 'windows' || !is.null(x$data$type)) ){
+ names(x$data)[1L] <- 'spec'
+ # start cluster
+ clObj <- do.call(parallel::makeCluster, x$data)
+ x$data <- list(clObj)
+ # setup cleanup procedure
+ x$cleanup <- cleanupCluster(x, clObj)
+ }
+ # register
+ register.foreach_backend(x, ...)
+}
+
+###############
+# doMPI
+###############
+
+isMPIBackend <- function(x, ...){
+ b <- if( missing(x) ) ForeachBackend(...) else ForeachBackend(object=x, ...)
+ if( is.null(b) ) FALSE
+ else if( identical(b$name, 'doMPI') ) TRUE
+ else if( length(b$data) ){
+ is(b$data[[1]], 'MPIcluster') || is(b$data[[1]], 'mpicluster')
+ }else FALSE
+}
+
+#' @S3method register doMPI_backend
+register.doMPI_backend <- function(x, ...){
+
+ if( length(x$data) && isNumber(cl <- x$data[[1]]) ){
+ clObj <- doMPI::startMPIcluster(cl)
+ x$data[[1]] <- clObj
+ # setup cleanup procedure
+ x$cleanup <- cleanupCluster(x, clObj, doMPI::closeCluster)
+ }
+ # register
+ register.foreach_backend(x, ...)
+}
+
+setOldClass('mpicluster')
+#' Creates a doMPI foreach backend that uses the MPI cluster described in
+#' \code{object}.
+setMethod('ForeachBackend', 'mpicluster',
+ function(object, ...){
+ ForeachBackend('doMPI', cl=object)
+ }
+)
+
+setOldClass('doMPI_backend')
+#' doMPI-specific backend factory
+setMethod('ForeachBackend', 'doMPI_backend',
+ function(object, cl){
+
+ # use all available cores if not otherwise specified
+ if( missing(cl) ) cl <- getMaxCores()
+
+ # required registration data
+ object$fun <- doMPI:::doMPI
+ object$info <- doMPI:::info
+
+ # return object
+ object
+ }
+)
+
+#as.foreach_backend <- function(x, ...){
+#
+# args <- list(...)
+# if( is.backend(x) ){
+# # update arg list if necessary
+# if( length(args) > 0L ) x$args <- args
+# return(x)
+# }
+#
+# be <-
+# if( is.null(x) ){
+# getDoParName()
+# } else if( is(x, 'cluster') || is.numeric(x) ){
+# # check numeric specification
+# if( is.numeric(x) ){
+# if( length(x) == 0L )
+# stop("invalid number of cores specified as a backend [empty]")
+# x <- x[1]
+# if( x <= 0 )
+# stop("invalid negative number of cores [", x, "] specified for backend 'doParallel'")
+# }
+#
+# args$spec <- x
+# 'Parallel'
+# } else if( is(x, 'mpicluster') ){
+# args$spec <- x
+# 'MPI'
+# } else if( is.character(x) ){
+# toupper(x)
+# } else
+# stop("invalid backend specification: must be NULL, a valid backend name, a numeric value or a cluster object [", class(x)[1L], "]")
+#
+# if( be %in% c('PAR', 'PARALLEL') ) be <- 'Parallel'
+# # remove leading 'do'
+# be <- str_c('do', sub('^do', '', be))
+# # build S3 class name
+# s3class <- str_c(be, "_backend")
+#
+# # check the registration routine is available
+# regfun <- .foreach_regfun(be)
+#
+# structure(list(name=be, args=args), class=c(s3class, 'foreach_backend'))
+#}
+
+is.backend <- function(x) is(x, 'foreach_backend')
+
+#' @S3method print foreach_backend
+print.foreach_backend <- function(x, ...){
+ cat("<foreach backend:", x$name, ">\n", sep='')
+ if( length(x$data) ){
+ cat("Specifications:\n")
+ str(x$data)
+ }
+}
+
+.foreach_regfun <- function(name){
+
+ # early exit for doSEQ
+ if( name == 'doSEQ' ) return( registerDoSEQ )
+
+ # build name of registration function
+ s <- str_c(toupper(substring(name, 1,1)), substring(name, 2))
+ funname <- str_c('register', s)
+ s3class <- str_c(name, "_backend")
+
+ # require definition package
+ if( !require.quiet(name, character.only=TRUE) )
+ stop("could not find package for foreach backend '", name, "'")
+ # check for registering function or generic
+ if( is.null(regfun <- getFunction(funname, mustFind=FALSE, where=asNamespace(name))) ){
+ if( is.null(regfun <- getS3method('register', s3class, optional=TRUE)) )
+ stop("could not find registration routine for foreach backend '", name, "'")
+ # stop("backend '", name,"' is not supported: function "
+ # ,"`", regfun, "` and S3 method `register.", s3class, "` not found.")
+ }
+ regfun
+}
+
+
+#' \code{getDoParHosts} is a generic function that returns the hostname of the worker nodes used by a backend.
+#'
+#' @export
+#' @rdname foreach
+#' @inline
+setGeneric('getDoParHosts', function(object, ...) standardGeneric('getDoParHosts'))
+setOldClass('foreach_backend')
+#' Default method that tries to heuristaically infer the number of hosts and in last
+#' resort temporarly register the backend and performs a foreach loop, to retrieve the
+#' nodename from each worker.
+setMethod('getDoParHosts', 'ANY',
+ function(object, ...){
+
+ be <- if( missing(object) ) ForeachBackend(...) else ForeachBackend(object, ...)
+ if( existsMethod('getDoParHosts', class(be)[1L]) ) return( callGeneric(object) )
+
+ # default behaviour
+ nodename <- setNames(Sys.info()['nodename'], NULL)
+
+ if( is.null(be) || is.null(be$data) ) return( NULL )
+ # doSEQ
+ if( be$name == 'doSEQ' )
+ return( nodename )
+ if( isNumber(be$data) )
+ return( rep(nodename, be$data) )
+ if( length(be$data) && isNumber(be$data[[1]]) )
+ return( rep(nodename, be$data[[1]]) )
+ if( length(be$data) && be$name == 'doParallel' )
+ return( sapply(be$data[[1L]], '[[', 'host') )
+
+ if( !missing(object) ){ # backend passed: register temporarly
+ ob <- getDoBackend()
+ on.exit( setDoBackend(ob) )
+ registerDoBackend(be)
+ }
+ setNames(unlist(times(getDoParWorkers()) %dopar% { Sys.info()['nodename'] }), NULL)
+ }
+)
+
+#' \code{getDoParNHosts} returns the number of hosts used by a backend.
+#'
+#' @export
+#' @rdname foreach
+getDoParNHosts <- function(object){
+ if( missing(object) ) foreach::getDoParWorkers()
+ else{
+ length(getDoParHosts(object))
+ }
+}
+
+# add new option: limit.cores indicates if the number of cores used in parallel
+# computation can exceed the detected number of CPUs on the host.
+#.OPTIONS$newOptions(limit.cores=TRUE)
+
+#' Computational Setup Functions
+#'
+#' @description
+#' Functions used internally to setup the computational environment.
+#'
+#' \code{setupBackend} sets up a foreach backend given some specifications.
+#'
+#' @param spec target parallel specification: either \code{TRUE} or \code{FALSE},
+#' or a single numeric value that specifies the number of cores to setup.
+#' @param backend value from argument \code{.pbackend} of \code{nmf}.
+#' @param optional a logical that indicates if the specification must be fully
+#' satisfied, throwing an error if it is not, or if one can switch back to
+#' sequential, only outputting a verbose message.
+#' @param verbose logical or integer level of verbosity for message outputs.
+#'
+#' @return Returns \code{FALSE} if no foreach backend is to be used, \code{NA} if the currently
+#' registered backend is to be used, or, if this function call registered a new backend,
+#' the previously registered backend as a \code{foreach} object, so that it can be restored
+#' after the computation is over.
+#' @keywords internals
+#' @rdname setup
+setupBackend <- function(spec, backend, optional=FALSE, verbose=FALSE){
+
+ pbackend <- backend
+ str_backend <- quick_str(pbackend)
+ # early exit: FALSE specification or NA backend means not using foreach at all
+ if( isFALSE(spec) || is_NA(pbackend) ) return(FALSE)
+ # use doParallel with number of cores if specified in backend
+ if( is.numeric(pbackend) ){
+ spec <- pbackend
+ pbackend <- 'PAR'
+ }
+ # identify doSEQ calls
+ doSEQ <- formatDoName(pbackend) == 'doSEQ'
+
+ # custom error function
+ pcomp <- is.numeric(spec) && !identical(spec[1], 1)
+ errorFun <- function(value=FALSE, stop=FALSE, level=1){
+ function(e, ...){
+ if( !is(e, 'error') ) e <- list(message=str_c(e, ...))
+
+ pref <- if( pcomp ) "Parallel" else "Foreach"
+ if( !optional || stop ){
+ if( verbose >= level ) message('ERROR')
+ stop(pref, " computation aborted: ", e$message, call.=FALSE)
+ }else if( verbose >= level ){
+ message('NOTE')
+ message("# NOTE: ", pref, " computation disabled: ", e$message)
+ }
+ value
+ }
+ }
+
+ # check current backend if backend is NULL
+ if( is.null(pbackend) ){
+ if( verbose > 1 ){
+ message("# Using current backend ... ", appendLF=FALSE)
+ }
+ ok <- tryCatch({
+ if( is.null(parname <- getDoParName()) )
+ stop("argument '.pbackend' is NULL but there is no registered backend")
+ if( verbose > 1 ) message('OK [', parname, ']')
+ TRUE
+ }, error = errorFun())
+ if( !ok ) return(FALSE)
+ # exit now since there is nothing to setup, nothing should change
+ # return NULL so that the backend is not restored on.exit of the parent call.
+ return(NA)
+ }
+ ##
+
+ # test if requested number of cores is actually available
+ NCORES <- getMaxCores(limit=FALSE)
+ if( verbose > 2 ) message("# Check available cores ... [", NCORES, ']')
+ if( verbose > 2 ) message("# Check requested cores ... ", appendLF=FALSE)
+ ncores <- if( doSEQ ) 1L
+ else{
+ ncores <- tryCatch({
+ if( is.numeric(spec) ){
+ if( length(spec) == 0L )
+ stop("no number of cores specified for backend '", str_backend, "'")
+ spec <- spec[1]
+ if( spec <= 0L )
+ stop("invalid negative number of cores [", spec, "] specified for backend '", str_backend, "'")
+ spec
+ }else # by default use the 'cores' option or half the number of cores
+ getMaxCores() #getOption('cores', ceiling(NCORES/2))
+ }, error = errorFun(stop=TRUE))
+ if( isFALSE(ncores) ) return(FALSE)
+ ncores
+ }
+ if( verbose > 2 ) message('[', ncores, ']')
+
+ # create backend object
+ if( verbose > 2 ) message("# Loading backend for specification `", str_backend, "` ... ", appendLF=FALSE)
+ newBackend <- tryCatch({
+ # NB: limit to the number of cores available on the host
+ if( !doSEQ ) ForeachBackend(pbackend, min(ncores, NCORES))
+ else ForeachBackend(pbackend)
+ }, error = errorFun(level=3))
+ if( isFALSE(newBackend) ) return(FALSE)
+ if( verbose > 2 ) message('OK')
+
+ if( verbose > 1 ) message("# Check host compatibility ... ", appendLF=FALSE)
+ ok <- tryCatch({
+ # check if we're not running on MAC from GUI
+ if( is.Mac(check.gui=TRUE) && (newBackend$name == 'doMC' || (newBackend$name == 'doParallel' && is.numeric(newBackend$data[[1]]))) ){
+ # error only if the parallel computation was explicitly asked by the user
+ stop("multicore parallel computations are not safe from R.app on Mac OS X."
+ , "\n -> Use a terminal session, starting R from the command line.")
+ }
+ TRUE
+ }, error = errorFun())
+ if( !ok ) return(FALSE)
+ if( verbose > 1 ) message('OK')
+
+ if( verbose > 1 ) message("# Registering backend `", newBackend$name, "` ... ", appendLF=FALSE)
+ # try registering the backend
+ oldBackend <- getDoBackend()
+ # setup retoration of backend in case of an error
+ # NB: the new backend cleanup will happens only
+ # if regsitration succeeds, since the cleanup routine is
+ # setup after the registration by the suitable register S3 method.
+ on.exit( setDoBackend(oldBackend, cleanup=TRUE) )
+
+ ov <- lverbose(verbose)
+ ok <- tryCatch({
+ registerDoBackend(newBackend)
+ TRUE
+ }
+ , error ={
+ lverbose(ov)
+ errorFun()
+ })
+ lverbose(ov)
+ if( !ok ) return(FALSE)
+ if( verbose > 1 ) message('OK')
+
+ # check allocated cores if not doSEQ backend
+ if( newBackend$name != 'doSEQ' ){
+ # test allocated number of cores
+ if( verbose > 2 ) message("# Check allocated cores ... ", appendLF=FALSE)
+ wcores <- getDoParWorkers()
+ if( ncores > 0L && wcores < ncores ){
+ if( !optional ){
+ errorFun(level=3)("only ", wcores, " core(s) available [requested ", ncores ," core(s)]")
+ }else if( verbose > 2 ){
+ message('NOTE [', wcores, '/', ncores, ']')
+ message("# NOTE: using only ", wcores,
+ " core(s) [requested ", ncores ," core(s)]")
+ }
+ }
+ else if( verbose > 2 ){
+ message('OK [', wcores, '/', ncores
+ , if(ncores != NCORES ) str_c(' out of ', NCORES)
+ , ']')
+ }
+ }
+
+ # cancel backend restoration
+ on.exit()
+ # return old backend
+ oldBackend
+}
+
+
+# add extra package bigmemory and synchronicity on Unix platforms
+if( .Platform$OS.type != 'windows' ){
+ setPackageExtra('install.packages', 'bigmemory', pkgs='bigmemory')
+ setPackageExtra('install.packages', 'synchronicity', pkgs='synchronicity')
+}
+# add new option: shared.memory that indicates if one should try using shared memory
+# to speed-up parallel computations.
+.OPTIONS$newOptions(shared.memory = (.Platform$OS.type != 'windows' && !is.Mac()))
+
+
+#' \code{setupSharedMemory} checks if one can use the packages \emph{bigmemory} and \emph{sychronicity}
+#' to speed-up parallel computations when not keeping all the fits.
+#' When both these packages are available, only one result per host is written on disk,
+#' with its achieved deviance stored in shared memory, that is accessible to all cores on
+#' a same host.
+#' It returns \code{TRUE} if both packages are available and NMF option \code{'shared'} is
+#' toggled on.
+#'
+#' @rdname setup
+setupSharedMemory <- function(verbose){
+
+ if( verbose > 1 ) message("# Check shared memory capability ... ", appendLF=FALSE)
+ # early exit if option shared is off
+ if( !nmf.getOption('shared.memory') ){
+ if( verbose > 1 ) message('SKIP [disabled]')
+ return(FALSE)
+ }
+ # early exit if foreach backend is doMPI: it is not working, not sure why
+ if( isMPIBackend() ){
+ if( verbose > 1 ) message('SKIP [MPI cluster]')
+ return(FALSE)
+ }
+ # not on Windows
+ if( .Platform$OS.type == 'windows' ){
+ if( verbose > 1 ) message('SKIP [Windows OS]')
+ return(FALSE)
+ }
+
+ if( !require.quiet('bigmemory', character.only=TRUE) ){
+ if( verbose > 1 ){
+ message('NO', if( verbose > 2 ) ' [Package `bigmemory` required]')
+ }
+ return(FALSE)
+ }
+ if( !require.quiet('synchronicity', character.only=TRUE) ){
+ if( verbose > 1 ){
+ message('NO', if( verbose > 2 ) ' [Package `synchronicity` required]')
+ }
+ return(FALSE)
+ }
+ if( verbose > 1 ) message('YES', if( verbose > 2 ) ' [synchronicity]')
+ TRUE
+}
+
+is.doSEQ <- function(){
+ dn <- getDoParName()
+ is.null(dn) || dn == 'doSEQ'
+}
+
+#' \code{setupTempDirectory} creates a temporary directory to store the best fits computed on each host.
+#' It ensures each worker process has access to it.
+#'
+#' @rdname setup
+setupTempDirectory <- function(verbose){
+
+ # - Create a temporary directory to store the best fits computed on each host
+ NMF_TMPDIR <- tempfile('NMF_', getwd())
+ if( verbose > 2 ) message("# Setup temporary directory: '", NMF_TMPDIR, "' ... ", appendLF=FALSE)
+ dir.create(NMF_TMPDIR)
+ if( !is.dir(NMF_TMPDIR) ){
+ if( verbose > 2 ) message('ERROR')
+ nmf_stop('nmf', "could not create temporary result directory '", NMF_TMPDIR, "'")
+ }
+
+ on.exit( unlink(NMF_TMPDIR, recursive=TRUE) )
+ # ensure that all workers can see the temporary directory
+ wd <- times(getDoParWorkers()) %dopar% {
+ if( !file_test('-d', NMF_TMPDIR) )
+ dir.create(NMF_TMPDIR, recursive=TRUE)
+ file_test('-d', NMF_TMPDIR)
+ }
+ # check it worked
+ if( any(!wd) ){
+ if( verbose > 2 ) message('ERROR')
+ nmf_stop('nmf', "could not create/see temporary result directory '", NMF_TMPDIR, "' on worker nodes ", str_out(which(!wd), Inf))
+ }
+ if( verbose > 2 ) message('OK')
+ on.exit()
+ NMF_TMPDIR
+}
+
+#' Utilities for Parallel Computations
+#'
+#'
+#' @rdname parallel
+#' @name parallel-NMF
+NULL
+
+#' \code{ts_eval} generates a thread safe version of \code{\link{eval}}.
+#' It uses boost mutexes provided by the \code{\link[synchronicity]{synchronicity}}
+#' package.
+#' The generated function has arguments \code{expr} and \code{envir}, which are passed
+#' to \code{\link{eval}}.
+#'
+#' @param mutex a mutex or a mutex descriptor.
+#' If missing, a new mutex is created via the function \code{\link[synchronicity]{boost.mutex}}.
+#' @param verbose a logical that indicates if messages should be printed when
+#' locking and unlocking the mutex.
+#'
+#' @rdname parallel
+#' @export
+ts_eval <- function(mutex = synchronicity::boost.mutex(), verbose=FALSE){
+
+
+ requireNamespace('bigmemory')
+ #library(bigmemory)
+ requireNamespace('synchronicity')
+ #library(synchronicity)
+ # describe mutex if necessary
+ .MUTEX_DESC <-
+ if( is(mutex, 'boost.mutex') ) synchronicity::describe(mutex)
+ else mutex
+
+ loadpkg <- TRUE
+ function(expr, envir=parent.frame()){
+
+ # load packages once
+ if( loadpkg ){
+ requireNamespace('bigmemory')
+ #library(bigmemory)
+ requireNamespace('synchronicity')
+ #library(synchronicity)
+ loadpkg <<- FALSE
+ }
+ MUTEX <- synchronicity::attach.mutex(.MUTEX_DESC)
+ synchronicity::lock(MUTEX)
+ if( verbose )
+ message('#', Sys.getpid(), " - START mutex: ", .MUTEX_DESC at description$shared.name)
+ ERROR <- "### <Error in mutex expression> ###\n"
+ on.exit({
+ if( verbose ){
+ message(ERROR, '#', Sys.getpid(), " - END mutex: ", .MUTEX_DESC at description$shared.name)
+ }
+ synchronicity::unlock(MUTEX)
+ })
+
+ eval(expr, envir=envir)
+
+ ERROR <- NULL
+ }
+}
+
+#' \code{ts_tempfile} generates a \emph{unique} temporary filename
+#' that includes the name of the host machine and/or the caller's process id,
+#' so that it is thread safe.
+#'
+#' @inheritParams base::tempfile
+#' @param ... extra arguments passed to \code{\link[base]{tempfile}}.
+#' @param host logical that indicates if the host machine name should
+#' be appear in the filename.
+#' @param pid logical that indicates if the current process id
+#' be appear in the filename.
+#'
+#' @rdname parallel
+#' @export
+ts_tempfile <- function(pattern = "file", ..., host=TRUE, pid=TRUE){
+ if( host ) pattern <- c(pattern, Sys.info()['nodename'])
+ if( pid ) pattern <- c(pattern, Sys.getpid())
+ tempfile(paste(pattern, collapse='_'), ...)
+}
+
+#' \code{hostfile} generates a temporary filename composed with
+#' the name of the host machine and/or the current process id.
+#'
+#' @inheritParams base::tempfile
+#' @inheritParams ts_tempfile
+#'
+#' @rdname parallel
+#' @export
+hostfile <- function(pattern = "file", tmpdir=tempdir(), fileext='', host=TRUE, pid=TRUE){
+ if( host ) pattern <- c(pattern, Sys.info()['nodename'])
+ if( pid ) pattern <- c(pattern, Sys.getpid())
+ file.path(tmpdir, str_c(paste(pattern, collapse='.'), fileext))
+}
+
+#' \code{gVariable} generates a function that access a global static variable,
+#' possibly in shared memory (only for numeric matrix-coercible data in this case).
+#' It is used primarily in parallel computations, to preserve data accross
+#' computations that are performed by the same process.
+#'
+#' @param init initial value
+#' @param shared a logical that indicates if the variable should be stored in shared
+#' memory or in a local environment.
+#'
+#' @rdname parallel
+#' @export
+gVariable <- function(init, shared=FALSE){
+
+ if( shared ){ # use bigmemory shared matrices
+ if( !is.matrix(init) )
+ init <- as.matrix(init)
+ requireNamespace('bigmemory')
+ #library(bigmemory)
+ DATA <- bigmemory::as.big.matrix(init, type='double', shared=TRUE)
+ DATA_DESC <- bigmemory::describe(DATA)
+ }else{ # use variables assigned to .GlobalEnv
+ DATA_DESC <- basename(tempfile('.gVariable_'))
+ }
+
+ .VALUE <- NULL
+ .loadpkg <- TRUE
+ function(value){
+
+ # load packages once
+ if( shared && .loadpkg ){
+ requireNamespace('bigmemory')
+ #library(bigmemory)
+ .loadpkg <<- FALSE
+ }
+
+ # if shared: attach bigmemory matrix from its descriptor object
+ if( shared ){
+ DATA <- bigmemory::attach.big.matrix(DATA_DESC)
+ }
+
+ if( missing(value) ){# READ ACCESS
+ if( !shared ){
+ # initialise on first call if necessary
+ if( is.null(.VALUE) ) .VALUE <<- init
+ # return variable
+ .VALUE
+ }else
+ DATA[]
+
+ }else{# WRITE ACCESS
+ if( !shared ) .VALUE <<- value
+ else DATA[] <- value
+
+ }
+ }
+}
+
+#' \code{setupLibPaths} add the path to the NMF package to each workers' libPaths.
+#'
+#' @param pkg package name whose path should be exported the workers.
+#'
+#' @rdname setup
+setupLibPaths <- function(pkg='NMF', verbose=FALSE){
+
+ # do nothing in sequential mode
+ if( is.doSEQ() ) return( character() )
+
+ if( verbose ){
+ message("# Setting up libpath on workers for package(s) "
+ , str_out(pkg, Inf), ' ... ', appendLF=FALSE)
+ }
+ p <- path.package(pkg)
+ if( is.null(p) ) return()
+
+ if( !isDevNamespace(pkg) ){ # not a dev package
+ plibs <- dirname(p)
+ libs <- times(getDoParWorkers()) %dopar% {
+ .libPaths(c(.libPaths(), plibs))
+ }
+ libs <- unique(unlist(libs))
+ if( verbose ){
+ message("OK\n# libPaths:\n", paste(' ', libs, collapse="\n"))
+ }
+ libs
+ pkg
+ }else if( getDoParName() != 'doParallel' || !isNumber(getDoBackend()$data) ){
+ # devmode: load the package + depends
+ if( verbose ){ message("[devtools::load_all] ", appendLF=FALSE) }
+ times(getDoParWorkers()) %dopar% {
+ capture.output({
+ suppressMessages({
+ requireNamespace('devtools')
+ #library(devtools)
+ requireNamespace('bigmemory')
+ #library(bigmemory)
+ devtools::load_all(p)
+ })
+ })
+ }
+ if( verbose ){ message("OK") }
+ c('bigmemory', 'rngtools')
+ }
+ else if( verbose ){
+ message("OK")
+ }
+}
+
+#StaticWorkspace <- function(..., .SHARED=FALSE){
+#
+# # create environment
+# e <- new.env(parent=.GlobalEnv)
+# # fill with initial data
+# vars <- list(...)
+# if( .SHARED ){
+# lapply(names(vars), function(x){
+# bm <- bigmemory::as.big.matrix(vars[[x]], type='double', shared=TRUE)
+# e[[x]] <- bigmemory::describe(bm)
+# })
+# }else
+# list2env(vars, envir=e)
+#
+# structure(e, shared=.SHARED, class=c("static_wsp", 'environment'))
+#}
+#
+#`[[.static_wsp` <- function(x, ..., exact = TRUE){
+# if( attr(x, 'shared') ){
+# var <- bigmemory::attach.big.matrix(NextMethod())
+# var[]
+# }else
+# NextMethod()
+#}
+#
+#`[[.static_wsp<-` <- function(x, i, value){
+#
+# if( attr(x, 'shared') ){
+# var <- bigmemory::attach.big.matrix(x[[i]])
+# var[] <- value
+# }else
+# x[[i]] <- value
+# x
+#}
+
+
+isRNGseed <- function(x){
+ is.numeric(x) ||
+ ( is.list(x)
+ && is.null(names(x))
+ && all(sapply(x, is.numeric)) )
+}
+
+#' \code{setupRNG} sets the RNG for use by the function nmf.
+#' It returns the old RNG as an rstream object or the result of set.seed
+#' if the RNG is not changed due to one of the following reason:
+#' - the settings are not compatible with rstream
+#'
+#' @param seed initial RNG seed specification
+#' @param n number of RNG seeds to generate
+#'
+#' @rdname setup
+setupRNG <- function(seed, n, verbose=FALSE){
+
+ if( verbose == 2 ){
+ message("# Setting up RNG ... ", appendLF=FALSE)
+ on.exit( if( verbose == 2 ) message("OK") )
+ }else if( verbose > 2 ) message("# Setting up RNG ... ")
+
+ if( verbose > 3 ){
+ message("# ** Original RNG settings:")
+ showRNG()
+ }
+
+ # for multiple runs one always uses RNGstreams
+ if( n > 1 ){
+
+ # seeding with numeric values only
+ if( is.list(seed) && isRNGseed(seed) ){
+ if( length(seed) != n )
+ stop("Invalid list of RNG seeds: must be of length ", n)
+
+ if( verbose > 2 ) message("# Using supplied list of RNG seeds")
+ return(seed)
+
+ }else if( is.numeric(seed) ){
+
+ if( verbose > 2 ){
+ message("# Generate RNGStream sequence using seed ("
+ , RNGstr(seed), ") ... "
+ , appendLF=FALSE)
+ }
+ res <- RNGseq(n, seed)
+ if( verbose > 2 ) message("OK")
+ return(res)
+
+ }else{ # create a sequence of RNGstream using a random seed
+ if( verbose > 2 ){
+ message("# Generate RNGStream sequence using a random seed ... "
+ , appendLF=FALSE)
+ }
+ res <- RNGseq(n, NULL)
+ if( verbose > 2 ) message("OK")
+ return(res)
+ }
+ }else if( is.numeric(seed) ){
+ # for single runs: 1-length seeds are used to set the current RNG
+ # 6-length seeds are used to set RNGstream
+
+ if( !is.vector(seed) ){
+ message('ERROR')
+ stop("NMF::nmf - Invalid numeric seed: expects a numeric vector.")
+ }
+
+ # convert to an integer vector
+ seed <- as.integer(seed)
+ # immediately setup the RNG in the standard way
+ if( length(seed) == 1L ){
+ if( verbose > 2 ){
+ message("# RNG setup: standard [seeding current RNG]")
+ message("# Seeding current RNG with seed (", seed, ") ... "
+ , appendLF=FALSE)
+ }
+ set.seed(seed)
+ if( verbose > 2 ) message("OK")
+ return( getRNG() )
+ }else if( length(seed) == 6L ){
+ if( verbose > 2 ){
+ message("# RNG setup: reproducible [using RNGstream]")
+ message("# Generate RNGStream sequence using seed ("
+ , RNGstr(seed), ") ... "
+ , appendLF=FALSE)
+ }
+ res <- RNGseq(1, seed)
+ setRNG(res)
+ if( verbose > 2 ) message("OK")
+ return( res )
+ }else{
+ if( verbose > 2 ){
+ message("# RNG setup: directly setting RNG")
+ message("# Setting RNG with .Random.seed= ("
+ , RNGstr(seed), ") ... "
+ , appendLF=FALSE)
+ }
+ setRNG(seed, verbose > 2)
+ if( verbose > 2 ) message("OK")
+ return( getRNG() )
+ }
+ stop("NMF::nmf - Invalid numeric seed: unexpected error.")
+ }else{
+ if( verbose > 2 ) message("# RNG setup: standard [using current RNG]")
+ NULL
+ }
+}
+
+##################################################################
+## END
+##################################################################
diff --git a/R/registry-algorithms.R b/R/registry-algorithms.R
new file mode 100644
index 0000000..8586679
--- /dev/null
+++ b/R/registry-algorithms.R
@@ -0,0 +1,453 @@
+# NMF algorithm registry access methods
+#
+# Author: Renaud Gaujoux
+###############################################################################
+
+#' @include registry.R
+#' @include NMFStrategy-class.R
+#' @include NMFStrategyFunction-class.R
+#' @include NMFStrategyIterative-class.R
+#' @include NMFStrategyOctave-class.R
+NULL
+
+# create sub-registry for NMF algorithm
+.registryAlgorithm <- setPackageRegistry('algorithm', "NMFStrategy"
+ , description = "Algorithms to solve MF optimisation problems"
+ , entrydesc = "NMF algorithm")
+
+nmfAlgorithmInfo <- function(show=TRUE){
+ obj <- .registryAlgorithm
+ if( show ) print(obj)
+ invisible(obj)
+}
+
+# specific register method for registering NMFStrategy objects
+setMethod('nmfRegister', signature(key='NMFStrategy', method='missing'),
+ function(key, method, ...){
+ nmfRegister(name(key), key, ..., regname='algorithm')
+ }
+)
+
+#' Registering NMF Algorithms
+#'
+#' Adds a new algorithm to the registry of algorithms that perform
+#' Nonnegative Matrix Factorization.
+#'
+#' @inheritParams NMFStrategy
+#' @param ... arguments passed to the factory function \code{\link{NMFStrategy}},
+#' which instantiate the \code{\linkS4class{NMFStrategy}} object that is stored
+#' in registry.
+#' @param overwrite logical that indicates if any existing NMF method with the
+#' same name should be overwritten (\code{TRUE}) or not (\code{FALSE}),
+#' in which case an error is thrown.
+#' @param verbose a logical that indicates if information about the registration
+#' should be printed (\code{TRUE}) or not (\code{FALSE}).
+#'
+#' @export
+#' @examples
+#'
+#' # define/regsiter a new -- dummy -- NMF algorithm with the minimum arguments
+#' # y: target matrix
+#' # x: initial NMF model (i.e. the seed)
+#' # NB: this algorithm simply return the seed unchanged
+#' setNMFMethod('mynmf', function(y, x, ...){ x })
+#'
+#' # check algorithm on toy data
+#' res <- nmfCheck('mynmf')
+#' # the NMF seed is not changed
+#' stopifnot( nmf.equal(res, nmfCheck('mynmf', seed=res)) )
+#'
+setNMFMethod <- function(name, method, ..., overwrite=isLoadingNamespace(), verbose=TRUE){
+
+ # build call to NMFStrategy constructor
+ call_const <- match.call(NMFStrategy)
+ call_const[[1]] <- as.name('NMFStrategy')
+ call_const$verbose <- NULL
+ call_const$overwrite <- NULL
+ # swap name and method if method is missing and name is a registered method
+ if( missing(method) && !missing(name) && is.character(name) && existsNMFMethod(name) ){
+ call_const$method <- name
+ call_const$name <- NULL
+ }
+ # build the NMFStrategy object (in the parent frame to get the package slot right)
+ e <- parent.frame()
+ method <- eval(call_const, envir=e)
+ # add to the algorithm registry
+ res <- nmfRegister(method, overwrite=overwrite, verbose=verbose)
+ # return wrapper function invisibly
+ wrap <- nmfWrapper(method)
+}
+
+#' \code{nmfRegisterAlgorithm} is an alias to \code{setNMFMethod} for backward
+#' compatibility.
+#'
+#' @export
+#' @rdname setNMFMethod
+nmfRegisterAlgorithm <- setNMFMethod
+
+
+#' Registry for NMF Algorithms
+#'
+#' @name methods-NMF
+#' @rdname registry-algorithm
+#' @family regalgo Registry for NMF algorithms
+NULL
+
+#' Testing Compatibility of Algorithm and Models
+#'
+#' \code{canFit} is an S4 generic that tests if an algorithm can
+#' fit a particular model.
+#'
+#' @param x an object that describes an algorithm
+#' @param y an object that describes a model
+#' @param ... extra arguments to allow extension
+#'
+#' @export
+#' @inline
+#' @family regalgo
+setGeneric('canFit', function(x, y, ...) standardGeneric('canFit') )
+#' Tells if an NMF algorithm can fit a given class of NMF models
+#'
+#' @param exact for logical that indicates if an algorithm is considered able to fit
+#' only the models that it explicitly declares (\code{TRUE}), or if it should be
+#' considered able to also fit models that extend models that it explicitly fits.
+#'
+setMethod('canFit', signature(x='NMFStrategy', y='character'),
+ function(x, y, exact=FALSE){
+
+ if( !exact ){
+
+ # check for one model amongst all the models fittable by the strategy
+ can <- if( length(mo <- modelname(x)) > 1 )
+ sapply(mo, function(m) extends(y, m))
+ else extends(y, mo)
+ any(can)
+
+ }else
+ is.element(y, modelname(x))
+ }
+)
+#' Tells if an NMF algorithm can fit the same class of models as \code{y}
+setMethod('canFit', signature(x='NMFStrategy', y='NMF'),
+ function(x, y, ...){
+ canFit(x, modelname(y), ...)
+ }
+)
+#' Tells if a registered NMF algorithm can fit a given NMF model
+setMethod('canFit', signature(x='character', y='ANY'),
+ function(x, y, ...){
+ canFit(nmfAlgorithm(x), y, ...)
+ }
+)
+
+#' \code{selectNMFMethod} tries to select an appropriate NMF algorithm that is
+#' able to fit a given the NMF model.
+#'
+#' @param name name of a registered NMF algorithm
+#' @param model class name of an NMF model, i.e. a class that inherits from class
+#' \code{\linkS4class{NMF}}.
+#' @param load a logical that indicates if the selected algorithms should be loaded
+#' into \code{NMFStrategy} objects
+#' @param all a logical that indicates if all algorithms that can fit \code{model}
+#' should be returned or only the default or first found.
+#' @param quiet a logical that indicates if the operation should be performed quietly,
+#' without throwing errors or warnings.
+#'
+#' @return \code{selectNMFMethod} returns a character vector or \code{NMFStrategy} objects,
+#' or NULL if no suitable algorithm was found.
+#'
+#' @rdname registry-algorithm
+#'
+selectNMFMethod <- function(name, model, load=FALSE, exact=FALSE, all=FALSE, quiet=FALSE){
+
+ # lookup for an algorithm suitable for the given NMF model
+ if( !isNMFclass(model) )
+ stop("argument 'model' must be the name of a class that extends class 'NMF'")
+
+
+ algo_list <- if( !missing(name) ){
+ algo <- nmfAlgorithm(name)
+ name(algo)
+ }else nmfAlgorithm()
+
+ # lookup for all the algorithms that can fit the given model
+ #NB: if only one model needs to be selected then first look for an exact fit as
+ # this would need to be done with exact=FALSE and TRUE anyways
+ w <- sapply(algo_list, canFit, model, exact= if(all) exact else TRUE)
+ algo <- algo_list[w]
+
+ # if no suitable algorithm was found, and an exact match is not required
+ # then look for other potential non-exact algorithms
+ if( !all && !exact && length(algo) == 0 ){
+ w <- sapply(algo_list, canFit, model, exact=FALSE)
+ algo <- algo_list[w]
+ }
+
+ # return NULL if no algorithm was found
+ if( length(algo) == 0L ){
+ if( !quiet )
+ stop("Could not find an NMF algorithm to fit model '", model, "'"
+ , if( !missing(name) ) paste(" amongst ", str_out(algo_list, Inf)))
+ return(NULL)
+ }
+
+ # if all=FALSE then try to choose the default algorithm if present in the list, or the first one
+ res <- if( !all && length(algo) > 1L ){
+
+ idx <- which( algo == nmf.getOption('default.algorithm') )
+ if( !length(idx) ) idx <- 1L
+
+ res <- algo[idx]
+ if( !quiet )
+ warning("Selected NMF algorithm '", res, "' amongst other possible algorithm(s): "
+ , paste(paste("'", algo[-idx], "'", sep=''), collapse=", "))
+ res
+ }else # otherwise return all the algorithms
+ algo
+
+ # load the methods if required
+ if( load ){
+ if( length(res) > 1 ) sapply(res, nmfAlgorithm) else nmfAlgorithm(res)
+ }
+ else
+ res
+}
+
+
+#' \code{getNMFMethod} retrieves NMF algorithm objects from the registry.
+#'
+#' @param ... extra arguments passed to \code{\link[pkgmaker]{pkgreg_fetch}}
+#' or \code{\link[pkgmaker]{pkgreg_remove}}.
+#'
+#' @export
+#' @rdname registry-algorithm
+getNMFMethod <- function(...) nmfGet('algorithm', ...)
+
+#' Listing and Retrieving NMF Algorithms
+#'
+#' \code{nmfAlgorithm} lists access keys or retrieves NMF algorithms that are
+#' stored in registry.
+#' It allows to list
+#'
+#' @param name Access key.
+#' If not missing, it must be a single character string that is partially matched
+#' against the available algorithms in the registry.
+#' In this case, if \code{all=FALSE} (default), then the algorithm is returned
+#' as an \code{NMFStrategy} object that can be directly passed to \code{\link{nmf}}.
+#' An error is thrown if no matching algorithm is found.
+#'
+#' If missing or \code{NULL}, then access keys of algorithms -- that
+#' match the criteria \code{version}, are returned.
+#' This argument is assumed to be regular expression if \code{all=TRUE} or
+#' \code{version} is not \code{NULL}.
+#' @param version version of the algorithm(s) to retrieve.
+#' Currently only value \code{'R'} is supported, which searched for plain R
+#' implementations.
+#' @param all a logical that indicates if all algorithm keys should be returned,
+#' including the ones from alternative algorithm versions (e.g. plain R
+#' implementations of algorithms, for which a version based on optimised
+#' C updates is used by default).
+#' @param ... extra arguments passed to \code{\link{getNMFMethod}} when \code{name}
+#' is not \code{NULL} and \code{all=FALSE}. It is not used otherwise.
+#'
+#' @return an \code{\linkS4class{NMFStrategy}} object if \code{name} is not
+#' \code{NULL} and \code{all=FALSE}, or a named character vector that contains
+#' the access keys of the matching algorithms.
+#' The names correspond to the access key of the primary algorithm: e.g.
+#' algorithm \sQuote{lee} has two registered versions, one plain R (\sQuote{.R#lee})
+#' and the other uses optimised C updates (\sQuote{lee}), which will all get
+#' named \sQuote{lee}.
+#'
+#' @export
+#' @family regalgo
+#'
+#' @examples
+#'
+#' # list all main algorithms
+#' nmfAlgorithm()
+#' # list all versions of algorithms
+#' nmfAlgorithm(all=TRUE)
+#' # list all plain R versions
+#' nmfAlgorithm(version='R')
+#'
+nmfAlgorithm <- function(name=NULL, version=NULL, all=FALSE, ...){
+
+ # if one passes an NMFStrategy just returns it
+ if( is(name, 'NMFStrategy') ) return(name)
+
+ # force all=TRUE if type is provided
+ if( !is.null(version) ) all <- TRUE
+
+ # directly return the algorithm object if a key is supplied and all=FALSE
+ if( !is.null(name) && !all ) return( getNMFMethod(name, ...) )
+
+ # get all algorithms
+ algo <- getNMFMethod(all=TRUE)
+ # set names to match the primary key
+ algo <- setNames(algo, sub("^\\.(.+#)?", '', algo))
+ # filter out hidden methods
+ if( !all ) algo <- algo[!grepl("^\\.", algo)]
+ # filter out methods not from the requested algorithm
+ if( !is.null(name) ) algo <- algo[grepl(str_c("^", name), names(algo))]
+ # filter out types
+ if( !is.null(version) ){
+ type <- match.arg(version, c('R'))
+ algo <- Filter( function(x) grepl(str_c("^\\.", version, '#'), x), algo)
+ }
+
+ # remove names if no arguments
+ if( is.null(version) ) algo <- setNames(algo, NULL)
+ # return the selected algorithm(s)
+ algo
+}
+
+#' \code{existsNMFMethod} tells if an NMF algorithm is registered under the
+#'
+#' @param exact a logical that indicates if the access key should be matched
+#' exactly (\code{TRUE}) or partially (\code{FALSE}).
+#'
+#' @export
+#' @rdname registry-algorithm
+existsNMFMethod <- function(name, exact=TRUE){
+
+ !is.null( getNMFMethod(name, error=FALSE, exact=exact) )
+
+}
+
+#' \code{removeNMFMethod} removes an NMF algorithm from the registry.
+#'
+#' @export
+#' @rdname registry-algorithm
+removeNMFMethod <- function(name, ...){
+ pkgreg_remove('algorithm', key=name, ...)
+}
+
+
+#' Wrapping NMF Algorithms
+#'
+#' This function creates a wrapper function for calling the function \code{\link{nmf}}
+#' with a given NMF algorithm.
+#'
+#' @param method Name of the NMF algorithm to be wrapped.
+#' It should be the name of a registered algorithm as returned by \code{\link{nmfAlgorithm}},
+#' or an NMF algorithm object (i.e. an instance of \code{\linkS4class{NMFStrategy}}).
+#' @param ... extra named arguments that define default values for any arguments
+#' of \code{\link{nmf}} or the algorithm itself.
+#' @param .FIXED a logical that indicates if the default arguments defined in \code{...}
+#' must be considered as fixed, i.e. that they are forced to have the defined values and cannot
+#' be used in a call to the wrapper function, in which case, a warning about discarding them
+#' is thrown if they are used.
+#' Non fixed arguments may have their value changed at call time, in which case it is honoured and
+#' passed to the \code{nmf} call.
+#'
+#' \code{.FIXED} may also be a character vector that specifies which argument amongst \code{...}
+#' should be considered as fixed.
+#' @return a function with argument \code{...} and a set of default arguments defined
+#' in \code{...} in the call to \code{nmfWrapper}.
+#'
+#' @seealso \code{\link{nmfAlgorithm}}, \code{\link{nmf}}
+#' @keywords internal
+#' @export
+#'
+#' @examples
+#'
+#' # wrap Lee & Seung algorithm into a function
+#' lee <- nmfWrapper('lee', seed=12345)
+#' args(lee)
+#'
+#' # test on random data
+#' x <- rmatrix(100,20)
+#' res <- nmf(x, 3, 'lee', seed=12345)
+#' res2 <- lee(x, 3)
+#' nmf.equal(res, res2)
+#' res3 <- lee(x, 3, seed=123)
+#' nmf.equal(res, res3)
+#'
+#' \dontshow{
+#' stopifnot(nmf.equal(res, res2))
+#' stopifnot( !nmf.equal(res, res3))
+#' }
+#'
+#' # argument 'method' has no effect
+#' res4 <- lee(x, 3, method='brunet')
+#' nmf.equal(res, res4)
+#'
+#' \dontshow{
+#' stopifnot(nmf.equal(res, res4))
+#' }
+#'
+#'
+nmfWrapper <- function(method, ..., .FIXED=FALSE){
+
+ # store original call
+ .call <- match.call()
+
+ # check that all arguments are named
+ if( nargs() > 1L && any(names(.call)[-(1:2)]=='') )
+ stop("Invalid call: all arguments must be named.")
+
+ # store fixed arguments from default arguments
+ .fixedargs <- 'method'
+ .defaults <- names(.call)[-1L]
+ .defaults <- .defaults[!.defaults %in% 'method']
+ if( length(.defaults) ){
+# e <- parent.frame()
+# for(n in .defaults){
+# .call[[n]] <- eval(.call[[n]], envir=e)
+# }
+ if( isTRUE(.FIXED) ) .fixedargs <- c(.fixedargs, .defaults)
+ else if( is.character(.FIXED) ){
+ .FIXED <- .FIXED[.FIXED %in% .defaults]
+ .fixedargs <- c(.fixedargs, .FIXED)
+ }
+ }
+ # store in local environment
+ .method <- method
+
+ .checkArgs <- function(ca, args){
+ # check for fixed arguments passed in the call that need
+ # to be discarded
+ nm <- names(ca)[-1L]
+ if( any(fnm <- !is.na(pmatch(nm, .fixedargs))) ){
+ warning("Discarding fixed arguments from wrapped call to ", .call[1L]
+ , " [", str_out(nm[fnm], Inf), '].', immediate.=TRUE)
+ ca <- ca[!c(FALSE, fnm)]
+ }
+ #
+
+ # start with complete call
+ .call <- ca
+ # set values of wrapper default arguments if any
+ if( length(.defaults) ){
+ defaults <- args[.defaults]
+ .call <- expand_list(ca, defaults, .exact=FALSE)
+ }
+ # change into a call to nmf
+ .call[[1L]] <- as.name('nmf')
+ .call[['method']] <- force(.method)
+ as.call(.call)
+ }
+
+ # define wrapper function
+ fwrap <- function(...){
+ ca <- match.call()
+ args <- formals()
+ .call <- .checkArgs(ca, args)
+ # eval in parent environment
+ e <- parent.frame()
+ eval(.call, envir=e)
+ }
+
+ # add default arguments to signature
+ if( length(.defaults) ){
+ formals(fwrap) <- expand_list(formals(fwrap), as.list(.call[.defaults]))
+ }
+ # add arguments from the NMF algorithm
+ if( length(meth <- nmfFormals(.method)) ){
+ formals(fwrap) <- expand_list(formals(fwrap), meth)
+ }
+
+ return( fwrap )
+
+}
+
diff --git a/R/registry-seed.R b/R/registry-seed.R
new file mode 100644
index 0000000..e532ef6
--- /dev/null
+++ b/R/registry-seed.R
@@ -0,0 +1,127 @@
+# Registry for NMF seeding method
+#
+# Author: Renaud Gaujoux
+###############################################################################
+
+#' @include registry.R
+#' @include NMFSeed-class.R
+NULL
+
+# create sub-registry for seeding methods
+.registrySeed <- setPackageRegistry('seed', "NMFSeed"
+ , description = "Initialization methods for NMF algorithms"
+ , entrydesc = 'NMF seeding method')
+
+nmfSeedInfo <- function(show=TRUE){
+ obj <- .registrySeed
+ if( show ) print(obj)
+ invisible(obj)
+}
+
+#' Seeding Strategies for NMF Algorithms
+#'
+#' \code{nmfSeed} lists and retrieves NMF seeding methods.
+#'
+#' Currently the internal registry contains the following seeding methods,
+#' which may be specified to the function \code{\link{nmf}} via its argument
+#' \code{seed} using their access keys:
+#'
+#' \describe{
+#' \item{random}{ The entries of each factors are drawn from a uniform
+#' distribution over \eqn{[0, max(x)]}, where $x$ is the target matrix.}
+#' \item{nndsvd}{ Nonnegative Double Singular Value Decomposition.
+#'
+#' The basic algorithm contains no randomization and is based on two SVD processes,
+#' one approximating the data matrix, the other approximating positive sections
+#' of the resulting partial SVD factors utilising an algebraic property of
+#' unit rank matrices.
+#'
+#' It is well suited to initialise NMF algorithms with sparse factors.
+#' Simple practical variants of the algorithm allows to generate dense factors.
+#'
+#' \strong{Reference:} \cite{Boutsidis2008}}
+#' \item{ica}{ Uses the result of an Independent Component Analysis (ICA)
+#' (from the \code{fastICA} package).
+#' Only the positive part of the result are used to initialise the factors.}
+#' \item{none}{ Fixed seed.
+#'
+#' This method allows the user to manually provide initial values for
+#' both matrix factors.}
+#' }
+#'
+#' @param name access key of a seeding method stored in registry.
+#' If missing, \code{nmfSeed} returns the list of all available seeding methods.
+#' @param ... extra arguments used for internal calls
+#'
+#' @export
+#'
+#' @examples
+#'
+#' # list all registered seeding methods
+#' nmfSeed()
+#' # retrieve one of the methods
+#' nmfSeed('ica')
+#'
+nmfSeed <- function(name=NULL, ...){
+
+ nmfGet('seed', name, ...)
+
+}
+
+#' \code{getNMFSeed} is an alias for \code{nmfSeed}.
+#' @rdname nmfSeed
+#' @export
+getNMFSeed <- nmfSeed
+
+#' \code{existsNMFSeed} tells if a given seeding method exists in the registry.
+#'
+#' @param exact a logical that indicates if the access key should be matched
+#' exactly or partially.
+#'
+#' @rdname nmfSeed
+#' @export
+existsNMFSeed <- function(name, exact=TRUE){
+
+ res <- !is.null( getNMFSeed(name, error=FALSE, exact=exact) )
+ return(res)
+
+}
+
+# specific register method for registering NMFSeed objects
+setMethod('nmfRegister', signature(key='NMFSeed', method='missing'),
+ function(key, method, ...){
+ nmfRegister(name(key), key, ..., regname='seed')
+ }
+)
+
+#' Registering NMF Seeding Methods
+#'
+#' NMF seeding methods are registered via the function \code{setNMFSeed}, which
+#' stores them as \code{\linkS4class{NMFSeed}} objects in a dedicated registry.
+#'
+#' @param ... arguments passed to \code{NMFSeed} and used to initialise slots
+#' in the \code{\linkS4class{NMFSeed}} object, or to \code{\link[pkgmaker]{pkgreg_remove}}.
+#' @inheritParams setNMFMethod
+#'
+#' @export
+setNMFSeed <- function(..., overwrite=isLoadingNamespace(), verbose=TRUE){
+
+ # wrap function method into a new NMFSeed object
+ method <- NMFSeed(...)
+ # register the newly created object
+ res <- nmfRegister(method, overwrite=overwrite, verbose=verbose)
+}
+
+nmfRegisterSeed <- setNMFSeed
+
+
+#' \code{removeNMFSeed} removes an NMF seeding method from the registry.
+#'
+#' @param name name of the seeding method.
+#'
+#' @export
+#' @rdname setNMFSeed
+removeNMFSeed <- function(name, ...){
+ pkgreg_remove('seed', key=name, ...)
+}
+
diff --git a/R/registry.R b/R/registry.R
new file mode 100644
index 0000000..6a79580
--- /dev/null
+++ b/R/registry.R
@@ -0,0 +1,96 @@
+###% Define access/setup methods for NMF package registry.
+###%
+###% The registry is used to provide a common interface to NMF methods (algorithms, seeding methods, distance, ...).
+###% It enables the user to add custom methods which will be accessible in the same way as the built-in ones.
+###%
+###% @author Renaud Gaujoux
+###% @created 22 Jul 2009
+
+
+###########################################################################
+# COMMON REGISTRY
+###########################################################################
+
+#' @import pkgmaker
+#' @import registry
+nmfRegistry <- function(...) pkgmaker::packageRegistry(...)
+
+# Returns the names of all the packages that contibute to all or a given
+# package's primary registry
+registryContributors <- function(package, regname = NULL){
+ regs <- packageRegistries(regname = regname, package = package, primary = TRUE)
+ if( length(regs) ) unique(names(unlist(lapply(paste0(package, '::', regs), packageRegistries))))
+}
+
+###% Return a method stored in the NMF registry.
+###%
+###% @param name the key (a character string) of the method to be retrieved
+###% @param regname the name of the sub-registry where to look for the \code{key}
+###% @param exact a boolean. When set to \code{TRUE} the key is searched exactly, otherwise (default) the key
+###% is matched partially with the keys registered in the registry.
+###% @param error a boolean. When set to \code{TRUE} (default) the function will raise an error if the key is not found.
+###% Otherwise it will not raise any error and return \code{NULL}.
+###%
+nmfGet <- function(regname, name=NULL, ...){
+
+ # retrieve from the given package's sub-registry
+ pkgmaker::pkgreg_fetch(regname, key=name, ...)
+
+}
+
+###% Register a NMF method so that it is accessible via the common interface defined by the \code{nmf} function.
+###% @param method an NMFStrategy object or a function that defines the method
+###% @param key a non-empty character string that will be used as an identifier to access the method
+###% @param overwrite a boolean that specify if an existing method (i.e. with exactly the same \code{key}) should be overwritten or not.
+###% If \code{FALSE} and a method with the same key exists, an error will be thrown.
+###% @param save [Not used] a boolean that if set to \code{TRUE} will save in database so that it is available in other R sessions.
+###% @param ... [Not used]
+###%
+###% @return \code{TRUE} invisibly in case of success.
+###%
+###% @seealso nmf
+###%
+setGeneric('nmfRegister', function(key, method, ...) standardGeneric('nmfRegister') )
+setMethod('nmfRegister', signature(key='character'),
+ function(key, method, regname, ...){
+ #TODO: add functionality to save the registered strategy into a file for use is other R sessions
+
+ parent.method <- attr(method, 'parent')
+ tmpl <- if( !is.null(parent.method) && parent.method != key ){
+ str_c(" based on template '", parent.method, "'")
+ }
+ setPackageRegistryEntry(regname, key, method, ..., where='NMF', msg=tmpl)
+ }
+)
+
+####% Unregister a NMF method.
+####%
+####% @param name the key of the method to unregister [character string]
+####%
+#nmfUnregister <- function(name, regname, quiet=FALSE){
+#
+# return( pkgreg_remove(regname, key=name, quiet=quiet) )
+# # add the strategy to the registry
+# obj <- nmfGet(name, exact=TRUE, error=FALSE, regname=regname)
+# regentry <- nmfRegistry(regname, entry=TRUE)
+# registry <- regentry$regobj
+# objtype <- regentry$entrydesc
+#
+# if( !is.null(obj) ){
+# # get the method registry and the method's fullname
+# name <- attr(strategy, 'name')
+#
+# if( !quiet ){
+# msg <- paste0("Removing ", objtype," '", name, "' from registry '", regname, "' [", class(obj), ']')
+# message(msg, ' ... ', appendLF=FALSE)
+# }
+# # delete from registry
+# registry$delete_entry(name)
+# if( !quiet ) message('OK')
+# TRUE
+# }else{
+# if( !quiet )
+# warning("Could not remove ", objtype, " '", name, "': no matching registry entry.", call.=FALSE)
+# FALSE
+# }
+#}
diff --git a/R/rmatrix.R b/R/rmatrix.R
new file mode 100644
index 0000000..38e0625
--- /dev/null
+++ b/R/rmatrix.R
@@ -0,0 +1,137 @@
+# Generation of random matrices
+#
+# Defines the generic function `rmatrix` and basic methods for it.
+#
+# Author: Renaud Gaujoux
+###############################################################################
+
+
+#' Generating Random Matrices
+#'
+#' The S4 generic \code{rmatrix} generates a random matrix from a given object.
+#' Methods are provided to generate matrices with entries drawn from any
+#' given random distribution function, e.g. \code{\link{runif}} or
+#' \code{\link{rnorm}}.
+#'
+#' @param x object from which to generate a random matrix
+#'
+#' @export
+setGeneric('rmatrix', function(x, ...) standardGeneric('rmatrix'))
+#' Generates a random matrix of given dimensions, whose entries
+#' are drawn using the distribution function \code{dist}.
+#'
+#' This is the workhorse method that is eventually called by all other methods.
+#' It returns a matrix with:
+#' \itemize{
+#' \item \code{x} rows and \code{y} columns if \code{y} is not missing and
+#' not \code{NULL};
+#' \item dimension \code{x[1]} x \code{x[2]} if \code{x} has at least two elements;
+#' \item dimension \code{x} (i.e. a square matrix) otherwise.
+#' }
+#'
+#' The default is to draw its entries from the standard uniform distribution using
+#' the base function \code{\link{runif}}, but any other function that generates
+#' random numeric vectors of a given length may be specified in argument \code{dist}.
+#' All arguments in \code{...} are passed to the function specified in \code{dist}.
+#'
+#' The only requirement is that the function in \code{dist} is of the following form:
+#'
+#' \samp{
+#' function(n, ...){
+#' # return vector of length n
+#' ...
+#' }}
+#'
+#' This is the case of all base random draw function such as \code{\link{rnorm}},
+#' \code{\link{rgamma}}, etc\ldots
+#'
+#'
+#' @param y optional specification of number of columns
+#' @param dist a random distribution function or a numeric seed (see details of method
+#' \code{rmatrix,numeric})
+#' @param byrow a logical passed in the internal call to the function
+#' \code{\link{matrix}}
+#' @param dimnames \code{NULL} or a \code{list} passed in the internal call to
+#' the function \code{\link{matrix}}
+#' @param ... extra arguments passed to the distribution function \code{dist}.
+#'
+#' @inline
+#'
+#' @examples
+#' ## Generate a random matrix of a given size
+#' rmatrix(5, 3)
+#' \dontshow{ stopifnot( identical(dim(rmatrix(5, 3)), c(5L,3L)) ) }
+#'
+#' ## Generate a random matrix of the same dimension of a template matrix
+#' a <- matrix(1, 3, 4)
+#' rmatrix(a)
+#' \dontshow{ stopifnot( identical(dim(rmatrix(a)), c(3L,4L)) ) }
+#'
+#' ## Specificy the distribution to use
+#'
+#' # the default is uniform
+#' a <- rmatrix(1000, 50)
+#' \dontrun{ hist(a) }
+#'
+#' # use normal ditribution
+#' a <- rmatrix(1000, 50, rnorm)
+#' \dontrun{ hist(a) }
+#'
+#' # extra arguments can be passed to the random variate generation function
+#' a <- rmatrix(1000, 50, rnorm, mean=2, sd=0.5)
+#' \dontrun{ hist(a) }
+#'
+setMethod('rmatrix', 'numeric',
+ function(x, y=NULL, dist=runif, byrow = FALSE, dimnames = NULL, ...){
+
+ x <- as.integer(x)
+ # early exit if x has length 0
+ if( length(x) == 0L )
+ stop("NMF::rmatrix - invalid empty vector in argument `x`.")
+
+ # check/ensure that 'dist' is a function.
+ if( is.null(dist) ) dist <- runif
+ if( isNumber(dist) ){
+ os <- RNGseed()
+ on.exit( RNGseed(os), add=TRUE)
+ set.seed(dist)
+ dist <- runif
+ }
+ if( !is.function(dist) )
+ stop("NMF::rmatrix - invalid value for argument 'dist': must be a function [class(dist)='", class(dist), "'].")
+
+ # if 'y' is not specified:
+ if( is.null(y) ){
+
+ if( length(x) == 1L ) y <- x # create a square matrix
+ else{ # assume x contains all dimensions (e.g. returned by dim())
+ y <- x[2L]
+ x <- x[1L]
+ }
+
+ }else{
+ y <- as.integer(y)
+ y <- y[1L] # only use first element
+ }
+
+ # build the random matrix using the distribution function
+ matrix(dist(x*y, ...), x, y, byrow=byrow, dimnames=dimnames)
+ }
+)
+
+#' Default method which calls \code{rmatrix,vector} on the dimensions of \code{x}
+#' that is assumed to be returned by a suitable \code{dim} method:
+#' it is equivalent to \code{rmatrix(dim(x), y=NULL, ...)}.
+#'
+#' @examples
+#'
+#' # random matrix of the same dimension as another matrix
+#' x <- matrix(3,4)
+#' dim(rmatrix(x))
+#'
+setMethod('rmatrix', 'ANY',
+ function(x, ...){
+ rmatrix(x=dim(x), y=NULL, ...)
+ }
+)
+
diff --git a/R/rnmf.R b/R/rnmf.R
new file mode 100644
index 0000000..6b35f5b
--- /dev/null
+++ b/R/rnmf.R
@@ -0,0 +1,368 @@
+# Generation of Random NMF Models
+#
+# Author: Renaud Gaujoux
+# Creation: 03 Jul 2012
+###############################################################################
+
+#' @include nmfModel.R
+NULL
+
+.rnmf_fixed <- oneoffVariable('none')
+
+#' Generates a random NMF model of the same class and rank as another NMF model.
+#'
+#' This is the workhorse method that is eventually called by all other methods.
+#' It generates an NMF model of the same class and rank as \code{x}, compatible with the
+#' dimensions specified in \code{target}, that can be a single or 2-length
+#' numeric vector, to specify a square or rectangular target matrix respectively.
+#'
+#' The second dimension can also be passed via argument \code{ncol}, so that
+#' calling \code{rnmf(x, 20, 10, ...)} is equivalent to \code{rnmf(x, c(20, 10), ...)},
+#' but easier to write.
+#'
+#' The entries are uniformly drawn between \code{0} and \code{max}
+#' (optionally specified in \code{...}) that defaults to 1.
+#'
+#' By default the dimnames of \code{x} are set on the returned NMF model.
+#' This behaviour is disabled with argument \code{keep.names=FALSE}.
+#' See \code{\link{nmfModel}}.
+#'
+#' @param ncol single numeric value that specifies the number of columns of the
+#' coefficient matrix. Only used when \code{target} is a single numeric value.
+#' @param keep.names a logical that indicates if the dimension names of the
+#' original NMF object \code{x} should be conserved (\code{TRUE}) or discarded
+#' (\code{FALSE}).
+#' @param dist specification of the random distribution to use to draw the entries
+#' of the basis and coefficient matrices.
+#' It may be specified as:
+#' \itemize{
+#'
+#' \item a \code{function} which must be a distribution function such as e.g.
+#' \code{\link{runif}} that is used to draw the entries of both the basis and
+#' coefficient matrices. It is passed in the \code{dist} argument of
+#' \code{\link{rmatrix}}.
+#'
+#' \item a \code{list} of arguments that are passed internally to \code{\link{rmatrix}},
+#' via \code{do.call('rmatrix', dist)}.
+#'
+#' \item a \code{character} string that is partially matched to \sQuote{basis} or
+#' \sQuote{coef}, that specifies which matrix in should be drawn randomly, the
+#' other remaining as in \code{x} -- unchanged.
+#'
+#' \item a \code{list} with elements \sQuote{basis} and/or \sQuote{coef}, which
+#' specify the \code{dist} argument separately for the basis and coefficient
+#' matrix respectively.
+#'
+#' These elements may be either a distribution function, or a list of arguments that
+#' are passed internally to \code{\link{rmatrix}}, via
+#' \code{do.call('rmatrix', dist$basis)}
+#' or \code{do.call('rmatrix', dist$coef)}.
+#' }
+#'
+#' @inline
+#' @examples
+#'
+#' ## random NMF of same class and rank as another model
+#'
+#' x <- nmfModel(3, 10, 5)
+#' x
+#' rnmf(x, 20) # square
+#' rnmf(x, 20, 13)
+#' rnmf(x, c(20, 13))
+#'
+#' # using another distribution
+#' rnmf(x, 20, dist=rnorm)
+#'
+#' # other than standard model
+#' y <- rnmf(3, 50, 10, model='NMFns')
+#' y
+#' \dontshow{ stopifnot( identical(dim(y), c(50L,10L,3L)) ) }
+#' \dontshow{ stopifnot( is(y, 'NMFns') ) }
+#'
+setMethod('rnmf', signature(x='NMF', target='numeric'),
+ function(x, target, ncol=NULL, keep.names=TRUE, dist=runif){
+
+ # store original dimnames
+ if( keep.names ) dn <- dimnames(x)
+
+ # valid parameter 'target'
+ if( length(target) != 1 && length(target) != 2 )
+ stop('NMF::rnmf - invalid target dimensions [length must be 1 or 2. Here length = ', length(target) ,']')
+ if( any(is.na(target)) )
+ stop('NMF::rnmf - invalid target dimensions [NA values in element(s): ', paste(which(is.na(target)), collapse=' and '), ']')
+ # shortcut for symetric case: provide only one dimension
+ if( length(target) == 1L ){
+ ncol <- if( !is.null(ncol) ){
+ if( !is.numeric(ncol) || length(ncol) != 1 || is.na(ncol) )
+ stop("NMF::rnmf - invalid argument `ncol`: must be a single numeric value")
+ ncol
+ }else target
+ target <- c(target, ncol)
+ }
+
+ # retrieve dimension of the target matrix
+ n <- target[1]; m <- target[2];
+ # retrieve the factorization rank
+ r <- nbasis(x)
+
+ ## draw basis and coef matrices
+ # interpret argument dist
+ if( length(dist) == 0L ) dist <- runif
+ if( is.character(dist) ){
+ dist <- match.arg(dist, c('basis', 'coef'))
+ dist <- setNames(list(runif), dist)
+ }
+ if( is.function(dist) ){
+ dist <- list(basis = list(x=n, y=r, dist=dist)
+ , coef = list(x=r, y=m, dist=dist))
+ }else if( is.list(dist) ){
+ if( !all(names(dist) %in% c('basis', 'coef')) ){
+ dist <- list(basis=c(list(x=n, y=r), dist)
+ , coef=c(list(x=r, y=m), dist))
+ }else{
+ if( !is.null(dist$basis) )
+ dist$basis <- c(list(x=n, y=r), dist$basis)
+ if( !is.null(dist$coef) )
+ dist$coef <- c(list(x=r, y=m), dist$coef)
+ }
+ }
+
+ fixed <- .rnmf_fixed()
+ #Vc# Initialize random matrix: W
+ # NB: this will keep the values of fixed basis terms
+ if( !is.null(dist$basis) && !('basis' %in% fixed) ){
+ basis(x) <- do.call('rmatrix', dist$basis);
+ }
+ #Vc# Initialize random matrix: H
+ # NB: this will keep the values of fixed coef terms
+ if( !is.null(dist$coef) && !('coef' %in% fixed) ){
+ coef(x) <- do.call('rmatrix', dist$coef);
+ }
+
+ # if one needs to keep the names (possibly or reducing/increasing)
+ if( keep.names && !is.null(dn) )
+ dimnames(x) <- list(dn[[1]][1:n], dn[[2]][1:m], dn[[3]][1:r])
+
+ # return the modified object
+ x
+ }
+)
+
+#' Generates a random NMF model compatible and consistent with a target matrix.
+#'
+#' The entries are uniformly drawn between \code{0} and \code{max(target)}.
+#' It is more or less a shortcut for:
+#' \samp{ rnmf(x, dim(target), max=max(target), ...)}
+#'
+#' It returns an NMF model of the same class as \code{x}.
+#'
+#' @param use.dimnames a logical that indicates whether the dimnames of the
+#' target matrix should be set on the returned NMF model.
+#'
+#' @inline
+#'
+#' @examples
+#' # random NMF compatible with a target matrix
+#' x <- nmfModel(3, 10, 5)
+#' y <- rmatrix(20, 13)
+#' rnmf(x, y) # rank of x
+#' rnmf(2, y) # rank 2
+#'
+setMethod('rnmf', signature(x='ANY', target='matrix'),
+ function(x, target, ..., dist=list(max=max(max(target, na.rm=TRUE), 1)), use.dimnames=TRUE){
+
+ # build a random NMF with the dimensions of the target matrix upper-bounded by the target's maximum entry.
+ res <- rnmf(x, dim(target), ..., dist=dist)
+ # compute the upper-bound of the random entries and enforce it if possible
+ no.na <- abs(target[!is.na(target)])
+ if( length(no.na) > 0 ){
+ m <- max(no.na)
+ basis(res) <- pmin(basis(res), m)
+ coef(res) <- pmin(coef(res), m)
+ }
+
+ # set the dimnames from the target matrix if necessary
+ if( use.dimnames )
+ dimnames(res) <- dimnames(target)
+
+ # return result
+ res
+ }
+)
+#' Shortcut for \code{rnmf(x, as.matrix(target))}.
+setMethod('rnmf', signature(x='ANY', target='data.frame'),
+ function(x, target, ...){
+ rnmf(x, as.matrix(target), ...)
+ }
+)
+#' Generates a random NMF model of the same dimension as another NMF model.
+#'
+#' It is a shortcut for \code{rnmf(x, nrow(x), ncol(x), ...)}, which returns
+#' a random NMF model of the same class and dimensions as \code{x}.
+#'
+#' @examples
+#' ## random NMF from another model
+#'
+#' a <- nmfModel(3, 100, 20)
+#' b <- rnmf(a)
+#' \dontshow{ stopifnot( !nmf.equal(a,b) ) }
+#'
+setMethod('rnmf', signature(x='NMF', target='missing'),
+ function(x, target, ...){
+ rnmf(x, c(nrow(x),ncol(x)), ...)
+ }
+)
+#' Generates a random NMF model of a given rank, with known basis and/or
+#' coefficient matrices.
+#'
+#' This methods allow to easily generate partially random NMF model, where one
+#' or both factors are known.
+#' Although the later case might seems strange, it makes sense for NMF models that
+#' have fit extra data, other than the basis and coefficient matrices, that
+#' are drawn by an \code{rnmf} method defined for their own class, which should
+#' internally call \code{rnmf,NMF,numeric} and let it draw the basis and
+#' coefficient matrices.
+#' (e.g. see \code{\linkS4class{NMFOffset}} and \code{\link{rnmf,NMFOffset,numeric-method}}).
+#'
+#' Depending on whether arguments \code{W} and/or \code{H} are missing,
+#' this method interprets \code{x} differently:
+#' \itemize{
+#'
+#' \item \code{W} provided, \code{H} missing: \code{x} is taken as the number of
+#' columns that must be drawn to build a random coefficient matrix
+#' (i.e. the number of columns in the target matrix).
+#'
+#' \item \code{W} is missing, \code{H} is provided: \code{x} is taken as the number of
+#' rows that must be drawn to build a random basis matrix
+#' (i.e. the number of rows in the target matrix).
+#'
+#' \item both \code{W} and \code{H} are provided: \code{x} is taken as the target
+#' rank of the model to generate.
+
+#' \item Having both \code{W} and \code{H} missing produces an error, as the
+#' dimension of the model cannot be determined in this case.
+#' }
+#'
+#' The matrices \code{W} and \code{H} are reduced if necessary and possible
+#' to be consistent with this value of the rank, by the internal call to
+#' \code{\link{nmfModel}}.
+#'
+#' All arguments in \code{...} are passed to the function \code{\link{nmfModel}}
+#' which is used to build an initial NMF model, that is in turn passed to
+#' \code{rnmf,NMF,numeric} with \code{dist=list(coef=dist)} or
+#' \code{dist=list(basis=dist)} when suitable.
+#' The type of NMF model to generate can therefore be specified in argument
+#' \code{model} (see \code{\link{nmfModel}} for other possible arguments).
+#'
+#' The returned NMF model, has a basis matrix equal to \code{W} (if not missing)
+#' and a coefficient matrix equal to \code{H} (if not missing), or drawn
+#' according to the specification provided in argument \code{dist}
+#' (see method \code{rnmf,NMF,numeric} for details on the supported values for \code{dist}).
+#'
+#' @examples
+#' # random NMF model with known basis matrix
+#' x <- rnmf(5, W=matrix(1:18, 6)) # 6 x 5 model with rank=3
+#' basis(x) # fixed
+#' coef(x) # random
+#'
+#' # random NMF model with known coefficient matrix
+#' x <- rnmf(5, H=matrix(1:18, 3)) # 5 x 6 model with rank=3
+#' basis(x) # random
+#' coef(x) # fixed
+#'
+#' # random model other than standard NMF
+#' x <- rnmf(5, H=matrix(1:18, 3), model='NMFOffset')
+#' basis(x) # random
+#' coef(x) # fixed
+#' offset(x) # random
+#'
+setMethod('rnmf', signature(x='numeric', target='missing'),
+ function(x, target, ..., W, H, dist=runif){
+
+ # get fixed matrices to restore on exit:
+ # one must enforce honouring the fixed matrices to prevent the call to
+ # rnmf from a sub-class method to change them.
+ of <- .rnmf_fixed()
+ on.exit( .rnmf_fixed(of) )
+
+ if( !missing(W) && missing(H) ){ # fixed basis matrix: x = n samples
+ # one must not change the values H
+ .rnmf_fixed('basis')
+ x <- nmfModel(ncol(W), nrow(W), x, W=W, ...)
+ dist <- list(coef=dist)
+ }else if( missing(W) && !missing(H) ){ # fixed coef matrix: x = n features
+ # one must not change the values H
+ .rnmf_fixed('coef')
+ x <- nmfModel(nrow(H), x, ncol(H), H=H, ...)
+ dist <- list(basis=dist)
+ }else if( !missing(W) && !missing(H) ){ # fixed basis and coef: x = rank
+ # one must not change the values of W and H
+ .rnmf_fixed(c('basis', 'coef'))
+ x <- nmfModel(x, nrow(W), ncol(H), W=W, H=H, ...)
+ }else
+ stop("NMF::rnmf - Missing both arguments `W` and/or `H`: at least one of them must be specified.")
+
+ rnmf(x, dist=dist)
+ }
+)
+#' Generates a random NMF model with known basis and coefficient matrices.
+#'
+#' This method is a shortcut for calling \code{rnmf,numeric,missing} with a
+#' suitable value for \code{x} (the rank), when both factors are known:
+#' code{rnmf(min(ncol(W), nrow(H)), ..., W=W, H=H)}.
+#'
+#' Arguments \code{W} and \code{H} are required.
+#' Note that calling this method only makes sense for NMF models that contains
+#' data to fit other than the basis and coefficient matrices,
+#' e.g. \code{\linkS4class{NMFOffset}}.
+#'
+#' @examples
+#'
+#' # random model other than standard NMF
+#' x <- rnmf(W=matrix(1:18, 6), H=matrix(21:38, 3), model='NMFOffset')
+#' basis(x) # fixed
+#' coef(x) # fixed
+#' offset(x) # random
+#'
+setMethod('rnmf', signature(x='missing', target='missing'),
+ function(x, target, ..., W, H){
+ rnmf(min(ncol(W), nrow(H)), ..., W=W, H=H)
+ }
+)
+
+#' Generates a random standard NMF model of given dimensions.
+#'
+#' This is a shortcut for \code{rnmf(nmfModel(x, target, ncol, ...)), dist=dist)}.
+#' It generates a standard NMF model compatible with the dimensions passed in
+#' \code{target}, that can be a single or 2-length numeric vector, to specify
+#' a square or rectangular target matrix respectively.
+#' See \code{\link{nmfModel}}.
+#'
+#' @inheritParams nmfModel,numeric,numeric-method
+#'
+#' @examples
+#'
+#' ## random standard NMF of given dimensions
+#'
+#' # generate a random NMF model with rank 3 that fits a 100x20 matrix
+#' rnmf(3, 100, 20)
+#' \dontshow{ stopifnot( identical(dim(rnmf(3, 100, 20)), c(100L,20L,3L)) ) }
+#' # generate a random NMF model with rank 3 that fits a 100x100 matrix
+#' rnmf(3, 100)
+#' \dontshow{ stopifnot( identical(dim(rnmf(3, 100)), c(100L,100L,3L)) ) }
+#'
+setMethod('rnmf', signature(x='numeric', target='numeric'),
+ function(x, target, ncol=NULL, ..., dist=runif){
+ rnmf(nmfModel(x, target, ncol, ...), dist=dist)
+ }
+)
+#' Generate a random formula-based NMF model, using the method
+#' \code{\link{nmfModel,formula,ANY-method}}.
+setMethod('rnmf', signature(x='formula', target='ANY'),
+ function(x, target, ..., dist=runif){
+ # missing target is NULL
+ if( missing(target) ) target <- NULL
+ rnmf(nmfModel(x, target, ...), dist=dist)
+ }
+)
+
diff --git a/R/run.R b/R/run.R
new file mode 100644
index 0000000..1574fbc
--- /dev/null
+++ b/R/run.R
@@ -0,0 +1,68 @@
+# Functions produce reports
+#
+# Author: Renaud Gaujoux
+# Created: 23 Jul 2013
+###############################################################################
+
+
+#' Run NMF Methods and Generate a Report
+#'
+#' Generates an HTML report from running a set of method on a given
+#' target matrix, for a set of factorization ranks.
+#'
+#' The report is based on an .Rmd document \code{'report.Rmd'} stored in
+#' the package installation sub-directory \code{scripts/}, and is compiled
+#' using \pkg{knitr}.
+#'
+#' At the beginning of the document, a file named \code{'functions.R'} is
+#' looked for in the current directory, and sourced if present.
+#' This enables the definition of custom NMF methods (see \code{\link{setNMFMethod}})
+#' or setting global options.
+#'
+#' @param x target matrix
+#' @param rank factorization rank
+#' @param method list of methods to apply
+#' @param colClass reference class to assess accuracy
+#' @param ... extra paramters passed to \code{\link{nmf}}
+#' @param output output HTML file
+#' @param template template Rmd file
+#'
+#' @return a list with the following elements:
+#' \item{fits}{the fit(s) for each method and each value of the rank.}
+#' \item{accuracy}{a data.frame that contains the summary assessment measures,
+#' for each fit.}
+#'
+#' @export
+#' @examples
+#'
+#' \dontrun{
+#'
+#' x <- rmatrix(20, 10)
+#' gr <- gl(2, 5)
+#' nmfReport(x, 2:4, method = list('br', 'lee'), colClass = gr, nrun = 5)
+#'
+#' }
+nmfReport <- function(x, rank, method, colClass = NULL, ..., output = NULL, template = NULL){
+
+ requireNamespace('knitr')
+ #library(knitr)
+ if( is.null(template) )
+ template <- system.file('scripts/report.Rmd', package = 'NMF')
+ x <- force(x)
+ rank <- force(rank)
+ method <- force(method)
+ if( isString(method) ) method <- list(method)
+
+ args <- list(...)
+ nmfRun <- function(x, rank, method, ...){
+ args <- expand_dots(args)
+ str(args)
+ do.call(nmf, c(list(x, rank, method), args))
+ }
+ accuracy <- NA
+ res <- NA
+ knitr::knit2html(template)
+ res <- list(fits = res, accuracy = accuracy)
+ saveRDS(res, file = 'report_results.rds')
+ invisible(res)
+}
diff --git a/R/seed-base.R b/R/seed-base.R
new file mode 100644
index 0000000..306b89d
--- /dev/null
+++ b/R/seed-base.R
@@ -0,0 +1,13 @@
+# Basic NMF seeding methods
+#
+# Author: Renaud Gaujoux
+###############################################################################
+
+#' @include registry-seed.R
+NULL
+
+## Register base seeding methods
+# None: do nothing and return object unchanged
+setNMFSeed('none', function(object, x, ...){object}, overwrite=TRUE)
+# Random: use function rnmf
+setNMFSeed('random', rnmf, overwrite=TRUE)
diff --git a/R/seed-ica.R b/R/seed-ica.R
new file mode 100644
index 0000000..7b7ef98
--- /dev/null
+++ b/R/seed-ica.R
@@ -0,0 +1,40 @@
+#' @include registry-seed.R
+NULL
+
+###% Seeding method: Absolute Independent Component Analysis
+###%
+###% @author Renaud Gaujoux
+###% @creation 17 Jul 2009
+
+
+###% Seeding method for Nonnegative Matrix Factorization (NMF) algorithms.
+###%
+###% @param object An instance of class \code{NMF} to seed
+###% @param x The target matrix
+###% @param method The method parameter passed to \code{fastICA}. Can either be 'R' or 'C' and
+###% tells which implementation of fastICA to use (R code or C code).
+###% @param ... extra parameters passed to \code{fastICA}
+###%
+###% @return an updated version of \code{object}, where the matrix slots \code{W} and \code{H}
+###% are set to the positive part of the IC of \code{x}.
+###%
+posICA <- function(object, x, ica.method=c('C', 'R'), ...){
+
+ # perform ICA using the fastICA package
+ if( !require.quiet('fastICA') )
+ stop("Seeding method 'ica' requires package `fastICA` to be installed")
+ requireNamespace('fastICA')
+ ica.method <- match.arg(ica.method)
+ res <- fastICA::fastICA(x, nbasis(object), method=ica.method, ...)
+
+ # update the 'NMF' object
+ .basis(object) <- pmax(res$S, .Machine$double.eps );
+ .coef(object) <- pmax(res$A, .Machine$double.eps );
+
+ # return the updated object
+ invisible(object)
+
+}
+
+# Register positive ICA
+setNMFSeed('ica', posICA, overwrite=TRUE)
diff --git a/R/seed-nndsvd.R b/R/seed-nndsvd.R
new file mode 100644
index 0000000..51eebf3
--- /dev/null
+++ b/R/seed-nndsvd.R
@@ -0,0 +1,131 @@
+#' @include registry-seed.R
+NULL
+
+###% Seeding method: Nonnegative Double Singular Value Decomposition
+###%
+###% @author Renaud Gaujoux
+###% @creation 17 Jul 2009
+
+
+###% Auxliary functions
+.pos <- function(x){ as.numeric(x>=0) * x }
+.neg <- function(x){ - as.numeric(x<0) * x }
+.norm <- function(x){ sqrt(drop(crossprod(x))) }
+
+
+###% This function implements the NNDSVD algorithm described in Boutsidis (2008) for
+###% initializattion of Nonnegative Matrix Factorization Algorithms.
+###%
+###% @param A the input nonnegative m x n matrix A
+###% @param k the rank of the computed factors W,H
+###% @param flag indicates the variant of the NNDSVD Algorithm:
+###% - flag=0 --> NNDSVD
+###% - flag=1 --> NNDSVDa
+###% - flag=2 --> NNDSVDar
+###%
+###% @note This code is a port from the MATLAB code from C. Boutsidis and E. Gallopoulos kindly provided by the authors for research purposes.
+###% Original MATLAB code: http://www.cs.rpi.edu/~boutsc/papers/paper1/nndsvd.m
+###%
+###% @references C. Boutsidis and E. Gallopoulos,
+###% SVD-based initialization: A head start for nonnegative matrix factorization,
+###% Pattern Recognition, 2007
+###% doi:10.1016/j.patcog.2007.09.010
+###%
+.nndsvd.wrapper <- function(object, x, densify=c('none', 'average', 'random')){
+
+ # match parameter 'densify'
+ densify <- match.arg(densify)
+ flag <- which(densify == c('none', 'average', 'random')) - 1
+ res <- .nndsvd.internal(x, nbasis(object), flag)
+
+ # update 'NMF' object
+ .basis(object) <- res$W; .coef(object) <- res$H
+
+ # return updated object
+ object
+}
+
+###% Port to R of the MATLAB code from Boutsidis
+.nndsvd.internal <- function(A, k, flag=0, LINPACK=FALSE){
+
+ #check the input matrix
+ if( any(A<0) ) stop('The input matrix contains negative elements !')
+
+ #size of input matrix
+ size = dim(A);
+ m <- size[1]; n<- size[2]
+
+ #the matrices of the factorization
+ W = matrix(0, m, k);
+ H = matrix(0, k, n);
+
+ #1st SVD --> partial SVD rank-k to the input matrix A.
+ s = svd(A, k, k, LINPACK=LINPACK);
+ U <- s$u; S <- s$d; V <- s$v
+
+ #-------------------------------------------------------
+ # We also recommend the use of propack for the SVD
+ # 1st SVD --> partial SVD rank-k ( propack )
+ # OPTIONS.tol = 0.00001; % remove comment to this line
+ # [U,S,X] = LANSVD(A,k,'L',OPTIONS); % remove comment to this line
+ #-------------------------------------------------------
+
+ #choose the first singular triplet to be nonnegative
+ W[,1] = sqrt(S[1]) * abs(U[,1]);
+ H[1,] = sqrt(S[1]) * abs(t(V[,1]));
+
+ # second SVD for the other factors (see table 1 in Boutsidis' paper)
+ for( i in seq(2,k) ){
+ uu = U[,i]; vv = V[,i];
+ uup = .pos(uu); uun = .neg(uu) ;
+ vvp = .pos(vv); vvn = .neg(vv);
+ n_uup = .norm(uup);
+ n_vvp = .norm(vvp) ;
+ n_uun = .norm(uun) ;
+ n_vvn = .norm(vvn) ;
+ termp = n_uup %*% n_vvp; termn = n_uun %*% n_vvn;
+ if (termp >= termn){
+ W[,i] = sqrt(S[i] * termp) * uup / n_uup;
+ H[i,] = sqrt(S[i] * termp) * vvp / n_vvp;
+ }else{
+ W[,i] = sqrt(S[i] * termn) * uun / n_uun;
+ H[i,] = sqrt(S[i] * termn) * vvn / n_vvn;
+ }
+ }
+
+ #------------------------------------------------------------
+
+ #actually these numbers are zeros
+ W[W<0.0000000001] <- 0;
+ H[H<0.0000000001] <- 0;
+
+ if( flag==1 ){ #NNDSVDa: fill in the zero elements with the average
+
+ ind1 <- W==0 ;
+ ind2 <- H==0 ;
+ average <- mean(A);
+ W[ind1] <- average;
+ H[ind2] <- average;
+
+ }else if( flag==2 ){#NNDSVDar: fill in the zero elements with random values in the space :[0:average/100]
+
+ ind1 <- W==0;
+ ind2 <- H==0;
+ n1 <- sum(ind1);
+ n2 <- sum(ind2);
+
+ average = mean(A);
+ W[ind1] = (average * runif(n1, min=0, max=1) / 100);
+ H[ind2] = (average * runif(n2, min=0, max=1) / 100);
+
+ }
+
+ # return matrices W and H
+ list(W=W, H=H)
+}
+
+###########################################################################
+# REGISTRATION
+###########################################################################
+setNMFSeed('nndsvd', .nndsvd.wrapper, overwrite=TRUE)
+
diff --git a/R/setNMFClass.R b/R/setNMFClass.R
new file mode 100644
index 0000000..cc54a94
--- /dev/null
+++ b/R/setNMFClass.R
@@ -0,0 +1,52 @@
+# Factory method for NMF model classes
+#
+# Author: Renaud Gaujoux
+# Creation: 18 Jul 2012
+###############################################################################
+
+#' @include NMF-class.R
+NULL
+
+if( FALSE ){ #START_DEACTIVATE
+
+## #' Factory Method for NMF Model Classes
+## #'
+## #' Defines two S4 classes for representing NMF models: one to hold data from
+## #' the actual model, the other one to hold fitting data for model estimated with
+## #' the function \code{\link{nmf}}.
+## #'
+#setNMFClass <- function(Class, ..., where=topns(), contains='NMFstd', VERBOSE=TRUE){
+#
+# # add 'NMF' to contains if necessary
+# wNMF <- sapply(contains, isNMFclass)
+# if( !length(wNMF) || !any(wNMF) ){
+# contains <- c(contains, 'NMFstd')
+# parentNMFClass <- 'NMFstd'
+# }else{
+# parentNMFClass <- contains[which(wNMF)]
+# }
+#
+# # extract NMF prefix if present
+# Class <- sub('^NMF(.*)', "\\1", Class)
+# # define class names
+# NMFClass <- str_c('NMF', Class)
+# NMFfitClass <- str_c(NMFClass, '_fit')
+# if( VERBOSE ){
+# message("Defining NMF classes: ", NMFClass , "(", parentNMFClass , ") and "
+# , NMFfitClass, ' in ', str_ns(where), ' ... '
+# , appendLF=FALSE)
+# }
+# # 1. Create model class
+# setClass(NMFClass, ..., where=where, contains=contains)
+#
+# # 2. Create model fit class (in the same environment as the model class)
+# e <- packageEnv(getClassDef(NMFClass)@package)
+# setClass(NMFfitClass, where=e, contains=c('NMFfit', NMFClass))
+#
+# if( VERBOSE ) message('OK')
+#
+# # return the name of the two new classes
+# c(NMFClass, NMFfitClass)
+#}
+
+}#END_DEACTIVATE
diff --git a/R/simulation.R b/R/simulation.R
new file mode 100644
index 0000000..5d598e3
--- /dev/null
+++ b/R/simulation.R
@@ -0,0 +1,152 @@
+# Functions to simulate NMF data
+#
+# Author: Renaud Gaujoux
+###############################################################################
+
+#' @include utils.R
+NULL
+
+#' Simulating Datasets
+#'
+#' The function \code{syntheticNMF} generates random target matrices that follow
+#' some defined NMF model, and may be used to test NMF algorithms.
+#' It is designed to designed to produce data with known or clear classes of
+#' samples.
+#'
+#' @param n number of rows of the target matrix.
+#' @param r specification of the factorization rank.
+#' It may be a single \code{numeric}, in which case argument \code{p} is required
+#' and \code{r} groups of samples are generated from a draw from a multinomial
+#' distribution with equal probabilities, that provides their sizes.
+#'
+#' It may also be a numerical vector, which contains the number of samples in
+#' each class (i.e integers). In this case argument \code{p} is discarded
+#' and forced to be the sum of \code{r}.
+#' @param p number of columns of the synthetic target matrix.
+#' Not used if parameter \code{r} is a vector (see description of argument \code{r}).
+#' @param offset specification of a common offset to be added to the synthetic target
+#' matrix, before noisification.
+#' Its may be a numeric vector of length \code{n}, or a single numeric value that
+#' is used as the standard deviation of a centred normal distribution from which
+#' the actual offset values are drawn.
+#' @param noise a logical that indicate if noise should be added to the
+#' matrix.
+#' @param factors a logical that indicates if the NMF factors should be return
+#' together with the matrix.
+#' @param seed a single numeric value used to seed the random number generator
+#' before generating the matrix.
+#' The state of the RNG is restored on exit.
+#'
+#' @return a matrix, or a list if argument \code{factors=TRUE}.
+#'
+#' When \code{factors=FALSE}, the result is a matrix object, with the following attributes set:
+#' \describe{
+#' \item{coefficients}{the true underlying coefficient matrix (i.e. \code{H});}
+#' \item{basis}{the true underlying coefficient matrix (i.e. \code{H});}
+#' \item{offset}{the offset if any;}
+#' \item{pData}{a \code{list} with one element \code{'Group'} that contains a factor
+#' that indicates the true groups of samples, i.e. the most contributing basis component for each sample;}
+#' \item{fData}{a \code{list} with one element \code{'Group'} that contains a factor
+#' that indicates the true groups of features, i.e. the basis component
+#' to which each feature contributes the most.}
+#' }
+#'
+#' Moreover, the result object is an \code{\link{ExposeAttribute}} object, which means that
+#' relevant attributes are accessible via \code{$}, e.g., \code{res$coefficients}.
+#' In particular, methods \code{\link{coef}} and \code{\link{basis}} will work as expected
+#' and return the true underlying coefficient and basis matrices respectively.
+#'
+#' @export
+#' @examples
+#'
+#' # generate a synthetic dataset with known classes: 50 features, 18 samples (5+5+8)
+#' n <- 50
+#' counts <- c(5, 5, 8)
+#'
+#' # no noise
+#' V <- syntheticNMF(n, counts, noise=FALSE)
+#' \dontrun{aheatmap(V)}
+#'
+#' # with noise
+#' V <- syntheticNMF(n, counts)
+#' \dontrun{aheatmap(V)}
+#'
+syntheticNMF <- function(n, r, p, offset=NULL, noise=TRUE, factors=FALSE, seed=NULL){
+
+ # set seed if necessary
+ if( !is.null(seed) ){
+ os <- RNGseed()
+ on.exit( RNGseed(os) )
+ set.seed(seed)
+ }
+
+ # internal parameters
+ mu.W <- 1; sd.W <- 1
+ if( isTRUE(noise) ){
+ noise <- list(mean=0, sd=1)
+ }else if( isNumber(noise) ){
+ noise <- list(mean=0, sd=noise)
+ }else if( is.list(noise) ){
+ stopifnot( length(noise) == 2L )
+ noise <- setNames(noise, c('mean', 'sd'))
+ }else
+ noise <- FALSE
+
+ if( length(r) == 1 ){
+ g <- rmultinom(1, p, rep(1, r))
+ }else{ # elements of r are the number of samples in each class
+ g <- r
+ p <- sum(r) # total number of samples
+ r <- length(r) # number of class
+ }
+
+ # generate H
+ H <- matrix(0, r, p)
+ tmp <- 0
+ for( i in 1:r ){
+ H[i,(tmp+1):(tmp+g[i])] <- 1
+ tmp <- tmp+g[i]
+ }
+
+ if( length(n) == 1 ){
+ b <- rmultinom(1, n, rep(1, r))
+ }else{ # elements of n are the number of genes in each class
+ b <- n
+ n <- sum(n)
+ }
+
+ # generate W
+ W <- matrix(0, n, r)
+ tmp <- 0
+ for( i in 1:r ){
+ W[(tmp+1):(tmp+b[i]),i] <- abs(rnorm(b[i], mu.W, sd.W))
+ tmp <- tmp + b[i]
+ }
+
+ # build the composite matrix
+ res <- W %*% H
+ # add the offset if necessary
+ if( !is.null(offset) ){
+ if( length(offset) == 1L )
+ offset <- rnorm(n, mean=0, sd=offset)
+
+ stopifnot(length(offset)==n)
+ res <- res + offset
+ }
+
+ # add some noise if required
+ if( !isFALSE(noise) )
+ res <- pmax(res + rmatrix(res, dist=rnorm, mean=noise$mean, sd=noise$sd), 0)
+
+ # return the factors if required
+ pData <- list(Group=factor(unlist(mapply(rep, 1:r, g, SIMPLIFY=FALSE))))
+ fData <- list(Group=factor(unlist(mapply(rep, 1:r, b, SIMPLIFY=FALSE))))
+ if( factors ) res <- list(res, W=W, H=H, offset=offset, pData=pData, fData=fData)
+
+ # wrap results and expose relevant attributes
+ ExposeAttribute(res, coefficients=H, basis=W, offset=offset
+ , pData = pData, fData = fData
+ , .VALUE=TRUE, .MODE='r')
+
+}
+
diff --git a/R/tests.R b/R/tests.R
new file mode 100644
index 0000000..66ddfb7
--- /dev/null
+++ b/R/tests.R
@@ -0,0 +1,45 @@
+# Utility functions to test NMF algorithms
+#
+# Author: Renaud Gaujoux
+# Created: 29 Nov 2012
+###############################################################################
+
+#' @include rmatrix.R
+NULL
+
+#' Checking NMF Algorithm
+#'
+#' \code{nmfCheck} enables to quickly check that a given NMF algorithm runs
+#' properly, by applying it to some small random data.
+#'
+#' @param method name of the NMF algorithm to be tested.
+#' @param rank rank of the factorization
+#' @param x target data. If \code{NULL}, a random 20 x 10 matrix is generated
+#' @param seed specifies a seed or seeding method for the computation.
+#' @param ... other arguments passed to the call to \code{\link{nmf}}.
+#'
+#' @return the result of the NMF fit invisibly.
+#'
+#' @export
+#' @examples
+#'
+#' # test default algorithm
+#' nmfCheck()
+#'
+#' # test 'lee' algorithm
+#' nmfCheck('lee')
+#'
+nmfCheck <- function(method=NULL, rank=max(ncol(x)/5, 3), x=NULL, seed=1234, ...){
+
+ # seed computation
+ if( isNumber(seed) ){
+ os <- RNGseed()
+ on.exit( RNGseed(os), add=TRUE)
+ set.seed(seed)
+ seed <- NULL
+ }
+ if( is.null(x) ){
+ x <- rmatrix(20, 10)
+ }
+ res <- nmf(x, rank, method, seed=seed, ...)
+}
diff --git a/R/transforms.R b/R/transforms.R
new file mode 100644
index 0000000..3bd0ddb
--- /dev/null
+++ b/R/transforms.R
@@ -0,0 +1,256 @@
+# Transformation methods for matrix-like and NMF objects
+#
+# Author: Renaud Gaujoux
+# Creation: 19 Jan 2012
+###############################################################################
+
+#' @include NMF-class.R
+NULL
+
+#' Transforming from Mixed-sign to Nonnegative Data
+#'
+#' \code{nneg} is a generic function to transform a data objects that
+#' contains negative values into a similar object that only contains
+#' values that are nonnegative or greater than a given threshold.
+#'
+#' @param object The data object to transform
+#' @param ... extra arguments to allow extension or passed down to \code{nneg,matrix}
+#' or \code{rposneg,matrix} in subsequent calls.
+#'
+#' @return an object of the same class as argument \code{object}.
+#' @export
+#' @inline
+#' @family transforms
+#'
+setGeneric('nneg', function(object, ...) standardGeneric('nneg'))
+#' Transforms a mixed-sign matrix into a nonnegative matrix, optionally apply a
+#' lower threshold.
+#' This is the workhorse method, that is eventually called by all other
+#' methods defined in the \code{\link{NMF}} package.
+#'
+#' @param method Name of the transformation method to use, that is partially
+#' matched against the following possible methods:
+#' \describe{
+#' \item{pmax}{Each entry is constrained to be above threshold \code{threshold}.}
+#'
+#' \item{posneg}{The matrix is split into its "positive" and "negative" parts,
+#' with the entries of each part constrained to be above threshold \code{threshold}.
+#' The result consists in these two parts stacked in rows (i.e. \code{\link{rbind}}-ed)
+#' into a single matrix, which has double the number of rows of the input
+#' matrix \code{object}.}
+#'
+#' \item{absolute}{The absolute value of each entry is constrained to be above
+#' threshold \code{threshold}.}
+#'
+#' \item{min}{Global shift by adding the minimum entry to each entry, only if
+#' it is negative, and then apply threshold.
+#' }
+#'
+#' }
+#'
+#' @param threshold Nonnegative lower threshold value (single numeric).
+#' See argument \code{shit} for details on how the threshold is used and affects
+#' the result.
+#' @param shift a logical indicating whether the entries below the threshold
+#' value \code{threshold} should be forced (shifted) to 0 (default) or to
+#' the threshold value itself.
+#' In other words, if \code{shift=TRUE} (default) all entries in
+#' the result matrix are either 0 or strictly greater than \code{threshold}.
+#' They are all greater or equal than \code{threshold} otherwise.
+#'
+#' @seealso \code{\link{pmax}}
+#' @examples
+#'
+#' # random mixed sign data (normal distribution)
+#' set.seed(1)
+#' x <- rmatrix(5,5, rnorm, mean=0, sd=5)
+#' x
+#'
+#' # pmax (default)
+#' nneg(x)
+#' # using a threshold
+#' nneg(x, threshold=2)
+#' # without shifting the entries lower than threshold
+#' nneg(x, threshold=2, shift=FALSE)
+#'
+#' # posneg: split positive and negative part
+#' nneg(x, method='posneg')
+#' nneg(x, method='pos', threshold=2)
+#'
+#' # absolute
+#' nneg(x, method='absolute')
+#' nneg(x, method='abs', threshold=2)
+#'
+#' # min
+#' nneg(x, method='min')
+#' nneg(x, method='min', threshold=2)
+#'
+setMethod('nneg', 'matrix'
+, function(object, method=c('pmax', 'posneg', 'absolute', 'min'), threshold=0, shift=TRUE){
+ # match argument
+ method <- match.arg(method)
+ if( !is.numeric(threshold) || length(threshold) != 1L )
+ stop("nneg - Invalid threshold value in argument `threshold` [",threshold,"]: must be a single numeric value.")
+ if( threshold < 0 )
+ stop("nneg - Invalid threshold value in argument `threshold` [",threshold,"]: must be nonnegative.")
+
+ # 1. Transform if there is any negative entry
+ m <- min(object)
+ if( m < 0 ){
+ object <-
+ switch(method
+ , pmax = pmax(object, 0)
+ , posneg = rbind(pmax(object, 0), pmax(-object, 0))
+ , absolute = pmax(abs(object), 0)
+ , min = object - m
+ , stop("NMF::nneg - Unexpected error: unimplemented transformation method '", method, "'.")
+ )
+ }
+
+ if( threshold > 0 ){
+ # 2. Apply threshold if any
+ object <- pmax(object, threshold)
+
+ # 3. Shifting: entries under threshold
+ if( shift ) object[object<=threshold] <- 0
+ }
+
+ # return modified object
+ object
+}
+)
+
+#' Apply \code{nneg} to the basis matrix of an \code{\link{NMF}}
+#' object (i.e. \code{basis(object)}).
+#' All extra arguments in \code{...} are passed to the method \code{nneg,matrix}.
+#'
+#' @examples
+#'
+#' # random
+#' M <- nmfModel(x, rmatrix(ncol(x), 3))
+#' nnM <- nneg(M)
+#' basis(nnM)
+#' # mixture coefficients are not affected
+#' identical( coef(M), coef(nnM) )
+#'
+setMethod('nneg', 'NMF',
+ function(object, ...){
+ basis(object) <- nneg(basis(object), ...)
+ object
+ }
+)
+
+#' \code{posneg} is a shortcut for \code{nneg(..., method='posneg')}, to split
+#' mixed-sign data into its positive and negative part.
+#' See description for method \code{"posneg"}, in \code{\link{nneg}}.
+#'
+#' @export
+#' @rdname nneg
+#' @examples
+#' # shortcut for the "posneg" transformation
+#' posneg(x)
+#' posneg(x, 2)
+#'
+posneg <- function(...) nneg(..., method='posneg')
+
+#' Transforming from Nonnegative to Mixed Sign Data
+#'
+#' \code{rposneg} performs the "reverse" transformation of the \code{\link{posneg}} function.
+#'
+#' @return an object of the same type of \code{object}
+#' @rdname nneg
+#' @inline
+#'
+setGeneric('rposneg', function(object, ...) standardGeneric('rposneg'))
+#' @param unstack Logical indicating whether the positive and negative parts
+#' should be unstacked and combined into a matrix as \code{pos - neg}, which contains
+#' half the number of rows of \code{object} (default), or left
+#' stacked as \code{[pos; -neg]}.
+#'
+#' @export
+#' @examples
+#'
+#' # random mixed sign data (normal distribution)
+#' set.seed(1)
+#' x <- rmatrix(5,5, rnorm, mean=0, sd=5)
+#' x
+#'
+#' # posneg-transform: split positive and negative part
+#' y <- posneg(x)
+#' dim(y)
+#' # posneg-reverse
+#' z <- rposneg(y)
+#' identical(x, z)
+#' rposneg(y, unstack=FALSE)
+#'
+#' # But posneg-transformation with a non zero threshold is not reversible
+#' y1 <- posneg(x, 1)
+#' identical(rposneg(y1), x)
+#'
+setMethod('rposneg', 'matrix'
+, function(object, unstack=TRUE){
+
+ # check that the number of rows is pair
+ if( nrow(object) %% 2 != 0 )
+ stop("rposneg - Invalid input matrix: must have a pair number of rows [",nrow(object),"].")
+ n2 <- nrow(object)
+ n <- n2/2
+ if( unstack ) object <- object[1:n,,drop=FALSE] - object[(n+1):n2,,drop=FALSE]
+ else object[(n+1):n2,] <- - object[(n+1):n2,,drop=FALSE]
+
+ # return modified object
+ object
+}
+)
+
+#' Apply \code{rposneg} to the basis matrix of an \code{\link{NMF}} object.
+#'
+#' @examples
+#'
+#' # random mixed signed NMF model
+#' M <- nmfModel(rmatrix(10, 3, rnorm), rmatrix(3, 4))
+#' # split positive and negative part
+#' nnM <- posneg(M)
+#' M2 <- rposneg(nnM)
+#' identical(M, M2)
+setMethod('rposneg', 'NMF'
+, function(object, ...){
+ basis(object) <- rposneg(basis(object), ...)
+ object
+}
+)
+
+#' Transformation NMF Model Objects
+#'
+#' \code{t} transpose an NMF model, by transposing and swapping its basis and
+#' coefficient matrices: \eqn{t([W,H]) = [t(H), t(W)]}.
+#'
+#' The function \code{t} is a generic defined in the \pkg{base} package.
+#' The method \code{t.NMF} defines the trasnformation for the general NMF interface.
+#' This method may need to be overloaded for NMF models, whose structure requires
+#' specific handling.
+#'
+#' @param x NMF model object.
+#'
+#' @family transforms
+#' @S3method t NMF
+#' @examples
+#'
+#' x <- rnmf(3, 100, 20)
+#' x
+#' # transpose
+#' y <- t(x)
+#' y
+#'
+#' # factors are swapped-transposed
+#' stopifnot( identical(basis(y), t(coef(x))) )
+#' stopifnot( identical(coef(y), t(basis(x))) )
+#'
+t.NMF <- function(x){
+ # transpose and swap factors
+ w <- t(basis(x))
+ .basis(x) <- t(coef(x))
+ .coef(x) <- w
+ # return object
+ x
+}
diff --git a/R/utils.R b/R/utils.R
new file mode 100644
index 0000000..793c105
--- /dev/null
+++ b/R/utils.R
@@ -0,0 +1,1058 @@
+#' @include rmatrix.R
+#' @include nmf-package.R
+NULL
+
+#' Utility Function in the NMF Package
+#'
+#' @name utils-NMF
+#' @rdname utils
+NULL
+
+#' Internal verbosity option
+#' @param val logical that sets the verbosity level.
+#' @return the old verbose level
+#' @keywords internal
+lverbose <- local({
+ .val <- 0
+ function(val){
+ if( missing(val) ) return(.val)
+ oval <- .val
+ .val <<- val
+ invisible(oval)
+ }
+ })
+vmessage <- function(..., appendLF=TRUE) if( lverbose() ) cat(..., if(appendLF) "\n", sep='')
+
+
+nmf_stop <- function(name, ...){
+ stop("NMF::", name , ' - ', ..., call.=FALSE)
+}
+nmf_warning <- function(name, ...){
+ warning("NMF::", name , ' - ', ..., call.=FALSE)
+}
+
+# or-NULL operator
+'%||%' <- function(x, y) if( !is.null(x) ) x else y
+
+# cat object or class for nice cat/message
+quick_str <- function(x) if( is.atomic(x) ) x else class(x)[1]
+
+# remove all attributes from an object
+rmAttributes <- function(x){
+ attributes(x) <- NULL
+ x
+}
+
+#' \code{str_args} formats the arguments of a function using \code{\link{args}},
+#' but returns the output as a string.
+#'
+#' @param x a function
+#' @param exdent indentation for extra lines if the output takes more than one line.
+#'
+#' @export
+#' @rdname utils
+#'
+#' @examples
+#'
+#' args(library)
+#' str_args(library)
+#'
+str_args <- function(x, exdent=10L){
+ s <- capture.output(print(args(x)))
+ paste(str_trim(s[-length(s)]), collapse=str_c('\n', paste(rep(' ', exdent), collapse='')))
+}
+
+#' Simple Progress Bar
+#'
+#' Creates a simple progress bar with title.
+#' This function is identical to \code{utils::txtProgressBar} but allow adding
+#' a title to the progress bar, and can be shared by multiple processes,
+#' e.g., in multicore or multi-hosts computations.
+#'
+#' @inheritParams utils::txtProgressBar
+#' @param shared specification of a shared directory to use when the progress
+#' bar is to be used by multiple processes.
+#'
+#' @author R Core Team
+#' @keywords internal
+txtProgressBar <- function (min = 0, max = 1, initial = 0, char = "=", width = NA,
+ title= if( style == 3 ) ' ', label, style = 1, file = ""
+ , shared = NULL)
+{
+ if (!identical(file, "") && !(inherits(file, "connection") &&
+ isOpen(file)))
+ stop("'file' must be \"\" or an open connection object")
+ if (!style %in% 1L:3L)
+ style <- 1
+ .val <- initial
+ .killed <- FALSE
+ .nb <- 0L
+ .pc <- -1L
+ nw <- nchar(char, "w")
+ if (is.na(width)) {
+ width <- getOption("width")
+ if (style == 3L)
+ width <- width - 10L
+ width <- trunc(width/nw)
+ }
+ if (max <= min)
+ stop("must have max > min")
+
+ # setup shared directory
+ .shared <- NULL
+ if( isTRUE(shared) ) shared <- tempdir()
+ if( is.character(shared) ){
+ .shared <- tempfile('progressbar_', tmpdir=shared[1L])
+ dir.create(.shared)
+ }
+ #
+
+ getval <- function(value){
+ if( value >= max || value <= min
+ || is.null(.shared) || !file.exists(.shared) ){
+ value
+ }else{
+ cat('', file=file.path(.shared, paste('_', value, sep='')))
+ length(list.files(.shared))
+ }
+ }
+
+ up1 <- function(value) {
+ if (!is.finite(value) || value < min || value > max)
+ return()
+
+ # get actual value
+ value <- getval(value)
+
+ .val <<- value
+ nb <- round(width * (value - min)/(max - min))
+ if (.nb < nb) {
+ cat(paste(rep.int(char, nb - .nb), collapse = ""),
+ file = file)
+ flush.console()
+ }
+ else if (.nb > nb) {
+ cat("\r", title, paste(rep.int(" ", .nb * nw), collapse = ""),
+ "\r", title, paste(rep.int(char, nb), collapse = ""),
+ sep = "", file = file)
+ flush.console()
+ }
+ .nb <<- nb
+ }
+ up2 <- function(value) {
+ if (!is.finite(value) || value < min || value > max)
+ return()
+
+ # get actual value
+ value <- getval(value)
+
+ .val <<- value
+ nb <- round(width * (value - min)/(max - min))
+ if (.nb <= nb) {
+ cat("\r", title, paste(rep.int(char, nb), collapse = ""),
+ sep = "", file = file)
+ flush.console()
+ }
+ else {
+ cat("\r", title, paste(rep.int(" ", .nb * nw), collapse = ""),
+ "\r", paste(rep.int(char, nb), collapse = ""),
+ sep = "", file = file)
+ flush.console()
+ }
+ .nb <<- nb
+ }
+ up3 <- function(value) {
+ if (!is.finite(value) || value < min || value > max)
+ return()
+
+ # get actual value
+ value <- getval(value)
+
+ .val <<- value
+ nb <- round(width * (value - min)/(max - min))
+ pc <- round(100 * (value - min)/(max - min))
+ if (nb == .nb && pc == .pc)
+ return()
+ cat(paste(c("\r",title," |", rep.int(" ", nw * width + 6)), collapse = ""),
+ file = file)
+ cat(paste(c("\r",title," |", rep.int(char, nb), rep.int(" ",
+ nw * (width - nb)), sprintf("| %3d%%", pc)), collapse = ""),
+ file = file)
+ flush.console()
+ .nb <<- nb
+ .pc <<- pc
+ }
+ getVal <- function() .val
+ kill <- function(cleanup=TRUE) if (!.killed) {
+ cat("\n", file = file)
+ flush.console()
+ .killed <<- TRUE
+
+ # do some cleanup
+ if( cleanup ){
+ # delete shared directory
+ if( !is.null(.shared) && file.exists(.shared) )
+ unlink(.shared, recursive=TRUE)
+ #
+ }
+ invisible(TRUE)
+ }
+ up <- switch(style, up1, up2, up3)
+ up(initial)
+ structure(list(getVal = getVal, up = up, kill = kill), class = "txtProgressBar")
+}
+
+###% apply a function to each entry in a matrix
+matapply <- function(x, FUN, ...){
+ res <- sapply(x, FUN, ...)
+ matrix(res, nrow(x))
+}
+
+###% try to convert a character string into a numeric
+toNumeric <- function(x){
+ suppressWarnings( as.numeric(x) )
+}
+
+###% Tells one is running in Sweave
+isSweave <- function() !is.null(sweaveLabel())
+
+sweaveLabel <- function(){
+ if ((n.parents <- length(sys.parents())) >= 3) {
+ for (i in seq_len(n.parents) - 1) {
+ if ("chunkopts" %in% ls(envir = sys.frame(i))) {
+ chunkopts = get("chunkopts", envir = sys.frame(i))
+ if (all(c("prefix.string", "label") %in% names(chunkopts))) {
+ img.name = paste(chunkopts$prefix.string, chunkopts$label,
+ sep = "-")
+ return(img.name)
+ break
+ }
+ }
+ }
+ }
+}
+
+sweaveFile <- function(){
+ label <- sweaveLabel()
+ if( !is.null(label) )
+ paste(label, '.pdf', sep='')
+}
+
+fixSweaveFigure <- function(filename){
+ if( missing(filename) ){
+ filename <- sweaveLabel()
+ if( is.null(filename) ) return()
+ filename <- paste(filename, '.pdf', sep='')
+ }
+ filepath <- normalizePath(filename)
+ tf <- tempfile()
+ system(paste("pdftk", filepath, "cat 2-end output", tf, "; mv -f", tf, filepath))
+}
+
+###% 'more' functionality to read data progressively
+more <- function(x, step.size=10, width=20, header=FALSE, pattern=NULL){
+
+ if( !(is.matrix(x) || is.data.frame(x) || is.vector(x) || is.list(x)) )
+ stop("NMF::more - invalid argument 'x': only 'matrix', 'data.frame', 'vector' and 'list' objects are handled.")
+
+ one.dim <- is.null(dim(x))
+ single.char <- FALSE
+ n <-
+ if( is.character(x) && length(x) == 1 ){
+ cat("<character string:", nchar(x), ">\n")
+ single.char <- TRUE
+ nchar(x)
+ }
+ else if( one.dim ){
+ cat("<", class(x),":", length(x), ">\n")
+
+ # limit to matching terms if necessary
+ if( !is.null(pattern) )
+ x[grep(pattern, x)]
+
+ length(x)
+ }else{
+ cat("<", class(x),":", nrow(x), "x", ncol(x), ">\n")
+ head.init <- colnames(x)
+ head.on <- TRUE
+
+ # limit to matching terms if necessary
+ if( !is.null(pattern) ){
+ idx <- apply(x, 2, grep, pattern=pattern)
+ print(idx)
+ idx <- unique(if( is.list(idx) ) unlist(idx) else as.vector(idx))
+ x <- x[idx,, drop=FALSE]
+ }
+
+ nrow(x)
+ }
+
+ i <- 0
+ while( i < n ){
+ # reduce 'step.size' if necessary
+ step.size <- min(step.size, n-i)
+
+ what2show <- if( single.char )
+ substr(x, i+1, i+step.size)
+ else if( one.dim )
+ if( !is.na(width) ) sapply(x[seq(i+1, i+step.size)], function(s) substr(s, 1, width) ) else x[seq(i+1, i+step.size)]
+ else{
+ w <- x[seq(i+1, i+step.size), , drop=FALSE]
+ if( !is.na(width) ){
+ w <- apply(w, 2,
+ function(s){
+ ns <- toNumeric(s)
+ if( !is.na(ns[1]) ) # keep numerical value as is
+ ns
+ else # limit output if required
+ substr(s, 1, width)
+
+ })
+ rownames(w) <- rownames(x)[seq(i+1, i+step.size)]
+ }
+
+
+ # remove header if not required
+ if( !header && head.on ){
+ colnames(x) <- sapply(colnames(x), function(c) paste(rep(' ', nchar(c)), collapse=''))
+ head.on <- FALSE
+ }
+
+ # return the content
+ w
+ }
+
+ cat( show(what2show) )
+ i <- i + step.size
+
+ # early break if necessary
+ if( i >= n )
+ break
+ # ask user what to to next
+ ans <- scan(what='character', quiet=TRUE, n=1, multi.line=FALSE)
+
+ # process user command if any (otherwise carry on)
+ if( length(ans) > 0 ){
+ if( !is.na(s <- toNumeric(ans)) ) # change step size
+ step.size <- s
+ else if( !header && ans %in% c('h', 'head') ){
+ colnames(x) <- head.init
+ head.on <- TRUE
+ }
+ else if( ans %in% c('q', 'quit') ) # quit
+ break
+ }
+ }
+ invisible()
+}
+
+#' Randomizing Data
+#'
+#' \code{randomize} permutates independently the entries in each column
+#' of a matrix-like object, to produce random data that can be used
+#' in permutation tests or bootstrap analysis.
+#'
+#' In the context of NMF, it may be used to generate random data, whose
+#' factorization serves as a reference for selecting a factorization rank,
+#' that does not overfit the data.
+#'
+#' @param x data to be permutated. It must be an object suitable to be
+#' passed to the function \code{\link{apply}}.
+#' @param ... extra arguments passed to the function \code{\link{sample}}.
+#'
+#' @return a matrix
+#'
+#' @export
+#' @examples
+#' x <- matrix(1:32, 4, 8)
+#' randomize(x)
+#' randomize(x)
+#'
+randomize <- function(x, ...){
+
+ if( is(x, 'ExpressionSet') ) x <- Biobase::exprs(x)
+
+ # resample the columns
+ apply(x, 2, function(c, ...) sample(c, size=length(c), ...), ...)
+
+}
+
+###% Returns the rank-k truncated SVD approximation of x
+tsvd <- function(x, r, ...){
+ stopifnot( r > 0 && r <= min(dim(x)))
+ s <- svd(x, nu=r, nv=r, ...)
+ s$d <- s$d[1:r]
+
+ # return results
+ s
+}
+
+###% Subset a list leaving only the arguments from a given function
+.extract.args <- function(x, fun, ...){
+
+ fdef <- if( is.character(fun) ) getFunction(fun, ...)
+ else if( is.function(fun) ) fun
+ else stop("invalid argument 'fun': expected function name or definition")
+
+ if( length(x) == 0 ) return(x)
+ x.ind <- charmatch(if( is.list(x) ) names(x) else x, args <- formalArgs(fdef))
+ x[!is.na(x.ind)]
+}
+
+###% Returns the version of the package
+nmfInfo <- function(command){
+ pkg <- 'NMF'
+ curWarn <- getOption("warn")
+ on.exit(options(warn = curWarn), add = TRUE)
+ options(warn = -1)
+ desc <- packageDescription(pkg, fields="Version")
+ if (is.na(desc))
+ stop(paste("Package", pkg, "not found"))
+ desc
+}
+
+###% Returns TRUE if running under Mac OS X + GUI
+is.Mac <- function(check.gui=FALSE){
+ is.mac <- (length(grep("darwin", R.version$platform)) > 0)
+ # return TRUE is running on Mac (adn optionally through GUI)
+ is.mac && (!check.gui || .Platform$GUI == 'AQUA')
+}
+
+###% Hash a function body (using digest)
+#' @import digest
+hash_function <- function(f){
+ b <- body(f)
+ attributes(b) <- NULL
+ fdef <- paste(c(capture.output(args(f))[1], capture.output(print(b))), collapse="\n")
+ # print(fdef)
+ digest(b)
+}
+
+
+###% compare function with copy and with no copy
+cmp.cp <- function(...){
+ res <- nmf(..., copy=F)
+ resc <- nmf(..., copy=T)
+ cat("identical: ", identical(fit(res), fit(resc))
+ , " - all.equal: ", all.equal(fit(res), fit(resc))
+ , " - diff: ", all.equal(fit(res), fit(resc), tol=0)
+ , "\n"
+ )
+ invisible(res)
+}
+
+# return the internal pointer address
+C.ptr <- function(x, rec=FALSE)
+{
+ attribs <- attributes(x)
+ if( !rec || is.null(attribs) )
+ .Call("ptr_address", x, PACKAGE='NMF')
+ else
+ c( C.ptr(x), sapply(attribs, C.ptr, rec=TRUE))
+
+}
+
+is.same <- function(x, y){
+ C.ptr(x) == C.ptr(y)
+}
+
+is.eset <- function(x) is(x, 'ExpressionSet')
+
+# clone an object
+clone <- function(x){
+ .Call('clone_object', x, PACKAGE='NMF')
+}
+
+# deep-clone an object
+clone2 <- function(x){
+ if( is.environment(x) ){
+ y <- Biobase::copyEnv(x)
+ eapply(ls(x, all.names=TRUE),
+ function(n){
+ if( is.environment(x[[n]]) ){
+ y[[n]] <<- clone(x[[n]])
+ if( identical(parent.env(x[[n]]), x) )
+ parent.env(y[[n]]) <<- y
+ }
+ })
+ }else{
+ y <- .Call('clone_object', x, PACKAGE='NMF')
+ if( isS4(x) ){ ## deep copy R object
+ lapply(slotNames(class(y)),
+ function(n){
+ slot(y, n) <<- clone(slot(x, n))
+ })
+ }else if( is.list(x) ){ ## copy list or vector
+ sapply(seq_along(x),
+ function(i){
+ y[[i]] <<- clone(x[[i]])
+ })
+ }
+ }
+
+ y
+}
+
+#compute RSS with C function
+.rss <- function(x, y)
+{
+ .Call("Euclidean_rss", x, y, PACKAGE='NMF')
+}
+
+#compute KL divergence with C function
+.KL <- function(x, y)
+{
+ .Call("KL_divergence", x, y, PACKAGE='NMF')
+}
+
+#' Updating Objects In Place
+#'
+#' These functions modify objects (mainly matrix objects) in place, i.e. they
+#' act directly on the C pointer.
+#' Due to their side-effect, they are not meant to be called by the end-user.
+#'
+#' \code{pmax.inplace} is a version of \code{\link{pmax}} that updates its first
+#' argument.
+#'
+#' @param x an object to update in place.
+#' @param lim lower threshold value
+#' @param skip indexes to skip
+#'
+#' @export
+#' @rdname inplace
+#' @keywords internal
+pmax.inplace <- function(x, lim, skip=NULL){
+
+ .Call('ptr_pmax', x, lim, as.integer(skip), PACKAGE='NMF')
+
+}
+
+# colMin
+colMin <- function(x){
+ .Call('colMin', x, PACKAGE='NMF')
+}
+
+# colMax
+colMax <- function(x){
+ .Call('colMax', x, PACKAGE='NMF')
+}
+
+#' \code{neq.constraints.inplace} apply unequality constraints in place.
+#'
+#' @param constraints constraint specification.
+#' @param ratio fixed ratio on which the constraint applies.
+#' @param value fixed value to enforce.
+#' @param copy a logical that indicates if \code{x} should be updated in place
+#' or not.
+#'
+#' @export
+#' @rdname inplace
+neq.constraints.inplace <- function(x, constraints, ratio=NULL, value=NULL, copy=FALSE){
+
+ # if requested: clone data as neq.constrains.inplace modify the input data in place
+ if( copy )
+ x <- clone(x)
+
+ .Call('ptr_neq_constraints', x, constraints, ratio, value, PACKAGE='NMF')
+}
+
+# Test if an external pointer is nil
+# Taken from package bigmemory
+ptr_isnil <- function (address)
+{
+ if (class(address) != "externalptr")
+ stop("address is not an externalptr.")
+ .Call("ptr_isnil", address, PACKAGE='NMF')
+}
+
+
+###% Draw the palette of colors
+###%
+###% Taken from the examples of colorspace::rainbow_hcl
+###%
+pal <- function(col, h=1, border = "light gray")
+{
+ n <- length(col)
+ plot(0, 0, type="n", xlim = c(0, 1), ylim = c(0, h), axes = FALSE, xlab = "", ylab = "")
+ rect(0:(n-1)/n, 0, 1:n/n, h, col = col, border = border)
+}
+###% Draw the Palette of Colors as a Wheel
+###%
+###% Taken from the examples of colorspace::rainbow_hcl
+###%
+wheel <- function(col, radius = 1, ...)
+ pie(rep(1, length(col)), col = col, radius = radius, ...)
+
+# Define a S4 class to handle function slots given as either a function definition
+# or a character string that gives the function's name.
+setClassUnion('.functionSlot', c('character', 'function'))
+
+# Define a S4 class to handle function slots given as either a function definition
+# or a character string that gives the function's name or NULL.
+setClassUnion('.functionSlotNULL', c('character', 'function', 'NULL'))
+.validFunctionSlot <- function(slot, allow.empty=FALSE, allow.null=TRUE){
+ if( is.null(slot) ){
+ if( !allow.null ) return('NULL value is not allowed')
+ return(TRUE)
+ }
+ if( is.character(slot) ){
+ if( !allow.empty && slot == '' ) return('character string cannot be empty')
+ if( length(slot) != 1 ) return(paste('character string must be a single value [length =', length(slot), ']', sep=''))
+ }
+
+ return(TRUE)
+}
+
+####% Utility function needed in heatmap.plus.2
+#invalid <- function (x)
+#{
+# if (missing(x) || is.null(x) || length(x) == 0)
+# return(TRUE)
+# if (is.list(x))
+# return(all(sapply(x, invalid)))
+# else if (is.vector(x))
+# return(all(is.na(x)))
+# else return(FALSE)
+#}
+#
+
+####% Modification of the function heatmap.2 including a small part of function
+####% heatmap.plus to allow extra annotation rows
+#heatmap.plus.2 <-
+# function (x, Rowv = TRUE, Colv = if (symm) "Rowv" else TRUE,
+# distfun = dist, hclustfun = hclust, dendrogram = c("both",
+# "row", "column", "none"), symm = FALSE, scale = c("none",
+# "row", "column"), na.rm = TRUE, revC = identical(Colv,
+# "Rowv"), add.expr, breaks, symbreaks = min(x < 0, na.rm = TRUE) ||
+# scale != "none", col = "heat.colors", colsep, rowsep,
+# sepcolor = "white", sepwidth = c(0.05, 0.05), cellnote, notecex = 1,
+# notecol = "cyan", na.color = par("bg"), trace = c("column",
+# "row", "both", "none"), tracecol = "cyan", hline = median(breaks),
+# vline = median(breaks), linecol = tracecol, margins = c(5,
+# 5), ColSideColors, RowSideColors, cexRow = 0.2 + 1/log10(nr),
+# cexCol = 0.2 + 1/log10(nc), labRow = NULL, labCol = NULL,
+# key = TRUE, keysize = 1.5, density.info = c("histogram",
+# "density", "none"), denscol = tracecol, symkey = min(x <
+# 0, na.rm = TRUE) || symbreaks, densadj = 0.25, main = NULL,
+# xlab = NULL, ylab = NULL, lmat = NULL, lhei = NULL, lwid = NULL,
+# ...)
+#{
+# scale01 <- function(x, low = min(x), high = max(x)) {
+# x <- (x - low)/(high - low)
+# x
+# }
+# retval <- list()
+# scale <- if (symm && missing(scale))
+# "none"
+# else match.arg(scale)
+# dendrogram <- match.arg(dendrogram)
+# trace <- match.arg(trace)
+# density.info <- match.arg(density.info)
+# if (length(col) == 1 && is.character(col))
+# col <- get(col, mode = "function")
+# if (!missing(breaks) && (scale != "none"))
+# warning("Using scale=\"row\" or scale=\"column\" when breaks are",
+# "specified can produce unpredictable results.", "Please consider using only one or the other.")
+# if (is.null(Rowv) || is.na(Rowv))
+# Rowv <- FALSE
+# if (is.null(Colv) || is.na(Colv))
+# Colv <- FALSE
+# else if (Colv == "Rowv" && !isTRUE(Rowv))
+# Colv <- FALSE
+# if (length(di <- dim(x)) != 2 || !is.numeric(x))
+# stop("`x' must be a numeric matrix")
+# nr <- di[1]
+# nc <- di[2]
+# if (nr <= 1 || nc <= 1)
+# stop("`x' must have at least 2 rows and 2 columns")
+# if (!is.numeric(margins) || length(margins) != 2)
+# stop("`margins' must be a numeric vector of length 2")
+# if (missing(cellnote))
+# cellnote <- matrix("", ncol = ncol(x), nrow = nrow(x))
+# if (!inherits(Rowv, "dendrogram")) {
+# if (((!isTRUE(Rowv)) || (is.null(Rowv))) && (dendrogram %in%
+# c("both", "row"))) {
+# if (is.logical(Colv) && (Colv))
+# dendrogram <- "column"
+# else dedrogram <- "none"
+# warning("Discrepancy: Rowv is FALSE, while dendrogram is `",
+# dendrogram, "'. Omitting row dendogram.")
+# }
+# }
+# if (!inherits(Colv, "dendrogram")) {
+# if (((!isTRUE(Colv)) || (is.null(Colv))) && (dendrogram %in%
+# c("both", "column"))) {
+# if (is.logical(Rowv) && (Rowv))
+# dendrogram <- "row"
+# else dendrogram <- "none"
+# warning("Discrepancy: Colv is FALSE, while dendrogram is `",
+# dendrogram, "'. Omitting column dendogram.")
+# }
+# }
+# if (inherits(Rowv, "dendrogram")) {
+# ddr <- Rowv
+# rowInd <- order.dendrogram(ddr)
+# }
+# else if (is.integer(Rowv)) {
+# hcr <- hclustfun(distfun(x))
+# ddr <- as.dendrogram(hcr)
+# ddr <- reorder(ddr, Rowv)
+# rowInd <- order.dendrogram(ddr)
+# if (nr != length(rowInd))
+# stop("row dendrogram ordering gave index of wrong length")
+# }
+# else if (isTRUE(Rowv)) {
+# Rowv <- rowMeans(x, na.rm = na.rm)
+# hcr <- hclustfun(distfun(x))
+# ddr <- as.dendrogram(hcr)
+# ddr <- reorder(ddr, Rowv)
+# rowInd <- order.dendrogram(ddr)
+# if (nr != length(rowInd))
+# stop("row dendrogram ordering gave index of wrong length")
+# }
+# else {
+# rowInd <- nr:1
+# }
+# if (inherits(Colv, "dendrogram")) {
+# ddc <- Colv
+# colInd <- order.dendrogram(ddc)
+# }
+# else if (identical(Colv, "Rowv")) {
+# if (nr != nc)
+# stop("Colv = \"Rowv\" but nrow(x) != ncol(x)")
+# if (exists("ddr")) {
+# ddc <- ddr
+# colInd <- order.dendrogram(ddc)
+# }
+# else colInd <- rowInd
+# }
+# else if (is.integer(Colv)) {
+# hcc <- hclustfun(distfun(if (symm)
+# x
+# else t(x)))
+# ddc <- as.dendrogram(hcc)
+# ddc <- reorder(ddc, Colv)
+# colInd <- order.dendrogram(ddc)
+# if (nc != length(colInd))
+# stop("column dendrogram ordering gave index of wrong length")
+# }
+# else if (isTRUE(Colv)) {
+# Colv <- colMeans(x, na.rm = na.rm)
+# hcc <- hclustfun(distfun(if (symm)
+# x
+# else t(x)))
+# ddc <- as.dendrogram(hcc)
+# ddc <- reorder(ddc, Colv)
+# colInd <- order.dendrogram(ddc)
+# if (nc != length(colInd))
+# stop("column dendrogram ordering gave index of wrong length")
+# }
+# else {
+# colInd <- 1:nc
+# }
+# retval$rowInd <- rowInd
+# retval$colInd <- colInd
+# retval$call <- match.call()
+# x <- x[rowInd, colInd]
+# x.unscaled <- x
+# cellnote <- cellnote[rowInd, colInd]
+# if (is.null(labRow))
+# labRow <- if (is.null(rownames(x)))
+# (1:nr)[rowInd]
+# else rownames(x)
+# else labRow <- labRow[rowInd]
+# if (is.null(labCol))
+# labCol <- if (is.null(colnames(x)))
+# (1:nc)[colInd]
+# else colnames(x)
+# else labCol <- labCol[colInd]
+# if (scale == "row") {
+# retval$rowMeans <- rm <- rowMeans(x, na.rm = na.rm)
+# x <- sweep(x, 1, rm)
+# retval$rowSDs <- sx <- apply(x, 1, sd, na.rm = na.rm)
+# x <- sweep(x, 1, sx, "/")
+# }
+# else if (scale == "column") {
+# retval$colMeans <- rm <- colMeans(x, na.rm = na.rm)
+# x <- sweep(x, 2, rm)
+# retval$colSDs <- sx <- apply(x, 2, sd, na.rm = na.rm)
+# x <- sweep(x, 2, sx, "/")
+# }
+# if (missing(breaks) || is.null(breaks) || length(breaks) <
+# 1) {
+# if (missing(col) || is.function(col))
+# breaks <- 16
+# else breaks <- length(col) + 1
+# }
+# if (length(breaks) == 1) {
+# if (!symbreaks)
+# breaks <- seq(min(x, na.rm = na.rm), max(x, na.rm = na.rm),
+# length = breaks)
+# else {
+# extreme <- max(abs(x), na.rm = TRUE)
+# breaks <- seq(-extreme, extreme, length = breaks)
+# }
+# }
+# nbr <- length(breaks)
+# ncol <- length(breaks) - 1
+# if (class(col) == "function")
+# col <- col(ncol)
+# min.breaks <- min(breaks)
+# max.breaks <- max(breaks)
+# x[x < min.breaks] <- min.breaks
+# x[x > max.breaks] <- max.breaks
+# if (missing(lhei) || is.null(lhei))
+# lhei <- c(keysize, 4)
+# if (missing(lwid) || is.null(lwid))
+# lwid <- c(keysize, 4)
+# if (missing(lmat) || is.null(lmat)) {
+# lmat <- rbind(4:3, 2:1)
+#
+# # hack for adding extra annotations
+# if (!missing(ColSideColors)) {
+# if (!is.matrix(ColSideColors))
+# stop("'ColSideColors' must be a matrix")
+#
+# if (!is.character(ColSideColors) || dim(ColSideColors)[1] !=
+# nc)
+# stop("'ColSideColors' must be a character vector/matrix with length/ncol = ncol(x)")
+# lmat <- rbind(lmat[1, ] + 1, c(NA, 1), lmat[2, ] + 1)
+# lhei <- c(lhei[1], 0.2, lhei[2])
+# }
+# if (!missing(RowSideColors)) {
+# if (!is.character(RowSideColors) || length(RowSideColors) !=
+# nr)
+# stop("'RowSideColors' must be a character vector of length nrow(x)")
+# lmat <- cbind(lmat[, 1] + 1, c(rep(NA, nrow(lmat) -
+# 1), 1), lmat[, 2] + 1)
+# lwid <- c(lwid[1], 0.2, lwid[2])
+# }
+# lmat[is.na(lmat)] <- 0
+# }
+# if (length(lhei) != nrow(lmat))
+# stop("lhei must have length = nrow(lmat) = ", nrow(lmat))
+# if (length(lwid) != ncol(lmat))
+# stop("lwid must have length = ncol(lmat) =", ncol(lmat))
+# op <- par(no.readonly = TRUE)
+# on.exit(par(op))
+# layout(lmat, widths = lwid, heights = lhei, respect = FALSE)
+# if (!missing(RowSideColors)) {
+# par(mar = c(margins[1], 0, 0, 0.5))
+# image(rbind(1:nr), col = RowSideColors[rowInd], axes = FALSE)
+# }
+# if (!missing(ColSideColors)) {
+# par(mar = c(0.5, 0, 0, margins[2]))
+# csc = ColSideColors[colInd, ]
+# csc.colors = matrix()
+# csc.names = names(table(csc))
+# csc.i = 1
+# for (csc.name in csc.names) {
+# csc.colors[csc.i] = csc.name
+# csc[csc == csc.name] = csc.i
+# csc.i = csc.i + 1
+# }
+# csc = matrix(as.numeric(csc), nrow = dim(csc)[1])
+# image(csc, col = as.vector(csc.colors), axes = FALSE)
+# if (length(colnames(ColSideColors)) > 0) {
+# axis(2, 0:(dim(csc)[2] - 1)/(dim(csc)[2] - 1), colnames(ColSideColors),
+# las = 2, tick = FALSE, cex.axis= cexRow)
+# }
+# }
+# par(mar = c(margins[1], 0, 0, margins[2]))
+# if (!symm || scale != "none") {
+# x <- t(x)
+# cellnote <- t(cellnote)
+# }
+# if (revC) {
+# iy <- nr:1
+# if (exists("ddr"))
+# ddr <- rev(ddr)
+# x <- x[, iy]
+# cellnote <- cellnote[, iy]
+# }
+# else iy <- 1:nr
+# image(1:nc, 1:nr, x, xlim = 0.5 + c(0, nc), ylim = 0.5 +
+# c(0, nr), axes = FALSE, xlab = "", ylab = "", col = col,
+# breaks = breaks, ...)
+# retval$carpet <- x
+# if (exists("ddr"))
+# retval$rowDendrogram <- ddr
+# if (exists("ddc"))
+# retval$colDendrogram <- ddc
+# retval$breaks <- breaks
+# retval$col <- col
+# if (!invalid(na.color) & any(is.na(x))) {
+# mmat <- ifelse(is.na(x), 1, NA)
+# image(1:nc, 1:nr, mmat, axes = FALSE, xlab = "", ylab = "",
+# col = na.color, add = TRUE)
+# }
+# axis(1, 1:nc, labels = labCol, las = 2, line = -0.5, tick = 0,
+# cex.axis = cexCol)
+# if (!is.null(xlab))
+# mtext(xlab, side = 1, line = margins[1] - 1.25)
+# axis(4, iy, labels = labRow, las = 2, line = -0.5, tick = 0,
+# cex.axis = cexRow)
+# if (!is.null(ylab))
+# mtext(ylab, side = 4, line = margins[2] - 1.25)
+# if (!missing(add.expr))
+# eval(substitute(add.expr))
+# if (!missing(colsep))
+# for (csep in colsep) rect(xleft = csep + 0.5, ybottom = rep(0,
+# length(csep)), xright = csep + 0.5 + sepwidth[1],
+# ytop = rep(ncol(x) + 1, csep), lty = 1, lwd = 1,
+# col = sepcolor, border = sepcolor)
+# if (!missing(rowsep))
+# for (rsep in rowsep) rect(xleft = 0, ybottom = (ncol(x) +
+# 1 - rsep) - 0.5, xright = nrow(x) + 1, ytop = (ncol(x) +
+# 1 - rsep) - 0.5 - sepwidth[2], lty = 1, lwd = 1,
+# col = sepcolor, border = sepcolor)
+# min.scale <- min(breaks)
+# max.scale <- max(breaks)
+# x.scaled <- scale01(t(x), min.scale, max.scale)
+# if (trace %in% c("both", "column")) {
+# retval$vline <- vline
+# vline.vals <- scale01(vline, min.scale, max.scale)
+# for (i in colInd) {
+# if (!is.null(vline)) {
+# abline(v = i - 0.5 + vline.vals, col = linecol,
+# lty = 2)
+# }
+# xv <- rep(i, nrow(x.scaled)) + x.scaled[, i] - 0.5
+# xv <- c(xv[1], xv)
+# yv <- 1:length(xv) - 0.5
+# lines(x = xv, y = yv, lwd = 1, col = tracecol, type = "s")
+# }
+# }
+# if (trace %in% c("both", "row")) {
+# retval$hline <- hline
+# hline.vals <- scale01(hline, min.scale, max.scale)
+# for (i in rowInd) {
+# if (!is.null(hline)) {
+# abline(h = i + hline, col = linecol, lty = 2)
+# }
+# yv <- rep(i, ncol(x.scaled)) + x.scaled[i, ] - 0.5
+# yv <- rev(c(yv[1], yv))
+# xv <- length(yv):1 - 0.5
+# lines(x = xv, y = yv, lwd = 1, col = tracecol, type = "s")
+# }
+# }
+# if (!missing(cellnote))
+# text(x = c(row(cellnote)), y = c(col(cellnote)), labels = c(cellnote),
+# col = notecol, cex = notecex)
+# par(mar = c(margins[1], 0, 0, 0))
+# if (dendrogram %in% c("both", "row")) {
+# plot(ddr, horiz = TRUE, axes = FALSE, yaxs = "i", leaflab = "none")
+# }
+# else plot.new()
+# par(mar = c(0, 0, if (!is.null(main)) 5 else 0, margins[2]))
+# if (dendrogram %in% c("both", "column")) {
+# plot(ddc, axes = FALSE, xaxs = "i", leaflab = "none")
+# }
+# else plot.new()
+# if (!is.null(main))
+# title(main, cex.main = 1.5 * op[["cex.main"]])
+# if (key) {
+# par(mar = c(5, 4, 2, 1), cex = 0.75)
+# tmpbreaks <- breaks
+# if (symkey) {
+# max.raw <- max(abs(c(x, breaks)), na.rm = TRUE)
+# min.raw <- -max.raw
+# tmpbreaks[1] <- -max(abs(x))
+# tmpbreaks[length(tmpbreaks)] <- max(abs(x))
+# }
+# else {
+# min.raw <- min(x, na.rm = TRUE)
+# max.raw <- max(x, na.rm = TRUE)
+# }
+# z <- seq(min.raw, max.raw, length = length(col))
+# image(z = matrix(z, ncol = 1), col = col, breaks = tmpbreaks,
+# xaxt = "n", yaxt = "n")
+# par(usr = c(0, 1, 0, 1))
+# lv <- pretty(breaks)
+# xv <- scale01(as.numeric(lv), min.raw, max.raw)
+# axis(1, at = xv, labels = lv)
+# if (scale == "row")
+# mtext(side = 1, "Row Z-Score", line = 2)
+# else if (scale == "column")
+# mtext(side = 1, "Column Z-Score", line = 2)
+# else mtext(side = 1, "Value", line = 2)
+# if (density.info == "density") {
+# dens <- density(x, adjust = densadj, na.rm = TRUE)
+# omit <- dens$x < min(breaks) | dens$x > max(breaks)
+# dens$x <- dens$x[-omit]
+# dens$y <- dens$y[-omit]
+# dens$x <- scale01(dens$x, min.raw, max.raw)
+# lines(dens$x, dens$y/max(dens$y) * 0.95, col = denscol,
+# lwd = 1)
+# axis(2, at = pretty(dens$y)/max(dens$y) * 0.95, pretty(dens$y))
+# title("Color Key\nand Density Plot")
+# par(cex = 0.5)
+# mtext(side = 2, "Density", line = 2)
+# }
+# else if (density.info == "histogram") {
+# h <- hist(x, plot = FALSE, breaks = breaks)
+# hx <- scale01(breaks, min.raw, max.raw)
+# hy <- c(h$counts, h$counts[length(h$counts)])
+# lines(hx, hy/max(hy) * 0.95, lwd = 1, type = "s",
+# col = denscol)
+# axis(2, at = pretty(hy)/max(hy) * 0.95, pretty(hy))
+# title("Color Key\nand Histogram")
+# par(cex = 0.5)
+# mtext(side = 2, "Count", line = 2)
+# }
+# else title("Color Key")
+# }
+# else plot.new()
+# retval$colorTable <- data.frame(low = retval$breaks[-length(retval$breaks)],
+# high = retval$breaks[-1], color = retval$col)
+# invisible(retval)
+#}
+
+# Extracted from the psychometric package (0.1.0)
+# Copyright Thomas D. Fletcher
+# Under Gnu GPL2
+CI.Rsqlm <- function (obj, level = 0.95)
+{
+ l <- level
+ rsq <- summary(obj)$r.squared
+ k <- summary(obj)$df[1] - 1
+ n <- obj$df + k + 1
+ mat <- CI.Rsq(rsq, n, k, level = l)
+ return(mat)
+}
+# Extracted from the psychometric package (0.1.0)
+# Copyright Thomas D. Fletcher
+# Under Gnu GPL2
+CI.Rsq <- function (rsq, n, k, level = 0.95)
+{
+ noma <- 1 - level
+ sersq <- sqrt((4 * rsq * (1 - rsq)^2 * (n - k - 1)^2)/((n^2 -
+ 1) * (n + 3)))
+ zs <- -qnorm(noma/2)
+ mez <- zs * sersq
+ lcl <- rsq - mez
+ ucl <- rsq + mez
+ mat <- data.frame(Rsq = rsq, SErsq = sersq, LCL = lcl, UCL = ucl)
+ return(mat)
+}
+
+str_dim <- function(x, dims=dim(x)){
+ if( !is.null(dims) ) paste0(dims, collapse = ' x ')
+ else length(x)
+}
+
+# Internal override stringr function str_match
+#
+# This is to get the previous behaviour on optional groups, because
+# in stringr >= 1.0.0 absent optional groups get an NA value instead
+# of an empty string, which in turn breaks some downstream processing.
+str_match <- function(...){
+
+ res <- stringr::str_match(...)
+ # replace NAs by "" for globally matched strings
+ if( length(w <- which(!is.na(res[, 1L]))) ){
+ res[w, ][is.na(res[w, ])] <- ""
+ }
+ res
+}
+
diff --git a/R/versions.R b/R/versions.R
new file mode 100644
index 0000000..86e0362
--- /dev/null
+++ b/R/versions.R
@@ -0,0 +1,197 @@
+# Tracking/Updating S4 class versions
+#
+# Author: Renaud Gaujoux
+###############################################################################
+
+#' @include utils.R
+NULL
+
+objectUpdater <- local({
+ .REGISTRY <- list()
+
+ function(x, version=NULL, fun=NULL, vfun=NULL, verbose=FALSE){
+
+ if( missing(x) ) return( .REGISTRY )
+
+ if( is.null(version) ){
+ cl <- class(x)
+ UPDATER <- .REGISTRY[[cl]]
+
+ vmsg <- 'Class'
+ if( is.character(verbose) ){
+ vmsg <- paste(verbose, ':', sep='')
+ verbose <- TRUE
+ }
+ if( verbose ) message("# ", vmsg, " '", cl, "' ... ", appendLF=FALSE)
+ if( !isS4(x) ){
+ if( verbose) message("NO")
+ return(x)
+ }
+
+ # create new object from old slots
+ newObject <- if( verbose ){
+ message()
+ updateObjectFromSlots(x, verbose=verbose>1)
+ }else suppressWarnings( updateObjectFromSlots(x, verbose=verbose>1) )
+
+
+ if( is.null(UPDATER) ){
+ if( verbose) message("AUTO")
+ return(newObject)
+ }
+
+ # find object version
+ v <- sapply(UPDATER, function(f) f$vfun(x))
+ v <- which(v)
+ if( !length(v) ){
+ if( verbose) message("SKIP [version unknown]")
+ return(newObject)
+ }
+ if( length(v) > 1L ){
+ warning("Object matched multiple version of class '", cl
+ , "' [", paste(names(UPDATER)[v], collapse=", "), "]")
+ if( verbose) message("SKIP [multiple versions]")
+ return(newObject)
+ }else if( verbose) message("UPDATING [", appendLF=FALSE)
+
+ for(n in names(UPDATER[v[1L]])){
+ f <- UPDATER[[n]]
+ if( verbose ) message(n, ' -> ', appendLF=FALSE)
+ newObject <- f$fun(x, newObject)
+ }
+ if( verbose ) message("*]")
+ # return updated object
+ return(newObject)
+ }
+
+ stopifnot( is.character(x) )
+ if( is.null(version) ){
+ if( !is.null(fun) || !is.null(vfun) )
+ stop("Argument `version` is required for defining updater functions for class `", x, "`")
+ return(.REGISTRY[[x]])
+ }
+
+ if( is.null(.REGISTRY[[x]]) ) .REGISTRY[[x]] <<- list()
+ # check result is a function
+ stopifnot(is.function(fun))
+ stopifnot(is.function(vfun))
+ if( !is.null(.REGISTRY[[x]][[version]]) )
+ stop("An update for class '", x, "' version ", version, " is already defined")
+
+ .REGISTRY[[x]][[version]] <<- list(vfun=vfun, fun=fun)
+ # put updaters in order
+ .REGISTRY[[x]] <<- .REGISTRY[[x]][orderVersion(names(.REGISTRY[[x]]))]
+ invisible(.REGISTRY[[x]])
+ }
+})
+
+# Taken from BiocGenerics 2.16
+getObjectSlots <- function (object)
+{
+ if (!is.object(object) || isVirtualClass(class(object)))
+ return(NULL)
+ value <- attributes(object)
+ value$class <- NULL
+ if (is(object, "vector")) {
+ .Data <- as.vector(object)
+ attr(.Data, "class") <- NULL
+ attrNames <- c("comment", "dim", "dimnames", "names",
+ "row.names", "tsp")
+ for (nm in names(value)[names(value) %in% attrNames]) attr(.Data,
+ nm) <- value[[nm]]
+ value <- value[!names(value) %in% attrNames]
+ value$.Data <- .Data
+ }
+ value
+}
+
+# Taken from BiocGenerics 2.16
+updateObjectFromSlots <- function (object, objclass = class(object), ..., verbose = FALSE)
+{
+ updateObject <- nmfObject
+ if (is(object, "environment")) {
+ if (verbose)
+ message("returning original object of class 'environment'")
+ return(object)
+ }
+ classSlots <- slotNames(objclass)
+ if (is.null(classSlots)) {
+ if (verbose)
+ message("definition of '", objclass, "' has no slots; ",
+ "returning original object")
+ return(object)
+ }
+ errf <- function(...) {
+ function(err) {
+ if (verbose)
+ message(..., ":\n ", conditionMessage(err),
+ "\n trying next method...")
+ NULL
+ }
+ }
+ if (verbose)
+ message("updateObjectFromSlots(object = '", class(object),
+ "' class = '", objclass, "')")
+ objectSlots <- getObjectSlots(object)
+ nulls <- sapply(names(objectSlots), function(slt) is.null(slot(object,
+ slt)))
+ objectSlots[nulls] <- NULL
+ joint <- intersect(names(objectSlots), classSlots)
+ toUpdate <- joint[joint != ".Data"]
+ objectSlots[toUpdate] <- lapply(objectSlots[toUpdate], updateObject,
+ ..., verbose = verbose)
+ toDrop <- which(!names(objectSlots) %in% classSlots)
+ if (length(toDrop) > 0L) {
+ warning("dropping slot(s) ", paste(names(objectSlots)[toDrop],
+ collapse = ", "), " from object = '", class(object),
+ "'")
+ objectSlots <- objectSlots[-toDrop]
+ }
+ res <- NULL
+ if (is.null(res)) {
+ if (verbose)
+ message("heuristic updateObjectFromSlots, method 1")
+ res <- tryCatch({
+ do.call(new, c(objclass, objectSlots[joint]))
+ }, error = errf("'new(\"", objclass, "\", ...)' from slots failed"))
+ }
+ if (is.null(res)) {
+ if (verbose)
+ message("heuristic updateObjectFromSlots, method 2")
+ res <- tryCatch({
+ obj <- do.call(new, list(objclass))
+ for (slt in joint) slot(obj, slt) <- updateObject(objectSlots[[slt]],
+ ..., verbose = verbose)
+ obj
+ }, error = errf("failed to add slots to 'new(\"", objclass,
+ "\", ...)'"))
+ }
+ if (is.null(res))
+ stop("could not updateObject to class '", objclass, "'",
+ "\nconsider defining an 'updateObject' method for class '",
+ class(object), "'")
+ res
+}
+
+
+#' Updating NMF Objects
+#'
+#' This function serves to update an objects created with previous versions of the
+#' NMF package, which would otherwise be incompatible with the current version,
+#' due to changes in their S4 class definition.
+#'
+#' This function makes use of heuristics to automatically update object slots,
+#' which have been borrowed from the BiocGenerics package, the function
+#' \code{updateObjectFromSlots} in particular.
+#'
+#' @param object an R object created by the NMF package, e.g., an object of class
+#' \code{\linkS4class{NMF}} or \code{\linkS4class{NMFfit}}.
+#' @param verbose logical to toggle verbose messages.
+#'
+#' @export
+#'
+nmfObject <- function(object, verbose=FALSE){
+
+ objectUpdater(object, verbose=verbose)
+
+}
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..e931835
--- /dev/null
+++ b/README.md
@@ -0,0 +1,29 @@
+## Background
+
+Nonnegative Matrix Factorization (NMF) is an unsupervised learning technique that has been applied successfully in several fields, including signal processing, face recognition and text mining.
+Recent applications of NMF in bioinformatics have demonstrated its ability to extract meaningful information from high-dimensional data such as gene expression microarrays. Developments in NMF theory and applications have resulted in a variety of algorithms and methods.
+However, most NMF implementations have been on commercial platforms, while those that are freely available typically require programming skills.
+This limits their use by the wider research community.
+
+## Results
+Our objective is to provide the bioinformatics community with an open-source, easy-to-use and unified interface to standard NMF algorithms, as well as with a simple framework to help implement and test new NMF methods.
+For that purpose, we have developed a package for the R/BioConductor platform. The package ports public code to R, and is structured to enable users to easily modify and/or add algorithms.
+It includes a number of published NMF algorithms and initialization methods and facilitates the combination of these to produce new NMF strategies.
+Commonly used benchmark data and visualization methods are provided to help in the comparison and interpretation of the results.
+
+## Conclusions
+The NMF package helps realize the potential of Nonnegative Matrix Factorization, especially in bioinformatics, providing easy access to methods that have already yielded new insights in many applications.
+
+## Availability
+
+Documentation, source code and sample data are available from:
+
+*  Latest stable release from CRAN: http://cran.r-project.org/package=NMF
+
+* Development versions:
+ *  project: http://r-forge.r-project.org/projects/nmf<br />
+_NOTE: due to some unknown problem on R-forge build system, the package is not being built. Please use the MyCRAN repository until the issue is fixed._<br /><br />
+ * MyCRAN: personal CRAN-like repository at http://web.cbio.uct.ac.za/~renaud/CRAN
+
+-----
+__Travis check:__ [](https://travis-ci.org/renozao/NMF)
diff --git a/TODO b/TODO
new file mode 100644
index 0000000..ecc6875
--- /dev/null
+++ b/TODO
@@ -0,0 +1,18 @@
+Features:
+ o handle missing data in target matrix
+ o NMF model/algorithm class for MCMC based NMF
+ o function/option to run standard consensus clustering,
+ i.e. with a different set sample for each run.
+ Possibly also use subsets of features and consensus matrix for them (memory issue).
+ o incorporate silhouette values/plots, notably in heatmaps
+ o support for other type of matrix-like objects (e.g., bigmatrix, Matrix)
+ o import/export functions
+
+Documentation:
+ o improve/update vignettes
+
+Technical/Internals:
+ o change plot.NMFrankestimate to screeplot, remove class NMFrankestimate,
+ change it to normal NMFlist
+ o Switch to the interface defined in the package modeltools
+
\ No newline at end of file
diff --git a/build/vignette.rds b/build/vignette.rds
new file mode 100644
index 0000000..fb437dd
Binary files /dev/null and b/build/vignette.rds differ
diff --git a/data/esGolub.rda b/data/esGolub.rda
new file mode 100644
index 0000000..4c74137
Binary files /dev/null and b/data/esGolub.rda differ
diff --git a/demo/00Index b/demo/00Index
new file mode 100644
index 0000000..19d9cea
--- /dev/null
+++ b/demo/00Index
@@ -0,0 +1,3 @@
+nmf Using the main function nmf()
+heatmaps Heatmaps of NMF objects
+aheatmap Annotated heatmaps
diff --git a/demo/aheatmap.R b/demo/aheatmap.R
new file mode 100644
index 0000000..2476d77
--- /dev/null
+++ b/demo/aheatmap.R
@@ -0,0 +1,61 @@
+# Generate random data
+n <- 50; p <- 20
+x <- abs(rmatrix(n, p, rnorm, mean=4, sd=1))
+x[1:10, seq(1, 10, 2)] <- x[1:10, seq(1, 10, 2)] + 3
+x[11:20, seq(2, 10, 2)] <- x[11:20, seq(2, 10, 2)] + 2
+rownames(x) <- paste("ROW", 1:n)
+colnames(x) <- paste("COL", 1:p)
+
+## Scaling
+aheatmap(x, scale = "row")
+aheatmap(x, scale = "col") # partially matched to 'column'
+aheatmap(x, scale = "r1") # each row sum up to 1
+aheatmap(x, scale = "c1") # each colum sum up to 1
+
+## Heatmap colors
+aheatmap(x, color = colorRampPalette(c("navy", "white", "firebrick3"))(50))
+# color specification as an integer: use R basic colors
+aheatmap(x, color = 1L)
+# color specification as a negative integer: use reverse basic palette
+aheatmap(x, color = -1L)
+# color specification as a numeric: use HCL color
+aheatmap(x, color = 1)
+# do not cluster the rows
+aheatmap(x, Rowv = NA)
+# no heatmap legend
+aheatmap(x, legend = FALSE)
+# cell and font size
+aheatmap(x, cellwidth = 10, cellheight = 5)
+
+# directly write into a file
+aheatmap(x, cellwidth = 15, cellheight = 12, fontsize = 8, filename = "aheatmap.pdf")
+unlink('aheatmap.pdf')
+
+# Generate column annotations
+annotation = data.frame(Var1 = factor(1:p %% 2 == 0, labels = c("Class1", "Class2")), Var2 = 1:10)
+
+aheatmap(x, annCol = annotation)
+aheatmap(x, annCol = annotation, annLegend = FALSE)
+
+
+# Specify colors
+Var1 = c("navy", "darkgreen")
+names(Var1) = c("Class1", "Class2")
+Var2 = c("lightgreen", "navy")
+
+ann_colors = list(Var1 = Var1, Var2 = Var2)
+
+aheatmap(x, annCol = annotation, annColors = ann_colors)
+
+# Specifying clustering from distance matrix
+drows = dist(x, method = "minkowski")
+dcols = dist(t(x), method = "minkowski")
+aheatmap(x, Rowv = drows, Colv = dcols)
+
+# Display text in each cells
+t <- outer(as.character(outer(letters, letters, paste0)), letters, paste0)[1:n, 1:p]
+aheatmap(x, txt = t)
+# NA values are shown as empty cells
+t.na <- t
+t.na[sample(length(t.na), 500)] <- NA # half of the cells
+aheatmap(x, txt = t.na)
diff --git a/demo/heatmaps.R b/demo/heatmaps.R
new file mode 100644
index 0000000..b26b0fc
--- /dev/null
+++ b/demo/heatmaps.R
@@ -0,0 +1,25 @@
+#' # random data with underlying NMF model
+v <- syntheticNMF(20, 3, 10)
+# estimate a model
+x <- nmf(v, 3)
+
+# highligh row only (using custom colors)
+basismap(x, tracks=':basis', annColor=list(basis=1:3))
+
+## character annotation vector: ok if it does not contain 'basis'
+# annotate first and second row + automatic special track
+basismap(x, annRow=c('alpha', 'beta'))
+# no special track here
+basismap(x, annRow=c('alpha', 'beta', ':basis'), tracks=NA)
+# with special track `basis`
+basismap(x, annRow=list(c('alpha', 'beta'), ':basis'), tracks=NA)
+# highligh columns only (using custom colors)
+basismap(x, tracks='basis:')
+
+# changing the name of the basis annotation track
+basismap(x, annRow=list(new_name=':basis'))
+
+# coefficient matrix
+coefmap(x, annCol=c('alpha', 'beta')) # annotate first and second sample
+coefmap(x, annCol=list('basis', Greek=c('alpha', 'beta'))) # annotate first and second sample + basis annotation
+coefmap(x, annCol=c(new_name='basis'))
diff --git a/demo/nmf.R b/demo/nmf.R
new file mode 100644
index 0000000..447cb82
--- /dev/null
+++ b/demo/nmf.R
@@ -0,0 +1,163 @@
+# generate a synthetic dataset with known classes: 50 features, 23 samples (10+5+8)
+n <- 20; counts <- c(5, 3, 2);
+p <- sum(counts)
+x <- syntheticNMF(n, counts)
+dim(x)
+
+# build the true cluster membership
+groups <- unlist(mapply(rep, seq(counts), counts))
+
+# run on a data.frame
+res <- nmf(data.frame(x), 3)
+
+# missing method: use algorithm suitable for seed
+res <- nmf(x, 2, seed=rnmf(2, x))
+algorithm(res)
+res <- nmf(x, 2, seed=rnmf(2, x, model='NMFns'))
+algorithm(res)
+
+# compare some NMF algorithms (tracking the approximation error)
+res <- nmf(x, 2, list('brunet', 'lee', 'nsNMF'), .options='t')
+res
+summary(res, class=groups)
+
+# plot the track of the residual errors
+plot(res)
+
+# specify algorithm by its name
+res <- nmf(x, 3, 'nsNMF', seed=123) # nonsmooth NMF
+# names are partially matched so this also works
+identical(res, nmf(x, 3, 'ns', seed=123))
+
+res <- nmf(x, 3, 'offset') # NMF with offset
+
+# run a custom algorithm defined as a standard function
+myfun <- function(x, start, alpha){
+# update starting point
+# ...
+basis(start) <- 3 * basis(start)
+# return updated point
+start
+}
+
+res <- nmf(x, 2, myfun, alpha=3)
+algorithm(res)
+# error: alpha missing
+try( nmf(x, 2, myfun) )
+
+# possibly the algorithm fits a non-standard NMF model, e.g. NMFns model
+res <- nmf(x, 2, myfun, alpha=3, model='NMFns')
+modelname(res)
+
+# assume a known NMF model compatible with the matrix `x`
+y <- rnmf(3, x)
+# fits an NMF model (with default method) on some data using y as a starting point
+res <- nmf(x, y)
+# the fit can be reproduced using the same starting point
+nmf.equal(nmf(x, y), res)
+
+# missing method: use default algorithm
+res <- nmf(x, 3)
+
+# Fit a 3-rank model providing an initial value for the basis matrix
+nmf(x, rmatrix(nrow(x), 3), 'snmf/r')
+
+# Fit a 3-rank model providing an initial value for the mixture coefficient matrix
+nmf(x, rmatrix(3, ncol(x)), 'snmf/l')
+
+# default fit
+res <- nmf(x, 2)
+summary(res, class=groups)
+
+# run default algorithm multiple times (only keep the best fit)
+res <- nmf(x, 3, nrun=10)
+res
+summary(res, class=groups)
+
+# run default algorithm multiple times keeping all the fits
+res <- nmf(x, 3, nrun=10, .options='k')
+res
+summary(res, class=groups)
+
+## Note: one could have equivalently done
+# res <- nmf(V, 3, nrun=10, .options=list(keep.all=TRUE))
+
+# use a method that fit different model
+res <- nmf(x, 2, 'nsNMF')
+fit(res)
+
+# pass parameter theta to the model via `...`
+res <- nmf(x, 2, 'nsNMF', theta=0.2)
+fit(res)
+
+## handling arguments in `...` and model parameters
+myfun <- function(x, start, theta=100){ cat("theta in myfun=", theta, "\n\n"); start }
+# no conflict: default theta
+fit( nmf(x, 2, myfun) )
+# no conlfict: theta is passed to the algorithm
+fit( nmf(x, 2, myfun, theta=1) )
+# conflict: theta is used as model parameter
+fit( nmf(x, 2, myfun, model='NMFns', theta=0.1) )
+# conflict solved: can pass different theta to model and algorithm
+fit( nmf(x, 2, myfun, model=list('NMFns', theta=0.1), theta=5) )
+
+## USING SEEDING METHODS
+
+# run default algorithm with the Non-negative Double SVD seeding method ('nndsvd')
+res <- nmf(x, 3, seed='nndsvd')
+
+## Note: partial match also works
+identical(res, nmf(x, 3, seed='nn'))
+
+# run nsNMF algorithm, fixing the seed of the random number generator
+res <- nmf(x, 3, 'nsNMF', seed=123456)
+nmf.equal(nmf(x, 3, 'nsNMF', seed=123456), res)
+
+# run default algorithm specifying the starting point following the NMF standard model
+start.std <- nmfModel(W=matrix(0.5, n, 3), H=matrix(0.2, 3, p))
+nmf(x, start.std)
+
+# to run nsNMF algorithm with an explicit starting point, this one
+# needs to follow the 'NMFns' model:
+start.ns <- nmfModel(model='NMFns', W=matrix(0.5, n, 3), H=matrix(0.2, 3, p))
+nmf(x, start.ns)
+# Note: the method name does not need to be specified as it is infered from the
+# when there is only one algorithm defined for the model.
+
+# if the model is not appropriate (as defined by the algorihtm) an error is thrown
+# [cf. the standard model doesn't include a smoothing parameter used in nsNMF]
+try( nmf(x, start.std, method='nsNMF') )
+
+## Callback functions
+# Pass a callback function to only save summary measure of each run
+res <- nmf(x, 3, nrun=3, .callback=summary)
+# the callback results are simplified into a matrix
+res$.callback
+res <- nmf(x, 3, nrun=3, .callback=summary, .opt='-S')
+# the callback results are simplified into a matrix
+res$.callback
+
+# Pass a custom callback function
+cb <- function(obj, i){ if( i %% 2 ) sparseness(obj) >= 0.5 }
+res <- nmf(x, 3, nrun=3, .callback=cb)
+res$.callback
+
+# Passs a callback function which throws an error
+cb <- function(){ i<-0; function(object){ i <<- i+1; if( i == 1 ) stop('SOME BIG ERROR'); summary(object) }}
+res <- nmf(x, 3, nrun=3, .callback=cb())
+
+## PARALLEL COMPUTATIONS
+# try using 3 cores, but use sequential if not possible
+res <- nmf(x, 3, nrun=3, .options='p3')
+
+# force using 3 cores, error if not possible
+res <- nmf(x, 3, nrun=3, .options='P3')
+
+# use externally defined cluster
+library(parallel)
+cl <- makeCluster(6)
+res <- nmf(x, 3, nrun=3, .pbackend=cl)
+
+# use externally registered backend
+registerDoParallel(cl)
+res <- nmf(x, 3, nrun=3, .pbackend=NULL)
diff --git a/inst/CITATION b/inst/CITATION
new file mode 100644
index 0000000..6127521
--- /dev/null
+++ b/inst/CITATION
@@ -0,0 +1,50 @@
+## R >= 2.8.0 passes package metadata to citation().
+if( !exists('meta') || is.null(meta) ) meta <- packageDescription("NMF")
+
+year <- sub(".*(2[[:digit:]]{3})-.*", "\\1", meta$Date, perl = TRUE)
+vers <- paste("R package version", meta$Version)
+author <- as.personList(meta$Author)
+url <- sprintf("http://cran.r-project.org/package=%s", meta$Package)
+
+citHeader(sprintf("To cite the package '%s' in publications use:", meta$Package))
+
+citEntry(entry="Article"
+ , title = "A flexible R package for nonnegative matrix factorization"
+ , author = personList(as.person("Renaud Gaujoux"), as.person("Cathal Seoighe"))
+ , journal = "BMC Bioinformatics"
+ , year = 2010
+ , volume = 11
+ , number = 1
+ , pages = 367
+ , url = "http://www.biomedcentral.com/1471-2105/11/367"
+ , doi = "10.1186/1471-2105-11-367"
+ , issn = "1471-2105"
+ , textVersion =
+ paste("Renaud Gaujoux, Cathal Seoighe (2010)"
+ , "A flexible R package for nonnegative matrix factorization"
+ , "BMC Bioinformatics 2010, 11:367"
+ , "[http://www.biomedcentral.com/1471-2105/11/367]"
+ , sep=". ")
+)
+
+citEntry(entry="Manual"
+ , title = vign <- "Using the package NMF"
+ , author = author
+ , publisher = "CRAN"
+ , year = year
+ , note = vers
+ , url = url
+ , textVersion = sprintf("%s (%s). %s. CRAN. %s. [%s]", author, year, vign, vers, url)
+ , header = "Vignette(s):"
+)
+
+citEntry(entry="Manual"
+ , title = "The package NMF: manual pages"
+ , author = author
+ , publisher = "CRAN"
+ , year = year
+ , note = vers
+ , url = url
+ , textVersion = sprintf("%s (%s). %s CRAN. %s. [%s]", author, year, meta$Title, vers, url)
+ , header = "Technical documentation:"
+)
diff --git a/inst/REFERENCES.bib b/inst/REFERENCES.bib
new file mode 100644
index 0000000..be09f13
--- /dev/null
+++ b/inst/REFERENCES.bib
@@ -0,0 +1,380 @@
+ at Manual{R,
+ address = {Vienna, Austria},
+ annote = {\{ISBN\} 3-900051-07-0},
+ author = {{R Development Core Team}},
+ organization = {R Foundation for Statistical Computing},
+ title = {{R: A Language and Environment for Statistical Computing}},
+ url = {http://www.r-project.org},
+ year = {2011},
+}
+
+ at Article{Gentleman2004,
+ abstract = {The Bioconductor project is an initiative for the collaborative creation of extensible software for computational biology and bioinformatics. The goals of the project include: fostering collaborative development and widespread use of innovative software, reducing barriers to entry into interdisciplinary scientific research, and promoting the achievement of remote reproducibility of research results. We describe details of our aims and methods, identify current challenges, c [...]
+ author = {Robert C Gentleman and Vincent J Carey and Douglas M Bates and Ben Bolstad and Marcel Dettling and Sandrine Dudoit and Byron Ellis and Laurent Gautier and Yongchao Ge and Jeff Gentry and Kurt Hornik and Torsten Hothorn and Wolfgang Huber and Stefano Iacus and Rafael Irizarry and Friedrich Leisch and Cheng Li and Martin Maechler and Anthony J Rossini and Gunther Sawitzki and Colin Smith and Gordon Smyth and Luke Tierney and Jean Y H Yang and Jianhua Zhang},
+ doi = {10.1186/gb-2004-5-10-r80},
+ issn = {1465-6914},
+ journal = {Genome biology},
+ keywords = {Computational Biology,Computational Biology: instrumentation,Computational Biology: methods,Internet,Reproducibility of Results,Software},
+ number = {10},
+ pages = {R80},
+ pmid = {15461798},
+ shorttitle = {Genome Biol},
+ title = {{Bioconductor: open software development for computational biology and bioinformatics.}},
+ url = {http://www.ncbi.nlm.nih.gov/pubmed/15461798},
+ volume = {5},
+ year = {2004},
+}
+
+ at Article{Lee2001,
+ author = {D D Lee and HS Seung},
+ file = {:home/renaud/Documents/articles/NMF/Algorithms for non-negative matrix factorization\_Lee2000.pdf:pdf},
+ journal = {Advances in neural information processing systems},
+ title = {{Algorithms for non-negative matrix factorization}},
+ url = {http://scholar.google.com/scholar?q=intitle:Algorithms+for+non-negative+matrix+factorization\#0},
+ year = {2001},
+}
+
+ at Article{Li2001,
+ author = {Stan Z Li and Xinwen Hou},
+ file = {:home/renaud/Documents/articles/NMF/Learning Spatially Localized, Parts-Based Representation\_Li2001.pdf:pdf},
+ journal = {Convergence},
+ number = {C},
+ pages = {1--6},
+ title = {{Learning Spatially Localized, Parts-Based Representation}},
+ volume = {00},
+ year = {2001},
+}
+
+ at Article{Badea2008,
+ abstract = {In this paper we introduce a clustering algorithm capable of simultaneously factorizing two distinct gene expression datasets with the aim of uncovering gene regulatory programs that are common to the two phenotypes. The siNMF algorithm simultaneously searches for two factorizations that share the same gene expression profiles. The two key ingredients of this algorithm are the nonnegativity constraint and the offset variables, which together ensure the sparseness of the fac [...]
+ author = {Liviu Badea},
+ file = {:home/renaud/Documents/articles/NMF/Extracting Gene Expression Profiles Common to Colon and Pancreatic Adenocarcinoma Using Simultaneous Nonnegative Matrix Factorization\_Badea2008.pdf:pdf},
+ issn = {1793-5091},
+ journal = {Pacific Symposium on Biocomputing. Pacific Symposium on Biocomputing},
+ keywords = {Adenocarcinoma,Adenocarcinoma: genetics,Algorithms,Carcinoma,Colonic Neoplasms,Colonic Neoplasms: genetics,Computational Biology,Data Interpretation,Databases,Gene Expression Profiling,Gene Expression Profiling: statistics \& numerical,Genetic,Humans,Pancreatic Ductal,Pancreatic Ductal: genetics,Pancreatic Neoplasms,Pancreatic Neoplasms: genetics,Statistical},
+ month = {jan},
+ pages = {267--78},
+ pmid = {18229692},
+ title = {{Extracting gene expression profiles common to colon and pancreatic adenocarcinoma using simultaneous nonnegative matrix factorization.}},
+ url = {http://www.ncbi.nlm.nih.gov/pubmed/18229692},
+ volume = {290},
+ year = {2008},
+}
+
+ at Article{Zhang2008,
+ abstract = {Independent component analysis (ICA) is a widely applicable and effective approach in blind source separation (BSS), with limitations that sources are statistically independent. However, more common situation is blind source separation for nonnegative linear model (NNLM) where the observations are nonnegative linear combinations of nonnegative sources, and the sources may be statistically dependent. We propose a pattern expression nonnegative matrix factorization (PE-NMF) a [...]
+ author = {Junying Zhang and Le Wei and Xuerong Feng and Zhen Ma and Yue Wang},
+ doi = {10.1155/2008/168769},
+ file = {:home/renaud/Documents/articles/NMF/Pattern Expression Nonnegative Matrix Factorization$\backslash$: Algorithm and Applications to Blind Source Separation\_Zhang2008.pdf:pdf},
+ issn = {1687-5265},
+ journal = {Computational intelligence and neuroscience},
+ pages = {168769},
+ pmid = {18566689},
+ shorttitle = {Comput Intell Neurosci},
+ title = {{Pattern expression nonnegative matrix factorization: algorithm and applications to blind source separation.}},
+ url = {http://www.ncbi.nlm.nih.gov/pubmed/18566689},
+ volume = {2008},
+ year = {2008},
+}
+
+ at Article{KimH2007,
+ abstract = {MOTIVATION: Many practical pattern recognition problems require non-negativity constraints. For example, pixels in digital images and chemical concentrations in bioinformatics are non-negative. Sparse non-negative matrix factorizations (NMFs) are useful when the degree of sparseness in the non-negative basis matrix or the non-negative coefficient matrix in an NMF needs to be controlled in approximating high-dimensional data in a lower dimensional space. RESULTS: In this art [...]
+ author = {Hyunsoo Kim and Haesun Park},
+ doi = {10.1093/bioinformatics/btm134},
+ file = {:home/renaud/Documents/articles/NMF/Sparse non-negative matrix factorizations via alternating non-negativity-constrained least squares for microarray data analysis Kim2007.pdf:pdf},
+ issn = {1460-2059},
+ journal = {Bioinformatics (Oxford, England)},
+ keywords = {Algorithms,Automated,Automated: methods,Cluster Analysis,Computational Biology,Computational Biology: methods,Data Interpretation,Databases,Entropy,Factor Analysis,Gene Expression,Genetic,Humans,Least-Squares Analysis,Microarray Analysis,Neoplasms,Neoplasms: classification,Neoplasms: genetics,Neoplasms: metabolism,Pattern Recognition,Statistical},
+ number = {12},
+ pages = {1495--502},
+ pmid = {17483501},
+ shorttitle = {Bioinformatics},
+ title = {{Sparse non-negative matrix factorizations via alternating non-negativity-constrained least squares for microarray data analysis.}},
+ url = {http://www.ncbi.nlm.nih.gov/pubmed/17483501},
+ volume = {23},
+ year = {2007},
+}
+
+ at TechReport{Albright2006,
+ author = {Russell Albright and James Cox and David Duling and Amy N. Langville and C. Meyer},
+ booktitle = {Matrix},
+ file = {:home/renaud/Documents/articles/NMF/Algorithms, Initializations, and Convergence for the Nonnegative Matrix Factorization\_Langville2006.pdf:pdf},
+ institution = {NCSU Technical Report Math 81706. http://meyer. math. ncsu. edu/Meyer/Abstracts/Publications. html},
+ keywords = {60j22,65b99,65c40,65f10,65f15,65f50,alternating least squares,ams subject classi cations,clustering,convergence crite-,image processing,initializations,nonnegative matrix factorization,rion,text mining},
+ number = {919},
+ title = {{Algorithms, initializations, and convergence for the nonnegative matrix factorization}},
+ url = {http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.89.2161\&rep=rep1\&type=pdf http://meyer.math.ncsu.edu/Meyer/PS\_Files/NMFInitAlgConv.pdf},
+ year = {2006},
+}
+
+ at Article{Boutsidis2008,
+ author = {C Boutsidis and E Gallopoulos},
+ doi = {10.1016/j.patcog.2007.09.010},
+ file = {:home/renaud/Documents/articles/NMF/SVD based initialization$\backslash$: A head start for nonnegative matrix factorization\_Boutsidis2008.pdf:pdf},
+ issn = {00313203},
+ journal = {Pattern Recognition},
+ month = {apr},
+ number = {4},
+ pages = {1350--1362},
+ title = {{SVD based initialization: A head start for nonnegative matrix factorization}},
+ url = {http://linkinghub.elsevier.com/retrieve/pii/S0031320307004359},
+ volume = {41},
+ year = {2008},
+}
+
+ at Article{Lecuyer2002,
+ author = {Pierre L'Ecuyer and Richard Simard and E.J. Chen},
+ file = {:home/renaud/Documents/articles/stats/An Object-Oriented Random-Number Package with Many Long Streams and Substreams\_Lecuyer2002.pdf:pdf},
+ journal = {Operations Research},
+ number = {6},
+ pages = {1073--1075},
+ publisher = {JSTOR},
+ title = {{An object-oriented random-number package with many long streams and substreams}},
+ url = {http://www.jstor.org/stable/3088626},
+ volume = {50},
+ year = {2002},
+}
+
+ at Article{Hutchins2008,
+ abstract = {MOTIVATION: Cis-acting regulatory elements are frequently constrained by both sequence content and positioning relative to a functional site, such as a splice or polyadenylation site. We describe an approach to regulatory motif analysis based on non-negative matrix factorization (NMF). Whereas existing pattern recognition algorithms commonly focus primarily on sequence content, our method simultaneously characterizes both positioning and sequence content of putative motifs. [...]
+ author = {Lucie N Hutchins and Sean M Murphy and Priyam Singh and Joel H Graber},
+ doi = {10.1093/bioinformatics/btn526},
+ file = {:home/renaud/Documents/articles/NMF/Position-dependent motif characterization using non-negative matrix factorization\_Hutchins2008.pdf:pdf},
+ issn = {1367-4811},
+ journal = {Bioinformatics (Oxford, England)},
+ keywords = {Algorithms,Computational Biology,Computational Biology: methods,Messenger,Messenger: genetics,Messenger: metabolism,RNA,Regulatory Sequences,Ribonucleic Acid,Sequence Analysis},
+ month = {dec},
+ number = {23},
+ pages = {2684--90},
+ pmid = {18852176},
+ title = {{Position-dependent motif characterization using non-negative matrix factorization.}},
+ url = {http://www.ncbi.nlm.nih.gov/pubmed/18852176},
+ volume = {24},
+ year = {2008},
+}
+
+ at Article{Frigyesi2008,
+ abstract = {Non-negative matrix factorization (NMF) is a relatively new approach to analyze gene expression data that models data by additive combinations of non-negative basis vectors (metagenes). The non-negativity constraint makes sense biologically as genes may either be expressed or not, but never show negative expression. We applied NMF to five different microarray data sets. We estimated the appropriate number metagens by comparing the residual error of NMF reconstruction of dat [...]
+ author = {Attila Frigyesi and Mattias H\"{o}glund},
+ file = {:home/renaud/Documents/articles/NMF/Non-Negative Matrix Factorization for the Analysis of Complex Gene Expression Data$\backslash$: Identification of Clinically Relevant Tumor Subtypes\_Frigyesi2008.pdf:pdf},
+ issn = {1176-9351},
+ journal = {Cancer informatics},
+ keywords = {gene expression,metagenes,nmf,tumor classifi cation},
+ month = {jan},
+ number = {2003},
+ pages = {275--92},
+ pmid = {19259414},
+ title = {{Non-negative matrix factorization for the analysis of complex gene expression data: identification of clinically relevant tumor subtypes.}},
+ url = {http://www.ncbi.nlm.nih.gov/pmc/articles/PMC2623306/},
+ volume = {6},
+ year = {2008},
+}
+ at Article{Brunet2004,
+ abstract = {We describe here the use of nonnegative matrix factorization (NMF), an algorithm based on decomposition by parts that can reduce the dimension of expression data from thousands of genes to a handful of metagenes. Coupled with a model selection mechanism, adapted to work for any stochastic clustering algorithm, NMF is an efficient method for identification of distinct molecular patterns and provides a powerful method for class discovery. We demonstrate the ability of NMF to [...]
+ author = {Jean-Philippe Brunet and Pablo Tamayo and Todd R Golub and Jill P Mesirov},
+ doi = {10.1073/pnas.0308531101},
+ file = {:home/renaud/Documents/articles/NMF/Metagenes and Molecular pattern discovery using matrix factorization Brunet2004.pdf:pdf},
+ issn = {0027-8424},
+ journal = {Proceedings of the National Academy of Sciences of the United States of America},
+ keywords = {Algorithms,Central Nervous System Neoplasms,Central Nervous System Neoplasms: classification,Central Nervous System Neoplasms: genetics,Computational Biology,Data Interpretation,Genetic,Leukemia,Leukemia: classification,Leukemia: genetics,Medulloblastoma,Medulloblastoma: genetics,Models,Neoplasms,Neoplasms: classification,Neoplasms: genetics,Statistical},
+ number = {12},
+ pages = {4164--9},
+ pmid = {15016911},
+ title = {{Metagenes and molecular pattern discovery using matrix factorization.}},
+ url = {http://www.ncbi.nlm.nih.gov/pubmed/15016911},
+ volume = {101},
+ year = {2004},
+}
+
+ at Article{Pascual-Montano2006,
+ author = {Alberto Pascual-Montano and Jose Maria Carazo and K Kochi and D Lehmann and R D Pascual-marqui},
+ file = {:home/renaud/Documents/articles/NMF/Nonsmooth nonnegative matrix factorization (nsNMF)\_Paascual-Montano2006.pdf:pdf},
+ journal = {IEEE Trans. Pattern Anal. Mach. Intell},
+ pages = {403--415},
+ title = {{Nonsmooth nonnegative matrix factorization (nsNMF)}},
+ volume = {28},
+ year = {2006},
+}
+ at Article{Lee1999,
+ abstract = {Is perception of the whole based on perception of its parts? There is psychological and physiological evidence for parts-based representations in the brain, and certain computational theories of object recognition rely on such representations. But little is known about how brains or computers might learn the parts of objects. Here we demonstrate an algorithm for non-negative matrix factorization that is able to learn parts of faces and semantic features of text. This is in [...]
+ author = {D D Lee and H S Seung},
+ doi = {10.1038/44565},
+ file = {:home/renaud/Documents/articles/NMF/Learning the parts of objects by non-negative matrix factorization\_Lee1999.pdf:pdf},
+ issn = {0028-0836},
+ journal = {Nature},
+ keywords = {Algorithms,Face,Humans,Learning,Models,Neurological,Perception,Perception: physiology,Semantics},
+ month = {oct},
+ number = {6755},
+ pages = {788--91},
+ pmid = {10548103},
+ title = {{Learning the parts of objects by non-negative matrix factorization.}},
+ url = {http://www.ncbi.nlm.nih.gov/pubmed/10548103},
+ volume = {401},
+ year = {1999},
+}
+
+ at Article{Paatero1994,
+ abstract = {A new variant ?PMF? of factor analysis is described. It is assumed that X is a matrix of observed data and ? is the known matrix of standard deviations of elements of X. Both X and ? are of dimensions n × m. The method solves the bilinear matrix problem X = GF + E where G is the unknown left hand factor matrix (scores) of dimensions n × p, F is the unknown right hand factor matrix (loadings) of dimensions p × m, and E is the matrix of residuals. The problem is solved in the [...]
+ author = {Pentti Paatero and Unto Tapper},
+ doi = {10.1002/env.3170050203},
+ journal = {Environmetrics},
+ keywords = {algorithm,nmf},
+ mendeley-tags = {algorithm,nmf},
+ number = {2},
+ pages = {111--126},
+ title = {{Positive matrix factorization: A non-negative factor model with optimal utilization of error estimates of data values}},
+ type = {Journal article},
+ url = {http://www3.interscience.wiley.com/cgi-bin/abstract/113468839/ABSTRACT},
+ volume = {5},
+ year = {1994},
+}
+
+ at Article{Hoyer2004,
+ author = {PO Hoyer},
+ file = {:home/renaud/Documents/articles/NMF/Non-negative Matrix Factorization with Sparseness Constraints\_Hoyer2004.pdf:pdf},
+ journal = {The Journal of Machine Learning Research},
+ pages = {1457--1469},
+ title = {{Non-negative matrix factorization with sparseness constraints}},
+ url = {http://portal.acm.org/citation.cfm?id=1044709},
+ volume = {5},
+ year = {2004},
+}
+
+ at Article{Carmona-Saez2006,
+ abstract = {BACKGROUND: The extended use of microarray technologies has enabled the generation and accumulation of gene expression datasets that contain expression levels of thousands of genes across tens or hundreds of different experimental conditions. One of the major challenges in the analysis of such datasets is to discover local structures composed by sets of genes that show coherent expression patterns across subsets of experimental conditions. These patterns may provide clues a [...]
+ author = {Pedro Carmona-Saez and Roberto D Pascual-Marqui and Francisco Tirado and Jose Maria Carazo and Alberto Pascual-Montano},
+ doi = {10.1186/1471-2105-7-78},
+ file = {:home/renaud/Documents/articles/NMF/Biclustering of gene expression data by non-smooth non-negative matrix factorization\_Carmona-Saez2006.pdf:pdf},
+ issn = {1471-2105},
+ journal = {BMC bioinformatics},
+ keywords = {Algorithms,Artificial Intelligence,Automated,Automated: methods,Cluster Analysis,Factor Analysis,Gene Expression Profiling,Gene Expression Profiling: methods,Oligonucleotide Array Sequence Analysis,Oligonucleotide Array Sequence Analysis: methods,Pattern Recognition,Statistical},
+ pages = {78},
+ pmid = {16503973},
+ title = {{Biclustering of gene expression data by Non-smooth Non-negative Matrix Factorization.}},
+ url = {http://www.ncbi.nlm.nih.gov/pubmed/16503973},
+ volume = {7},
+ year = {2006},
+}
+
+ at Article{Wang2006,
+ abstract = {BACKGROUND: Non-negative matrix factorisation (NMF), a machine learning algorithm, has been applied to the analysis of microarray data. A key feature of NMF is the ability to identify patterns that together explain the data as a linear combination of expression signatures. Microarray data generally includes individual estimates of uncertainty for each gene in each condition, however NMF does not exploit this information. Previous work has shown that such uncertainties can b [...]
+ author = {Guoli Wang and Andrew V Kossenkov and Michael F Ochs},
+ doi = {10.1186/1471-2105-7-175},
+ file = {:home/renaud/Documents/articles/NMF/LS-NMF A modified non-negative matrix factorization algorithm utilizing uncertainty estimates\_Wang2006.pdf:pdf},
+ issn = {1471-2105},
+ journal = {BMC bioinformatics},
+ keywords = {Algorithms,Automated,Automated: methods,Databases,Genetic,Messenger,Messenger: genetics,Oligonucleotide Array Sequence Analysis,Oligonucleotide Array Sequence Analysis: methods,Oligonucleotide Array Sequence Analysis: statistic,Pattern Recognition,RNA,Uncertainty},
+ month = {jan},
+ pages = {175},
+ pmid = {16569230},
+ title = {{LS-NMF: a modified non-negative matrix factorization algorithm utilizing uncertainty estimates.}},
+ url = {http://www.ncbi.nlm.nih.gov/pubmed/16569230},
+ volume = {7},
+ year = {2006},
+}
+
+ at Article{VanBenthem2004,
+ author = {Mark H. {Van Benthem} and Michael R. Keenan},
+ doi = {10.1002/cem.889},
+ file = {:home/renaud/Documents/articles/NMF/Fast algorithm for the solution of large-scale non-negativity-constrained least squares problems\_Benthem2005.pdf:pdf},
+ issn = {0886-9383},
+ journal = {Journal of Chemometrics},
+ keywords = {als,mcr,nnls,non-negativity},
+ month = {oct},
+ number = {10},
+ pages = {441--450},
+ title = {{Fast algorithm for the solution of large-scale non-negativity-constrained least squares problems}},
+ url = {http://doi.wiley.com/10.1002/cem.889},
+ volume = {18},
+ year = {2004},
+}
+
+ at Article{Golub1999,
+ abstract = {Although cancer classification has improved over the past 30 years, there has been no general approach for identifying new cancer classes (class discovery) or for assigning tumors to known classes (class prediction). Here, a generic approach to cancer classification based on gene expression monitoring by DNA microarrays is described and applied to human acute leukemias as a test case. A class discovery procedure automatically discovered the distinction between acute myeloid [...]
+ author = {T R Golub and D K Slonim and P Tamayo and C Huard and M Gaasenbeek and J P Mesirov and H Coller and M L Loh and J R Downing and M a Caligiuri and C D Bloomfield and E S Lander},
+ file = {:home/renaud/Documents/articles/microarray/Molecular Classification of Cancer$\backslash$: Class Discovery and Class Prediction by Gene Expression\_Golub1999.pdf:pdf},
+ issn = {0036-8075},
+ journal = {Science (New York, N.Y.)},
+ keywords = {Acute Disease,Antineoplastic Combined Chemotherapy Protocols,Antineoplastic Combined Chemotherapy Protocols: th,Cell Adhesion,Cell Adhesion: genetics,Cell Cycle,Cell Cycle: genetics,Gene Expression Profiling,Homeodomain Proteins,Homeodomain Proteins: genetics,Humans,Leukemia, Myeloid,Leukemia, Myeloid: classification,Leukemia, Myeloid: drug therapy,Leukemia, Myeloid: genetics,Neoplasm Proteins,Neoplasm Proteins: genetics,Neoplasms,Neoplasms: classification,Neoplasms: geneti [...]
+ month = {oct},
+ number = {5439},
+ pages = {531--7},
+ pmid = {10521349},
+ title = {{Molecular classification of cancer: class discovery and class prediction by gene expression monitoring.}},
+ url = {http://www.ncbi.nlm.nih.gov/pubmed/10521349},
+ volume = {286},
+ year = {1999},
+}
+ at Article{Cichocki2008,
+ author = {Andrzej Cichocki and Rafal Zdunek and Shun-ichi Amari},
+ file = {:home/renaud/Documents/articles/NMF/Nonnegative Matrix and Tensor Factorization\_Cichocki2008.pdf:pdf},
+ journal = {IEEE Signal Processing Magazine},
+ pages = {142--145},
+ title = {{Nonnegative matrix and tensor factorization}},
+ volume = {25},
+ year = {2008},
+}
+ at article{Berry2007,
+author = {Berry, M.W. and Browne, M and Langville, Amy N. and Pauca, V.P. and Plemmons, R.J.},
+file = {:home/renaud/Documents/articles/NMF/Algorithms and Applications for Approximate Nonnegative Matrix Factorization\_Berry2006.pdf:pdf},
+journal = {Computational Statistics \& Data Analysis},
+number = {1},
+pages = {155--173},
+publisher = {Elsevier},
+title = {{Algorithms and applications for approximate nonnegative matrix factorization}},
+url = {http://www.sciencedirect.com/science/article/pii/S0167947306004191},
+volume = {52},
+year = {2007}
+}
+ at article{Chu2004,
+author = {Chu, M and Diele, F and Plemmons, R and Ragni, S},
+file = {:home/renaud/Documents/articles/NMF/Optimality, computation, and interpretations of nonnegative matrix factorizations\_Chu2004.pdf:pdf},
+journal = {SIAM Journal on Matrix Analysis},
+keywords = {ellipsoid method,gradient method,kuhn-,least squares,linear model,mass balance,newton method,nonnegative matrix factorization,quadratic programming,reduced quadratic model,tucker condition},
+pages = {4--8030},
+publisher = {Citeseer},
+title = {{Optimality, computation, and interpretation of nonnegative matrix factorizations}},
+url = {http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.61.5758},
+year = {2004}
+}
+ at article{Gao2005,
+abstract = {MOTIVATION: Identifying different cancer classes or subclasses with similar morphological appearances presents a challenging problem and has important implication in cancer diagnosis and treatment. Clustering based on gene-expression data has been shown to be a powerful method in cancer class discovery. Non-negative matrix factorization is one such method and was shown to be advantageous over other clustering techniques, such as hierarchical clustering or self-organizing maps [...]
+author = {Gao, Yuan and Church, George},
+doi = {10.1093/bioinformatics/bti653},
+file = {:home/renaud/Documents/articles/NMF/Improving molecular cancer class discovery through sparse non-negative matrix factorization\_Gao2005.pdf:pdf},
+issn = {1367-4803},
+journal = {Bioinformatics (Oxford, England)},
+keywords = {Algorithms,Biological,Biological: classification,Biological: metabolism,Computer-Assisted,Computer-Assisted: methods,Diagnosis,Factor Analysis,Gene Expression Profiling,Gene Expression Profiling: methods,Humans,Neoplasm Proteins,Neoplasm Proteins: classification,Neoplasm Proteins: metabolism,Neoplasms,Neoplasms: classification,Neoplasms: diagnosis,Neoplasms: metabolism,Oligonucleotide Array Sequence Analysis,Oligonucleotide Array Sequence Analysis: methods,Reproducibility of [...]
+month = nov,
+number = {21},
+pages = {3970--5},
+pmid = {16244221},
+title = {{Improving molecular cancer class discovery through sparse non-negative matrix factorization.}},
+url = {http://www.ncbi.nlm.nih.gov/pubmed/16244221},
+volume = {21},
+year = {2005}
+}
+ at article{Roux2008,
+author = {Roux, Jonathan Le and de Cheveign\'{e}, Alain},
+file = {:home/renaud/Documents/articles/NMF/Adaptive Template Matching with Shift-Invariant Semi-NMF\_Le Roux2008.pdf:pdf},
+journal = {Science And Technology},
+title = {{Adaptive template matching with shift-invariant semi-NMF}},
+url = {http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.143.6846&rep=rep1&type=pdf},
+year = {2008}
+}
+ at article{Ding2010,
+abstract = {We present several new variations on the theme of nonnegative matrix factorization (NMF). Considering factorizations of the form X=FG(T), we focus on algorithms in which G is restricted to containing nonnegative entries, but allowing the data matrix X to have mixed signs, thus extending the applicable range of NMF methods. We also consider algorithms in which the basis vectors of F are constrained to be convex combinations of the data points. This is used for a kernel extensi [...]
+author = {Ding, Chris and Li, Tao and Jordan, Michael I},
+doi = {10.1109/TPAMI.2008.277},
+file = {:home/renaud/Documents/articles/NMF/Convex and Semi-Nonnegative Matrix Factorization\_Ding2009.pdf:pdf},
+issn = {1939-3539},
+journal = {IEEE transactions on pattern analysis and machine intelligence},
+month = jan,
+number = {1},
+pages = {45--55},
+pmid = {19926898},
+title = {{Convex and semi-nonnegative matrix factorizations.}},
+url = {http://www.ncbi.nlm.nih.gov/pubmed/19926898},
+volume = {32},
+year = {2010}
+}
\ No newline at end of file
diff --git a/inst/doc/NMF-unitTests.R b/inst/doc/NMF-unitTests.R
new file mode 100644
index 0000000..b86c1cc
--- /dev/null
+++ b/inst/doc/NMF-unitTests.R
@@ -0,0 +1,9 @@
+
+## ----setup, include=FALSE------------------------------------------------
+pkg <- 'NMF'
+require( pkg, character.only=TRUE )
+prettyVersion <- packageDescription(pkg)$Version
+prettyDate <- format(Sys.Date(), '%B %e, %Y')
+authors <- packageDescription(pkg)$Author
+
+
diff --git a/inst/doc/NMF-unitTests.Rnw b/inst/doc/NMF-unitTests.Rnw
new file mode 100644
index 0000000..70a4d17
--- /dev/null
+++ b/inst/doc/NMF-unitTests.Rnw
@@ -0,0 +1,188 @@
+
+\documentclass[10pt]{article}
+%\VignetteDepends{knitr}
+%\VignetteIndexEntry{NMF-unitTests}
+%\VignetteCompiler{knitr}
+%\VignetteEngine{knitr::knitr}
+\usepackage{vmargin}
+\setmargrb{0.75in}{0.75in}{0.75in}{0.75in}
+
+<<setup, include=FALSE>>=
+pkg <- 'NMF'
+require( pkg, character.only=TRUE )
+prettyVersion <- packageDescription(pkg)$Version
+prettyDate <- format(Sys.Date(), '%B %e, %Y')
+authors <- packageDescription(pkg)$Author
+@
+
+\usepackage[colorlinks]{hyperref}
+\author{\Sexpr{authors}}
+\title{\texttt{\Sexpr{pkg}}: Unit testing results\footnote{Vignette computed on Tue Mar 4 13:14:49 2014}}
+\date{\texttt{\Sexpr{pkg}} version \Sexpr{prettyVersion} as of \Sexpr{prettyDate}}
+\begin{document}
+\maketitle
+
+\section{Details}
+\begin{verbatim}
+
+RUNIT TEST PROTOCOL -- Tue Mar 4 13:14:49 2014
+***********************************************
+Number of test functions: 81
+Number of deactivated test functions: 5
+Number of errors: 0
+Number of failures: 0
+
+
+1 Test Suite :
+package:NMF - 81 test functions, 0 errors, 0 failures
+
+
+
+Details
+***************************
+Test Suite: package:NMF
+Test function regexp: ^test.
+Test file regexp: ^runit.*.[rR]$
+Involved directory:
+/tmp/Rpkglib_26ff65706d7b/NMF/tests
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.aheatmap.R
+test.mfrow: (1 checks) ... OK (0.69 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.algorithms.r
+test.brunet: (16 checks) ... OK (4.22 seconds)
+test.cversions.brunet: (1 checks) ... OK (0.87 seconds)
+test.cversions.lee: (1 checks) ... OK (1.03 seconds)
+test.cversions.lnmf : DEACTIVATED, Algorithm 'lnmf' is not fully working.
+test.cversions.ns: (1 checks) ... OK (1.11 seconds)
+test.cversions.offset: (1 checks) ... OK (2.19 seconds)
+test.frobenius: (16 checks) ... OK (5.38 seconds)
+test.KL: (16 checks) ... OK (4.23 seconds)
+test.lee: (16 checks) ... OK (3.72 seconds)
+test.lnmf : DEACTIVATED, Algorithm 'lnmf' is not fully working.
+test.ns: (16 checks) ... OK (3.78 seconds)
+test.offset: (16 checks) ... OK (3.97 seconds)
+test.port_brunet : DEACTIVATED, Package RcppOctave not available.
+test.snmf: (44 checks) ... OK (9.39 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.bioc.r
+test.access: (26 checks) ... OK (0.02 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.distance.r
+test.KL: (9 checks) ... OK (1.44 seconds)
+test.rss: (4 checks) ... OK (0.06 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.interface.r
+test.compare: (5 checks) ... OK (9.3 seconds)
+test.nmf.callback: (22 checks) ... OK (13.81 seconds)
+test.nmf.custom: (87 checks) ... OK (1.5 seconds)
+test.nmf.default: (8 checks) ... OK (0.23 seconds)
+test.nmf.dots: (11 checks) ... OK (0.84 seconds)
+test.nmf.method: (36 checks) ... OK (10.79 seconds)
+test.nmf.model: (22 checks) ... OK (0.62 seconds)
+test.nmfModel.formula: (12 checks) ... OK (0.92 seconds)
+test.nmf.multirank: (10 checks) ... OK (5.68 seconds)
+test.nmf.options: (18 checks) ... OK (5.44 seconds)
+test.nmf.parameters: (53 checks) ... OK (0.81 seconds)
+test.nmf.seed.argument: (149 checks) ... OK (9.4 seconds)
+test.nmf.seed.equivalent: (11 checks) ... OK (10.82 seconds)
+test.nmf.seed.fault: (4 checks) ... OK (2.9 seconds)
+test.nmf.seed.repro: (8 checks) ... OK (14.43 seconds)
+test.nmf.stop: (6 checks) ... OK (2.17 seconds)
+test.parallel: (6 checks) ... OK (12.28 seconds)
+test.registry: (9 checks) ... OK (0.13 seconds)
+test.seed: (33 checks) ... OK (0.13 seconds)
+test.summary: (3 checks) ... OK (2.86 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.NMFclass.r
+test.basis: (2 checks) ... OK (0.01 seconds)
+test.class.NMFns: (65 checks) ... OK (0.03 seconds)
+test.class.NMFstd: (28 checks) ... OK (0.01 seconds)
+test.coef: (2 checks) ... OK (0 seconds)
+test.connectivity: (3 checks) ... OK (0.01 seconds)
+test.deviance: (9 checks) ... OK (0.02 seconds)
+test.dimensions: (4 checks) ... OK (0 seconds)
+test.dimnames: (173 checks) ... OK (0.08 seconds)
+test.entropy: (5 checks) ... OK (0 seconds)
+test.misc: (9 checks) ... OK (0 seconds)
+test.nmfModel: (363 checks) ... OK (0.11 seconds)
+test.NMF.rnmf: (93 checks) ... OK (1.5 seconds)
+test.predict: (10 checks) ... OK (0.01 seconds)
+test.purity: (5 checks) ... OK (0 seconds)
+test.sparseness: (13 checks) ... OK (0.01 seconds)
+test.subset: (50 checks) ... OK (0.05 seconds)
+test.syntheticNMF: (5 checks) ... OK (1.62 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.NMFfit-class.r
+test.deviance: (0 checks) ... OK (0 seconds)
+test.isNMFfit: (6 checks) ... OK (3.59 seconds)
+test.niter: (4 checks) ... OK (1.1 seconds)
+test.nmf.equal: (304 checks) ... OK (1.87 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.NMFSet.r
+test.fit: (9 checks) ... OK (3.85 seconds)
+test.interface: (6 checks) ... OK (1.86 seconds)
+test.join.multipleAndSingleRunsMethods: (2 checks) ... OK (3.32 seconds)
+test.join.multipleRuns: (2 checks) ... OK (4.6 seconds)
+test.join.singleRuns: (7 checks) ... OK (0.7 seconds)
+test.multipleruns: (2 checks) ... OK (1.7 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.NMFStrategy-class.r
+test.accessors: (26 checks) ... OK (0.06 seconds)
+test.constructor: (16 checks) ... OK (0.06 seconds)
+test.constructorMethod: (3 checks) ... OK (0.04 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.options.r
+test.nmf.getOption: (2 checks) ... OK (0 seconds)
+test.nmf.options: (9 checks) ... OK (0 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.parallel.r
+test.ForeachBackend: (4 checks) ... OK (1.37 seconds)
+test.gVariable: (11 checks) ... OK (10.16 seconds)
+test.nmf: (59 checks) ... OK (41.99 seconds)
+test.setupBackend: (4 checks) ... OK (0.05 seconds)
+test.shared_memory_doMC: (12 checks) ... OK (6.1 seconds)
+test.shared_memory_doMPI : DEACTIVATED, NMF shared memory feature does not currently work with doMPI.
+test.shared_memory_doParallel: (12 checks) ... OK (10.88 seconds)
+test.shared_memory_doSEQ: (11 checks) ... OK (6.46 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.seed.r
+test.nndsvd: (10 checks) ... OK (0.04 seconds)
+test.none: (6 checks) ... OK (0.03 seconds)
+test.random: (26 checks) ... OK (0.13 seconds)
+test.restore : DEACTIVATED, The option 'restore.seed' is deprecated. Related tests are now in test.seed.effect
+test.seed.effect: (15 checks) ... OK (16.37 seconds)
+test.zzz.all: (297 checks) ... OK (16.42 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.utils.r
+test.nmfWrapper: (16 checks) ... OK (0.85 seconds)
+test.rmatrix: (16 checks) ... OK (0.01 seconds)
+
+Total execution time
+***************************
+ user system elapsed
+253.753 31.645 293.297
+
+\end{verbatim}
+
+\section*{Session Information}
+\begin{itemize}\raggedright
+ \item R Under development (unstable) (2014-03-02 r65102), \verb|x86_64-unknown-linux-gnu|
+ \item Locale: \verb|LC_CTYPE=en_US.UTF-8|, \verb|LC_NUMERIC=C|, \verb|LC_TIME=en_US.UTF-8|, \verb|LC_COLLATE=en_US.UTF-8|, \verb|LC_MONETARY=en_US.UTF-8|, \verb|LC_MESSAGES=en_US.UTF-8|, \verb|LC_PAPER=en_US.UTF-8|, \verb|LC_NAME=C|, \verb|LC_ADDRESS=C|, \verb|LC_TELEPHONE=C|, \verb|LC_MEASUREMENT=en_US.UTF-8|, \verb|LC_IDENTIFICATION=C|
+ \item Base packages: base, datasets, graphics, grDevices, methods,
+ parallel, stats, utils
+ \item Other packages: BH~1.51.0-4, bigmemory~4.4.6,
+ bigmemory.sri~0.1.2, Biobase~2.22.0, BiocGenerics~0.8.0,
+ cluster~1.14.4, doMPI~0.2, doParallel~1.0.8, fastICA~1.2-0,
+ foreach~1.4.1, iterators~1.0.6, NMF~0.20.2, pkgmaker~0.17.4,
+ RColorBrewer~1.0-5, Rcpp~0.11.0, registry~0.2, Rmpi~0.6-3,
+ rngtools~1.2.3, RUnit~0.4.26, stringr~0.6.2, synchronicity~1.1.2
+ \item Loaded via a namespace (and not attached): codetools~0.2-8,
+ colorspace~1.2-4, compiler~3.1.0, dichromat~2.0-0, digest~0.6.4,
+ ggplot2~0.9.3.1, grid~3.1.0, gridBase~0.4-7, gtable~0.1.2,
+ labeling~0.2, MASS~7.3-29, munsell~0.4.2, plyr~1.8.1, proto~0.3-10,
+ reshape2~1.2.2, scales~0.2.3, tools~3.1.0, xtable~1.7-1
+\end{itemize}
+
+\end{document}
+
diff --git a/inst/doc/NMF-unitTests.pdf b/inst/doc/NMF-unitTests.pdf
new file mode 100644
index 0000000..aabdcd9
Binary files /dev/null and b/inst/doc/NMF-unitTests.pdf differ
diff --git a/inst/doc/NMF-vignette.R b/inst/doc/NMF-vignette.R
new file mode 100644
index 0000000..44d183e
--- /dev/null
+++ b/inst/doc/NMF-vignette.R
@@ -0,0 +1,503 @@
+
+## ----pkgmaker_preamble, echo=FALSE, results='asis'-----------------------
+pkgmaker::latex_preamble()
+
+
+## ----bibliofile, echo=FALSE, results='asis'------------------------------
+pkgmaker::latex_bibliography('NMF')
+
+
+## ----options, echo=FALSE-------------------------------------------------
+set.seed(123456)
+library(knitr)
+knit_hooks$set(try = pkgmaker::hook_try, backspace = pkgmaker::hook_backspace())
+
+
+## ----load_library, echo=FALSE, include=FALSE-----------------------------
+# Load
+library(NMF)
+# limit number of cores used
+nmf.options(cores = 2)
+
+
+## ----load_library_fake, eval=FALSE---------------------------------------
+## # Install
+## install.packages('NMF')
+## # Load
+## library(NMF)
+
+
+## ----updateObject, eval=FALSE--------------------------------------------
+## # eg., load from some RData file
+## load('object.RData')
+## # update class definition
+## object <- nmfObject(object)
+
+
+## ----features, echo=FALSE------------------------------------------------
+nalgo <- length(nmfAlgorithm())
+nseed <- length(nmfSeed())
+
+
+## ----nmfAlgorithm--------------------------------------------------------
+# list all available algorithms
+nmfAlgorithm()
+# retrieve a specific algorithm: 'brunet'
+nmfAlgorithm('brunet')
+# partial match is also fine
+identical(nmfAlgorithm('br'), nmfAlgorithm('brunet'))
+
+
+## ----nmfSeed-------------------------------------------------------------
+# list all available seeding methods
+nmfSeed()
+# retrieve a specific method: 'nndsvd'
+nmfSeed('nndsvd')
+# partial match is also fine
+identical(nmfSeed('nn'), nmfSeed('nndsvd'))
+
+
+## ----show_Rversions------------------------------------------------------
+nmfAlgorithm(all=TRUE)
+
+# to get all the algorithms that have a secondary R version
+nmfAlgorithm(version='R')
+
+
+## ----perftable_setup, cache=TRUE-----------------------------------------
+# retrieve all the methods that have a secondary R version
+meth <- nmfAlgorithm(version='R')
+meth <- c(names(meth), meth)
+meth
+
+# load the Golub data
+data(esGolub)
+
+# compute NMF for each method
+res <- nmf(esGolub, 3, meth, seed=123456)
+
+# extract only the elapsed time
+t <- sapply(res, runtime)[3,]
+
+
+## ----perftable, echo=FALSE, results='asis'-------------------------------
+# speed-up
+m <- length(res)/2
+su <- cbind( C=t[1:m], R=t[-(1:m)], Speed.up=t[-(1:m)]/t[1:m])
+
+library(xtable)
+xtable(su, caption='Performance speed up achieved by the optimized C++ implementation for some of the NMF algorithms.', label='tab:perf')
+
+
+## ----citations, eval=FALSE-----------------------------------------------
+## # plain text
+## citation('NMF')
+##
+## # or to get the bibtex entries
+## toBibtex(citation('NMF'))
+
+
+## ----esGolub-------------------------------------------------------------
+data(esGolub)
+esGolub
+esGolub <- esGolub[1:200,]
+
+# remove the uneeded variable 'Sample' from the phenotypic data
+esGolub$Sample <- NULL
+
+
+## ----algo_default, cache=TRUE--------------------------------------------
+# default NMF algorithm
+res <- nmf(esGolub, 3)
+
+
+## ----single_show---------------------------------------------------------
+res
+
+
+## ----single_show_model---------------------------------------------------
+fit(res)
+
+
+## ----single_show_estimate------------------------------------------------
+V.hat <- fitted(res)
+dim(V.hat)
+
+
+## ----singlerun_summary---------------------------------------------------
+summary(res)
+
+# More quality measures are computed, if the target matrix is provided:
+summary(res, target=esGolub)
+
+
+## ----singlerun_summary_factor--------------------------------------------
+summary(res, class=esGolub$Cell)
+
+
+## ----get_matrices--------------------------------------------------------
+# get matrix W
+w <- basis(res)
+dim(w)
+
+# get matrix H
+h <- coef(res)
+dim(h)
+
+
+## ----subset--------------------------------------------------------------
+# keep only the first 10 features
+res.subset <- res[1:10,]
+class(res.subset)
+dim(res.subset)
+# keep only the first 10 samples
+dim(res[,1:10])
+# subset both features and samples:
+dim(res[1:20,1:10])
+
+
+## ----single_extract------------------------------------------------------
+# only compute the scores
+s <- featureScore(res)
+summary(s)
+
+# compute the scores and characterize each metagene
+s <- extractFeatures(res)
+str(s)
+
+
+## ----algo_list-----------------------------------------------------------
+nmfAlgorithm()
+
+
+## ----algo_lee, cache=TRUE------------------------------------------------
+# using Lee and Seung's algorithm
+res <- nmf(esGolub, 3, 'lee')
+algorithm(res)
+
+
+## ----algo_ns, cache=TRUE-------------------------------------------------
+# using the Nonsmooth NMF algorithm with parameter theta=0.7
+res <- nmf(esGolub, 3, 'ns', theta=0.7)
+algorithm(res)
+fit(res)
+
+
+## ----algo_pe, cache=TRUE-------------------------------------------------
+# using the PE-NMF algorithm with parameters alpha=0.01, beta=1
+res <- nmf(esGolub, 3, 'pe', alpha=0.01, beta=1)
+res
+
+
+## ----seed_list-----------------------------------------------------------
+nmfSeed()
+
+
+## ----seed, cache=TRUE----------------------------------------------------
+res <- nmf(esGolub, 3, seed='nndsvd')
+res
+
+
+## ----seed_numeric, cache=TRUE--------------------------------------------
+# single run and single numeric seed
+res <- nmf(esGolub, 3, seed=123456)
+showRNG(res)
+
+# multiple runs and single numeric seed
+res <- nmf(esGolub, 3, seed=123456, nrun=2)
+showRNG(res)
+
+# single run with a 6-length seed
+res <- nmf(esGolub, 3, seed=rep(123456, 6))
+showRNG(res)
+
+
+## ----seed_WH-------------------------------------------------------------
+# initialize a "constant" factorization based on the target dimension
+init <- nmfModel(3, esGolub, W=0.5, H=0.3)
+head(basis(init))
+
+# fit using this NMF model as a seed
+res <- nmf(esGolub, 3, seed=init)
+
+
+## ----algo_multirun, cache=TRUE-------------------------------------------
+res.multirun <- nmf(esGolub, 3, nrun=5)
+res.multirun
+
+
+## ----multirun_keep, cache=TRUE-------------------------------------------
+# explicitly setting the option keep.all to TRUE
+res <- nmf(esGolub, 3, nrun=5, .options=list(keep.all=TRUE))
+res
+
+
+## ----multirun_keep_alt, eval=FALSE---------------------------------------
+## # or using letter code 'k' in argument .options
+## nmf(esGolub, 3, nrun=5, .options='k')
+
+
+## ----parallel_multicore_alt, eval=FALSE----------------------------------
+## # the default call will try to run in parallel using all the cores
+## # => will be in parallel if all the requirements are satisfied
+## nmf(esGolub, 3, nrun=5, .opt='v')
+##
+## # request a certain number of cores to use => no error if not possible
+## nmf(esGolub, 3, nrun=5, .opt='vp8')
+##
+## # force parallel computation: use option 'P'
+## nmf(esGolub, 3, nrun=5, .opt='vP')
+##
+## # require an improbable number of cores => error
+## nmf(esGolub, 3, nrun=5, .opt='vP200')
+
+
+## ----mpi, eval=FALSE-----------------------------------------------------
+## # file: mpi.R
+##
+## ## 0. Create and register an MPI cluster
+## library(doMPI)
+## cl <- startMPIcluster()
+## registerDoMPI(cl)
+## library(NMF)
+##
+## # run on all workers using the current parallel backend
+## data(esGolub)
+## res <- nmf(esGolub, 3, 'brunet', nrun=n, .opt='p', .pbackend=NULL)
+##
+## # save result
+## save(res, file='result.RData')
+##
+## ## 4. Shutdown the cluster and quit MPI
+## closeCluster(cl)
+## mpi.quit()
+##
+
+
+## ----force_seq, cache=TRUE, backspace = TRUE-----------------------------
+# parallel execution on 2 cores (if possible)
+res1 <- nmf(esGolub, 3, nrun=5, .opt='vp2', seed=123)
+
+# or use the doParallel with single core
+res2 <- nmf(esGolub, 3, nrun=5, .opt='vp1', seed=123)
+
+# force sequential computation by sapply: use option '-p' or .pbackend=NA
+res3 <- nmf(esGolub, 3, nrun=5, .opt='v-p', seed=123)
+res4 <- nmf(esGolub, 3, nrun=5, .opt='v', .pbackend=NA, seed=123)
+
+# or use the SEQ backend of foreach: .pbackend='seq'
+res5 <- nmf(esGolub, 3, nrun=5, .opt='v', .pbackend='seq', seed=123)
+
+# all results are all identical
+nmf.equal(list(res1, res2, res3, res4, res5))
+
+
+## ----estimate_rank, cache=TRUE-------------------------------------------
+# perform 10 runs for each value of r in range 2:6
+estim.r <- nmf(esGolub, 2:6, nrun=10, seed=123456)
+
+
+## ----estimate_rank_plot, fig.width=10, fig.height=6----------------------
+plot(estim.r)
+
+
+## ----estimate_rank_hm_include, fig.width=14, fig.height=7, fig.keep='last'----
+consensusmap(estim.r, annCol=esGolub, labCol=NA, labRow=NA)
+
+
+## ----estimate_rank_random, cache=TRUE, fig.width=10, fig.height=6, fig.keep='last'----
+# shuffle original data
+V.random <- randomize(esGolub)
+# estimate quality measures from the shuffled data (use default NMF algorithm)
+estim.r.random <- nmf(V.random, 2:6, nrun=10, seed=123456)
+# plot measures on same graph
+plot(estim.r, estim.r.random)
+
+
+## ----multimethod, cache=TRUE---------------------------------------------
+# fit a model for several different methods
+res.multi.method <- nmf(esGolub, 3, list('brunet', 'lee', 'ns'), seed=123456, .options='t')
+
+
+## ----compare-------------------------------------------------------------
+compare(res.multi.method)
+
+# If prior knowledge of classes is available
+compare(res.multi.method, class=esGolub$Cell)
+
+
+## ----errorplot_compute, cache=TRUE---------------------------------------
+# run nmf with .option='t'
+res <- nmf(esGolub, 3, .options='t')
+# or with .options=list(track=TRUE)
+
+
+## ----errorplot, out.width="0.5\\textwidth", fig.show='hold'--------------
+plot(res)
+plot(res.multi.method)
+
+
+## ----heatmap_coef_basis_inc, fig.width=14, fig.height=7, fig.keep='last'----
+layout(cbind(1,2))
+# basis components
+basismap(res, subsetRow=TRUE)
+# mixture coefficients
+coefmap(res)
+
+
+## ----heatmap_consensus_inc, out.width="0.49\\textwidth", crop=TRUE, echo=1:2----
+# The cell type is used to label rows and columns
+consensusmap(res.multirun, annCol=esGolub, tracks=NA)
+plot(1:10)
+f2 <- fig_path("2.pdf")
+
+
+## ----hack_consensus, include=FALSE---------------------------------------
+file.copy('consensus.pdf', f2, overwrite=TRUE)
+
+
+## ----custom_algo_sig-----------------------------------------------------
+my.algorithm <- function(x, seed, param.1, param.2){
+ # do something with starting point
+ # ...
+
+ # return updated starting point
+ return(seed)
+}
+
+
+## ----custom_algo---------------------------------------------------------
+my.algorithm <- function(x, seed, scale.factor=1){
+ # do something with starting point
+ # ...
+ # for example:
+ # 1. compute principal components
+ pca <- prcomp(t(x), retx=TRUE)
+
+ # 2. use the absolute values of the first PCs for the metagenes
+ # Note: the factorization rank is stored in object 'start'
+ factorization.rank <- nbasis(seed)
+ basis(seed) <- abs(pca$rotation[,1:factorization.rank])
+ # use the rotated matrix to get the mixture coefficient
+ # use a scaling factor (just to illustrate the use of extra parameters)
+ coef(seed) <- t(abs(pca$x[,1:factorization.rank])) / scale.factor
+
+ # return updated data
+ return(seed)
+}
+
+
+## ----define_V------------------------------------------------------------
+n <- 50; r <- 3; p <- 20
+V <-syntheticNMF(n, r, p)
+
+
+## ----custom_algo_run-----------------------------------------------------
+nmf(V, 3, my.algorithm, scale.factor=10)
+
+
+## ----custom_algo_run_obj-------------------------------------------------
+# based on Kullback-Leibler divergence
+nmf(V, 3, my.algorithm, scale.factor=10, objective='KL')
+# based on custom distance metric
+nmf(V, 3, my.algorithm, scale.factor=10
+ , objective=function(model, target, ...){
+ ( sum( (target-fitted(model))^4 ) )^{1/4}
+ }
+)
+
+
+## ----custom_algo_run_mixed, error = TRUE, try = TRUE---------------------
+# put some negative input data
+V.neg <- V; V.neg[1,] <- -1;
+
+# this generates an error
+try( nmf(V.neg, 3, my.algorithm, scale.factor=10) )
+
+# this runs my.algorithm without error
+nmf(V.neg, 3, my.algorithm, mixed=TRUE, scale.factor=10)
+
+
+## ----nmf_models----------------------------------------------------------
+nmfModel()
+
+
+## ----custom_algo_NMFoffset-----------------------------------------------
+my.algorithm.offset <- function(x, seed, scale.factor=1){
+ # do something with starting point
+ # ...
+ # for example:
+ # 1. compute principal components
+ pca <- prcomp(t(x), retx=TRUE)
+
+ # retrieve the model being estimated
+ data.model <- fit(seed)
+
+ # 2. use the absolute values of the first PCs for the metagenes
+ # Note: the factorization rank is stored in object 'start'
+ factorization.rank <- nbasis(data.model)
+ basis(data.model) <- abs(pca$rotation[,1:factorization.rank])
+ # use the rotated matrix to get the mixture coefficient
+ # use a scaling factor (just to illustrate the use of extra parameters)
+ coef(data.model) <- t(abs(pca$x[,1:factorization.rank])) / scale.factor
+
+ # 3. Compute the offset as the mean expression
+ data.model at offset <- rowMeans(x)
+
+ # return updated data
+ fit(seed) <- data.model
+ seed
+}
+
+
+## ----custom_algo_NMFOffset_run-------------------------------------------
+# run custom algorithm with NMF model with offset
+nmf(V, 3, my.algorithm.offset, model='NMFOffset', scale.factor=10)
+
+
+## ----custom_seed---------------------------------------------------------
+
+# start: object of class NMF
+# target: the target matrix
+my.seeding.method <- function(model, target){
+
+ # use only the largest columns for W
+ w.cols <- apply(target, 2, function(x) sqrt(sum(x^2)))
+ basis(model) <- target[,order(w.cols)[1:nbasis(model)]]
+
+ # initialize H randomly
+ coef(model) <- matrix(runif(nbasis(model)*ncol(target))
+ , nbasis(model), ncol(target))
+
+ # return updated object
+ return(model)
+}
+
+
+## ----custom_seed_run-----------------------------------------------------
+nmf(V, 3, 'snmf/r', seed=my.seeding.method)
+
+
+## ----options_algo, eval=1:6----------------------------------------------
+#show default algorithm and seeding method
+nmf.options('default.algorithm', 'default.seed')
+
+# retrieve a single option
+nmf.getOption('default.seed')
+
+# All options
+nmf.options()
+
+
+## ----nmf_options, echo=FALSE, results='asis'-----------------------------
+RdSection2latex('nmf.options', package='NMF')
+
+
+## ----print_options-------------------------------------------------------
+nmf.printOptions()
+
+
+## ----sessionInfo, echo=FALSE, results='asis'-----------------------------
+toLatex(sessionInfo())
+
+
diff --git a/inst/doc/NMF-vignette.Rnw b/inst/doc/NMF-vignette.Rnw
new file mode 100644
index 0000000..04498a6
--- /dev/null
+++ b/inst/doc/NMF-vignette.Rnw
@@ -0,0 +1,1305 @@
+%\VignetteIndexEntry{An introduction to the package NMF}
+%\VignetteDepends{utils,NMF,Biobase,bigmemory,xtable,RColorBrewer,knitr,bibtex}
+%\VignetteKeyword{math}
+%\VignetteCompiler{knitr}
+%\VignetteEngine{knitr::knitr}
+
+\documentclass[a4paper]{article}
+
+%\usepackage[OT1]{fontenc}
+\usepackage[colorlinks]{hyperref} % for hyperlinks
+\usepackage{a4wide}
+\usepackage{xspace}
+\usepackage[all]{hypcap} % for linking to the top of the figures or tables
+
+% add preamble from pkgmaker
+<<pkgmaker_preamble, echo=FALSE, results='asis'>>=
+pkgmaker::latex_preamble()
+@
+
+\newcommand{\nmfpack}{\Rpkg{NMF}}
+\newcommand{\RcppOctave}{\textit{RcppOctave}\xspace}
+\newcommand{\matlab}{Matlab$^\circledR$\xspace}
+\newcommand{\MATLAB}{\matlab}
+\newcommand{\gauss}{GAUSS$^\circledR$\xspace}
+
+\newcommand{\graphwidth}{0.9\columnwidth}
+\newcommand{\refeqn}[1]{(\ref{#1})}
+
+% REFERENCES
+\usepackage[citestyle=authoryear-icomp
+, doi=true
+, url=true
+, maxnames=1
+, maxbibnames=15
+, backref=true
+, backend=bibtex]{biblatex}
+\AtEveryCitekey{\clearfield{url}}
+<<bibliofile, echo=FALSE, results='asis'>>=
+pkgmaker::latex_bibliography('NMF')
+@
+\newcommand{\citet}[1]{\textcite{#1}}
+\renewcommand{\cite}[1]{\parencite{#1}}
+\DefineBibliographyStrings{english}{%
+ backrefpage = {see p.}, % for single page number
+ backrefpages = {see pp.} % for multiple page numbers
+}
+%%
+
+% boxed figures
+\usepackage{float}
+\floatstyle{boxed}
+\restylefloat{figure}
+
+\usepackage{array}
+\usepackage{tabularx}
+\usepackage{xcolor}
+
+\usepackage{url}
+\urlstyle{rm}
+
+<<options, echo=FALSE>>=
+set.seed(123456)
+library(knitr)
+knit_hooks$set(try = pkgmaker::hook_try, backspace = pkgmaker::hook_backspace())
+@
+
+% use cleveref for automatic reference label formatting
+\usepackage[capitalise, noabbrev]{cleveref}
+
+% multiple columns
+\usepackage{multicol}
+
+% define commands for notes
+\usepackage{todonotes}
+\newcommand{\nbnote}[1]{\todo[inline, backgroundcolor=blue!20!white]{\scriptsize\textsf{\textbf{NB:} #1}}\ \\}
+
+% default graphic width
+\setkeys{Gin}{width=0.95\textwidth}
+
+\begin{document}
+
+<<load_library, echo=FALSE, include=FALSE>>=
+# Load
+library(NMF)
+# limit number of cores used
+nmf.options(cores = 2)
+@
+
+\title{An introduction to NMF package\\
+\small Version \Sexpr{utils::packageVersion('NMF')}}
+\author{Renaud Gaujoux}
+% \\Address Computational Biology - University of Cape Town, South Africa,
+
+\maketitle
+
+This vignette presents the \citeCRANpkg{NMF}, which implements a framework
+for Nonnegative Matrix Factorization (NMF) algorithms in R \cite{R}.
+The objective is to provide an implementation of some standard algorithms, while
+allowing the user to easily implement new methods that integrate into a
+common framework, which facilitates analysis, result visualisation or
+performance benchmarking.
+If you use the package \nmfpack in your analysis and publications please cite:
+
+\bigskip
+\todo[inline, backgroundcolor=blue!10!white]{\fullcite{Rpackage:NMF}}
+
+Note that the \nmfpack includes several NMF algorithms, published by different
+authors.
+Please make sure to also cite the paper(s) associated with the algorithm(s)
+you used.
+Citations for those can be found in \cref{tab:algo} and in the dedicated help
+pages \code{?gedAlgorithm.<algorithm>}, e.g., \code{?gedAlgorithm.SNMF\_R}.
+
+\bigskip
+\paragraph{Installation:} The latest stable version of the package can be installed from any
+\href{http://cran.r-project.org}{CRAN} repository mirror:
+<<load_library_fake, eval=FALSE>>=
+# Install
+install.packages('NMF')
+# Load
+library(NMF)
+@
+The \nmfpack is a project hosted on \emph{R-forge}\footnote{\url{https://r-forge.r-project.org/projects/nmf}}.
+The latest development version is available from \url{https://r-forge.r-project.org/R/?group_id=649} and may be installed from there\footnote{\code{install.packages("NMF", repos = "http://R-Forge.R-project.org")}}.
+
+\paragraph{Support:} UseRs interested in this package are encouraged to subscribe to the user mailing list (\href{https://lists.r-forge.r-project.org/mailman/listinfo/nmf-user}{nmf-user at lists.r-forge.r-project.org}), which is the preferred channel for enquiries, bug reports, feature requests, suggestions or NMF-related discussions.
+This will enable better tracking as well as fruitful community exchange.
+
+\paragraph{Important:} Note that some of the classes defined in the NMF package have gained new slots.
+If you need to load objects saved in versions prior 0.8.14 please use:
+
+<<updateObject, eval=FALSE>>=
+# eg., load from some RData file
+load('object.RData')
+# update class definition
+object <- nmfObject(object)
+@
+
+\pagebreak
+\tableofcontents
+\pagebreak
+
+\section{Overview}
+
+\subsection{Package features}
+
+This section provides a quick overview of the \nmfpack package's features.
+\Cref{sec:usecase} provides more details, as well as sample code on how to actually perform common tasks in NMF analysis.
+
+<<features, echo=FALSE>>=
+nalgo <- length(nmfAlgorithm())
+nseed <- length(nmfSeed())
+@
+
+The \nmfpack package provides:
+\begin{itemize}
+\item \Sexpr{nalgo} built-in algorithms;
+\item \Sexpr{nseed} built-in seeding methods;
+\item Single interface to perform all algorithms, and combine them with the seeding methods;
+\item Provides a common framework to test, compare and develop NMF methods;
+\item Accept custom algorithms and seeding methods;
+\item Plotting utility functions to visualize and help in the interpretation of the results;
+\item Transparent parallel computations;
+\item Optimized and memory efficient C++ implementations of the standard algorithms;
+\item Optional layer for bioinformatics using BioConductor \cite{Gentleman2004};
+\end{itemize}
+
+\subsection{Nonnegative Matrix Factorization}
+
+This section gives a formal definition for Nonnegative Matrix Factorization problems, and defines the notations used throughout the vignette.
+
+Let $X$ be a $n \times p$ non-negative matrix, (i.e with $x_{ij} \geq 0$,
+denoted $X \geq 0$), and $r > 0$ an integer. Non-negative Matrix Factorization (NMF) consists in finding an approximation
+\begin{equation}
+X \approx W H\ , \label{NMFstd}
+\end{equation}
+where $W, H$ are $n\times r$ and $r \times p$ non-negative matrices, respectively.
+In practice, the factorization rank $r$ is often chosen such that $r \ll \min(n, p)$.
+The objective behind this choice is to summarize and split the information contained in $X$ into $r$ factors: the columns of $W$.
+
+Depending on the application field, these factors are given different names: basis images, metagenes, source signals. In this vignette we equivalently and alternatively use the terms
+\emph{basis matrix} or \emph{metagenes} to refer to matrix $W$, and \emph{mixture coefficient matrix} and \emph{metagene expression profiles} to refer to matrix $H$.
+
+The main approach to NMF is to estimate matrices $W$ and $H$ as a local minimum:
+\begin{equation}
+\min_{W, H \geq 0}\ \underbrace{[D(X, WH) + R(W, H)]}_{=F(W,H)} \label{nmf_min}
+\end{equation}
+where
+
+\begin{itemize}
+\item $D$ is a loss function that measures the quality of the approximation.
+Common loss functions are based on either the Frobenius distance
+$$D: A,B\mapsto \frac{Tr(AB^t)}{2} = \frac{1}{2} \sum_{ij} (a_{ij} - b_{ij})^2,$$
+or the Kullback-Leibler divergence.
+$$D: A,B\mapsto KL(A||B) = \sum_{i,j} a_{ij} \log \frac{a_{ij}}{b_{ij}} - a_{ij} + b_{ij}.$$
+\item $R$ is an optional regularization function, defined to enforce desirable
+properties on matrices $W$ and $H$, such as smoothness or sparsity
+\cite{Cichocki2008}.
+\end{itemize}
+
+\subsection{Algorithms}
+NMF algorithms generally solve problem \refeqn{nmf_min} iteratively, by building a sequence of matrices $(W_k,H_k)$ that reduces at each step the value of the objective function $F$.
+Beside some variations in the specification of $F$, they also differ in the optimization techniques that are used to compute the updates for $(W_k,H_k)$.
+
+For reviews on NMF algorithms see \cite{Berry2007, Chu2004} and references therein.
+
+The \nmfpack package implements a number of published algorithms, and provides a general framework to implement other ones.
+\Cref{tab:algo} gives a short description of each one of the built-in algorithms:
+
+The built-in algorithms are listed or retrieved with function \code{nmfAlgorithm}.
+A given algorithm is retrieved by its name (a \code{character} key), that is partially matched against the list of available algorithms:
+
+<<nmfAlgorithm>>=
+# list all available algorithms
+nmfAlgorithm()
+# retrieve a specific algorithm: 'brunet'
+nmfAlgorithm('brunet')
+# partial match is also fine
+identical(nmfAlgorithm('br'), nmfAlgorithm('brunet'))
+@
+
+\begin{table}[h!t]
+\begin{tabularx}{\textwidth}{lX}
+\hline
+Key & Description\\
+\hline
+\code{brunet} & Standard NMF. Based on Kullback-Leibler divergence, it uses
+simple multiplicative updates from \cite{Lee2001}, enhanced to avoid numerical underflow.
+
+\begin{eqnarray}
+H_{kj} & \leftarrow & H_{kj} \frac{\left( \sum_l \frac{W_{lk} V_{lj}}{(WH)_{lj}} \right)}{ \sum_l W_{lk} }\\
+W_{ik} & \leftarrow & W_{ik} \frac{ \sum_l [H_{kl} A_{il} / (WH)_{il} ] }{\sum_l H_{kl} }
+\end{eqnarray}
+
+\textbf{Reference:} \cite{Brunet2004}\\
+\hline
+%
+\code{lee} & Standard NMF. Based on euclidean distance, it uses simple multiplicative updates
+
+\begin{eqnarray}
+H_{kj} & \leftarrow & H_{kj} \frac{(W^T V)_{kj}}{(W^T W H)_{kj}}\\
+W_{ik} & \leftarrow & W_{ik} \frac{(V H^T)_{ik}}{(W H H^T)_{ik}}
+\end{eqnarray}
+
+
+\textbf{Reference:} \cite{Lee2001}\\
+\hline
+%
+%\code{lnmf} & Local Nonnegative Matrix Factorization. Based on a
+%regularized Kullback-Leibler divergence, it uses a modified version of
+%Lee and Seung's multiplicative updates.
+%
+%\textbf{Reference:} \cite{Li2001}\\
+%
+\code{nsNMF} & Non-smooth NMF. Uses a modified version of Lee and Seung's multiplicative updates for Kullback-Leibler divergence to fit a extension of the standard NMF model.
+It is meant to give sparser results.
+
+\textbf{Reference:} \cite{Pascual-Montano2006}\\
+\hline
+%
+\code{offset} & Uses a modified version of Lee and Seung's multiplicative updates for euclidean distance, to fit a NMF model that includes an intercept.
+
+\textbf{Reference:} \cite{Badea2008}\\
+\hline
+%
+\code{pe-nmf} & Pattern-Expression NMF. Uses multiplicative updates to minimize an objective function based on the Euclidean distance and regularized for effective expression of patterns with basis vectors.
+
+\textbf{Reference:} \cite{Zhang2008}\\
+\hline
+%
+\code{snmf/r}, \code{snmf/l} & Alternating Least Square (ALS) approach.
+It is meant to be very fast compared to other approaches.
+
+\textbf{Reference:} \cite{KimH2007}\\
+\hline
+\end{tabularx}
+\caption{Description of the implemented NMF algorithms. The first column gives the key to use in
+the call to the \texttt{nmf} function.\label{tab:algo}}
+\end{table}
+
+\subsection{Initialization: seeding methods}
+NMF algorithms need to be initialized with a seed (i.e. a value for $W_0$ and/or
+$H_0$\footnote{Some algorithms only need one matrix factor (either $W$ or $H$) to be initialized. See for example the SNMF/R(L) algorithm of Kim and Park \cite{KimH2007}.}), from which to start the iteration process.
+Because there is no global minimization algorithm, and due to the problem's high dimensionality, the choice of the initialization is in fact very important to ensure meaningful results.
+
+The more common seeding method is to use a random starting point, where the entries of $W$ and/or $H$ are drawn from a uniform distribution, usually within the same range as the target matrix's entries.
+This method is very simple to implement.
+However, a drawback is that to achieve stability one has to perform multiple runs, each with a different starting point.
+This significantly increases the computation time needed to obtain the desired factorization.
+
+To tackle this problem, some methods have been proposed so as to compute a reasonable starting point from the target matrix itself.
+Their objective is to produce deterministic algorithms that need to run only once, still giving meaningful results.
+
+For a review on some existing NMF initializations see \cite{Albright2006} and references therein.
+
+The \nmfpack\ package implements a number of already published seeding methods, and provides a general framework to implement other ones.
+\Cref{tab:seed} gives a short description of each one of the built-in seeding methods:
+
+The built-in seeding methods are listed or retrieved with function \code{nmfSeed}.
+A given seeding method is retrieved by its name (a \code{character} key) that is partially matched against the list of available seeding methods:
+
+<<nmfSeed>>=
+# list all available seeding methods
+nmfSeed()
+# retrieve a specific method: 'nndsvd'
+nmfSeed('nndsvd')
+# partial match is also fine
+identical(nmfSeed('nn'), nmfSeed('nndsvd'))
+@
+
+\begin{table}[h!t]
+\begin{tabularx}{\textwidth}{lX}
+\hline
+Key & Description\\
+\hline
+\code{ica} & Uses the result of an Independent Component Analysis (ICA) (from
+the \citeCRANpkg{fastICA}).
+Only the positive part of the result are used to initialize the factors.\\
+\hline
+%
+\code{nnsvd} & Nonnegative Double Singular Value Decomposition.
+The basic algorithm contains no randomization and is based on two SVD processes, one approximating the data matrix, the other approximating positive sections of the resulting partial SVD factors utilizing an algebraic property of unit rank matrices.
+It is well suited to initialize NMF algorithms with sparse factors. Simple practical variants of the algorithm allows to generate dense factors.
+
+\textbf{Reference:} \cite{Boutsidis2008}\\
+\hline
+%
+\code{none} & Fix seed.
+This method allows the user to manually provide initial values for both matrix factors.\\
+\hline
+%
+\code{random} & The entries of each factors are drawn from a uniform distribution over $[0, max(V)]$, where $V$ is the target matrix.\\
+\hline
+\end{tabularx}
+\caption{Description of the implemented seeding methods to initialize NMF algorithms.
+The first column gives the key to use in the call to the \texttt{nmf} function.\label{tab:seed}}
+\end{table}
+
+\subsection{How to run NMF algorithms}
+
+Method \code{nmf} provides a single interface to run NMF algorithms.
+It can directly perform NMF on object of class \code{matrix} or
+\code{data.frame} and \code{ExpressionSet} -- if the \citeBioCpkg{Biobase} is
+installed.
+The interface has four main parameters:
+
+\medskip
+\fbox{\code{nmf(x, rank, method, seed, ...)}}
+
+\begin{description}
+\item[\code{x}] is the target \code{matrix}, \code{data.frame} or \code{ExpressionSet}
+\footnote{\code{ExpressionSet} is the base class for handling microarray data in
+BioConductor, and is defined in the \pkgname{Biobase} package.}
+\item[\code{rank}] is the factorization rank, i.e. the number of columns in matrix $W$.
+\item[\code{method}] is the algorithm used to estimate the factorization.
+The default algorithm is given by the package specific option \code{'default.algorithm'}, which defaults to \code{'brunet'} on installation \cite{Brunet2004}.
+\item[\code{seed}] is the seeding method used to compute the starting point.
+The default method is given by the package specific option \code{'default.seed'}, which defaults to \code{'random'} on initialization (see method \code{?rnmf} for details on its implementation).
+\end{description}
+
+See also \code{?nmf} for details on the interface and extra parameters.
+
+
+\subsection{Performances}
+
+Since version 0.4, some built-in algorithms are optimized in C++, which results in a significant speed-up and a more efficient memory management, especially on large scale data.
+
+The older R versions of the concerned algorithms are still available, and accessible by adding the prefix \code{'.R\#'} to the algorithms' access keys (e.g. the key \code{'.R\#offset'} corresponds to the R implementation of NMF with offset \cite{Badea2008}).
+Moreover they do not show up in the listing returned by the \code{nmfAlgorithm} function, unless argument \code{all=TRUE}:
+
+<<show_Rversions>>=
+nmfAlgorithm(all=TRUE)
+
+# to get all the algorithms that have a secondary R version
+nmfAlgorithm(version='R')
+@
+
+\Cref{tab:perf} shows the speed-up achieved by the algorithms that benefit from the optimized code.
+All algorithms were run once with a factorization rank equal to 3, on the Golub data set which contains a $5000\times 38$ gene expression matrix.
+The same numeric random seed (\code{seed=123456}) was used for all factorizations.
+The columns \emph{C} and \emph{R} show the elapsed time (in seconds) achieved by the C++ version and R version respectively.
+The column \emph{Speed.up} contains the ratio $R/C$.
+
+<<perftable_setup, cache=TRUE>>=
+# retrieve all the methods that have a secondary R version
+meth <- nmfAlgorithm(version='R')
+meth <- c(names(meth), meth)
+meth
+
+# load the Golub data
+data(esGolub)
+
+# compute NMF for each method
+res <- nmf(esGolub, 3, meth, seed=123456)
+
+# extract only the elapsed time
+t <- sapply(res, runtime)[3,]
+@
+
+<<perftable, echo=FALSE, results='asis'>>=
+# speed-up
+m <- length(res)/2
+su <- cbind( C=t[1:m], R=t[-(1:m)], Speed.up=t[-(1:m)]/t[1:m])
+
+library(xtable)
+xtable(su, caption='Performance speed up achieved by the optimized C++ implementation for some of the NMF algorithms.', label='tab:perf')
+@
+
+
+\subsection{How to cite the package NMF}
+
+To view all the package's bibtex citations, including all vignette(s) and manual(s):
+
+<<citations, eval=FALSE>>=
+# plain text
+citation('NMF')
+
+# or to get the bibtex entries
+toBibtex(citation('NMF'))
+@
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\section{Use case: Golub dataset}\label{sec:usecase}
+We illustrate the functionalities and the usage of the \nmfpack package on the -- now standard -- Golub dataset on leukemia.
+It was used in several papers on NMF \cite{Brunet2004, Gao2005} and is included in the \nmfpack package's data, wrapped into an \code{ExpressionSet} object.
+ For performance reason we use here only the first 200 genes.
+ Therefore the results shown in the following are not meant to be biologically meaningful, but only illustrative:
+
+<<esGolub>>=
+data(esGolub)
+esGolub
+esGolub <- esGolub[1:200,]
+
+# remove the uneeded variable 'Sample' from the phenotypic data
+esGolub$Sample <- NULL
+@
+% TODO: pass to 50 genes for dev
+
+\paragraph{Note:} To run this example, the \code{Biobase} package from BioConductor is required.
+
+\subsection{Single run}\label{sec:single_run}
+
+\subsubsection{Performing a single run}
+To run the default NMF algorithm on data \code{esGolub} with a factorization rank of 3, we call:
+
+<<algo_default, cache=TRUE>>=
+# default NMF algorithm
+res <- nmf(esGolub, 3)
+@
+
+Here we did not specify either the algorithm or the seeding method, so that the computation is done using the default algorithm and is seeded by the
+default seeding methods.
+These defaults are set in the package specific options \code{'default.algorithm'}
+and \code{'default.seed'} respectively.
+
+See also \cref{sec:algo,sec:seed} for how to explicitly specify the algorithm and/or the seeding method.
+
+\subsubsection{Handling the result}
+
+The result of a single NMF run is an object of class \code{NMFfit}, that holds both the fitted NMF model and data about the run:
+
+<<single_show>>=
+res
+@
+
+The fitted model can be retrieved via method \code{fit}, which returns an object of class \code{NMF}:
+
+<<single_show_model>>=
+fit(res)
+@
+
+The estimated target matrix can be retrieved via the generic method \code{fitted}, which returns a -- generally big -- \code{matrix}:
+
+<<single_show_estimate>>=
+V.hat <- fitted(res)
+dim(V.hat)
+@
+
+Quality and performance measures about the factorization are computed by method \code{summary}:
+
+<<singlerun_summary>>=
+summary(res)
+
+# More quality measures are computed, if the target matrix is provided:
+summary(res, target=esGolub)
+@
+
+If there is some prior knowledge of classes present in the data, some other measures about the unsupervised clustering's performance are computed (purity, entropy, \ldots).
+Here we use the phenotypic variable \code{Cell} found in the Golub dataset, that gives the samples' cell-types (it is a factor with levels: T-cell, B-cell or \code{NA}):
+
+<<singlerun_summary_factor>>=
+summary(res, class=esGolub$Cell)
+@
+
+The basis matrix (i.e. matrix $W$ or the metagenes) and the mixture coefficient matrix (i.e matrix $H$ or the metagene expression profiles) are retrieved using methods \code{basis} and \code{coef} respectively:
+
+<<get_matrices>>=
+# get matrix W
+w <- basis(res)
+dim(w)
+
+# get matrix H
+h <- coef(res)
+dim(h)
+@
+
+
+If one wants to keep only part of the factorization, one can directly subset on the \code{NMF} object on features and samples (separately or simultaneously).
+The result is a \code{NMF} object composed of the selected rows and/or columns:
+<<subset>>=
+# keep only the first 10 features
+res.subset <- res[1:10,]
+class(res.subset)
+dim(res.subset)
+# keep only the first 10 samples
+dim(res[,1:10])
+# subset both features and samples:
+dim(res[1:20,1:10])
+@
+
+\subsubsection{Extracting metagene-specific features}
+
+In general NMF matrix factors are sparse, so that the metagenes can usually be characterized by a relatively small set of genes. Those are determined based on
+their relative contribution to each metagene.
+
+Kim and Park \cite{KimH2007} defined a procedure to extract the relevant genes for each metagene, based on a gene scoring schema.
+
+The NMF package implements this procedure in methods \code{featureScore} and \code{extractFeature}:
+
+<<single_extract>>=
+# only compute the scores
+s <- featureScore(res)
+summary(s)
+
+# compute the scores and characterize each metagene
+s <- extractFeatures(res)
+str(s)
+@
+
+\subsection{Specifying the algorithm}\label{sec:algo}
+
+\subsubsection{Built-in algorithms}
+The \nmfpack package provides a number of built-in algorithms, that are listed or retrieved by function \code{nmfAlgorithm}.
+Each algorithm is identified by a unique name.
+The following algorithms are currently implemented (cf. \cref{tab:algo} for more details):
+
+<<algo_list>>=
+nmfAlgorithm()
+@
+
+%\begin{tech}
+%Internally, all algorithms are stored in objects that inherit from class
+%\code{NMFStrategy}. This class defines the minimum interface
+%\end{tech}
+
+The algorithm used to compute the NMF is specified in the third argument (\code{method}).
+For example, to use the NMF algorithm from Lee and Seung \cite{Lee2001} based on
+the Frobenius euclidean norm, one make the following call:
+<<algo_lee, cache=TRUE>>=
+# using Lee and Seung's algorithm
+res <- nmf(esGolub, 3, 'lee')
+algorithm(res)
+@
+
+To use the Nonsmooth NMF algorithm from \cite{Pascual-Montano2006}:
+<<algo_ns, cache=TRUE>>=
+# using the Nonsmooth NMF algorithm with parameter theta=0.7
+res <- nmf(esGolub, 3, 'ns', theta=0.7)
+algorithm(res)
+fit(res)
+@
+
+Or to use the PE-NMF algorithm from \cite{Zhang2008}:
+<<algo_pe, cache=TRUE>>=
+# using the PE-NMF algorithm with parameters alpha=0.01, beta=1
+res <- nmf(esGolub, 3, 'pe', alpha=0.01, beta=1)
+res
+@
+
+%\begin{tech}
+%Although the last two calls looks similar these are handled
+%
+%In the case of the nsNMF algorithm, the fitted model is an object of class
+%\code{NMFns} that extends the standard NMF model \code{NMFstd}, as it introduces
+%a smoothing matrix $S$, parametrised by a real number $\theta \in [0,1]$, such
+%that the fitted model is:
+%$$
+%V \approx W S(\theta) H.
+%$$
+%
+%Hence the call to function \code{nmf}, parameter $\theta$ is used to
+%
+%\end{tech}
+
+
+\subsubsection{Custom algorithms}
+The \nmfpack package provides the user the possibility to define his own algorithms, and benefit from all the functionalities available in the NMF framework.
+There are only few contraints on the way the custom algorithm must be defined.
+See the details in \cref{sec:algo_custom}.
+
+\subsection{Specifying the seeding method}\label{sec:seed}
+The seeding method used to compute the starting point for the chosen algorithm can be set via argument \code{seed}.
+Note that if the seeding method is deterministic there is no need to perform multiple run anymore.
+
+\subsubsection{Built-in seeding methods}
+Similarly to the algorithms, the \code{nmfSeed} function can be used to list or retrieve the built-in seeding methods.
+The following seeding methods are currently implemented:
+
+<<seed_list>>=
+nmfSeed()
+@
+
+To use a specific method to seed the computation of a factorization, one simply passes its name to \code{nmf}:
+
+<<seed, cache=TRUE>>=
+res <- nmf(esGolub, 3, seed='nndsvd')
+res
+@
+
+\subsubsection{Numerical seed}\label{sec:numseed}
+Another possibility, useful when comparing methods or reproducing results, is to set the random number generator (RNG) by passing a numerical value in argument \code{seed}.
+This value is used to set the state of the RNG, and the initialization is performed by the built-in seeding method \code{'random'}.
+When the function \code{nmf} exits, the value of the random seed (\code{.Random.seed}) is restored to its original state -- as before the call.
+
+In the case of a single run (i.e. with \code{nrun=1}), the default is to use the current RNG, set with the R core function \code{set.seed}.
+In the case of multiple runs, the computations use RNGstream, as provided by the core RNG ``L'Ecuyer-CMRG" \cite{Lecuyer2002}, which generates multiple independent random streams (one per run).
+This ensures the complete reproducibility of any given set of runs, even when their computation is performed in parallel.
+Since RNGstream requires a 6-length numeric seed, a random one is generated if only a single numeric value is passed to \code{seed}.
+Moreover, single runs can also use RNGstream by passing a 6-length seed.
+
+<<seed_numeric, cache=TRUE>>=
+# single run and single numeric seed
+res <- nmf(esGolub, 3, seed=123456)
+showRNG(res)
+
+# multiple runs and single numeric seed
+res <- nmf(esGolub, 3, seed=123456, nrun=2)
+showRNG(res)
+
+# single run with a 6-length seed
+res <- nmf(esGolub, 3, seed=rep(123456, 6))
+showRNG(res)
+@
+\nbnote{To show the RNG changes happening during the computation use \texttt{.options='v4'} to turn on verbosity at level 4.\\
+In versions prior 0.6, one could specify option \texttt{restore.seed=FALSE} or \texttt{'-r'}, this option is now deprecated.}
+
+\subsubsection{Fixed factorization}
+Yet another option is to completely specify the initial factorization, by passing values for matrices $W$ and $H$:
+<<seed_WH>>=
+# initialize a "constant" factorization based on the target dimension
+init <- nmfModel(3, esGolub, W=0.5, H=0.3)
+head(basis(init))
+
+# fit using this NMF model as a seed
+res <- nmf(esGolub, 3, seed=init)
+@
+
+
+\subsubsection{Custom function}
+The \nmfpack package provides the user the possibility to define his own seeding method, and benefit from all the functionalities available in the NMF framework.
+There are only few contraints on the way the custom seeding method must be defined.
+See the details in \cref{sec:seed_custom}.
+
+\subsection{Multiple runs}
+
+When the seeding method is stochastic, multiple runs are usually required to achieve stability or a resonable result.
+This can be done by setting argument \code{nrun} to the desired value.
+For performance reason we use \code{nrun=5} here, but a typical choice would lies between 100 and 200:
+
+<<algo_multirun, cache=TRUE>>=
+res.multirun <- nmf(esGolub, 3, nrun=5)
+res.multirun
+@
+
+By default, the returned object only contains the best fit over all the runs.
+That is the factorization that achieved the lowest approximation error (i.e. the lowest objective value).
+Even during the computation, only the current best factorization is kept in memory.
+This limits the memory requirement for performing multiple runs, which in turn allows to perform more runs.
+
+The object \code{res.multirun} is of class \code{NMFfitX1} that extends class \code{NMFfit}, the class returned by single NMF runs.
+It can therefore be handled as the result of a single run and benefit from all the methods defined for single run results.
+
+\medskip
+If one is interested in keeping the results from all the runs, one can set the option \code{keep.all=TRUE}:
+
+<<multirun_keep, cache=TRUE>>=
+# explicitly setting the option keep.all to TRUE
+res <- nmf(esGolub, 3, nrun=5, .options=list(keep.all=TRUE))
+res
+@
+
+<<multirun_keep_alt, eval=FALSE>>=
+# or using letter code 'k' in argument .options
+nmf(esGolub, 3, nrun=5, .options='k')
+@
+
+In this case, the result is an object of class \code{NMFfitXn} that also inherits from class \code{list}.
+
+Note that keeping all the results may be memory consuming.
+For example, a 3-rank \code{NMF} fit\footnote{i.e. the result of a single NMF run with rank equal 3.} for the Golub gene expression matrix ($5000 \times 38$) takes about \Sexpr{round(object.size(fit(res.multirun))/1000)}Kb\footnote{This size might change depending on the architecture (32 or 64 bits)}.
+
+\subsection{Parallel computations}\label{multicore}
+
+To speed-up the analysis whenever possible, the \nmfpack package implements transparent parallel computations when run on multi-core machines.
+It uses the \code{foreach} framework developed by REvolution Computing
+\citeCRANpkg{foreach}, together with the related \code{doParallel} parallel
+backend from the \citeCRANpkg{doParallel} -- based on the
+\pkgname{parallel} package -- to make use of all the CPUs available on the
+system, with each core simultaneously performing part of the runs.
+
+\subsubsection{Memory considerations}
+Running multicore computations increases the required memory linearly
+with the number of cores used.
+When only the best run is of interest, memory usage is
+optimized to only keep the current best factorization.
+On non-Windows machine, further speed improvement are achieved by using shared
+memory and mutex objects from the \citeCRANpkg{bigmemory} and the
+\citeCRANpkg{synchronicity}.
+
+\subsubsection{Parallel foreach backends}
+The default parallel backend used by the \code{nmf} function is defined by the
+package specific option \code{'pbackend'}, which defaults to \code{'par'} -- for
+\code{doParallel}.
+The backend can also be set on runtime via argument \code{.pbackend}.
+
+\medskip
+\paragraph{IMPORTANT NOTE:}
+The parallel computation is based on the \pkgname{doParallel} and
+\pkgname{parallel} packages, and the same care should be taken as stated in the
+vignette of the \citeCRANpkg{doMC}:
+\begin{quote}
+\emph{... it usually isn't safe to run doMC and multicore from a GUI environment.
+In particular, it is not safe to use doMC from R.app on Mac OS X.
+Instead, you should use doMC from a terminal session, starting R from the command line.}
+\end{quote}
+Therefore, the \code{nmf} function does not allow to run multicore computation from the
+MacOS X GUI.
+
+From version 0.8, other parallel backends are supported, and may be specified
+via argument \code{.pbackend}:
+
+\begin{description}
+ \item[\code{.pbackend='mpi'}] uses the parallel backend \citeCRANpkg{doParallel} and \citeCRANpkg{doMPI}
+ \item[\code{.pbackend=NULL}]{}
+\end{description}
+
+It is possible to specify that the currently registered backend should be
+used, by setting argument \code{.pbackend=NULL}.
+This allow to perform parallel computations with ``permanent'' backends that are
+configured externally of the \code{nmf} call.
+
+\subsubsection{Runtime options}
+There are two other runtime options, \code{parallel} and
+\code{parallel.required}, that can be passed via argument \code{.options}, to
+control the behaviour of the parallel computation (see below).
+
+\medskip
+A call for multiple runs will be computed in parallel if one of the following condition is satisfied:
+
+\begin{itemize}
+\item call with option \code{'P'} or \code{parallel.required} set to TRUE (note the upper case in \code{'P'}).
+In this case, if for any reason the computation cannot be run in parallel (packages requirements, OS, ...), then an error is thrown. Use this mode to force the parallel execution.
+\item call with option \code{'p'} or \code{parallel} set to TRUE. In this case if something prevents a parallel computation, the factorizations will be done
+sequentially.
+\item a valid parallel backend is specified in argument \code{.pbackend}.
+For the moment it can either be the string \code{'mc'} or a single \code{numeric} value specifying the number of core to use. Unless option \code{'P'} is specified, it will run using option \code{'p'} (i.e. try-parallel mode).
+\end{itemize}
+
+\nbnote{The number of processors to use can also be specified in the runtime options as e.g. \texttt{.options='p4'} or \texttt{.options='P4'} -- to ask or request 4 CPUs.}
+
+\paragraph{Examples}\ \\
+The following exmaples are run with \code{.options='v'} which turn on verbosity at level 1, that will show which parallell setting is used by each computation.
+Although we do not show the output here, the user is recommended to run these commands on his machine to see the internal differences of each call.
+
+<<parallel_multicore_alt, eval=FALSE>>=
+# the default call will try to run in parallel using all the cores
+# => will be in parallel if all the requirements are satisfied
+nmf(esGolub, 3, nrun=5, .opt='v')
+
+# request a certain number of cores to use => no error if not possible
+nmf(esGolub, 3, nrun=5, .opt='vp8')
+
+# force parallel computation: use option 'P'
+nmf(esGolub, 3, nrun=5, .opt='vP')
+
+# require an improbable number of cores => error
+nmf(esGolub, 3, nrun=5, .opt='vP200')
+@
+
+\subsubsection{High Performance Computing on a cluster}
+
+To achieve further speed-up, the computation can be run on an HPC cluster.
+In our tests we used the \citeCRANpkg{doMPI} to perform 100
+factorizations using hybrid parallel computation on 4 quadri-core machines -- making use of all
+the cores computation on each machine.
+
+<<mpi, eval=FALSE>>=
+# file: mpi.R
+
+## 0. Create and register an MPI cluster
+library(doMPI)
+cl <- startMPIcluster()
+registerDoMPI(cl)
+library(NMF)
+
+# run on all workers using the current parallel backend
+data(esGolub)
+res <- nmf(esGolub, 3, 'brunet', nrun=n, .opt='p', .pbackend=NULL)
+
+# save result
+save(res, file='result.RData')
+
+## 4. Shutdown the cluster and quit MPI
+closeCluster(cl)
+mpi.quit()
+
+@
+
+Passing the following shell script to \emph{qsub} should launch the execution on a Sun Grid Engine HPC cluster, with OpenMPI.
+Some adaptation might be necessary for other queueing systems/installations.
+
+\begin{shaded}
+\small
+\begin{verbatim}
+#!/bin/bash
+#$ -cwd
+#$ -q opteron.q
+#$ -pe mpich_4cpu 16
+echo "Got $NSLOTS slots. $TMP/machines"
+
+orterun -v -n $NSLOTS -hostfile $TMP/machines R --slave -f mpi.R
+\end{verbatim}
+\end{shaded}
+
+\subsubsection{Forcing sequential execution}
+When running on a single core machine, \nmfpack package has no other option than performing the multiple runs sequentially, one after another.
+This is done via the \code{sapply} function.
+
+On multi-core machine, one usually wants to perform the runs in parallel, as it speeds up the computation (cf. \cref{multicore}).
+However in some situation (e.g. while debugging), it might be useful to force the sequential execution of the runs.
+This can be done via the option \code{'p1'} to run on a single core , or with
+\code{.pbackend='seq'} to use the foreach backend \code{doSEQ} or to \code{NA} to use a standard \code{sapply} call:
+
+<<force_seq, cache=TRUE, backspace = TRUE>>=
+# parallel execution on 2 cores (if possible)
+res1 <- nmf(esGolub, 3, nrun=5, .opt='vp2', seed=123)
+
+# or use the doParallel with single core
+res2 <- nmf(esGolub, 3, nrun=5, .opt='vp1', seed=123)
+
+# force sequential computation by sapply: use option '-p' or .pbackend=NA
+res3 <- nmf(esGolub, 3, nrun=5, .opt='v-p', seed=123)
+res4 <- nmf(esGolub, 3, nrun=5, .opt='v', .pbackend=NA, seed=123)
+
+# or use the SEQ backend of foreach: .pbackend='seq'
+res5 <- nmf(esGolub, 3, nrun=5, .opt='v', .pbackend='seq', seed=123)
+
+# all results are all identical
+nmf.equal(list(res1, res2, res3, res4, res5))
+@
+
+
+\subsection{Estimating the factorization rank}
+A critical parameter in NMF is the factorization rank $r$.
+It defines the number of metagenes used to approximate the target matrix.
+Given a NMF method and the target matrix, a common way of deciding on $r$ is to try different values, compute some quality measure of the results, and choose the best value according to this quality criteria.
+
+Several approaches have then been proposed to choose the optimal value of $r$.
+For example, \cite{Brunet2004} proposed to take the first value of $r$ for which the cophenetic coefficient starts decreasing, \cite{Hutchins2008} suggested to choose the first value where the RSS curve presents an inflection point, and \cite{Frigyesi2008} considered the smallest value at which the decrease in the RSS is lower than the decrease of the RSS obtained from random data.
+
+The \nmfpack package provides functions to help implement such procedures and plot the relevant quality measures.
+Note that this can be a lengthy computation, depending on the data size.
+Whereas the standard NMF procedure usually involves several hundreds of random initialization, performing 30-50 runs is considered sufficient to get a robust estimate of the factorization rank \cite{Brunet2004, Hutchins2008}.
+For performance reason, we perform here only 10 runs for each value of the rank.
+
+<<estimate_rank, cache=TRUE>>=
+# perform 10 runs for each value of r in range 2:6
+estim.r <- nmf(esGolub, 2:6, nrun=10, seed=123456)
+@
+
+The result is a S3 object of class \code{NMF.rank}, that contains a \code{data.frame} with the quality measures in column, and the values of $r$ in row.
+It also contains a list of the consensus matrix for each value of $r$.
+
+All the measures can be plotted at once with the method \code{plot} (\cref{fig:estim_all}), and the function \code{consensusmap} generates heatmaps of the consensus matrix for each value of the rank.
+In the context of class discovery, it is useful to see if the clusters obtained correspond to known classes.
+This is why in the particular case of the Golub dataset, we added annotation tracks for the two covariates available ('Cell' and 'ALL.AML').
+Since we removed the variable 'Sample' in the preliminaries, these are the only variables in the phenotypic \code{data.frame} embedded within the \code{ExpressionSet} object, and we can simply pass the whole object to argument \code{annCol} (\cref{fig:estim_all_hm}).
+One can see that at rank 2, the clusters correspond to the ALL and AML samples respectively, while rank 3 separates AML from ALL/T-cell and ALL/B-cell\footnote{Remember that the plots shown in \cref{fig:estim_all_hm} come from only 10 runs, using the 200 first genes in the dataset, which explains the somewhat not so clean clusters.
+The results are in fact much cleaner when using the full dataset (\cref{fig:heatmap_consensus}).}.
+
+\begin{figure}
+<<estimate_rank_plot, fig.width=10, fig.height=6>>=
+plot(estim.r)
+@
+\caption{Estimation of the rank: Quality measures computed from 10 runs for each value of $r$. \label{fig:estim_all}}
+\end{figure}
+
+\begin{figure}
+<<estimate_rank_hm_include, fig.width=14, fig.height=7, fig.keep='last'>>=
+consensusmap(estim.r, annCol=esGolub, labCol=NA, labRow=NA)
+@
+\caption{Estimation of the rank: Consensus matrices computed from 10 runs for each value of $r$. \label{fig:estim_all_hm}}
+\end{figure}
+
+\subsubsection{Overfitting}
+Even on random data, increasing the factorization rank would lead to decreasing residuals, as more variables are available to better fit the data.
+In other words, there is potentially an overfitting problem.
+
+In this context, the approach from \cite{Frigyesi2008} may be useful to prevent or detect overfitting as it takes into account the results for unstructured data.
+However it requires to compute the quality measure(s) for the random data.
+The \nmfpack package provides a function that shuffles the original data, by permuting the rows of each column, using each time a different permutation.
+The rank estimation procedure can then be applied to the randomized data, and the ``random'' measures added to the plot for comparison (\cref{fig:estim_all_rd}).
+
+\begin{figure}
+<<estimate_rank_random, cache=TRUE, fig.width=10, fig.height=6, fig.keep='last'>>=
+# shuffle original data
+V.random <- randomize(esGolub)
+# estimate quality measures from the shuffled data (use default NMF algorithm)
+estim.r.random <- nmf(V.random, 2:6, nrun=10, seed=123456)
+# plot measures on same graph
+plot(estim.r, estim.r.random)
+@
+\caption{Estimation of the rank: Comparison of the quality measures with those obtained from randomized data.
+The curves for the actual data are in blue and green, those for the randomized data are in red and pink.
+The estimation is based on Brunet's algorithm.}
+\label{fig:estim_all_rd}
+\end{figure}
+
+\subsection{Comparing algorithms}
+To compare the results from different algorithms, one can pass a list of methods in argument \code{method}.
+To enable a fair comparison, a deterministic seeding method should also be used.
+Here we fix the random seed to 123456.
+
+<<multimethod, cache=TRUE>>=
+# fit a model for several different methods
+res.multi.method <- nmf(esGolub, 3, list('brunet', 'lee', 'ns'), seed=123456, .options='t')
+@
+
+Passing the result to method \code{compare} produces a \code{data.frame} that contains summary measures for each method. Again, prior knowledge of classes may be used to compute clustering quality measures:
+
+<<compare>>=
+compare(res.multi.method)
+
+# If prior knowledge of classes is available
+compare(res.multi.method, class=esGolub$Cell)
+@
+
+Because the computation was performed with error tracking enabled, an error plot
+can be produced by method \code{plot} (\cref{fig:errorplot}).
+Each track is normalized so that its first value equals one, and stops at the iteration where the method's convergence criterion was fulfilled.
+
+\subsection{Visualization methods}
+
+\subsubsection*{Error track}
+
+If the NMF computation is performed with error tracking enabled -- using argument \code{.options} -- the trajectory of the objective value is computed during the fit.
+This computation is not enabled by default as it induces some overhead.
+
+<<errorplot_compute, cache=TRUE>>=
+# run nmf with .option='t'
+res <- nmf(esGolub, 3, .options='t')
+# or with .options=list(track=TRUE)
+@
+
+The trajectory can be plot with the method \code{plot} (\cref{fig:errorplot}):
+\begin{figure}[!htbp]
+<<errorplot, out.width="0.5\\textwidth", fig.show='hold'>>=
+plot(res)
+plot(res.multi.method)
+@
+\caption{Error track for a single NMF run (left) and multiple method
+runs (right)}
+\label{fig:errorplot}
+\end{figure}
+
+\subsubsection*{Heatmaps}
+
+The methods \code{basismap}, \code{coefmap} and \code{consensusmap} provide an
+easy way to visualize respectively the resulting basis matrix (i.e. metagenes),
+mixture coefficient matrix (i.e. metaprofiles) and the consensus matrix, in the
+case of multiple runs.
+It produces pre-configured heatmaps based on the function \code{aheatmap}, the
+underlying heatmap engine provided with the package NMF.
+The default heatmaps produced by these functions are shown in
+\cref{fig:heatmap_coef_basis,fig:heatmap_consensus}.
+They can be customized in many different ways (colours, annotations, labels).
+See the dedicated vignette \emph{``NMF: generating heatmaps"} or the help pages
+\code{?coefmap} and \code{?aheatmap} for more information.
+
+An important and unique feature of the function \code{aheatmap}, is that it
+makes it possible to combine several heatmaps on the same plot, using the both
+standard layout calls \texttt{par(mfrow=...)} and \texttt{layout(...)}, or grid
+viewports from \texttt{grid} graphics.
+The plotting context is automatically internally detected, and a correct
+behaviour is achieved thanks to the \citeCRANpkg{gridBase}.
+Examples are provided in the dedicated vignette mentioned above.
+
+The rows of the basis matrix often carry the high dimensionality of the data: genes, loci, pixels, features, etc\ldots
+The function \code{basismap} extends the use of argument \code{subsetRow} (from \code{aheatmap}) to the specification of a feature selection method.
+In \cref{fig:heatmap_coef_basis} we simply used \code{subsetRow=TRUE}, which subsets the rows using the method described in \cite{KimH2007}, to only keep the basis-specific features (e.g. the metagene-specific genes).
+We refer to the relevant help pages \code{?basismap} and \code{?aheatmap} for more details about other possible values for this argument.
+
+\begin{figure}[!htbp]
+\centering
+<<heatmap_coef_basis_inc, fig.width=14, fig.height=7, fig.keep='last'>>=
+layout(cbind(1,2))
+# basis components
+basismap(res, subsetRow=TRUE)
+# mixture coefficients
+coefmap(res)
+@
+\caption{Heatmap of the basis and the mixture coefficient matrices. The rows of the basis matrix were selected using the default feature selection method -- described in \cite{KimH2007}.}
+\label{fig:heatmap_coef_basis}
+\end{figure}
+
+In the case of multiple runs the function \code{consensusmap} plots the consensus matrix, i.e. the average connectivity matrix across the runs (see results in \cref{fig:heatmap_consensus} for a consensus matrix obtained with 100 runs of Brunet's algorithm on the complete
+Golub dataset):
+
+\begin{figure}[ht]
+<<heatmap_consensus_inc, out.width="0.49\\textwidth", crop=TRUE, echo=1:2>>=
+# The cell type is used to label rows and columns
+consensusmap(res.multirun, annCol=esGolub, tracks=NA)
+plot(1:10)
+f2 <- fig_path("2.pdf")
+@
+<<hack_consensus, include=FALSE>>=
+file.copy('consensus.pdf', f2, overwrite=TRUE)
+@
+\caption{Heatmap of consensus matrices from 10 runs on the reduced dataset
+(left) and from 100 runs on the complete Golub dataset (right).}
+\label{fig:heatmap_consensus}
+\end{figure}
+
+\section{Extending the package}
+
+We developed the \nmfpack\ package with the objective to facilitate the integration of new NMF methods, trying to impose only few requirements on their implementations.
+All the built-in algorithms and seeding methods are implemented as strategies that are called from within the main interface method \code{nmf}.
+
+The user can define new strategies and those are handled in exactly the same way as the built-in ones, benefiting from the same utility functions to interpret the
+results and assess their performance.
+
+\subsection{Custom algorithm}
+%New NMF algrithms can be defined in two ways:
+%
+%\begin{itemize}
+%\item as a single \code{function}
+%\item as a set of functions that implement a pre-defined \emph{iterative schema}
+%\end{itemize}
+%
+%\subsubsection{Defined as a \code{function}}
+
+\subsubsection{Using a custom algorithm}\label{sec:algo_custom}
+To define a strategy, the user needs to provide a \code{function} that implements the complete algotihm. It must be of the form:
+
+<<custom_algo_sig>>=
+my.algorithm <- function(x, seed, param.1, param.2){
+ # do something with starting point
+ # ...
+
+ # return updated starting point
+ return(seed)
+}
+@
+Where:
+
+\begin{description}
+\item[target] is a \code{matrix};
+\item[start] is an object that inherits from class \code{NMF}.
+This \code{S4} class is used to handle NMF models (matrices \code{W} and \code{H}, objective function, etc\dots);
+\item[param.1, param.2] are extra parameters specific to the algorithms;
+\end{description}
+
+The function must return an object that inherits from class \code{NMF}.
+
+For example:
+<<custom_algo>>=
+my.algorithm <- function(x, seed, scale.factor=1){
+ # do something with starting point
+ # ...
+ # for example:
+ # 1. compute principal components
+ pca <- prcomp(t(x), retx=TRUE)
+
+ # 2. use the absolute values of the first PCs for the metagenes
+ # Note: the factorization rank is stored in object 'start'
+ factorization.rank <- nbasis(seed)
+ basis(seed) <- abs(pca$rotation[,1:factorization.rank])
+ # use the rotated matrix to get the mixture coefficient
+ # use a scaling factor (just to illustrate the use of extra parameters)
+ coef(seed) <- t(abs(pca$x[,1:factorization.rank])) / scale.factor
+
+ # return updated data
+ return(seed)
+}
+@
+
+To use the new method within the package framework, one pass \code{my.algorithm} to main interface \code{nmf} via argument \code{method}.
+Here we apply the algorithm to some matrix \code{V} randomly generated:
+
+<<define_V>>=
+n <- 50; r <- 3; p <- 20
+V <-syntheticNMF(n, r, p)
+@
+
+<<custom_algo_run>>=
+nmf(V, 3, my.algorithm, scale.factor=10)
+@
+
+\subsubsection{Using a custom distance measure}
+The default distance measure is based on the euclidean distance.
+If the algorithm is based on another distance measure, this one can be specified in argument \code{objective}, either as a \code{character} string corresponding to a built-in objective function, or a custom \code{function} definition\footnote{Note that from version 0.8, the arguments for custom objective functions have been swapped: (1) the current NMF model, (2) the target matrix}:
+
+<<custom_algo_run_obj>>=
+# based on Kullback-Leibler divergence
+nmf(V, 3, my.algorithm, scale.factor=10, objective='KL')
+# based on custom distance metric
+nmf(V, 3, my.algorithm, scale.factor=10
+ , objective=function(model, target, ...){
+ ( sum( (target-fitted(model))^4 ) )^{1/4}
+ }
+)
+@
+
+%\subsubsection{Using the iterative schema}
+%
+%NMF algorithms generally implement the following common iterative schema:
+%
+%\begin{enumerate}
+%\item
+%\item
+%\end{enumerate}
+
+\subsubsection{Defining algorithms for mixed sign data}
+All the algorithms implemented in the \nmfpack package assume that the input data is nonnegative.
+However, some methods exist in the litterature that work with relaxed constraints, where the input data and one of the matrix factors ($W$ or $H$) are allowed to have negative entries (eg. semi-NMF \cite{Ding2010, Roux2008}).
+Strictly speaking these methods do not fall into the NMF category, but still solve constrained matrix factorization problems, and could be considered as NMF methods when applied to non-negative data.
+Moreover, we received user requests to enable the development of semi-NMF type methods within the package's framework.
+Therefore, we designed the \nmfpack package so that such algorithms -- that handle negative data -- can be integrated. This section documents how to do it.
+
+By default, as a safe-guard, the sign of the input data is checked before running any method, so that the \code{nmf} function throws an error if applied to data that contain negative entries \footnote{Note that on the other side, the sign of the factors returned by the algorithms is never checked, so that one can always return factors with negative entries.}.
+To extend the capabilities of the \nmfpack package in handling negative data, and plug mixed sign NMF methods into the framework, the user needs to specify the argument \code{mixed=TRUE} in the call to the \code{nmf} function.
+This will skip the sign check of the input data and let the custom algorithm perform the factorization.
+
+As an example, we reuse the previously defined custom algorithm\footnote{As it is defined here, the custom algorithm still returns nonnegative factors, which would not be desirable in a real example, as one would not be able to closely fit the negative entries.}:
+
+<<custom_algo_run_mixed, error = TRUE, try = TRUE>>=
+# put some negative input data
+V.neg <- V; V.neg[1,] <- -1;
+
+# this generates an error
+try( nmf(V.neg, 3, my.algorithm, scale.factor=10) )
+
+# this runs my.algorithm without error
+nmf(V.neg, 3, my.algorithm, mixed=TRUE, scale.factor=10)
+@
+
+\subsubsection{Specifying the NMF model}
+If not specified in the call, the NMF model that is used is the standard one, as defined in \cref{NMFstd}.
+However, some NMF algorithms have different underlying models, such as non-smooth NMF \cite{Pascual-Montano2006} which uses an extra matrix factor that introduces an extra parameter, and change the way the target matrix is approximated.
+
+The NMF models are defined as S4 classes that extends class \code{NMF}. All the available models can be retreived calling the \code{nmfModel()} function with no
+argument:
+
+<<nmf_models>>=
+nmfModel()
+@
+
+One can specify the NMF model to use with a custom algorithm, using argument \code{model}. Here we first adapt a bit the custom algorithm, to justify and illustrate the use of a different model.
+We use model \code{NMFOffset} \cite{Badea2008}, that includes an offset to take into account genes that have constant expression levels accross the samples:
+
+<<custom_algo_NMFoffset>>=
+my.algorithm.offset <- function(x, seed, scale.factor=1){
+ # do something with starting point
+ # ...
+ # for example:
+ # 1. compute principal components
+ pca <- prcomp(t(x), retx=TRUE)
+
+ # retrieve the model being estimated
+ data.model <- fit(seed)
+
+ # 2. use the absolute values of the first PCs for the metagenes
+ # Note: the factorization rank is stored in object 'start'
+ factorization.rank <- nbasis(data.model)
+ basis(data.model) <- abs(pca$rotation[,1:factorization.rank])
+ # use the rotated matrix to get the mixture coefficient
+ # use a scaling factor (just to illustrate the use of extra parameters)
+ coef(data.model) <- t(abs(pca$x[,1:factorization.rank])) / scale.factor
+
+ # 3. Compute the offset as the mean expression
+ data.model at offset <- rowMeans(x)
+
+ # return updated data
+ fit(seed) <- data.model
+ seed
+}
+@
+
+Then run the algorithm specifying it needs model \code{NMFOffset}:
+<<custom_algo_NMFOffset_run>>=
+# run custom algorithm with NMF model with offset
+nmf(V, 3, my.algorithm.offset, model='NMFOffset', scale.factor=10)
+@
+
+
+\subsection{Custom seeding method}\label{sec:seed_custom}
+
+The user can also define custom seeding method as a function of the form:
+
+
+<<custom_seed>>=
+
+# start: object of class NMF
+# target: the target matrix
+my.seeding.method <- function(model, target){
+
+ # use only the largest columns for W
+ w.cols <- apply(target, 2, function(x) sqrt(sum(x^2)))
+ basis(model) <- target[,order(w.cols)[1:nbasis(model)]]
+
+ # initialize H randomly
+ coef(model) <- matrix(runif(nbasis(model)*ncol(target))
+ , nbasis(model), ncol(target))
+
+ # return updated object
+ return(model)
+}
+@
+
+To use the new seeding method:
+<<custom_seed_run>>=
+nmf(V, 3, 'snmf/r', seed=my.seeding.method)
+@
+
+\section{Advanced usage}
+
+\subsection{Package specific options}
+The package specific options can be retieved or changed using the \code{nmf.getOption} and \code{nmf.options} functions.
+These behave similarly as the \code{getOption} and \code{nmf.options} base functions:
+
+<<options_algo, eval=1:6>>=
+#show default algorithm and seeding method
+nmf.options('default.algorithm', 'default.seed')
+
+# retrieve a single option
+nmf.getOption('default.seed')
+
+# All options
+nmf.options()
+@
+
+Currently the following options are available:
+
+<<nmf_options, echo=FALSE, results='asis'>>=
+RdSection2latex('nmf.options', package='NMF')
+@
+
+The default/current values of each options can be displayed using the function
+\code{nmf.printOptions}:
+
+<<print_options>>=
+nmf.printOptions()
+@
+
+%% latex table generated in R 2.10.1 by xtable 1.5-6 package
+%% Wed Apr 7 15:27:05 2010
+%\begin{table}[ht]
+%\begin{center}
+%\begin{tabularx}{\textwidth}{>{\ttfamily}rlX}
+% \hline
+%Option & Default value & Description\\
+%\hline
+%default.algorithm & brunet & Default NMF algorithm used by the \code{nmf} function when argument \code{method} is missing.
+%The value should the key of one of the available NMF algorithms.
+%See \code{?nmfAlgorithm}.\\
+%track.interval & 30 & Number of iterations between two points in the residual track.
+%This option is relevant only when residual tracking is enabled.
+%See \code{?nmf}.\\
+%error.track & FALSE & Toggle default residual tracking.
+%When \code{TRUE}, the \code{nmf} function compute and store the residual track in the result -- if not otherwise specified in argument \code{.options}.
+%Note that tracking may significantly slow down the computations.\\
+%default.seed & random & Default seeding method used by the \code{nmf} function when argument \code{seed} is missing.
+%The value should the key of one of the available seeding methods.
+%See \code{?nmfSeed}.\\
+%backend & mc & Default parallel backend used used by the \code{nmf} function when argument \code{.pbackend} is missing.
+%Currently the following values are supported: \code{'mc'} for multicore, \code{'seq'} for sequential, \code{''} for \code{sapply}.\\
+%verbose & FALSE & Toggle verbosity.\\
+%debug & FALSE & Toggle debug mode, which is an extended verbose mode.\\
+%\hline
+%\end{tabularx}
+%\end{center}
+%\caption{}
+%\end{table}
+
+\pagebreak
+\section{Session Info}
+<<sessionInfo, echo=FALSE, results='asis'>>=
+toLatex(sessionInfo())
+@
+
+\printbibliography[heading=bibintoc]
+
+\end{document}
+
diff --git a/inst/doc/NMF-vignette.pdf b/inst/doc/NMF-vignette.pdf
new file mode 100644
index 0000000..0a43112
Binary files /dev/null and b/inst/doc/NMF-vignette.pdf differ
diff --git a/inst/doc/consensus.pdf b/inst/doc/consensus.pdf
new file mode 100644
index 0000000..94d7014
Binary files /dev/null and b/inst/doc/consensus.pdf differ
diff --git a/inst/doc/heatmaps.R b/inst/doc/heatmaps.R
new file mode 100644
index 0000000..2f4ea2d
--- /dev/null
+++ b/inst/doc/heatmaps.R
@@ -0,0 +1,145 @@
+
+## ----pkgmaker_preamble, echo=FALSE, results='asis'-----------------------
+pkgmaker::latex_preamble()
+
+
+## ----bibliofile, echo=FALSE, results='asis'------------------------------
+pkgmaker::latex_bibliography('NMF')
+
+
+## ----options, include=FALSE, verbose=TRUE--------------------------------
+#options(prompt=' ')
+#options(continue=' ')
+set.seed(123456)
+library(NMF)
+
+
+## ----data----------------------------------------------------------------
+# random data that follow an 3-rank NMF model (with quite some noise: sd=2)
+X <- syntheticNMF(100, 3, 20, noise=2)
+
+# row annotations and covariates
+n <- nrow(X)
+d <- rnorm(n)
+e <- unlist(mapply(rep, c('X', 'Y', 'Z'), 10))
+e <- c(e, rep(NA, n-length(e)))
+rdata <- data.frame(Var=d, Type=e)
+
+# column annotations and covariates
+p <- ncol(X)
+a <- sample(c('alpha', 'beta', 'gamma'), p, replace=TRUE)
+# define covariates: true groups and some numeric variable
+c <- rnorm(p)
+# gather them in a data.frame
+covariates <- data.frame(a, X$pData, c)
+
+
+## ----figoptions, include=FALSE-------------------------------------------
+library(knitr)
+opts_chunk$set(fig.width=14, fig.height=7)
+
+
+## ----heatmap_data--------------------------------------------------------
+par(mfrow=c(1,2))
+aheatmap(X, annCol=covariates, annRow=X$fData)
+aheatmap(X)
+
+
+## ----model, cache=TRUE---------------------------------------------------
+res <- nmf(X, 3, nrun=10)
+res
+
+
+## ----coefmap_res, fig.keep='last'----------------------------------------
+opar <- par(mfrow=c(1,2))
+# coefmap from multiple run fit: includes a consensus track
+coefmap(res)
+# coefmap of a single run fit: no consensus track
+coefmap(minfit(res))
+par(opar)
+
+
+## ----coefmap_default, eval=FALSE-----------------------------------------
+## Rowv = NA
+## Colv = TRUE
+## scale = 'c1'
+## color = 'YlOrRd:50'
+## annCol = predict(object) + predict(object, 'consensus')
+
+
+## ----coefmap_custom, fig.keep='last', tidy=FALSE-------------------------
+opar <- par(mfrow=c(1,2))
+# removing all automatic annotation tracks
+coefmap(res, tracks=NA)
+# customized plot
+coefmap(res, Colv = 'euclidean'
+ , main = "Metagene contributions in each sample", labCol = NULL
+ , annRow = list(Metagene=':basis'), annCol = list(':basis', Class=a, Index=c)
+ , annColors = list(Metagene='Set2')
+ , info = TRUE)
+par(opar)
+
+
+## ----basismap_res, fig.keep='last'---------------------------------------
+opar <- par(mfrow=c(1,2))
+# default plot
+basismap(res)
+# customized plot: only use row special annotation track.
+basismap(res, main="Metagenes", annRow=list(d, e), tracks=c(Metagene=':basis'))
+par(opar)
+
+
+## ----basismap_default, eval=FALSE----------------------------------------
+## Colv = NA
+## scale = 'r1'
+## color = 'YlOrRd:50'
+## annRow = predict(object, 'features')
+
+
+## ----consensusmap_res, fig.keep='last'-----------------------------------
+opar <- par(mfrow=c(1,2))
+# default plot
+consensusmap(res)
+# customized plot
+consensusmap(res, annCol=covariates, annColors=list(c='blue')
+ , labCol='sample ', main='Cluster stability'
+ , sub='Consensus matrix and all covariates')
+par(opar)
+
+
+## ----cmap_default, eval=FALSE--------------------------------------------
+## distfun = function(x) as.dist(1-x) # x being the consensus matrix
+## hclustfun = 'average'
+## Rowv = TRUE
+## Colv = "Rowv"
+## color = '-RdYlBu'
+
+
+## ----estimate, cache=TRUE------------------------------------------------
+res2_7 <- nmf(X, 2:7, nrun=10, .options='v')
+class(res2_7)
+
+
+## ----consensusmap_estimate, fig.keep='last'------------------------------
+consensusmap(res2_7)
+
+
+## ----fit_methods, cache=TRUE---------------------------------------------
+res_methods <- nmf(X, 3, list('lee', 'brunet', 'nsNMF'), nrun=10)
+class(res_methods)
+
+
+## ----consensusmap_methods, fig.width=10, fig.height=7, fig.keep='last'----
+consensusmap(res_methods)
+
+
+## ----demo_hm, eval=FALSE-------------------------------------------------
+## demo('aheatmap')
+## # or
+## demo('heatmaps')
+
+
+## ----sessionInfo, echo=FALSE, results='asis'-----------------------------
+toLatex(sessionInfo())
+
+
diff --git a/inst/doc/heatmaps.Rnw b/inst/doc/heatmaps.Rnw
new file mode 100644
index 0000000..ad1947d
--- /dev/null
+++ b/inst/doc/heatmaps.Rnw
@@ -0,0 +1,481 @@
+%\VignetteIndexEntry{NMF: generating heatmaps}
+%\VignetteDepends{utils,NMF,RColorBrewer,knitr,bibtex}
+%\VignetteKeyword{aplot}
+%\VignetteCompiler{knitr}
+%\VignetteEngine{knitr::knitr}
+
+\documentclass[a4paper]{article}
+
+%\usepackage[OT1]{fontenc}
+\usepackage[colorlinks]{hyperref}
+\usepackage{a4wide}
+\usepackage{xspace}
+\usepackage[all]{hypcap} % for linking to the top of the figures or tables
+
+% add preamble from pkgmaker
+<<pkgmaker_preamble, echo=FALSE, results='asis'>>=
+pkgmaker::latex_preamble()
+@
+
+\newcommand{\nmfpack}{\pkgname{NMF}}
+\newcommand{\MATLAB}{MATLAB\textsuperscript{\textregistered}\xspace}
+\newcommand{\refeqn}[1]{(\ref{#1})}
+
+% REFERENCES
+\usepackage[citestyle=authoryear-icomp
+, doi=true
+, url=true
+, maxnames=1
+, maxbibnames=15
+, backref=true
+, backend=bibtex]{biblatex}
+\AtEveryCitekey{\clearfield{url}}
+<<bibliofile, echo=FALSE, results='asis'>>=
+pkgmaker::latex_bibliography('NMF')
+@
+\newcommand{\citet}[1]{\textcite{#1}}
+\renewcommand{\cite}[1]{\parencite{#1}}
+\DefineBibliographyStrings{english}{%
+ backrefpage = {see p.}, % for single page number
+ backrefpages = {see pp.} % for multiple page numbers
+}
+%
+
+% boxed figures
+\usepackage{float}
+\floatstyle{boxed}
+\restylefloat{figure}
+
+\usepackage{array}
+\usepackage{tabularx}
+\usepackage{mathabx}
+
+\usepackage{url}
+\urlstyle{rm}
+
+% use cleveref for automatic reference label formatting
+\usepackage[capitalise, noabbrev]{cleveref}
+
+% define commands for notes
+\usepackage{todonotes}
+\newcommand{\nbnote}[1]{\ \bigskip\todo[inline, backgroundcolor=blue!20!white]{\scriptsize\textsf{\textbf{NB:} #1}}\ \\}
+
+% put table of contents on two columns
+\usepackage[toc]{multitoc}
+
+\setkeys{Gin}{width=0.95\textwidth}
+
+\begin{document}
+
+<<options, include=FALSE, verbose=TRUE>>=
+#options(prompt=' ')
+#options(continue=' ')
+set.seed(123456)
+library(NMF)
+@
+
+\title{Generating heatmaps for Nonnegative Matrix Factorization\\
+\small Package \nmfpack\ - Version \Sexpr{utils::packageVersion('NMF')}}
+\author{Renaud Gaujoux}
+
+\maketitle
+
+\begin{abstract}
+This vignette describes how to produce different informative heatmaps from NMF objects,
+such as returned by the function \code{nmf} in the \citeCRANpkg{NMF}.
+The main drawing engine is implemented by the function \code{aheatmap}, which is
+a highly enhanced modification of the function \code{pheatmap} from the \CRANpkg{pheatmap},
+and provides convenient and quick ways of producing high quality and customizable annotated heatmaps.
+Currently this function is part of the package \nmfpack, but may eventually
+compose a separate package on its own.
+\end{abstract}
+
+{\small \tableofcontents}
+
+\section{Preliminaries}
+
+\subsection{Quick reminder on NMF models}
+
+Given a nonnegative target matrix $X$ of dimension $n\times p$, NMF algorithms
+aim at finding a rank $k$ approximation of the form:
+$$
+X \approx W H,
+$$
+where $W$ and $H$ are nonnegative matrices of dimensions $n\times k$ and $k\times p$
+respectively.
+
+The matrix $W$ is the basis matrix, whose columns are the basis components.
+The matrix $H$ is the mixture coefficient or weight matrix, whose columns contain
+the contribution of each basis component to the corresponding column of $X$.
+We call the rows of $H$ the basis profiles.
+
+\subsection{Heatmaps for NMF}
+
+Because NMF objects essentially wrap up a pair of matrices, heatmaps are convenient
+to visualise the results of NMF runs.
+The package \nmfpack provides several specialised heatmap functions, designed to produce
+heatmaps with sensible default configurations according to the data being drawn.
+Being all based on a common drawing engine, they share almost identical interfaces
+and capabilities.
+The following specialised functions are currently implemented:
+
+\begin{description}
+\item[\code{basismap}] draws heatmaps of the basis matrix
+\item[\code{coefmap}] draws heatmaps of the mixture coefficient matrix
+\item[\code{consensusmap}] draws heatmaps of the consensus matrix, for results
+of multiple NMF runs.
+\end{description}
+
+\subsection{Heatmap engine}
+
+All the above functions eventually call a common heatmap engine, with
+different default parameters, chosen to be relevant for the given underlying data.
+The engine is implemented by the function \code{aheatmap}.
+Its development started as modification of the function \code{pheatmap} from
+the \pkgname{pheatmap} package.
+The initial objective was to improve and increase its capabilities, as well as
+defining a simplified interface, more consistent with the R core function \code{heatmap}.
+We eventually aim at providing a general, flexible, powerful and easy to use engine
+for drawing annotated heatmaps.
+
+The function \code{aheatmap} has many advantages compared to other heatmap functions
+such as \code{heatmap}, \code{gplots::heatmap2}, \code{heatmap.plus::heatmap.plus}
+, or even \code{pheatmap}:
+
+\begin{itemize}
+\item Annotations: unlimited number of annotation tracks can be added to
+\emph{both} columns and rows, with automated colouring for categorical and
+numeric variables.
+\item Compatibility with both base and grid graphics: the function can be
+directly called in drawing contexts such as grid, mfrow or layout.
+This is a feature many R users were looking for, and that was strictly
+impossible with base heatmaps.
+\item Legends: default automatic legend and colouring;
+\item Customisation: clustering methods, annotations, colours and legend can all
+be customised, even separately for rows and columns;
+\item Convenient interface: many arguments provide multiple ways of
+specifying their value(s), which speeds up developping/writing and reduce the
+amount of code required to generate customised plots (e.g. see
+\cref{sec:colour_spec}).
+\item Aesthetics: the heatmaps look globally cleaner, the image and text components
+are by default well proportioned relatively to each other, and all fit within
+the graphic device.
+\end{itemize}
+
+\subsection{Data and model}
+\label{sec:data}
+
+For the purpose of illustrating the use of each heatmap function, we generate a
+random target matrix, as well as some annotations or covariates:
+
+<<data>>=
+# random data that follow an 3-rank NMF model (with quite some noise: sd=2)
+X <- syntheticNMF(100, 3, 20, noise=2)
+
+# row annotations and covariates
+n <- nrow(X)
+d <- rnorm(n)
+e <- unlist(mapply(rep, c('X', 'Y', 'Z'), 10))
+e <- c(e, rep(NA, n-length(e)))
+rdata <- data.frame(Var=d, Type=e)
+
+# column annotations and covariates
+p <- ncol(X)
+a <- sample(c('alpha', 'beta', 'gamma'), p, replace=TRUE)
+# define covariates: true groups and some numeric variable
+c <- rnorm(p)
+# gather them in a data.frame
+covariates <- data.frame(a, X$pData, c)
+@
+
+%\SweaveOpts{fig.width=14,fig.height=7}
+<<figoptions, include=FALSE>>=
+library(knitr)
+opts_chunk$set(fig.width=14, fig.height=7)
+@
+Note that in the code above, the object \code{X} returned by \code{syntheticNMF} \emph{really is} a matrix object, but wrapped through the function \code{ExposedAttribute} object, which exposes its attributes via a more friendly and access controlled interface \code{\$}.
+Of particular interests are attributes \code{'pData'} and \code{'fData'}, which are lists that contain a factor named \code{'Group'} that indicates the true underlying clusters.
+These are respectively defined as each sample's most contrbuting basis component and the basis component to which each feature contributes the most.
+They are useful to annotate heatmaps and assess the ability of NMF methods to recover the true clusters.
+
+As an example, one can conveniently visualize the target matrix as a heatmap, with or without the relevant sample and feature annotations, using simple calls to the \code{aheatmap} function:
+<<heatmap_data>>=
+par(mfrow=c(1,2))
+aheatmap(X, annCol=covariates, annRow=X$fData)
+aheatmap(X)
+@
+
+Then, we fit an NMF model using multiple runs, that will be used throughtout this vignette to illustrate the use of NMF heatmaps:
+
+<<model, cache=TRUE>>=
+res <- nmf(X, 3, nrun=10)
+res
+@
+
+\nbnote{To keep the vignette simple, we always use the default NMF method
+(i.e. \code{'brunet'}), but all steps could be performed using a different method,
+or multiple methods in order to compare their perfromances.}
+
+\section{Mixture Coefficient matrix: \texttt{coefmap}}
+
+The coefficient matrix of the result can be plotted using the function
+\code{coefmap}.
+The default behaviour for multiple NMF runs is to add two annotation tracks that
+show the clusters obtained by the best fit and the hierarchical clustering of
+the consensus matrix\footnote{The hierarchical clustering is computed using the
+consensus matrix itself as a similarity measure, and average linkage. See
+\code{?consensushc}.}.
+In the legend, these tracks are named \emph{basis} and \emph{consensus} respectively.
+For single NMF run or NMF model objects, no consensus data are available, and
+only the clusters from the fit are displayed.
+
+<<coefmap_res, fig.keep='last'>>=
+opar <- par(mfrow=c(1,2))
+# coefmap from multiple run fit: includes a consensus track
+coefmap(res)
+# coefmap of a single run fit: no consensus track
+coefmap(minfit(res))
+par(opar)
+@
+
+\nbnote{Note how both heatmaps were drawn on the same plot, simply using the standard
+call to \code{par(mfrow=c(1,2)}.
+This is impossible to achieve with the R core function \code{heatmap}.
+See \cref{sec:aheatmap} for more details about compatibility with base
+and grid graphics.}
+
+By default:
+\begin{itemize}
+\item the rows are not ordered;
+\item the columns use the default ordering of \code{aheatmap}, but may easily be
+ordered according to the clusters defined by the dominant basis component for
+each column with \code{Colv="basis"}, or according to those implied by the
+consensus matrix, i.e. as in \code{consensusmap}, with \code{Colv="consensus"};
+\item each column is scaled to sum up to one;
+\item the color palette used is \code{'YlOrRd'} from the
+\citeCRANpkg{RColorBrewer}, with 50 breaks.
+\end{itemize}
+
+In term of arguments passed to the heatmap engine \code{aheatmap}, these default
+settings translate as:
+
+<<coefmap_default, eval=FALSE>>=
+Rowv = NA
+Colv = TRUE
+scale = 'c1'
+color = 'YlOrRd:50'
+annCol = predict(object) + predict(object, 'consensus')
+@
+
+If the ordering does not come from a hierarchical clustering (e.g., if
+\code{Colv='basis'}), then no dendrogram is displayed.
+The default behaviour of \code{aheatmap} can be obtained by setting arguments
+\code{Rowv=TRUE, Colv=TRUE, scale='none'}.
+
+\medskip
+The automatic annotation tracks can be hidden all together by setting argument
+\code{tracks=NA}, displayed separately by passing only one of the given names
+(e.g. \code{tracks=':basis'} or \code{tracks='basis:'} for the row or column respectively),
+and their legend names may be changed by
+specifying e.g. \code{tracks=c(Metagene=':basis', 'consensus')}.
+Beside this, they are handled by the heatmap engine function \code{aheatmap}
+and can be customised as any other annotation tracks -- that can be added via
+the same argument \code{annCol} (see \cref{sec:aheatmap} or \code{?aheatmap} for
+more details).
+
+<<coefmap_custom, fig.keep='last', tidy=FALSE>>=
+opar <- par(mfrow=c(1,2))
+# removing all automatic annotation tracks
+coefmap(res, tracks=NA)
+# customized plot
+coefmap(res, Colv = 'euclidean'
+ , main = "Metagene contributions in each sample", labCol = NULL
+ , annRow = list(Metagene=':basis'), annCol = list(':basis', Class=a, Index=c)
+ , annColors = list(Metagene='Set2')
+ , info = TRUE)
+par(opar)
+@
+
+\nbnote{The feature that allows to display some information about the fit
+at the bottom of the plot via argument \code{info=TRUE} is still experimental.
+It is helpful mostly when developing algorithms or doing an analysis, but
+would seldom be used in publications.}
+
+\section{Basis matrix: \texttt{basismap}}
+
+The basis matrix can be plotted using the function \code{basismap}.
+The default behaviour is to add an annotation track that shows for each row
+the dominant basis component.
+That is, for each row, the index of the basis component with the highest
+loading.
+
+This track can be disabled by setting \code{tracks=NA}, and extra
+row annotations can be added using the same argument \code{annRow}.
+
+<<basismap_res, fig.keep='last'>>=
+opar <- par(mfrow=c(1,2))
+# default plot
+basismap(res)
+# customized plot: only use row special annotation track.
+basismap(res, main="Metagenes", annRow=list(d, e), tracks=c(Metagene=':basis'))
+par(opar)
+@
+
+By default:
+\begin{itemize}
+\item the columns are not ordered;
+\item the rows are ordered by hierarchical clustering using default distance and
+linkage methods (\code{'eculidean'} and \code{'complete'});
+\item each row is scaled to sum up to one;
+\item the color palette used is \code{'YlOrRd'} from the
+\citeCRANpkg{RColorBrewer}, with 50 breaks.
+\end{itemize}
+
+In term of arguments passed to the heatmap engine \code{aheatmap}, these default
+settings translate as:
+
+<<basismap_default, eval=FALSE>>=
+Colv = NA
+scale = 'r1'
+color = 'YlOrRd:50'
+annRow = predict(object, 'features')
+@
+
+\section{Consensus matrix: \texttt{consensusmap}}
+
+When doing clustering with NMF, a common way of assessing the stability of the
+clusters obtained for a given rank is to consider the consensus matrix
+computed over multiple independent NMF runs, which is the average of the connectivity
+matrices of each separate run
+\footnote{Hence, stability here means robustness with regards to the initial starting point,
+and shall not be interpreted as in e.g. cross-validation/bootstrap analysis.
+However, one can argue that having very consistent clusters across runs somehow supports
+for a certain regularity or the presence of an underlying pattern in the data.}.
+This procedure is usually repeated over a certain range of factorization ranks,
+and the results are compared to identify which rank gives the best clusters,
+possibly in the light of some extra knowledge one could have about the samples
+(e.g. covariates).
+The functions \code{nmf} and \code{consensusmap} make it easy to implement
+this whole process.
+
+\nbnote{The consensus plots can also be generated for fits obtained from single NMF runs,
+in which case the consensus matrix simply reduces to a single connectivity matrix.
+This is a binary matrix (i.e. entries are either 0 or 1), that will always produce
+a bi-colour heatmap, and by default clear blocks for each cluster.}
+
+\subsection{Single fit}
+In section \cref{sec:data}, the NMF fit \code{res} was computed with argument
+\code{nrun=10}, and therefore contains the best fit over 10 runs, as well as
+the consensus matrix computed over all the runs
+\footnote{If one were interested in keeping the fits from all the runs, the
+function \code{nmf} should have been called with argument \code{.options='k'}.
+See section \emph{Options} in \code{?nmf}.
+The downstream hanlding of the result would remain identical.}.
+This can be ploted using the function \code{consensusmap}, which allows for the
+same kind of customization as the other NMF heatmap functions:
+
+<<consensusmap_res, fig.keep='last'>>=
+opar <- par(mfrow=c(1,2))
+# default plot
+consensusmap(res)
+# customized plot
+consensusmap(res, annCol=covariates, annColors=list(c='blue')
+ , labCol='sample ', main='Cluster stability'
+ , sub='Consensus matrix and all covariates')
+par(opar)
+@
+
+By default:
+\begin{itemize}
+\item the rows and columns of the consensus heatmap are symmetrically
+ordered by hierarchical clustering using the consensus matrix as a similarity
+measure and average linkage, and the associated dendrogram is displayed;
+\item the color palette used is the reverse of \code{'RdYlBu'} from the \citeCRANpkg{RColorBrewer}.
+\end{itemize}
+
+In term of arguments passed to the heatmap engine \code{aheatmap}, these default
+settings translate as:
+
+<<cmap_default, eval=FALSE>>=
+distfun = function(x) as.dist(1-x) # x being the consensus matrix
+hclustfun = 'average'
+Rowv = TRUE
+Colv = "Rowv"
+color = '-RdYlBu'
+@
+
+\subsection{Single method over a range of ranks}
+
+The function \code{nmf} accepts a range of value for the rank (argument \code{rank}),
+making it fit NMF models for each value in the given range
+\footnote{Before version 0.6, this feature was provided by the function \code{nmfEstimateRank}.
+From version 0.6, the function \code{nmf} accepts ranges of ranks, and internally
+calls the function \code{nmfEstimateRank} -- that remains exported and can still
+be called directly.
+See documentation \code{?nmfEstimateRank} for more details on the returned value.}:
+
+<<estimate, cache=TRUE>>=
+res2_7 <- nmf(X, 2:7, nrun=10, .options='v')
+class(res2_7)
+@
+
+The result \code{res2\_7} is an S3 object of class \code{'NMF.rank'},
+that contains -- amongst other data -- a list of the best fits obtained for each
+value of the rank in range $\ldbrack 2, 7\rdbrack]$.
+The method of \code{consensusmap} defined for class \code{'NMF.rank'},
+which plots all the consensus matrices on the same plot:
+
+<<consensusmap_estimate, fig.keep='last'>>=
+consensusmap(res2_7)
+@
+
+\nbnote{ The main title of each consensus heatmap can be customized by passing
+to argument \code{main} a character vector or a list whose elements specify each title.
+All other arguments are used in each internal call to consensusmap, and will
+therefore affect all the plots simultaneously.
+The layout can be specified via argument \code{layout} as a numeric vector
+giving the number of rows and columns in a \code{mfrow}-like way, or as a
+matrix that will be passed to R core function \code{layout}.
+See \code{?consensusmap} for more details and example code.
+}
+
+\subsection{Single rank over a range of methods}
+If one is interested in comparing methods, for a given factorization rank, then
+on can fit an NMF model for each method by providing the function \code{nmf} with
+a \code{list} in argument \code{method}:
+
+<<fit_methods, cache=TRUE>>=
+res_methods <- nmf(X, 3, list('lee', 'brunet', 'nsNMF'), nrun=10)
+class(res_methods)
+@
+
+The result \code{res\_methods} is an S4 object of class \code{NMFList}, which
+is essentially a named list, that contains each fits and the CPU time required
+by the whole computation.
+As previously, the sequence of consensus matrices is plotted with \code{consensusmap}:
+
+<<consensusmap_methods, fig.width=10, fig.height=7, fig.keep='last'>>=
+consensusmap(res_methods)
+@
+
+\section{Generic heatmap engine: \texttt{aheatmap}}
+\label{sec:aheatmap}
+
+This section still needs to be written, but many examples of annotated heatmaps can be found in the demos \code{'aheatmap'} and \code{'heatmaps'}:
+<<demo_hm, eval=FALSE>>=
+demo('aheatmap')
+# or
+demo('heatmaps')
+@
+
+These demos and the plots they generate can also be browsed online at \url{http://nmf.r-forge.r-project.org/_DEMOS.html}.
+
+\section{Session Info}
+<<sessionInfo, echo=FALSE, results='asis'>>=
+toLatex(sessionInfo())
+@
+
+\printbibliography[heading=bibintoc]
+
+
+\end{document}
diff --git a/inst/doc/heatmaps.pdf b/inst/doc/heatmaps.pdf
new file mode 100644
index 0000000..e2154fd
Binary files /dev/null and b/inst/doc/heatmaps.pdf differ
diff --git a/inst/m-files/brunet-run.m b/inst/m-files/brunet-run.m
new file mode 100644
index 0000000..87d874f
--- /dev/null
+++ b/inst/m-files/brunet-run.m
@@ -0,0 +1,38 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%
+% MATLAB/Octave code to run NMF using Brunet et al. original algorithm
+% (see in file brunet.m).
+% The objective is to be able to compare the results/performances from the
+% NMF package and the original MATLAB code.
+%
+% The original function 'nmf' was adapted to accept arguments to set the initial
+% values for the matrix factors W and H.
+%
+% Original MATLAB codes can be found at:
+% http://www.broadinstitute.org/mpr/publications/projects/NMF/nmf.m
+% http://www.broadinstitute.org/publications/broad872
+%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+% clean workspace
+clear -all;
+
+% load Brunet et al. algorithm -> defines the 'nmf' function
+source('brunet.m');
+
+% load test data
+target = load('target.txt');
+W0 = load('W.txt');
+H0 = load('H.txt');
+[n, rank] = size(W0);
+
+% run algorithm
+[total, user, sys] = cputime();
+[W,H] = nmf(target, rank, false, W0, H0);
+[total2, user2, sys2] = cputime();
+elapsed = total2 - total;
+user = user2 - user;
+sys = sys2 - sys;
+
+% save result
+save 'ref.brunet.oct' W H elapsed user sys;
diff --git a/inst/m-files/brunet.R b/inst/m-files/brunet.R
new file mode 100644
index 0000000..eb89392
--- /dev/null
+++ b/inst/m-files/brunet.R
@@ -0,0 +1,118 @@
+#######################################################################
+#
+# Script to compare the results/performances from the NMF package
+# and the original MATLAB implementation of the algorithm from Brunet et al..
+#
+# This is for when the RcppOctave package is not available, which
+# makes things much manual...
+#
+#######################################################################
+
+cat("\n# START\n")
+
+# auxiliary function to save data in a plain text format
+save.ascii <- function(X, file){
+
+ X <- format(X, digits=11)
+ write.table(X, file=file, row.names=FALSE, col.names=FALSE, quote=FALSE)
+ invisible()
+
+}
+
+#load NMF
+library(NMF)
+
+
+##################################################
+# STEP 1: Generate the test data
+##################################################
+
+# load the target: the Golub data
+cat("* Prepare data:\n")
+cat("\t- Load Golub data\n")
+data(esGolub)
+target <- exprs(esGolub)
+n <- nrow(target)
+p <- ncol(target)
+rank <- 3
+
+# save target
+cat("\t- Save Golub data in ASCII\n")
+save.ascii(target, 'target.txt')
+
+# set the seed for reproducibility
+set.seed(654321)
+# generate and save W
+cat("\t- Generate initial value for W\n")
+save.ascii(matrix(runif(n*rank), n, rank), 'W.txt')
+# generate and save H
+cat("\t- Generate initial value for H\n")
+save.ascii(matrix(runif(rank*p), rank, p), 'H.txt')
+
+
+
+###########################################################
+# STEP 2: Run Brunet et al. algorithm using the NMF package
+###########################################################
+# load the test data
+cat("\n* Reload the generated data\n")
+target <- as.matrix(read.table('target.txt'))
+W0 <- as.matrix(read.table('W.txt'))
+H0 <- as.matrix(read.table('H.txt'))
+
+# wrap the seed into a NMF object
+start <- nmfModel(W=W0, H=H0)
+
+# apply Brunet algorithm
+cat("* NMF package: run Brunet [optim]\n")
+res <- nmf(target, method='brunet', seed=start) # optimized in C++
+cat("* NMF package: run Brunet [plain]\n")
+res.R <- nmf(target, method='.R#brunet', seed=start) # plain R
+
+
+######################################################################
+# STEP 3: Switch to MATLAB/GNU Octave and run Brunet et al. algorithm
+# using the orginal MATLAB code
+######################################################################
+# We adapted the original MATLAB code obtained to be able to specify
+# initial values for the matrices W and H.
+# Original MATLAB code: http://www.broadinstitute.org/mpr/publications/projects/NMF/nmf.m
+# Adapted algorithm: m-files/brunet.m
+# MATLAB code to run the test factorization: m-files/brunet-run.m
+#
+# The results should be saved in a single file named 'ref.brunet.oct'
+#, that contains the final values for W and H, in variables named 'W' and 'H'.
+
+###################################################################
+# STEP 4: Compare the results
+###################################################################
+# load the results obtained with the MATLAB code (from Brunet et al. publication)
+
+cat("* Load results from MATLAB/Octave\n")
+if( !file.exists('ref.brunet.oct') )
+ stop("Could not find file 'ref.brunet.oct'. [Please run the script 'brunet-run.m' to generate it]")
+
+library(foreign)
+ref <- read.octave('ref.brunet.oct')
+
+## Note: we used GNU Octave to run the MATLAB code,
+## if the result was obtained using MATLAB, then the following code should load
+## it correctly (we did not test it though).
+#library(R.matlab)
+#ref <- readMat('ref.brunet.mat')
+
+cat("* Comparison of results:\n\n")
+#Sum of differences in W
+cat("\t- Sum of absolute differences in W: ", sum( abs(basis(res) -ref$W) ), "\n")
+cat("\t [all.equal = ", all.equal(basis(res), ref$W, check.attributes=FALSE), "]\n")
+
+#Sum of differences in H
+cat("\t- Sum of absolute differences in H: ", sum( abs(coef(res) - ref$H) ), "\n")
+cat("\t [all.equal = ", all.equal(coef(res), ref$H, check.attributes=FALSE), "]\n")
+
+# compare performances
+cat("\t- Speed comparaison: \n")
+t.ref <- unlist(ref[c('user', 'sys', 'elapsed')])
+rbind(`R optim` = runtime(res)[1:3], `MATLAB/Octave`=t.ref, `R plain`=runtime(res.R)[1:3])
+cat("\n# DONE\n")
+
diff --git a/inst/m-files/brunet.m b/inst/m-files/brunet.m
new file mode 100644
index 0000000..ea726de
--- /dev/null
+++ b/inst/m-files/brunet.m
@@ -0,0 +1,198 @@
+% NMF algorithm using the update equations for the Kullback-Leibler divergence
+% from Lee and Seung (2001), implemented in MATLAB by Brunet et al. (2004).
+%
+% USAGE: [w, h, elapsed, user, sys, niter] = brunet(v, r, verbose, w, h)
+%
+% ARGUMENTS:
+%
+% v (n,m) : N (genes) x M (samples) original matrix
+% Numerical data only.
+% Must be non negative.
+% Not all entries in a row can be 0. If so, add a small constant to the
+% matrix, eg.v+0.01*min(min(v)),and restart.
+%
+% r : number of desired factors (rank of the factorization)
+%
+% verbose : prints iteration count and changes in connectivity matrix elements
+% unless verbose is 0
+%
+% OPTIONAL ARGUMENTS:
+%
+% w : N (genes) x r matrix to used to seed the computation
+% h : r x M (samples) matrix to used to seed the computation
+%
+% Note : both matrices w and h must be supplied to effectively seed the
+% computation. Otherwise the original random initialization of both is
+% used.
+%
+% Note : NMF iterations stop when connectivity matrix has not changed
+% for 10*stopconv interations. This is experimental and can be
+% adjusted.
+%
+% RETURNED VALUE(S):
+%
+% w : N x r NMF factor
+% h : r x M NMF factor
+% elapsed : Elapsed wallclock time
+% user : Elapsed user time
+% sys : Elapsed system time
+% niter : Number of iterations used
+%
+% DETAILS:
+%
+% The original MATLAB/Octave code for NMF is from Brunet et al.
+%
+% It was slightly adapted for the purpose of the development of the
+% NMF package (http://cran.r-project.org/package=NMF)
+% Modifications include:
+% - renaming of the function from `nmf` to `brunet`
+% - add arguments to allow setting the initial values for the matrix
+% factors W and H
+% - compute and return CPU timing
+%
+% Modifications in the original code are signaled with tags RG, RG_START and RG_END.
+%
+% REFERENCES
+%
+% Lee, D..D., and Seung, H.S. (2001).
+% 'Algorithms for Non-negative Matrix Factorization'.
+% Adv. Neural Info. Proc. Syst. 13, 556-562.
+%
+% Brunet, J.P. et al. (2004).
+% 'Metagenes and molecular pattern discovery using matrix factorization'.
+% Proc Natl Acad Sci U S A, \bold{101}(12), 4164--4169.
+%
+% Original MATLAB files can be found at:
+% http://www.broadinstitute.org/mpr/publications/projects/NMF/nmf.m
+% http://www.broadinstitute.org/publications/broad872
+%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+function [W,H,runtime,niter] = brunet(v,r,verbose, w, h, niter)
+%
+% Jean-Philippe Brunet
+% Cancer Genomics
+% The Broad Institute
+% brunet at broad.mit.edu
+%
+% This software and its documentation are copyright 2004 by the
+% Broad Institute/Massachusetts Institute of Technology. All rights are reserved.
+% This software is supplied without any warranty or guaranteed support whatsoever.
+% Neither the Broad Institute nor MIT can not be responsible for its use, misuse,
+% or functionality.
+%
+% NMF divergence update equations :
+% Lee, D..D., and Seung, H.S., (2001), 'Algorithms for Non-negative Matrix
+% Factorization', Adv. Neural Info. Proc. Syst. 13, 556-562.
+%
+% v (n,m) : N (genes) x M (samples) original matrix
+% Numerical data only.
+% Must be non negative.
+% Not all entries in a row can be 0. If so, add a small constant to the
+% matrix, eg.v+0.01*min(min(v)),and restart.
+%
+% r : number of desired factors (rank of the factorization)
+%
+% verbose : prints iteration count and changes in connectivity matrix elements
+% unless verbose is 0
+%
+% Note : NMF iterations stop when connectivity matrix has not changed
+% for 10*stopconv interations. This is experimental and can be
+% adjusted.
+%
+% w : N x r NMF factor
+% h : r x M NMF factor
+
+% test for negative values in v
+if min(min(v)) < 0
+error('matrix entries can not be negative');
+return
+end
+if min(sum(v,2)) == 0
+error('not all entries in a row can be zero');
+return
+end
+
+
+[n,m]=size(v);
+stopconv=40; % stopping criterion (can be adjusted)
+if nargin<6,
+ niter = 2000; % maximum number of iterations (can be adjusted)
+end
+
+
+cons=zeros(m,m);
+consold=cons;
+inc=0;
+j=0;
+
+%% RG_START: Modified by Renaud Gaujoux (2009)
+%
+% initialize random w and h (only if one of the factor is missing)
+%
+if nargin<5,
+ if( verbose )
+ fprintf('Use random W and H\n');
+ end
+ w=rand(n,r);
+ h=rand(r,m);
+end
+%% RG_END
+
+[total, user, sys] = cputime(); % [RG] Add CPU timing
+
+if verbose % prints number of changing elements
+fprintf('\t%s\t%s\t%s\n','niter','citer','changes'),
+end
+
+for i=1:niter
+
+% divergence-reducing NMF iterations
+
+x1=repmat(sum(w,1)',1,m);
+h=h.*(w'*(v./(w*h)))./x1;
+x2=repmat(sum(h,2)',n,1);
+w=w.*((v./(w*h))*h')./x2;
+
+% test convergence every 10 iterations
+
+if(mod(i,10)==0)
+j=j+1;
+
+% adjust small values to avoid undeflow
+h=max(h,eps);w=max(w,eps);
+
+% construct connectivity matrix
+[y,index]=max(h,[],1); %find largest factor
+mat1=repmat(index,m,1); % spread index down
+mat2=repmat(index',1,m); % spread index right
+cons=mat1==mat2;
+
+if(sum(sum(cons~=consold))==0) % connectivity matrix has not changed
+inc=inc+1; %accumulate count
+else
+inc=0; % else restart count
+end
+if verbose % prints number of changing elements
+fprintf('\t%d\t%d\t%d\n',i,inc,sum(sum(cons~=consold))),
+end
+
+if(inc>stopconv)
+break, % assume convergence is connectivity stops changing
+end
+
+consold=cons;
+
+end
+end
+
+% [RG_START] Compute CPU time
+[total2, user2, sys2] = cputime();
+runtime.user = user2 - user;
+runtime.sys = sys2 - sys;
+runtime.elapsed = total2 - total;
+niter = i;
+W = w;
+H = h;
+% [RG_END]
diff --git a/inst/scripts/grid.R b/inst/scripts/grid.R
new file mode 100644
index 0000000..20f5719
--- /dev/null
+++ b/inst/scripts/grid.R
@@ -0,0 +1,60 @@
+# NMF package
+#
+# Helper code to allow mixing grid/base graphics.
+# This code is only loaded with the explicit request of the user,
+# either via option 'grid.patch' or environment variable R_PACKAGE_NMF_GRID_PATCH.
+#
+# The functions in this file were adapted from the grid package, which is
+# under the following GPL license:
+#
+# R : A Computer Language for Statistical Data Analysis
+# Copyright (C) 2001-3 Paul Murrell
+# 2003 The R Core Team
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, a copy is available at
+# http://www.r-project.org/Licenses/
+#
+# Author: Renaud Gaujoux
+# Created: Sep 16, 2013
+###############################################################################
+
+# This is essentially where the patch lies: not calling L_gridDirty
+grid.Call <- function (fnname, ...)
+{
+ #.Call(L_gridDirty)
+ .Call(fnname, ..., PACKAGE = "grid")
+}
+
+# One has to test for nullity since not using L_gridDirty means potentially
+# returning a NULL viewport
+current.viewport <- function()
+{
+ cv <- grid.Call(grid:::L_currentViewport)
+ if( !is.null(cv) ) grid:::vpFromPushedvp(cv)
+}
+
+# same thing here: call patched current.viewport and
+# check for nullity
+current.vpPath <- function(){
+ names <- NULL
+ pvp <- current.viewport()
+ if( is.null(pvp) ) return(NULL)
+ while ( !is.null(pvp) && !grid:::rootVP(pvp)) {
+ names <- c(names, pvp$name)
+ pvp <- pvp$parent
+ }
+ if (!is.null(names))
+ grid:::vpPathFromVector(rev(names))
+ else names
+}
diff --git a/inst/scripts/report.Rmd b/inst/scripts/report.Rmd
new file mode 100644
index 0000000..a732ed2
--- /dev/null
+++ b/inst/scripts/report.Rmd
@@ -0,0 +1,91 @@
+
+
+```{r setup, echo = FALSE}
+library(knitr)
+library(NMF)
+options(width = 300)
+opts_knit$set(root.dir = opts_knit$get('output.dir'))
+```
+
+# Input
+
+## Method definition
+```{r load_custom}
+if( file.exists(f <- file.path(opts_knit$get('output.dir'), 'functions.R')) ){
+ cat("Sourcing custom definition in '", f,"' ... ", sep ='')
+ source(f)
+ cat('OK\n')
+}
+```
+
+## Data
+
+```{r data}
+# Target matrix
+class(x)
+dim(x)
+head(x[, 1:5])
+```
+## Parameters
+```{r args}
+# Factorisation ranks
+rank
+
+# Methods
+unlist(method)
+
+# Reference class
+summary(colClass)
+```
+
+# Run
+
+```{r run}
+# run NMF for all ranks
+res <- nmfRun(x, rank, method)
+```
+
+# Results
+
+## Plots
+
+```{r resplots, echo = FALSE, fig.width = 10, fig.height = 7}
+dummy <- lapply(names(res), function(x){
+ cat("##", x, "\n")
+ fit <- res[[x]]
+ # consensus map
+ consensusmap(fit, main = x, annCol = colClass)
+ # measures
+ if( length(rank) > 1){
+ p <- plot(fit)
+ print(p)
+ }
+})
+```
+
+## Accuracy
+
+```{r summary, echo = FALSE, fig.width = 15, fig.height = 8}
+# compute summary measures for all survey fits
+s <- lapply(names(res), function(x){
+ NMF::summary(res[[x]], class = colClass)
+})
+
+# complete missing measures
+snames <- unique(unlist(lapply(s, names)))
+s <- lapply(s, function(x){
+ if( any(i <- !snames %in% names(x)) ){
+ nas <- rep(NA, nrow(x))
+ x <- cbind(x, sapply(snames[i], function(x) nas))
+ }
+ x[, snames]
+})
+print(s_all <- do.call(rbind, s))
+library(reshape2)
+accuracy <- melt(s_all, id.vars = c('method', 'seed', 'rank', 'metric'))
+accuracy <- accuracy[!accuracy$variable %in% c('rng', 'nrun'),]
+ggplot(accuracy) +
+ geom_bar(aes(x = rank, y = value, fill = method), position='dodge', stat='identity') +
+ facet_wrap(~variable, scales = 'free') +
+ scale_x_discrete(breaks = unique(accuracy$rank))
+```
diff --git a/inst/tests/runit.NMFSet.r b/inst/tests/runit.NMFSet.r
new file mode 100644
index 0000000..54d72ed
--- /dev/null
+++ b/inst/tests/runit.NMFSet.r
@@ -0,0 +1,154 @@
+# Unit testing for multiple NMF runs
+#
+# Author: Renaud Gaujoux
+###############################################################################
+
+# make the internal functions visible
+if( isNamespaceLoaded('NMF') ){
+ join <- NMF:::NMFfitX
+}
+
+.testData <- function(n=20, r=3, m=10, ...){
+ syntheticNMF(n, r, m, ...)
+}
+
+check.result <- function(obj, V, r, size, msg=NULL){
+ checkTrue( is(obj, 'NMFfitX'), paste(msg, ' -> result is an object of class NMFfitX', sep=''))
+ checkEquals( nrun(obj), size, paste(msg, ' -> number of run is correctly set', sep=''))
+}
+
+test.join.singleRuns <- function(){
+
+ # set random seed
+ set.seed(123456)
+
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ # init a list for the results
+ resL <- list()
+ resL$brunet <- nmf(V, r)
+ resL$brunet2 <- nmf(V, r)
+ resL$brunet3 <- nmf(V, r)
+
+ # simple join
+ res <- join(resL)
+ check.result(res, V, r, length(resL), 'Simple join')
+
+ res <- join(resL, runtime.all={tt<-runif(5)})
+ check.result(res, V, r, length(resL), 'Simple join + set time')
+ checkTrue(all.equal(tt, as.numeric(runtime.all(res))), 'Simple join + set time: time is correctly set')
+
+ # merging join
+ res <- join(resL, .merge=TRUE)
+ check.result(res, V, r, length(resL), 'Merging join')
+
+}
+
+test.join.multipleRuns <- function(){
+
+ # set random seed
+ set.seed(123456)
+
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ # init a list for the results
+ resL <- list()
+ nruns <- c(2,3,4)
+ resL$brunet <- nmf(V, r, nrun=nruns[1])
+ resL$brunet2 <- nmf(V, r, nrun=nruns[2])
+ resL$brunet3 <- nmf(V, r, nrun=nruns[3])
+ res <- join(resL)
+ check.result(res, V, r, sum(nruns), 'Join multiple runs')
+
+}
+
+
+test.join.multipleAndSingleRunsMethods <- function(){
+
+ # set random seed
+ set.seed(123456)
+
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ # init a list for the results
+ resL <- list()
+ nruns <- c(1,3,4,1)
+ resL$a <- nmf(V, r)
+ resL$b <- nmf(V, r, nrun=nruns[2])
+ resL$c <- nmf(V, r, nrun=nruns[3])
+ resL$d <- nmf(V, r)
+ res <- join(resL)
+ check.result(res, V, r, sum(nruns), 'Join multiple runs + single runs')
+
+}
+
+test.multipleruns <- function(){
+
+ # set random seed
+ set.seed(123456)
+
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ # multiple runs
+ res <- nmf(V, r, nrun=5)
+ check.result(res, V, r, 5, 'Multiple runs')
+
+}
+
+test.interface <- function(){
+
+ # set random seed
+ set.seed(123456)
+
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+ rownames(V) <- seq(nrow(V))
+ colnames(V) <- seq(ncol(V))
+
+ # perform multiple runs
+ res <- nmf(V, r, nrun=5)
+
+ # clusters
+ checkTrue( is.factor(predict(res)), 'Clusters are computed without error')
+ checkEquals( length(predict(res)), ncol(V), 'Clusters for samples have correct length')
+ checkEquals( length(predict(res, 'features')), nrow(V), 'Clusters for features have correct length')
+ checkTrue( is.list(predict(res, prob=TRUE)), 'Clusters are computed without error')
+
+ # featureNames
+ checkTrue( is.character(featureNames(res)), 'Feature names are accessible without error')
+
+ # sampleNames
+ checkTrue( is.character(sampleNames(res)), 'Sample names are accessible without error')
+
+}
+
+#' Unit test for the function 'fit'
+test.fit <- function(){
+
+ # set random seed
+ set.seed(123456)
+
+ # create a random target matrix
+ n <- 20; r <- 3; m <- 30
+ V <- rmatrix(n,m)
+
+ # check result
+ check.result <- function(res){
+ cl <- class(res)
+
+ checkTrue( is( fit(res), 'NMF' ), paste(cl, "- fit: returns an object of class 'NMF'"))
+ checkTrue( !isNMFfit( fit(res) ), paste(cl, '- fit: does not return the complete fit'))
+ checkTrue( is( minfit(res), 'NMFfit' ), paste(cl, "- minfit: returns a 'NMFfit' object"))
+ }
+
+ # perform multiple runs not keeping
+ check.result( nmf(V, r) )
+ # perform multiple runs not keeping
+ check.result( nmf(V, r, nrun=3, .opt='-k') )
+ # perform multiple runs keeping
+ check.result( nmf(V, r, nrun=3, .opt='k') )
+}
\ No newline at end of file
diff --git a/inst/tests/runit.NMFStrategy-class.r b/inst/tests/runit.NMFStrategy-class.r
new file mode 100644
index 0000000..4247d63
--- /dev/null
+++ b/inst/tests/runit.NMFStrategy-class.r
@@ -0,0 +1,114 @@
+#' Unit Testing script for NMF package: virtual class NMFStrategy
+#'
+#' @author Renaud Gaujoux
+#' @creation 14 Aug 2009
+
+# make the internal functions/objects visible
+if( isNamespaceLoaded('NMF') ){
+ name <- NMF:::name
+ `name<-` <- NMF:::`name<-`
+ is.mixed <- NMF:::is.mixed
+}
+
+.TestSeed <- 123456
+
+#' Unit test for constructor
+test.constructor <- function(){
+
+ # no arguments
+ checkException( new('NMFStrategy'), 'Class is virtual')
+
+ # define a sub-class
+ setClass('A', contains='NMFStrategy')
+ on.exit(removeClass('A'), add=TRUE)
+
+ # with just name
+ #checkException( new('A', name=character()), 'Error if slot name is a null character string')
+ checkException( new('A', name=''), 'Error if slot name is an empty character string')
+
+ checkTrue( validObject(new('A', name='toto')), 'No error if object with non empty name')
+
+ # with objective function
+ checkException( new('A', name='toto', objective=4), 'Error if slot objective is NOT a character or function (numeric)')
+ checkException( new('A', name='toto', objective=''), 'Error if slot objective is an empty character string')
+
+ checkTrue( validObject(new('A', name='toto', objective='tata')), 'No error if slot objective is a non empty character string')
+ checkTrue( validObject(new('A', name='toto', objective=function(){})), 'No error if slot objective is a function')
+
+ # with model
+ checkException( new('A', name='toto', model=''), 'Error if slot model is an empty character string')
+ checkException( new('A', name='toto', model='toto'), 'Error if slot model is not an sub-class of class NMF')
+ #Now it is allowed to set the model to 'NMF'
+ #checkException( new('A', name='toto', model='NMF'), 'Error if slot model is class NMF')
+
+ checkTrue( validObject( new('A', name='toto', model='NMFstd')) , "Valid object if slot model is 'NMFstd'")
+ checkTrue( validObject( new('A', name='toto', model='NMFns')), "Valid object if slot model is a subclass of class 'NMF'")
+ checkTrue( validObject( new('A', name='toto', model=c('NMFns','NMFOffset'))), "Valid object if slot model is vector of subclasses of class 'NMF'")
+
+ # with mixed set
+ checkException( new('A', name='toto', mixed='toto'), 'Error if slot mixed is not logical')
+ checkException( new('A', name='toto', mixed=c(TRUE, FALSE)), 'Error if slot mixed is not length 1')
+ checkTrue( validObject( new('A', name='toto', mixed=TRUE) ), 'Valid object if slot mixed is TRUE' )
+ checkTrue( validObject( new('A', name='toto', mixed=TRUE) ), 'Valid object if slot mixed is FALSE' )
+}
+
+check.slots.methods <- function(obj, title=''){
+
+ checkEquals( name(obj), obj at name, paste(title, ": slot methods for 'name' give same result"))
+ checkEquals( objective(obj), obj at objective, paste(title, ": slot methods for 'objective' give same result"))
+ checkEquals( modelname(obj), obj at model, paste(title, ": slot methods for 'model' give same result"))
+ checkEquals( is.mixed(obj), obj at mixed, paste(title, ": slot methods for 'mixed' give same result"))
+
+}
+
+#' Unit test for accessors
+test.accessors <- function(){
+
+ # define a sub-class
+ setClass('A', contains='NMFStrategy')
+ on.exit(removeClass('A'), add=TRUE)
+
+ # create an object
+ a <- new('A')
+
+ # prototype is not valid
+ checkException( validObject(a), 'Prototype object is not valid')
+ check.slots.methods(a, 'Prototype object')
+
+ # slot name
+# checkException( a at name <- '', "Method @<-: Error if setting slot 'name' to ''")
+# checkException( a at name <- character(), "Method @<-: Error if setting slot 'name' to character()")
+# checkException( a at name <- 4, "Method @<-: Error if setting slot 'name' to not character")
+
+ checkException( name(a) <- '', "Method name<-: Error if setting slot 'name' to ''")
+ checkException( name(a) <- character(), "Method name<-: Error if setting slot 'name' to character()")
+ checkException( name(a) <- 4, "Method name<-: Error if setting slot 'name' to not character")
+
+ name(a) <- 'toto'
+ checkEquals( a at name, 'toto', "Method name<-: set slot 'name' correctly")
+ check.slots.methods(a, 'Object after name set by name<-')
+
+ # slot objective
+ checkException( objective(a) <- '', "Method objective<-: Error if setting slot 'objective' to ''")
+ checkException( objective(a) <- character(), "Method objective<-: Error if setting slot 'objective' to character()")
+ checkException( objective(a) <- 4, "Method objective<-: Error if setting slot 'objective' to not character")
+
+ objective(a) <- 'toto'
+ checkEquals( a at objective, 'toto', "Method objective<-: set slot 'objective' correctly")
+ check.slots.methods(a, 'Object after name set by objective<-')
+ objective(a) <- function(...){}
+ checkEquals( a at objective, function(...){}, "Method objective<-: set slot 'objective' correctly")
+ check.slots.methods(a, 'Object after name set by objective<-')
+}
+
+checkClass <- function(x, cl, msg){
+ checkEquals(class(x)[1L], cl, paste(msg, "[object of class '", class(x)[1L],"']"))
+}
+
+test.constructorMethod <- function(){
+
+ checkClass(NMFStrategy('a', Update=function(i, y, x, ...){}), 'NMFStrategyIterative', 'With argument `Update`')
+ checkClass(NMFStrategy('a', function(i, y, x, ...){}), 'NMFStrategyFunction', 'With method=function')
+ checkClass(NMFStrategy('a', algorithm=function(i, y, x, ...){}), 'NMFStrategyFunction', 'With argument `algorithm`')
+
+}
diff --git a/inst/tests/runit.NMFclass.r b/inst/tests/runit.NMFclass.r
new file mode 100644
index 0000000..b21bd4d
--- /dev/null
+++ b/inst/tests/runit.NMFclass.r
@@ -0,0 +1,922 @@
+#' Unit Testing script for NMF package: NMF models and utilities.
+#'
+#' @author Renaud Gaujoux
+#' @creation 22 April 2009
+
+# make the internal functions/objects visible
+if( isNamespaceLoaded('NMF') ){
+ .predict.nmf <- NMF:::.predict.nmf
+ is.same <- NMF:::is.same
+}
+
+.TestSeed <- 123456
+
+checkOnlyNAs <- function(x, msg){
+ checkTrue( all(is.na(basis(x))) , paste(msg, ': Only NAs in W'))
+ checkTrue( all(is.na(coef(x))), paste(msg, ': Only NAs in H'))
+}
+
+basicHM <- aheatmap
+
+checkPlot <- function(...){
+ if( isCHECK() ) return()
+ pkgmaker::checkPlot(...)
+}
+
+#' checks the validity of a NMF object: dimensions
+check.object <- function(obj, n, m, r, title='Check NMF object', class='NMFstd'){
+
+ # convert dimensions to integers
+ n <- as.integer(n)
+ m <- as.integer(m)
+ r <- as.integer(r)
+
+ # check class
+ checkTrue(is(obj, class), paste(title, ': object is of class "', class, "'"));
+ # check virtual interface accessors
+ checkTrue(is.same(obj at W, basis(obj)), msg('method `basis` returns slot W'))
+ checkTrue(is.same(obj at H, coef(obj)), msg('method `coef` returns slot H'))
+
+ checkIdentical(nrow(basis(obj)), n, paste(title, ': number of rows in basis matrix is correct'))
+ checkIdentical(nrow(obj), n, paste(title, ': nrow returns correct value'))
+ checkIdentical(ncol(basis(obj)), r, paste(title, ': number of columns in basis matrix is correct'))
+ checkIdentical(nbasis(obj), r, paste(title, ': nbasis returns correct value'))
+ checkIdentical(nrow(coef(obj)), r, paste(title, ': number of rows in coef matrix correct'))
+ checkIdentical(ncol(coef(obj)), m, paste(title, ': number of columns in coef matrix is correct'))
+ checkIdentical(ncol(obj), m, paste(title, ': ncol returns correct value'))
+}
+
+
+check.NMF.class <- function(class, ...){
+
+ set.seed(.TestSeed)
+
+ msg <- function(...) paste('New -', class,':', ...)
+
+ # base constructor: should build an empty model
+ a <- new(class, ...)
+
+ # check if there is only NAs
+ checkOnlyNAs(a, msg('with no parameters'))
+ check.object(a, 0, 0, 0, msg('with no parameters'), class)
+
+ # define some dimensions to use as template
+ n <- 50; m <- 10; r <- 3;
+ w <- rmatrix(n, r); h <- rmatrix(r, m)
+
+ # base constructor with one of the two matrices: exceptions
+ checkException(new(class, W=w, ...), msg('error if only basis matrix'))
+ checkException(new(class, H=h, ...), msg('error if only coef matrix'))
+
+ # base constructor with two matrices
+ a <- new(class, W=w, H=h, ...)
+
+ # check the dimensions of the internal matrices
+ check.object(a, n, m, r, msg('with two matrices - '), class)
+ checkIdentical(basis(a), w, msg('with two matrices - basis matrix is correctly set'));
+ checkIdentical(coef(a), h, msg('with two matrices - coef matrix is correctly set'));
+
+ # check error with wrong dimension
+ checkException(a <- new(class, W=matrix(1,n,r+1), H=matrix(1,r,m), ...), msg('Error if incompatible dimensions (W)'))
+ checkException(a <- new(class, W=matrix(1,n,r), H=matrix(1,r+1,m), ...), msg('Error if incompatible dimensions (H)'))
+}
+
+#' Tests the class 'NMF'
+test.class.NMFstd <- function(){
+ check.NMF.class('NMFstd')
+}
+
+#' Tests the class 'NMFns'
+test.class.NMFns <- function(){
+ # with no parameter
+ check.NMF.class('NMFns')
+
+ # with a parameter
+ t <- 0.8
+ check.NMF.class('NMFns', theta=t)
+
+ # test specific stuff
+ a <- new('NMFns', theta=t)
+ checkIdentical(a at theta, t, 'Slot theta is correctly set')
+ checkException(a <- new('NMFns', theta=-1), 'Negative value of theta throws an exception')
+ checkException(a <- new('NMFns', theta=1.2), 'Value of theta > 1 throws an exception')
+
+ # test equivalence with standard model when theta=0
+ set.seed(.TestSeed)
+ n <- 50; m <- 10; r <- 3
+ W <- rmatrix(n, r)
+ H <- rmatrix(r, m)
+ a.ns <- new('NMFns', W=W, H=H, theta=0)
+ a.std <- new('NMFstd', W=W, H=H)
+ checkIdentical(fitted(a.ns), fitted(a.std), 'Values fitted correspond to standard model if theta=0')
+
+ # check method smoothing
+ a.ns <- new('NMFns', W=W, H=H, theta=0.4)
+ s <- smoothing(a.ns)
+ checkEquals(dim(s), c(r, r), 'Smoothing matrix: dimension are correct')
+ checkTrue( all(s >= 0), 'Smoothing matrix: all entries are nonnegative')
+ checkEquals( rowSums(s), rep(1, r), 'Smoothing matrix: sum of rows are ones')
+ checkEquals( colSums(s), rep(1, r), 'Smoothing matrix: sum of columns are ones')
+ checkEquals( fitted(a.ns), basis(a.ns) %*% s %*% coef(a.ns), 'Fitted values are correct (product of basis, smoothing and coef).')
+
+ #TODO: put this in file test.algorithms.R
+# n <- 100; m <- 20; r <- 3
+# set.seed(.TestSeed)
+# V <- syntheticNMF(n, r, m, noise=TRUE) # add noise for stability
+# set.seed(.TestSeed)
+# res.std <- fit(nmf(V, r, 'brunet', seed='nndsvd'))
+# set.seed(.TestSeed)
+# res.ns <- fit(nmf(V, r, 'ns', seed='nndsvd', theta=0))
+
+ #checkEqualsNumeric(basis(res.ns), basis(res.std), 'W from nsNMF(theta=0) are the same as the ones from the standard model')
+ #checkEqualsNumeric(coef(res.ns), coef(res.std), 'H from nsNMF(theta=0) are the same as the ones from the standard model')
+}
+
+test.nmfModel <- function(){
+
+ set.seed(.TestSeed)
+
+ # define some dimensions to use as template
+ n <- as.integer(25); m <- as.integer(10); r <- as.integer(3);
+
+ check.empty.model <- function(x, n, m, r, msg, class='NMFstd'){
+ check.object(x, n, m, r, msg, class)
+ checkOnlyNAs(x, msg)
+ }
+
+ # check basic errors
+ checkException(nmfModel(numeric()), 'Error if negative rank')
+ checkException(nmfModel(c(1,2)), 'Error if rank of length != 1')
+ checkException(nmfModel(r, -1), 'Error if negative target dimension')
+ checkException(nmfModel(r, 1:3), 'Error if target dimension of length > 2')
+ checkException(nmfModel(r, 1, -1), 'Error if target ncol negative')
+ checkException(nmfModel(r, 1, 1:2), 'Error if target ncol of length > 1')
+ checkException(nmfModel(r, 1, matrix(1,2,2)), 'Error if target ncol not vector')
+
+ # constructor of empty model
+ check.empty.model(nmfModel(), 0, 0, 0, 'Constructor with no arguments returns empty model')
+ # constructor of empty model with ncol specified
+ check.empty.model(nmfModel(ncol=5), 0, 5, 0, 'Constructor with only with ncol specified')
+ # constructor with missing target
+ check.empty.model(nmfModel(r), 0, 0, r, 'Constructor with missing target')
+ # constructor using dimension vector
+ check.empty.model(nmfModel(r, c(n,m)), n, m, r, 'Constructor with dimensions as a vector')
+ # constructor using separate dimensions
+ check.empty.model(nmfModel(r, n, m), n, m, r, 'Constructor with separate dimensions')
+ # constructor with single dimension
+ check.empty.model(nmfModel(r, n), n, n, r, 'Constructor with single dimension (nrow)')
+ # constructor with single dimension (ncol)
+ check.empty.model(nmfModel(r, ncol=m), 0, m, r, 'Constructor with single dimension (ncol)')
+ #TODO: check exceptions if passing negative numbers
+
+ # constructor using a target matrix
+ msg <- function(...) paste('Constructor with target matrix -', ...)
+ V <- rmatrix(n, m)
+ check.empty.model(nmfModel(r, V), n, m, r, msg('second argument'))
+ check.empty.model(nmfModel(V, r), n, m, r, msg('first argument'))
+ check.empty.model(nmfModel(V), n, m, 0, msg('single argument'))
+ dimnames(V) <- list(rows=letters[1:n], cols=letters[1:m])
+ checkIdentical(dimnames(nmfModel(V)), c(dimnames(V), list(NULL)), msg('dimnames are correctly set'))
+ checkIdentical(dimnames(nmfModel(V, use.names=FALSE)), NULL, msg('dimnames are not used if use.names=FALSE'))
+
+
+ w <- rmatrix(n, r); h <- rmatrix(r, m)
+ # constructor supplying matrices W and H
+ msg <- function(...) paste('Constructor with target rank and both basis and coef matrices -', ...)
+ a <- nmfModel(r, W=w, H=h)
+ check.object(a, n, m, r, msg())
+ checkIdentical(basis(a), w, msg('basis matrix is correctly set'))
+ checkIdentical(coef(a), h, msg('coef matrix is correctly set'))
+ checkException(nmfModel(r, c(n+1,m), W=w, H=h), msg('error if bad number of rows in basis matrix'))
+ checkException(nmfModel(r, c(n,m), W=w[,-r], H=h), msg('error if bad number of columns in basis matrix'))
+ checkException(nmfModel(r, c(n,m), W=w, H=h[-r,]), msg('error if bad number of rows in coef matrix'))
+ checkException(nmfModel(r, c(n,m+1), W=w, H=h), msg('error if bad number of columns in coef matrix'))
+
+ # reducing dimensions
+ rmsg <- function(...) msg('reduce rank -', ...)
+ a <- nmfModel(r-1, W=w, H=h)
+ check.object(a, n, m, r-1, rmsg('dimensions are OK'))
+ checkIdentical(basis(a), w[,-r], rmsg("entries for basis are OK"))
+ checkIdentical(coef(a), h[-r,], rmsg("entries for coef are OK"))
+
+ rmsg <- function(...) msg('reduce nrow -', ...)
+ a <- nmfModel(r, n-1, W=w, H=h)
+ check.object(a, n-1, m, r, rmsg('dimensions are OK'))
+ checkIdentical(basis(a), w[-n,], rmsg("entries for basis are OK"))
+ checkIdentical(coef(a), h, rmsg("entries for coef are OK"))
+
+ rmsg <- function(...) msg('reduce ncol -', ...)
+ a <- nmfModel(r, ncol=m-1, W=w, H=h)
+ check.object(a, n, m-1, r, rmsg('dimensions are OK'))
+ checkIdentical(basis(a), w, rmsg("entries for basis are OK"))
+ checkIdentical(coef(a), h[,-m], rmsg("entries for coef are OK"))
+
+ # constructor supplying only matrices W and H
+ msg <- function(...) paste('Constructor with only basis and coef matrices (named arguments) -', ...)
+ a <- nmfModel(W=w, H=h)
+ check.object(a, n, m, r, msg())
+ checkIdentical(basis(a), w, msg('basis matrix is correctly set'))
+ checkIdentical(coef(a), h, msg('coef matrix is correctly set'))
+ checkException(nmfModel(W=matrix(1, n, r+1), H=matrix(1, r, m)), msg('error if incompatible dimensions (1)'))
+ checkException(nmfModel(W=matrix(1, n, r), H=matrix(1, r+1, m)), msg('error if incompatible dimensions (2)'))
+ # constructor supplying only matrices W and H and not naming the arguments
+ msg <- function(...) paste('Constructor with only basis and coef matrices (unamed argument) -', ...)
+ a <- nmfModel(w, h)
+ check.object(a, n, m, r, msg())
+ checkIdentical(basis(a), w, msg('basis matrix is correctly set'))
+ checkIdentical(coef(a), h, msg('coef matrix is correctly set'))
+ checkException(nmfModel(matrix(1, n, r+1), matrix(1, r, m)), msg('error if incompatible dimensions (1)'))
+ checkException(nmfModel(matrix(1, n, r), matrix(1, r+1, m)), msg('error if incompatible dimensions (2)'))
+
+ # constructor supplying only W and target rank
+ msg <- function(...) paste('Constructor with target rank and basis matrix only -', ...)
+ a <- nmfModel(r, W=w)
+ check.object(a, n, 0, r, msg())
+ checkIdentical(basis(a), w, msg('basis matrix is correctly set'))
+ checkTrue(all(is.na(coef(a))), msg('only NA in coef matrix'))
+ checkException(nmfModel(r+1, W=w), msg('error if smaller number of columns in basis matrix'))
+
+ # reducing dimensions
+ rmsg <- function(...) msg('reduce rank -', ...)
+ a <- nmfModel(r-1, W=w)
+ check.object(a, n, 0, r-1, rmsg('dimensions are OK'))
+ checkIdentical(basis(a), w[,-r], rmsg("entries for basis are OK"))
+ checkTrue(all(is.na(coef(a))), rmsg('only NA in coef matrix'))
+ checkException(nmfModel(r-1, W=w, force.dim=FALSE), msg('error if greater number of columns in basis matrix and force.dim=FALSE'))
+
+ # constructor supplying only W
+ msg <- function(...) paste('Constructor with basis matrix only -', ...)
+ a <- nmfModel(W=w)
+ check.object(a, n, 0, r, msg())
+ checkIdentical(basis(a), w, msg('basis matrix is correctly set'))
+ checkTrue(all(is.na(coef(a))), msg('only NA in coef matrix'))
+
+ # constructor supplying only H and target rank
+ msg <- function(...) paste('Constructor with target rank and coef matrix only -', ...)
+ a <- nmfModel(r, H=h)
+ check.object(a, 0, m, r, msg())
+ checkIdentical(coef(a), h, msg('coef matrix is correctly set'))
+ checkTrue(all(is.na(basis(a))), msg('only NA in basis matrix'))
+ checkException(nmfModel(r+1, H=h), msg('error if smaller number of rows in coef matrix'))
+
+ # reducing dimensions
+ rmsg <- function(...) msg('reduce rank -', ...)
+ a <- nmfModel(r-1, H=h)
+ check.object(a, 0, m, r-1, rmsg('dimensions are OK'))
+ checkIdentical(coef(a), h[-r,], rmsg('coef matrix is correctly set'))
+ checkTrue(all(is.na(basis(a))), rmsg('only NA in basis matrix'))
+ checkException(nmfModel(r-1, H=h, force.dim=FALSE), msg('error if greater number of rows in coef matrix and force.dim=FALSE'))
+
+ # constructor supplying only H
+ msg <- function(...) paste('Constructor with coef matrix only -', ...)
+ a <- nmfModel(H=h)
+ check.object(a, 0, m, r, msg())
+ checkIdentical(coef(a), h, msg('coef matrix is correctly set'))
+ checkTrue(all(is.na(basis(a))), msg('only NA in basis matrix'))
+
+ # constructor supplying W and target dimensions
+ msg <- function(...) paste('Constructor with basis matrix and both target dimensions -', ...)
+ a <- nmfModel(r, n, m, W=w)
+ check.object(a, n, m, r, msg())
+ checkIdentical(basis(a), w, rmsg("entries for basis are OK"))
+ checkTrue(all(is.na(coef(a))), rmsg('only NA in coef matrix'))
+
+ rmsg <- function(...) msg('reduce nrow -', ...)
+ a <- nmfModel(r, n-1, m, W=w)
+ check.object(a, n-1, m, r, rmsg('dimensions are OK'))
+ checkIdentical(basis(a), w[-n,], rmsg("entries for basis are OK"))
+ checkTrue(all(is.na(coef(a))), rmsg('only NA in coef matrix'))
+
+ checkException(nmfModel(r, n+1, m, W=w), msg('error if smaller number of rows in basis matrix'))
+ checkException(nmfModel(r, n-1, W=w, force.dim=FALSE), msg('error if greater number of rows in basis matrix and force.dim=FALSE'))
+ checkException(nmfModel(r+1, n, m, W=w), msg('error if smaller number of columns in basis matrix'))
+
+ # constructor supplying H and target dimensions
+ msg <- function(...) paste('Constructor with coef matrix and both target dimensions -', ...)
+ a <- nmfModel(r, n, m, H=h)
+ check.object(a, n, m, r, msg())
+ checkTrue(all(is.na(basis(a))), msg('only NA in basis matrix'))
+ checkIdentical(coef(a), h, msg('coef matrix is correctly set'))
+
+ rmsg <- function(...) msg('reduce ncol -', ...)
+ a <- nmfModel(r, n , m-1, H=h)
+ check.object(a, n, m-1, r, rmsg('dimensions are OK'))
+ checkIdentical(coef(a), h[,-m], rmsg('coef matrix is correctly set'))
+ checkTrue(all(is.na(basis(a))), rmsg('only NA in basis matrix'))
+
+ checkException(nmfModel(r+1, n, m, H=h), msg('error if smaller number of rows in coef matrix'))
+ checkException(nmfModel(r, n, m-1, H=h, force.dim=FALSE), msg('error if greater number of columns in coef matrix and force.dim=FALSE'))
+ checkException(nmfModel(r, n, m+1, H=h), msg('error if smaller number of columns in coef matrix'))
+
+ # check basisnames passage
+
+ check.model.dimnames <- function(x, dn, title){
+ msg <- function(...) paste(title, '-', ...)
+ checkIdentical(dimnames(x), dn, msg("dimnames are correct"))
+ checkIdentical(colnames(basis(x)), dn[[3]], msg("colnames of basis matrix are correct"))
+ checkIdentical(rownames(coef(x)), dn[[3]], msg("rownames of coef matrix are correct"))
+ }
+
+ dn <- letters[1:nrow(h)]
+ h2 <- h; rownames(h2) <- dn;
+ a <- nmfModel(r, H=h2)
+ check.model.dimnames(a, list(NULL, NULL, dn), "Basis names are passed from input coef matrix")
+
+ w2 <- w; colnames(w2) <- dn;
+ a <- nmfModel(r, W=w2)
+ check.model.dimnames(a, list(NULL, NULL, dn), "Basis names are passed from input basis matrix")
+
+ w2 <- w; colnames(w2) <- dn;
+ h2 <- h; rownames(h2) <- dn;
+ a <- nmfModel(W=w2, H=h2)
+ check.model.dimnames(a, list(NULL, NULL, dn), "Basis names are used unchanged if equal in input basis and coef matrices")
+
+ msg <- function(...) paste("Basis names from input basis matrix are used to order the components - ", ...)
+ w2 <- w; colnames(w2) <- dn;
+ h2 <- h; rownames(h2) <- rev(dn);
+ a <- nmfModel(W=w2, H=h2)
+ check.model.dimnames(a, list(NULL, NULL, dn), msg("rownames of input basis are enforced"))
+ checkIdentical(basis(a), w2, msg("basis unchanged"))
+ checkIdentical(coef(a), h2[nrow(h):1,], msg("coef entries are reordered"))
+
+ msg <- function(...) paste("Basis names from input basis matrix are NOT used to order the components if argument order.basis=FALSE - ", ...)
+ w2 <- w; colnames(w2) <- dn;
+ h2 <- h; rownames(h2) <- rev(dn);
+ a <- nmfModel(W=w2, H=h2, order.basis=FALSE)
+ check.model.dimnames(a, list(NULL, NULL, dn), msg("rownames of input basis are enforced"))
+ checkIdentical(basis(a), w2, msg("basis unchanged"))
+ checkEquals(coef(a), h2, msg("coef entries are not ordered"), check.attributes=FALSE)
+
+ msg <- function(...) paste("Basis names from input basis matrix are forced onto to the coef matrix - ", ...)
+ w2 <- w; colnames(w2) <- dn;
+ h2 <- h; rownames(h2) <- paste(letters[1:nrow(h)], 2);
+ a <- nmfModel(W=w2, H=h2)
+ check.model.dimnames(a, list(NULL, NULL, dn), msg("rownames of input basis are enforced"))
+ checkIdentical(basis(a), w2, msg("basis is unchanged"))
+ checkEquals(coef(a), h2, msg("coef entries are correct"), check.attributes=FALSE)
+}
+
+test.dimensions <- function(){
+ # define some dimensions to use as template
+ n <- as.integer(50); m <- as.integer(10); r <- as.integer(3);
+
+ # create an NMF object
+ a <- nmfModel(r, n, m)
+
+ # check the dimensions
+ checkIdentical(dim(a), c(n, m, r), "Function 'dim' is OK")
+
+ # check the row number
+ checkIdentical(nrow(a), n, "Function 'nrow' is OK")
+
+ # check the column number
+ checkIdentical(ncol(a), m, "Function 'ncol' is OK")
+
+ # check the number of basis
+ checkIdentical(nbasis(a), r, "Function 'nbasis' is OK")
+
+}
+
+check.dimnames <- function(x, dn, msg){
+
+ checkIdentical(dimnames(x), dn, paste(msg, '-',"dimnames returns correct value"))
+ checkIdentical(dimnames(x)[c(1,3)], dimnames(basis(x)), paste(msg, '-', "dimnames returns value consistent with basis"))
+ checkIdentical(dimnames(x)[c(3,2)], dimnames(coef(x)), paste(msg, '-', "dimnames returns value consistent with coef"))
+
+ checkIdentical(rownames(x), dn[[1]], paste(msg, '-', "rownames returns correct value"))
+ checkIdentical(rownames(basis(x)), rownames(x), paste(msg, '-', "rownames returns same value as rownames(basis)"))
+
+ checkIdentical(colnames(x), dn[[2]], paste(msg, '-', "colnames returns correct value"))
+ checkIdentical(colnames(coef(x)), colnames(x), paste(msg, '-', "colnames returns same value as colnames(basis)"))
+
+ checkIdentical(basisnames(x), dn[[3]], paste(msg, '-', "basisnames returns correct value"))
+ checkIdentical(colnames(basis(x)), basisnames(x), paste(msg, '-', "basisnames returns same value as colnames(basis)"))
+ checkIdentical(rownames(coef(x)), basisnames(x), paste(msg, '-', "basisnames returns same value as rownames(coef)"))
+
+}
+
+test.dimnames <- function(){
+
+ # set random seed
+ set.seed(.TestSeed)
+ # define some dimensions to use as template
+ n <- 20; m <- 10; r <- 3;
+ # generate matrices
+ w <- rmatrix(n, r); h <- rmatrix(r, m)
+
+ M <- nmfModel(r, n, m)
+
+ # check errors
+ a <- M
+ checkException({dimnames(a) <- 1:n}, 'set to vector')
+ checkException({dimnames(a) <- list(seq(n-1))}, 'Error of wrong dimension (nrow-1)')
+ checkException({dimnames(a) <- list(seq(n+1))}, 'Error of wrong dimension (nrow+1)')
+
+ # check with no elements
+ msg <- function(...) paste('Dimnames with 2 elements -', ...)
+ a <- M
+ check.dimnames(a, NULL, 'No dimnames => NULL')
+ check.dimnames({dimnames(a) <- NULL; a}, NULL, msg('set to NULL'))
+ check.dimnames({dimnames(a) <- list(); a}, NULL, msg('set to list()'))
+
+ # check with one elements
+ msg <- function(...) paste('Dimnames with 1 element -', ...)
+ a <- M
+ dn <- list(letters[1:nrow(a)])
+ dn.name <- setNames(dn, 'rows')
+ check.dimnames({a <- M; dimnames(a) <- dn; a}, c(dn, list(NULL, NULL)), msg('Set dimnames'))
+ check.dimnames({a <- M; dimnames(a) <- dn.name; a}, c(dn.name, list(NULL, NULL)), msg('Set with names'))
+
+ check.dimnames({a <- M; rownames(a) <- dn[[1]]; a}, c(dn, list(NULL, NULL)), msg('Set rownames'))
+ check.dimnames({a <- M; colnames(a) <- letters[1:ncol(a)]; a}, list(NULL, letters[1:ncol(a)], NULL), msg('Set colnames'))
+ check.dimnames({a <- M; basisnames(a) <- letters[1:nbasis(a)]; a}, list(NULL, NULL, letters[1:nbasis(a)]), msg('Set basisnames'))
+ check.dimnames({dimnames(a) <- NULL; a}, NULL, msg('Reset to NULL'))
+
+ # check with two elements
+ msg <- function(...) paste('Dimnames with 2 elements -', ...)
+ a <- M
+ dn <- list(letters[1:nrow(a)], letters[seq(nrow(a)+1, nrow(a)+ncol(a))])
+ dn.name <- setNames(dn, c('rows', 'cols'))
+ check.dimnames({dimnames(a) <- dn; a}, c(dn, list(NULL)), msg('Set dimnames'))
+ check.dimnames({dimnames(a) <- NULL; a}, NULL, msg('Reset to NULL'))
+ check.dimnames({dimnames(a) <- dn.name; a}, c(dn.name, list(NULL)), msg('Set with names'))
+ check.dimnames({dimnames(a) <- NULL; a}, NULL, msg('Reset to NULL (2)'))
+
+ # check with three elements
+ msg <- function(...) paste('Dimnames with 3 elements -', ...)
+ a <- M
+ dn <- list(letters[1:nrow(a)], letters[seq(nrow(a)+1, nrow(a)+ncol(a))], letters[seq(nrow(a)+ncol(a)+1, nrow(a)+ncol(a)+nbasis(a))])
+ dn.name <- setNames(dn, c('rows', 'cols', 'basis'))
+ check.dimnames({dimnames(a) <- dn; a}, dn, msg('Set dimnames'))
+ check.dimnames({dimnames(a) <- NULL; a}, NULL, msg('Reset to NULL'))
+ check.dimnames({dimnames(a) <- dn.name; a}, dn.name, msg('Set with names'))
+ check.dimnames({dimnames(a) <- NULL; a}, NULL, msg('Reset to NULL (2)'))
+}
+
+#' Unit test for accessor method: \code{basis}
+test.basis <- function(){
+
+ # define some dimensions to use as template
+ n <- 50; m <- 10; r <- 3;
+
+ # create an empty object
+ a <- nmfModel(r);
+
+ # get factor W
+ checkTrue(is.same(basis(a), a at W), "Method 'basis' correctly returns slot W");
+
+ # set factor W
+ W.ext <- matrix(1, n, r)
+ basis(a) <- W.ext
+ checkIdentical(a at W, W.ext, "Method 'basis<-' correctly sets slot W");
+ #checkException(basis(a) <- matrix(1, n, r+1), "Error if setting basis with a matrix of incompatible dimensions");
+}
+
+#' Unit test for accessor method: \code{coef}
+test.coef <- function(){
+
+ # define some dimensions to use as template
+ n <- 50; m <- 10; r <- 3;
+
+ # create an empty object
+ a <- nmfModel(r);
+
+ # get factor H
+ checkTrue(is.same(coef(a), a at H), "Method 'coef' correctly returns slot H");
+
+ # set factor H
+ ext <- matrix(1, r, m)
+ coef(a) <- ext
+ checkIdentical(a at H, ext, "Method 'coef<-' correctly sets slot H");
+ #checkException(coef(a) <- matrix(1, r+1, m), "Error if setting coef with a matrix of incompatible dimensions");
+}
+
+test.NMF.rnmf <- function(){
+
+ # define some dimensions to use as template
+ n <- 50; m <- 10; r <- 3;
+
+ # create an empty NMF object
+ a <- nmfModel(r)
+
+ # check parameter validity checks
+ set.seed(.TestSeed)
+ checkException(rnmf(a, as.numeric(NA)), 'Error thrown if single NA value')
+ checkException(rnmf(a, as.numeric(c(1,NA))), 'Error thrown if some NA value')
+ checkException(rnmf(a, c(1,2,3)), 'Error thrown if some length greater than 2')
+ checkException(rnmf(a, numeric()), 'Error thrown if some length is 0')
+
+ # create a random NMF of given dimension
+ set.seed(.TestSeed)
+ a <- rnmf(r, n, m)
+ checkPlot(basicHM(basis(a)), 'Random NMF basis (target dimension)')
+ checkPlot(basicHM(coef(a)), 'Random NMF coef (target dimension)')
+ # check the NMF dimensions
+ checkEquals(nrow(a), n, 'number of rows matches target dimension')
+ checkEquals(ncol(a), m, 'number of columns matches target dimension')
+ checkEquals(nbasis(a), r, 'number of basis matches target dimension')
+ # check equivalence of calls
+ set.seed(.TestSeed)
+ checkIdentical(a, rnmf(r, c(n, m)), "calling with numeric target of length 2 is equivalent to separate dimensions")
+ set.seed(.TestSeed)
+ checkIdentical(a, rnmf(r, n, m), "calling with numeric target of length 2 is equivalent to separate dimensions")
+
+ # create a random NMF based on a template NMF
+ a <- nmfModel(r, n, m)
+ set.seed(.TestSeed)
+ b <- rnmf(a)
+ checkPlot(basicHM(basis(b)), 'Random NMF basis (target NMF)')
+ checkPlot(basicHM(coef(b)), 'Random NMF coef (target NMF)')
+ # check the NMF dimensions
+ checkEquals(nrow(a), nrow(b), 'number of rows matches NMF target')
+ checkEquals(ncol(a), ncol(b), 'number of columns matches NMF target')
+ checkEquals(nbasis(a), nbasis(b), 'number of basis matches NMF model')
+
+ # create a random NMF based on a target ExpressionSet
+ set.seed(.TestSeed)
+ max.entry <- 100
+ V <- new('ExpressionSet', exprs=rmatrix(n, m, min=0, max=max.entry))
+ a <- nmfModel(r, n, m)
+ check.object(a <- rnmf(a, V), n, m, r, 'NMFobject + target ExpressionSet')
+ check.dimnames(a, c(dimnames(exprs(V)), list(NULL)), 'NMFobject + target ExpressionSet')
+ check.object(a <- rnmf(r, V), n, m, r, 'rank + target ExpressionSet')
+ check.dimnames(a, c(dimnames(exprs(V)), list(NULL)), 'rank + target ExpressionSet')
+
+ # create a random NMF based on a target matrix
+ set.seed(.TestSeed)
+ max.entry <- 100
+ V <- rmatrix(n, m, min=0, max=max.entry)
+ a <- nmfModel(r, n, m)
+ a <- rnmf(a, V)
+ checkPlot(basicHM(basis(a)), 'Random NMF basis (target matrix)')
+ checkPlot(basicHM(coef(a)), 'Random NMF coef (target matrix)')
+ # check the NMF dimensions
+ checkEquals(nrow(a), n, 'number of rows matches matrix target')
+ checkEquals(ncol(a), m, 'number of columns matches matrix target')
+ checkEquals(nbasis(a), r, 'matrix target: number of basis matches NMF model')
+ # check maximum value
+ msg <- function(...) paste('Set max in target matrix -', ...)
+ .check_max <- function(x, max.entry){
+ checkTrue( max(basis(a)) <= max.entry, msg("Basis maximum entry is OK (<=)"))
+ checkTrue( max(basis(a)) >= max.entry/2, msg("Basis maximum entry is OK (>=)"))
+ checkTrue( max(coef(a)) <= max.entry, msg("Coef maximum entry is OK (<=)"))
+ checkTrue( max(coef(a)) >= max.entry/2, msg("Coef maximum entry is OK (>=)"))
+ }
+ .check_max(a, max.entry)
+ # check dimnames
+ dn <- list(rows=letters[1:nrow(V)], cols=letters[seq(25-ncol(V)+1,25)])
+ dimnames(V) <- dn
+ check.dimnames(rnmf(a, V), c(dn, list(NULL)), "rnmf on target matrix with dimnames: dimnames are passed")
+ check.dimnames(rnmf(a, V, use.dimnames=FALSE), NULL, "rnmf on target matrix with dimnames and use.dimnames=FALSE: dimnames are not passed")
+
+ # setting maximum on NMFOffset model
+ msg <- function(...) paste('Set max by argument -', ...)
+ set.seed(.TestSeed)
+ a <- rnmf(r, V, model='NMFOffset')
+ .check_max(a, max.entry)
+
+ # setting maximum entry by argument
+ msg <- function(...) paste('Set max by argument -', ...)
+ set.seed(.TestSeed)
+ max.entry <- 5
+ a <- rnmf(r, n, m, dist=list(max=max.entry))
+ .check_max(a, max.entry)
+
+
+}
+
+#' Tests synthetic data generation
+test.syntheticNMF <- function(){
+
+ # define sizes
+ n <- 100; m <- 20; r <- 3
+
+ # standard
+ set.seed(.TestSeed)
+ d <- syntheticNMF(n, r, m)
+ checkPlot(basicHM(d), 'Synthetic data plain')
+
+ # with offset
+ set.seed(.TestSeed)
+ n.offset <- 15
+ o <- c(rep(1, n.offset), rep(0, n-n.offset))
+ d <- syntheticNMF(n, r, m, offset=o)
+ # the function should throw an error when called with an offset of wrong length
+ checkException(syntheticNMF(n, r, m, offset=o[-1]))
+ checkPlot(basicHM(d), 'Synthetic data offset')
+
+ # with noise
+ set.seed(.TestSeed)
+ d <- syntheticNMF(n, r, m, noise=TRUE)
+ checkPlot(basicHM(d), 'Synthetic data with noise')
+
+ # with offset and noise
+ set.seed(.TestSeed)
+ d <- syntheticNMF(n, r, m, offset=o, noise=TRUE)
+ checkPlot(basicHM(d), 'Synthetic data with offset and noise')
+}
+
+# Sparseness
+test.sparseness <- function(){
+
+ # local function to check bounds of sparseness
+ checkBounds <- function(s){
+ checkTrue(s >= 0, 'greater than 0')
+ checkTrue(s <= 1, 'lower than 1')
+ }
+
+ # test with a perfectly non-sparse vector (constant vector)
+ x <- rep(1, 100)
+ s <- sparseness(x)
+
+ # check values
+ checkBounds(s)
+ checkEqualsNumeric(s, 0, 'should be 0')
+
+ # test with a perfectly sparse vector
+ x <- c(1, rep(0, 100))
+ s <- sparseness(x)
+
+ # check values
+ checkBounds(s)
+ checkEqualsNumeric(s, 1)
+
+ # define sizes
+ n <- 100; m <- 20; r <- 3
+
+ # test with a random matrix (not necessarly positive)
+ set.seed(.TestSeed)
+ V <- matrix(rnorm(n*m), n, m)
+ s <- sparseness(V)
+ #check values
+ checkBounds(s)
+
+ # test with a random NMF object
+ a <- nmfModel(r, V)
+ set.seed(.TestSeed)
+ a <- rnmf(a, V)
+ s <- sparseness(a)
+ # check return vector
+ checkTrue( length(s) == 2, "Method 'sparseness' returns a 2-length vector" )
+ #check values
+ checkBounds(s[1])
+ checkBounds(s[2])
+}
+
+# Clusters
+test.predict <- function(){
+
+ # define some dimensions
+ n <- 100; m <- 20; r <- 3
+
+ .msg <- NULL
+ mess <- function(...) paste(.msg, ':', ...)
+
+ # test on a known matrix
+ .msg <- 'Artificial matrix'
+ V <- matrix(c( c(1, rep(0,n-1)), c(0, 1, rep(0,n-2)), rep(c(0,0,1, rep(0, n-3)), m-2) ) , n, m)
+ # compute clusters
+ res <- .predict.nmf(t(V))
+ # check the result
+ checkEquals(res, as.factor(c(1, 2, rep(3, m-2))), mess('Return known clusters'))
+
+ # test on a random matrix
+ .msg <- 'Random matrix'
+ set.seed(.TestSeed)
+ V <- matrix(sapply(sample(n), function(i){x <- rep(0, n); x[i] <- 1; x}), n, m)
+
+ # compute clusters
+ res <- .predict.nmf(V)
+ # check the result
+ checkTrue( is.factor(res), mess('Result is a factor'))
+ checkTrue( length(res) == nrow(V), mess('Result is the right size' ))
+ checkTrue( nlevels(res) == ncol(V), mess('Result has the right number of levels' ))
+
+ # test on a random NMF
+ .msg <- 'NMF model'
+ a <- nmfModel(r, V)
+ set.seed(.TestSeed)
+ a <- rnmf(a)
+
+ res <- predict(a, 'samples')
+ # check the result
+ checkTrue( is.factor(res), mess('Result is a factor'))
+ checkTrue( length(res) == ncol(a), mess('Result has right size' ))
+ checkTrue( nlevels(res) == nbasis(a), mess('Result has right number of levels' ))
+
+ # factor
+ .msg <- 'Factor'
+ res <- predict(a, 'features')
+ # check the result
+ checkTrue( is.factor(res), mess('Result is a factor'))
+ checkTrue( length(res) == nrow(a), mess('Result has right size' ))
+ checkTrue( nlevels(res) == nbasis(a), mess('Result has right number of levels' ))
+
+}
+
+# Purity
+test.purity <- function(){
+
+ # local function to check bounds of purity
+ checkBounds <- function(x){
+ checkTrue(x >= 0, 'greater than 0')
+ checkTrue(x <= 1, 'lower than 1')
+ }
+
+ # generate factor
+ x <- as.factor(c(rep(1,5), rep(2,10), rep(3,15)))
+
+ # compute perfect clustering
+ p <- purity(x, x)
+ checkBounds(p)
+ checkEqualsNumeric(p, 1)
+
+ # compute random clustering
+ set.seed(.TestSeed)
+ p <- purity(as.factor(sample(x)), x)
+ checkBounds(p)
+}
+
+# Entropy
+test.entropy <- function(){
+
+ # local function to check bounds of entropy
+ checkBounds <- function(x){
+ checkTrue(x >= 0, 'greater than 0')
+ checkTrue(x <= 1, 'lower than 1')
+ }
+
+ # generate factor
+ x <- as.factor(c(rep(1,5), rep(2,10), rep(3,15)))
+
+ # comppute perfect entropy
+ e <- entropy(x, x)
+ checkBounds(e)
+ checkEqualsNumeric(e, 0)
+
+ # compute random clustering
+ set.seed(.TestSeed)
+ e <- entropy(as.factor(sample(x)), x)
+ checkBounds(e)
+
+}
+
+#' Tests the distance method
+test.deviance <- function(){
+
+ # define some dimensions and matrices
+ n <- 10; m <- 5;
+ set.seed(.TestSeed)
+ y <- rmatrix(n, m) # random matrix 1
+ x <- rnmf(nmfModel(3, y))
+
+ # check default is no computation
+ checkEquals( deviance(x, y), as.numeric(NA), 'With no method: NA')
+ # check error if undefined method
+ checkException( deviance(x, y, 'toto'), 'Error if undefined method')
+
+ # check if works when passing a function name
+ norm1 <- function(x, y){ sum(abs(fitted(x)-y)) } # local function
+ # generate a random function name
+ funname <- paste('test', paste(sample(1:9, 20, replace=TRUE), collapse=''), sep='.')
+ assign(funname, norm1, envir=.GlobalEnv)
+ on.exit(rm(list=funname, envir=.GlobalEnv), add=TRUE)
+ #TODO: make it work without assigning in .GloablEnv
+ checkTrue( deviance(x, y, norm1) > 0, 'Works with a user-defined function in .GlobalEnv')
+ checkTrue( deviance(x, y, funname) > 0, 'Works with name of a user-defined function .GlobalEnv')
+
+ # check euclidean distance
+ meth <- 'euclidean'
+ #checkEqualsNumeric( deviance(x, x, meth), 0, 'Euclidean: separation')
+ checkTrue( deviance(x, y, meth) > 0, 'Euclidean: positive')
+ checkEqualsNumeric( deviance(x, y, meth), sum((fitted(x) - y)^2)/2, 'Euclidean: OK')
+
+ # check Kullback-Leibler divergence
+ meth <- 'KL'
+ #checkEqualsNumeric( deviance(x, x, meth), 0, 'KL: separation')
+ checkTrue( deviance(x, y, meth) > 0, 'KL: positive')
+ #checkTrue( deviance(x, y, meth) != deviance(y, x, meth), 'KL: not symetric')
+ # check if not infinite when there is some zero entries in the target matrix
+ z <- y; z[1,] <- 0
+ checkTrue( deviance(x, z, meth) != Inf, 'Ok if some zeros in the target' )
+ # check if infinite when there is some zero entries in the second term
+ z <- x; basis(z)[1,] <- 0
+ checkIdentical( deviance(z, y, meth), Inf, 'Infinite if some zeros in the estimate' )
+}
+
+
+#' Tests the connectivity method
+test.connectivity <- function(){
+ # define some dimensions to use as template
+ n <- 50; m <- 10; r <- 3;
+
+ # build random NMF
+ set.seed(.TestSeed)
+ a <- nmfModel(r, c(n,m))
+ a <- rnmf(a)
+ con <- connectivity(a)
+
+ # check properties of the connectivity matrix
+ checkTrue( is.matrix(con), 'The result is a matrix')
+ checkTrue( all(con %in% c(0,1)), 'All entries are 0 or 1')
+ checkTrue( all(t(con) == con) , 'The connectivity matrix is symmetric')
+
+}
+
+#' test subsetting function
+test.subset <- function(){
+
+ # create a random NMF object
+ n <- 30; r <- 5; p <- 20
+ a <- nmfModel(r, n, p)
+ a <- rnmf(a)
+
+ # fake subset
+ checkTrue(identical(a[], a), "subset [] is OK (identical)")
+ checkTrue(identical(a[,], a), "subset [,] is OK (identical)")
+ checkTrue(identical(a[TRUE,], a), "subset [TRUE,] is OK (identical)")
+ checkTrue(identical(a[,TRUE], a), "subset [,TRUE] is OK (identical)")
+ checkTrue(identical(a[TRUE,TRUE], a), "subset [TRUE,TRUE] is OK (identical)")
+ checkTrue(identical(a[,,TRUE], a), "subset [,,TRUE] is OK (identical)")
+ checkTrue(identical(a[TRUE,TRUE,TRUE], a), "subset [TRUE,TRUE,TRUE] is OK (identical)")
+ # with NULL
+ checkTrue(identical(a[NULL,], a[0,]), "subset [NULL,] is OK")
+ checkTrue(identical(a[,NULL], a[,0]), "subset [,NULL] is OK")
+ checkTrue(identical(a[NULL,NULL], a[0,0]), "subset [NULL,NULL] is OK")
+ checkTrue(identical(a[NULL,NULL,NULL], a[0,0,0]), "subset [NULL,NULL,NULL] is OK")
+ checkException(a[,,], "Error when called with [,,]")
+
+ # subset on features
+ checkEquals(dim(a[1,]), c(1, p, r), "subset 1 feature is OK (dim)")
+ checkEquals(basis(a[5,]), basis(a)[5,, drop=FALSE], "subset 1 feature is OK (basis)")
+ checkEquals(coef(a[5,]), coef(a), "subset 1 feature is OK (coef)")
+ checkEquals(a[5,,drop=TRUE], basis(a)[5,, drop=TRUE], "subset 1 feature dropping is OK (return basis)")
+
+ checkEquals(dim(a[1:10,]), c(10, p, r), "subset more than 1 feature is OK (dim)")
+ checkEquals(basis(a[1:10,]), basis(a)[1:10,, drop=FALSE], "subset more than 1 feature is OK (basis)")
+ checkEquals(coef(a[1:10,]), coef(a), "subset more than 1 feature is OK (coef)")
+ checkEquals(a[1:10,,drop=TRUE], basis(a)[1:10,, drop=TRUE], "subset more than 1 feature dropping is OK (return basis)")
+
+ # subset on samples
+ checkEquals(dim(a[,1]), c(n, 1, r), "subset 1 sample is OK (dim)")
+ checkEquals(coef(a[,5]), coef(a)[,5, drop=FALSE], "subset 1 sample is OK (coef)")
+ checkEquals(basis(a[,1]), basis(a), "subset 1 sample is OK (basis)")
+ checkEquals(a[,5,drop=TRUE], coef(a)[,5, drop=TRUE], "subset 1 sample dropping is OK (return coef)")
+
+ checkEquals(dim(a[,1:10]), c(n, 10, r), "subset more then 1 sample is OK (dim)")
+ checkEquals(coef(a[,1:10]), coef(a)[,1:10, drop=FALSE], "subset more than 1 sample is OK (coef)")
+ checkEquals(basis(a[,1:10]), basis(a), "subset more than 1 sample is OK (basis)")
+ checkEquals(a[,1:10,drop=TRUE], coef(a)[,1:10, drop=TRUE], "subset more than 1 sample dropping is OK (return coef)")
+
+ # subset on basis
+ checkEquals(dim(a[,,1]), c(n, p, 1), "subset 1 basis is OK (dim)")
+ checkEquals(coef(a[,,3]), coef(a)[3,, drop=FALSE], "subset 1 basis is OK (coef)")
+ checkEquals(basis(a[,,3]), basis(a)[,3, drop=FALSE], "subset 1 basis is OK (basis)")
+ checkTrue(identical(a[,,3,drop=TRUE], a[,,3,drop=TRUE]), "subset 1 basis dropping is OK (do nothing)")
+
+ checkEquals(dim(a[,,2:4]), c(n, p, 3), "subset more than 1 basis is OK (dim)")
+ checkEquals(coef(a[,,2:4]), coef(a)[2:4, , drop=FALSE], "subset more than 1 basis is OK (coef)")
+ checkEquals(basis(a[,,2:4]), basis(a)[, 2:4, drop=FALSE], "subset more than 1 basis is OK (basis)")
+ checkTrue(identical(a[,,2:4,drop=TRUE], a[,,2:4,drop=FALSE]), "subset more than 1 basis dropping is OK (do nothing)")
+
+ checkEquals(dim(a[NULL]), c(n, p, 0), "subset basis NULL is OK (dim)")
+ checkIdentical(a[2], basis(a)[,2], "subset with single index + drop missing returns single basis as vector")
+ checkIdentical(a[2, drop = FALSE], a[,,2], "subset with single index with drop=FALSE returns the complete NMF object")
+ checkIdentical(a[2, drop=TRUE], basis(a)[,2, drop=TRUE], "subset with single index + drop=TRUE returns single basis as vector")
+
+ checkTrue(is.nmf(a[2:3]), "subset with single vector index returns NMF object")
+ checkEquals(basis(a[2:3]), basis(a)[,2:3], "subset with single vector index returns subset of NMF object")
+ checkEquals(a[2:3, drop=TRUE], basis(a)[,2:3, drop=TRUE], "subset with single vector index + dropping returns correct matrix if length > 1")
+ checkIdentical(a[2:3, drop=FALSE], a[,,2:3], "subset with single vector index + NOT dropping returns correct matrix if length > 1")
+
+ # subset on both features and samples
+ checkEquals(dim(a[1,1]), c(1, 1, r), "subset 1 feature x 1 sample is OK (dim)")
+ checkEquals(coef(a[3,5]), coef(a)[,5, drop=FALSE], "subset 1 feature x 1 sample is OK (coef)")
+ checkEquals(basis(a[3,5]), basis(a)[3,, drop=FALSE], "subset 1 feature x 1 sample is OK (basis)")
+
+ checkEquals(dim(a[10:19,5:11]), c(10, 7, r), "subset more than 1 feature x sample is OK (dim)")
+ checkEquals(coef(a[10:19,5:11]), coef(a)[,5:11], "subset more than 1 feature x sample is OK (coef)")
+ checkEquals(basis(a[10:19,5:11]), basis(a)[10:19,], "subset more than 1 feature x sample is OK (basis)")
+}
+
+
+#' Tests for get/set misc elements in NMF models
+test.misc <- function(){
+
+ x <- nmfModel()
+ m <- slot(x, 'misc')
+ checkTrue(is.list(m) && length(m)==0L, 'On empty model misc is an empty list')
+ checkEquals(misc(x), m, 'On empty model misc() returns an empty list')
+ x$a <- 3
+ checkEquals(slot(x, 'misc'), list(a=3), "Setting misc with $ works")
+ checkEquals(misc(x), list(a=3), "Getting misc with misc() works")
+ checkEquals(x$a, 3, "Getting misc with $ works")
+
+ checkEquals(misc(list()), NULL, 'On empty list misc is NULL')
+ checkEquals(misc(list(misc=4)), 4, 'On list with a `misc` element, misc() returns the element')
+ checkEquals(misc(1), NULL, 'On non list object misc() is NULL')
+ a <- 1
+ attr(a, 'misc') <- 2
+ checkEquals(misc(a), 2, 'On non list object with `misc` attribute, misc() returns the attribute')
+
+}
\ No newline at end of file
diff --git a/inst/tests/runit.NMFfit-class.r b/inst/tests/runit.NMFfit-class.r
new file mode 100644
index 0000000..27e68d0
--- /dev/null
+++ b/inst/tests/runit.NMFfit-class.r
@@ -0,0 +1,161 @@
+#' Unit Testing script for NMF package: NMFfit objects
+#'
+#' @author Renaud Gaujoux
+#' @creation 22 April 2009
+
+# make the internal functions/objects visible
+if( isNamespaceLoaded('NMF') ){
+ NMFfitX <- NMF:::NMFfitX
+}
+
+.TestSeed <- 123456
+
+.testData <- function(n=20, r=3, m=10, ...){
+ syntheticNMF(n, r, m, ...)
+}
+
+
+#' Unit test for the number of iterations
+test.niter <- function(){
+
+ # set random seed
+ set.seed(.TestSeed)
+ # generate random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ # fit an iterative model
+ res <- nmf(V,r)
+ checkTrue(!is.null(niter(res)), "The number of iterations is set by the default -- iterative -- algorithm")
+ # fit with SNMF/R(L)
+ res <- nmf(V,r, method='snmf/r')
+ checkTrue(!is.null(niter(res)), "The number of iterations is set by the SNMF/R algorithms")
+ res <- nmf(V,r, method='snmf/l')
+ checkTrue(!is.null(niter(res)), "The number of iterations is set by the SNMF/R algorithms")
+
+ # fix number of iterations
+ res <- nmf(V, r, .stop=function(strat, i, target, data, ...) if(i>=10) TRUE else FALSE)
+ checkEquals(niter(res), 10, "The number of iterations is correctly set in the case of a fixed number of iterations .stop function")
+
+}
+
+test.isNMFfit <- function(){
+
+ # set random seed
+ set.seed(.TestSeed)
+ # generate random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ # single run
+ res <- nmf(V, 2)
+ checkTrue(isNMFfit(res), "isNMFfit returns TRUE on the result of a single run")
+
+ # multiple runs - keeping single fit
+ resm <- nmf(V, 2, nrun=3)
+ checkTrue(isNMFfit(resm), "isNMFfit returns TRUE on the result of a multiple runs - keep best")
+
+ # multiple runs - keeping all fits
+ resM <- nmf(V, 2, nrun=3, .opt='k')
+ checkTrue(isNMFfit(resM), "isNMFfit returns TRUE on the result of a multiple runs - keep best")
+
+ # with a list of results
+ checkEquals(isNMFfit(list(res, resm, resM)), rep(TRUE, 3), "isNMFfit returns [TRUE TRUE TRUE] on a list of 3 NMF results")
+ checkEquals(isNMFfit(list(res, resm, resM, 'not a result')), c(rep(TRUE, 3), FALSE), "isNMFfit returns [TRUE TRUE TRUE FALSE] on a list of 3 NMF results + 1 not result")
+ checkEquals(isNMFfit(list(res, resm, resM), recursive=FALSE), FALSE, "isNMFfit returns FALSE on a list of 3 NMF results when 'recursive=FALSE'")
+
+}
+
+#' Unit test for function nmf.equal
+test.nmf.equal <- function(){
+
+ check.nmf.equal <- function(type=c('NMF', 'NMFfit', 'NMFfitX1', 'NMFfitXn')){
+
+ n <- 100; r <- 3; m <- 20
+
+ # create an NMF model
+ set.seed(123)
+ V <- rmatrix(n, m)
+ resM <- nmf(V, 3)
+ resM <- NMFfitX(list(resM))
+
+ ## utility functions
+ create.type <- function(type, obj){
+ a <- if( type=='NMF' )
+ fit(obj)
+ else if( type=='NMFfit' )
+ minfit(obj)
+ else if( type=='NMFfitX1' )
+ NMFfitX(obj, .merge=TRUE)
+ else
+ obj
+
+ if( type != 'NMF' ){
+ #print(class(a))
+ stopifnot( class(a) == type )
+ }
+ a
+ }
+
+ add.diff <- function(obj, addon){
+ basis(fit(obj[[1]])) <- basis(fit(obj[[1]])) + rmatrix(basis(fit(obj[[1]])), max=addon)
+ obj
+ }
+ ##
+
+ a <- create.type(type, resM)
+ sapply(c('NMF', 'NMFfit', 'NMFfitX1', 'NMFfitXn'), function(type2){
+
+ b <- create.type(type2, resM)
+
+ type.pair <- paste(type, "x", type2)
+ # on same object
+ checkTrue( nmf.equal(a, a), paste(type.pair, "- Default: returns TRUE on same object"))
+ checkTrue( nmf.equal(a, a, identical=TRUE), paste(type.pair, "- With identical=TRUE: returns TRUE on same object"))
+ checkTrue( nmf.equal(a, a, identical=FALSE), paste(type.pair, "- With identical=FALSE: returns TRUE on same object"))
+ checkTrue( nmf.equal(a, a, identical=FALSE, tol=0), paste(type.pair, "- With identical=FALSE, tol=0: returns TRUE on same object"))
+ checkTrue( nmf.equal(a, a, tol=0), paste(type.pair, "- With only argument tol=0: returns TRUE on same object"))
+
+ # on almost same object
+ b <- add.diff(resM, .Machine$double.eps ^ 0.6)
+ b <- create.type(type2, b)
+
+ checkTrue( !nmf.equal(a, b), paste(type.pair, "- Default: returns FALSE on almost same object"))
+ checkTrue( !nmf.equal(a, b, identical=TRUE), paste(type.pair, "- With identical=TRUE: returns FALSE on almost same object"))
+ checkTrue( nmf.equal(a, b, identical=FALSE), paste(type.pair, "- With identical=FALSE: returns TRUE on almost same object"))
+ checkTrue( nmf.equal(a, b, identical=FALSE, tol=10^-4)
+ , paste(type.pair, "- With identical=FALSE, tol > difference: returns TRUE on almost same object"))
+ checkTrue( nmf.equal(a, b, tol=10^-4)
+ , paste(type.pair, "- With only argument tol > difference: returns TRUE on almost same object"))
+ checkTrue( !isTRUE(nmf.equal(a, b, identical=FALSE, tolerance= .Machine$double.eps * 2))
+ , paste(type.pair, "- With identical=FALSE, tol < difference: returns FALSE on almost same object"))
+ checkTrue( !isTRUE(nmf.equal(a, b, tolerance= .Machine$double.eps * 2))
+ , paste(type.pair, "- With only argument tol < difference: returns FALSE on almost same object"))
+
+ # on very different object
+ b <- add.diff(resM, 10)
+ b <- create.type(type2, b)
+
+ checkTrue( !nmf.equal(a, b), paste(type.pair, "- Default: returns FALSE on very different object"))
+ checkTrue( !nmf.equal(a, b, identical=TRUE), paste(type.pair, "- With identical=TRUE: returns FALSE on very different object"))
+ checkTrue( !isTRUE(nmf.equal(a, b, identical=FALSE)), paste(type.pair, "- With identical=FALSE: returns FALSE on very different object"))
+ checkTrue( nmf.equal(a, b, identical=FALSE, tol=11)
+ , paste(type.pair, "- With identical=FALSE, tol > difference: returns TRUE on very different object"))
+ checkTrue( nmf.equal(a, b, tol=11)
+ , paste(type.pair, "- With only argument tol > difference: returns TRUE on very different object"))
+ checkTrue( !isTRUE(nmf.equal(a, b, identical=FALSE, tol=0.5))
+ , paste(type.pair, "- With identical=FALSE, tol < difference: returns FALSE on very different object"))
+ checkTrue( !isTRUE(nmf.equal(a, b, tol=0.5))
+ , paste(type.pair, "- With only argument tol < difference: returns FALSE on very different object"))
+ })
+
+ }
+
+
+ sapply(c('NMF', 'NMFfit', 'NMFfitX1', 'NMFfitXn'), check.nmf.equal)
+
+}
+
+test.deviance <- function(){
+
+
+
+}
\ No newline at end of file
diff --git a/inst/tests/runit.aheatmap.R b/inst/tests/runit.aheatmap.R
new file mode 100644
index 0000000..634add1
--- /dev/null
+++ b/inst/tests/runit.aheatmap.R
@@ -0,0 +1,22 @@
+# Unit tests for the heatmap drawing function
+#
+# Author: Renaud Gaujoux
+# Creation: 18 Nov 2011
+###############################################################################
+
+checkPlot <- function(...){
+ if( isCHECK() ) return()
+ pkgmaker::checkPlot(...)
+}
+
+test.mfrow <- function(){
+
+ x <- rmatrix(20,10)
+
+ checkPlot({
+ op <- par(mfrow=c(1,2))
+ on.exit(par(op))
+ aheatmap(x)
+ aheatmap(x*100)
+ }, "Using mfrow correctly generates two heatmaps side by side.")
+}
diff --git a/inst/tests/runit.algorithms.r b/inst/tests/runit.algorithms.r
new file mode 100644
index 0000000..99d5ee0
--- /dev/null
+++ b/inst/tests/runit.algorithms.r
@@ -0,0 +1,277 @@
+#' Unit Testing script for NMF package: NMF algorithms.
+#'
+#' @author Renaud Gaujoux
+#' @creation 22 April 2009
+
+library(rngtools)
+
+.TestSeed <- 123456
+
+.testData <- function(n=20, r=3, m=10, ...){
+ syntheticNMF(n, r, m, ...)
+}
+
+checkNMFPlot <- function(V, res, prefix=''){
+
+ if( isCHECK() ) return()
+
+ # check heatmaps of the target matrix, the metaprofiles and the metagenes
+ checkPlot( aheatmap(V), paste(prefix, ': Target'))
+ checkPlot( coefmap(res), paste(prefix, ': Metaprofiles'))
+ checkPlot( basismap(res), paste(prefix, ': Metagenes'))
+}
+
+#' Tests an algorithm on all data: synthetic, Golub, Cell-type
+checkData <- function(meth, ...){
+
+ message("\n###############\n#", meth, "\n###############")
+ # On synthetic data
+
+ #1. with noise
+ set.seed(.TestSeed)
+ r <- 3; V <- .testData(r=r)
+ n <- nrow(V); m <- ncol(V);
+
+ res <- nmf(V, r, meth, ..., rng=1234)
+
+ # check the consistency of the result
+ checkTrue( validObject(res), 'Returned object is valid')
+ checkEquals(nrow(res), n, 'W has correct number of rows', checkNames=FALSE)
+ checkEquals(nbasis(res), r, 'Result has correct rank', checkNames=FALSE)
+ checkEquals(ncol(res), m, 'H has correct number of columns', checkNames=FALSE)
+ checkEquals(algorithm(res), meth, "Algorithm's name is correctly set", checkNames=FALSE)
+
+ wr <- nmfWrapper(meth)
+ checkTrue( isNMFfit(resWrapper <- wr(V, r, ..., rng=1234)), 'Wrapper call works')
+ checkTrue( nmf.equal(res, resWrapper), 'Wrapper call gives identical result')
+
+ # check heatmaps
+ checkNMFPlot(V, res, 'Synthetic [noise]')
+
+ #2. with noise + offset
+ n.offset <- 15
+ o <- c(rep(1, n.offset), rep(0, n-n.offset))
+ set.seed(.TestSeed)
+ V <- syntheticNMF(n, r, m, offset=o, noise=TRUE)
+ res <- nmf(V, r, meth, ...)
+ # check heatmaps
+ checkNMFPlot(V, res, 'Synthetic [noise + offset]')
+
+ # On Golub data
+ data(esGolub)
+ eset <- esGolub[1:50,]
+ # check the heatmap of the target expression matrix
+ set.seed(.TestSeed)
+ res <- nmf(eset, r, meth, ...)
+ # check heatmaps
+ checkNMFPlot(exprs(eset), res, 'Golub')
+
+ return()
+ # On Cell-type data
+ data(CellType)
+ eset <- esCellType[1:100,]
+ V <- exp(exprs(eset))
+ # check the heatmap of the target expression matrix
+ set.seed(.TestSeed)
+ res <- nmf(V, r, meth, ...)
+ # check heatmaps
+ checkNMFPlot(V, res, 'Cell-type')
+
+}
+
+#' Tests Brunet algorithm
+test.brunet <- function(){
+ checkData('brunet')
+}
+
+#' Tests KL algorithm
+test.KL <- function(){
+ checkData('KL')
+}
+
+#' Tests Lee algorithm
+test.lee <- function(){
+ checkData('lee')
+}
+
+#' Tests Frobenius algorithm
+test.frobenius <- function(){
+ checkData('Frobenius')
+}
+
+#' Test NMF with offset
+test.offset <- function(){
+ checkData('offset')
+}
+
+#' Test Nonsmooth NMF
+test.ns <- function(){
+ checkData('nsNMF', theta=0.6)
+}
+
+#' Test Sparse NMF (i.e. NNLS)
+test.snmf <- function(){
+ checkData('snmf/r')#, version='R')
+ checkData('snmf/l')#, version='L')
+
+ # check errors due to parameter checks
+ set.seed(.TestSeed)
+ V <- .testData()
+ # beta
+ checkException(nmf(V, 3, 'snmf/r', beta=0), 'beta: 0 is not a valid value')
+ checkException(nmf(V, 3, 'snmf/r', beta=-1), 'beta: <0 is not a valid value')
+ # bi_conv
+ checkException(nmf(V, 3, 'snmf/r', bi_conv=-1), 'bi_conv: 1-length vector is not a valid value')
+ checkException(nmf(V, 3, 'snmf/r', bi_conv=c(-1, 10, 3)), 'bi_conv: > 2-length vector is not a valid value')
+ checkException(nmf(V, 3, 'snmf/r', bi_conv=c(-1, 10)), 'wminchange: <0 is not a valid value')
+ checkException(nmf(V, 3, 'snmf/r', bi_conv=c(0, -1)), 'iconv: <0 is not a valid value')
+ # eps_conv
+ checkException(nmf(V, 3, 'snmf/r', eps_conv=0), 'eps_conv: 0 is not a valid value')
+ checkException(nmf(V, 3, 'snmf/r', eps_conv=-1), 'eps_conv: <0 is not a valid value')
+
+ # check passage of parameters
+ # eps_conv
+ res <- nmf(V, 3, 'snmf/r', eps_conv=1)
+ checkEquals(res at parameters$eps_conv, 1, 'eps_conv: argument is passed to algorithm')
+ # eta
+ res <- nmf(V, 3, 'snmf/r', eta=1)
+ checkEquals(res at parameters$eta, 1, 'eta: argument is passed to algorithm')
+ # beta
+ res <- nmf(V, 3, 'snmf/r', beta=0.05)
+ checkEquals(res at parameters$beta, 0.05, 'beta: argument is passed to algorithm')
+ # bi_conv
+ res <- nmf(V, 3, 'snmf/r', bi_conv=c(1, 10))
+ checkEquals(res at parameters$bi_conv, c(1, 10), 'bi_conv: argument is passed to algorithm')
+}
+
+#' Test Local NMF
+test.lnmf <- function(){
+ DEACTIVATED("Algorithm 'lnmf' is not fully working.")
+ checkData('lnmf')
+}
+
+##' Tests multiple runs of NMF, using Brunet algorithm Golub data.
+#atest.zzz.runs <- function(){
+#
+# # define the number of runs
+# N <- 3
+# r <- 3
+#
+# # load data
+# data(esGolub)
+# eset <- esGolub[1:50, ]
+#
+# # run nmf N times
+# set.seed(.TestSeed)
+# res <- nmf(eset, r, 'brunet', nrun=N)
+#
+# # check the consensus matrix
+# checkPlot( basicHM(connectivity(res)), 'Consensus matrix')
+#
+#}
+
+#' Unit test for identical results if NMF algorithms
+check.algos <- function(algo1, algo2, identical=FALSE){
+
+ r <- 3
+ data(esGolub)
+ eset <- esGolub[1:50,]
+ res1 <- nmf(eset, r, algo1, seed=.TestSeed)
+ res2 <- nmf(eset, r, algo2, seed=.TestSeed)
+ checkTrue( nmf.equal(res2, res2, identical=identical)
+ , paste("Results are the same for '", algo1, "' and '", algo2, "'", sep=''))
+
+}
+
+#' Unit test for C and R versions of algorithms
+check.cversion <- function(algo){
+
+ check.algos(paste('.R#', algo, sep=''), algo)
+
+}
+
+#' Unit test for C and R versions of the algorithm: Brunet
+test.cversions.brunet <- function(){
+
+ check.cversion('brunet')
+
+}
+
+#' Unit test for C and R versions of the algorithm: Lee
+test.cversions.lee <- function(){
+
+ check.cversion('lee')
+
+}
+
+#' Unit test for C and R versions of the algorithm: nsNMF
+test.cversions.ns <- function(){
+
+ check.cversion('ns')
+
+}
+
+#' Unit test for C and R versions of the algorithm: Offset
+test.cversions.offset <- function(){
+
+ check.cversion('offset')
+
+}
+
+#' Unit test for C and R versions of the algorithm: Lee
+test.cversions.lnmf <- function(){
+
+ DEACTIVATED("Algorithm 'lnmf' is not fully working.")
+ check.cversion('lnmf')
+
+}
+
+#' Unit test for the port of `brunet`
+test.port_brunet <- function(){
+
+ # load RcppOctave if possible
+ if( !require(RcppOctave) ){
+ DEACTIVATED("Package RcppOctave not available.")
+ }
+
+ # source
+ o_source(file.path(packagePath('m-files', package='NMF'), 'brunet.m'))
+
+ # define input data
+ setRNG('default', 'default')
+ set.seed(1234)
+ x <- rmatrix(100,20)
+ x0 <- rnmf(3, x)
+
+ # run MATLAB code: brunet(v,r,verbose, w, h)
+ o <- .CallOctave('brunet', x, 3, FALSE, basis(x0), coef(x0))
+ ofit <- nmfModel(o$W, o$H)
+ checkTrue( !nmf.equal(ofit, x0), "MATLAB version returned something different than the seed model")
+ o2 <- .CallOctave('brunet', x, 3, FALSE, basis(x0), coef(x0))
+ ofit2 <- nmfModel(o2$W, o2$H)
+ checkTrue( nmf.equal(ofit, ofit2), "MATLAB version really uses the seed model")
+ o_rm("brunet")
+
+ # do not use option maxIter here.
+ # run R port
+ tol <- 10^-14
+ res <- nmf(x, 3, '.R#brunet', seed=x0, maxIter = 2000L)
+ checkEquals(niter(res), o$niter, "Pure R and MATLAB use same number of iterations")
+ checkTrue(nmf.equal(ofit, res, tolerance=tol)
+ , paste("Pure R port and MATLAB results are identical at tolerance ", tol))
+
+ # C version with copy
+ res <- nmf(x, 3, 'brunet', seed=x0, copy=TRUE, maxIter = 2000L)
+ checkEquals(niter(res), o$niter, "C version without copy and MATLAB use same number of iterations")
+ checkTrue(isTRUE(nmf.equal(ofit, res, tolerance=tol))
+ , paste("C version with copy and MATLAB results are identical at tolerance ", tol))
+ # C version without copy
+ res <- nmf(x, 3, 'brunet', seed=x0, copy=FALSE, maxIter = 2000L)
+ checkEquals(niter(res), o$niter, "C version without copy and MATLAB use same number of iterations")
+ checkTrue(isTRUE(nmf.equal(ofit, res, tolerance=tol))
+ , paste("C version without copy and MATLAB results are identical at tolerance ", tol))
+
+ # check NMFStrategyOctave
+ check.algos('brunet', '.M#brunet', identical=TRUE)
+
+}
diff --git a/inst/tests/runit.bioc.r b/inst/tests/runit.bioc.r
new file mode 100644
index 0000000..c00e7a4
--- /dev/null
+++ b/inst/tests/runit.bioc.r
@@ -0,0 +1,34 @@
+# Unit tests for the Bioconductor layer
+#
+# Author: Renaud Gaujoux
+# Created: Mar 6, 2013
+###############################################################################
+
+
+# check extension of Bioc access methods
+# => this also serves to check that they are correctly exported
+test.access <- function(){
+
+ x <- nmfModel(3, 20, 10)
+ .check <- function(fun, val, newval){
+ msg <- function(...) paste(fun, ': ', ..., sep='')
+ f <- match.fun(fun)
+ checkIdentical(f(x), val, msg('on fresh object returns NULL'))
+
+ if( isNumber(newval) ) newval <- paste('aaa', 1:newval)
+ res <- try(eval(parse(text=paste(fun, '(x) <- newval', sep=''))))
+ checkTrue(!is(res, 'try-error'), msg('setting value works'))
+ checkIdentical(f(x), newval, msg('new value is correct'))
+ res <- try(eval(parse(text=paste(fun, '(x) <- val', sep=''))))
+ checkTrue(!is(res, 'try-error'), msg('resetting value works'))
+ checkIdentical(f(x), val, msg('reset value is correct'))
+ }
+
+ checkIdentical(nbasis(x), nmeta(x), 'nmeta is defined')
+ .check('featureNames', NULL, 20)
+ .check('sampleNames', NULL, 10)
+ .check('basisnames', NULL, 3)
+ .check('metaprofiles', coef(x), rmatrix(coef(x)))
+ .check('metagenes', basis(x), rmatrix(basis(x)))
+
+}
\ No newline at end of file
diff --git a/inst/tests/runit.distance.r b/inst/tests/runit.distance.r
new file mode 100644
index 0000000..19c4b75
--- /dev/null
+++ b/inst/tests/runit.distance.r
@@ -0,0 +1,76 @@
+#' Unit Testing script for NMF package: NMF distances.
+#'
+#' @author Renaud Gaujoux
+#' @creation 08 April 2010
+
+.TestSeed <- 123456
+
+# make the internal function visible
+if( isNamespaceLoaded('NMF') ){
+ .rss <- NMF:::.rss
+ .KL <- NMF:::.KL
+}
+
+
+
+check.storage.mode <- function(R.fun, C.fun, name, ...){
+
+ n <- 5000; p <- 50;
+
+ # create random matrices in storage mode double
+ x <- rmatrix(n, p, min=1, max=100)
+ y <- rmatrix(n, p, min=1, max=100)
+
+ # create random matrices in storage mode integer
+ xi <- x; storage.mode(xi) <- 'integer'
+ yi <- y; storage.mode(yi) <- 'integer'
+
+ # check result for all combinations
+ checkEquals( R.fun(x, y, ...), C.fun(x, y), paste(name, "- Version double-double: OK" ))
+ checkEquals( R.fun(x, yi), C.fun(x, yi), paste(name, "- Version double-integer: OK" ))
+ checkEquals( R.fun(xi, y), C.fun(xi, y), paste(name, "- Version integer-double: OK" ))
+ checkEquals( R.fun(xi, yi), C.fun(xi, yi), paste(name, "- Version integer-integer: OK" ))
+
+}
+
+test.rss <- function(){
+
+ set.seed(.TestSeed)
+
+ # create R version for RSS
+ R_rss <- function(x, y) sum((x-y)^2)
+
+ # check the storage mode
+ check.storage.mode(R_rss, .rss, 'RSS')
+}
+
+test.KL <- function(){
+
+ set.seed(.TestSeed)
+
+ # create R version for RSS
+ R_kl <- function(x, y) sum( ifelse(x==0, y, x * log(x/y) - x + y) );
+
+ # check the storage mode
+ check.storage.mode(R_kl, .KL, 'KL divergence')
+
+ # create random matrices
+ n <- 5000; p <- 50;
+ x <- rmatrix(n, p, min=1, max=100)
+ y <- rmatrix(n, p, min=1, max=100)
+
+ # check result with NA values
+ z <- x; z[1,1] <- NA
+ checkTrue( is.na(.KL(z, y)), "Return NA if there is a NA in x")
+ checkTrue( is.na(.KL(x, z)), "Return NA if there is a NA in y")
+
+ # check result with NaN values
+ z <- x; z[1,1] <- NaN
+ checkTrue( is.na(.KL(z, y)), "Return NA if there is a NaN in x")
+ checkTrue( is.na(.KL(x, z)), "Return NA if there is a NaN in y")
+
+ # check result with 0 values in y
+ z <- y; z[1,1] <- 0
+ checkEquals( .KL(x, z), Inf, "Return Inf if there is a 0 in y")
+
+}
\ No newline at end of file
diff --git a/inst/tests/runit.interface.r b/inst/tests/runit.interface.r
new file mode 100644
index 0000000..9755c25
--- /dev/null
+++ b/inst/tests/runit.interface.r
@@ -0,0 +1,997 @@
+#' Unit Testing script for NMF package: NMF interface for algorithms.
+#'
+#' @author Renaud Gaujoux
+#' @creation 14 May 2009
+
+library(rngtools)
+checkIdenticalRNG <- checkRNG
+
+# make the internal functions/objects visible
+if( isNamespaceLoaded('NMF') ){
+ seed <- NMF:::seed
+# nmfUnregister <- NMF:::nmfUnregister
+ name <- NMF:::name
+ `name<-` <- NMF:::`name<-`
+}
+
+.testData <- function(n=20, r=3, m=10, ...){
+ syntheticNMF(n, r, m, ...)
+}
+
+test.registry <- function(){
+
+ checkNotNull <- function(x, ...) checkTrue(!is.null(x), ...)
+ # register function as a method
+ dummy.method <- function(){}
+
+ # methods that don't exist
+# checkException(nmfUnregister('algo.tata'), 'Unregister a method without specifying the registry name')
+# checkTrue(nmfUnregister('algo.tata', 'algorithm'), 'Unregister a method that does not exist: should not generate an error')
+ checkIdentical(removeNMFMethod('algo.tata'), FALSE, 'removeNMFMethod a method that does not exist: should not generate an error')
+ checkException( nmfAlgorithm('algo.toto'), 'Try to access a method that does not exist: should generate an error')
+ checkTrue(is.null(nmfAlgorithm('algo.toto', error=FALSE)), 'Try to access a method that does not exist with error=FALSE: should NOT generate an error and return NULL')
+
+ # Registration of new methods
+ # force un-registration of 'dummy' on exit
+ on.exit({removeNMFMethod('dummy')}, add=TRUE)
+ checkNotNull(setNMFMethod('dummy', dummy.method), 'Register works on dummy -- empty -- method')
+ checkException(setNMFMethod('dummy', dummy.method), 'Try to register an algorithm with an existing name')
+ checkNotNull(setNMFMethod('dummy', dummy.method, overwrite=TRUE), 'Overwrite an existing algorithm ')
+
+ # Access to methods
+ checkTrue( is(nmfAlgorithm('dummy'), 'NMFStrategyFunction'), 'Get method by exact match')
+ checkTrue( is(nmfAlgorithm('dum'), 'NMFStrategyFunction'), 'Get method by partial match')
+ checkEquals( name(nmfAlgorithm('dum')), 'dummy', "The method's full name is set in slot 'name'")
+}
+
+
+#' Utility function for \code{test.seed}: performs a set of test on a seeded object
+check.seed <- function(title, obj, V, r, expect.class){
+
+ checkTrue( isNMFfit(obj), paste(title, ": class returned is a valid NMF fit object") )
+ checkTrue( is(fit(obj), expect.class), paste(title, ": default class returned is ", expect.class) )
+ checkTrue( !is.empty.nmf(fit(obj)) , paste(title, ": Seeded object is not empty"))
+ checkEquals( nbasis(obj), r , paste(title, ": Seeded object has correct rank"))
+ checkEquals( nrow(obj), nrow(V) , paste(title, ": Seeded object has correct number of rows"), checkNames=FALSE)
+ checkEquals( ncol(obj), ncol(V) , paste(title, ": Seeded object has correct number of columns"), checkNames=FALSE)
+
+}
+
+check.res <- function(title, obj, V, r, expect.class, algo=NULL, seed=NULL
+ , rng=NULL, rngref=NULL){
+
+ # check the same thing as in the seed
+ check.seed(title, obj, V, r, expect.class)
+
+ # check if some slots are correctly set
+ if( is.null(algo) ) algo <- nmf.getOption('default.algorithm')
+ checkEquals( algorithm(obj), algo, paste(title, ": Slot 'method' is correctly set"))
+
+ if( is.null(seed) ) seed <- nmf.getOption('default.seed')
+ checkEquals( seeding(obj), seed, paste(title, ": Slot 'seed' is correctly set"))
+
+ # rng
+ if( !is.null(rng) ){
+
+ # check RNG
+ checkTrue( !rng.equal(rng), paste(title, ": The RNG after the fit is different from the one used to sed the computation"))
+ if( nrun(obj) == 1 ){
+ checkTrue(rng.equal(obj, rng), paste(title, ": The fit's RNG seed is correctly set"))
+ }else{
+ if( is.list(rng) ){
+ if( is(obj, 'NMFfitXn') )
+ checkTrue( all(mapply(rng.equal, obj, rng))
+ , paste(title, ": The RNGs used in the multi-run computation are from the correct sequence"))
+ }
+ }
+
+ # check RNG_1
+ rng1 <- if( is.list(rng) ) rng[[1]] else rng
+ if( !is.null(rngref) )
+ checkTrue( !rng.equal(rng1, rngref), paste(title, ": The initial current RNG is different from the first RNG used in computation"))
+ checkTrue(rng1.equal(obj, rng1), paste(title, ": The first fit's RNG seed is correctly set"))
+ checkIdenticalRNG( getRNG1(obj), rng1, paste(title, ": The first RNG used in the computation is given by getRNG1"))
+ }
+ # ref rng
+ if( !is.null(rngref) ){
+ checkTrue( rng.equal(rngref), paste(title, ": The current RNG was not affected by the computation"))
+ if( is.null(rng) )
+ checkTrue( rng.equal(obj, rngref), paste(title, ": The fit's RNG is the same as the reference RNG"))
+ }
+}
+
+
+#' Unit test for the interface function 'seed'
+test.seed <- function(){
+
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+ n <- nrow(V); m <- ncol(V);
+
+ # test default call
+ obj <- seed(V, r)
+ check.seed('Call with rank', obj, V, r, 'NMFstd')
+
+ # test call with numeric value
+ obj <- seed(V, r, 123456)
+ check.seed('Call with rank and numeric seed', obj, V, r, 'NMFstd')
+
+ # test call with name and extra parameters
+ obj <- seed(V, r, 'nndsvd', densify='average')
+ check.seed('Call with name and extra parameters', obj, V, r, 'NMFstd')
+ # test error when unused argument is used
+ checkException(seed(V, r, 'random', toto=1), "Throw an error when: unused parameter is passed to seeding method")
+
+ # test providing the class to instantiate
+ class.in <- 'NMFOffset'
+ obj <- seed(V, list(class.in, r))
+ check.seed('Call with class', obj, V, r, class.in)
+
+ # test with an empty initalization object of another class: the class should not change
+ class.in <- 'NMFOffset'
+ obj <- nmfModel(r, model=class.in)
+ obj <- seed(V, obj)
+ check.seed('Call with object', obj, V, r, class.in)
+
+ # test calls of methods
+ checkException({obj <- seed(V, r, 'seed.toto')}, 'Error when calling with an undefined seeding method')
+ checkTrue(inherits(seed(V, r, 'random'), 'NMFfit'), 'No error when calling with a defined seeding method')
+
+}
+
+#' Unit test for the interface function 'nmf': minimum default call
+test.nmf.default <- function(){
+
+ # set random seed
+ set.seed(123456)
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ # run nmf with no argument
+ check.res('Call with rank (only)'
+ , nmf(V, r)
+ , V, r, 'NMFstd')
+}
+
+#' Unit test for the interface function 'nmf': argument 'method'
+test.nmf.method <- function(){
+
+ # set random seed
+ set.seed(123456)
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ # check errors
+ checkException( nmf(V, r, 'zzz'), "Throw an error when: inexistent algorithm name")
+ checkException( nmf(V, r, toto=3), "Throw an error when: unused argument is passed to algorithm")
+
+ ## ARGUMENT: method
+ # run nmf with only an algorithm name
+ check.res('Call with algorithm name'
+ , nmf(V, r, 'nsNMF')
+ , V, r, 'NMFns', 'nsNMF')
+
+ # run nmf with only an algorithm name (partial match)
+ check.res('Call with algorithm name and partial match'
+ , nmf(V, r, 'ns')
+ , V, r, 'NMFns', 'nsNMF')
+
+ old.rseed <- getRNG()
+ res <- nmf(V, r, list('ns', 'br', 'lee'))
+ checkIdentical(names(res), c('nsNMF', 'brunet', 'lee'), "Argument list(): names are set correctly to the complete method names")
+ checkTrue( all(sapply(res, function(x) identical(getRNG(x), getRNG(res[[1]])))),
+ "Initial RNG settings are the same for each method")
+ checkTrue( !identical(old.rseed, getRNG()), "RNG setting is different after the run" )
+ new.rseed <- getRNG()
+ setRNG(old.rseed)
+ nmf(V, r, 'lee')
+ checkIdentical( new.rseed, getRNG(), "RNG setting after the run is the same as if one has run only the last method" )
+
+ # list of methods
+ res <- nmf(V, r, list('ns', 'br', 'lee'), nrun=3)
+ checkIdentical(names(res), c('nsNMF', 'brunet', 'lee'), "Argument list() + multiple run: names are set correctly to the complete method names")
+ checkTrue( all(sapply(res, function(x) identical(getRNG1(x), getRNG1(res[[1]])))),
+ "Argument list() + multiple runs: Initial RNG settings are the same for each method")
+
+ ml <- list('ns', 'brunet', 'lee')
+ checkException(nmf(V, r, ml, .parameters = 2:3), "Error if argument .parameters not a list")
+ checkException(nmf(V, r, ml, .parameters = list(list(copy = TRUE))), "Error if argument .parameters has no names")
+ checkException(nmf(V, r, ml, .parameters = list(br = list(), list(copy = TRUE))), "Error if argument .parameters has missing names")
+ checkException(nmf(V, r, ml, .parameters = list(br = list(), brun = list(copy = TRUE))), "Error if argument .parameters has multiple matching names")
+ checkWarning(nmf(V, r, ml, .parameters = list(br = list(aaa = 1))), TRUE, "Error if unused argument in selected method-specific parameters")
+ checkWarning(nmf(V, r, ml, .parameters = list(br = list(), toto = list())), TRUE, "Warning if unused elements in .parameters")
+ checkTrue(all(isNMFfit(res <- nmf(V, r, ml, seed = 123, .parameters = list(br = list(maxIter = 10), ns = list(maxIter = 2)))))
+ , "List of methods working if called with correct .parameters")
+ checkIdentical( niter(res$nsNMF), 2L, )
+ checkIdentical( niter(res$brunet), 10L)
+ res_lee <- nmf(V, r, 'lee', seed = 123)
+ checkTrue( niter(res$lee) > 10L, "Method without method-specific parameter specification correctly runs without them: niter > 10L" )
+ checkIdentical( niter(res$lee), niter(res$lee), "Method without method-specific parameter specification correctly runs without them: niter equal" )
+ checkTrue( nmf.equal(res$lee, res_lee), "Method without method-specific parameter specification correctly runs without them: identical result" )
+
+}
+
+#' Unit test for multiple rank
+test.nmf.multirank <- function(){
+
+ # set random seed
+ set.seed(123456)
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ old.rseed <- getRNG()
+ ranks <- 2:4
+ old.rseed <- getRNG()
+ res <- nmf(V, ranks, nrun=1)
+ checkTrue( is(res, 'NMF.rank'), "Result is a NMF.rank object")
+ checkIdentical(names(res), c('measures', 'consensus', 'fit'), "result names are corrects")
+ checkIdentical(names(res$fit), as.character(ranks), "names of fits are the ranks as character strings")
+ fits <- res$fit
+ checkTrue( all(sapply(fits, function(x) identical(getRNG(x), getRNG(fits[[1]])))),
+ "Initial RNG settings are the same for each rank")
+ checkTrue( !identical(old.rseed, getRNG()), "RNG setting is different after the run" )
+ new.rseed <- getRNG()
+ setRNG(old.rseed)
+ nmf(V, tail(ranks, 1))
+ checkIdentical( new.rseed, getRNG(), "RNG setting after the run is the same as if one has run only the last rank" )
+
+ res <- nmf(V, ranks, nrun=3)
+ checkTrue( is(res, 'NMF.rank'), "multiple runs: Result is a NMF.rank object")
+ checkIdentical(names(res), c('measures', 'consensus', 'fit'), "multiple runs: result names are corrects")
+ checkIdentical(names(res$fit), as.character(ranks), "multiple runs: names of fits are the ranks as character strings")
+ fits <- res$fit
+ checkTrue( all(sapply(fits, function(x) identical(getRNG1(x), getRNG1(fits[[1]])))),
+ "multiple runs: Initial RNG settings are the same for each rank")
+}
+
+#' Unit test for fault tolerance of .Random.seed
+test.nmf.seed.fault <- function(){
+
+ # set random seed
+ set.seed(123456)
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ # .Random.seed is not changed after an error in the run
+ os <- .Random.seed
+ try(res <- nmf(V, r, method=function(...){}))
+ checkIdentical( os, .Random.seed, ".Random.seed is NOT changed after error in single run without seed")
+ #
+ os <- .Random.seed
+ try(res <- nmf(V, r, nrun=3, method=function(...){}, .opt='-p'))
+ checkIdentical(os, .Random.seed, ".Random.seed is NOT changed after error in multiple runs without seed (sapply)")
+ #
+ os <- .Random.seed
+ try(res <- nmf(V, r, nrun=3, method=function(...){}, .opt='P2'))
+ checkIdentical(os, .Random.seed, ".Random.seed is NOT changed after error in multiple runs without seed (foreach-MC)")
+ #
+ os <- .Random.seed
+ try(res <- nmf(V, r, nrun=3, method=function(...){}, .opt='P1'))
+ checkIdentical(os, .Random.seed, ".Random.seed is NOT changed after error in multiple runs without seed (foreach-SEQ)")
+
+}
+
+#' Unit test for the interface function 'nmf': argument 'seed'
+test.nmf.seed.argument <- function(){
+
+ # set random seed
+ set.seed(123456)
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ ## ARGUMENT: seed
+
+ # check errors
+ checkException( nmf(V, r, seed='zzz'), "Throw an error when: inexistent seeding method name")
+ checkException( nmf(V, r, seed=matrix(1,2,2)), "Throw an error when: invalid object as seeding method")
+ checkException( nmf(V, r, seed=list('zzz')), "Throw an error when: inexistent seeding method name (passed as list)")
+ checkException( nmf(V, r, seed=list(method='zzz')), "Throw an error when: inexistent seeding method name (passed as named list)")
+ checkException( nmf(V, r, seed=list(toto=1, method='random')), "Throw an error when: unused argument is passed to seeding method")
+ checkException( nmf(V, r, seed=numeric()), "Throw an error when: seed argument is an empty numeric")
+
+ checkException( nmf(V, r, seed=c(1,2)), "Throw an error when: seed argument is a numeric of invalid length (2)")
+ checkException( nmf(V, r, seed=rep(5,5)), "Throw an error when: seed argument is an invalid numeric value for .Random.seed (7)")
+
+ # run nmf with only a seeding method name
+ set.seed(123)
+ rngRef <- getRNG()
+ check.res('Call with only a NON random seeding method name'
+ , nmf(V, r, seed='nndsvd')
+ , V, r, 'NMFstd', seed='nndsvd', rngref=rngRef)
+
+ # run nmf with only a seeding method name partially matched
+ check.res('Call with only a NON random seeding method name partially match'
+ , nmf(V, r, seed='nnd')
+ , V, r, 'NMFstd', seed='nndsvd')
+
+ # run nmf with 'random' seeding method
+ set.seed(1234)
+ rngRef <- getRNG()
+ check.res('Call with "random" seeding method name'
+ , res <- nmf(V, r, seed='random')
+ , V, r, 'NMFstd', seed='random', rng=rngRef)
+
+ # run nmf with numeric seed
+ msg <- function(...) paste("Call with only a numerical seed:", ...)
+ rngRef <- getRNG()
+ s <- nextRNG(123456)
+ check.res(msg()
+ , res <- nmf(V, r, seed=123456)
+ , V, r, 'NMFstd', seed='random', rng=s, rngref=rngRef)
+
+ # run nmf with 6-length numeric seed
+ msg <- function(...) paste("Call with a 6-length numerical seed:", ...)
+ runif(10)
+ rngRef <- getRNG()
+ nseed <- c(1,2,3,4,5,6)
+ s <- RNGseq(1, nseed)
+ check.res(msg()
+ , res <- nmf(V, r, seed=nseed)
+ , V, r, 'NMFstd', seed='random', rng=s, rngref=rngRef)
+
+# # run nmf with rstream object
+# msg <- function(...) paste("Call with only a rstream object:", ...)
+# rngRef <- getRNG()
+# s <- new('rstream.mrg32k3a')
+# check.res(msg()
+# , res <- nmf(V, r, seed=s)
+# , V, r, 'NMFstd', seed='random', rng=s, rngref=rngRef)
+#
+ # run multi-nmf with numeric seed
+ msg <- function(...) paste("Multirun - parallel + numeric seed (keep all):", ...)
+ runif(10)
+ rngRef <- getRNG()
+ sRNG <- RNGseq(3, seed=5698)
+ check.res(msg()
+ , res <- nmf(V, r, nrun=3, seed=5698, .opt='kP')
+ , V, r, 'NMFstd', seed='random', rng=sRNG, rngref=rngRef)
+
+ # run multi-nmf with 7-length numeric seed (keep one)
+ msg <- function(...) paste("Multirun - parallel + list of seeds (keep all):", ...)
+ runif(10)
+ rngRef <- getRNG()
+ check.res(msg()
+ , res2 <- nmf(V, r, nrun=3, seed=sRNG, .opt='kP')
+ , V, r, 'NMFstd', seed='random', rng=sRNG, rngref=rngRef)
+ checkIdenticalRNG( res2, res, msg("The best fit's RNG is the same as when seeding with corresponding single numeric seed"))
+
+ # run multi-nmf with numeric seed (keep one)
+ msg <- function(...) paste("Multirun - parallel + numeric seed (keep best):", ...)
+ runif(10)
+ res2 <- nmf(V, r, nrun=3, seed=5698, .opt='P')
+ checkIdenticalRNG( res2, res, msg("The best fit's RNG is the same as when keeping all the fits"))
+ checkIdenticalRNG( getRNG1(res2), sRNG[[1]], msg("The first RNG used in the computation of the NMFfitX1 object is given by getRNG1"))
+ checkTrue( rng1.equal(res2, sRNG[[1]]), msg("The first RNG used in the computation is correct"))
+
+ # run multi-nmf with 7-length numeric seed (keep one)
+ msg <- function(...) paste("Multirun - parallel + single 7-length numeric seed (keep best):", ...)
+ runif(10)
+ res2 <- nmf(V, r, nrun=3, seed=sRNG[[1]], .opt='P')
+ checkIdenticalRNG( res2, res, msg("The best fit's RNG is the same as when keeping all the fits"))
+ checkIdenticalRNG( getRNG1(res2), sRNG[[1]], msg("The first RNG used in the computation of the NMFfitX1 object is given by getRNG1"))
+ checkTrue( rng1.equal(res2, sRNG[[1]]), msg("The first RNG used in the computation is correct"))
+
+# # run multi-nmf with rstream object
+# msg <- function(...) paste("Multirun - parallel + rstream seed:", ...)
+# rngRef <- getRNG()
+# sRNG <- new('rstream.mrg32k3a')
+# check.res(msg()
+# , res <- nmf(V, r, nrun=3, seed=sRNG, .opt='kP')
+# , V, r, 'NMFstd', seed='random')
+# checkIdenticalRNG( res[[1]], sRNG, msg("The first RNG used in the computation is correct"))
+# checkTrue( !rng.equal(sRNG), msg("The current RNG is different from the first one used to seed the computation"))
+# checkTrue( rng.equal(rngRef), msg("The current RNG was not affected by the computation"))
+# checkIdenticalRNG( getRNG1(res), sRNG, msg("The first RNG used in the computation of the NMFfitXn object is given by getRNG1"))
+ # run multi-nmf with rstream seed (keep one)
+ msg <- function(...) paste("Multirun - parallel + rstream seed (keep best):", ...)
+ runif(10)
+ res2 <- nmf(V, r, nrun=3, seed=sRNG[[1]], .opt='P')
+ checkIdenticalRNG( res2, res, msg("The best fit's RNG is the same as when keeping all the fits"))
+ checkIdenticalRNG( getRNG1(res2), sRNG[[1]], msg("The first RNG used in the computation of the NMFfitX1 object is given by getRNG1"))
+
+ # Seeding with NMF object
+ obj.s <- rnmf(r, V)
+ rngRef <- getRNG()
+ res <- nmf(V, obj.s)
+ check.res('Call with rank = <NMF object>', res, V, r, 'NMFstd', 'brunet', 'NMF', rngref = rngRef)
+ checkTrue( nmf.equal(res, nmf(V, obj.s)), 'Run with rank=<NMF object> is deterministic')
+ res.s <- nmf(V, seed = obj.s)
+ check.res('Call with seed = <NMF object>', res, V, r, 'NMFstd', 'brunet', 'NMF', rngref = rngRef)
+ checkTrue( nmf.equal(res, res.s), 'Run with rank=<NMF object> returns identical result as with seed=<NMF object>')
+
+ # run nmf with only a seeding method name and some extra parameters
+ check.res('Call with only a seeding method name and some extra parameters (element method first and not named)'
+ , nmf(V, r, seed=list('nndsvd', densify='average'))
+ , V, r, 'NMFstd', seed='nndsvd')
+
+ check.res('Call with only a seeding method name and some extra parameters (element method second and named)'
+ , nmf(V, r, seed=list(densify='average', method='nndsvd'))
+ , V, r, 'NMFstd', seed='nndsvd')
+
+ # run nmf with both algorithm and seeding method
+ check.res('Call with both algorithm and seeding method'
+ , nmf(V, r, 'lee', seed='nndsvd')
+ , V, r, 'NMFstd', 'lee', 'nndsvd')
+}
+
+test.nmf.seed.equivalent <- function(){
+
+ # set random seed
+ set.seed(123456)
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ # multiple run nmf with numeric seed is equivalent to set.seed before the call
+ set.seed(1234)
+ ss_SEQ <- nmf(V, r, nrun=3, .opt='k-p')
+ #
+ runif(10)
+ SEQ <- nmf(V, r, nrun=3, seed=1234, .opt='k-p')
+ checkTrue( nmf.equal(ss_SEQ, SEQ, all=TRUE)
+ , "Multiple run using sapply with a numeric seed is equivalent to set.seed + run (sapply)")
+
+ # multiple run nmf with numeric seed is equivalent to set.seed before the call
+ set.seed(1234)
+ ss_PAR <- nmf(V, r, nrun=3, .opt='kP2')
+ runif(10)
+ PAR <- nmf(V, r, nrun=3, seed=1234, .opt='kP2')
+ checkTrue( nmf.equal(ss_SEQ, PAR, all=TRUE)
+ , "Multiple run using foreach with a numeric seed is equivalent to set.seed + run (sapply)")
+ checkTrue( nmf.equal(ss_PAR, PAR, all=TRUE)
+ , "Multiple run using foreach with a numeric seed is equivalent to set.seed + run (foreach)")
+ PAR_SEQ <- nmf(V, r, nrun=3, seed=1234, .opt='kP', .pbackend='seq')
+ checkTrue( nmf.equal(PAR_SEQ, PAR, all=TRUE)
+ , "Multiple run using foreach with a numeric seed is equivalent to foreach sequential with numeric seed")
+ set.seed(1234)
+ ss_PAR_SEQ <- nmf(V, r, nrun=3, .opt='kP', .pbackend='seq')
+ checkTrue( nmf.equal(ss_PAR_SEQ, PAR, all=TRUE)
+ , "Multiple run using foreach with a numeric seed is equivalent to set.seed + foreach sequential")
+ #and:
+ set.seed(1234)
+ ss_SEQ_noR <- nmf(V, r, nrun=3, .opt='k-pR')
+ runif(10)
+ SEQ_noR <- nmf(V, r, nrun=3, seed=1234, .opt='k-pR')
+ checkTrue( nmf.equal(ss_SEQ_noR, SEQ_noR, all=TRUE)
+ , "Multiple run using sapply with a numeric seed WITHOUT option R is equivalent to set.seed + run (sapply) WITHOUT option R")
+ checkTrue( !nmf.equal(SEQ_noR, SEQ, all=TRUE)
+ , "Multiple run using sapply with a numeric seed WITHOUT option R is NOT equivalent to set.seed + run (sapply)")
+ #
+
+ # fits of multiple runs are not the same as the ones obtained from separate fits
+ set.seed(1234)
+ ss_SEPA <- replicate(3, nmf(V,r))
+ checkTrue( !nmf.equal(ss_SEPA, ss_SEQ, all=TRUE)
+ , "Fits of multiple runs with sapply and a seed are NOT the same as the ones obtained from set.seed + separate fits")
+ # but:
+ checkTrue( nmf.equal(ss_SEPA, ss_SEQ_noR, all=TRUE)
+ , "Fits of multiple runs WITHOUT option R with sapply and a seed are the same as the ones obtained from set.seed + separate fits")
+ #
+ checkTrue( !nmf.equal(ss_SEPA, PAR, all=TRUE)
+ , "Fits of multiple runs with foreach and a seed are NOT the same as the ones obtained from set.seed + separate fits")
+ # and:
+ PAR_noR <- nmf(V, r, nrun=3, seed=1234, .opt='kP2-R')
+ checkTrue( nmf.equal(PAR_noR, PAR, all=TRUE), "Option -R has no effect on true parallel computations")
+
+}
+
+test.nmf.seed.repro <- function(){
+
+ # set random seed
+ set.seed(123456)
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ # check reproducibility
+ res <- replicate(2, nmf(V, r, seed=123))
+ checkTrue( nmf.equal(res[[1]], res[[2]]), "Results are reproducible: single run" )
+ res <- replicate(2, nmf(V, r))
+ checkTrue( !nmf.equal(res[[1]], res[[2]]), "Results are NOT the same if not seeded: single run" )
+ #
+ res <- replicate(2, nmf(V, r, nrun=3, seed=123, .opt='kP'), simplify=FALSE)
+ checkTrue( nmf.equal(res[[1]], res[[2]], all=TRUE), "Results are reproducible: multiple run - Parallel" )
+ res <- replicate(2, nmf(V, r, nrun=3, .opt='kP'), simplify=FALSE)
+ checkTrue( !nmf.equal(res[[1]], res[[2]]), "Results are NOT the same if not seeded: multiple run - Parallel" )
+ #
+ res <- replicate(2, nmf(V, r, nrun=3, seed=123, .opt='k-p'), simplify=FALSE)
+ checkTrue( nmf.equal(res[[1]], res[[2]], all=TRUE), "Results are reproducible: multiple run - sapply" )
+ res <- replicate(2, nmf(V, r, nrun=3, .opt='k-p'), simplify=FALSE)
+ checkTrue( !nmf.equal(res[[1]], res[[2]]), "Results are NOT the same if not seeded: multiple run - sapply" )
+ #
+ res <- list(nmf(V, r, nrun=3, seed=123, .opt='kP', .pbackend='seq')
+ , nmf(V, r, nrun=3, seed=123, .opt='kP', .pbackend='mc'))
+ checkTrue( nmf.equal(res[[1]], res[[2]], all=TRUE), "Identical results from seeded foreach MC and SEQ" )
+ res <- list(nmf(V, r, nrun=3, .opt='kP', .pbackend='seq')
+ , nmf(V, r, nrun=3, .opt='kP', .pbackend='mc'))
+ checkTrue( !nmf.equal(res[[1]], res[[2]], all=TRUE), "NON-identical results from non-seeded foreach MC and SEQ" )
+
+}
+
+#' Unit test for the interface function 'nmf': argument 'model'
+test.nmf.model <- function(){
+
+ # set random seed
+ set.seed(123456)
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ ## ARGUMENT: model
+ # run nmf with empty argument'model'
+ check.res("Call with empty argument 'model'"
+ , nmf(V, r, model=list())
+ , V, r, 'NMFstd')
+
+ # run nmf with bad types in 'model'
+ checkException(nmf(V, r, model=NA), "Error if there argument 'model' is of a bad type: NA")
+ checkException(nmf(V, r, model='toto'), "Error if there argument 'model' is of a bad type: character")
+ checkException(nmf(V, r, model=12), "Error if there argument 'model' is of a bad type: numeric")
+
+ # run nmf with not named element in argument 'model'
+ checkException(nmf(V, r, model=list('toto')), "Error if there is a not named element in argument 'model'")
+
+ # run nmf with bad slot name in argument 'model'
+ checkException(nmf(V, r, model=list(toto=5)), "Error if there is a bad slot name in argument 'model'")
+
+ # run nmf specifying arguments for initialization in argument 'model'
+ res <- nmf(V, r, 'nsNMF', model=list(theta=0.6))
+ check.res("Call with argument 'model' to specify extra initialization parameter"
+ , res
+ , V, r, 'NMFns', 'nsNMF')
+ checkEquals(fit(res)@theta, 0.6
+ , "Call algo:nsNMF with theta in argument 'model': argument correctly passed to model")
+}
+
+str_dim <- NMF:::str_dim
+
+test.nmfModel.formula <- function(){
+
+ set.seed(123456)
+ r <- 3
+ V <- .testData(r = r)
+ w <- rmatrix(nrow(V), r)
+ h <- rmatrix(r, ncol(V))
+ cx <- runif(ncol(V))
+ bx <- runif(nrow(V))
+
+ .check <- function(res, dims, msg, cterm = NULL, bterm = NULL){
+ .msg <- function(...) paste0(msg, ': ', ...)
+ checkTrue(isNMFfit(res), .msg('Result is an NMFfit object'))
+ checkEquals(dim(res), dims, .msg('Dimensions [', str_dim(res), '] are as expected [', str_dim(dims=dims), ']'))
+
+ # check fixed terms don't change
+ if( !is.null(cterm) ){
+ if( is.null(dim(cterm)) ) cterm <- matrix(cterm, 1L)
+ else if( is.data.frame(cterm) ) t(as.matrix(cterm))
+ else if( !is.matrix(cterm) ) stop("Unexpected error: invalid data type [", class(cterm), ']')
+ n <- nrow(cterm)
+ ft <- coef(res)[tail(1:nbasis(res), n), , drop = FALSE]
+ dimnames(ft) <- NULL
+ checkIdentical(cterm, ft, "Fixed coef term don't change")
+ }
+ if( !is.null(bterm) ){
+ if( is.null(dim(bterm)) ) bterm <- matrix(bterm, ncol = 1L)
+ else if( is.data.frame(bterm) ) as.matrix(bterm)
+ else if( !is.matrix(cterm) ) stop("Unexpected error: invalid data type [", class(bterm), ']')
+ n <- ncol(bterm)
+ ft <- basis(res)[, tail(1:nbasis(res), n), drop = FALSE]
+ dimnames(ft) <- NULL
+ checkIdentical(bterm, ft, "Fixed basis term don't change")
+ }
+ }
+
+ # coef terms
+ .check(nmf(V ~ cx), c(dim(V), 1L), cterm = cx, 'Single coef term')
+ .check(nmf(V ~ h), c(dim(V), nrow(h)), cterm = h, 'Matrix coef term')
+ .check(nmf(t(V) ~ t(w)), c(dim(t(V)), ncol(w)), cterm = t(w), 'Matrix coef term (transpose)')
+ .check(nmf(V ~ data.frame(t(h))), c(dim(V), nrow(h)), cterm = h, 'Data frame coef term')
+ # basis terms
+# .check(nmf(V ~ bx), c(dim(V), 1L), bterm = bx, 'Single basis term')
+# .check(nmf(V ~ w), c(dim(V), ncol(w)), bterm = w, 'Matrix basis term')
+# .check(nmf(V ~ data.frame(w)), c(dim(V), ncol(w)), bterm = w, 'Data frame basis term')
+
+}
+
+#' Unit test for the interface function 'nmf': argument '...'
+test.nmf.dots <- function(){
+
+ # set random seed
+ set.seed(123456)
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ ## ARGUMENT: ...
+ # run nmf with unused parameter in '...'
+ checkException(nmf(V, r, toto=5), "Error if there is an unused parameter in '...'")
+
+ # run nmf forcing using argument in '...' for algorithm
+ checkException(nmf(V, r, 'nsNMF', model=list(), theta=0.6), "Forcing argument to go to algo: error if there is an unused parameter in '...'")
+
+ # run nmf specifying arguments for initialization in argument '...'
+ res <- nmf(V, r, 'nsNMF', theta=0.6)
+ check.res("Call with argument '...' to specify extra initialization parameter"
+ , res
+ , V, r, 'NMFns', 'nsNMF')
+ checkEquals(fit(res)@theta, 0.6
+ , "Call algo:nsNMF with theta in argument '...': argument correctly passed to model")
+
+
+}
+
+test.nmf.callback <- function(){
+
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ # check that the result of the callback are stored in the result object
+ cb <- function(object, i){ 1 }
+ res <- nmf(V, r, nrun=3, .callback=cb, .opt='P')
+ checkEquals(res$.callback, rep(1, 3), 'Result of callback is in: res$.callback (PAR)')
+ res <- nmf(V, r, nrun=3, .callback=cb, .opt='-p')
+ checkEquals(res$.callback, rep(1, 3), 'Result of callback is in: res$.callback (SEQ)')
+
+ # check that callback can make use of the result of each run
+ cb <- algorithm
+ res <- nmf(V, r, nrun=3, .callback=cb, .opt='P')
+ checkEquals(res$.callback, rep('brunet', 3), 'Result of callback can use the result object of each run (PAR)')
+ res <- nmf(V, r, nrun=3, .callback=cb, .opt='-p')
+ checkEquals(res$.callback, rep('brunet', 3), 'Result of callback can use the result object of each run (SEQ)')
+
+ # check that the callback is not used with option 'keep.all'
+ cb <- function(object, i){ stop() }
+ checkWarning(res <- nmf(V, r, 'br', nrun=3, .callback=cb, .opt='Pk'), "discarding argument .*\\.callback")
+ checkTrue( is(res, 'NMFfitXn'), "Callback function is not used with option 'keep.all=TRUE' (PAR)")
+ checkWarning(res <- nmf(V, r, 'br', nrun=3, .callback=cb, .opt='k-p'), "discarding argument .*\\.callback")
+ checkTrue( is(res, 'NMFfitXn'), "Callback function is not used with option 'keep.all=TRUE' (SEQ)")
+
+ # check that an error in the callback function stops the computation with an error
+ cb <- function(object, i){ stop('BIG ERROR') }
+ checkTrue(isNMFfit(res <- nmf(V, r, 'br', nrun=3, .callback=cb, .opt='P'))
+ , 'Error in callback function does not stop the copmutation (PAR)')
+ checkTrue(is.list(res$.callback), 'res$.callback is a list when there is an error (PAR)')
+ checkEquals(sapply(res$.callback, function(x) is(x, 'error')), rep(TRUE, 3), checkNames = FALSE
+ , 'Error in callback function returns errors in res$.callback (PAR)')
+
+ checkTrue(isNMFfit(res <- nmf(V, r, 'br', nrun=3, .callback=cb, .opt='-p')), 'Error in callback function does not stop the copmutation (SEQ)')
+ checkTrue(is.list(res$.callback), 'res$.callback is a list when there is an error (SEQ)')
+ checkEquals(sapply(res$.callback, function(x) is(x, 'error')), rep(TRUE, 3), checkNames = FALSE
+ , 'Error in callback function returns errors in res$.callback (SEQ)')
+
+ # simplification from list if no error
+ res <- nmf(V, r, 'br', nrun=3, .callback=summary, .opt='P')
+ checkTrue(is.matrix(res$.callback), 'res$.callback is a list when there is NO error (PAR)')
+ res <- nmf(V, r, 'br', nrun=3, .callback=summary, .opt='P-S')
+ checkTrue(is.list(res$.callback), 'res$.callback is a list when there is NO error (PAR) and simplifyCB=FALSE')
+
+ res <- nmf(V, r, 'br', nrun=3, .callback=summary, .opt='-p')
+ checkTrue(is.matrix(res$.callback), 'res$.callback is a list when there is NO error (SEQ)')
+ res <- nmf(V, r, 'br', nrun=3, .callback=summary, .opt='-pS')
+ checkTrue(is.list(res$.callback), 'res$.callback is a list when there is NO error (SEQ) and simplifyCB=FALSE')
+#
+ # no simplification from list if there is at least one error
+ cb <- function(object, i){ if( i ==1 ) stop('BIG ERROR ', i); summary(object) }
+ res <- nmf(V, r, 'br', nrun=3, .callback=cb, .opt='P')
+ checkTrue(is.list(res$.callback), 'res$.callback is a list when there is at least one error (PAR)')
+ checkEquals(sapply(res$.callback, function(x) is(x, 'error')), c(TRUE, FALSE, FALSE), checkNames = FALSE
+ , 'Error in callback function returns errors mixed with values in res$.callback (PAR)')
+
+ res <- nmf(V, r, 'br', nrun=3, .callback=cb, .opt='-p')
+ checkTrue(is.list(res$.callback), 'res$.callback is a list when there is at least one error (SEQ)')
+ checkEquals(sapply(res$.callback, function(x) is(x, 'error')), c(TRUE, FALSE, FALSE), checkNames = FALSE
+ , 'Error in callback function returns errors mixed with values in res$.callback (SEQ)')
+
+}
+
+test.nmf.options <- function(){
+
+ x <- rmatrix(20,10)
+
+ .check <- function(msg, it, ...){
+
+ .msg <- function(...) paste(msg, ':', ...)
+ res <- nmf(x, 2, ...)
+ t <- residuals(res, track=TRUE)
+ checkTrue( !is.null(names(t)), .msg("Track has names"))
+ checkTrue( 0 == names(t)[1], .msg("First value in track is for iteration 0"))
+ t <- t[-1]
+ lags <- head(diff(as.numeric(names(t))), length(t)-2)
+ checkIdentical( lags, rep(it, length(t)-2), .msg("Track interval is correct"))
+
+ }
+
+ .test <- function(msg, ...){
+ .check(paste(msg, '- single run'), ..., nrun=1)
+ .check(paste(msg, '- multiple runs'), ..., nrun=3)
+ }
+
+ .test('Default call -> use option', nmf.getOption('track.interval'), .options='t')
+ .test('Specified in .options="t5" -> use value from "t"', 5, .options='t5')
+ nmf.options(track.interval=7)
+ .test('Default call after changing option -> use new option', 7, .options='t')
+
+
+}
+
+test.nmf.custom <- function(){
+
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ # define a dummy nmf algorithm with an argument with the same name as a slot
+ my.algo <- function(x, seed, theta=0){
+ seed$extra.param <- theta
+ seed
+ }
+
+ # check if everything works fine plain
+ res <- nmf(V, r, my.algo, name='dummy')
+ check.res('No argument (only name)'
+ , res
+ , V, r, 'NMFstd', 'dummy')
+ checkEquals(res$extra.param, 0, "No argument: NO argument is provided to the algorithm")
+
+ # check if everything works fine if model is an empty list
+ res <- nmf(V, r, my.algo, name='dummy', model=list())
+ check.res("Argument 'model' an empty list"
+ , res
+ , V, r, 'NMFstd', 'dummy')
+ checkEquals(res$extra.param, 0, "No argument: NO argument is provided to the algorithm")
+
+ # with standard model: theta is not a model parameter => Error
+ checkException(nmf(V, r, my.algo, name='dummy', model=list(theta=1))
+ , "Error when passing non model parameter in argument 'model', with same name as an algo parameter")
+
+ # with standard model: extra argument in '...' used in algo
+ res <- nmf(V, r, my.algo, name='dummy', theta=10)
+ check.res('No argument (only name)'
+ , res
+ , V, r, 'NMFstd', 'dummy')
+ checkEquals(res$extra.param, 10
+ , "NMFstd + Extra argument in '...': extra argument IS provided to the algorithm")
+
+ # unsued extra argument in algorithm => Error
+ checkException(nmf(V, r, my.algo, name='dummy', toto=1)
+ , "Error if NMFstd + unused parameter in argument '...'")
+
+ # run model nsNMF plain to get default value of theta
+ res <- nmf(V, r, my.algo, model='NMFns')
+ default.theta <- fit(res)@theta
+ custom.theta <- 1
+ checkEquals(res$extra.param, 0, "NMFns + no args: extra argument is NOT provided to the algorithm")
+
+ # with model nsNMF: the parameter should be used in the model if in argument 'model'
+ res <- nmf(V, r, my.algo, name='dummy', model=list('NMFns', theta=custom.theta))
+ check.res("NMFns + With extra argument in argument 'model'"
+ , res
+ , V, r, 'NMFns', 'dummy')
+ checkEquals(res$extra.param, 0, "NMFns + Argument in 'model': extra argument is NOT provided to the algorithm")
+ checkEquals(fit(res)@theta, custom.theta, "NMFns + Argument in 'model': extra argument IS used in model")
+
+ # with model nsNMF: the parameter should be used in the model if in
+ # argument '...' and 'model' is not specified
+ res <- nmf(V, r, my.algo, name='dummy', model='NMFns', theta=custom.theta)
+ check.res("NMFns + With extra argument in argument '...' and 'model' a model name"
+ , res
+ , V, r, 'NMFns', 'dummy')
+ checkEquals(res$extra.param, 0, "NMFns + Argument in '...', 'model' a model name: extra argument is NOT provided to the algorithm")
+ checkEquals(fit(res)@theta, custom.theta, "NMFns + Argument in '...' and 'model' a model name: extra argument used in model")
+
+ # with model nsNMF: the parameter should be used in the algorithm if in
+ # argument '...' and 'model' is a list
+ res <- nmf(V, r, my.algo, name='dummy', model=list('NMFns'), theta=1)
+ check.res("NMFns + With extra argument in argument '...' and 'model' a list with model name"
+ , res
+ , V, r, 'NMFns', 'dummy')
+ checkEquals(res$extra.param, 1, "NMFns + Argument in '...' and 'model' is a list with model name: extra argument IS provided to the algorithm")
+ checkEquals(fit(res)@theta, default.theta, "NMFns + Argument in '...' and 'model' is list with model name: extra argument NOT used in model")
+
+ # with model nsNMF: conflicts in names resolved passing different values
+ # in arguments '...' and 'model'
+ res <- nmf(V, r, my.algo, name='dummy', model=list('NMFns', theta=custom.theta), theta=1)
+ check.res("NMFns + With extra argument in argument 'model'"
+ , res
+ , V, r, 'NMFns', 'dummy')
+ checkEquals(res$extra.param, 1, "NMFns + Different values in argument in '...' and 'model': correct extra argument IS provided to the algorithm")
+ checkEquals(fit(res)@theta, custom.theta, "NMFns + Different values in '...' and 'model': correct extra argument IS used in model")
+
+
+ # TODO: run nmf with both algorithm and seeding method
+
+ # test with negative input entries
+ V.neg <- V
+ V.neg[1,1] <- -1
+ checkException( nmf(V.neg, r, my.algo, name='dummy'), 'Throw an error if some input entries are negative and algoritham is declared NOT MIXED')
+ res <- nmf(V.neg, r, my.algo, name='dummy', mixed=TRUE)
+ check.res('Call with dummy MIXED algorithm on input with negative entries'
+ , res
+ , V.neg, r, 'NMFstd', 'dummy')
+
+ # test with negative output entries
+ my.algo <- function(target, start, param1, param2){
+ basis(start)[1,] <- -1
+ start
+ }
+ res <- nmf(V, r, my.algo, name='dummy')
+ check.res('Call with dummy algorithm and MIXED output'
+ , res
+ , V, r, 'NMFstd', 'dummy')
+
+}
+
+#' Unit test for interface nmf: testing the passage of parameters
+test.nmf.parameters <- function(){
+
+ # define a dummy nmf algorithm
+ my.algo <- function(target, start, param1, param2){
+ start
+ }
+
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ check.res('Call with custom algo, model NMF',
+ nmf(V, r, my.algo, name='dummy', model='NMFstd')
+ , V, r, 'NMFstd', 'dummy', 'random')
+
+ check.res('Call with custom algo, model NMFns',
+ nmf(V, r, my.algo, name='dummy', model='NMFns')
+ , V, r, 'NMFns', 'dummy', 'random')
+
+ res <- nmf(V, r, my.algo, name='dummy', model=list('NMFns', theta=0.3))
+ check.res('Call with custom algo, model NMFns, theta in argument model: TEST RES',
+ res
+ , V, r, 'NMFns', 'dummy', 'random')
+ checkEquals(fit(res)@theta, 0.3
+ , 'Call with custom algo, model NMFns, theta in argument model: argument correctly passed to model')
+
+ res <- nmf(V, r, my.algo, name='dummy', model='NMFns', theta=0.3)
+ check.res('Call with custom algo, model NMFns, theta in extra argument: TEST RES',
+ res
+ , V, r, 'NMFns', 'dummy', 'random')
+ checkEquals(fit(res)@theta, 0.3
+ , 'Call with custom algo, model NMFns, theta in extra argument: argument correctly passed to model')
+
+ res <- nmf(V, r, my.algo, name='dummy', model='NMFstd', param1=0.6)
+ check.res('Call with custom algo, model NMFns, plus an extra argument: TEST RES',
+ res
+ , V, r, 'NMFstd', 'dummy', 'random')
+ checkEquals(res at parameters, list(param1=0.6)
+ , 'Call with custom algo, model NMFns, plus an extra argument: argument is passed correctly to algorithm')
+
+ # redefine a dummy nmf algorithm
+ my.algo2 <- function(target, start, theta){
+ start
+ }
+ res <- nmf(V, r, my.algo2, name='dummy', model=list('NMFns', theta=0.3), theta=0.6)
+ check.res('Call with custom algo, model NMFns, theta in argument model AND extra argument: TEST RES',
+ res
+ , V, r, 'NMFns', 'dummy', 'random')
+ checkEquals(fit(res)@theta, 0.3
+ , 'Call with custom algo, model NMFns, theta in argument model AND extra argument: argument model passed to model')
+ checkEquals(res at parameters, list(theta=0.6)
+ , 'Call with custom algo, model NMFns, theta in argument model AND extra argument: extra argument passed to algorithm')
+
+
+ # test seeding
+# # define a dummy seeding method
+# my.seed <- function(model, target, param.s1, param.s2){
+# rnmf(model, target)
+# }
+
+ #res <- nmf(V, r, my.algo2, name='dummy', seed=list(), model=list('NMFns', theta=0.3), theta=0.6)
+
+}
+
+#' Unit test for the interface function: compare
+test.compare <- function(){
+
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+ m <- ncol(V)
+
+ # init a list for the results
+ res <- list()
+
+ # compute NMF using different algorithms
+ res$brunet <- nmf(V, r, 'brunet')
+ res$ns <- nmf(V, r, 'ns')
+ res$offset <- nmf(V, r, 'off')
+ res$snmfr <- nmf(V, r, 'snmf/r')
+ res$snmfl <- nmf(V, r, 'snmf/l')
+
+ classes <- as.factor(sample(seq(r), m, replace=TRUE))
+
+ # compare the results with a list argument
+ checkTrue( is.data.frame(compare(res, class=classes)), "Result of method 'compare' (list) is a data.frame" )
+
+ # compare the results with sorting
+ checkTrue( is.data.frame(compare(res, class=classes, sort.by='method'))
+ , "Result of method 'compare' (list) is a data.frame" )
+
+ # try with multiple runs
+ res$brunet <- nmf(V, r, 'brunet', nrun=10)
+ checkTrue( is.data.frame(compare(res, class=classes)), "Result of method 'compare' (list with multiple runs) is a data.frame" )
+
+ # try with multiple methods
+ res <- nmf(V, r, list('brunet', 'lee', 'offset'))
+ checkTrue( is.data.frame(compare(res, class=classes)), "Result of method 'compare' (list with multiple methods) is a data.frame" )
+
+ # try with multiple runs multiple methods
+ res <- nmf(V, r, list('brunet', 'lee', 'ns'), nrun=3)
+ checkTrue( is.data.frame(compare(res, class=classes))
+ , "Result of method 'compare' (list with multiple runs + multiple methods) is a data.frame" )
+
+}
+
+
+test.summary <- function(){
+
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ # test on a single run
+ checkTrue( is.numeric(summary(nmf(V, r))), 'Single run: result is numeric')
+
+ # test on a multiple run (no keep)
+ checkTrue( is.numeric(summary(nmf(V, r, nrun=3))), 'Multiple run (no keep): result is numeric')
+
+ # test on a multiple run with keep
+ checkTrue( is.numeric(summary(nmf(V, r, nrun=3, .options='k'))), 'Multiple run with keep: result is numeric')
+
+}
+
+test.parallel <- function(){
+
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+ #
+ # run seeded standard sequential run
+ ref <- nmf(V,r, nrun=3, .opt='k-p', seed=123456)
+
+ # identical results with .pbackend='seq' and standard sequential
+ res <- nmf(V,r, nrun=3, .opt='kP', seed=123456, .pbackend='seq')
+ checkTrue( nmf.equal(res, ref), "Identical results with seeded parallel .pbackend='seq' and standard sequential '-p'" )
+
+ # identical results with .pbackend='par' and standard sequential
+ res <- nmf(V,r, nrun=3, .opt='kP', seed=123456, .pbackend='par')
+ checkTrue( nmf.equal(res, ref), "Identical results with seeded parallel .pbackend='par' and standard sequential '-p'" )
+
+ # identical results with .pbackend='mc' and standard sequential
+ res <- nmf(V,r, nrun=3, .opt='kP', seed=123456, .pbackend='mc')
+ checkTrue( nmf.equal(res, ref), "Identical results with seeded parallel .pbackend='mc' and standard sequential '-p'" )
+
+ # identical results with .pbackend='seq' and NA
+ res <- nmf(V,r, nrun=3, .pbackend=NA, seed=123456)
+ checkTrue( nmf.equal(res, ref), "Identical results with seeded .pbackend=NA and standard sequential" )
+
+ # identical results with .pbackend=cluster
+ cl <- makeCluster(2)
+ on.exit( stopCluster(cl), add=TRUE)
+ res <- nmf(V,r, nrun=3, .pbackend=cl, seed=123456)
+ checkTrue( nmf.equal(res, ref), "Identical results with seeded .pbackend=cl and standard sequential" )
+
+ # identical results with .pbackend=NULL and registered backend
+ registerDoParallel(cl)
+ on.exit( registerDoSEQ(), add=TRUE)
+ res <- nmf(V,r, nrun=3, .pbackend=NULL, seed=123456)
+ checkTrue( nmf.equal(res, ref), "Identical results with seeded .pbackend=NULL + registered backend and standard sequential" )
+
+}
+
+#' Unit test for the stopping criterium
+test.nmf.stop <- function(){
+
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+ #
+
+ if( is.null(maxIter <- nmf.getOption('maxIter')) ) maxIter <- 2000L
+ maxIter <- maxIter + 100L
+ checkIdentical( niter(nmf(V, r, .stop=37L)), 37L, "Integer stopping criterium: fixed number of iterations")
+ checkIdentical( niter(nmf(V, r, .stop=maxIter)), maxIter
+ , "Integer stopping criterium greater than default maxIter: fixed number of iterations is honoured")
+ checkIdentical( niter(nmf(V, r, .stop=200L, maxIter=67L)), 67L
+ , "Integer stopping criterium greater than provided maxIter: maxIter is honoured")
+ checkTrue( niter(nmf(V, r, .stop=37)) != 37, "Numeric stopping criterium: stationarity threshold")
+ checkTrue( niter(nmf(V, r, .stop='nmf.stop.stationary')) != 37, "stopping criterium 'stationary' as full name is passed correctly")
+ checkTrue( niter(nmf(V, r, .stop='stationary')) != 37, "stopping criterium 'stationary' as short name is passed correctly")
+
+}
\ No newline at end of file
diff --git a/inst/tests/runit.options.r b/inst/tests/runit.options.r
new file mode 100644
index 0000000..416e0a9
--- /dev/null
+++ b/inst/tests/runit.options.r
@@ -0,0 +1,47 @@
+#' Unit Testing script for NMF package: package specific options
+#'
+#' @author Renaud Gaujoux
+#' @creation 25 July 2009
+
+# make the internal functions/objects visible
+if( isNamespaceLoaded('NMF') ){
+ #.nmf.Options.Runtime <- NMF:::.nmf.Options.Runtime
+}
+
+
+test.nmf.options <-function(){
+
+ # clean up removing created options
+ OLD <- nmf.options()
+ on.exit( nmf.options(OLD) )
+
+ checkTrue( is.list(nmf.options()), 'Options are returned as a list' )
+ checkTrue( is.list(nmf.options('error.track', 'debug')), 'Options are returned as a list' )
+ checkTrue( is.list(nmf.options('error.track')), 'Single option is returned as a list')
+ checkEquals( nmf.options('toto'), list(toto=NULL), 'Unknow in nmf.options returns NULL correctly named')
+ checkTrue( !is.null(nmf.options(toto=6)), 'Can add new option')
+ nmf.options(tata=10)
+ opt <- nmf.options()
+ checkEquals( o <- nmf.options(toto=5, tata=9, titi=25), list(toto=6, tata=10, titi=NULL), 'Changing options return old values')
+ checkIdentical({nmf.options(o); nmf.options()}, opt, "Restoring options works" )
+
+ nmf.options(toto=4)
+ checkEquals( nmf.options(toto=NULL), list(toto=4), 'Removing an option returns old value')
+ checkTrue( !is.element('toto', names(nmf.options())), 'Removing an option actually removes it from the option list')
+
+ #checkException( nmf.options(debug=NULL), 'Removing built-in option is throws an error')
+}
+
+test.nmf.getOption <-function(){
+
+ # clean up removing created options
+ OLD <- nmf.options()
+ on.exit( nmf.options(OLD) )
+
+ checkTrue( is.null(nmf.getOption('toto')), 'Unknow in nmf.getOption returns NULL')
+ nmf.options(toto=5)
+ checkEquals( nmf.getOption('toto'), 5, 'nmf.getOption returns correct value')
+
+ # clean up removing created options
+ nmf.options(toto=NULL)
+}
diff --git a/inst/tests/runit.parallel.r b/inst/tests/runit.parallel.r
new file mode 100644
index 0000000..e5528e1
--- /dev/null
+++ b/inst/tests/runit.parallel.r
@@ -0,0 +1,305 @@
+# Test parallel computations
+#
+# Author: Renaud Gaujoux
+###############################################################################
+
+# make the internal functions/objects visible
+if( isNamespaceLoaded('NMF') ){
+ setupLibPaths <- NMF:::setupLibPaths
+ setupBackend <- NMF:::setupBackend
+}
+
+library(stringr)
+library(foreach)
+
+shared_DEACTIVATED <- function(...){
+ msg <- NULL
+ if( .Platform$OS.type == 'windows' ) msg <- str_c(..., ' [OS: Windows]')
+ else if( !require.quiet(bigmemory) ) msg <- str_c(..., ' [missing: bigmemory]')
+ else if( !require.quiet(synchronicity) ) msg <- str_c(..., ' [missing: synchronicity]')
+
+ if( !is.null(msg) ) DEACTIVATED(msg)
+}
+
+check_shared_memory <- function(.msg, libs=TRUE, seq=FALSE){
+
+ .test <- function(.msg, mutex, libs, seq){
+
+ mess <- function(...){
+ paste(.msg
+ , if( mutex ) "With mutex" else "No mutex"
+ , ":", ...)
+ }
+
+ mtx <- if( mutex ) ts_eval() else force
+
+ if( libs ) setupLibPaths()
+
+ alpha <- 5
+ res <- foreach(i=1:4) %dopar% {
+ t <- Sys.time()
+ if( i==1 ) mtx(Sys.sleep(3))
+ else if( i== 2) Sys.sleep(0.2)
+ mtx({a <- runif(i); c <- 10 * i; d <- alpha + i})
+ b <- c
+ list(i, Sys.getpid(), t, Sys.time(), a, b, c, d)
+ }
+
+ pids <- sapply(res, '[[', 2)
+ wtime <- sapply(res, function(x) round(as.numeric(x[[4]] - x[[3]]), 2))
+ pid <- unique(pids)
+ stopifnot( length(pid) == if( seq ) 1L else 2L )
+
+ # check evaluation
+ checkEquals( length(unlist(lapply(res,'[[', 5))), 4 *5 /2, mess("Evaluation of random draws is OK"))
+ checkIdentical( sapply(res,'[[', 6), 1:4 * 10, mess("Evaluation outside eval call is OK"))
+ checkIdentical( sapply(res,'[[', 7), 1:4 * 10, mess("Evaluation inside eval call is OK"))
+ checkIdentical( sapply(res,'[[', 8), alpha + 1:4, mess("Evaluation inside eval call with exported variable is OK"))
+
+ # return time differences
+ ipid <- if( seq ) 1:2
+ else c(which(pids == pid[1])[1L], which(pids == pid[2])[1L])
+ wt <- wtime[ipid]
+
+# message(mess())
+# message( str_out(wt))
+ wt
+ }
+
+ mess <- function(...) paste(.msg, ":", ...)
+
+ # restore doSEQ backend on.exit
+ on.exit( registerDoSEQ() )
+
+ # no mutex
+ wtime <- .test(mess(), mutex=FALSE, libs, seq)
+ checkTrue( wtime[1] >= 2 , mess("No mutex: Thread 1 waits 2 second (", wtime[1], ')'))
+ checkTrue( wtime[2] < 1 , mess("No mutex: Thread 2 does not wait at all (", wtime[2], ')'))
+
+ # check mutex lock
+ shared_DEACTIVATED("NMF shared memory feature not available.")
+
+ wtime <- .test(mess(), mutex=TRUE, libs, seq)
+ checkTrue( wtime[1] >= 2 , mess("With mutex : Thread 1 waits 2 seconds (", wtime[1], ')'))
+ if( !seq )
+ checkTrue( wtime[2] > 2 , mess("With mutex: Thread 2 also waits at least 2 seconds (", wtime[2], ')'))
+
+}
+
+test.shared_memory_doSEQ <- function(){
+
+ # doSEQ
+ registerDoSEQ()
+ check_shared_memory('doSEQ', libs=FALSE, seq=TRUE)
+
+}
+
+test.shared_memory_doMC <- function(){
+ # doParallel (doMC)
+ library(doParallel)
+ registerDoParallel(2)
+ check_shared_memory('doParallel - Multicore', libs=FALSE)
+
+}
+
+test.shared_memory_doParallel <- function(){
+ # doParallel (doParallel)
+ cl <- makeCluster(2, outfile='wout.log')
+ on.exit( stopCluster(cl), add=TRUE)
+ registerDoParallel(cl)
+ check_shared_memory('doParallel')
+
+}
+
+test.shared_memory_doMPI <- function(){
+ DEACTIVATED("NMF shared memory feature does not currently work with doMPI.")
+ if( !require(doMPI) ) DEACTIVATED("Package doMPI not available.")
+ # doMPI
+ cl_MPI <- startMPIcluster(2)
+ on.exit( closeCluster(cl_MPI), add=TRUE)
+ registerDoMPI(cl_MPI)
+ check_shared_memory('doMPI')
+}
+
+test.setupBackend <- function(){
+
+ # restore backend on.exit
+ on.exit( registerDoSEQ() )
+
+ checkException( setupBackend(-1, 'par', TRUE), "Invalid number of cores (optional)")
+ checkException( setupBackend(-1, 'par', FALSE), "Invalid number of cores (required)")
+ checkException( setupBackend(10, 'par', FALSE), "Required too many cores")
+ checkException( setupBackend(1, 'toto', FALSE), "Required unknown backend")
+
+}
+
+
+test.gVariable <- function(){
+
+ # restore backend on.exit
+ on.exit( registerDoSEQ() )
+
+ .check <- function(.msg, libs=TRUE, seq=FALSE){
+ on.exit( registerDoSEQ() )
+
+ .test <- function(shared){
+ mess <- function(...) paste(.msg, ' + shared=', shared, ":", ...)
+ cat(mess(), "\n")
+
+ # run foreach loop
+ v <- gVariable(123, shared=shared)
+ if( libs ) setupLibPaths(verbose = TRUE)
+ res <- foreach(i=1:20) %dopar% {
+ if(i==1) v(456) else if( i== 2) Sys.sleep(0.2); c(Sys.getpid(), v())
+ }
+
+ # extract result data
+ pids <- sapply(res, '[', 1)
+ vals <- sapply(res, '[', 2)
+ pid <- unique(pids)
+ stopifnot( length(pid) == if( seq ) 1L else 2L )
+
+ # when not shared: only the iterations run by the first process see changes
+ if( !shared && !seq ){
+ checkIdentical( unique(vals[pids==pid[1]]), 456, mess("Value change in first process affects first process"))
+ checkIdentical( unique(vals[pids==pid[2]]), 123, mess("Value change ins first process does not affect second process"))
+ }
+ else{
+ checkIdentical( unique(vals), 456
+ , mess("Value change affects all processes"))
+ }
+ }
+ .test(FALSE)
+
+ shared_DEACTIVATED("NMF global shared variables not available.")
+ .test(TRUE)
+ }
+
+ # doSEQ
+ registerDoSEQ()
+ .check('doSEQ', libs=FALSE, seq=TRUE)
+
+ # doParallel (Multicore)
+ library(doParallel)
+ registerDoParallel(2)
+ .check('doParallel - Multicore')
+
+ # doParallel (doSNOW)
+ cl <- makeCluster(2, outfile='wout.log')
+ on.exit( stopCluster(cl), add=TRUE)
+ registerDoParallel(cl)
+ .check('doParallel')
+
+ # doMPI
+ if( !require(doMPI) ) DEACTIVATED("Package doMPI not available.")
+ cl_MPI <- startMPIcluster(2)
+ on.exit( closeCluster(cl_MPI), add=TRUE)
+ registerDoMPI(cl_MPI)
+ .check('doMPI')
+
+}
+
+test.ForeachBackend <- function(){
+
+ .check <- function(type, n, ...){
+ b <- ForeachBackend(...)
+ checkIdentical(class(b), c(str_c(type, '_backend'), 'foreach_backend'), str_c(type, ": Class is ok"))
+ b
+ }
+
+ # doParallel (Multicore)
+ library(doParallel)
+ .check('doParallel', 3, 'PAR', 3)
+
+ # doParallel (SNOW)
+ cl <- makeCluster(2)
+ on.exit( stopCluster(cl), add=TRUE)
+ b <- .check('doParallel', 2, cl)
+
+ # doMPI
+ if( !require(doMPI) ) DEACTIVATED("Package doMPI not available.")
+ b <- .check('doMPI', 2, 'MPI', 2)
+ cl_MPI <- startMPIcluster(2)
+ on.exit( closeCluster(cl_MPI), add=TRUE)
+ b <- .check('doMPI', 2, cl_MPI)
+
+}
+
+test.nmf <- function(){
+
+ on.exit( registerDoSEQ() )
+
+ set.seed(123456)
+ a <- rmatrix(20,10)
+ nmf.options(cores=2)
+
+ checkTrue( isNMFfit(resREF <- nmf(a, 2, seed=123, nrun=3, .opt='v3')), "Default works")
+
+ cl_loadedNamespaces <- function(cl=NULL){
+ if( is_NA(cl) ) return()
+ if( is.null(cl) ) unique(unlist(foreach(i=1:2) %dopar% { loadedNamespaces() }))
+ else unique(unlist(clusterApplyLB(cl, 1:2, function(i){ loadedNamespaces() })))
+ }
+
+ .check <- function(msg, .options=NULL, ..., LOADED_NAMESPACES=NA){
+
+ be <- getDoBackend()
+ checkTrue( isNMFfit(res2 <- nmf(a, 2, seed=123, nrun=3, .opt=str_c('v3', .options), ...)), str_c(msg, " works"))
+ # retrieve namespaces on dopar processes if necessary
+ ns <- if( !is_NA(LOADED_NAMESPACES) ) cl_loadedNamespaces(LOADED_NAMESPACES)
+
+ checkTrue( nmf.equal(resREF, res2), str_c(msg, ": result is identical to default") )
+ checkIdentical( consensus(resREF, no.attrib=TRUE), consensus(res2, no.attrib=TRUE)
+ , str_c(msg, ": consensus matrice (no.attrib) is identical to default") )
+ checkIdentical( consensus(resREF), consensus(res2), str_c(msg, ": consensus matrice is identical to default") )
+ checkTrue( identical(be, getDoBackend()), str_c(msg, ": backend is restored") )
+
+ # check restoration on error
+ checkException( nmf(a, 2, method=function(...) 1L, seed=123, nrun=3, .opt=str_c('v3', .options), ...), str_c(msg, " throw error if bad method"))
+ checkTrue( identical(be, getDoBackend()), str_c(msg, ": backend is restored after error") )
+
+ # return loaded namespaces
+ ns
+ }
+
+ library(parallel)
+
+ .check('SEQ', .pbackend='SEQ')
+ # Multicore
+ if( parallel::detectCores() > 1 )
+ .check('P2', .options='P2')
+
+ # SNOW-type from char spec
+ .check('.pbackend="psock"', .options='P2', .pbackend='PSOCK')
+
+ # SNOW-type
+ cl <- makeCluster(2)
+ on.exit( stopCluster(cl), add=TRUE)
+ lpkg0 <- cl_loadedNamespaces(cl)
+ lpkg1 <- .check('.pbackend=cl + SNOW-like cluster', .pbackend=cl, LOADED_NAMESPACES=cl)
+# if( !isCHECK() ){ #TODO: investigate why this test does not work in R CMD check
+# checkTrue(length(setdiff(lpkg1, lpkg0)) > 0, "Provided cluster was used if .pbackend=cl")
+# }
+ stopCluster(cl)
+
+ library(doParallel)
+ cl <- makeCluster(2)
+ registerDoParallel(cl)
+ lpkg0 <- cl_loadedNamespaces(NULL)
+ # no .pbackend => use registered cluster
+ lpkg1 <- .check('doParallel registered cluster + P2 [should not use registered cluster]', .opt='P2'
+ , LOADED_NAMESPACES=NULL)
+ checkIdentical(lpkg0, lpkg1, "Registered cluster was not used if .opt='P2'")
+ # .pbackend=NULL
+ lpkg1 <- .check('.pbackend=NULL + doParallel registered cluster', .pbackend=NULL
+ , LOADED_NAMESPACES=NULL)
+ checkTrue(length(setdiff(lpkg1, lpkg0))>0, "Registered cluster was used if .pbackend=NULL")
+
+ # MPI
+ if( !require(doMPI) ) DEACTIVATED("Package doMPI not available.")
+ cl_MPI <- startMPIcluster(2)
+ on.exit( closeCluster(cl_MPI), add=TRUE)
+ .check('.pbackend=cl_MPI + MPI cluster', .pbackend=cl_MPI)
+ registerDoMPI(cl_MPI)
+ .check('.pbackend=NULL + doMPI registered MPI cluster', .pbackend=NULL)
+}
diff --git a/inst/tests/runit.seed.r b/inst/tests/runit.seed.r
new file mode 100644
index 0000000..41bdffc
--- /dev/null
+++ b/inst/tests/runit.seed.r
@@ -0,0 +1,252 @@
+#' Unit Testing script for NMF package: seeding methods.
+#'
+#' @author Renaud Gaujoux
+#' @creation 17 Jul 2009
+
+# make the internal functions/objects visible
+if( isNamespaceLoaded('NMF') ){
+ seed <- NMF:::seed
+}
+
+.testData <- function(n=20, r=3, m=10, ...){
+ syntheticNMF(n, r, m, ...)
+}
+
+#' Unit test for seeding method: none
+test.none <- function(){
+
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+ n <- nrow(V); m <- ncol(V);
+
+ # seed with the matrix
+ obj <- seed(V, r, 'none')
+ checkTrue( is(obj, 'NMFfit') , "Seeded object is an instance of class 'NMFfit'")
+ checkTrue( is(fit(obj), 'NMFstd') , "Seeded model is an instance of class 'NMFstd'")
+ checkTrue( is.empty.nmf(obj), 'Should not initialize the NMF object')
+ checkEquals( nbasis(obj), r, 'Seeded object have the correct rank')
+
+ # seed with empty object
+ obj.init <- nmfModel(r)
+ obj <- seed(V, obj.init, 'none')
+ checkTrue( identical(fit(obj), obj.init), 'Empty object: seeded object is identical to the initial one')
+
+ # seed with dummy object
+ obj.init <- nmfModel(r, model='NMFstd', W=matrix(seq(n*r), n, r), H=matrix(seq(r*m), r, m))
+ obj <- seed(V, obj.init, 'none')
+ checkTrue( identical(fit(obj), obj.init), 'Dummy object: seeded object is identical to the initial one')
+
+}
+
+
+#' Utility function for \code{test.seed}: performs a set of test on a seeded object
+check.seed <- function(title, obj, V, r, seeding.meth, expect.class, exact.class=TRUE){
+
+ checkTrue( inherits(obj, 'NMFfit'), paste(title, ": result class inherits from 'NMFfit'") )
+ checkTrue( inherits(fit(obj), 'NMF'), paste(title, ": model class inherits from 'NMF'") )
+
+ if( exact.class )
+ checkTrue( is(fit(obj), expect.class), paste(title, ": default class returned is '", expect.class, "'") )
+ else
+ checkTrue( inherits(fit(obj), expect.class), paste(title, ": default class returned inherits from '", expect.class, "'") )
+
+ checkTrue( !is.empty.nmf(obj) , paste(title, ": Seeded object is not empty"))
+ checkEquals( nbasis(obj), r , paste(title, ": Seeded object has correct rank"))
+ checkEquals( nrow(obj), nrow(V) , paste(title, ": Seeded object has correct number of rows"), checkNames=FALSE)
+ checkEquals( ncol(obj), ncol(V) , paste(title, ": Seeded object has correct number of columns"), checkNames=FALSE)
+ checkEquals( seeding(obj), seeding.meth, "Seeding method's name is correctly set")
+
+}
+
+#' Unit test for compatibility of algorithms and seeding methods
+test.zzz.all <- function(){
+
+ set.seed(123)
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+ n <- nrow(V); m <- ncol(V);
+
+ # list the available algorithms
+ algorithms <- nmfAlgorithm()
+ algorithms <- algorithms[!algorithms %in% c('ls-nmf', 'pe-nmf', 'siNMF')]
+ # list the available seeding methods
+ seed.methods <- nmfSeed()
+ seed.methods <- seed.methods[which(seed.methods != 'none')]
+
+ test_algo <- function(name.algo, ..., target_rank=r){
+ sapply(seed.methods,
+ function(name.seed, ...){
+ message("\n###########\n# ", name.algo, " + ", name.seed, "\n#############")
+ err <- try(obj <- nmf(..., method=name.algo, seed=name.seed))
+ checkTrue( !is(err, 'try-error'), paste('Run OK - Algo:', name.algo, '+ Seed:', name.seed, if( is(err, 'try-error') ) paste('[Error: ', err, ']') else NULL) )
+ check.seed(paste('Algo:', name.algo, '+ Seed:', name.seed), obj, V, target_rank, name.seed, 'NMF', exact.class=FALSE)
+ }
+ , ...)
+ }
+
+ # all algorithms
+ sapply(algorithms, test_algo, V, r)
+ # PE-NMF
+ test_algo('pe-nmf', V, r, alpha=1, beta=0.1)
+ # LS-NMF
+ test_algo('ls-nmf', V, r, weight=rmatrix(V))
+ # siNMF
+ g <- gl(2, m/2)
+ test_algo('siNMF', V ~ g, r, target_rank=r+2)
+}
+
+
+#' Utility check function: checks the range of value in a NMF object
+check.range <- function(title, nmf.fit, max){
+ obj <- fit(nmf.fit)
+ checkTrue( all(basis(obj) <= max & basis(obj) >= 0), paste(title, ': All entries of W are between 0 and', max) )
+ checkTrue( all(coef(obj) <= max & coef(obj) >= 0), paste(title, ': All entries of H are between 0 and', max) )
+}
+
+#' Unit test for seeding method: random
+test.random <- function(){
+
+ .seedTest <- 123456
+ # create dummy matrix
+ V.na <- matrix(NA, 50, 20)
+ r <- 3
+
+ # check the range of the generated values
+ obj <- seed(V.na, r, 'random')
+ check.range('NA matrix', obj, 1)
+
+ max <- 0.05
+ obj <- seed(matrix(max, 50, 20), r, 'random')
+ check.range(paste('Matrix', max), obj, max)
+
+ # seed with the matrix
+ set.seed(.seedTest)
+ obj <- seed(V.na, r, 'random')
+ check.seed('With matrix', obj, V.na, r, 'random', 'NMFstd')
+
+ # test randomness
+ obj2 <- seed(V.na, r, 'random')
+ checkTrue( !identical(obj2, obj), 'Seeded objects are different if seed has not been fixed before seeding')
+ # test reproducibility
+ set.seed(.seedTest)
+ obj.bis <- seed(V.na, r, 'random')
+ checkTrue( nmf.equal(obj.bis, obj), 'Seeded NMF models are identical if seed has been reset to the same value before seeding')
+
+ # seed with object
+ set.seed(.seedTest)
+ nmfOff <- nmfModel(r, model='NMFOffset')
+ obj <- seed(V.na, nmfOff, 'random')
+ max <- 1
+ check.seed('With NMFOffset object', obj, V.na, r, 'random', 'NMFOffset')
+ check.range(paste('Object NMFOffset', max), obj, max)
+ checkTrue( all(offset(fit(obj)) <= max & offset(fit(obj)) >= 0), paste('Object NMFOffset: All entries of Offset are between 0 and', max) )
+
+ # seed with numeric value
+ res <- seed(V.na, r, .seedTest)
+ # manually reset name for seeding method
+ set.seed(.seedTest)
+ checkTrue( nmf.equal(seed(V.na, r, 'random'), res), "Seeded NMF models are identical when setting random generator seed and call method 'seed' with the same numerical seed (except for name of seeding method)")
+
+}
+
+check.seed.change <- function(msg, expr, base){
+
+ bs <- .Random.seed
+ e <- parent.frame()
+ eval(expr, env=e)
+
+ if( base ) checkTrue( any(bs != .Random.seed), paste(msg, ": .Random.seed IS changed"))
+ else checkIdentical(bs, .Random.seed, paste(msg, ": .Random.seed is NOT changed"))
+
+}
+
+#' Unit tests for checking the impact of seeding nmf computation on the .Random.seed
+test.seed.effect <- function(){
+ # set random seed
+ set.seed(123456)
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ # Single runs
+ check.seed.change("After single run without seed", nmf(V, r), TRUE)
+ check.seed.change("After single run without seed (NO-REPRO has no effect)", nmf(V, r), TRUE)
+ check.seed.change("After single run with seed", nmf(V, r, seed=123), FALSE)
+ #
+ # Multiple runs: NO seed
+ check.seed.change("After multiple runs without seed (sapply)", nmf(V, r, nrun=3, .opt='-p'), TRUE)
+ check.seed.change("NO-REPRO: After multiple runs without seed (sapply)", nmf(V, r, nrun=3, .opt='-pR'), TRUE)
+ check.seed.change("After multiple runs without seed (foreach-MC)", nmf(V, r, nrun=3, .opt='P', .pbackend='par'), TRUE)
+ check.seed.change("NO-REPRO: After multiple runs without seed (foreach-MC)", nmf(V, r, nrun=3, .opt='P-R', .pbackend='par'), TRUE)
+ check.seed.change("After multiple runs without seed (foreach-SEQ)", nmf(V, r, nrun=3, .opt='P', .pbackend='seq'), TRUE)
+ check.seed.change("NO-REPRO: After multiple runs without seed (foreach-SEQ)", nmf(V, r, nrun=3, .opt='P-R', .pbackend='seq'), TRUE)
+
+ # Multiple runs: WITH numeric seed
+ check.seed.change("After multiple runs with seed (sapply)", nmf(V, r, nrun=3, seed=1234, .opt='-p'), FALSE)
+ check.seed.change("NO-REPRO: After multiple runs with seed (sapply)", nmf(V, r, nrun=3, seed=1234, .opt='-pR'), FALSE)
+ check.seed.change("After multiple runs with seed (foreach-MC)", nmf(V, r, nrun=3, seed=1234, .opt='P', .pback='par'), FALSE)
+ check.seed.change("NO-REPRO: After multiple runs with seed (foreach-MC)", nmf(V, r, nrun=3, seed=1234, .opt='P-R', .pback='par'), FALSE)
+ check.seed.change("After multiple runs with seed (foreach-SEQ)", nmf(V, r, nrun=3, seed=1234, .opt='P', .pback='seq'), FALSE)
+ check.seed.change("NO-REPRO: After multiple runs with seed (foreach-SEQ)", nmf(V, r, nrun=3, seed=1234, .opt='P-R', .pback='seq'), FALSE)
+
+ # Multiple runs: WITH NA seed
+# check.seed.change("After multiple runs with NA seed (sapply)", nmf(V, r, nrun=3, seed=NA, .opt='-p'), FALSE)
+# check.seed.change("NO-REPRO: After multiple runs with NA seed (sapply)", nmf(V, r, nrun=3, seed=NA, .opt='-pR'), TRUE)
+# check.seed.change("After multiple runs with NA seed (foreach-MC)", nmf(V, r, nrun=3, seed=NA, .opt='P', .pback='par'), FALSE)
+# check.seed.change("NO-REPRO: After multiple runs with NA seed (foreach-MC)", nmf(V, r, nrun=3, seed=NA, .opt='P-R', .pback='par'), FALSE)
+# check.seed.change("After multiple runs with NA seed (foreach-SEQ)", nmf(V, r, nrun=3, seed=NA, .opt='P', .pback='seq'), FALSE, TRUE)
+# check.seed.change("NO-REPRO: After multiple runs with NA seed (foreach-SEQ)", nmf(V, r, nrun=3, seed=NA, .opt='P-R', .pback='seq'), TRUE)
+}
+
+#' test the restoration of the random seed
+test.restore <- function(){
+
+ DEACTIVATED("The option 'restore.seed' is deprecated. Related tests are now in test.seed.effect")
+
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ # default call no seed
+ os <- .Random.seed
+ nmf(V, r)
+ checkTrue( !(all.equal(os, .Random.seed) == TRUE ), "call with no seed: seed is correctly NOT restored")
+
+ # default call
+ os <- .Random.seed
+ nmf(V, r, seed=1)
+ checkIdentical(os, .Random.seed, "Default behaviour is to restore the seed: seed is correctly restored")
+
+ # force restore
+ os <- .Random.seed
+ nmf(V, r, .opt='r', seed=12)
+ checkIdentical(os, .Random.seed, "force seed restoration with 'r': seed correctly restored")
+ os <- .Random.seed
+ nmf(V, r, .opt=list(restore.seed=TRUE), seed=123)
+ checkIdentical(os, .Random.seed, "force seed restoration with 'restore.seed=TRUE': seed correctly restored")
+
+ # do not restore
+ os <- .Random.seed
+ nmf(V, r, .opt='-r', seed=1234)
+ checkTrue( !(all.equal(os, .Random.seed) == TRUE), "Disable seed restoration with '-r': seed correctly NOT restored")
+ os <- .Random.seed
+ nmf(V, r, .opt=list(restore.seed=FALSE), seed=12345)
+ checkTrue( !(all.equal(os, .Random.seed) == TRUE), "force seed restoration with 'restore.seed=FALSE': seed correctly NOT restored")
+
+}
+
+#' Unit test for seeding method: Non-Negative Double SVD (nndsvd)
+test.nndsvd <- function(){
+
+ .seedTest <- 123456
+ set.seed(.seedTest)
+
+ # create a random target matrix
+ r <- 3; V <- .testData(r=r)
+
+ # perform NMF with seed 'nndsvd'
+ check.seed.change('seeding with "nndsvd"', obj <- seed(V, r, 'nndsvd'), FALSE)
+ check.seed('With matrix', obj, V, r, 'nndsvd', 'NMF')
+ # redo: should be the same (one needs identical=FALSE because svd() may return slightly different values)
+ obj.bis <- seed(V, r, 'nndsvd')
+ checkTrue( nmf.equal(obj.bis, obj, identical=FALSE), 'Seeded NMF models are identical for every run')
+
+}
diff --git a/inst/tests/runit.utils.r b/inst/tests/runit.utils.r
new file mode 100644
index 0000000..d393e2c
--- /dev/null
+++ b/inst/tests/runit.utils.r
@@ -0,0 +1,110 @@
+#' Unit Testing script for NMF package: NMF utility functions.
+#'
+#' @author Renaud Gaujoux
+#' @creation 10 Aug 2010
+
+
+#' Unit test for rmatrix: random matrix generation
+test.rmatrix <- function(){
+
+ n <- 100; p <- 20
+ A <- matrix(1, n, p)
+
+ # square matrix if y is missing
+ set.seed(123456); M <- matrix(runif(n*n), n, n)
+ set.seed(123456); checkIdentical(M, rmatrix(n), "Square matrix if 'y' is missing")
+ set.seed(123456); checkIdentical(M, rmatrix(matrix(NA, nrow(M), ncol(M))), "Correct if 'x' is a matrix")
+
+ # from NMF model
+ model <- rnmf(3, A)
+ set.seed(123456); M <- fitted(model) + matrix(runif(n*p), n, p)
+ set.seed(123456); checkIdentical(M, rmatrix(model), "Correct if 'x' is an NMF model")
+ set.seed(123456); M <- fitted(model) + matrix(rnorm(n*p), n, p)
+ set.seed(123456); checkIdentical(M, rmatrix(model, dist=rnorm), "dist is passed correctly if 'x' is an NMF model")
+
+ # default dist is uniform
+ set.seed(123456); M <- matrix(runif(n*p), n, p)
+ set.seed(123456); checkIdentical(M, rmatrix(n, p), "Default correctly to 'runif'")
+ set.seed(123456); checkIdentical(M, rmatrix(A), "Default correctly to 'runif' (arg: matrix)")
+
+ # argument byrow is correctly passed
+ set.seed(123456); M <- matrix(runif(n*p), n, p, byrow=TRUE)
+ set.seed(123456); checkIdentical(M, rmatrix(n, p, byrow=TRUE), "argument byrow is correctly passed")
+ set.seed(123456); checkIdentical(M, rmatrix(A, byrow=TRUE), "argument byrow is correctly passed (arg: matrix)")
+
+ # argument dimnames is correctly passed
+ dims <-list(rep('a',n), rep('b',p))
+ set.seed(123456); M <- matrix(runif(n*p), n, p, dimnames=dims)
+ set.seed(123456); checkIdentical(M, rmatrix(n, p, dimnames=dims), "argument dimnames is correctly passed")
+ set.seed(123456); checkIdentical(M, rmatrix(A, dimnames=dims), "argument dimnames is correctly passed (arg: matrix)")
+
+ # can pass distribution function
+ set.seed(123456); M <- matrix(rnorm(n*p), n, p)
+ set.seed(123456); checkIdentical(M, rmatrix(n, p, dist=rnorm), "argument dist is correctly passed")
+ set.seed(123456); checkIdentical(M, rmatrix(A, dist=rnorm), "argument dist is correctly passed (arg: matrix)")
+
+ # can pass distribution functions as third argument
+ set.seed(123456); M <- matrix(rnorm(n*p), n, p)
+ set.seed(123456); checkIdentical(M, rmatrix(n, p, rnorm), "argument dist is the third argument")
+ set.seed(123456); checkIdentical(M, rmatrix(A, rnorm), "argument dist is the second argument (arg: matrix)")
+
+ # can pass extra arguments to distribution function
+ set.seed(123456); M <- matrix(rnorm(n*p, 20), n, p)
+ set.seed(123456); checkIdentical(M, rmatrix(n, p, rnorm, mean=20), "extra arguments are passed to the distribution function")
+ set.seed(123456); checkIdentical(M, rmatrix(A, rnorm, mean=20), "extra arguments are passed to the distribution function (arg: matrix)")
+}
+
+#test.ptr_neq_constraints <- function(){
+#
+# .do_constrain <- function(...){
+#
+# }
+#
+# .check <- function(c, msg){
+# .msg <- function(...) paste(msg, ':', ...)
+# x <- rmatrix(20,3)
+# y <- NMF:::neq.constraints.inplace(x, copy=TRUE)
+# checkIdentical(max.col(y[1:9,]), c(rep(1,3), rep(2,3), rep(3,3)), .msg("Max are ok"))
+# checkIdentical(y[-(1:9,], , .msg("Non constrained rows are identical"))
+# }
+#
+# #.check(list(1:3,4:6,7:9), "")
+#
+#
+#
+#}
+
+
+test.nmfWrapper <- function(){
+
+ .msg <- NULL
+ msg <- function(...) paste(.msg, ': ', ..., sep='')
+
+ f <- nmfWrapper('lee')
+ x <- rmatrix(20, 10)
+ checkTrue( isNMFfit(res <- f(x, 3)), msg('result is an NMFfit object') )
+ checkIdentical(nbasis(res), 3L, msg('result was computed using the correct rank') )
+ checkIdentical(algorithm(res), 'lee', msg('result was computed using the correct algorithm') )
+
+
+ .msg <- 'with default maxIter and seed value'
+ f <- nmfWrapper('nsNMF', maxIter=3, seed='nndsvd')
+ checkTrue( isNMFfit(res <- f(x, 2)), msg('result is an NMFfit object' ))
+ checkIdentical(nbasis(res), 2L, msg('result was computed using the correct rank') )
+ checkIdentical(algorithm(res), 'nsNMF', msg('result was computed using the correct algorithm') )
+ checkIdentical(niter(res), 3L, msg('result was computed using the correct number of iterations') )
+ checkIdentical(seeding(res), 'nndsvd', msg('result was computed using the correct seed') )
+ # overwrite default in call
+ .msg <- 'overwriting defaults in call'
+ checkTrue( isNMFfit(res <- f(x, 4, seed='random')), msg('result is an NMFfit object' ))
+ checkIdentical(nbasis(res), 4L, msg('result was computed using the correct rank') )
+ checkIdentical(algorithm(res), 'nsNMF', msg('result was computed using the correct algorithm') )
+ checkIdentical(niter(res), 3L, msg('result was computed using the correct number of iterations') )
+ checkIdentical(seeding(res), 'random', msg('result was computed using the correct seed') )
+ # pass method as well
+ .msg <- 'overwriting defaults in call + try overwrite method'
+ checkWarning(res <- f(x, 4, method='lee', seed='random'), 'Discarding fixed arguments.*', msg('a warning is thrown'))
+ checkTrue( isNMFfit(res), msg('result is an NMFfit object' ))
+ checkIdentical(algorithm(res), 'nsNMF', msg('result was still computed using the correct algorithm defined in nmfWrapper') )
+
+}
\ No newline at end of file
diff --git a/man/Frobenius-nmf.Rd b/man/Frobenius-nmf.Rd
new file mode 100644
index 0000000..df8e72d
--- /dev/null
+++ b/man/Frobenius-nmf.Rd
@@ -0,0 +1,143 @@
+\name{nmf_update.lee_R}
+\alias{Frobenius-nmf}
+\alias{lee-nmf}
+\alias{lee_R-nmf}
+\alias{nmfAlgorithm.Frobenius}
+\alias{nmfAlgorithm.lee}
+\alias{nmfAlgorithm.lee_R}
+\alias{nmf_update.lee}
+\alias{nmf_update.lee_R}
+\title{NMF Algorithm/Updates for Frobenius Norm}
+\usage{
+ nmf_update.lee_R(i, v, x, rescale = TRUE, eps = 10^-9,
+ ...)
+
+ nmf_update.lee(i, v, x, rescale = TRUE, copy = FALSE,
+ eps = 10^-9, weight = NULL, ...)
+
+ nmfAlgorithm.lee_R(..., .stop = NULL,
+ maxIter = nmf.getOption("maxIter") \%||\% 2000,
+ rescale = TRUE, eps = 10^-9, stopconv = 40,
+ check.interval = 10)
+
+ nmfAlgorithm.lee(..., .stop = NULL,
+ maxIter = nmf.getOption("maxIter") \%||\% 2000,
+ rescale = TRUE, copy = FALSE, eps = 10^-9,
+ weight = NULL, stopconv = 40, check.interval = 10)
+
+ nmfAlgorithm.Frobenius(..., .stop = NULL,
+ maxIter = nmf.getOption("maxIter") \%||\% 2000,
+ rescale = TRUE, copy = FALSE, eps = 10^-9,
+ weight = NULL, stationary.th = .Machine$double.eps,
+ check.interval = 5 * check.niter, check.niter = 10L)
+}
+\arguments{
+ \item{rescale}{logical that indicates if the basis matrix
+ \eqn{W} should be rescaled so that its columns sum up to
+ one.}
+
+ \item{i}{current iteration number.}
+
+ \item{v}{target matrix.}
+
+ \item{x}{current NMF model, as an
+ \code{\linkS4class{NMF}} object.}
+
+ \item{eps}{small numeric value used to ensure numeric
+ stability, by shifting up entries from zero to this fixed
+ value.}
+
+ \item{...}{extra arguments. These are generally not used
+ and present only to allow other arguments from the main
+ call to be passed to the initialisation and stopping
+ criterion functions (slots \code{onInit} and \code{Stop}
+ respectively).}
+
+ \item{copy}{logical that indicates if the update should
+ be made on the original matrix directly (\code{FALSE}) or
+ on a copy (\code{TRUE} - default). With \code{copy=FALSE}
+ the memory footprint is very small, and some speed-up may
+ be achieved in the case of big matrices. However, greater
+ care should be taken due the side effect. We recommend
+ that only experienced users use \code{copy=TRUE}.}
+
+ \item{.stop}{specification of a stopping criterion, that
+ is used instead of the one associated to the NMF
+ algorithm. It may be specified as: \itemize{ \item the
+ access key of a registered stopping criterion; \item a
+ single integer that specifies the exact number of
+ iterations to perform, which will be honoured unless a
+ lower value is explicitly passed in argument
+ \code{maxIter}. \item a single numeric value that
+ specifies the stationnarity threshold for the objective
+ function, used in with \code{\link{nmf.stop.stationary}};
+ \item a function with signature
+ \code{(object="NMFStrategy", i="integer", y="matrix",
+ x="NMF", ...)}, where \code{object} is the
+ \code{NMFStrategy} object that describes the algorithm
+ being run, \code{i} is the current iteration, \code{y} is
+ the target matrix and \code{x} is the current value of
+ the NMF model. }}
+
+ \item{maxIter}{maximum number of iterations to perform.}
+
+ \item{stopconv}{number of iterations intervals over which
+ the connectivity matrix must not change for stationarity
+ to be achieved.}
+
+ \item{check.interval}{interval (in number of iterations)
+ on which the stopping criterion is computed.}
+
+ \item{stationary.th}{maximum absolute value of the
+ gradient, for the objective function to be considered
+ stationary.}
+
+ \item{check.niter}{number of successive iteration used to
+ compute the stationnary criterion.}
+
+ \item{weight}{numeric vector of sample weights, e.g.,
+ used to normalise samples coming from multiple datasets.
+ It must be of the same length as the number of
+ samples/columns in \code{v} -- and \code{h}.}
+}
+\description{
+ The built-in NMF algorithms described here minimise the
+ Frobenius norm (Euclidean distance) between an NMF model
+ and a target matrix. They use the updates for the basis
+ and coefficient matrices (\eqn{W} and \eqn{H}) defined by
+ \cite{Lee et al. (2001)}.
+
+ \code{nmf_update.lee} implements in C++ an optimised
+ version of the single update step.
+
+ Algorithms \sQuote{lee} and \sQuote{.R#lee} provide the
+ complete NMF algorithm from \cite{Lee et al. (2001)},
+ using the C++-optimised and pure R updates
+ \code{\link{nmf_update.lee}} and
+ \code{\link{nmf_update.lee_R}} respectively.
+
+ Algorithm \sQuote{Frobenius} provides an NMF algorithm
+ based on the C++-optimised version of the updates from
+ \cite{Lee et al. (2001)}, which uses the stationarity of
+ the objective value as a stopping criterion
+ \code{\link{nmf.stop.stationary}}, instead of the
+ stationarity of the connectivity matrix
+ \code{\link{nmf.stop.connectivity}} as used by
+ \sQuote{lee}.
+}
+\details{
+ \code{nmf_update.lee_R} implements in pure R a single
+ update step, i.e. it updates both matrices.
+}
+\author{
+ Original update definition: D D Lee and HS Seung
+
+ Port to R and optimisation in C++: Renaud Gaujoux
+}
+\references{
+ Lee DD and Seung H (2001). "Algorithms for non-negative
+ matrix factorization." _Advances in neural information
+ processing systems_. <URL:
+ http://scholar.google.com/scholar?q=intitle:Algorithms+for+non-negative+matrix+factorization\#0>.
+}
+
diff --git a/man/KL-nmf.Rd b/man/KL-nmf.Rd
new file mode 100644
index 0000000..37a3df1
--- /dev/null
+++ b/man/KL-nmf.Rd
@@ -0,0 +1,174 @@
+\name{nmf_update.brunet_R}
+\alias{brunet_M-nmf}
+\alias{brunet-nmf}
+\alias{brunet_R-nmf}
+\alias{KL-nmf}
+\alias{nmfAlgorithm.brunet}
+\alias{nmfAlgorithm.brunet_M}
+\alias{nmfAlgorithm.brunet_R}
+\alias{nmfAlgorithm.KL}
+\alias{nmf_update.brunet}
+\alias{nmf_update.brunet_R}
+\title{NMF Algorithm/Updates for Kullback-Leibler Divergence}
+\source{
+ Original MATLAB files and references can be found at:
+
+ \url{http://www.broadinstitute.org/mpr/publications/projects/NMF/nmf.m}
+
+ \url{http://www.broadinstitute.org/publications/broad872}
+
+ Original license terms:
+
+ This software and its documentation are copyright 2004 by
+ the Broad Institute/Massachusetts Institute of
+ Technology. All rights are reserved. This software is
+ supplied without any warranty or guaranteed support
+ whatsoever. Neither the Broad Institute nor MIT can not
+ be responsible for its use, misuse, or functionality.
+}
+\usage{
+ nmf_update.brunet_R(i, v, x, eps = .Machine$double.eps,
+ ...)
+
+ nmf_update.brunet(i, v, x, copy = FALSE,
+ eps = .Machine$double.eps, ...)
+
+ nmfAlgorithm.brunet_R(..., .stop = NULL,
+ maxIter = nmf.getOption("maxIter") \%||\% 2000,
+ eps = .Machine$double.eps, stopconv = 40,
+ check.interval = 10)
+
+ nmfAlgorithm.brunet(..., .stop = NULL,
+ maxIter = nmf.getOption("maxIter") \%||\% 2000,
+ copy = FALSE, eps = .Machine$double.eps, stopconv = 40,
+ check.interval = 10)
+
+ nmfAlgorithm.KL(..., .stop = NULL,
+ maxIter = nmf.getOption("maxIter") \%||\% 2000,
+ copy = FALSE, eps = .Machine$double.eps,
+ stationary.th = .Machine$double.eps,
+ check.interval = 5 * check.niter, check.niter = 10L)
+
+ nmfAlgorithm.brunet_M(..., object, y, x)
+}
+\arguments{
+ \item{i}{current iteration number.}
+
+ \item{v}{target matrix.}
+
+ \item{x}{current NMF model, as an
+ \code{\linkS4class{NMF}} object.}
+
+ \item{eps}{small numeric value used to ensure numeric
+ stability, by shifting up entries from zero to this fixed
+ value.}
+
+ \item{...}{extra arguments. These are generally not used
+ and present only to allow other arguments from the main
+ call to be passed to the initialisation and stopping
+ criterion functions (slots \code{onInit} and \code{Stop}
+ respectively).}
+
+ \item{copy}{logical that indicates if the update should
+ be made on the original matrix directly (\code{FALSE}) or
+ on a copy (\code{TRUE} - default). With \code{copy=FALSE}
+ the memory footprint is very small, and some speed-up may
+ be achieved in the case of big matrices. However, greater
+ care should be taken due the side effect. We recommend
+ that only experienced users use \code{copy=TRUE}.}
+
+ \item{.stop}{specification of a stopping criterion, that
+ is used instead of the one associated to the NMF
+ algorithm. It may be specified as: \itemize{ \item the
+ access key of a registered stopping criterion; \item a
+ single integer that specifies the exact number of
+ iterations to perform, which will be honoured unless a
+ lower value is explicitly passed in argument
+ \code{maxIter}. \item a single numeric value that
+ specifies the stationnarity threshold for the objective
+ function, used in with \code{\link{nmf.stop.stationary}};
+ \item a function with signature
+ \code{(object="NMFStrategy", i="integer", y="matrix",
+ x="NMF", ...)}, where \code{object} is the
+ \code{NMFStrategy} object that describes the algorithm
+ being run, \code{i} is the current iteration, \code{y} is
+ the target matrix and \code{x} is the current value of
+ the NMF model. }}
+
+ \item{maxIter}{maximum number of iterations to perform.}
+
+ \item{object}{an object computed using some algorithm, or
+ that describes an algorithm itself.}
+
+ \item{y}{data object, e.g. a target matrix}
+
+ \item{stopconv}{number of iterations intervals over which
+ the connectivity matrix must not change for stationarity
+ to be achieved.}
+
+ \item{check.interval}{interval (in number of iterations)
+ on which the stopping criterion is computed.}
+
+ \item{stationary.th}{maximum absolute value of the
+ gradient, for the objective function to be considered
+ stationary.}
+
+ \item{check.niter}{number of successive iteration used to
+ compute the stationnary criterion.}
+}
+\description{
+ The built-in NMF algorithms described here minimise the
+ Kullback-Leibler divergence (KL) between an NMF model and
+ a target matrix. They use the updates for the basis and
+ coefficient matrices (\eqn{W} and \eqn{H}) defined by
+ \cite{Brunet et al. (2004)}, which are essentially those
+ from \cite{Lee et al. (2001)}, with an stabilisation step
+ that shift up all entries from zero every 10 iterations,
+ to a very small positive value.
+
+ \code{nmf_update.brunet} implements in C++ an optimised
+ version of the single update step.
+
+ Algorithms \sQuote{brunet} and \sQuote{.R#brunet} provide
+ the complete NMF algorithm from \cite{Brunet et al.
+ (2004)}, using the C++-optimised and pure R updates
+ \code{\link{nmf_update.brunet}} and
+ \code{\link{nmf_update.brunet_R}} respectively.
+
+ Algorithm \sQuote{KL} provides an NMF algorithm based on
+ the C++-optimised version of the updates from
+ \cite{Brunet et al. (2004)}, which uses the stationarity
+ of the objective value as a stopping criterion
+ \code{\link{nmf.stop.stationary}}, instead of the
+ stationarity of the connectivity matrix
+ \code{\link{nmf.stop.connectivity}} as used by
+ \sQuote{brunet}.
+
+ \samp{ library(RcppOctave)
+ file.show(system.mfile('brunet.m', package='NMF')) }
+}
+\details{
+ \code{nmf_update.brunet_R} implements in pure R a single
+ update step, i.e. it updates both matrices.
+}
+\author{
+ Original implementation in MATLAB: Jean-Philippe Brunet
+ \email{brunet at broad.mit.edu}
+
+ Port to R and optimisation in C++: Renaud Gaujoux
+}
+\references{
+ Brunet J, Tamayo P, Golub TR and Mesirov JP (2004).
+ "Metagenes and molecular pattern discovery using matrix
+ factorization." _Proceedings of the National Academy of
+ Sciences of the United States of America_, *101*(12), pp.
+ 4164-9. ISSN 0027-8424, <URL:
+ http://dx.doi.org/10.1073/pnas.0308531101>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/15016911>.
+
+ Lee DD and Seung H (2001). "Algorithms for non-negative
+ matrix factorization." _Advances in neural information
+ processing systems_. <URL:
+ http://scholar.google.com/scholar?q=intitle:Algorithms+for+non-negative+matrix+factorization\#0>.
+}
+
diff --git a/man/NMF-class.Rd b/man/NMF-class.Rd
new file mode 100644
index 0000000..55fd9e7
--- /dev/null
+++ b/man/NMF-class.Rd
@@ -0,0 +1,474 @@
+\docType{class}
+\name{NMF-class}
+\alias{.DollarNames,NMF-method}
+\alias{misc}
+\alias{NMF-class}
+\alias{$<-,NMF-method}
+\alias{$,NMF-method}
+\title{Generic Interface for Nonnegative Matrix Factorisation Models}
+\usage{
+ misc(object, ...)
+
+ \S4method{$}{NMF}(x, name)
+
+ \S4method{$}{NMF}(x, name)<-value
+
+ \S4method{.DollarNames}{NMF}(x, pattern = "")
+}
+\arguments{
+ \item{object}{an object that inherit from class
+ \code{NMF}}
+
+ \item{...}{extra arguments (not used)}
+
+ \item{x}{ object from which to extract element(s) or in
+ which to replace element(s). }
+
+ \item{name}{ A literal character string or a \link{name}
+ (possibly \link{backtick} quoted). For extraction, this
+ is normally (see under \sQuote{Environments}) partially
+ matched to the \code{\link{names}} of the object. }
+
+ \item{value}{typically an array-like \R object of a
+ similar class as \code{x}.}
+
+ \item{pattern}{ A regular expression. Only matching
+ names are returned. }
+}
+\description{
+ The class \code{NMF} is a \emph{virtual class} that
+ defines a common interface to handle Nonnegative Matrix
+ Factorization models (NMF models) in a generic way.
+ Provided a minimum set of generic methods is implemented
+ by concrete model classes, these benefit from a whole set
+ of functions and utilities to perform common computations
+ and tasks in the context of Nonnegative Matrix
+ Factorization.
+
+ The function \code{misc} provides access to miscellaneous
+ data members stored in slot \code{misc} (as a
+ \code{list}), which allow extensions of NMF models to be
+ implemented, without defining a new S4 class.
+}
+\details{
+ Class \code{NMF} makes it easy to develop new models that
+ integrate well into the general framework implemented by
+ the \emph{NMF} package.
+
+ Following a few simple guidelines, new types of NMF
+ models benefit from all the functionalities available for
+ the built-in NMF models -- that derive themselves from
+ class \code{NMF}. See section \emph{Implementing NMF
+ models} below.
+
+ See \code{\linkS4class{NMFstd}}, and references and links
+ therein for details on the built-in implementations of
+ the standard NMF model and its extensions.
+}
+\section{Slots}{
+ \describe{
+
+ \item{misc}{A list that is used internally to temporarily
+ store algorithm parameters during the computation.}
+
+ }
+}
+\section{Methods}{
+ \describe{
+
+ \item{[}{\code{signature(x = "NMF")}: This method
+ provides a convenient way of sub-setting objects of class
+ \code{NMF}, using a matrix-like syntax.
+
+ It allows to consistently subset one or both matrix
+ factors in the NMF model, as well as retrieving part of
+ the basis components or part of the mixture coefficients
+ with a reduced amount of code.
+
+ See \code{\link{[,NMF-method}} for more details. }
+
+ \item{$}{\code{signature(x = "NMF")}: shortcut for
+ \code{x at misc[[name, exact=TRUE]]} respectively. }
+
+ \item{$}{\code{signature(x = "NMF")}: shortcut for
+ \code{x at misc[[name, exact=TRUE]]} respectively. }
+
+ \item{$<-}{\code{signature(x = "NMF")}: shortcut for
+ \code{x at misc[[name]] <- value} }
+
+ \item{$<-}{\code{signature(x = "NMF")}: shortcut for
+ \code{x at misc[[name]] <- value} }
+
+ \item{.basis}{\code{signature(object = "NMF")}: Pure
+ virtual method for objects of class
+ \code{\linkS4class{NMF}}, that should be overloaded by
+ sub-classes, and throws an error if called. }
+
+ \item{.basis<-}{\code{signature(object = "NMF", value =
+ "matrix")}: Pure virtual method for objects of class
+ \code{\linkS4class{NMF}}, that should be overloaded by
+ sub-classes, and throws an error if called. }
+
+ \item{basis<-}{\code{signature(object = "NMF")}: Default
+ methods that calls \code{.basis<-} and check the validity
+ of the updated object. }
+
+ \item{basiscor}{\code{signature(x = "NMF", y =
+ "matrix")}: Computes the correlations between the basis
+ vectors of \code{x} and the columns of \code{y}. }
+
+ \item{basiscor}{\code{signature(x = "NMF", y = "NMF")}:
+ Computes the correlations between the basis vectors of
+ \code{x} and \code{y}. }
+
+ \item{basiscor}{\code{signature(x = "NMF", y =
+ "missing")}: Computes the correlations between the basis
+ vectors of \code{x}. }
+
+ \item{basismap}{\code{signature(object = "NMF")}: Plots a
+ heatmap of the basis matrix of the NMF model
+ \code{object}. This method also works for fitted NMF
+ models (i.e. \code{NMFfit} objects). }
+
+ \item{c}{\code{signature(x = "NMF")}: Binds compatible
+ matrices and NMF models together. }
+
+ \item{.coef}{\code{signature(object = "NMF")}: Pure
+ virtual method for objects of class
+ \code{\linkS4class{NMF}}, that should be overloaded by
+ sub-classes, and throws an error if called. }
+
+ \item{.coef<-}{\code{signature(object = "NMF", value =
+ "matrix")}: Pure virtual method for objects of class
+ \code{\linkS4class{NMF}}, that should be overloaded by
+ sub-classes, and throws an error if called. }
+
+ \item{coef<-}{\code{signature(object = "NMF")}: Default
+ methods that calls \code{.coef<-} and check the validity
+ of the updated object. }
+
+ \item{coefficients}{\code{signature(object = "NMF")}:
+ Alias to \code{coef,NMF}, therefore also pure virtual. }
+
+ \item{coefmap}{\code{signature(object = "NMF")}: The
+ default method for NMF objects has special default values
+ for some arguments of \code{\link{aheatmap}} (see
+ argument description). }
+
+ \item{connectivity}{\code{signature(object = "NMF")}:
+ Computes the connectivity matrix for an NMF model, for
+ which cluster membership is given by the most
+ contributing basis component in each sample. See
+ \code{\link{predict,NMF-method}}. }
+
+ \item{consensus}{\code{signature(object = "NMF")}: This
+ method is provided for completeness and is identical to
+ \code{\link{connectivity}}, and returns the connectivity
+ matrix, which, in the case of a single NMF model, is also
+ the consensus matrix. }
+
+ \item{consensushc}{\code{signature(object = "NMF")}:
+ Compute the hierarchical clustering on the connectivity
+ matrix of \code{object}. }
+
+ \item{consensusmap}{\code{signature(object = "NMF")}:
+ Plots a heatmap of the connectivity matrix of an NMF
+ model. }
+
+ \item{deviance}{\code{signature(object = "NMF")}:
+ Computes the distance between a matrix and the estimate
+ of an \code{NMF} model. }
+
+ \item{dim}{\code{signature(x = "NMF")}: method for NMF
+ objects for the base generic \code{\link{dim}}. It
+ returns all dimensions in a length-3 integer vector: the
+ number of row and columns of the estimated target matrix,
+ as well as the factorization rank (i.e. the number of
+ basis components). }
+
+ \item{dimnames}{\code{signature(x = "NMF")}: Returns the
+ dimension names of the NMF model \code{x}.
+
+ It returns either NULL if no dimnames are set on the
+ object, or a 3-length list containing the row names of
+ the basis matrix, the column names of the mixture
+ coefficient matrix, and the column names of the basis
+ matrix (i.e. the names of the basis components). }
+
+ \item{dimnames<-}{\code{signature(x = "NMF")}: sets the
+ dimension names of the NMF model \code{x}.
+
+ \code{value} can be \code{NULL} which resets all
+ dimension names, or a 1, 2 or 3-length list providing
+ names at least for the rows of the basis matrix.
+
+ See \code{\link{dimnames<-,NMF-method}} for more details.
+ }
+
+ \item{.DollarNames}{\code{signature(x = "NMF")}:
+ Auto-completion for \code{\linkS4class{NMF}} objects }
+
+ \item{.DollarNames}{\code{signature(x = "NMF")}:
+ Auto-completion for \code{\linkS4class{NMF}} objects }
+
+ \item{extractFeatures}{\code{signature(object = "NMF")}:
+ Select basis-specific features from an NMF model, by
+ applying the method \code{extractFeatures,matrix} to its
+ basis matrix. }
+
+ \item{featureScore}{\code{signature(object = "NMF")}:
+ Computes feature scores on the basis matrix of an NMF
+ model. }
+
+ \item{fitted}{\code{signature(object = "NMF")}: Pure
+ virtual method for objects of class
+ \code{\linkS4class{NMF}}, that should be overloaded by
+ sub-classes, and throws an error if called. }
+
+ \item{ibterms}{\code{signature(object = "NMF")}: Default
+ pure virtual method that ensure a method is defined for
+ concrete NMF model classes. }
+
+ \item{icterms}{\code{signature(object = "NMF")}: Default
+ pure virtual method that ensure a method is defined for
+ concrete NMF model classes. }
+
+ \item{loadings}{\code{signature(x = "NMF")}: Method
+ loadings for NMF Models
+
+ The method \code{loadings} is identical to \code{basis},
+ but do not accept any extra argument.
+
+ See \code{\link{loadings,NMF-method}} for more details. }
+
+ \item{metaHeatmap}{\code{signature(object = "NMF")}:
+ Deprecated method that is substituted by
+ \code{\link{coefmap}} and \code{\link{basismap}}. }
+
+ \item{nmf.equal}{\code{signature(x = "NMF", y = "NMF")}:
+ Compares two NMF models.
+
+ Arguments in \code{...} are used only when
+ \code{identical=FALSE} and are passed to
+ \code{all.equal}. }
+
+ \item{nmf.equal}{\code{signature(x = "NMF", y =
+ "NMFfit")}: Compares two NMF models when at least one
+ comes from a NMFfit object, i.e. an object returned by a
+ single run of \code{\link{nmf}}. }
+
+ \item{nmf.equal}{\code{signature(x = "NMF", y =
+ "NMFfitX")}: Compares two NMF models when at least one
+ comes from multiple NMF runs. }
+
+ \item{nneg}{\code{signature(object = "NMF")}: Apply
+ \code{nneg} to the basis matrix of an \code{\link{NMF}}
+ object (i.e. \code{basis(object)}). All extra arguments
+ in \code{...} are passed to the method
+ \code{nneg,matrix}. }
+
+ \item{predict}{\code{signature(object = "NMF")}: Default
+ method for NMF models }
+
+ \item{profcor}{\code{signature(x = "NMF", y = "matrix")}:
+ Computes the correlations between the basis profiles of
+ \code{x} and the rows of \code{y}. }
+
+ \item{profcor}{\code{signature(x = "NMF", y = "NMF")}:
+ Computes the correlations between the basis profiles of
+ \code{x} and \code{y}. }
+
+ \item{profcor}{\code{signature(x = "NMF", y =
+ "missing")}: Computes the correlations between the basis
+ profiles of \code{x}. }
+
+ \item{rmatrix}{\code{signature(x = "NMF")}: Returns the
+ target matrix estimate of the NMF model \code{x},
+ perturbated by adding a random matrix generated using the
+ default method of \code{rmatrix}: it is a equivalent to
+ \code{fitted(x) + rmatrix(fitted(x), ...)}.
+
+ This method can be used to generate random target
+ matrices that depart from a known NMF model to a
+ controlled extend. This is useful to test the robustness
+ of NMF algorithms to the presence of certain types of
+ noise in the data. }
+
+ \item{rnmf}{\code{signature(x = "NMF", target =
+ "numeric")}: Generates a random NMF model of the same
+ class and rank as another NMF model.
+
+ This is the workhorse method that is eventually called by
+ all other methods. It generates an NMF model of the same
+ class and rank as \code{x}, compatible with the
+ dimensions specified in \code{target}, that can be a
+ single or 2-length numeric vector, to specify a square or
+ rectangular target matrix respectively.
+
+ See \code{\link{rnmf,NMF,numeric-method}} for more
+ details. }
+
+ \item{rnmf}{\code{signature(x = "NMF", target =
+ "missing")}: Generates a random NMF model of the same
+ dimension as another NMF model.
+
+ It is a shortcut for \code{rnmf(x, nrow(x), ncol(x),
+ ...)}, which returns a random NMF model of the same class
+ and dimensions as \code{x}. }
+
+ \item{rposneg}{\code{signature(object = "NMF")}: Apply
+ \code{rposneg} to the basis matrix of an
+ \code{\link{NMF}} object. }
+
+ \item{show}{\code{signature(object = "NMF")}: Show method
+ for objects of class \code{NMF} }
+
+ \item{sparseness}{\code{signature(x = "NMF")}: Compute
+ the sparseness of an object of class \code{NMF}, as the
+ sparseness of the basis and coefficient matrices computed
+ separately.
+
+ It returns the two values in a numeric vector with names
+ \sQuote{basis} and \sQuote{coef}. }
+
+ \item{summary}{\code{signature(object = "NMF")}: Computes
+ summary measures for a single NMF model.
+
+ The following measures are computed:
+
+ See \code{\link{summary,NMF-method}} for more details. }
+
+ }
+}
+\section{Implementing NMF models}{
+ The class \code{NMF} only defines a basic data/low-level
+ interface for NMF models, as a collection of generic
+ methods, responsible with data handling, upon which
+ relies a comprehensive set of functions, composing a rich
+ higher-level interface.
+
+ Actual NMF models are defined as sub-classes that
+ inherits from class \code{NMF}, and implement the
+ management of data storage, providing definitions for the
+ interface's pure virtual methods.
+
+ The minimum requirement to define a new NMF model that
+ integrates into the framework of the \emph{NMF} package
+ are the followings:
+
+ \itemize{
+
+ \item Define a class that inherits from class \code{NMF}
+ and implements the new model, say class \code{myNMF}.
+
+ \item Implement the following S4 methods for the new
+ class \code{myNMF}: \describe{
+ \item{fitted}{\code{signature(object = "myNMF", value =
+ "matrix")}: Must return the estimated target matrix as
+ fitted by the NMF model \code{object}. }
+ \item{basis}{\code{signature(object = "myNMF")}: Must
+ return the basis matrix(e.g. the first matrix factor in
+ the standard NMF model). }
+ \item{basis<-}{\code{signature(object = "myNMF", value =
+ "matrix")}: Must return \code{object} with the basis
+ matrix set to \code{value}. }
+ \item{coef}{\code{signature(object = "myNMF")}: Must
+ return the matrix of mixture coefficients (e.g. the
+ second matrix factor in the standard NMF model). }
+ \item{coef<-}{\code{signature(object = "myNMF", value =
+ "matrix")}: Must return \code{object} with the matrix of
+ mixture coefficients set to \code{value}. } }
+
+ The \emph{NMF} package provides "pure virtual"
+ definitions of these methods for class \code{NMF} (i.e.
+ with signatures \code{(object='NMF', ...)} and
+ \code{(object='NMF', value='matrix')}) that throw an
+ error if called, so as to force their definition for
+ model classes.
+
+ \item Optionally, implement method
+ \code{rnmf}(signature(x="myNMF", target="ANY")). This
+ method should call \code{callNextMethod(x=x,
+ target=target, ...)} and fill the returned NMF model with
+ its specific data suitable random values. }
+
+ For concrete examples of NMF models implementations, see
+ class \code{\linkS4class{NMFstd}} and its extensions
+ (e.g. classes \code{\linkS4class{NMFOffset}} or
+ \code{\linkS4class{NMFns}}).
+}
+
+\section{Creating NMF objects}{
+ Strictly speaking, because class \code{NMF} is virtual,
+ no object of class \code{NMF} can be instantiated, only
+ objects from its sub-classes. However, those objects are
+ sometimes shortly referred in the documentation and
+ vignettes as "\code{NMF} objects" instead of "objects
+ that inherits from class \code{NMF}".
+
+ For built-in models or for models that inherit from the
+ standard model class \code{\linkS4class{NMFstd}}, the
+ factory method \code{nmfModel} enables to easily create
+ valid \code{NMF} objects in a variety of common
+ situations. See documentation for the the factory method
+ \code{\link{nmfModel}} for more details.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# show all the NMF models available (i.e. the classes that inherit from class NMF)
+nmfModels()
+# show all the built-in NMF models available
+nmfModels(builtin.only=TRUE)
+
+# class NMF is a virtual class so cannot be instantiated:
+try( new('NMF') )
+
+# To instantiate an NMF model, use the factory method nmfModel. see ?nmfModel
+nmfModel()
+nmfModel(3)
+nmfModel(3, model='NMFns')
+}
+\references{
+ Definition of Nonnegative Matrix Factorization in its
+ modern formulation: \cite{Lee et al. (1999)}
+
+ Historical first definition and algorithms: \cite{Paatero
+ et al. (1994)}
+
+ Lee DD and Seung HS (1999). "Learning the parts of
+ objects by non-negative matrix factorization." _Nature_,
+ *401*(6755), pp. 788-91. ISSN 0028-0836, <URL:
+ http://dx.doi.org/10.1038/44565>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/10548103>.
+
+ Paatero P and Tapper U (1994). "Positive matrix
+ factorization: A non-negative factor model with optimal
+ utilization of error estimates of data values."
+ _Environmetrics_, *5*(2), pp. 111-126. <URL:
+ http://dx.doi.org/10.1002/env.3170050203>, <URL:
+ http://www3.interscience.wiley.com/cgi-bin/abstract/113468839/ABSTRACT>.
+}
+\seealso{
+ Main interface to perform NMF in
+ \code{\link{nmf-methods}}.
+
+ Built-in NMF models and factory method in
+ \code{\link{nmfModel}}.
+
+ Method \code{\link{seed}} to set NMF objects with values
+ suitable to start algorithms with.
+
+ Other NMF-interface: \code{\link{basis}},
+ \code{\link{.basis}}, \code{\link{.basis<-}},
+ \code{\link{basis<-}}, \code{\link{coef}},
+ \code{\link{.coef}}, \code{\link{.coef<-}},
+ \code{\link{coef<-}}, \code{\link{coefficients}},
+ \code{\link{loadings,NMF-method}},
+ \code{\link{nmfModel}}, \code{\link{nmfModels}},
+ \code{\link{rnmf}}, \code{\link{scoef}}
+}
+\keyword{methods}
+
diff --git a/man/NMF-defunct.Rd b/man/NMF-defunct.Rd
new file mode 100644
index 0000000..242b6cb
--- /dev/null
+++ b/man/NMF-defunct.Rd
@@ -0,0 +1,38 @@
+\docType{methods}
+\name{NMF-defunct}
+\alias{metaHeatmap}
+\alias{metaHeatmap,matrix-method}
+\alias{metaHeatmap-methods}
+\alias{metaHeatmap,NMFfitX-method}
+\alias{metaHeatmap,NMF-method}
+\alias{NMF-defunct}
+\title{Defunct Functions and Classes in the NMF Package}
+\usage{
+ metaHeatmap(object, ...)
+}
+\arguments{
+ \item{object}{an R object}
+
+ \item{...}{other arguments}
+}
+\description{
+ Defunct Functions and Classes in the NMF Package
+}
+\section{Methods}{
+ \describe{
+
+ \item{metaHeatmap}{\code{signature(object = "matrix")}:
+ Defunct method substituted by \code{\link{aheatmap}}. }
+
+ \item{metaHeatmap}{\code{signature(object = "NMF")}:
+ Deprecated method that is substituted by
+ \code{\link{coefmap}} and \code{\link{basismap}}. }
+
+ \item{metaHeatmap}{\code{signature(object = "NMFfitX")}:
+ Deprecated method subsituted by
+ \code{\link{consensusmap}}. }
+
+ }
+}
+\keyword{methods}
+
diff --git a/man/NMF-deprecated.Rd b/man/NMF-deprecated.Rd
new file mode 100644
index 0000000..6855b4a
--- /dev/null
+++ b/man/NMF-deprecated.Rd
@@ -0,0 +1,12 @@
+\name{NMF-deprecated}
+\alias{NMF-deprecated}
+\title{Deprecated Functions in the Package NMF}
+\arguments{
+ \item{object}{an R object}
+
+ \item{...}{extra arguments}
+}
+\description{
+ Deprecated Functions in the Package NMF
+}
+
diff --git a/man/NMF-package.Rd b/man/NMF-package.Rd
new file mode 100644
index 0000000..34c47f6
--- /dev/null
+++ b/man/NMF-package.Rd
@@ -0,0 +1,46 @@
+\docType{package}
+\name{NMF-package}
+\alias{NMF}
+\alias{NMF-package}
+\title{Algorithms and framework for Nonnegative Matrix Factorization (NMF).}
+\description{
+ This package provides a framework to perform Non-negative
+ Matrix Factorization (NMF). It implements a set of
+ already published algorithms and seeding methods, and
+ provides a framework to test, develop and plug new/custom
+ algorithms. Most of the built-in algorithms have been
+ optimized in C++, and the main interface function
+ provides an easy way of performing parallel computations
+ on multicore machines.
+}
+\details{
+ \code{\link{nmf}} Run a given NMF algorithm
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# generate a synthetic dataset with known classes
+n <- 50; counts <- c(5, 5, 8);
+V <- syntheticNMF(n, counts)
+
+# perform a 3-rank NMF using the default algorithm
+res <- nmf(V, 3)
+
+basismap(res)
+coefmap(res)
+}
+\author{
+ Renaud Gaujoux \email{renaud at cbio.uct.ac.za}
+}
+\references{
+ \url{http://cran.r-project.org/}
+
+ \url{http://nmf.r-forge.project.org}
+}
+\seealso{
+ \code{\link{nmf}}
+}
+\keyword{package}
+
diff --git a/man/NMFList-class.Rd b/man/NMFList-class.Rd
new file mode 100644
index 0000000..248d204
--- /dev/null
+++ b/man/NMFList-class.Rd
@@ -0,0 +1,42 @@
+\docType{class}
+\name{NMFList-class}
+\alias{NMFList-class}
+\title{Class for Storing Heterogeneous NMF fits}
+\description{
+ This class wraps a list of NMF fit objects, which may
+ come from different runs of the function
+ \code{\link{nmf}}, using different parameters, methods,
+ etc.. These can be either from a single run (NMFfit) or
+ multiple runs (NMFfitX).
+
+ Note that its definition/interface is very likely to
+ change in the future.
+}
+\section{Methods}{
+ \describe{
+
+ \item{algorithm}{\code{signature(object = "NMFList")}:
+ Returns the method names used to compute the NMF fits in
+ the list. It returns \code{NULL} if the list is empty. }
+
+ \item{runtime}{\code{signature(object = "NMFList")}:
+ Returns the CPU time required to compute all NMF fits in
+ the list. It returns \code{NULL} if the list is empty. If
+ no timing data are available, the sequential time is
+ returned. }
+
+ \item{seqtime}{\code{signature(object = "NMFList")}:
+ Returns the CPU time that would be required to
+ sequentially compute all NMF fits stored in
+ \code{object}.
+
+ This method calls the function \code{runtime} on each fit
+ and sum up the results. It returns \code{NULL} on an
+ empty object. }
+
+ \item{show}{\code{signature(object = "NMFList")}: Show
+ method for objects of class \code{NMFList} }
+
+ }
+}
+
diff --git a/man/NMFOffset-class.Rd b/man/NMFOffset-class.Rd
new file mode 100644
index 0000000..5cd8623
--- /dev/null
+++ b/man/NMFOffset-class.Rd
@@ -0,0 +1,125 @@
+\docType{class}
+\name{NMFOffset-class}
+\alias{initialize,NMFOffset-method}
+\alias{NMFOffset-class}
+\title{NMF Model - Nonnegative Matrix Factorization with Offset}
+\usage{
+ \S4method{initialize}{NMFOffset}(.Object, ..., offset)
+}
+\arguments{
+ \item{offset}{optional numeric vector used to initialise
+ slot \sQuote{offset}.}
+
+ \item{.Object}{ An object: see the Details section.}
+
+ \item{...}{data to include in the new object. Named
+ arguments correspond to slots in the class definition.
+ Unnamed arguments must be objects from classes that this
+ class extends.}
+}
+\description{
+ This class implements the \emph{Nonnegative Matrix
+ Factorization with Offset} model, required by the NMF
+ with Offset algorithm.
+}
+\details{
+ The NMF with Offset algorithm is defined by \cite{Badea
+ (2008)} as a modification of the euclidean based NMF
+ algorithm from \code{Lee2001} (see section Details and
+ references below). It aims at obtaining 'cleaner' factor
+ matrices, by the introduction of an offset matrix,
+ explicitly modelling a feature specific baseline --
+ constant across samples.
+}
+\section{Methods}{
+ \describe{
+
+ \item{fitted}{\code{signature(object = "NMFOffset")}:
+ Computes the target matrix estimate for an NMFOffset
+ object.
+
+ The estimate is computed as: \deqn{ W H + offset } }
+
+ \item{offset}{\code{signature(object = "NMFOffset")}: The
+ function \code{offset} returns the offset vector from an
+ NMF model that has an offset, e.g. an \code{NMFOffset}
+ model. }
+
+ \item{rnmf}{\code{signature(x = "NMFOffset", target =
+ "numeric")}: Generates a random NMF model with offset,
+ from class \code{NMFOffset}.
+
+ The offset values are drawn from a uniform distribution
+ between 0 and the maximum entry of the basis and
+ coefficient matrices, which are drawn by the next
+ suitable \code{\link{rnmf}} method, which is the
+ workhorse method \code{rnmf,NMF,numeric}. }
+
+ \item{show}{\code{signature(object = "NMFOffset")}: Show
+ method for objects of class \code{NMFOffset} }
+
+ }
+}
+\section{Creating objects from the Class}{
+ Object of class \code{NMFOffset} can be created using the
+ standard way with operator \code{\link{new}}
+
+ However, as for all NMF model classes -- that extend
+ class \code{\linkS4class{NMF}}, objects of class
+ \code{NMFOffset} should be created using factory method
+ \code{\link{nmfModel}} :
+
+ \code{new('NMFOffset')}
+
+ \code{nmfModel(model='NMFOffset')}
+
+ \code{nmfModel(model='NMFOffset', W=w, offset=rep(1,
+ nrow(w)))}
+
+ See \code{\link{nmfModel}} for more details on how to use
+ the factory method.
+}
+
+\section{Initialize method}{
+ The initialize method for \code{NMFOffset} objects tries
+ to correct the initial value passed for slot
+ \code{offset}, so that it is consistent with the
+ dimensions of the \code{NMF} model: it will pad the
+ offset vector with NA values to get the length equal to
+ the number of rows in the basis matrix.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# create a completely empty NMF object
+new('NMFOffset')
+
+# create a NMF object based on random (compatible) matrices
+n <- 50; r <- 3; p <- 20
+w <- rmatrix(n, r)
+h <- rmatrix(r, p)
+nmfModel(model='NMFOffset', W=w, H=h, offset=rep(0.5, nrow(w)))
+
+# apply Nonsmooth NMF algorithm to a random target matrix
+V <- rmatrix(n, p)
+\dontrun{nmf(V, r, 'offset')}
+
+# random NMF model with offset
+rnmf(3, 10, 5, model='NMFOffset')
+}
+\references{
+ Badea L (2008). "Extracting gene expression profiles
+ common to colon and pancreatic adenocarcinoma using
+ simultaneous nonnegative matrix factorization." _Pacific
+ Symposium on Biocomputing. Pacific Symposium on
+ Biocomputing_, *290*, pp. 267-78. ISSN 1793-5091, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/18229692>.
+}
+\seealso{
+ Other NMF-model: \code{\link{NMFns-class}},
+ \code{\link{NMFstd-class}}
+}
+\keyword{methods}
+
diff --git a/man/NMFSeed-class.Rd b/man/NMFSeed-class.Rd
new file mode 100644
index 0000000..df4574b
--- /dev/null
+++ b/man/NMFSeed-class.Rd
@@ -0,0 +1,46 @@
+\docType{class}
+\name{NMFSeed-class}
+\alias{NMFSeed-class}
+\title{Base class that defines the interface for NMF seeding methods.}
+\description{
+ This class implements a simple wrapper strategy object
+ that defines a unified interface to seeding methods, that
+ are used to initialise NMF models before fitting them
+ with any NMF algorithm.
+}
+\section{Slots}{
+ \describe{
+
+ \item{name}{character string giving the name of the
+ seeding strategy}
+
+ \item{method}{workhorse function that implements the
+ seeding strategy. It must have signature
+ \code{(object="NMF", x="matrix", ...)} and initialise the
+ NMF model \code{object} with suitable values for fitting
+ the target matrix \code{x}.}
+
+ }
+}
+\section{Methods}{
+ \describe{
+
+ \item{algorithm}{\code{signature(object = "NMFSeed")}:
+ Returns the workhorse function of the seeding method
+ described by \code{object}. }
+
+ \item{algorithm<-}{\code{signature(object = "NMFSeed",
+ value = "function")}: Sets the workhorse function of the
+ seeding method described by \code{object}. }
+
+ \item{NMFSeed}{\code{signature(key = "NMFSeed")}: Creates
+ an \code{NMFSeed} based on a template object
+ (Constructor-Copy), in particular it uses the
+ \strong{same} name. }
+
+ \item{show}{\code{signature(object = "NMFSeed")}: Show
+ method for objects of class \code{NMFSeed} }
+
+ }
+}
+
diff --git a/man/NMFStrategy-class.Rd b/man/NMFStrategy-class.Rd
new file mode 100644
index 0000000..4a4127e
--- /dev/null
+++ b/man/NMFStrategy-class.Rd
@@ -0,0 +1,135 @@
+\docType{class}
+\name{NMFStrategy-class}
+\alias{is.mixed}
+\alias{NMFStrategy-class}
+\alias{objective<-,NMFStrategy,character-method}
+\alias{objective<-,NMFStrategy,function-method}
+\alias{objective,NMFStrategy-method}
+\alias{show,NMFStrategy-method}
+\title{Virtual Interface for NMF Algorithms}
+\usage{
+ \S4method{show}{NMFStrategy}(object)
+
+ \S4method{objective}{NMFStrategy}(object)
+
+ \S4method{objective}{NMFStrategy,character}(object)<-value
+
+ \S4method{objective}{NMFStrategy,function}(object)<-value
+
+ is.mixed(object)
+}
+\arguments{
+ \item{object}{Any R object}
+
+ \item{value}{replacement value}
+}
+\description{
+ This class partially implements the generic interface
+ defined for general algorithms defined in the \pkg{NMF}
+ package (see \code{\link{algorithmic-NMF}}).
+
+ \code{is.mixed} tells if an NMF algorithm works on
+ mixed-sign data.
+}
+\section{Slots}{
+ \describe{
+
+ \item{objective}{the objective function associated with
+ the algorithm (Frobenius, Kullback-Leibler, etc...). It
+ is either an access key of a registered objective
+ function or a function definition. In the latter case,
+ the given function must have the following signature
+ \code{(x="NMF", y="matrix")} and return a nonnegative
+ real value.}
+
+ \item{model}{a character string giving either the
+ (sub)class name of the NMF-class instance used and
+ returned by the strategy, or a function name.}
+
+ \item{mixed}{a logical that indicates if the algorithm
+ works on mixed-sign data.}
+
+ }
+}
+\section{Methods}{
+ \describe{
+
+ \item{canFit}{\code{signature(x = "NMFStrategy", y =
+ "character")}: Tells if an NMF algorithm can fit a given
+ class of NMF models }
+
+ \item{canFit}{\code{signature(x = "NMFStrategy", y =
+ "NMF")}: Tells if an NMF algorithm can fit the same class
+ of models as \code{y} }
+
+ \item{deviance}{\code{signature(object = "NMFStrategy")}:
+ Computes the value of the objective function between the
+ estimate \code{x} and the target \code{y}. }
+
+ \item{modelname}{\code{signature(object =
+ "NMFStrategy")}: Returns the model(s) that an NMF
+ algorithm can fit. }
+
+ \item{NMFStrategy}{\code{signature(name = "NMFStrategy",
+ method = "missing")}: Creates an \code{NMFStrategy} based
+ on a template object (Constructor-Copy), in particular it
+ uses the \strong{same} name. }
+
+ \item{objective}{\code{signature(object =
+ "NMFStrategy")}: Gets the objective function associated
+ with an NMF algorithm.
+
+ It is used in
+ \code{\link[=deviance,NMFStrategy-method]{deviance}} to
+ compute the objective value for an NMF model with respect
+ to a given target matrix. }
+
+ \item{objective}{\code{signature(object =
+ "NMFStrategy")}: Gets the objective function associated
+ with an NMF algorithm.
+
+ It is used in
+ \code{\link[=deviance,NMFStrategy-method]{deviance}} to
+ compute the objective value for an NMF model with respect
+ to a given target matrix. }
+
+ \item{objective<-}{\code{signature(object =
+ "NMFStrategy", value = "character")}: Sets the objective
+ function associated with an NMF algorithm, with a
+ character string that must be a registered objective
+ function. }
+
+ \item{objective<-}{\code{signature(object =
+ "NMFStrategy", value = "character")}: Sets the objective
+ function associated with an NMF algorithm, with a
+ character string that must be a registered objective
+ function. }
+
+ \item{objective<-}{\code{signature(object =
+ "NMFStrategy", value = "function")}: Sets the objective
+ function associated with an NMF algorithm, with a
+ function that computes the approximation error between an
+ NMF model and a target matrix. }
+
+ \item{objective<-}{\code{signature(object =
+ "NMFStrategy", value = "function")}: Sets the objective
+ function associated with an NMF algorithm, with a
+ function that computes the approximation error between an
+ NMF model and a target matrix. }
+
+ \item{run}{\code{signature(object = "NMFStrategy", y =
+ "matrix", x = "NMFfit")}: Pure virtual method defined for
+ all NMF algorithms to ensure that a method \code{run} is
+ defined by sub-classes of \code{NMFStrategy}.
+
+ It throws an error if called directly. }
+
+ \item{run}{\code{signature(object = "NMFStrategy", y =
+ "matrix", x = "NMF")}: Method to run an NMF algorithm
+ directly starting from a given NMF model. }
+
+ }
+}
+\keyword{internal}
+\keyword{methods}
+
diff --git a/man/NMFStrategy.Rd b/man/NMFStrategy.Rd
new file mode 100644
index 0000000..bccefc2
--- /dev/null
+++ b/man/NMFStrategy.Rd
@@ -0,0 +1,181 @@
+\docType{methods}
+\name{NMFStrategy}
+\alias{NMFStrategy}
+\alias{NMFStrategy,character,character-method}
+\alias{NMFStrategy,character,function-method}
+\alias{NMFStrategy,character,missing-method}
+\alias{NMFStrategy,character,NMFStrategy-method}
+\alias{NMFStrategy-methods}
+\alias{NMFStrategy,missing,character-method}
+\alias{NMFStrategy,NMFStrategy,missing-method}
+\alias{NMFStrategy,NULL,character-method}
+\alias{NMFStrategy,NULL,NMFStrategy-method}
+\alias{run,NMFStrategyFunction,matrix,NMFfit-method}
+\alias{run,NMFStrategyIterative,matrix,NMFfit-method}
+\alias{run,NMFStrategyIterativeX,matrix,NMFfit-method}
+\alias{run,NMFStrategy,matrix,NMFfit-method}
+\alias{run,NMFStrategy,matrix,NMF-method}
+\alias{run,NMFStrategyOctave,matrix,NMFfit-method}
+\title{Factory Method for NMFStrategy Objects}
+\usage{
+ NMFStrategy(name, method, ...)
+
+ \S4method{run}{NMFStrategy,matrix,NMFfit}(object, y, x,
+ ...)
+
+ \S4method{run}{NMFStrategy,matrix,NMF}(object, y, x, ...)
+
+ \S4method{run}{NMFStrategyFunction,matrix,NMFfit}(object,
+ y, x, ...)
+
+ \S4method{run}{NMFStrategyIterative,matrix,NMFfit}(object,
+ y, x, .stop = NULL,
+ maxIter = nmf.getOption("maxIter") \%||\% 2000, ...)
+
+ \S4method{run}{NMFStrategyIterativeX,matrix,NMFfit}(object,
+ y, x, maxIter, ...)
+
+ \S4method{run}{NMFStrategyOctave,matrix,NMFfit}(object,
+ y, x, ...)
+}
+\arguments{
+ \item{name}{name/key of an NMF algorithm.}
+
+ \item{method}{definition of the algorithm}
+
+ \item{...}{extra arguments passed to \code{\link{new}}.}
+
+ \item{.stop}{specification of a stopping criterion, that
+ is used instead of the one associated to the NMF
+ algorithm. It may be specified as: \itemize{ \item the
+ access key of a registered stopping criterion; \item a
+ single integer that specifies the exact number of
+ iterations to perform, which will be honoured unless a
+ lower value is explicitly passed in argument
+ \code{maxIter}. \item a single numeric value that
+ specifies the stationnarity threshold for the objective
+ function, used in with \code{\link{nmf.stop.stationary}};
+ \item a function with signature
+ \code{(object="NMFStrategy", i="integer", y="matrix",
+ x="NMF", ...)}, where \code{object} is the
+ \code{NMFStrategy} object that describes the algorithm
+ being run, \code{i} is the current iteration, \code{y} is
+ the target matrix and \code{x} is the current value of
+ the NMF model. }}
+
+ \item{maxIter}{maximum number of iterations to perform.}
+
+ \item{object}{an object computed using some algorithm, or
+ that describes an algorithm itself.}
+
+ \item{y}{data object, e.g. a target matrix}
+
+ \item{x}{a model object used as a starting point by the
+ algorithm, e.g. a non-empty NMF model.}
+}
+\description{
+ Creates NMFStrategy objects that wraps implementation of
+ NMF algorithms into a unified interface.
+}
+\section{Methods}{
+ \describe{
+
+ \item{NMFStrategy}{\code{signature(name = "character",
+ method = "function")}: Creates an
+ \code{NMFStrategyFunction} object that wraps the function
+ \code{method} into a unified interface.
+
+ \code{method} must be a function with signature
+ \code{(y="matrix", x="NMFfit", ...)}, and return an
+ object of class \code{\linkS4class{NMFfit}}. }
+
+ \item{NMFStrategy}{\code{signature(name = "character",
+ method = "NMFStrategy")}: Creates an \code{NMFStrategy}
+ object based on a template object (Constructor-Copy). }
+
+ \item{NMFStrategy}{\code{signature(name = "NMFStrategy",
+ method = "missing")}: Creates an \code{NMFStrategy} based
+ on a template object (Constructor-Copy), in particular it
+ uses the \strong{same} name. }
+
+ \item{NMFStrategy}{\code{signature(name = "missing",
+ method = "character")}: Creates an \code{NMFStrategy}
+ based on a registered NMF algorithm that is used as a
+ template (Constructor-Copy), in particular it uses the
+ \strong{same} name.
+
+ It is a shortcut for
+ \code{NMFStrategy(nmfAlgorithm(method, exact=TRUE),
+ ...)}. }
+
+ \item{NMFStrategy}{\code{signature(name = "NULL", method
+ = "NMFStrategy")}: Creates an \code{NMFStrategy} based on
+ a template object (Constructor-Copy) but using a randomly
+ generated name. }
+
+ \item{NMFStrategy}{\code{signature(name = "character",
+ method = "character")}: Creates an \code{NMFStrategy}
+ based on a registered NMF algorithm that is used as a
+ template. }
+
+ \item{NMFStrategy}{\code{signature(name = "NULL", method
+ = "character")}: Creates an \code{NMFStrategy} based on a
+ registered NMF algorithm (Constructor-Copy) using a
+ randomly generated name.
+
+ It is a shortcut for \code{NMFStrategy(NULL,
+ nmfAlgorithm(method), ...)}. }
+
+ \item{NMFStrategy}{\code{signature(name = "character",
+ method = "missing")}: Creates an NMFStrategy, determining
+ its type from the extra arguments passed in \code{...}:
+ if there is an argument named \code{Update} then an
+ \code{NMFStrategyIterative} is created, or if there is an
+ argument named \code{algorithm} then an
+ \code{NMFStrategyFunction} is created. Calls other than
+ these generates an error. }
+
+ \item{run}{\code{signature(object = "NMFStrategy", y =
+ "matrix", x = "NMFfit")}: Pure virtual method defined for
+ all NMF algorithms to ensure that a method \code{run} is
+ defined by sub-classes of \code{NMFStrategy}.
+
+ It throws an error if called directly. }
+
+ \item{run}{\code{signature(object = "NMFStrategy", y =
+ "matrix", x = "NMF")}: Method to run an NMF algorithm
+ directly starting from a given NMF model. }
+
+ \item{run}{\code{signature(object =
+ "NMFStrategyFunction", y = "matrix", x = "NMFfit")}: Runs
+ the NMF algorithms implemented by the single R function
+ -- and stored in slot \code{'algorithm'} of
+ \code{object}, on the data object \code{y}, using
+ \code{x} as starting point. It is equivalent to calling
+ \code{object at algorithm(y, x, ...)}.
+
+ This method is usually not called directly, but only via
+ the function \code{\link{nmf}}, which takes care of many
+ other details such as seeding the computation, handling
+ RNG settings, or setting up parallelisation. }
+
+ \item{run}{\code{signature(object =
+ "NMFStrategyIterative", y = "matrix", x = "NMFfit")}:
+ Runs an NMF iterative algorithm on a target matrix
+ \code{y}. }
+
+ \item{run}{\code{signature(object = "NMFStrategyOctave",
+ y = "matrix", x = "NMFfit")}: Runs the NMF algorithms
+ implemented by the Octave/Matlab function associated with
+ the strategy -- and stored in slot \code{'algorithm'} of
+ \code{object}.
+
+ This method is usually not called directly, but only via
+ the function \code{\link{nmf}}, which takes care of many
+ other details such as seeding the computation, handling
+ RNG settings, or setting up parallel computations. }
+
+ }
+}
+\keyword{methods}
+
diff --git a/man/NMFStrategyFunction-class.Rd b/man/NMFStrategyFunction-class.Rd
new file mode 100644
index 0000000..3573038
--- /dev/null
+++ b/man/NMFStrategyFunction-class.Rd
@@ -0,0 +1,53 @@
+\docType{class}
+\name{NMFStrategyFunction-class}
+\alias{NMFStrategyFunction-class}
+\title{Interface for Single Function NMF Strategies}
+\description{
+ This class implements the virtual interface
+ \code{\link{NMFStrategy}} for NMF algorithms that are
+ implemented by a single workhorse R function.
+}
+\section{Slots}{
+ \describe{
+
+ \item{algorithm}{a function that implements an NMF
+ algorithm. It must have signature \code{(y='matrix',
+ x='NMFfit')}, where \code{y} is the target matrix to
+ approximate and \code{x} is the NMF model assumed to be
+ seeded with an appropriate initial value -- as it is done
+ internally by function \code{\link{nmf}}.
+
+ Note that argument names currently do not matter, but it
+ is recommended to name them as specified above.}
+
+ }
+}
+\section{Methods}{
+ \describe{
+
+ \item{algorithm}{\code{signature(object =
+ "NMFStrategyFunction")}: Returns the single R function
+ that implements the NMF algorithm -- as stored in slot
+ \code{algorithm}. }
+
+ \item{algorithm<-}{\code{signature(object =
+ "NMFStrategyFunction", value = "function")}: Sets the
+ function that implements the NMF algorithm, stored in
+ slot \code{algorithm}. }
+
+ \item{run}{\code{signature(object =
+ "NMFStrategyFunction", y = "matrix", x = "NMFfit")}: Runs
+ the NMF algorithms implemented by the single R function
+ -- and stored in slot \code{'algorithm'} of
+ \code{object}, on the data object \code{y}, using
+ \code{x} as starting point. It is equivalent to calling
+ \code{object at algorithm(y, x, ...)}.
+
+ This method is usually not called directly, but only via
+ the function \code{\link{nmf}}, which takes care of many
+ other details such as seeding the computation, handling
+ RNG settings, or setting up parallelisation. }
+
+ }
+}
+
diff --git a/man/NMFStrategyIterative-class.Rd b/man/NMFStrategyIterative-class.Rd
new file mode 100644
index 0000000..cc1680d
--- /dev/null
+++ b/man/NMFStrategyIterative-class.Rd
@@ -0,0 +1,71 @@
+\docType{class}
+\name{NMFStrategyIterative-class}
+\alias{NMFStrategyIterative-class}
+\title{Interface for Algorithms: Implementation for Iterative NMF Algorithms}
+\description{
+ This class provides a specific implementation for the
+ generic function \code{run} -- concretising the virtual
+ interface class \code{\linkS4class{NMFStrategy}}, for NMF
+ algorithms that conform to the following iterative schema
+ (starred numbers indicate mandatory steps):
+
+ \itemize{ \item 1. Initialisation \item 2*. Update the
+ model at each iteration \item 3. Stop if some criterion
+ is satisfied \item 4. Wrap up }
+
+ This schema could possibly apply to all NMF algorithms,
+ since these are essentially optimisation algorithms,
+ almost all of which use iterative methods to approximate
+ a solution of the optimisation problem. The main
+ advantage is that it allows to implement updates and
+ stopping criterion separately, and combine them in
+ different ways. In particular, many NMF algorithms are
+ based on multiplicative updates, following the approach
+ from \cite{Lee et al. (2001)}, which are specially
+ suitable to be cast into this simple schema.
+}
+\section{Slots}{
+ \describe{
+
+ \item{onInit}{optional function that performs some
+ initialisation or pre-processing on the model, before
+ starting the iteration loop.}
+
+ \item{Update}{mandatory function that implement the
+ update step, which computes new values for the model,
+ based on its previous value. It is called at each
+ iteration, until the stopping criterion is met or the
+ maximum number of iteration is achieved.}
+
+ \item{Stop}{optional function that implements the
+ stopping criterion. It is called \strong{before} each
+ Update step. If not provided, the iterations are stopped
+ after a fixed number of updates.}
+
+ \item{onReturn}{optional function that wraps up the
+ result into an NMF object. It is called just before
+ returning the}
+
+ }
+}
+\section{Methods}{
+ \describe{
+
+ \item{run}{\code{signature(object =
+ "NMFStrategyIterative", y = "matrix", x = "NMFfit")}:
+ Runs an NMF iterative algorithm on a target matrix
+ \code{y}. }
+
+ \item{show}{\code{signature(object =
+ "NMFStrategyIterative")}: Show method for objects of
+ class \code{NMFStrategyIterative} }
+
+ }
+}
+\references{
+ Lee DD and Seung H (2001). "Algorithms for non-negative
+ matrix factorization." _Advances in neural information
+ processing systems_. <URL:
+ http://scholar.google.com/scholar?q=intitle:Algorithms+for+non-negative+matrix+factorization\#0>.
+}
+
diff --git a/man/NMFStrategyOctave-class.Rd b/man/NMFStrategyOctave-class.Rd
new file mode 100644
index 0000000..229fa3e
--- /dev/null
+++ b/man/NMFStrategyOctave-class.Rd
@@ -0,0 +1,66 @@
+\docType{class}
+\name{NMFStrategyOctave-class}
+\alias{NMFStrategyOctave-class}
+\alias{show,NMFStrategyOctave-method}
+\title{S4 Interface for Octave-Matlab NMF Algorithms}
+\usage{
+ \S4method{show}{NMFStrategyOctave}(object)
+}
+\arguments{
+ \item{object}{Any R object}
+}
+\description{
+ This class implements the virtual interface
+ \code{\linkS4class{NMFStrategy}} for NMF algorithms that
+ are implemented in Octave/Matlab, and provided as a set
+ of .m files or as plain code.
+}
+\details{
+ The \code{run} method for this class runs the algorithms
+ via the \code{\link[RcppOctave]{RcppOctave}} package.
+}
+\section{Slots}{
+ \describe{
+
+ \item{algorithm}{character string that gives the name of
+ the main Octave/Matlab function that implements the
+ algorithm. The function must take at least two arguments:
+ the target matrix and the initial NMF model, converted
+ into an Octave list object, with elements corresponding
+ to slots of the corresponding S4 class.}
+
+ \item{mcode}{character vector that contains a set of path
+ to .m files. These files are (re-)sourced every time the
+ strategy is called, and must be present at runtime in the
+ current directory or in a directory from Octave path.}
+
+ }
+}
+\section{Methods}{
+ \describe{
+
+ \item{algorithm}{\code{signature(object =
+ "NMFStrategyOctave")}: Returns the name of the
+ Octave/Matlab function that implements the NMF algorithm
+ -- as stored in slot \code{algorithm}. }
+
+ \item{algorithm<-}{\code{signature(object =
+ "NMFStrategyOctave", value = "character")}: Sets the name
+ of the Octave/Matlab function that implements the NMF
+ algorithm. It is stored in slot \code{algorithm}. }
+
+ \item{run}{\code{signature(object = "NMFStrategyOctave",
+ y = "matrix", x = "NMFfit")}: Runs the NMF algorithms
+ implemented by the Octave/Matlab function associated with
+ the strategy -- and stored in slot \code{'algorithm'} of
+ \code{object}.
+
+ This method is usually not called directly, but only via
+ the function \code{\link{nmf}}, which takes care of many
+ other details such as seeding the computation, handling
+ RNG settings, or setting up parallel computations. }
+
+ }
+}
+\keyword{methods}
+
diff --git a/man/NMFfit-class.Rd b/man/NMFfit-class.Rd
new file mode 100644
index 0000000..725b5b4
--- /dev/null
+++ b/man/NMFfit-class.Rd
@@ -0,0 +1,327 @@
+\docType{class}
+\name{NMFfit-class}
+\alias{NMFfit}
+\alias{NMFfit-class}
+\title{Base Class for to store Nonnegative Matrix Factorisation results}
+\usage{
+ NMFfit(fit = nmfModel(), ..., rng = NULL)
+}
+\arguments{
+ \item{fit}{an NMF model}
+
+ \item{...}{extra argument used to initialise slots in the
+ instantiating \code{NMFfit} object.}
+
+ \item{rng}{RNG settings specification (typically a
+ suitable value for \code{\link{.Random.seed}}).}
+}
+\description{
+ Base class to handle the results of general
+ \strong{Nonnegative Matrix Factorisation} algorithms
+ (NMF).
+
+ The function \code{NMFfit} is a factory method for NMFfit
+ objects, that should not need to be called by the user.
+ It is used internally by the functions \code{\link{nmf}}
+ and \code{seed} to instantiate the starting point of NMF
+ algorithms.
+}
+\details{
+ It provides a general structure and generic functions to
+ manage the results of NMF algorithms. It contains a slot
+ with the fitted NMF model (see slot \code{fit}) as well
+ as data about the methods and parameters used to compute
+ the factorization.
+
+ The purpose of this class is to handle in a generic way
+ the results of NMF algorithms. Its slot \code{fit}
+ contains the fitted NMF model as an object of class
+ \code{\linkS4class{NMF}}.
+
+ Other slots contains data about how the factorization has
+ been computed, such as the algorithm and seeding method,
+ the computation time, the final residuals, etc\dots{}
+
+ Class \code{NMFfit} acts as a wrapper class for its slot
+ \code{fit}. It inherits from interface class
+ \code{\linkS4class{NMF}} defined for generic NMF models.
+ Therefore, all the methods defined by this interface can
+ be called directly on objects of class \code{NMFfit}. The
+ calls are simply dispatched on slot \code{fit}, i.e. the
+ results are the same as if calling the methods directly
+ on slot \code{fit}.
+}
+\section{Slots}{
+ \describe{
+
+ \item{fit}{An object that inherits from class
+ \code{\linkS4class{NMF}}, and contains the fitted NMF
+ model.
+
+ NB: class \code{NMF} is a virtual class. The default
+ class for this slot is \code{NMFstd}, that implements the
+ standard NMF model.}
+
+ \item{residuals}{A \code{numeric} vector that contains
+ the final residuals or the residuals track between the
+ target matrix and its NMF estimate(s). Default value is
+ \code{numeric()}.
+
+ See method \code{\link{residuals}} for details on
+ accessor methods and main interface \code{\link{nmf}} for
+ details on how to compute NMF with residuals tracking.}
+
+ \item{method}{a single \code{character} string that
+ contains the name of the algorithm used to fit the model.
+ Default value is \code{''}.}
+
+ \item{seed}{a single \code{character} string that
+ contains the name of the seeding method used to seed the
+ algorithm that fitted the NMF model. Default value is
+ \code{''}. See \code{\link{nmf}} for more details.}
+
+ \item{rng}{an object that contains the RNG settings used
+ for the fit. Currently the settings are stored as an
+ integer vector, the value of \code{\link{.Random.seed}}
+ at the time the object is created. It is initialized by
+ the \code{initialized} method. See \code{\link{getRNG}}
+ for more details.}
+
+ \item{distance}{either a single \code{"character"} string
+ that contains the name of the built-in objective
+ function, or a \code{function} that measures the
+ residuals between the target matrix and its NMF estimate.
+ See \code{\link{objective}} and
+ \code{\link{deviance,NMF-method}}.}
+
+ \item{parameters}{a \code{list} that contains the extra
+ parameters -- usually specific to the algorithm -- that
+ were used to fit the model.}
+
+ \item{runtime}{object of class \code{"proc_time"} that
+ contains various measures of the time spent to fit the
+ model. See \code{\link[base]{system.time}}}
+
+ \item{options}{a \code{list} that contains the options
+ used to compute the object.}
+
+ \item{extra}{a \code{list} that contains extra
+ miscellaneous data for internal usage only. For example
+ it can be used to store extra parameters or temporary
+ data, without the need to explicitly extend the
+ \code{NMFfit} class. Currently built-in algorithms only
+ use this slot to store the number of iterations performed
+ to fit the object.
+
+ Data that need to be easily accessible by the end-user
+ should rather be set using the methods \code{$<-} that
+ sets elements in the \code{list} slot \code{misc} -- that
+ is inherited from class \code{\linkS4class{NMF}}.}
+
+ \item{call}{stored call to the last \code{nmf} method
+ that generated the object.}
+
+ }
+}
+\section{Methods}{
+ \describe{
+
+ \item{algorithm}{\code{signature(object = "NMFfit")}:
+ Returns the name of the algorithm that fitted the NMF
+ model \code{object}. }
+
+ \item{.basis}{\code{signature(object = "NMFfit")}:
+ Returns the basis matrix from an NMF model fitted with
+ function \code{\link{nmf}}.
+
+ It is a shortcut for \code{.basis(fit(object), ...)},
+ dispatching the call to the \code{.basis} method of the
+ actual NMF model. }
+
+ \item{.basis<-}{\code{signature(object = "NMFfit", value
+ = "matrix")}: Sets the the basis matrix of an NMF model
+ fitted with function \code{\link{nmf}}.
+
+ It is a shortcut for \code{.basis(fit(object)) <- value},
+ dispatching the call to the \code{.basis<-} method of the
+ actual NMF model. It is not meant to be used by the user,
+ except when developing NMF algorithms, to update the
+ basis matrix of the seed object before returning it. }
+
+ \item{.coef}{\code{signature(object = "NMFfit")}: Returns
+ the the coefficient matrix from an NMF model fitted with
+ function \code{\link{nmf}}.
+
+ It is a shortcut for \code{.coef(fit(object), ...)},
+ dispatching the call to the \code{.coef} method of the
+ actual NMF model. }
+
+ \item{.coef<-}{\code{signature(object = "NMFfit", value =
+ "matrix")}: Sets the the coefficient matrix of an NMF
+ model fitted with function \code{\link{nmf}}.
+
+ It is a shortcut for \code{.coef(fit(object)) <- value},
+ dispatching the call to the \code{.coef<-} method of the
+ actual NMF model. It is not meant to be used by the user,
+ except when developing NMF algorithms, to update the
+ coefficient matrix in the seed object before returning
+ it. }
+
+ \item{compare}{\code{signature(object = "NMFfit")}:
+ Compare multiple NMF fits passed as arguments. }
+
+ \item{deviance}{\code{signature(object = "NMFfit")}:
+ Returns the deviance of a fitted NMF model.
+
+ This method returns the final residual value if the
+ target matrix \code{y} is not supplied, or the
+ approximation error between the fitted NMF model stored
+ in \code{object} and \code{y}. In this case, the
+ computation is performed using the objective function
+ \code{method} if not missing, or the objective of the
+ algorithm that fitted the model (stored in slot
+ \code{'distance'}).
+
+ See \code{\link{deviance,NMFfit-method}} for more
+ details. }
+
+ \item{fit}{\code{signature(object = "NMFfit")}: Returns
+ the NMF model object stored in slot \code{'fit'}. }
+
+ \item{fit<-}{\code{signature(object = "NMFfit", value =
+ "NMF")}: Updates the NMF model object stored in slot
+ \code{'fit'} with a new value. }
+
+ \item{fitted}{\code{signature(object = "NMFfit")}:
+ Computes and return the estimated target matrix from an
+ NMF model fitted with function \code{\link{nmf}}.
+
+ It is a shortcut for \code{fitted(fit(object), ...)},
+ dispatching the call to the \code{fitted} method of the
+ actual NMF model. }
+
+ \item{ibterms}{\code{signature(object = "NMFfit")}:
+ Method for single NMF fit objects, which returns the
+ indexes of fixed basis terms from the fitted model. }
+
+ \item{icterms}{\code{signature(object = "NMFfit")}:
+ Method for single NMF fit objects, which returns the
+ indexes of fixed coefficient terms from the fitted model.
+ }
+
+ \item{icterms}{\code{signature(object = "NMFfit")}:
+ Method for multiple NMF fit objects, which returns the
+ indexes of fixed coefficient terms from the best fitted
+ model. }
+
+ \item{minfit}{\code{signature(object = "NMFfit")}:
+ Returns the object its self, since there it is the result
+ of a single NMF run. }
+
+ \item{modelname}{\code{signature(object = "NMFfit")}:
+ Returns the type of a fitted NMF model. It is a shortcut
+ for \code{modelname(fit(object)}. }
+
+ \item{niter}{\code{signature(object = "NMFfit")}: Returns
+ the number of iteration performed to fit an NMF model,
+ typically with function \code{\link{nmf}}.
+
+ Currently this data is stored in slot \code{'extra'}, but
+ this might change in the future. }
+
+ \item{niter<-}{\code{signature(object = "NMFfit", value =
+ "numeric")}: Sets the number of iteration performed to
+ fit an NMF model.
+
+ This function is used internally by the function
+ \code{\link{nmf}}. It is not meant to be called by the
+ user, except when developing new NMF algorithms
+ implemented as single function, to set the number of
+ iterations performed by the algorithm on the seed, before
+ returning it (see
+ \code{\linkS4class{NMFStrategyFunction}}). }
+
+ \item{nmf.equal}{\code{signature(x = "NMFfit", y =
+ "NMF")}: Compares two NMF models when at least one comes
+ from a NMFfit object, i.e. an object returned by a single
+ run of \code{\link{nmf}}. }
+
+ \item{nmf.equal}{\code{signature(x = "NMFfit", y =
+ "NMFfit")}: Compares two fitted NMF models, i.e. objects
+ returned by single runs of \code{\link{nmf}}. }
+
+ \item{NMFfitX}{\code{signature(object = "NMFfit")}:
+ Creates an \code{NMFfitX1} object from a single fit. This
+ is used in \code{\link{nmf}} when only the best fit is
+ kept in memory or on disk. }
+
+ \item{nrun}{\code{signature(object = "NMFfit")}: This
+ method always returns 1, since an \code{NMFfit} object is
+ obtained from a single NMF run. }
+
+ \item{objective}{\code{signature(object = "NMFfit")}:
+ Returns the objective function associated with the
+ algorithm that computed the fitted NMF model
+ \code{object}, or the objective value with respect to a
+ given target matrix \code{y} if it is supplied. }
+
+ \item{offset}{\code{signature(object = "NMFfit")}:
+ Returns the offset from the fitted model. }
+
+ \item{plot}{\code{signature(x = "NMFfit", y =
+ "missing")}: Plots the residual track computed at regular
+ interval during the fit of the NMF model \code{x}. }
+
+ \item{residuals}{\code{signature(object = "NMFfit")}:
+ Returns the residuals -- track -- between the target
+ matrix and the NMF fit \code{object}. }
+
+ \item{runtime}{\code{signature(object = "NMFfit")}:
+ Returns the CPU time required to compute a single NMF
+ fit. }
+
+ \item{runtime.all}{\code{signature(object = "NMFfit")}:
+ Identical to \code{runtime}, since their is a single fit.
+ }
+
+ \item{seeding}{\code{signature(object = "NMFfit")}:
+ Returns the name of the seeding method that generated the
+ starting point for the NMF algorithm that fitted the NMF
+ model \code{object}. }
+
+ \item{show}{\code{signature(object = "NMFfit")}: Show
+ method for objects of class \code{NMFfit} }
+
+ \item{summary}{\code{signature(object = "NMFfit")}:
+ Computes summary measures for a single fit from
+ \code{\link{nmf}}.
+
+ This method adds the following measures to the measures
+ computed by the method \code{summary,NMF}:
+
+ See \code{\link{summary,NMFfit-method}} for more details.
+ }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# run default NMF algorithm on a random matrix
+n <- 50; r <- 3; p <- 20
+V <- rmatrix(n, p)
+res <- nmf(V, r)
+
+# result class is NMFfit
+class(res)
+isNMFfit(res)
+
+# show result
+res
+
+# compute summary measures
+summary(res, target=V)
+}
+
diff --git a/man/NMFfitX-class.Rd b/man/NMFfitX-class.Rd
new file mode 100644
index 0000000..3c867d7
--- /dev/null
+++ b/man/NMFfitX-class.Rd
@@ -0,0 +1,189 @@
+\docType{class}
+\name{NMFfitX-class}
+\alias{NMFfitX-class}
+\title{Virtual Class to Handle Results from Multiple Runs of NMF Algorithms}
+\description{
+ This class defines a common interface to handle the
+ results from multiple runs of a single NMF algorithm,
+ performed with the \code{\link{nmf}} method.
+}
+\details{
+ Currently, this interface is implemented by two classes,
+ \code{\linkS4class{NMFfitX1}} and
+ \code{\linkS4class{NMFfitXn}}, which respectively handle
+ the case where only the best fit is kept, and the case
+ where the list of all the fits is returned.
+
+ See \code{\link{nmf}} for more details on the method
+ arguments.
+}
+\section{Slots}{
+ \describe{
+
+ \item{runtime.all}{Object of class
+ \code{\link[=proc.time]{proc_time}} that contains CPU
+ times required to perform all the runs.}
+
+ }
+}
+\section{Methods}{
+ \describe{
+
+ \item{basismap}{\code{signature(object = "NMFfitX")}:
+ Plots a heatmap of the basis matrix of the best fit in
+ \code{object}. }
+
+ \item{coefmap}{\code{signature(object = "NMFfitX")}:
+ Plots a heatmap of the coefficient matrix of the best fit
+ in \code{object}.
+
+ This method adds: \itemize{ \item an extra special column
+ annotation track for multi-run NMF fits,
+ \code{'consensus:'}, that shows the consensus cluster
+ associated to each sample. \item a column sorting schema
+ \code{'consensus'} that can be passed to argument
+ \code{Colv} and orders the columns using the hierarchical
+ clustering of the consensus matrix with average linkage,
+ as returned by \code{\link{consensushc}(object)}. This is
+ also the ordering that is used by default for the heatmap
+ of the consensus matrix as ploted by
+ \code{\link{consensusmap}}. } }
+
+ \item{consensus}{\code{signature(object = "NMFfitX")}:
+ Pure virtual method defined to ensure \code{consensus} is
+ defined for sub-classes of \code{NMFfitX}. It throws an
+ error if called. }
+
+ \item{consensushc}{\code{signature(object = "NMFfitX")}:
+ Compute the hierarchical clustering on the consensus
+ matrix of \code{object}, or on the connectivity matrix of
+ the best fit in \code{object}. }
+
+ \item{consensusmap}{\code{signature(object = "NMFfitX")}:
+ Plots a heatmap of the consensus matrix obtained when
+ fitting an NMF model with multiple runs. }
+
+ \item{cophcor}{\code{signature(object = "NMFfitX")}:
+ Computes the cophenetic correlation coefficient on the
+ consensus matrix of \code{object}. All arguments in
+ \code{...} are passed to the method
+ \code{cophcor,matrix}. }
+
+ \item{deviance}{\code{signature(object = "NMFfitX")}:
+ Returns the deviance achieved by the best fit object,
+ i.e. the lowest deviance achieved across all NMF runs. }
+
+ \item{dispersion}{\code{signature(object = "NMFfitX")}:
+ Computes the dispersion on the consensus matrix obtained
+ from multiple NMF runs. }
+
+ \item{fit}{\code{signature(object = "NMFfitX")}: Returns
+ the model object that achieves the lowest residual
+ approximation error across all the runs.
+
+ It is a pure virtual method defined to ensure \code{fit}
+ is defined for sub-classes of \code{NMFfitX}, which
+ throws an error if called. }
+
+ \item{getRNG1}{\code{signature(object = "NMFfitX")}:
+ Returns the RNG settings used for the first NMF run of
+ multiple NMF runs. }
+
+ \item{ibterms}{\code{signature(object = "NMFfitX")}:
+ Method for multiple NMF fit objects, which returns the
+ indexes of fixed basis terms from the best fitted model.
+ }
+
+ \item{metaHeatmap}{\code{signature(object = "NMFfitX")}:
+ Deprecated method subsituted by
+ \code{\link{consensusmap}}. }
+
+ \item{minfit}{\code{signature(object = "NMFfitX")}:
+ Returns the fit object that achieves the lowest residual
+ approximation error across all the runs.
+
+ It is a pure virtual method defined to ensure
+ \code{minfit} is defined for sub-classes of
+ \code{NMFfitX}, which throws an error if called. }
+
+ \item{nmf.equal}{\code{signature(x = "NMFfitX", y =
+ "NMF")}: Compares two NMF models when at least one comes
+ from multiple NMF runs. }
+
+ \item{NMFfitX}{\code{signature(object = "NMFfitX")}:
+ Provides a way to aggregate \code{NMFfitXn} objects into
+ an \code{NMFfitX1} object. }
+
+ \item{nrun}{\code{signature(object = "NMFfitX")}: Returns
+ the number of NMF runs performed to create \code{object}.
+
+ It is a pure virtual method defined to ensure \code{nrun}
+ is defined for sub-classes of \code{NMFfitX}, which
+ throws an error if called.
+
+ See \code{\link{nrun,NMFfitX-method}} for more details. }
+
+ \item{predict}{\code{signature(object = "NMFfitX")}:
+ Returns the cluster membership index from an NMF model
+ fitted with multiple runs.
+
+ Besides the type of clustering available for any NMF
+ models (\code{'columns', 'rows', 'samples', 'features'}),
+ this method can return the cluster membership index based
+ on the consensus matrix, computed from the multiple NMF
+ runs.
+
+ See \code{\link{predict,NMFfitX-method}} for more
+ details. }
+
+ \item{residuals}{\code{signature(object = "NMFfitX")}:
+ Returns the residuals achieved by the best fit object,
+ i.e. the lowest residual approximation error achieved
+ across all NMF runs. }
+
+ \item{runtime.all}{\code{signature(object = "NMFfitX")}:
+ Returns the CPU time required to compute all the NMF
+ runs. It returns \code{NULL} if no CPU data is available.
+ }
+
+ \item{show}{\code{signature(object = "NMFfitX")}: Show
+ method for objects of class \code{NMFfitX} }
+
+ \item{summary}{\code{signature(object = "NMFfitX")}:
+ Computes a set of measures to help evaluate the quality
+ of the \emph{best fit} of the set. The result is similar
+ to the result from the \code{summary} method of
+ \code{NMFfit} objects. See \code{\linkS4class{NMF}} for
+ details on the computed measures. In addition, the
+ cophenetic correlation (\code{\link{cophcor}}) and
+ \code{\link{dispersion}} coefficients of the consensus
+ matrix are returned, as well as the total CPU time
+ (\code{\link{runtime.all}}). }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# generate a synthetic dataset with known classes
+n <- 20; counts <- c(5, 2, 3);
+V <- syntheticNMF(n, counts)
+
+# perform multiple runs of one algorithm (default is to keep only best fit)
+res <- nmf(V, 3, nrun=3)
+res
+
+# plot a heatmap of the consensus matrix
+\dontrun{ consensusmap(res) }
+
+# perform multiple runs of one algorithm (keep all the fits)
+res <- nmf(V, 3, nrun=3, .options='k')
+res
+}
+\seealso{
+ Other multipleNMF: \code{\link{NMFfitX1-class}},
+ \code{\link{NMFfitXn-class}}
+}
+
diff --git a/man/NMFfitX.Rd b/man/NMFfitX.Rd
new file mode 100644
index 0000000..6a3e144
--- /dev/null
+++ b/man/NMFfitX.Rd
@@ -0,0 +1,48 @@
+\docType{methods}
+\name{NMFfitX}
+\alias{NMFfitX}
+\alias{NMFfitX,list-method}
+\alias{NMFfitX-methods}
+\alias{NMFfitX,NMFfit-method}
+\alias{NMFfitX,NMFfitX-method}
+\title{Factory Method for Multiple NMF Run Objects}
+\usage{
+ NMFfitX(object, ...)
+
+ \S4method{NMFfitX}{list}(object, ..., .merge = FALSE)
+}
+\arguments{
+ \item{object}{an object from which is created an
+ \code{NMFfitX} object}
+
+ \item{...}{extra arguments used to pass values for slots}
+
+ \item{.merge}{a logical that indicates if the fits should
+ be aggregated, only keeping the best fit, and return an
+ \code{NMFfitX1} object. If \code{FALSE}, an
+ \code{NMFfitXn} object containing the data of all the
+ fits is returned.}
+}
+\description{
+ Factory Method for Multiple NMF Run Objects
+}
+\section{Methods}{
+ \describe{
+
+ \item{NMFfitX}{\code{signature(object = "list")}: Create
+ an \code{NMFfitX} object from a list of fits. }
+
+ \item{NMFfitX}{\code{signature(object = "NMFfit")}:
+ Creates an \code{NMFfitX1} object from a single fit. This
+ is used in \code{\link{nmf}} when only the best fit is
+ kept in memory or on disk. }
+
+ \item{NMFfitX}{\code{signature(object = "NMFfitX")}:
+ Provides a way to aggregate \code{NMFfitXn} objects into
+ an \code{NMFfitX1} object. }
+
+ }
+}
+\keyword{internal}
+\keyword{methods}
+
diff --git a/man/NMFfitX1-class.Rd b/man/NMFfitX1-class.Rd
new file mode 100644
index 0000000..62c7378
--- /dev/null
+++ b/man/NMFfitX1-class.Rd
@@ -0,0 +1,115 @@
+\docType{class}
+\name{NMFfitX1-class}
+\alias{NMFfitX1-class}
+\title{Structure for Storing the Best Fit Amongst Multiple NMF Runs}
+\description{
+ This class is used to return the result from a multiple
+ run of a single NMF algorithm performed with function
+ \code{nmf} with the -- default -- option
+ \code{keep.all=FALSE} (cf. \code{\link{nmf}}).
+}
+\details{
+ It extends both classes \code{\linkS4class{NMFfitX}} and
+ \code{\linkS4class{NMFfit}}, and stores a the result of
+ the best fit in its \code{NMFfit} structure.
+
+ Beside the best fit, this class allows to hold data about
+ the computation of the multiple runs, such as the number
+ of runs, the CPU time used to perform all the runs, as
+ well as the consensus matrix.
+
+ Due to the inheritance from class \code{NMFfit}, objects
+ of class \code{NMFfitX1} can be handled exactly as the
+ results of single NMF run -- as if only the best run had
+ been performed.
+}
+\section{Slots}{
+ \describe{
+
+ \item{consensus}{object of class \code{matrix} used to
+ store the consensus matrix based on all the runs.}
+
+ \item{nrun}{an \code{integer} that contains the number of
+ runs performed to compute the object.}
+
+ \item{rng1}{an object that contains RNG settings used for
+ the first run. See \code{\link{getRNG1}}.}
+
+ }
+}
+\section{Methods}{
+ \describe{
+
+ \item{consensus}{\code{signature(object = "NMFfitX1")}:
+ The result is the matrix stored in slot
+ \sQuote{consensus}. This method returns \code{NULL} if
+ the consensus matrix is empty. }
+
+ \item{fit}{\code{signature(object = "NMFfitX1")}: Returns
+ the model object associated with the best fit, amongst
+ all the runs performed when fitting \code{object}.
+
+ Since \code{NMFfitX1} objects only hold the best fit,
+ this method simply returns the NMF model fitted by
+ \code{object} -- that is stored in slot \sQuote{fit}. }
+
+ \item{getRNG1}{\code{signature(object = "NMFfitX1")}:
+ Returns the RNG settings used to compute the first of all
+ NMF runs, amongst which \code{object} was selected as the
+ best fit. }
+
+ \item{minfit}{\code{signature(object = "NMFfitX1")}:
+ Returns the fit object associated with the best fit,
+ amongst all the runs performed when fitting
+ \code{object}.
+
+ Since \code{NMFfitX1} objects only hold the best fit,
+ this method simply returns \code{object} coerced into an
+ \code{NMFfit} object. }
+
+ \item{nmf.equal}{\code{signature(x = "NMFfitX1", y =
+ "NMFfitX1")}: Compares the NMF models fitted by multiple
+ runs, that only kept the best fits. }
+
+ \item{nrun}{\code{signature(object = "NMFfitX1")}:
+ Returns the number of NMF runs performed, amongst which
+ \code{object} was selected as the best fit. }
+
+ \item{show}{\code{signature(object = "NMFfitX1")}: Show
+ method for objects of class \code{NMFfitX1} }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# generate a synthetic dataset with known classes
+n <- 20; counts <- c(5, 2, 3);
+V <- syntheticNMF(n, counts)
+
+# get the class factor
+groups <- V$pData$Group
+
+# perform multiple runs of one algorithm, keeping only the best fit (default)
+#i.e.: the implicit nmf options are .options=list(keep.all=FALSE) or .options='-k'
+res <- nmf(V, 3, nrun=3)
+res
+
+# compute summary measures
+summary(res)
+# get more info
+summary(res, target=V, class=groups)
+
+# show computational time
+runtime.all(res)
+
+# plot the consensus matrix, as stored (pre-computed) in the object
+\dontrun{ consensusmap(res, annCol=groups) }
+}
+\seealso{
+ Other multipleNMF: \code{\link{NMFfitX-class}},
+ \code{\link{NMFfitXn-class}}
+}
+
diff --git a/man/NMFfitXn-class.Rd b/man/NMFfitXn-class.Rd
new file mode 100644
index 0000000..b69668a
--- /dev/null
+++ b/man/NMFfitXn-class.Rd
@@ -0,0 +1,185 @@
+\docType{class}
+\name{NMFfitXn-class}
+\alias{NMFfitXn-class}
+\title{Structure for Storing All Fits from Multiple NMF Runs}
+\description{
+ This class is used to return the result from a multiple
+ run of a single NMF algorithm performed with function
+ \code{nmf} with option \code{keep.all=TRUE} (cf.
+ \code{\link{nmf}}).
+}
+\details{
+ It extends both classes \code{\linkS4class{NMFfitX}} and
+ \code{list}, and stores the result of each run (i.e. a
+ \code{NMFfit} object) in its \code{list} structure.
+
+ IMPORTANT NOTE: This class is designed to be
+ \strong{read-only}, even though all the
+ \code{list}-methods can be used on its instances. Adding
+ or removing elements would most probably lead to
+ incorrect results in subsequent calls. Capability for
+ concatenating and merging NMF results is for the moment
+ only used internally, and should be included and
+ supported in the next release of the package.
+}
+\section{Slots}{
+ \describe{
+
+ \item{.Data}{standard slot that contains the S3
+ \code{list} object data. See R documentation on S3/S4
+ classes for more details (e.g.,
+ \code{\link{setOldClass}}).}
+
+ }
+}
+\section{Methods}{
+ \describe{
+
+ \item{algorithm}{\code{signature(object = "NMFfitXn")}:
+ Returns the name of the common NMF algorithm used to
+ compute all fits stored in \code{object}
+
+ Since all fits are computed with the same algorithm, this
+ method returns the name of algorithm that computed the
+ first fit. It returns \code{NULL} if the object is empty.
+ }
+
+ \item{basis}{\code{signature(object = "NMFfitXn")}:
+ Returns the basis matrix of the best fit amongst all the
+ fits stored in \code{object}. It is a shortcut for
+ \code{basis(fit(object))}. }
+
+ \item{coef}{\code{signature(object = "NMFfitXn")}:
+ Returns the coefficient matrix of the best fit amongst
+ all the fits stored in \code{object}. It is a shortcut
+ for \code{coef(fit(object))}. }
+
+ \item{compare}{\code{signature(object = "NMFfitXn")}:
+ Compares the fits obtained by separate runs of NMF, in a
+ single call to \code{\link{nmf}}. }
+
+ \item{consensus}{\code{signature(object = "NMFfitXn")}:
+ This method returns \code{NULL} on an empty object. The
+ result is a matrix with several attributes attached, that
+ are used by plotting functions such as
+ \code{\link{consensusmap}} to annotate the plots. }
+
+ \item{dim}{\code{signature(x = "NMFfitXn")}: Returns the
+ dimension common to all fits.
+
+ Since all fits have the same dimensions, it returns the
+ dimension of the first fit. This method returns
+ \code{NULL} if the object is empty. }
+
+ \item{entropy}{\code{signature(x = "NMFfitXn", y =
+ "ANY")}: Computes the best or mean entropy across all NMF
+ fits stored in \code{x}. }
+
+ \item{fit}{\code{signature(object = "NMFfitXn")}: Returns
+ the best NMF fit object amongst all the fits stored in
+ \code{object}, i.e. the fit that achieves the lowest
+ estimation residuals. }
+
+ \item{.getRNG}{\code{signature(object = "NMFfitXn")}:
+ Returns the RNG settings used for the best fit.
+
+ This method throws an error if the object is empty. }
+
+ \item{getRNG1}{\code{signature(object = "NMFfitXn")}:
+ Returns the RNG settings used for the first run.
+
+ This method throws an error if the object is empty. }
+
+ \item{minfit}{\code{signature(object = "NMFfitXn")}:
+ Returns the best NMF model in the list, i.e. the run that
+ achieved the lower estimation residuals.
+
+ The model is selected based on its \code{deviance} value.
+ }
+
+ \item{modelname}{\code{signature(object = "NMFfitXn")}:
+ Returns the common type NMF model of all fits stored in
+ \code{object}
+
+ Since all fits are from the same NMF model, this method
+ returns the model type of the first fit. It returns
+ \code{NULL} if the object is empty. }
+
+ \item{nbasis}{\code{signature(x = "NMFfitXn")}: Returns
+ the number of basis components common to all fits.
+
+ Since all fits have been computed using the same rank, it
+ returns the factorization rank of the first fit. This
+ method returns \code{NULL} if the object is empty. }
+
+ \item{nrun}{\code{signature(object = "NMFfitXn")}:
+ Returns the number of runs performed to compute the fits
+ stored in the list (i.e. the length of the list itself).
+ }
+
+ \item{purity}{\code{signature(x = "NMFfitXn", y =
+ "ANY")}: Computes the best or mean purity across all NMF
+ fits stored in \code{x}. }
+
+ \item{runtime.all}{\code{signature(object = "NMFfitXn")}:
+ If no time data is available from in slot
+ \sQuote{runtime.all} and argument \code{null=TRUE}, then
+ the sequential time as computed by \code{\link{seqtime}}
+ is returned, and a warning is thrown unless
+ \code{warning=FALSE}. }
+
+ \item{seeding}{\code{signature(object = "NMFfitXn")}:
+ Returns the name of the common seeding method used the
+ computation of all fits stored in \code{object}
+
+ Since all fits are seeded using the same method, this
+ method returns the name of the seeding method used for
+ the first fit. It returns \code{NULL} if the object is
+ empty. }
+
+ \item{seqtime}{\code{signature(object = "NMFfitXn")}:
+ Returns the CPU time that would be required to
+ sequentially compute all NMF fits stored in
+ \code{object}.
+
+ This method calls the function \code{runtime} on each fit
+ and sum up the results. It returns \code{NULL} on an
+ empty object. }
+
+ \item{show}{\code{signature(object = "NMFfitXn")}: Show
+ method for objects of class \code{NMFfitXn} }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# generate a synthetic dataset with known classes
+n <- 20; counts <- c(5, 2, 3);
+V <- syntheticNMF(n, counts)
+
+# get the class factor
+groups <- V$pData$Group
+
+# perform multiple runs of one algorithm, keeping all the fits
+res <- nmf(V, 3, nrun=3, .options='k') # .options=list(keep.all=TRUE) also works
+res
+
+summary(res)
+# get more info
+summary(res, target=V, class=groups)
+
+# compute/show computational times
+runtime.all(res)
+seqtime(res)
+
+# plot the consensus matrix, computed on the fly
+\dontrun{ consensusmap(res, annCol=groups) }
+}
+\seealso{
+ Other multipleNMF: \code{\link{NMFfitX1-class}},
+ \code{\link{NMFfitX-class}}
+}
+
diff --git a/man/NMFns-class.Rd b/man/NMFns-class.Rd
new file mode 100644
index 0000000..a2769a1
--- /dev/null
+++ b/man/NMFns-class.Rd
@@ -0,0 +1,135 @@
+\docType{class}
+\name{NMFns-class}
+\alias{NMFns-class}
+\title{NMF Model - Nonsmooth Nonnegative Matrix Factorization}
+\description{
+ This class implements the \emph{Nonsmooth Nonnegative
+ Matrix Factorization} (nsNMF) model, required by the
+ Nonsmooth NMF algorithm.
+
+ The Nonsmooth NMF algorithm is defined by
+ \cite{Pascual-Montano et al. (2006)} as a modification of
+ the standard divergence based NMF algorithm (see section
+ Details and references below). It aims at obtaining
+ sparser factor matrices, by the introduction of a
+ smoothing matrix.
+}
+\details{
+ The Nonsmooth NMF algorithm is a modification of the
+ standard divergence based NMF algorithm (see
+ \code{\linkS4class{NMF}}). Given a non-negative \eqn{n
+ \times p}{n x p} matrix \eqn{V} and a factorization rank
+ \eqn{r}, it fits the following model:
+
+ \deqn{V \equiv W S(\theta) H,}{V ~ W S(theta) H,}
+ where: \itemize{
+
+ \item \eqn{W} and \eqn{H} are such as in the standard
+ model, i.e. non-negative matrices of dimension \eqn{n
+ \times r}{n x r} and \eqn{r \times p}{r x p}
+ respectively;
+
+ \item \eqn{S} is a \eqn{r \times r} square matrix whose
+ entries depends on an extra parameter \eqn{0\leq \theta
+ \leq 1} in the following way: \deqn{S = (1-\theta)I +
+ \frac{\theta}{r} 11^T ,} where \eqn{I} is the identity
+ matrix and \eqn{1} is a vector of ones.
+
+ }
+
+ The interpretation of S as a smoothing matrix can be
+ explained as follows: Let \eqn{X} be a positive, nonzero,
+ vector. Consider the transformed vector \eqn{Y = S X}. If
+ \eqn{\theta = 0}, then \eqn{Y = X} and no smoothing on
+ \eqn{X} has occurred. However, as \eqn{\theta \to
+ 1}{theta tends to 1}, the vector \eqn{Y} tends to the
+ constant vector with all elements almost equal to the
+ average of the elements of \eqn{X}. This is the smoothest
+ possible vector in the sense of non-sparseness because
+ all entries are equal to the same nonzero value, instead
+ of having some values close to zero and others clearly
+ nonzero.
+}
+\section{Methods}{
+ \describe{
+
+ \item{fitted}{\code{signature(object = "NMFns")}: Compute
+ estimate for an NMFns object, according to the Nonsmooth
+ NMF model (cf. \code{\link{NMFns-class}}).
+
+ Extra arguments in \code{...} are passed to method
+ \code{smoothing}, and are typically used to pass a value
+ for \code{theta}, which is used to compute the smoothing
+ matrix instead of the one stored in \code{object}. }
+
+ \item{show}{\code{signature(object = "NMFns")}: Show
+ method for objects of class \code{NMFns} }
+
+ }
+}
+\section{Creating objects from the Class}{
+ Object of class \code{NMFns} can be created using the
+ standard way with operator \code{\link{new}}
+
+ However, as for all NMF model classes -- that extend
+ class \code{\linkS4class{NMF}}, objects of class
+ \code{NMFns} should be created using factory method
+ \code{\link{nmfModel}} :
+
+ \code{new('NMFns')}
+
+ \code{nmfModel(model='NMFns')}
+
+ \code{nmfModel(model='NMFns', W=w, theta=0.3}
+
+ See \code{\link{nmfModel}} for more details on how to use
+ the factory method.
+}
+
+\section{Algorithm}{
+ The Nonsmooth NMF algorithm uses a modified version of
+ the multiplicative update equations in Lee & Seung's
+ method for Kullback-Leibler divergence minimization. The
+ update equations are modified to take into account the --
+ constant -- smoothing matrix. The modification reduces to
+ using matrix \eqn{W S} instead of matrix \eqn{W} in the
+ update of matrix \eqn{H}, and similarly using matrix
+ \eqn{S H} instead of matrix \eqn{H} in the update of
+ matrix \eqn{W}.
+
+ After the matrix \eqn{W} has been updated, each of its
+ columns is scaled so that it sums up to 1.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# create a completely empty NMFns object
+new('NMFns')
+
+# create a NMF object based on random (compatible) matrices
+n <- 50; r <- 3; p <- 20
+w <- rmatrix(n, r)
+h <- rmatrix(r, p)
+nmfModel(model='NMFns', W=w, H=h)
+
+# apply Nonsmooth NMF algorithm to a random target matrix
+V <- rmatrix(n, p)
+\dontrun{nmf(V, r, 'ns')}
+
+# random nonsmooth NMF model
+rnmf(3, 10, 5, model='NMFns', theta=0.3)
+}
+\references{
+ Pascual-Montano A, Carazo JM, Kochi K, Lehmann D and
+ Pascual-marqui RD (2006). "Nonsmooth nonnegative matrix
+ factorization (nsNMF)." _IEEE Trans. Pattern Anal. Mach.
+ Intell_, *28*, pp. 403-415.
+}
+\seealso{
+ Other NMF-model:
+ \code{\link{initialize,NMFOffset-method}},
+ \code{\link{NMFOffset-class}}, \code{\link{NMFstd-class}}
+}
+
diff --git a/man/NMFstd-class.Rd b/man/NMFstd-class.Rd
new file mode 100644
index 0000000..3a91b7a
--- /dev/null
+++ b/man/NMFstd-class.Rd
@@ -0,0 +1,186 @@
+\docType{class}
+\name{NMFstd-class}
+\alias{NMFstd-class}
+\title{NMF Model - Standard model}
+\description{
+ This class implements the standard model of Nonnegative
+ Matrix Factorization. It provides a general structure and
+ generic functions to manage factorizations that follow
+ the standard NMF model, as defined by \cite{Lee et al.
+ (2001)}.
+}
+\details{
+ Let \eqn{V} be a \eqn{n \times m} non-negative matrix and
+ \eqn{r} a positive integer. In its standard form (see
+ references below), a NMF of \eqn{V} is commonly defined
+ as a pair of matrices \eqn{(W, H)} such that:
+
+ \deqn{V \equiv W H,}
+
+ where: \itemize{ \item \eqn{W} and \eqn{H} are \eqn{n
+ \times r} and \eqn{r \times m} matrices respectively with
+ non-negative entries; \item \eqn{\equiv} is to be
+ understood with respect to some loss function. Common
+ choices of loss functions are based on Frobenius norm or
+ Kullback-Leibler divergence. }
+
+ Integer \eqn{r} is called the \emph{factorization rank}.
+ Depending on the context of application of NMF, the
+ columns of \eqn{W} and \eqn{H} are given different names:
+ \describe{ \item{columns of \code{W}}{basis vector,
+ metagenes, factors, source, image basis} \item{columns of
+ \code{H}}{mixture coefficients, metagene sample
+ expression profiles, weights} \item{rows of
+ \code{H}}{basis profiles, metagene expression profiles} }
+
+ NMF approaches have been successfully applied to several
+ fields. The package NMF was implemented trying to use
+ names as generic as possible for objects and methods.
+
+ The following terminology is used: \describe{
+ \item{samples}{the columns of the target matrix \eqn{V}}
+ \item{features}{the rows of the target matrix \eqn{V}}
+ \item{basis matrix}{the first matrix factor \eqn{W}}
+ \item{basis vectors}{the columns of first matrix factor
+ \eqn{W}} \item{mixture matrix}{the second matrix factor
+ \eqn{H}} \item{mixtures coefficients}{the columns of
+ second matrix factor \eqn{H}} }
+
+ However, because the package NMF was primarily
+ implemented to work with gene expression microarray data,
+ it also provides a layer to easily and intuitively work
+ with objects from the Bioconductor base framework. See
+ \link{bioc-NMF} for more details.
+}
+\section{Slots}{
+ \describe{
+
+ \item{W}{A \code{matrix} that contains the basis matrix,
+ i.e. the \emph{first} matrix factor of the factorisation}
+
+ \item{H}{A \code{matrix} that contains the coefficient
+ matrix, i.e. the \emph{second} matrix factor of the
+ factorisation}
+
+ \item{bterms}{a \code{data.frame} that contains the
+ primary data that define fixed basis terms. See
+ \code{\link{bterms}}.}
+
+ \item{ibterms}{integer vector that contains the indexes
+ of the basis components that are fixed, i.e. for which
+ only the coefficient are estimated.
+
+ IMPORTANT: This slot is set on construction of an NMF
+ model via
+ \code{\link[=nmfModel,formula,ANY-method]{nmfModel}} and
+ is not recommended to not be subsequently changed by the
+ end-user.}
+
+ \item{cterms}{a \code{data.frame} that contains the
+ primary data that define fixed coefficient terms. See
+ \code{\link{cterms}}.}
+
+ \item{icterms}{integer vector that contains the indexes
+ of the basis components that have fixed coefficients,
+ i.e. for which only the basis vectors are estimated.
+
+ IMPORTANT: This slot is set on construction of an NMF
+ model via
+ \code{\link[=nmfModel,formula,ANY-method]{nmfModel}} and
+ is not recommended to not be subsequently changed by the
+ end-user.}
+
+ }
+}
+\section{Methods}{
+ \describe{
+
+ \item{.basis}{\code{signature(object = "NMFstd")}: Get
+ the basis matrix in standard NMF models
+
+ This function returns slot \code{W} of \code{object}. }
+
+ \item{.basis<-}{\code{signature(object = "NMFstd", value
+ = "matrix")}: Set the basis matrix in standard NMF models
+
+ This function sets slot \code{W} of \code{object}. }
+
+ \item{bterms<-}{\code{signature(object = "NMFstd")}:
+ Default method tries to coerce \code{value} into a
+ \code{data.frame} with \code{\link{as.data.frame}}. }
+
+ \item{.coef}{\code{signature(object = "NMFstd")}: Get the
+ mixture coefficient matrix in standard NMF models
+
+ This function returns slot \code{H} of \code{object}. }
+
+ \item{.coef<-}{\code{signature(object = "NMFstd", value =
+ "matrix")}: Set the mixture coefficient matrix in
+ standard NMF models
+
+ This function sets slot \code{H} of \code{object}. }
+
+ \item{cterms<-}{\code{signature(object = "NMFstd")}:
+ Default method tries to coerce \code{value} into a
+ \code{data.frame} with \code{\link{as.data.frame}}. }
+
+ \item{fitted}{\code{signature(object = "NMFstd")}:
+ Compute the target matrix estimate in \emph{standard NMF
+ models}.
+
+ The estimate matrix is computed as the product of the two
+ matrix slots \code{W} and \code{H}: \deqn{\hat{V} = W
+ H}{V ~ W H} }
+
+ \item{ibterms}{\code{signature(object = "NMFstd")}:
+ Method for standard NMF models, which returns the integer
+ vector that is stored in slot \code{ibterms} when a
+ formula-based NMF model is instantiated. }
+
+ \item{icterms}{\code{signature(object = "NMFstd")}:
+ Method for standard NMF models, which returns the integer
+ vector that is stored in slot \code{icterms} when a
+ formula-based NMF model is instantiated. }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# create a completely empty NMFstd object
+new('NMFstd')
+
+# create a NMF object based on one random matrix: the missing matrix is deduced
+# Note this only works when using factory method NMF
+n <- 50; r <- 3;
+w <- rmatrix(n, r)
+nmfModel(W=w)
+
+# create a NMF object based on random (compatible) matrices
+p <- 20
+h <- rmatrix(r, p)
+nmfModel(W=w, H=h)
+
+# create a NMF object based on incompatible matrices: generate an error
+h <- rmatrix(r+1, p)
+try( new('NMFstd', W=w, H=h) )
+try( nmfModel(w, h) )
+
+# Giving target dimensions to the factory method allow for coping with dimension
+# incompatibilty (a warning is thrown in such case)
+nmfModel(r, W=w, H=h)
+}
+\references{
+ Lee DD and Seung H (2001). "Algorithms for non-negative
+ matrix factorization." _Advances in neural information
+ processing systems_. <URL:
+ http://scholar.google.com/scholar?q=intitle:Algorithms+for+non-negative+matrix+factorization\#0>.
+}
+\seealso{
+ Other NMF-model:
+ \code{\link{initialize,NMFOffset-method}},
+ \code{\link{NMFns-class}}, \code{\link{NMFOffset-class}}
+}
+
diff --git a/man/RNG.Rd b/man/RNG.Rd
new file mode 100644
index 0000000..9b68257
--- /dev/null
+++ b/man/RNG.Rd
@@ -0,0 +1,75 @@
+\docType{methods}
+\name{getRNG1}
+\alias{.getRNG}
+\alias{getRNG1}
+\alias{getRNG1-methods}
+\alias{getRNG1,NMFfitX1-method}
+\alias{getRNG1,NMFfitX-method}
+\alias{getRNG1,NMFfitXn-method}
+\alias{.getRNG-methods}
+\alias{.getRNG,NMFfitXn-method}
+\title{Extracting RNG Data from NMF Objects}
+\usage{
+ getRNG1(object, ...)
+
+ .getRNG(object, ...)
+}
+\arguments{
+ \item{object}{an R object from which RNG settings can be
+ extracted, e.g. an integer vector containing a suitable
+ value for \code{.Random.seed} or embedded RNG data, e.g.,
+ in S3/S4 slot \code{rng} or \code{rng$noise}.}
+
+ \item{...}{extra arguments to allow extension and passed
+ to a suitable S4 method \code{.getRNG} or
+ \code{.setRNG}.}
+}
+\description{
+ The \code{\link{nmf}} function returns objects that
+ contain embedded RNG data, that can be used to exactly
+ reproduce any computation. These data can be extracted
+ using dedicated methods for the S4 generics
+ \code{\link[rngtools]{getRNG}} and
+ \code{\link[rngtools]{getRNG1}}.
+}
+\section{Methods}{
+ \describe{
+
+ \item{.getRNG}{\code{signature(object = "NMFfitXn")}:
+ Returns the RNG settings used for the best fit.
+
+ This method throws an error if the object is empty. }
+
+ \item{getRNG1}{\code{signature(object = "NMFfitX")}:
+ Returns the RNG settings used for the first NMF run of
+ multiple NMF runs. }
+
+ \item{getRNG1}{\code{signature(object = "NMFfitX1")}:
+ Returns the RNG settings used to compute the first of all
+ NMF runs, amongst which \code{object} was selected as the
+ best fit. }
+
+ \item{getRNG1}{\code{signature(object = "NMFfitXn")}:
+ Returns the RNG settings used for the first run.
+
+ This method throws an error if the object is empty. }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# For multiple NMF runs, the RNG settings used for the first run is also stored
+V <- rmatrix(20,10)
+res <- nmf(V, 3, nrun=4)
+# RNG used for the best fit
+getRNG(res)
+# RNG used for the first of all fits
+getRNG1(res)
+# they may differ if the best fit is not the first one
+rng.equal(res, getRNG1(res))
+}
+\keyword{methods}
+
diff --git a/man/SNMF-nmf.Rd b/man/SNMF-nmf.Rd
new file mode 100644
index 0000000..ca3cdaa
--- /dev/null
+++ b/man/SNMF-nmf.Rd
@@ -0,0 +1,80 @@
+\name{nmfAlgorithm.SNMF_R}
+\alias{nmfAlgorithm.SNMF_L}
+\alias{nmfAlgorithm.SNMF_R}
+\alias{SNMF/L-nmf}
+\alias{SNMF/R-nmf}
+\title{NMF Algorithm - Sparse NMF via Alternating NNLS}
+\usage{
+ nmfAlgorithm.SNMF_R(..., maxIter = 20000L, eta = -1,
+ beta = 0.01, bi_conv = c(0, 10), eps_conv = 1e-04)
+
+ nmfAlgorithm.SNMF_L(..., maxIter = 20000L, eta = -1,
+ beta = 0.01, bi_conv = c(0, 10), eps_conv = 1e-04)
+}
+\arguments{
+ \item{maxIter}{maximum number of iterations.}
+
+ \item{eta}{parameter to suppress/bound the L2-norm of
+ \code{W} and in \code{H} in \sQuote{SNMF/R} and
+ \sQuote{SNMF/L} respectively.
+
+ If \code{eta < 0}, then it is set to the maximum value in
+ the target matrix is used.}
+
+ \item{beta}{regularisation parameter for sparsity
+ control, which balances the trade-off between the
+ accuracy of the approximation and the sparseness of
+ \code{H} and \code{W} in \sQuote{SNMF/R} and
+ \sQuote{SNMF/L} respectively.
+
+ Larger beta generates higher sparseness on \code{H}
+ (resp. \code{W}). Too large beta is not recommended.}
+
+ \item{bi_conv}{parameter of the biclustering convergence
+ test. It must be a size 2 numeric vector
+ \code{bi_conv=c(wminchange, iconv)}, with: \describe{
+ \item{\code{wminchange}:}{the minimal allowance of change
+ in row-clusters.} \item{\code{iconv}:}{ decide
+ convergence if row-clusters (within the allowance of
+ \code{wminchange}) and column-clusters have not changed
+ for \code{iconv} convergence checks.} }
+
+ Convergence checks are performed every 5 iterations.}
+
+ \item{eps_conv}{threshold for the KKT convergence test.}
+
+ \item{...}{extra argument not used.}
+}
+\description{
+ NMF algorithms proposed by \cite{Kim et al. (2007)} that
+ enforces sparsity constraint on the basis matrix
+ (algorithm \sQuote{SNMF/L}) or the mixture coefficient
+ matrix (algorithm \sQuote{SNMF/R}).
+}
+\details{
+ The algorithm \sQuote{SNMF/R} solves the following NMF
+ optimization problem on a given target matrix \eqn{A} of
+ dimension \eqn{n \times p}{n x p}: \deqn{
+ \begin{array}{ll} & \min_{W,H} \frac{1}{2} \left(|| A -
+ WH ||_F^2 + \eta ||W||_F^2 + \beta (\sum_{j=1}^p
+ ||H_{.j}||_1^2)\right)\\ s.t. & W\geq 0, H\geq 0
+ \end{array} }{ min_{W,H} 1/2 (|| A - WH ||_F^2 + eta
+ ||W||_F^2 + beta (sum_j ||H[,j]||_1^2))
+
+ s.t. W>=0, H>=0 }
+
+ The algorithm \sQuote{SNMF/L} solves a similar problem on
+ the transposed target matrix \eqn{A}, where \eqn{H} and
+ \eqn{W} swap roles, i.e. with sparsity constraints
+ applied to \code{W}.
+}
+\references{
+ Kim H and Park H (2007). "Sparse non-negative matrix
+ factorizations via alternating non-negativity-constrained
+ least squares for microarray data analysis."
+ _Bioinformatics (Oxford, England)_, *23*(12), pp.
+ 1495-502. ISSN 1460-2059, <URL:
+ http://dx.doi.org/10.1093/bioinformatics/btm134>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/17483501>.
+}
+
diff --git a/man/Strategy-class.Rd b/man/Strategy-class.Rd
new file mode 100644
index 0000000..e0cd1c6
--- /dev/null
+++ b/man/Strategy-class.Rd
@@ -0,0 +1,73 @@
+\docType{class}
+\name{Strategy-class}
+\alias{name}
+\alias{name<-}
+\alias{name<--methods}
+\alias{name-methods}
+\alias{name<-,Strategy,character-method}
+\alias{name,Strategy-method}
+\alias{Strategy-class}
+\title{Generic Strategy Class}
+\usage{
+ name(object, ...)
+
+ \S4method{name}{Strategy}(object, all = FALSE)
+
+ name(object, ...)<-value
+}
+\arguments{
+ \item{object}{an R object with a defined \code{name}
+ method}
+
+ \item{...}{extra arguments to allow extension}
+
+ \item{value}{replacement value}
+
+ \item{all}{a logical that indicates if all the names
+ associated with a strategy should be returned
+ (\code{TRUE}), or only the first (primary) one
+ (\code{FALSE}).}
+}
+\description{
+ This class defines a common interface for generic
+ algorithm strategies (e.g.,
+ \code{\linkS4class{NMFStrategy}}).
+
+ \code{name} and \code{name<-} gets and sets the name
+ associated with an object. In the case of \code{Strategy}
+ objects it is the the name of the algorithm.
+}
+\section{Slots}{
+ \describe{
+
+ \item{name}{character string giving the name of the
+ algorithm}
+
+ \item{package}{name of the package that defined the
+ strategy.}
+
+ \item{defaults}{default values for some of the
+ algorithm's arguments.}
+
+ }
+}
+\section{Methods}{
+ \describe{
+
+ \item{name}{\code{signature(object = "Strategy")}:
+ Returns the name of an algorithm }
+
+ \item{name}{\code{signature(object = "Strategy")}:
+ Returns the name of an algorithm }
+
+ \item{name<-}{\code{signature(object = "Strategy", value
+ = "character")}: Sets the name(s) of an NMF algorithm }
+
+ \item{name<-}{\code{signature(object = "Strategy", value
+ = "character")}: Sets the name(s) of an NMF algorithm }
+
+ }
+}
+\keyword{internal}
+\keyword{methods}
+
diff --git a/man/advanced.Rd b/man/advanced.Rd
new file mode 100644
index 0000000..ac48f46
--- /dev/null
+++ b/man/advanced.Rd
@@ -0,0 +1,25 @@
+\name{advanced-NMF}
+\alias{advanced-NMF}
+\alias{which.best}
+\title{Advanced Usage of the Package NMF}
+\usage{
+ which.best(object, FUN = deviance, ...)
+}
+\arguments{
+ \item{object}{an NMF model fitted by multiple runs.}
+
+ \item{FUN}{the function that computes the quantitative
+ measure.}
+
+ \item{...}{extra arguments passed to \code{FUN}.}
+}
+\description{
+ The functions documented here provide advanced
+ functionalities useful when developing within the
+ framework implemented in the NMF package.
+
+ \code{which.best} returns the index of the best fit in a
+ list of NMF fit, according to some quantitative measure.
+ The index of the fit with the lowest measure is returned.
+}
+
diff --git a/man/aheatmap.Rd b/man/aheatmap.Rd
new file mode 100644
index 0000000..988b720
--- /dev/null
+++ b/man/aheatmap.Rd
@@ -0,0 +1,373 @@
+\name{aheatmap}
+\alias{aheatmap}
+\title{Annotated Heatmaps}
+\usage{
+ aheatmap(x, color = "-RdYlBu2:100", breaks = NA,
+ border_color = NA, cellwidth = NA, cellheight = NA,
+ scale = "none", Rowv = TRUE, Colv = TRUE,
+ revC = identical(Colv, "Rowv") || is_NA(Rowv) || (is.integer(Rowv) &&
+ length(Rowv) > 1) || is(Rowv, "silhouette"),
+ distfun = "euclidean", hclustfun = "complete",
+ reorderfun = function(d, w) reorder(d, w),
+ treeheight = 50, legend = TRUE, annCol = NA,
+ annRow = NA, annColors = NA, annLegend = TRUE,
+ labRow = NULL, labCol = NULL, subsetRow = NULL,
+ subsetCol = NULL, txt = NULL, fontsize = 10,
+ cexRow = min(0.2 + 1/log10(nr), 1.2),
+ cexCol = min(0.2 + 1/log10(nc), 1.2), filename = NA,
+ width = NA, height = NA, main = NULL, sub = NULL,
+ info = NULL, verbose = getOption("verbose"),
+ gp = gpar())
+}
+\arguments{
+ \item{x}{numeric matrix of the values to be plotted. An
+ \code{\link[Biobase:ExpressionSet-class]{ExpressionSet}}
+ objects can also be passed, in which case the expression
+ values are plotted (\code{exprs(x)}).}
+
+ \item{color}{colour specification for the heatmap.
+ Default to palette '-RdYlBu2:100', i.e. reversed palette
+ 'RdYlBu2' (a slight modification of RColorBrewer's
+ palette 'RdYlBu') with 100 colors. Possible values are:
+ \itemize{ \item a character/integer vector of length
+ greater than 1 that is directly used and assumed to
+ contain valid R color specifications. \item a single
+ color/integer (between 0 and 8)/other numeric value that
+ gives the dominant colors. Numeric values are converted
+ into a pallete by \code{rev(sequential_hcl(2, h = x, l =
+ c(50, 95)))}. Other values are concatenated with the grey
+ colour '#F1F1F1'. \item one of RColorBrewer's palette
+ name (see \code{\link[RColorBrewer]{display.brewer.all}})
+ , or one of 'RdYlBu2', 'rainbow', 'heat', 'topo',
+ 'terrain', 'cm'. } When the coluor palette is specified
+ with a single value, and is negative or preceded a minus
+ ('-'), the reversed palette is used. The number of breaks
+ can also be specified after a colon (':'). For example,
+ the default colour palette is specified as
+ '-RdYlBu2:100'.}
+
+ \item{breaks}{a sequence of numbers that covers the range
+ of values in \code{x} and is one element longer than
+ color vector. Used for mapping values to colors. Useful,
+ if needed to map certain values to certain colors. If
+ value is NA then the breaks are calculated automatically.
+ If \code{breaks} is a single value, then the colour
+ palette is centered on this value.}
+
+ \item{border_color}{color of cell borders on heatmap, use
+ NA if no border should be drawn.}
+
+ \item{cellwidth}{individual cell width in points. If left
+ as NA, then the values depend on the size of plotting
+ window.}
+
+ \item{cellheight}{individual cell height in points. If
+ left as NA, then the values depend on the size of
+ plotting window.}
+
+ \item{scale}{character indicating how the values should
+ scaled in either the row direction or the column
+ direction. Note that the scaling is performed after
+ row/column clustering, so that it has no effect on the
+ row/column ordering. Possible values are: \itemize{ \item
+ \code{"row"}: center and standardize each row separately
+ to row Z-scores \item \code{"column"}: center and
+ standardize each column separately to column Z-scores
+ \item \code{"r1"}: scale each row to sum up to one \item
+ \code{"c1"}: scale each column to sum up to one \item
+ \code{"none"}: no scaling }}
+
+ \item{Rowv}{clustering specification(s) for the rows. It
+ allows to specify the
+ distance/clustering/ordering/display parameters to be
+ used for the \emph{rows only}. Possible values are:
+ \itemize{ \item \code{TRUE} or \code{NULL} (to be
+ consistent with \code{\link{heatmap}}): compute a
+ dendrogram from hierarchical clustering using the
+ distance and clustering methods \code{distfun} and
+ \code{hclustfun}.
+
+ \item \code{NA}: disable any ordering. In this case, and
+ if not otherwise specified with argument
+ \code{revC=FALSE}, the heatmap shows the input matrix
+ with the rows in their original order, with the first row
+ on top to the last row at the bottom. Note that this
+ differ from the behaviour or \code{\link{heatmap}}, but
+ seemed to be a more sensible choice when vizualizing a
+ matrix without reordering.
+
+ \item an integer vector of length the number of rows of
+ the input matrix (\code{nrow(x)}), that specifies the row
+ order. As in the case \code{Rowv=NA}, the ordered matrix
+ is shown first row on top, last row at the bottom.
+
+ \item a character vector or a list specifying values to
+ use instead of arguments \code{distfun}, \code{hclustfun}
+ and \code{reorderfun} when clustering the rows (see the
+ respective argument descriptions for a list of accepted
+ values). If \code{Rowv} has no names, then the first
+ element is used for \code{distfun}, the second (if
+ present) is used for \code{hclustfun}, and the third (if
+ present) is used for \code{reorderfun}.
+
+ \item a numeric vector of weights, of length the number
+ of rows of the input matrix, used to reorder the
+ internally computed dendrogram \code{d} by
+ \code{reorderfun(d, Rowv)}.
+
+ \item \code{FALSE}: the dendrogram \emph{is} computed
+ using methods \code{distfun}, \code{hclustfun}, and
+ \code{reorderfun} but is not shown.
+
+ \item a single integer that specifies how many subtrees
+ (i.e. clusters) from the computed dendrogram should have
+ their root faded out. This can be used to better
+ highlight the different clusters.
+
+ \item a single double that specifies how much space is
+ used by the computed dendrogram. That is that this value
+ is used in place of \code{treeheight}. }}
+
+ \item{Colv}{clustering specification(s) for the columns.
+ It accepts the same values as argument \code{Rowv}
+ (modulo the expected length for vector specifications),
+ and allow specifying the
+ distance/clustering/ordering/display parameters to be
+ used for the \emph{columns only}. \code{Colv} may also be
+ set to \code{"Rowv"}, in which case the dendrogram or
+ ordering specifications applied to the rows are also
+ applied to the columns. Note that this is allowed only
+ for square input matrices, and that the row ordering is
+ in this case by default reversed (\code{revC=TRUE}) to
+ obtain the diagonal in the standard way (from top-left to
+ bottom-right). See argument \code{Rowv} for other
+ possible values.}
+
+ \item{revC}{a logical that specify if the \emph{row
+ order} defined by \code{Rowv} should be reversed. This is
+ mainly used to get the rows displayed from top to bottom,
+ which is not the case by default. Its default value is
+ computed at runtime, to suit common situations where
+ natural ordering is a more sensible choice: no or fix
+ ordering of the rows (\code{Rowv=NA} or an integer vector
+ of indexes -- of length > 1), and when a symmetric
+ ordering is requested -- so that the diagonal is shown as
+ expected. An argument in favor of the "odd" default
+ display (bottom to top) is that the row dendrogram is
+ plotted from bottom to top, and reversing its reorder may
+ take a not too long but non negligeable time.}
+
+ \item{distfun}{default distance measure used in
+ clustering rows and columns. Possible values are:
+ \itemize{ \item all the distance methods supported by
+ \code{\link{dist}} (e.g. "euclidean" or "maximum").
+
+ \item all correlation methods supported by
+ \code{\link{cor}}, such as \code{"pearson"} or
+ \code{"spearman"}. The pairwise distances between
+ rows/columns are then computed as \code{d <- dist(1 -
+ cor(..., method = distfun))}.
+
+ One may as well use the string "correlation" which is an
+ alias for "pearson".
+
+ \item an object of class \code{dist} such as returned by
+ \code{\link{dist}} or \code{\link{as.dist}}. }}
+
+ \item{hclustfun}{default clustering method used to
+ cluster rows and columns. Possible values are: \itemize{
+ \item a method name (a character string) supported by
+ \code{\link{hclust}} (e.g. \code{'average'}). \item an
+ object of class \code{hclust} such as returned by
+ \code{\link{hclust}} \item a dendrogram }}
+
+ \item{reorderfun}{default dendrogram reordering function,
+ used to reorder the dendrogram, when either \code{Rowv}
+ or \code{Colv} is a numeric weight vector, or provides or
+ computes a dendrogram. It must take 2 parameters: a
+ dendrogram, and a weight vector.}
+
+ \item{subsetRow}{Specification of subsetting the rows
+ before drawing the heatmap. Possible values are:
+ \itemize{ \item an integer vector of length > 1
+ specifying the indexes of the rows to keep; \item a
+ character vector of length > 1 specyfing the names of the
+ rows to keep. These are the original rownames, not the
+ names specified in \code{labRow}. \item a logical vector
+ of length > 1, whose elements are recycled if the vector
+ has not as many elements as rows in \code{x}. } Note that
+ in the case \code{Rowv} is a dendrogram or hclust object,
+ it is first converted into an ordering vector, and cannot
+ be displayed -- and a warning is thrown.}
+
+ \item{subsetCol}{Specification of subsetting the columns
+ before drawing the heatmap. It accepts the similar values
+ as \code{subsetRow}. See details above.}
+
+ \item{txt}{character matrix of the same size as \code{x},
+ that contains text to display in each cell. \code{NA}
+ values are allowed and are not displayed. See demo for an
+ example.}
+
+ \item{treeheight}{how much space (in points) should be
+ used to display dendrograms. If specified as a single
+ value, it is used for both dendrograms. A length-2 vector
+ specifies separate values for the row and column
+ dendrogram respectively. Default value: 50 points.}
+
+ \item{legend}{boolean value that determines if a colour
+ ramp for the heatmap's colour palette should be drawn or
+ not. Default is \code{TRUE}.}
+
+ \item{annCol}{specifications of column annotation tracks
+ displayed as coloured rows on top of the heatmaps. The
+ annotation tracks are drawn from bottom to top. A single
+ annotation track can be specified as a single vector;
+ multiple tracks are specified as a list, a data frame, or
+ an
+ \code{\link[Biobase:ExpressionSet-class]{ExpressionSet}}
+ object, in which case the phenotypic data is used
+ (\code{pData(eset)}). Character or integer vectors are
+ converted and displayed as factors. Unnamed tracks are
+ internally renamed into \code{Xi}, with i being
+ incremented for each unamed track, across both column and
+ row annotation tracks. For each track, if no
+ corresponding colour is specified in argument
+ \code{annColors}, a palette or a ramp is automatically
+ computed and named after the track's name.}
+
+ \item{annRow}{specifications of row annotation tracks
+ displayed as coloured columns on the left of the
+ heatmaps. The annotation tracks are drawn from left to
+ right. The same conversion, renaming and colouring rules
+ as for argument \code{annCol} apply.}
+
+ \item{annColors}{list for specifying annotation track
+ colors manually. It is possible to define the colors for
+ only some of the annotations. Check examples for
+ details.}
+
+ \item{annLegend}{boolean value specifying if the legend
+ for the annotation tracks should be drawn or not. Default
+ is \code{TRUE}.}
+
+ \item{labRow}{labels for the rows.}
+
+ \item{labCol}{labels for the columns. See description for
+ argument \code{labRow} for a list of the possible
+ values.}
+
+ \item{fontsize}{base fontsize for the plot}
+
+ \item{cexRow}{fontsize for the rownames, specified as a
+ fraction of argument \code{fontsize}.}
+
+ \item{cexCol}{fontsize for the colnames, specified as a
+ fraction of argument \code{fontsize}.}
+
+ \item{main}{Main title as a character string or a grob.}
+
+ \item{sub}{Subtitle as a character string or a grob.}
+
+ \item{info}{(experimental) Extra information as a
+ character vector or a grob. If \code{info=TRUE},
+ information about the clustering methods is displayed at
+ the bottom of the plot.}
+
+ \item{filename}{file path ending where to save the
+ picture. Currently following formats are supported: png,
+ pdf, tiff, bmp, jpeg. Even if the plot does not fit into
+ the plotting window, the file size is calculated so that
+ the plot would fit there, unless specified otherwise.}
+
+ \item{width}{manual option for determining the output
+ file width in}
+
+ \item{height}{manual option for determining the output
+ file height in inches.}
+
+ \item{verbose}{if \code{TRUE} then verbose messages are
+ displayed and the borders of some viewports are
+ highlighted. It is entended for debugging purposes.}
+
+ \item{gp}{graphical parameters for the text used in plot.
+ Parameters passed to \code{\link{grid.text}}, see
+ \code{\link{gpar}}.}
+}
+\description{
+ The function \code{aheatmap} plots high-quality heatmaps,
+ with a detailed legend and unlimited annotation tracks
+ for both columns and rows. The annotations are coloured
+ differently according to their type (factor or numeric
+ covariate). Although it uses grid graphics, the generated
+ plot is compatible with base layouts such as the ones
+ defined with \code{'mfrow'} or \code{\link{layout}},
+ enabling the easy drawing of multiple heatmaps on a
+ single a plot -- at last!.
+}
+\details{
+ The development of this function started as a fork of the
+ function \code{pheatmap} from the \pkg{pheatmap} package,
+ and provides several enhancements such as: \itemize{
+ \item argument names match those used in the base
+ function \code{\link{heatmap}}; \item unlimited number of
+ annotation for \strong{both} columns and rows, with
+ simplified and more flexible interface; \item easy
+ specification of clustering methods and colors; \item
+ return clustering data, as well as grid grob object. }
+
+ Please read the associated vignette for more information
+ and sample code.
+}
+\section{PDF graphic devices}{
+ if plotting on a PDF graphic device -- started with
+ \code{\link{pdf}}, one may get generate a first blank
+ page, due to internals of standard functions from the
+ \pkg{grid} package that are called by \code{aheatmap}.
+ The \pkg{NMF} package ships a custom patch that fixes
+ this issue. However, in order to comply with CRAN
+ policies, the patch is \strong{not} applied by default
+ and the user must explicitly be enabled it. This can be
+ achieved on runtime by either setting the NMF specific
+ option 'grid.patch' via
+ \code{nmf.options(grid.patch=TRUE)}, or on load time if
+ the environment variable 'R_PACKAGE_NMF_GRID_PATCH' is
+ defined and its value is something that is not equivalent
+ to \code{FALSE} (i.e. not '', 'false' nor 0).
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+## See the demo 'aheatmap' for more examples:
+\dontrun{
+demo('aheatmap')
+}
+
+# Generate random data
+n <- 50; p <- 20
+x <- abs(rmatrix(n, p, rnorm, mean=4, sd=1))
+x[1:10, seq(1, 10, 2)] <- x[1:10, seq(1, 10, 2)] + 3
+x[11:20, seq(2, 10, 2)] <- x[11:20, seq(2, 10, 2)] + 2
+rownames(x) <- paste("ROW", 1:n)
+colnames(x) <- paste("COL", 1:p)
+
+## Default heatmap
+aheatmap(x)
+
+## Distance methods
+aheatmap(x, Rowv = "correlation")
+aheatmap(x, Rowv = "man") # partially matched to 'manhattan'
+aheatmap(x, Rowv = "man", Colv="binary")
+
+# Generate column annotations
+annotation = data.frame(Var1 = factor(1:p \%\% 2 == 0, labels = c("Class1", "Class2")), Var2 = 1:10)
+aheatmap(x, annCol = annotation)
+}
+\author{
+ Original version of \code{pheatmap}: Raivo Kolde
+
+ Enhancement into \code{aheatmap}: Renaud Gaujoux
+}
+
diff --git a/man/algorithm-commaNMFList-method.Rd b/man/algorithm-commaNMFList-method.Rd
new file mode 100644
index 0000000..94a0e95
--- /dev/null
+++ b/man/algorithm-commaNMFList-method.Rd
@@ -0,0 +1,27 @@
+\docType{methods}
+\name{algorithm,NMFList-method}
+\alias{algorithm,NMFList-method}
+\title{Returns the method names used to compute the NMF fits in the list.
+It returns \code{NULL} if the list is empty.}
+\usage{
+ \S4method{algorithm}{NMFList}(object, string = FALSE,
+ unique = TRUE)
+}
+\arguments{
+ \item{string}{a logical that indicate whether the names
+ should be collapsed into a comma-separated string.}
+
+ \item{unique}{a logical that indicates whether the result
+ should contain the set of method names, removing
+ duplicated names. This argument is forced to \code{TRUE}
+ when \code{string=TRUE}.}
+
+ \item{object}{an object computed using some algorithm, or
+ that describes an algorithm itself.}
+}
+\description{
+ Returns the method names used to compute the NMF fits in
+ the list. It returns \code{NULL} if the list is empty.
+}
+\keyword{methods}
+
diff --git a/man/algorithm-commaNMFStrategyOctave-method.Rd b/man/algorithm-commaNMFStrategyOctave-method.Rd
new file mode 100644
index 0000000..f852257
--- /dev/null
+++ b/man/algorithm-commaNMFStrategyOctave-method.Rd
@@ -0,0 +1,23 @@
+\docType{methods}
+\name{algorithm,NMFStrategyOctave-method}
+\alias{algorithm,NMFStrategyOctave-method}
+\title{Returns the name of the Octave/Matlab function that implements the NMF algorithm -- as stored in
+slot \code{algorithm}.}
+\usage{
+ \S4method{algorithm}{NMFStrategyOctave}(object,
+ load = FALSE)
+}
+\arguments{
+ \item{load}{logical that indicates if the algorithm
+ should be loaded as an R function.}
+
+ \item{object}{an object computed using some algorithm, or
+ that describes an algorithm itself.}
+}
+\description{
+ Returns the name of the Octave/Matlab function that
+ implements the NMF algorithm -- as stored in slot
+ \code{algorithm}.
+}
+\keyword{methods}
+
diff --git a/man/algorithmic.Rd b/man/algorithmic.Rd
new file mode 100644
index 0000000..26a6b9a
--- /dev/null
+++ b/man/algorithmic.Rd
@@ -0,0 +1,428 @@
+\docType{methods}
+\name{algorithmic-NMF}
+\alias{algorithm}
+\alias{algorithm<-}
+\alias{algorithmic-NMF}
+\alias{algorithm<--methods}
+\alias{algorithm-methods}
+\alias{algorithm<-,NMFfit,ANY-method}
+\alias{algorithm,NMFfit-method}
+\alias{algorithm,NMFfitXn-method}
+\alias{algorithm<-,NMFSeed,function-method}
+\alias{algorithm,NMFSeed-method}
+\alias{algorithm<-,NMFStrategyFunction,function-method}
+\alias{algorithm,NMFStrategyFunction-method}
+\alias{algorithm<-,NMFStrategyOctave,character-method}
+\alias{compare}
+\alias{compare-methods}
+\alias{compare,NMFfitXn-method}
+\alias{logs}
+\alias{logs,ANY-method}
+\alias{logs-methods}
+\alias{modelname}
+\alias{modelname,ANY-method}
+\alias{modelname-methods}
+\alias{modelname,NMFfit-method}
+\alias{modelname,NMFfitXn-method}
+\alias{modelname,NMFStrategy-method}
+\alias{niter}
+\alias{niter<-}
+\alias{niter<--methods}
+\alias{niter-methods}
+\alias{niter,NMFfit-method}
+\alias{niter<-,NMFfit,numeric-method}
+\alias{nrun}
+\alias{nrun,ANY-method}
+\alias{nrun-methods}
+\alias{nrun,NMFfit-method}
+\alias{nrun,NMFfitX1-method}
+\alias{nrun,NMFfitX-method}
+\alias{nrun,NMFfitXn-method}
+\alias{objective}
+\alias{objective<-}
+\alias{objective<--methods}
+\alias{objective-methods}
+\alias{objective<-,NMFfit,ANY-method}
+\alias{run}
+\alias{run-methods}
+\alias{runtime}
+\alias{runtime.all}
+\alias{runtime.all-methods}
+\alias{runtime.all,NMFfit-method}
+\alias{runtime.all,NMFfitX-method}
+\alias{runtime-methods}
+\alias{runtime,NMFfit-method}
+\alias{seeding}
+\alias{seeding<-}
+\alias{seeding<--methods}
+\alias{seeding-methods}
+\alias{seeding<-,NMFfit-method}
+\alias{seeding,NMFfit-method}
+\alias{seeding,NMFfitXn-method}
+\alias{seqtime}
+\alias{seqtime-methods}
+\alias{seqtime,NMFfitXn-method}
+\alias{seqtime,NMFList-method}
+\title{Generic Interface for Algorithms}
+\usage{
+ algorithm(object, ...)
+
+ algorithm(object, ...)<-value
+
+ seeding(object, ...)
+
+ seeding(object, ...)<-value
+
+ niter(object, ...)
+
+ niter(object, ...)<-value
+
+ nrun(object, ...)
+
+ objective(object, ...)
+
+ objective(object, ...)<-value
+
+ runtime(object, ...)
+
+ runtime.all(object, ...)
+
+ seqtime(object, ...)
+
+ modelname(object, ...)
+
+ run(object, y, x, ...)
+
+ logs(object, ...)
+
+ compare(object, ...)
+}
+\arguments{
+ \item{object}{an object computed using some algorithm, or
+ that describes an algorithm itself.}
+
+ \item{value}{replacement value}
+
+ \item{...}{extra arguments to allow extension}
+
+ \item{y}{data object, e.g. a target matrix}
+
+ \item{x}{a model object used as a starting point by the
+ algorithm, e.g. a non-empty NMF model.}
+}
+\description{
+ The functions documented here are S4 generics that define
+ an general interface for -- optimisation -- algorithms.
+
+ This interface builds upon the broad definition of an
+ algorithm as a workhorse function to which is associated
+ auxiliary objects such as an underlying model or an
+ objective function that measures the adequation of the
+ model with observed data. It aims at complementing the
+ interface provided by the \code{\link{stats}} package.
+}
+\details{
+ \code{algorithm} and \code{algorithm<-} get/set an object
+ that describes the algorithm used to compute another
+ object, or with which it is associated. It may be a
+ simple character string that gives the algorithm's names,
+ or an object that includes the algorithm's definition
+ itself (e.g. an \code{\link{NMFStrategy}} object).
+
+ \code{seeding} get/set the seeding method used to
+ initialise the computation of an object, i.e. usually the
+ function that sets the starting point of an algorithm.
+
+ \code{niter} and \code{niter<-} get/set the number of
+ iterations performed to compute an object. The function
+ \code{niter<-} would usually be called just before
+ returning the result of an algorithm, when putting
+ together data about the fit.
+
+ \code{nrun} returns the number of times the algorithm has
+ been run to compute an object. Usually this will be 1,
+ but may be be more if the algorithm involves multiple
+ starting points.
+
+ \code{objective} and \code{objective<-} get/set the
+ objective function associated with an object. Some
+ methods for \code{objective} may also compute the
+ objective value with respect to some target/observed
+ data.
+
+ \code{runtime} returns the CPU time required to compute
+ an object. This would generally be an object of class
+ \code{\link[=proc.time]{proc_time}}.
+
+ \code{runtime.all} returns the CPU time required to
+ compute a collection of objects, e.g. a sequence of
+ independent fits.
+
+ \code{seqtime} returns the sequential CPU time -- that
+ would be -- required to compute a collection of objects.
+ It would differ from \code{runtime.all} if the
+ computations were performed in parallel.
+
+ \code{modelname} returns a the type of model associated
+ with an object.
+
+ \code{run} calls the workhorse function that actually
+ implements a strategy/algorithm, and run it on some data
+ object.
+
+ \code{logs} returns the log messages output during the
+ computation of an object.
+
+ \code{compare} compares objects obtained from running
+ separate algorithms.
+}
+\section{Methods}{
+ \describe{
+
+ \item{algorithm}{\code{signature(object = "NMFfit")}:
+ Returns the name of the algorithm that fitted the NMF
+ model \code{object}. }
+
+ \item{algorithm}{\code{signature(object = "NMFList")}:
+ Returns the method names used to compute the NMF fits in
+ the list. It returns \code{NULL} if the list is empty.
+
+ See \code{\link{algorithm,NMFList-method}} for more
+ details. }
+
+ \item{algorithm}{\code{signature(object = "NMFfitXn")}:
+ Returns the name of the common NMF algorithm used to
+ compute all fits stored in \code{object}
+
+ Since all fits are computed with the same algorithm, this
+ method returns the name of algorithm that computed the
+ first fit. It returns \code{NULL} if the object is empty.
+ }
+
+ \item{algorithm}{\code{signature(object = "NMFSeed")}:
+ Returns the workhorse function of the seeding method
+ described by \code{object}. }
+
+ \item{algorithm}{\code{signature(object =
+ "NMFStrategyFunction")}: Returns the single R function
+ that implements the NMF algorithm -- as stored in slot
+ \code{algorithm}. }
+
+ \item{algorithm}{\code{signature(object =
+ "NMFStrategyOctave")}: Returns the name of the
+ Octave/Matlab function that implements the NMF algorithm
+ -- as stored in slot \code{algorithm}.
+
+ See \code{\link{algorithm,NMFStrategyOctave-method}} for
+ more details. }
+
+ \item{algorithm<-}{\code{signature(object = "NMFSeed",
+ value = "function")}: Sets the workhorse function of the
+ seeding method described by \code{object}. }
+
+ \item{algorithm<-}{\code{signature(object =
+ "NMFStrategyFunction", value = "function")}: Sets the
+ function that implements the NMF algorithm, stored in
+ slot \code{algorithm}. }
+
+ \item{algorithm<-}{\code{signature(object =
+ "NMFStrategyOctave", value = "character")}: Sets the name
+ of the Octave/Matlab function that implements the NMF
+ algorithm. It is stored in slot \code{algorithm}. }
+
+ \item{compare}{\code{signature(object = "NMFfitXn")}:
+ Compares the fits obtained by separate runs of NMF, in a
+ single call to \code{\link{nmf}}. }
+
+ \item{logs}{\code{signature(object = "ANY")}: Default
+ method that returns the value of attribute/slot
+ \code{'logs'} or, if this latter does not exists, the
+ value of element \code{'logs'} if \code{object} is a
+ \code{list}. It returns \code{NULL} if no logging data
+ was found. }
+
+ \item{modelname}{\code{signature(object = "ANY")}:
+ Default method which returns the class name(s) of
+ \code{object}. This should work for objects representing
+ models on their own.
+
+ For NMF objects, this is the type of NMF model, that
+ corresponds to the name of the S4 sub-class of
+ \code{\linkS4class{NMF}}, inherited by \code{object}. }
+
+ \item{modelname}{\code{signature(object = "NMFfit")}:
+ Returns the type of a fitted NMF model. It is a shortcut
+ for \code{modelname(fit(object)}. }
+
+ \item{modelname}{\code{signature(object = "NMFfitXn")}:
+ Returns the common type NMF model of all fits stored in
+ \code{object}
+
+ Since all fits are from the same NMF model, this method
+ returns the model type of the first fit. It returns
+ \code{NULL} if the object is empty. }
+
+ \item{modelname}{\code{signature(object =
+ "NMFStrategy")}: Returns the model(s) that an NMF
+ algorithm can fit. }
+
+ \item{niter}{\code{signature(object = "NMFfit")}: Returns
+ the number of iteration performed to fit an NMF model,
+ typically with function \code{\link{nmf}}.
+
+ Currently this data is stored in slot \code{'extra'}, but
+ this might change in the future. }
+
+ \item{niter<-}{\code{signature(object = "NMFfit", value =
+ "numeric")}: Sets the number of iteration performed to
+ fit an NMF model.
+
+ This function is used internally by the function
+ \code{\link{nmf}}. It is not meant to be called by the
+ user, except when developing new NMF algorithms
+ implemented as single function, to set the number of
+ iterations performed by the algorithm on the seed, before
+ returning it (see
+ \code{\linkS4class{NMFStrategyFunction}}). }
+
+ \item{nrun}{\code{signature(object = "ANY")}: Default
+ method that returns the value of attribute \sQuote{nrun}.
+
+ Such an attribute my be attached to objects to keep track
+ of data about the parent fit object (e.g. by method
+ \code{\link{consensus}}), which can be used by subsequent
+ function calls such as plot functions (e.g. see
+ \code{\link{consensusmap}}). This method returns
+ \code{NULL} if no suitable data was found. }
+
+ \item{nrun}{\code{signature(object = "NMFfitX")}: Returns
+ the number of NMF runs performed to create \code{object}.
+
+ It is a pure virtual method defined to ensure \code{nrun}
+ is defined for sub-classes of \code{NMFfitX}, which
+ throws an error if called.
+
+ Note that because the \code{\link{nmf}} function allows
+ to run the NMF computation keeping only the best fit,
+ \code{nrun} may return a value greater than one, while
+ only the result of the best run is stored in the object
+ (cf. option \code{'k'} in method \code{\link{nmf}}). }
+
+ \item{nrun}{\code{signature(object = "NMFfit")}: This
+ method always returns 1, since an \code{NMFfit} object is
+ obtained from a single NMF run. }
+
+ \item{nrun}{\code{signature(object = "NMFfitX1")}:
+ Returns the number of NMF runs performed, amongst which
+ \code{object} was selected as the best fit. }
+
+ \item{nrun}{\code{signature(object = "NMFfitXn")}:
+ Returns the number of runs performed to compute the fits
+ stored in the list (i.e. the length of the list itself).
+ }
+
+ \item{objective}{\code{signature(object = "NMFfit")}:
+ Returns the objective function associated with the
+ algorithm that computed the fitted NMF model
+ \code{object}, or the objective value with respect to a
+ given target matrix \code{y} if it is supplied.
+
+ See \code{\link{objective,NMFfit-method}} for more
+ details. }
+
+ \item{runtime}{\code{signature(object = "NMFfit")}:
+ Returns the CPU time required to compute a single NMF
+ fit. }
+
+ \item{runtime}{\code{signature(object = "NMFList")}:
+ Returns the CPU time required to compute all NMF fits in
+ the list. It returns \code{NULL} if the list is empty. If
+ no timing data are available, the sequential time is
+ returned.
+
+ See \code{\link{runtime,NMFList-method}} for more
+ details. }
+
+ \item{runtime.all}{\code{signature(object = "NMFfit")}:
+ Identical to \code{runtime}, since their is a single fit.
+ }
+
+ \item{runtime.all}{\code{signature(object = "NMFfitX")}:
+ Returns the CPU time required to compute all the NMF
+ runs. It returns \code{NULL} if no CPU data is available.
+ }
+
+ \item{runtime.all}{\code{signature(object = "NMFfitXn")}:
+ If no time data is available from in slot
+ \sQuote{runtime.all} and argument \code{null=TRUE}, then
+ the sequential time as computed by \code{\link{seqtime}}
+ is returned, and a warning is thrown unless
+ \code{warning=FALSE}.
+
+ See \code{\link{runtime.all,NMFfitXn-method}} for more
+ details. }
+
+ \item{seeding}{\code{signature(object = "NMFfit")}:
+ Returns the name of the seeding method that generated the
+ starting point for the NMF algorithm that fitted the NMF
+ model \code{object}. }
+
+ \item{seeding}{\code{signature(object = "NMFfitXn")}:
+ Returns the name of the common seeding method used the
+ computation of all fits stored in \code{object}
+
+ Since all fits are seeded using the same method, this
+ method returns the name of the seeding method used for
+ the first fit. It returns \code{NULL} if the object is
+ empty. }
+
+ \item{seqtime}{\code{signature(object = "NMFList")}:
+ Returns the CPU time that would be required to
+ sequentially compute all NMF fits stored in
+ \code{object}.
+
+ This method calls the function \code{runtime} on each fit
+ and sum up the results. It returns \code{NULL} on an
+ empty object. }
+
+ \item{seqtime}{\code{signature(object = "NMFfitXn")}:
+ Returns the CPU time that would be required to
+ sequentially compute all NMF fits stored in
+ \code{object}.
+
+ This method calls the function \code{runtime} on each fit
+ and sum up the results. It returns \code{NULL} on an
+ empty object. }
+
+ }
+}
+\section{Interface fo NMF algorithms}{
+ This interface is implemented for NMF algorithms by the
+ classes \code{\link{NMFfit}}, \code{\link{NMFfitX}} and
+ \code{\link{NMFStrategy}}, and their respective
+ sub-classes. The examples given in this documentation
+ page are mainly based on this implementation.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+#----------
+# modelname,ANY-method
+#----------
+# get the type of an NMF model
+modelname(nmfModel(3))
+modelname(nmfModel(3, model='NMFns'))
+modelname(nmfModel(3, model='NMFOffset'))
+
+#----------
+# modelname,NMFStrategy-method
+#----------
+# get the type of model(s) associated with an NMF algorithm
+modelname( nmfAlgorithm('brunet') )
+modelname( nmfAlgorithm('nsNMF') )
+modelname( nmfAlgorithm('offset') )
+}
+\keyword{methods}
+
diff --git a/man/assess.Rd b/man/assess.Rd
new file mode 100644
index 0000000..0f36ab3
--- /dev/null
+++ b/man/assess.Rd
@@ -0,0 +1,137 @@
+\docType{methods}
+\name{summary}
+\alias{summary}
+\alias{summary-methods}
+\alias{summary-NMF}
+\alias{summary,NMFfit-method}
+\alias{summary,NMFfitX-method}
+\alias{summary,NMF-method}
+\title{Assessing and Comparing NMF Models}
+\usage{
+ summary(object, ...)
+
+ \S4method{summary}{NMF}(object, class, target)
+}
+\arguments{
+ \item{object}{an NMF object. See available methods in
+ section \emph{Methods}.}
+
+ \item{...}{extra arguments passed to the next
+ \code{summary} method.}
+
+ \item{class}{known classes/cluster of samples specified
+ in one of the formats that is supported by the functions
+ \code{\link{entropy}} and \code{\link{purity}}.}
+
+ \item{target}{target matrix specified in one of the
+ formats supported by the functions \code{\link{rss}} and
+ \code{\link{evar}}}
+}
+\description{
+ The NMF package defines \code{summary} methods for
+ different classes of objects, which helps assessing and
+ comparing the quality of NMF models by computing a set of
+ quantitative measures, e.g. with respect to their ability
+ to recover known classes and/or the original target
+ matrix.
+
+ The most useful methods are for classes
+ \code{\linkS4class{NMF}}, \code{\linkS4class{NMFfit}},
+ \code{\linkS4class{NMFfitX}} and
+ \code{\linkS4class{NMFList}}, which compute summary
+ measures for, respectively, a single NMF model, a single
+ fit, a multiple-run fit and a list of heterogenous fits
+ performed with the function \code{\link{nmf}}.
+}
+\details{
+ Due to the somehow hierarchical structure of the classes
+ mentionned in \emph{Description}, their respective
+ \code{summary} methods call each other in chain, each
+ super-class adding some extra measures, only relevant for
+ objects of a specific class.
+}
+\section{Methods}{
+ \describe{
+
+ \item{summary}{\code{signature(object = "NMF")}: Computes
+ summary measures for a single NMF model.
+
+ The following measures are computed:
+
+ \describe{ \item{sparseness}{Sparseness of the
+ factorization computed by the function
+ \code{\link{sparseness}}.} \item{entropy}{Purity of the
+ clustering, with respect to known classes, computed by
+ the function \code{\link{purity}}.}
+ \item{entropy}{Entropy of the clustering, with respect to
+ known classes, computed by the function
+ \code{\link{entropy}}.} \item{RSS}{Residual Sum of
+ Squares computed by the function \code{\link{rss}}.}
+ \item{evar}{Explained variance computed by the function
+ \code{\link{evar}}.} } }
+
+ \item{summary}{\code{signature(object = "NMFfit")}:
+ Computes summary measures for a single fit from
+ \code{\link{nmf}}.
+
+ This method adds the following measures to the measures
+ computed by the method \code{summary,NMF}:
+
+ \describe{ \item{residuals}{Residual error as measured by
+ the objective function associated to the algorithm used
+ to fit the model.} \item{niter}{Number of iterations
+ performed to achieve convergence of the algorithm.}
+ \item{cpu}{Total CPU time required for the fit.}
+ \item{cpu.all}{Total CPU time required for the fit. For
+ \code{NMFfit} objects, this element is always equal to
+ the value in \dQuote{cpu}, but will be different for
+ multiple-run fits.} \item{nrun}{Number of runs performed
+ to fit the model. This is always equal to 1 for
+ \code{NMFfit} objects, but will vary for multiple-run
+ fits.} } }
+
+ \item{summary}{\code{signature(object = "NMFfitX")}:
+ Computes a set of measures to help evaluate the quality
+ of the \emph{best fit} of the set. The result is similar
+ to the result from the \code{summary} method of
+ \code{NMFfit} objects. See \code{\linkS4class{NMF}} for
+ details on the computed measures. In addition, the
+ cophenetic correlation (\code{\link{cophcor}}) and
+ \code{\link{dispersion}} coefficients of the consensus
+ matrix are returned, as well as the total CPU time
+ (\code{\link{runtime.all}}). }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+#----------
+# summary,NMF-method
+#----------
+# random NMF model
+x <- rnmf(3, 20, 12)
+summary(x)
+summary(x, gl(3, 4))
+summary(x, target=rmatrix(x))
+summary(x, gl(3,4), target=rmatrix(x))
+
+#----------
+# summary,NMFfit-method
+#----------
+# generate a synthetic dataset with known classes: 50 features, 18 samples (5+5+8)
+n <- 50; counts <- c(5, 5, 8);
+V <- syntheticNMF(n, counts)
+cl <- unlist(mapply(rep, 1:3, counts))
+
+# perform default NMF with rank=2
+x2 <- nmf(V, 2)
+summary(x2, cl, V)
+# perform default NMF with rank=2
+x3 <- nmf(V, 3)
+summary(x2, cl, V)
+}
+\keyword{methods}
+
diff --git a/man/atrack.Rd b/man/atrack.Rd
new file mode 100644
index 0000000..26ad660
--- /dev/null
+++ b/man/atrack.Rd
@@ -0,0 +1,144 @@
+\docType{methods}
+\name{.atrack}
+\alias{adata}
+\alias{alength}
+\alias{amargin}
+\alias{anames}
+\alias{annotationTrack}
+\alias{atrack}
+\alias{.atrack}
+\alias{.atrack,ANY-method}
+\alias{.atrack,character-method}
+\alias{.atrack,data.frame-method}
+\alias{.atrack,matrix-method}
+\alias{.atrack-methods}
+\alias{is.atrack}
+\title{Annotation Tracks}
+\usage{
+ .atrack(object, ...)
+
+ is.atrack(x)
+
+ adata(x, value, ...)
+
+ amargin(x, value)
+
+ anames(x, default.margin)
+
+ alength(x, default.margin)
+
+ \S4method{.atrack}{ANY}(object, data = NULL, ...)
+
+ atrack(..., order = NULL, enforceNames = FALSE,
+ .SPECIAL = NA, .DATA = NULL, .CACHE = NULL)
+
+ annotationTrack(x = list())
+}
+\arguments{
+ \item{object}{an object from which is extracted
+ annotation tracks}
+
+ \item{...}{extra arguments to allow extensions and passed
+ to the next method call. For \code{atrack}, arguments in
+ \code{...} are concatenated into a single
+ \code{annotationTrack} object.}
+
+ \item{x}{an R object}
+
+ \item{value}{replacement value for the complete
+ annotation data list}
+
+ \item{default.margin}{margin to use if no margin data is
+ stored in the \code{x}.}
+
+ \item{data}{object used to extend the annotation track
+ within a given data context. It is typically a
+ matrix-like object, against which annotation
+ specifications are matched using
+ \code{\link{match_atrack}}.}
+
+ \item{order}{an integer vector that indicates the order
+ of the annotation tracks in the result list}
+
+ \item{enforceNames}{logical that indicates if missing
+ track names should be generated as \code{X<i>}}
+
+ \item{.SPECIAL}{an optional list of functions (with no
+ arguments) that are called to generate special annotation
+ tracks defined by codes of the form \code{':NAME'}. e.g.,
+ the function \code{link{consensusmap}} defines special
+ tracks \code{':basis'} and \code{':consensus'}.
+
+ If \code{.SPECIAL=FALSE}, then any special tracks is
+ discarded and a warning is thrown.}
+
+ \item{.DATA}{data used to match and extend annotation
+ specifications. It is passed to argument \code{data} of
+ the \code{.atrack} methods, which in turn use pass it to
+ \code{\link{match_atrack}}.}
+
+ \item{.CACHE}{an \code{annotationTrack} object with which
+ the generated annotation track should be consistent. This
+ argument is more for internal/advanced usage and should
+ not be used by the end-user.}
+}
+\value{
+ \code{atrack} returns a list, decorated with class
+ \code{'annotationTrack'}, where each element contains the
+ description of an annotation track.
+}
+\description{
+ \code{.atrack} is an S4 generic method that converts an
+ object into an annotation track object. It provides a
+ general and flexible annotation framework that is used by
+ \code{\link{aheatmap}} to annotates heatmap rows and
+ columns.
+
+ \code{is.atrack} tests if an object is an
+ \code{annotationTrack} object.
+
+ \code{adata} get/sets the annotation parameters on an
+ object
+
+ \code{amargin} get/sets the annotation margin, i.e. along
+ which dimension of the data the annotations are to be
+ considered.
+
+ \code{anames} returns the reference margin names for
+ annotation tracks, from their embedded annotation data
+ object.
+
+ \code{alength} returns the reference length for
+ annotation tracks, from their embedded annotation data
+ object
+
+ \code{atrack} creates/concatenates \code{annotationTrack}
+ objects
+
+ \code{annotationTrack} is constructor function for
+ \code{annotationTrack} object
+}
+\details{
+ Methods for \code{.atrack} exist for common type of
+ objects, which should provide enough options for new
+ methods to define how annotation track are extracted from
+ more complex objects, by coercing/filtering them into a
+ supported type.
+}
+\section{Methods}{
+ \describe{
+
+ \item{.atrack}{\code{signature(object = "ANY")}: The
+ default method converts character or integer vectors into
+ factors. Numeric vectors, factors, a single NA or
+ \code{annotationTrack} objects are returned unchanged
+ (except from reordering by argument \code{order}). Data
+ frames are not changed either, but class
+ 'annotationTrack' is appended to their original class
+ set. }
+
+ }
+}
+\keyword{internal}
+\keyword{methods}
+
diff --git a/man/basis-coef-methods.Rd b/man/basis-coef-methods.Rd
new file mode 100644
index 0000000..d35777e
--- /dev/null
+++ b/man/basis-coef-methods.Rd
@@ -0,0 +1,343 @@
+\docType{methods}
+\name{basis}
+\alias{basis}
+\alias{.basis}
+\alias{.basis<-}
+\alias{basis<-}
+\alias{basis,ANY-method}
+\alias{.basis<--methods}
+\alias{.basis-methods}
+\alias{basis<--methods}
+\alias{basis-methods}
+\alias{.basis<-,NMFfit,matrix-method}
+\alias{.basis,NMFfit-method}
+\alias{basis,NMFfitXn-method}
+\alias{.basis<-,NMF,matrix-method}
+\alias{.basis,NMF-method}
+\alias{basis<-,NMF-method}
+\alias{basis,NMF-method}
+\alias{.basis<-,NMFstd,matrix-method}
+\alias{.basis,NMFstd-method}
+\alias{coef}
+\alias{.coef}
+\alias{.coef<-}
+\alias{coef<-}
+\alias{coefficients}
+\alias{coefficients-methods}
+\alias{coefficients,NMF-method}
+\alias{.coef<--methods}
+\alias{.coef-methods}
+\alias{coef<--methods}
+\alias{coef-methods}
+\alias{.coef<-,NMFfit,matrix-method}
+\alias{.coef,NMFfit-method}
+\alias{coef,NMFfitXn-method}
+\alias{.coef<-,NMF,matrix-method}
+\alias{.coef,NMF-method}
+\alias{coef<-,NMF-method}
+\alias{coef,NMF-method}
+\alias{.coef<-,NMFstd,matrix-method}
+\alias{.coef,NMFstd-method}
+\alias{loadings,NMF-method}
+\alias{scoef}
+\alias{scoef,matrix-method}
+\alias{scoef-methods}
+\alias{scoef,NMF-method}
+\title{Accessing NMF Factors}
+\usage{
+ basis(object, ...)
+
+ \S4method{basis}{NMF}(object, all = TRUE, ...)
+
+ .basis(object, ...)
+
+ basis(object, ...)<-value
+
+ \S4method{basis}{NMF}(object, use.dimnames = TRUE,
+ ...)<-value
+
+ .basis(object)<-value
+
+ \S4method{loadings}{NMF}(x)
+
+ coef(object, ...)
+
+ \S4method{coef}{NMF}(object, all = TRUE, ...)
+
+ .coef(object, ...)
+
+ coef(object, ...)<-value
+
+ \S4method{coef}{NMF}(object, use.dimnames = TRUE,
+ ...)<-value
+
+ .coef(object)<-value
+
+ coefficients(object, ...)
+
+ \S4method{coefficients}{NMF}(object, all = TRUE, ...)
+
+ scoef(object, ...)
+
+ \S4method{scoef}{NMF}(object, scale = 1)
+
+ \S4method{scoef}{matrix}(object, scale = 1)
+}
+\arguments{
+ \item{object}{an object from which to extract the factor
+ matrices, typically an object of class
+ \code{\linkS4class{NMF}}.}
+
+ \item{...}{extra arguments to allow extension and passed
+ to the low-level access functions \code{.coef} and
+ \code{.basis}.
+
+ Note that these throw an error if used in replacement
+ functions \code{}.}
+
+ \item{all}{a logical that indicates whether the complete
+ matrix factor should be returned (\code{TRUE}) or only
+ the non-fixed part. This is relevant only for
+ formula-based NMF models that include fixed basis or
+ coefficient terms.}
+
+ \item{use.dimnames}{logical that indicates if the
+ object's dim names should be set using those from the new
+ value, or left unchanged -- after truncating them to fit
+ new dimensions if necessary. This is useful to only set
+ the entries of a factor.}
+
+ \item{value}{replacement value}
+
+ \item{scale}{scaling factor, which indicates to the value
+ the columns of the coefficient matrix should sum up to.}
+
+ \item{x}{an object of class \code{"\link{factanal}"} or
+ \code{"\link{princomp}"} or the \code{loadings} component
+ of such an object.}
+}
+\description{
+ \code{basis} and \code{basis<-} are S4 generic functions
+ which respectively extract and set the matrix of basis
+ components of an NMF model (i.e. the first matrix
+ factor).
+
+ The methods \code{.basis}, \code{.coef} and their
+ replacement versions are implemented as pure virtual
+ methods for the interface class \code{NMF}, meaning that
+ concrete NMF models must provide a definition for their
+ corresponding class (i.e. sub-classes of class
+ \code{NMF}). See \code{\linkS4class{NMF}} for more
+ details.
+
+ \code{coef} and \code{coef<-} respectively extract and
+ set the coefficient matrix of an NMF model (i.e. the
+ second matrix factor). For example, in the case of the
+ standard NMF model \eqn{V \equiv WH}{V ~ W H}, the method
+ \code{coef} will return the matrix \eqn{H}.
+
+ \code{.coef} and \code{.coef<-} are low-level S4 generics
+ that simply return/set coefficient data in an object,
+ leaving some common processing to be performed in
+ \code{coef} and \code{coef<-}.
+
+ Methods \code{coefficients} and \code{coefficients<-} are
+ simple aliases for methods \code{coef} and \code{coef<-}
+ respectively.
+
+ \code{scoef} is similar to \code{coef}, but returns the
+ mixture coefficient matrix of an NMF model, with the
+ columns scaled so that they sum up to a given value (1 by
+ default).
+}
+\details{
+ For example, in the case of the standard NMF model \eqn{V
+ \equiv W H}{V ~ W H}, the method \code{basis} will return
+ the matrix \eqn{W}.
+
+ \code{basis} and \code{basis<-} are defined for the top
+ virtual class \code{\linkS4class{NMF}} only, and rely
+ internally on the low-level S4 generics \code{.basis} and
+ \code{.basis<-} respectively that effectively extract/set
+ the coefficient data. These data are post/pre-processed,
+ e.g., to extract/set only their non-fixed terms or check
+ dimension compatibility.
+
+ \code{coef} and \code{coef<-} are S4 methods defined for
+ the corresponding generic functions from package
+ \code{stats} (See \link[stats]{coef}). Similarly to
+ \code{basis} and \code{basis<-}, they are defined for the
+ top virtual class \code{\linkS4class{NMF}} only, and rely
+ internally on the S4 generics \code{.coef} and
+ \code{.coef<-} respectively that effectively extract/set
+ the coefficient data. These data are post/pre-processed,
+ e.g., to extract/set only their non-fixed terms or check
+ dimension compatibility.
+}
+\section{Methods}{
+ \describe{
+
+ \item{basis}{\code{signature(object = "ANY")}: Default
+ method returns the value of S3 slot or attribute
+ \code{'basis'}. It returns \code{NULL} if none of these
+ are set.
+
+ Arguments \code{...} are not used by this method. }
+
+ \item{basis}{\code{signature(object = "NMFfitXn")}:
+ Returns the basis matrix of the best fit amongst all the
+ fits stored in \code{object}. It is a shortcut for
+ \code{basis(fit(object))}. }
+
+ \item{.basis}{\code{signature(object = "NMF")}: Pure
+ virtual method for objects of class
+ \code{\linkS4class{NMF}}, that should be overloaded by
+ sub-classes, and throws an error if called. }
+
+ \item{.basis}{\code{signature(object = "NMFstd")}: Get
+ the basis matrix in standard NMF models
+
+ This function returns slot \code{W} of \code{object}. }
+
+ \item{.basis}{\code{signature(object = "NMFfit")}:
+ Returns the basis matrix from an NMF model fitted with
+ function \code{\link{nmf}}.
+
+ It is a shortcut for \code{.basis(fit(object), ...)},
+ dispatching the call to the \code{.basis} method of the
+ actual NMF model. }
+
+ \item{.basis<-}{\code{signature(object = "NMF", value =
+ "matrix")}: Pure virtual method for objects of class
+ \code{\linkS4class{NMF}}, that should be overloaded by
+ sub-classes, and throws an error if called. }
+
+ \item{.basis<-}{\code{signature(object = "NMFstd", value
+ = "matrix")}: Set the basis matrix in standard NMF models
+
+ This function sets slot \code{W} of \code{object}. }
+
+ \item{.basis<-}{\code{signature(object = "NMFfit", value
+ = "matrix")}: Sets the the basis matrix of an NMF model
+ fitted with function \code{\link{nmf}}.
+
+ It is a shortcut for \code{.basis(fit(object)) <- value},
+ dispatching the call to the \code{.basis<-} method of the
+ actual NMF model. It is not meant to be used by the user,
+ except when developing NMF algorithms, to update the
+ basis matrix of the seed object before returning it. }
+
+ \item{basis<-}{\code{signature(object = "NMF")}: Default
+ methods that calls \code{.basis<-} and check the validity
+ of the updated object. }
+
+ \item{coef}{\code{signature(object = "NMFfitXn")}:
+ Returns the coefficient matrix of the best fit amongst
+ all the fits stored in \code{object}. It is a shortcut
+ for \code{coef(fit(object))}. }
+
+ \item{.coef}{\code{signature(object = "NMF")}: Pure
+ virtual method for objects of class
+ \code{\linkS4class{NMF}}, that should be overloaded by
+ sub-classes, and throws an error if called. }
+
+ \item{.coef}{\code{signature(object = "NMFstd")}: Get the
+ mixture coefficient matrix in standard NMF models
+
+ This function returns slot \code{H} of \code{object}. }
+
+ \item{.coef}{\code{signature(object = "NMFfit")}: Returns
+ the the coefficient matrix from an NMF model fitted with
+ function \code{\link{nmf}}.
+
+ It is a shortcut for \code{.coef(fit(object), ...)},
+ dispatching the call to the \code{.coef} method of the
+ actual NMF model. }
+
+ \item{.coef<-}{\code{signature(object = "NMF", value =
+ "matrix")}: Pure virtual method for objects of class
+ \code{\linkS4class{NMF}}, that should be overloaded by
+ sub-classes, and throws an error if called. }
+
+ \item{.coef<-}{\code{signature(object = "NMFstd", value =
+ "matrix")}: Set the mixture coefficient matrix in
+ standard NMF models
+
+ This function sets slot \code{H} of \code{object}. }
+
+ \item{.coef<-}{\code{signature(object = "NMFfit", value =
+ "matrix")}: Sets the the coefficient matrix of an NMF
+ model fitted with function \code{\link{nmf}}.
+
+ It is a shortcut for \code{.coef(fit(object)) <- value},
+ dispatching the call to the \code{.coef<-} method of the
+ actual NMF model. It is not meant to be used by the user,
+ except when developing NMF algorithms, to update the
+ coefficient matrix in the seed object before returning
+ it. }
+
+ \item{coef<-}{\code{signature(object = "NMF")}: Default
+ methods that calls \code{.coef<-} and check the validity
+ of the updated object. }
+
+ \item{coefficients}{\code{signature(object = "NMF")}:
+ Alias to \code{coef,NMF}, therefore also pure virtual. }
+
+ \item{loadings}{\code{signature(x = "NMF")}: Method
+ loadings for NMF Models
+
+ The method \code{loadings} is identical to \code{basis},
+ but do not accept any extra argument.
+
+ The method \code{loadings} is provided to standardise the
+ NMF interface against the one defined in the
+ \code{\link{stats}} package, and emphasises the
+ similarities between NMF and PCA or factorial analysis
+ (see \code{\link{loadings}}). }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+#----------
+# scoef
+#----------
+# Scaled coefficient matrix
+x <- rnmf(3, 10, 5)
+scoef(x)
+scoef(x, 100)
+
+#----------
+# .basis,NMFstd-method
+#----------
+# random standard NMF model
+x <- rnmf(3, 10, 5)
+basis(x)
+coef(x)
+
+# set matrix factors
+basis(x) <- matrix(1, nrow(x), nbasis(x))
+coef(x) <- matrix(1, nbasis(x), ncol(x))
+# set random factors
+basis(x) <- rmatrix(basis(x))
+coef(x) <- rmatrix(coef(x))
+
+# incompatible matrices generate an error:
+try( coef(x) <- matrix(1, nbasis(x)-1, nrow(x)) )
+# but the low-level method allow it
+.coef(x) <- matrix(1, nbasis(x)-1, nrow(x))
+try( validObject(x) )
+}
+\seealso{
+ Other NMF-interface:
+ \code{\link{.DollarNames,NMF-method}},
+ \code{\link{misc}}, \code{\link{NMF-class}},
+ \code{\link{$<-,NMF-method}}, \code{\link{$,NMF-method}},
+ \code{\link{nmfModel}}, \code{\link{nmfModels}},
+ \code{\link{rnmf}}
+}
+\keyword{methods}
+
diff --git a/man/basiscor.Rd b/man/basiscor.Rd
new file mode 100644
index 0000000..a3aab93
--- /dev/null
+++ b/man/basiscor.Rd
@@ -0,0 +1,117 @@
+\docType{methods}
+\name{basiscor}
+\alias{basiscor}
+\alias{basiscor,matrix,NMF-method}
+\alias{basiscor-methods}
+\alias{basiscor,NMF,matrix-method}
+\alias{basiscor,NMF,missing-method}
+\alias{basiscor,NMF,NMF-method}
+\alias{profcor}
+\alias{profcor,matrix,NMF-method}
+\alias{profcor-methods}
+\alias{profcor,NMF,matrix-method}
+\alias{profcor,NMF,missing-method}
+\alias{profcor,NMF,NMF-method}
+\title{Correlations in NMF Models}
+\usage{
+ basiscor(x, y, ...)
+
+ profcor(x, y, ...)
+}
+\arguments{
+ \item{x}{a matrix or an object with suitable methods
+ \code{\link{basis}} or \code{\link{coef}}.}
+
+ \item{y}{a matrix or an object with suitable methods
+ \code{\link{basis}} or \code{\link{coef}}, and dimensions
+ compatible with \code{x}. If missing the correlations are
+ computed between \code{x} and \code{y=x}.}
+
+ \item{...}{extra arguments passed to \code{\link{cor}}.}
+}
+\description{
+ \code{basiscor} computes the correlation matrix between
+ basis vectors, i.e. the \emph{columns} of its basis
+ matrix -- which is the model's first matrix factor.
+
+ \code{profcor} computes the correlation matrix between
+ basis profiles, i.e. the \emph{rows} of the coefficient
+ matrix -- which is the model's second matrix factor.
+}
+\details{
+ Each generic has methods defined for computing
+ correlations between NMF models and/or compatible
+ matrices. The computation is performed by the base
+ function \code{\link{cor}}.
+}
+\section{Methods}{
+ \describe{
+
+ \item{basiscor}{\code{signature(x = "NMF", y =
+ "matrix")}: Computes the correlations between the basis
+ vectors of \code{x} and the columns of \code{y}. }
+
+ \item{basiscor}{\code{signature(x = "matrix", y =
+ "NMF")}: Computes the correlations between the columns of
+ \code{x} and the the basis vectors of \code{y}. }
+
+ \item{basiscor}{\code{signature(x = "NMF", y = "NMF")}:
+ Computes the correlations between the basis vectors of
+ \code{x} and \code{y}. }
+
+ \item{basiscor}{\code{signature(x = "NMF", y =
+ "missing")}: Computes the correlations between the basis
+ vectors of \code{x}. }
+
+ \item{profcor}{\code{signature(x = "NMF", y = "matrix")}:
+ Computes the correlations between the basis profiles of
+ \code{x} and the rows of \code{y}. }
+
+ \item{profcor}{\code{signature(x = "matrix", y = "NMF")}:
+ Computes the correlations between the rows of \code{x}
+ and the basis profiles of \code{y}. }
+
+ \item{profcor}{\code{signature(x = "NMF", y = "NMF")}:
+ Computes the correlations between the basis profiles of
+ \code{x} and \code{y}. }
+
+ \item{profcor}{\code{signature(x = "NMF", y =
+ "missing")}: Computes the correlations between the basis
+ profiles of \code{x}. }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# generate two random NMF models
+a <- rnmf(3, 100, 20)
+b <- rnmf(3, 100, 20)
+
+# Compute auto-correlations
+basiscor(a)
+profcor(a)
+# Compute correlations with b
+basiscor(a, b)
+profcor(a, b)
+
+# try to recover the underlying NMF model 'a' from noisy data
+res <- nmf(fitted(a) + rmatrix(a), 3)
+
+# Compute correlations with the true model
+basiscor(a, res)
+profcor(a, res)
+
+# Compute correlations with a random compatible matrix
+W <- rmatrix(basis(a))
+basiscor(a, W)
+identical(basiscor(a, W), basiscor(W, a))
+
+H <- rmatrix(coef(a))
+profcor(a, H)
+identical(profcor(a, H), profcor(H, a))
+}
+\keyword{methods}
+
diff --git a/man/bioc.Rd b/man/bioc.Rd
new file mode 100644
index 0000000..6642831
--- /dev/null
+++ b/man/bioc.Rd
@@ -0,0 +1,39 @@
+\name{bioc-NMF}
+\alias{.atrack,ExpressionSet-method}
+\alias{bioc-NMF}
+\alias{featureNames,NMFfitX-method}
+\alias{featureNames<-,NMF-method}
+\alias{featureNames,NMF-method}
+\alias{metagenes}
+\alias{metagenes<-}
+\alias{metaprofiles}
+\alias{metaprofiles<-}
+\alias{nmeta}
+\alias{nmf,ExpressionSet,ANY,ANY-method}
+\alias{nmf,matrix,ExpressionSet,ANY-method}
+\alias{nmfModel,ANY,ExpressionSet-method}
+\alias{nmfModel,ExpressionSet,ANY-method}
+\alias{nneg,ExpressionSet-method}
+\alias{rnmf,ANY,ExpressionSet-method}
+\alias{rposneg,ExpressionSet-method}
+\alias{run,NMFStrategy,ExpressionSet,ANY-method}
+\alias{sampleNames<-,NMF,ANY-method}
+\alias{sampleNames,NMFfitX-method}
+\alias{sampleNames,NMF-method}
+\alias{seed,ExpressionSet,ANY,ANY-method}
+\title{Specific NMF Layer for Bioconductor}
+\description{
+ The package NMF provides an optional layer for working
+ with common objects and functions defined in the
+ Bioconductor platform.
+}
+\details{
+ It provides: \itemize{ \item computation functions that
+ support \code{ExpressionSet} objects as inputs. \item
+ aliases and methods for generic functions defined and
+ widely used by Bioconductor base packages. \item
+ specialised visualisation methods that adapt the titles
+ and legend using bioinformatics terminology. \item
+ functions to link the results with annotations, etc... }
+}
+
diff --git a/man/c-commaNMF-method.Rd b/man/c-commaNMF-method.Rd
new file mode 100644
index 0000000..aeb3daf
--- /dev/null
+++ b/man/c-commaNMF-method.Rd
@@ -0,0 +1,31 @@
+\docType{methods}
+\name{c,NMF-method}
+\alias{c,NMF-method}
+\title{Concatenating NMF Models}
+\usage{
+ \S4method{c}{NMF}(x, ..., margin = 3, recursive = FALSE)
+}
+\arguments{
+ \item{x}{an NMF model}
+
+ \item{...}{other objects to concatenate. Currently only
+ two objects at a time can be concatenated (i.e. \code{x}
+ and \code{..1}).}
+
+ \item{margin}{integer that indicates the margin along
+ which to concatenate (only used when \code{..1} is a
+ matrix): \describe{ \item{1L}{} \item{2L}{} \item{3L}{}
+ \item{4L}{} } If missing the margin is heuristically
+ determined by looking at common dimensions between the
+ objects.}
+
+ \item{recursive}{logical. If \code{recursive = TRUE},
+ the function recursively descends through lists (and
+ pairlists) combining all their elements into a vector.}
+}
+\description{
+ Binds compatible matrices and NMF models together.
+}
+\keyword{internal}
+\keyword{methods}
+
diff --git a/man/canFit.Rd b/man/canFit.Rd
new file mode 100644
index 0000000..27e05d8
--- /dev/null
+++ b/man/canFit.Rd
@@ -0,0 +1,53 @@
+\docType{methods}
+\name{canFit}
+\alias{canFit}
+\alias{canFit,character,ANY-method}
+\alias{canFit-methods}
+\alias{canFit,NMFStrategy,character-method}
+\alias{canFit,NMFStrategy,NMF-method}
+\title{Testing Compatibility of Algorithm and Models}
+\usage{
+ canFit(x, y, ...)
+
+ \S4method{canFit}{NMFStrategy,character}(x, y,
+ exact = FALSE)
+}
+\arguments{
+ \item{x}{an object that describes an algorithm}
+
+ \item{y}{an object that describes a model}
+
+ \item{...}{extra arguments to allow extension}
+
+ \item{exact}{for logical that indicates if an algorithm
+ is considered able to fit only the models that it
+ explicitly declares (\code{TRUE}), or if it should be
+ considered able to also fit models that extend models
+ that it explicitly fits.}
+}
+\description{
+ \code{canFit} is an S4 generic that tests if an algorithm
+ can fit a particular model.
+}
+\section{Methods}{
+ \describe{
+
+ \item{canFit}{\code{signature(x = "NMFStrategy", y =
+ "character")}: Tells if an NMF algorithm can fit a given
+ class of NMF models }
+
+ \item{canFit}{\code{signature(x = "NMFStrategy", y =
+ "NMF")}: Tells if an NMF algorithm can fit the same class
+ of models as \code{y} }
+
+ \item{canFit}{\code{signature(x = "character", y =
+ "ANY")}: Tells if a registered NMF algorithm can fit a
+ given NMF model }
+
+ }
+}
+\seealso{
+ Other regalgo: \code{\link{nmfAlgorithm}}
+}
+\keyword{methods}
+
diff --git a/man/ccBreaks.Rd b/man/ccBreaks.Rd
new file mode 100644
index 0000000..f739b95
--- /dev/null
+++ b/man/ccBreaks.Rd
@@ -0,0 +1,12 @@
+\name{ccBreaks}
+\alias{ccBreaks}
+\title{Generate Break Intervals from Numeric Variables}
+\usage{
+ ccBreaks(x, breaks)
+}
+\description{
+ Implementation is borrowed from the R core function
+ \code{\link{cut.default}}.
+}
+\keyword{internal}
+
diff --git a/man/ccPalette.Rd b/man/ccPalette.Rd
new file mode 100644
index 0000000..55e99f6
--- /dev/null
+++ b/man/ccPalette.Rd
@@ -0,0 +1,11 @@
+\name{ccPalette}
+\alias{ccPalette}
+\title{Builds a Color Palette from Compact Color Specification}
+\usage{
+ ccPalette(x, n = NA, verbose = FALSE)
+}
+\description{
+ Builds a Color Palette from Compact Color Specification
+}
+\keyword{internal}
+
diff --git a/man/ccRamp.Rd b/man/ccRamp.Rd
new file mode 100644
index 0000000..7d26780
--- /dev/null
+++ b/man/ccRamp.Rd
@@ -0,0 +1,11 @@
+\name{ccRamp}
+\alias{ccRamp}
+\title{Builds a Color Ramp from Compact Color Specification}
+\usage{
+ ccRamp(x, n = NA, ...)
+}
+\description{
+ Builds a Color Ramp from Compact Color Specification
+}
+\keyword{internal}
+
diff --git a/man/ccSpec.Rd b/man/ccSpec.Rd
new file mode 100644
index 0000000..47d01c8
--- /dev/null
+++ b/man/ccSpec.Rd
@@ -0,0 +1,17 @@
+\name{ccSpec}
+\alias{ccSpec}
+\title{Extract Colour Palette Specification}
+\usage{
+ ccSpec(x)
+}
+\arguments{
+ \item{a}{character string that specify a colour palette.}
+}
+\value{
+ a list with elements: palette, n and rev
+}
+\description{
+ Extract Colour Palette Specification
+}
+\keyword{internal}
+
diff --git a/man/checkErrors.Rd b/man/checkErrors.Rd
new file mode 100644
index 0000000..267cada
--- /dev/null
+++ b/man/checkErrors.Rd
@@ -0,0 +1,17 @@
+\name{checkErrors}
+\alias{checkErrors}
+\title{Error Checks in NMF Runs}
+\usage{
+ checkErrors(object, element = NULL)
+}
+\arguments{
+ \item{object}{a list of lists}
+
+ \item{element}{name of an element of the inner lists}
+}
+\description{
+ Auxiliary function for internal error checks in nmf
+ results.
+}
+\keyword{internal}
+
diff --git a/man/cluster_mat.Rd b/man/cluster_mat.Rd
new file mode 100644
index 0000000..cf49632
--- /dev/null
+++ b/man/cluster_mat.Rd
@@ -0,0 +1,33 @@
+\name{cluster_mat}
+\alias{cluster_mat}
+\title{Cluster Matrix Rows in Annotated Heatmaps}
+\usage{
+ cluster_mat(mat, param, distfun, hclustfun, reorderfun,
+ na.rm = TRUE, subset = NULL, verbose = FALSE)
+}
+\arguments{
+ \item{mat}{original input matrix that has already been
+ appropriately subset in the caller function
+ (\code{aheatmap})}
+
+ \item{param}{clustering specifications}
+
+ \item{distfun}{Default distance method/function}
+
+ \item{hclustfun}{Default clustering (linkage)
+ method/function}
+
+ \item{reorderfun}{Default reordering function}
+
+ \item{na.rm}{Logical that specifies if NA values should
+ be removed}
+
+ \item{subset}{index (integer) vector specifying the
+ subset indexes used to subset mat. This is required to be
+ able to return the original indexes.}
+}
+\description{
+ Cluster Matrix Rows in Annotated Heatmaps
+}
+\keyword{internal}
+
diff --git a/man/connectivity.Rd b/man/connectivity.Rd
new file mode 100644
index 0000000..360a19b
--- /dev/null
+++ b/man/connectivity.Rd
@@ -0,0 +1,141 @@
+\docType{methods}
+\name{connectivity}
+\alias{connectivity}
+\alias{connectivity,ANY-method}
+\alias{connectivity,factor-method}
+\alias{connectivity-methods}
+\alias{connectivity,NMF-method}
+\alias{connectivity,numeric-method}
+\alias{consensus}
+\alias{consensus-methods}
+\alias{consensus,NMFfitX-method}
+\alias{consensus,NMF-method}
+\title{Clustering Connectivity and Consensus Matrices}
+\usage{
+ connectivity(object, ...)
+
+ \S4method{connectivity}{NMF}(object, no.attrib = FALSE)
+
+ consensus(object, ...)
+}
+\arguments{
+ \item{object}{an object with a suitable
+ \code{\link{predict}} method.}
+
+ \item{...}{extra arguments to allow extension. They are
+ passed to \code{\link{predict}}, except for the
+ \code{vector} and \code{factor} methods.}
+
+ \item{no.attrib}{a logical that indicates if attributes
+ containing information about the NMF model should be
+ attached to the result (\code{TRUE}) or not
+ (\code{FALSE}).}
+}
+\value{
+ a square matrix of dimension the number of samples in the
+ model, full of 0s or 1s.
+}
+\description{
+ \code{connectivity} is an S4 generic that computes the
+ connectivity matrix based on the clustering of samples
+ obtained from a model's \code{\link{predict}} method.
+
+ The consensus matrix has been proposed by \cite{Brunet et
+ al. (2004)} to help visualising and measuring the
+ stability of the clusters obtained by NMF approaches. For
+ objects of class \code{NMF} (e.g. results of a single NMF
+ run, or NMF models), the consensus matrix reduces to the
+ connectivity matrix.
+}
+\details{
+ The connectivity matrix of a given partition of a set of
+ samples (e.g. given as a cluster membership index) is the
+ matrix \eqn{C} containing only 0 or 1 entries such that:
+ \deqn{C_{ij} = \left\{\begin{array}{l} 1\mbox{ if sample
+ }i\mbox{ belongs to the same cluster as sample }j\\
+ 0\mbox{ otherwise} \end{array}\right..}{ C_{ij} = 1 if
+ sample i belongs to the same cluster as sample j, 0
+ otherwise}
+}
+\section{Methods}{
+ \describe{
+
+ \item{connectivity}{\code{signature(object = "ANY")}:
+ Default method which computes the connectivity matrix
+ using the result of \code{predict(x, ...)} as cluster
+ membership index. }
+
+ \item{connectivity}{\code{signature(object = "factor")}:
+ Computes the connectivity matrix using \code{x} as
+ cluster membership index. }
+
+ \item{connectivity}{\code{signature(object = "numeric")}:
+ Equivalent to \code{connectivity(as.factor(x))}. }
+
+ \item{connectivity}{\code{signature(object = "NMF")}:
+ Computes the connectivity matrix for an NMF model, for
+ which cluster membership is given by the most
+ contributing basis component in each sample. See
+ \code{\link{predict,NMF-method}}. }
+
+ \item{consensus}{\code{signature(object = "NMFfitX")}:
+ Pure virtual method defined to ensure \code{consensus} is
+ defined for sub-classes of \code{NMFfitX}. It throws an
+ error if called. }
+
+ \item{consensus}{\code{signature(object = "NMF")}: This
+ method is provided for completeness and is identical to
+ \code{\link{connectivity}}, and returns the connectivity
+ matrix, which, in the case of a single NMF model, is also
+ the consensus matrix. }
+
+ \item{consensus}{\code{signature(object = "NMFfitX1")}:
+ The result is the matrix stored in slot
+ \sQuote{consensus}. This method returns \code{NULL} if
+ the consensus matrix is empty.
+
+ See \code{\link{consensus,NMFfitX1-method}} for more
+ details. }
+
+ \item{consensus}{\code{signature(object = "NMFfitXn")}:
+ This method returns \code{NULL} on an empty object. The
+ result is a matrix with several attributes attached, that
+ are used by plotting functions such as
+ \code{\link{consensusmap}} to annotate the plots.
+
+ See \code{\link{consensus,NMFfitXn-method}} for more
+ details. }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+#----------
+# connectivity,ANY-method
+#----------
+# clustering of random data
+h <- hclust(dist(rmatrix(10,20)))
+connectivity(cutree(h, 2))
+
+#----------
+# connectivity,factor-method
+#----------
+connectivity(gl(2, 4))
+}
+\references{
+ Brunet J, Tamayo P, Golub TR and Mesirov JP (2004).
+ "Metagenes and molecular pattern discovery using matrix
+ factorization." _Proceedings of the National Academy of
+ Sciences of the United States of America_, *101*(12), pp.
+ 4164-9. ISSN 0027-8424, <URL:
+ http://dx.doi.org/10.1073/pnas.0308531101>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/15016911>.
+}
+\seealso{
+ \code{\link{predict}}
+}
+\keyword{methods}
+
diff --git a/man/consensus-commaNMFfitX1-method.Rd b/man/consensus-commaNMFfitX1-method.Rd
new file mode 100644
index 0000000..6522d88
--- /dev/null
+++ b/man/consensus-commaNMFfitX1-method.Rd
@@ -0,0 +1,24 @@
+\docType{methods}
+\name{consensus,NMFfitX1-method}
+\alias{consensus,NMFfitX1-method}
+\title{Returns the consensus matrix computed while performing all NMF runs,
+amongst which \code{object} was selected as the best fit.}
+\usage{
+ \S4method{consensus}{NMFfitX1}(object, no.attrib = FALSE)
+}
+\arguments{
+ \item{object}{an object with a suitable
+ \code{\link{predict}} method.}
+
+ \item{no.attrib}{a logical that indicates if attributes
+ containing information about the NMF model should be
+ attached to the result (\code{TRUE}) or not
+ (\code{FALSE}).}
+}
+\description{
+ The result is the matrix stored in slot
+ \sQuote{consensus}. This method returns \code{NULL} if
+ the consensus matrix is empty.
+}
+\keyword{methods}
+
diff --git a/man/consensus-commaNMFfitXn-method.Rd b/man/consensus-commaNMFfitXn-method.Rd
new file mode 100644
index 0000000..29e5ad1
--- /dev/null
+++ b/man/consensus-commaNMFfitXn-method.Rd
@@ -0,0 +1,31 @@
+\docType{methods}
+\name{consensus,NMFfitXn-method}
+\alias{consensus,NMFfitXn-method}
+\alias{plot.NMF.consensus}
+\title{Computes the consensus matrix of the set of fits stored in \code{object}, as
+the mean connectivity matrix across runs.}
+\usage{
+ \S4method{consensus}{NMFfitXn}(object, ...,
+ no.attrib = FALSE)
+}
+\arguments{
+ \item{object}{an object with a suitable
+ \code{\link{predict}} method.}
+
+ \item{...}{extra arguments to allow extension. They are
+ passed to \code{\link{predict}}, except for the
+ \code{vector} and \code{factor} methods.}
+
+ \item{no.attrib}{a logical that indicates if attributes
+ containing information about the NMF model should be
+ attached to the result (\code{TRUE}) or not
+ (\code{FALSE}).}
+}
+\description{
+ This method returns \code{NULL} on an empty object. The
+ result is a matrix with several attributes attached, that
+ are used by plotting functions such as
+ \code{\link{consensusmap}} to annotate the plots.
+}
+\keyword{methods}
+
diff --git a/man/consensushc.Rd b/man/consensushc.Rd
new file mode 100644
index 0000000..6ac64d3
--- /dev/null
+++ b/man/consensushc.Rd
@@ -0,0 +1,62 @@
+\docType{methods}
+\name{consensushc}
+\alias{consensushc}
+\alias{consensushc,matrix-method}
+\alias{consensushc-methods}
+\alias{consensushc,NMFfitX-method}
+\alias{consensushc,NMF-method}
+\title{Hierarchical Clustering of a Consensus Matrix}
+\usage{
+ consensushc(object, ...)
+
+ \S4method{consensushc}{matrix}(object,
+ method = "average", dendrogram = TRUE)
+
+ \S4method{consensushc}{NMFfitX}(object,
+ what = c("consensus", "fit"), ...)
+}
+\arguments{
+ \item{object}{a matrix or an \code{NMFfitX} object, as
+ returned by multiple NMF runs.}
+
+ \item{...}{extra arguments passed to next method calls}
+
+ \item{method}{linkage method passed to
+ \code{\link{hclust}}.}
+
+ \item{dendrogram}{a logical that specifies if the result
+ of the hierarchical clustering (en \code{hclust} object)
+ should be converted into a dendrogram. Default value is
+ \code{TRUE}.}
+
+ \item{what}{character string that indicates which matrix
+ to use in the computation.}
+}
+\value{
+ an object of class \code{dendrogram} or \code{hclust}
+ depending on the value of argument \code{dendrogram}.
+}
+\description{
+ The function \code{consensushc} computes the hierarchical
+ clustering of a consensus matrix, using the matrix itself
+ as a similarity matrix and average linkage. It is
+}
+\section{Methods}{
+ \describe{
+
+ \item{consensushc}{\code{signature(object = "matrix")}:
+ Workhorse method for matrices. }
+
+ \item{consensushc}{\code{signature(object = "NMF")}:
+ Compute the hierarchical clustering on the connectivity
+ matrix of \code{object}. }
+
+ \item{consensushc}{\code{signature(object = "NMFfitX")}:
+ Compute the hierarchical clustering on the consensus
+ matrix of \code{object}, or on the connectivity matrix of
+ the best fit in \code{object}. }
+
+ }
+}
+\keyword{methods}
+
diff --git a/man/cophcor.Rd b/man/cophcor.Rd
new file mode 100644
index 0000000..ecff2e6
--- /dev/null
+++ b/man/cophcor.Rd
@@ -0,0 +1,69 @@
+\docType{methods}
+\name{cophcor}
+\alias{cophcor}
+\alias{cophcor,matrix-method}
+\alias{cophcor-methods}
+\alias{cophcor,NMFfitX-method}
+\title{Cophenetic Correlation Coefficient}
+\usage{
+ cophcor(object, ...)
+
+ \S4method{cophcor}{matrix}(object, linkage = "average")
+}
+\arguments{
+ \item{object}{an object from which is extracted a
+ consensus matrix.}
+
+ \item{...}{extra arguments to allow extension and passed
+ to subsequent calls.}
+
+ \item{linkage}{linkage method used in the hierarchical
+ clustering. It is passed to \code{\link{hclust}}.}
+}
+\description{
+ The function \code{cophcor} computes the cophenetic
+ correlation coefficient from consensus matrix
+ \code{object}, e.g. as obtained from multiple NMF runs.
+}
+\details{
+ The cophenetic correlation coeffificient is based on the
+ consensus matrix (i.e. the average of connectivity
+ matrices) and was proposed by \cite{Brunet et al. (2004)}
+ to measure the stability of the clusters obtained from
+ NMF.
+
+ It is defined as the Pearson correlation between the
+ samples' distances induced by the consensus matrix (seen
+ as a similarity matrix) and their cophenetic distances
+ from a hierachical clustering based on these very
+ distances (by default an average linkage is used). See
+ \cite{Brunet et al. (2004)}.
+}
+\section{Methods}{
+ \describe{
+
+ \item{cophcor}{\code{signature(object = "matrix")}:
+ Workhorse method for matrices. }
+
+ \item{cophcor}{\code{signature(object = "NMFfitX")}:
+ Computes the cophenetic correlation coefficient on the
+ consensus matrix of \code{object}. All arguments in
+ \code{...} are passed to the method
+ \code{cophcor,matrix}. }
+
+ }
+}
+\references{
+ Brunet J, Tamayo P, Golub TR and Mesirov JP (2004).
+ "Metagenes and molecular pattern discovery using matrix
+ factorization." _Proceedings of the National Academy of
+ Sciences of the United States of America_, *101*(12), pp.
+ 4164-9. ISSN 0027-8424, <URL:
+ http://dx.doi.org/10.1073/pnas.0308531101>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/15016911>.
+}
+\seealso{
+ \code{\link{cophenetic}}
+}
+\keyword{methods}
+
diff --git a/man/cutdendro.Rd b/man/cutdendro.Rd
new file mode 100644
index 0000000..a464c5f
--- /dev/null
+++ b/man/cutdendro.Rd
@@ -0,0 +1,16 @@
+\name{cutdendro}
+\alias{cutdendro}
+\title{Fade Out the Upper Branches from a Dendrogram}
+\usage{
+ cutdendro(x, n)
+}
+\arguments{
+ \item{x}{a dendrogram}
+
+ \item{n}{the number of groups}
+}
+\description{
+ Fade Out the Upper Branches from a Dendrogram
+}
+\keyword{internal}
+
diff --git a/man/deviance.Rd b/man/deviance.Rd
new file mode 100644
index 0000000..b373f9d
--- /dev/null
+++ b/man/deviance.Rd
@@ -0,0 +1,100 @@
+\docType{methods}
+\name{deviance}
+\alias{deviance}
+\alias{deviance-methods}
+\alias{deviance,NMFfit-method}
+\alias{deviance,NMFfitX-method}
+\alias{deviance,NMF-method}
+\alias{deviance,NMFStrategy-method}
+\alias{nmfDistance}
+\title{Distances and Objective Functions}
+\usage{
+ deviance(object, ...)
+
+ \S4method{deviance}{NMF}(object, y,
+ method = c("", "KL", "euclidean"), ...)
+
+ nmfDistance(method = c("", "KL", "euclidean"))
+
+ \S4method{deviance}{NMFfit}(object, y, method, ...)
+
+ \S4method{deviance}{NMFStrategy}(object, x, y, ...)
+}
+\arguments{
+ \item{y}{a matrix compatible with the NMF model
+ \code{object}, i.e. \code{y} must have the same dimension
+ as \code{fitted(object)}.}
+
+ \item{method}{a character string or a function with
+ signature \code{(x="NMF", y="matrix", ...)} that
+ implements a distance measure between an NMF model
+ \code{x} and a target matrix \code{y}, i.e. an objective
+ function to use to compute the deviance. In
+ \code{deviance}, it is passed to \code{nmfDistance} to
+ get the function that effectively computes the deviance.}
+
+ \item{...}{extra parameters passed to the objective
+ function.}
+
+ \item{x}{an NMF model that estimates \code{y}.}
+
+ \item{object}{an object for which the deviance is
+ desired.}
+}
+\value{
+ \code{deviance} returns a nonnegative numerical value
+
+ \code{nmfDistance} returns a function with least two
+ arguments: an NMF model and a matrix.
+}
+\description{
+ The NMF package defines methods for the generic
+ \code{deviance} from the package \code{stats}, to compute
+ approximation errors between NMF models and matrices,
+ using a variety of objective functions.
+
+ \code{nmfDistance} returns a function that computes the
+ distance between an NMF model and a compatible matrix.
+}
+\section{Methods}{
+ \describe{
+
+ \item{deviance}{\code{signature(object = "NMF")}:
+ Computes the distance between a matrix and the estimate
+ of an \code{NMF} model. }
+
+ \item{deviance}{\code{signature(object = "NMFfit")}:
+ Returns the deviance of a fitted NMF model.
+
+ This method returns the final residual value if the
+ target matrix \code{y} is not supplied, or the
+ approximation error between the fitted NMF model stored
+ in \code{object} and \code{y}. In this case, the
+ computation is performed using the objective function
+ \code{method} if not missing, or the objective of the
+ algorithm that fitted the model (stored in slot
+ \code{'distance'}).
+
+ If not computed by the NMF algorithm itself, the value is
+ automatically computed at the end of the fitting process
+ by the function \code{\link{nmf}}, using the objective
+ function associated with the NMF algorithm, so that it
+ should always be available. }
+
+ \item{deviance}{\code{signature(object = "NMFfitX")}:
+ Returns the deviance achieved by the best fit object,
+ i.e. the lowest deviance achieved across all NMF runs. }
+
+ \item{deviance}{\code{signature(object = "NMFStrategy")}:
+ Computes the value of the objective function between the
+ estimate \code{x} and the target \code{y}. }
+
+ }
+}
+\seealso{
+ Other stats: \code{\link{deviance,NMF-method}},
+ \code{\link{hasTrack}}, \code{\link{residuals}},
+ \code{\link{residuals<-}}, \code{\link{trackError}}
+}
+\keyword{methods}
+
diff --git a/man/dimnames.Rd b/man/dimnames.Rd
new file mode 100644
index 0000000..001950e
--- /dev/null
+++ b/man/dimnames.Rd
@@ -0,0 +1,164 @@
+\docType{methods}
+\name{basisnames}
+\alias{basisnames}
+\alias{basisnames<-}
+\alias{basisnames<-,ANY-method}
+\alias{basisnames,ANY-method}
+\alias{basisnames<--methods}
+\alias{basisnames-methods}
+\alias{dimnames-NMF}
+\alias{dimnames<-,NMF-method}
+\alias{dimnames,NMF-method}
+\title{Dimension names for NMF objects}
+\usage{
+ basisnames(x, ...)
+
+ basisnames(x, ...)<-value
+
+ \S4method{dimnames}{NMF}(x)
+
+ \S4method{dimnames}{NMF}(x)<-value
+}
+\arguments{
+ \item{x}{an object with suitable \code{basis} and
+ \code{coef} methods, such as an object that inherit from
+ \code{\linkS4class{NMF}}.}
+
+ \item{...}{extra argument to allow extension.}
+
+ \item{value}{a character vector, or \code{NULL} or, in
+ the case of \code{dimnames<-}, a list 2 or 3-length list
+ of character vectors.}
+}
+\description{
+ The methods \code{dimnames}, \code{rownames},
+ \code{colnames} and \code{basisnames} and their
+ respective replacement form allow to get and set the
+ dimension names of the matrix factors in a NMF model.
+
+ \code{dimnames} returns all the dimension names in a
+ single list. Its replacement form \code{dimnames<-}
+ allows to set all dimension names at once.
+
+ \code{rownames}, \code{colnames} and \code{basisnames}
+ provide separate access to each of these dimension names
+ respectively. Their respective replacement form allow to
+ set each dimension names separately.
+}
+\details{
+ The function \code{basisnames} is a new S4 generic
+ defined in the package NMF, that returns the names of the
+ basis components of an object. Its default method should
+ work for any object, that has a suitable \code{basis}
+ method defined for its class.
+
+ The method \code{dimnames} is implemented for the base
+ generic \code{\link{dimnames}}, which make the base
+ function \code{\link{rownames}} and
+ \code{\link{colnames}} work directly.
+
+ Overall, these methods behave as their equivalent on
+ \code{matrix} objects. The function \code{basisnames<-}
+ ensures that the dimension names are handled in a
+ consistent way on both factors, enforcing the names on
+ both matrix factors simultaneously.
+
+ The function \code{basisnames<-} is a new S4 generic
+ defined in the package NMF, that sets the names of the
+ basis components of an object. Its default method should
+ work for any object, that has suitable \code{basis<-} and
+ \code{coef<-} methods method defined for its class.
+}
+\section{Methods}{
+ \describe{
+
+ \item{basisnames}{\code{signature(x = "ANY")}: Default
+ method which returns the column names of the basis matrix
+ extracted from \code{x}, using the \code{basis} method.
+
+ For NMF objects these also correspond to the row names of
+ the coefficient matrix. }
+
+ \item{basisnames<-}{\code{signature(x = "ANY")}: Default
+ method which sets, respectively, the row and the column
+ names of the basis matrix and coefficient matrix of
+ \code{x} to \code{value}. }
+
+ \item{dimnames}{\code{signature(x = "NMF")}: Returns the
+ dimension names of the NMF model \code{x}.
+
+ It returns either NULL if no dimnames are set on the
+ object, or a 3-length list containing the row names of
+ the basis matrix, the column names of the mixture
+ coefficient matrix, and the column names of the basis
+ matrix (i.e. the names of the basis components). }
+
+ \item{dimnames<-}{\code{signature(x = "NMF")}: sets the
+ dimension names of the NMF model \code{x}.
+
+ \code{value} can be \code{NULL} which resets all
+ dimension names, or a 1, 2 or 3-length list providing
+ names at least for the rows of the basis matrix.
+
+ The optional second element of \code{value} (NULL if
+ absent) is used to set the column names of the
+ coefficient matrix. The optional third element of
+ \code{value} (NULL if absent) is used to set both the
+ column names of the basis matrix and the row names of the
+ coefficient matrix. }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# create a random NMF object
+a <- rnmf(2, 5, 3)
+
+# set dimensions
+dims <- list( features=paste('f', 1:nrow(a), sep='')
+ , samples=paste('s', 1:ncol(a), sep='')
+ , basis=paste('b', 1:nbasis(a), sep='') )
+dimnames(a) <- dims
+dimnames(a)
+basis(a)
+coef(a)
+
+# access the dimensions separately
+rownames(a)
+colnames(a)
+basisnames(a)
+
+# set only the first dimension (rows of basis): the other two dimnames are set to NULL
+dimnames(a) <- dims[1]
+dimnames(a)
+basis(a)
+coef(a)
+
+# set only the two first dimensions (rows and columns of basis and coef respectively):
+# the basisnames are set to NULL
+dimnames(a) <- dims[1:2]
+dimnames(a)
+basis(a)
+
+# reset the dimensions
+dimnames(a) <- NULL
+dimnames(a)
+basis(a)
+coef(a)
+
+# set each dimensions separately
+rownames(a) <- paste('X', 1:nrow(a), sep='') # only affect rows of basis
+basis(a)
+
+colnames(a) <- paste('Y', 1:ncol(a), sep='') # only affect columns of coef
+coef(a)
+
+basisnames(a) <- paste('Z', 1:nbasis(a), sep='') # affect both basis and coef matrices
+basis(a)
+coef(a)
+}
+\keyword{methods}
+
diff --git a/man/dims.Rd b/man/dims.Rd
new file mode 100644
index 0000000..b6b190e
--- /dev/null
+++ b/man/dims.Rd
@@ -0,0 +1,95 @@
+\docType{methods}
+\name{nbasis}
+\alias{dim-NMF}
+\alias{dim,NMFfitXn-method}
+\alias{dim,NMF-method}
+\alias{nbasis}
+\alias{nbasis,ANY-method}
+\alias{nbasis-methods}
+\alias{nbasis,NMFfitXn-method}
+\title{Dimension of NMF Objects}
+\usage{
+ nbasis(x, ...)
+
+ \S4method{dim}{NMF}(x)
+
+ \S4method{dim}{NMFfitXn}(x)
+}
+\arguments{
+ \item{x}{an object with suitable \code{basis} and
+ \code{coef} methods, such as an object that inherit from
+ \code{\linkS4class{NMF}}.}
+
+ \item{...}{extra arguments to allow extension.}
+}
+\value{
+ a single integer value or, for \code{dim}, a length-3
+ integer vector, e.g. \code{c(2000, 30, 3)} for an
+ \code{NMF} model that fits a 2000 x 30 matrix using 3
+ basis components.
+}
+\description{
+ The methods \code{dim}, \code{nrow}, \code{ncol} and
+ \code{nbasis} return the different dimensions associated
+ with an NMF model.
+
+ \code{dim} returns all dimensions in a length-3 integer
+ vector: the number of row and columns of the estimated
+ target matrix, as well as the factorization rank (i.e.
+ the number of basis components).
+
+ \code{nrow}, \code{ncol} and \code{nbasis} provide
+ separate access to each of these dimensions respectively.
+}
+\details{
+ The NMF package does not implement specific functions
+ \code{nrow} and \code{ncol}, but rather the S4 method
+ \code{dim} for objects of class \code{\linkS4class{NMF}}.
+ This allows the base methods \code{\link{nrow}} and
+ \code{\link{ncol}} to directly work with such objects, to
+ get the number of rows and columns of the target matrix
+ estimated by an NMF model.
+
+ The function \code{nbasis} is a new S4 generic defined in
+ the package NMF, that returns the number of basis
+ components of an object. Its default method should work
+ for any object, that has a suitable \code{basis} method
+ defined for its class.
+}
+\section{Methods}{
+ \describe{
+
+ \item{dim}{\code{signature(x = "NMF")}: method for NMF
+ objects for the base generic \code{\link{dim}}. It
+ returns all dimensions in a length-3 integer vector: the
+ number of row and columns of the estimated target matrix,
+ as well as the factorization rank (i.e. the number of
+ basis components). }
+
+ \item{dim}{\code{signature(x = "NMFfitXn")}: Returns the
+ dimension common to all fits.
+
+ Since all fits have the same dimensions, it returns the
+ dimension of the first fit. This method returns
+ \code{NULL} if the object is empty. }
+
+ \item{nbasis}{\code{signature(x = "ANY")}: Default method
+ which returns the number of columns of the basis matrix
+ extracted from \code{x} using a suitable method
+ \code{basis}, or, if the latter is \code{NULL}, the value
+ of attributes \code{'nbasis'}.
+
+ For NMF models, this also corresponds to the number of
+ rows in the coefficient matrix. }
+
+ \item{nbasis}{\code{signature(x = "NMFfitXn")}: Returns
+ the number of basis components common to all fits.
+
+ Since all fits have been computed using the same rank, it
+ returns the factorization rank of the first fit. This
+ method returns \code{NULL} if the object is empty. }
+
+ }
+}
+\keyword{methods}
+
diff --git a/man/dispersion.Rd b/man/dispersion.Rd
new file mode 100644
index 0000000..bf2aa0c
--- /dev/null
+++ b/man/dispersion.Rd
@@ -0,0 +1,62 @@
+\docType{methods}
+\name{dispersion}
+\alias{dispersion}
+\alias{dispersion,matrix-method}
+\alias{dispersion-methods}
+\alias{dispersion,NMFfitX-method}
+\title{Dispersion of a Matrix}
+\usage{
+ dispersion(object, ...)
+}
+\arguments{
+ \item{object}{an object from which the dispersion is
+ computed}
+
+ \item{...}{extra arguments to allow extension}
+}
+\description{
+ Computes the dispersion coefficient of a -- consensus --
+ matrix \code{object}, generally obtained from multiple
+ NMF runs.
+}
+\details{
+ The dispersion coefficient is based on the consensus
+ matrix (i.e. the average of connectivity matrices) and
+ was proposed by \cite{Kim et al. (2007)} to measure the
+ reproducibility of the clusters obtained from NMF.
+
+ It is defined as: \deqn{\rho = \sum_{i,j=1}^n 4 (C_{ij} -
+ \frac{1}{2})^2 , } where \eqn{n} is the total number of
+ samples.
+
+ By construction, \eqn{0 \leq \rho \leq 1} and \eqn{\rho =
+ 1} only for a perfect consensus matrix, where all entries
+ 0 or 1. A perfect consensus matrix is obtained only when
+ all the connectivity matrices are the same, meaning that
+ the algorithm gave the same clusters at each run. See
+ \cite{Kim et al. (2007)}.
+}
+\section{Methods}{
+ \describe{
+
+ \item{dispersion}{\code{signature(object = "matrix")}:
+ Workhorse method that computes the dispersion on a given
+ matrix. }
+
+ \item{dispersion}{\code{signature(object = "NMFfitX")}:
+ Computes the dispersion on the consensus matrix obtained
+ from multiple NMF runs. }
+
+ }
+}
+\references{
+ Kim H and Park H (2007). "Sparse non-negative matrix
+ factorizations via alternating non-negativity-constrained
+ least squares for microarray data analysis."
+ _Bioinformatics (Oxford, England)_, *23*(12), pp.
+ 1495-502. ISSN 1460-2059, <URL:
+ http://dx.doi.org/10.1093/bioinformatics/btm134>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/17483501>.
+}
+\keyword{methods}
+
diff --git a/man/dot-fcnnls.Rd b/man/dot-fcnnls.Rd
new file mode 100644
index 0000000..7a63c3d
--- /dev/null
+++ b/man/dot-fcnnls.Rd
@@ -0,0 +1,63 @@
+\name{.fcnnls}
+\alias{.fcnnls}
+\title{Internal Routine for Fast Combinatorial Nonnegative Least-Squares}
+\usage{
+ .fcnnls(x, y, verbose = FALSE, pseudo = FALSE, eps = 0)
+}
+\arguments{
+ \item{x}{the coefficient matrix}
+
+ \item{y}{the target matrix to be approximated by \eqn{X
+ K}.}
+
+ \item{verbose}{logical that indicates if log messages
+ should be shown.}
+
+ \item{pseudo}{By default (\code{pseudo=FALSE}) the
+ algorithm uses Gaussian elimination to solve the
+ successive internal linear problems, using the
+ \code{\link{solve}} function. If \code{pseudo=TRUE} the
+ algorithm uses Moore-Penrose generalized
+ \code{\link[corpcor]{pseudoinverse}} from the
+ \code{corpcor} package instead of \link{solve}.}
+
+ \item{eps}{threshold for considering entries as
+ nonnegative. This is an experimental parameter, and it is
+ recommended to leave it at 0.}
+}
+\value{
+ A list with the following elements:
+
+ \item{coef}{the fitted coefficient matrix.}
+ \item{Pset}{the set of passive constraints, as a logical
+ matrix of the same size as \code{K} that indicates which
+ element is positive.}
+}
+\description{
+ This is the workhorse function for the higher-level
+ function \code{\link{fcnnls}}, which implements the fast
+ nonnegative least-square algorithm for multiple
+ right-hand-sides from \cite{Van Benthem et al. (2004)} to
+ solve the following problem:
+
+ \deqn{ \begin{array}{l} \min \|Y - X K\|_F\\ \mbox{s.t. }
+ K>=0 \end{array} }{min ||Y - X K||_F, s.t. K>=0}
+
+ where \eqn{Y} and \eqn{X} are two real matrices of
+ dimension \eqn{n \times p}{n x p} and \eqn{n \times r}{n
+ x r} respectively, and \eqn{\|.\|_F}{|.|_F} is the
+ Frobenius norm.
+
+ The algorithm is very fast compared to other approaches,
+ as it is optimised for handling multiple right-hand
+ sides.
+}
+\references{
+ Van Benthem M and Keenan MR (2004). "Fast algorithm for
+ the solution of large-scale non-negativity-constrained
+ least squares problems." _Journal of Chemometrics_,
+ *18*(10), pp. 441-450. ISSN 0886-9383, <URL:
+ http://dx.doi.org/10.1002/cem.889>, <URL:
+ http://doi.wiley.com/10.1002/cem.889>.
+}
+
diff --git a/man/esGolub.Rd b/man/esGolub.Rd
new file mode 100644
index 0000000..788dbc3
--- /dev/null
+++ b/man/esGolub.Rd
@@ -0,0 +1,81 @@
+\docType{data}
+\name{esGolub}
+\alias{esGolub}
+\title{Golub ExpressionSet}
+\format{There are 3 covariates listed.
+
+\itemize{
+
+\item Samples: The original sample labels. \item ALL.AML: Whether the
+patient had AML or ALL. It is a \code{\link{factor}} with levels
+\code{c('ALL', 'AML')}. \item Cell: ALL arises from two different types of
+lymphocytes (T-cell and B-cell). This specifies which for the ALL patients;
+There is no such information for the AML samples. It is a
+\code{\link{factor}} with levels \code{c('T-cell', 'B-cell', NA)}.
+
+}}
+\source{
+ Web page for \cite{Brunet2004}:\cr
+ \url{http://www.broadinstitute.org/publications/broad872}
+
+ Original data from Golub et al.:\cr
+ \code{http://www-genome.wi.mit.edu/mpr/data_set_ALL_AML.html}
+}
+\description{
+ This data comes originally from the gene expression data
+ from \cite{Golub et al. (1999)}. The version included in
+ the package is the one used and referenced in
+ \cite{Brunet et al. (2004)}. The samples are from 27
+ patients with acute lymphoblastic leukemia (ALL) and 11
+ patients with acute myeloid leukemia (AML).
+}
+\details{
+ The samples were assayed using Affymetrix Hgu6800 chips
+ and the original data on the expression of 7129 genes
+ (Affymetrix probes) are available on the Broad Institute
+ web site (see references below).
+
+ The data in \code{esGolub} were obtained from the web
+ page related to the paper from \cite{Brunet et al.
+ (2004)}, which describes an application of Nonnegative
+ Matrix Factorization to gene expression clustering. (see
+ link in section \emph{Source}).
+
+ They contain the 5,000 most highly varying genes
+ according to their coefficient of variation, and were
+ installed in an object of class
+ \code{\link[Biobase]{ExpressionSet-class}}.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# requires package Biobase to be installed
+if( require(Biobase) ){
+
+ data(esGolub)
+ esGolub
+ \dontrun{pData(esGolub)}
+
+}
+}
+\references{
+ Golub TR, Slonim DK, Tamayo P, Huard C, Gaasenbeek M,
+ Mesirov JP, Coller H, Loh ML, Downing JR, Caligiuri Ma,
+ Bloomfield CD and Lander ES (1999). "Molecular
+ classification of cancer: class discovery and class
+ prediction by gene expression monitoring." _Science (New
+ York, N.Y.)_, *286*(5439), pp. 531-7. ISSN 0036-8075,
+ <URL: http://www.ncbi.nlm.nih.gov/pubmed/10521349>.
+
+ Brunet J, Tamayo P, Golub TR and Mesirov JP (2004).
+ "Metagenes and molecular pattern discovery using matrix
+ factorization." _Proceedings of the National Academy of
+ Sciences of the United States of America_, *101*(12), pp.
+ 4164-9. ISSN 0027-8424, <URL:
+ http://dx.doi.org/10.1073/pnas.0308531101>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/15016911>.
+}
+\keyword{datasets}
+
diff --git a/man/fcnnls.Rd b/man/fcnnls.Rd
new file mode 100644
index 0000000..ae32af8
--- /dev/null
+++ b/man/fcnnls.Rd
@@ -0,0 +1,169 @@
+\docType{methods}
+\name{fcnnls}
+\alias{fcnnls}
+\alias{fcnnls,ANY,numeric-method}
+\alias{fcnnls,matrix,matrix-method}
+\alias{fcnnls-methods}
+\alias{fcnnls,numeric,matrix-method}
+\title{Fast Combinatorial Nonnegative Least-Square}
+\usage{
+ fcnnls(x, y, ...)
+
+ \S4method{fcnnls}{matrix,matrix}(x, y, verbose = FALSE,
+ pseudo = TRUE, ...)
+}
+\arguments{
+ \item{...}{extra arguments passed to the internal
+ function \code{.fcnnls}. Currently not used.}
+
+ \item{verbose}{toggle verbosity (default is
+ \code{FALSE}).}
+
+ \item{x}{the coefficient matrix}
+
+ \item{y}{the target matrix to be approximated by \eqn{X
+ K}.}
+
+ \item{pseudo}{By default (\code{pseudo=FALSE}) the
+ algorithm uses Gaussian elimination to solve the
+ successive internal linear problems, using the
+ \code{\link{solve}} function. If \code{pseudo=TRUE} the
+ algorithm uses Moore-Penrose generalized
+ \code{\link[corpcor]{pseudoinverse}} from the
+ \code{corpcor} package instead of \link{solve}.}
+}
+\value{
+ A list containing the following components:
+
+ \item{x}{ the estimated optimal matrix \eqn{K}.}
+ \item{fitted}{ the fitted matrix \eqn{X K}.}
+ \item{residuals}{ the residual matrix \eqn{Y - X K}.}
+ \item{deviance}{ the residual sum of squares between the
+ fitted matrix \eqn{X K} and the target matrix \eqn{Y}.
+ That is the sum of the square residuals.} \item{passive}{
+ a \eqn{r x p} logical matrix containing the passive set,
+ that is the set of entries in \eqn{K} that are not null
+ (i.e. strictly positive).} \item{pseudo}{ a logical that
+ is \code{TRUE} if the computation was performed using the
+ pseudoinverse. See argument \code{pseudo}.}
+}
+\description{
+ This function solves the following nonnegative least
+ square linear problem using normal equations and the fast
+ combinatorial strategy from \cite{Van Benthem et al.
+ (2004)}:
+
+ \deqn{ \begin{array}{l} \min \|Y - X K\|_F\\ \mbox{s.t. }
+ K>=0 \end{array} }{min ||Y - X K||_F, s.t. K>=0}
+
+ where \eqn{Y} and \eqn{X} are two real matrices of
+ dimension \eqn{n \times p}{n x p} and \eqn{n \times r}{n
+ x r} respectively, and \eqn{\|.\|_F}{|.|_F} is the
+ Frobenius norm.
+
+ The algorithm is very fast compared to other approaches,
+ as it is optimised for handling multiple right-hand
+ sides.
+}
+\details{
+ Within the \code{NMF} package, this algorithm is used
+ internally by the SNMF/R(L) algorithm from \cite{Kim et
+ al. (2007)} to solve general Nonnegative Matrix
+ Factorization (NMF) problems, using alternating
+ nonnegative constrained least-squares. That is by
+ iteratively and alternatively estimate each matrix
+ factor.
+
+ The algorithm is an active/passive set method, which
+ rearrange the right-hand side to reduce the number of
+ pseudo-inverse calculations. It uses the unconstrained
+ solution \eqn{K_u} obtained from the unconstrained least
+ squares problem, i.e. \eqn{\min \|Y - X K\|_F^2}{min ||Y
+ - X K||_F^2} , so as to determine the initial passive
+ sets.
+
+ The function \code{fcnnls} is provided separately so that
+ it can be used to solve other types of nonnegative least
+ squares problem. For faster computation, when multiple
+ nonnegative least square fits are needed, it is
+ recommended to directly use the function
+ \code{\link{.fcnnls}}.
+
+ The code of this function is a port from the original
+ MATLAB code provided by \cite{Kim et al. (2007)}.
+}
+\section{Methods}{
+ \describe{
+
+ \item{fcnnls}{\code{signature(x = "matrix", y =
+ "matrix")}: This method wraps a call to the internal
+ function \code{.fcnnls}, and formats the results in a
+ similar way as other lest-squares methods such as
+ \code{\link{lm}}. }
+
+ \item{fcnnls}{\code{signature(x = "numeric", y =
+ "matrix")}: Shortcut for \code{fcnnls(as.matrix(x), y,
+ ...)}. }
+
+ \item{fcnnls}{\code{signature(x = "ANY", y = "numeric")}:
+ Shortcut for \code{fcnnls(x, as.matrix(y), ...)}. }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+## Define a random nonnegative matrix matrix
+n <- 200; p <- 20; r <- 3
+V <- rmatrix(n, p)
+
+## Compute the optimal matrix K for a given X matrix
+X <- rmatrix(n, r)
+res <- fcnnls(X, V)
+
+## Compute the same thing using the Moore-Penrose generalized pseudoinverse
+res <- fcnnls(X, V, pseudo=TRUE)
+
+## It also works in the case of single vectors
+y <- runif(n)
+res <- fcnnls(X, y)
+# or
+res <- fcnnls(X[,1], y)
+}
+\author{
+ Original MATLAB code : Van Benthem and Keenan
+
+ Adaption of MATLAB code for SNMF/R(L): H. Kim
+
+ Adaptation to the NMF package framework: Renaud Gaujoux
+}
+\references{
+ Original MATLAB code from Van Benthem and Keenan,
+ slightly modified by H. Kim:\cr
+ \url{http://www.cc.gatech.edu/~hpark/software/fcnnls.m}
+
+ Van Benthem M and Keenan MR (2004). "Fast algorithm for
+ the solution of large-scale non-negativity-constrained
+ least squares problems." _Journal of Chemometrics_,
+ *18*(10), pp. 441-450. ISSN 0886-9383, <URL:
+ http://dx.doi.org/10.1002/cem.889>, <URL:
+ http://doi.wiley.com/10.1002/cem.889>.
+
+ Kim H and Park H (2007). "Sparse non-negative matrix
+ factorizations via alternating non-negativity-constrained
+ least squares for microarray data analysis."
+ _Bioinformatics (Oxford, England)_, *23*(12), pp.
+ 1495-502. ISSN 1460-2059, <URL:
+ http://dx.doi.org/10.1093/bioinformatics/btm134>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/17483501>.
+}
+\seealso{
+ \code{\link{nmf}}
+}
+\keyword{methods}
+\keyword{multivariate}
+\keyword{optimize}
+\keyword{regression}
+
diff --git a/man/fit.Rd b/man/fit.Rd
new file mode 100644
index 0000000..e43661b
--- /dev/null
+++ b/man/fit.Rd
@@ -0,0 +1,123 @@
+\docType{methods}
+\name{fit}
+\alias{fit}
+\alias{fit<-}
+\alias{fit<--methods}
+\alias{fit-methods}
+\alias{fit,NMFfit-method}
+\alias{fit<-,NMFfit,NMF-method}
+\alias{fit,NMFfitX1-method}
+\alias{fit,NMFfitX-method}
+\alias{fit,NMFfitXn-method}
+\alias{minfit}
+\alias{minfit-methods}
+\alias{minfit,NMFfit-method}
+\alias{minfit,NMFfitX1-method}
+\alias{minfit,NMFfitX-method}
+\alias{minfit,NMFfitXn-method}
+\title{Extracting Fitted Models}
+\usage{
+ fit(object, ...)
+
+ fit(object)<-value
+
+ minfit(object, ...)
+}
+\arguments{
+ \item{object}{an object fitted by some algorithm, e.g. as
+ returned by the function \code{\link{nmf}}.}
+
+ \item{value}{replacement value}
+
+ \item{...}{extra arguments to allow extension}
+}
+\description{
+ The functions \code{fit} and \code{minfit} are S4
+ genetics that extract the best model object and the best
+ fit object respectively, from a collection of models or
+ from a wrapper object.
+
+ \code{fit<-} sets the fitted model in a fit object. It is
+ meant to be called only when developing new NMF
+ algorithms, e.g. to update the value of the model stored
+ in the starting point.
+}
+\details{
+ A fit object differs from a model object in that it
+ contains data about the fit, such as the initial RNG
+ settings, the CPU time used, etc\ldots, while a model
+ object only contains the actual modelling data such as
+ regression coefficients, loadings, etc\ldots
+
+ That best model is generally defined as the one that
+ achieves the maximum/minimum some quantitative measure,
+ amongst all models in a collection.
+
+ In the case of NMF models, the best model is the one that
+ achieves the best approximation error, according to the
+ objective function associated with the algorithm that
+ performed the fit(s).
+}
+\section{Methods}{
+ \describe{
+
+ \item{fit}{\code{signature(object = "NMFfit")}: Returns
+ the NMF model object stored in slot \code{'fit'}. }
+
+ \item{fit}{\code{signature(object = "NMFfitX")}: Returns
+ the model object that achieves the lowest residual
+ approximation error across all the runs.
+
+ It is a pure virtual method defined to ensure \code{fit}
+ is defined for sub-classes of \code{NMFfitX}, which
+ throws an error if called. }
+
+ \item{fit}{\code{signature(object = "NMFfitX1")}: Returns
+ the model object associated with the best fit, amongst
+ all the runs performed when fitting \code{object}.
+
+ Since \code{NMFfitX1} objects only hold the best fit,
+ this method simply returns the NMF model fitted by
+ \code{object} -- that is stored in slot \sQuote{fit}. }
+
+ \item{fit}{\code{signature(object = "NMFfitXn")}: Returns
+ the best NMF fit object amongst all the fits stored in
+ \code{object}, i.e. the fit that achieves the lowest
+ estimation residuals. }
+
+ \item{fit<-}{\code{signature(object = "NMFfit", value =
+ "NMF")}: Updates the NMF model object stored in slot
+ \code{'fit'} with a new value. }
+
+ \item{minfit}{\code{signature(object = "NMFfit")}:
+ Returns the object its self, since there it is the result
+ of a single NMF run. }
+
+ \item{minfit}{\code{signature(object = "NMFfitX")}:
+ Returns the fit object that achieves the lowest residual
+ approximation error across all the runs.
+
+ It is a pure virtual method defined to ensure
+ \code{minfit} is defined for sub-classes of
+ \code{NMFfitX}, which throws an error if called. }
+
+ \item{minfit}{\code{signature(object = "NMFfitX1")}:
+ Returns the fit object associated with the best fit,
+ amongst all the runs performed when fitting
+ \code{object}.
+
+ Since \code{NMFfitX1} objects only hold the best fit,
+ this method simply returns \code{object} coerced into an
+ \code{NMFfit} object. }
+
+ \item{minfit}{\code{signature(object = "NMFfitXn")}:
+ Returns the best NMF model in the list, i.e. the run that
+ achieved the lower estimation residuals.
+
+ The model is selected based on its \code{deviance} value.
+ }
+
+ }
+}
+\keyword{methods}
+
diff --git a/man/fitted.Rd b/man/fitted.Rd
new file mode 100644
index 0000000..59ffd9c
--- /dev/null
+++ b/man/fitted.Rd
@@ -0,0 +1,120 @@
+\docType{methods}
+\name{fitted}
+\alias{fitted}
+\alias{fitted-methods}
+\alias{fitted,NMFfit-method}
+\alias{fitted,NMF-method}
+\alias{fitted,NMFns-method}
+\alias{fitted,NMFOffset-method}
+\alias{fitted,NMFstd-method}
+\title{Fitted Matrix in NMF Models}
+\usage{
+ fitted(object, ...)
+
+ \S4method{fitted}{NMFstd}(object, W, H, ...)
+
+ \S4method{fitted}{NMFOffset}(object, W, H,
+ offset = object at offset)
+
+ \S4method{fitted}{NMFns}(object, W, H, S, ...)
+}
+\arguments{
+ \item{object}{an object that inherit from class
+ \code{NMF}}
+
+ \item{...}{extra arguments to allow extension}
+
+ \item{W}{a matrix to use in the computation as the basis
+ matrix in place of \code{basis(object)}. It must be
+ compatible with the coefficient matrix used in the
+ computation (i.e. number of columns in \code{W} = number
+ of rows in \code{H}).}
+
+ \item{H}{a matrix to use in the computation as the
+ coefficient matrix in place of \code{coef(object)}. It
+ must be compatible with the basis matrix used in the
+ computation (i.e. number of rows in \code{H} = number of
+ columns in \code{W}).}
+
+ \item{offset}{offset vector}
+
+ \item{S}{smoothing matrix to use instead of
+ \code{smoothing(object)} It must be a square matrix
+ compatible with the basis and coefficient matrices used
+ in the computation.}
+}
+\value{
+ the target matrix estimate as fitted by the model
+ \code{object}
+}
+\description{
+ Computes the estimated target matrix based on a given
+ \emph{NMF} model. The estimation depends on the
+ underlying NMF model. For example in the standard model
+ \eqn{V \equiv W H}{V ~ W H}, the target matrix is
+ estimated by the matrix product \eqn{W H}. In other
+ models, the estimate may depend on extra
+ parameters/matrix (cf. Non-smooth NMF in
+ \code{\link{NMFns-class}}).
+}
+\details{
+ This function is a S4 generic function imported from
+ \link[stats]{fitted} in the package \emph{stats}. It is
+ implemented as a pure virtual method for objects of class
+ \code{NMF}, meaning that concrete NMF models must provide
+ a definition for their corresponding class (i.e.
+ sub-classes of class \code{NMF}). See
+ \code{\linkS4class{NMF}} for more details.
+}
+\section{Methods}{
+ \describe{
+
+ \item{fitted}{\code{signature(object = "NMF")}: Pure
+ virtual method for objects of class
+ \code{\linkS4class{NMF}}, that should be overloaded by
+ sub-classes, and throws an error if called. }
+
+ \item{fitted}{\code{signature(object = "NMFstd")}:
+ Compute the target matrix estimate in \emph{standard NMF
+ models}.
+
+ The estimate matrix is computed as the product of the two
+ matrix slots \code{W} and \code{H}: \deqn{\hat{V} = W
+ H}{V ~ W H} }
+
+ \item{fitted}{\code{signature(object = "NMFOffset")}:
+ Computes the target matrix estimate for an NMFOffset
+ object.
+
+ The estimate is computed as: \deqn{ W H + offset } }
+
+ \item{fitted}{\code{signature(object = "NMFns")}: Compute
+ estimate for an NMFns object, according to the Nonsmooth
+ NMF model (cf. \code{\link{NMFns-class}}).
+
+ Extra arguments in \code{...} are passed to method
+ \code{smoothing}, and are typically used to pass a value
+ for \code{theta}, which is used to compute the smoothing
+ matrix instead of the one stored in \code{object}. }
+
+ \item{fitted}{\code{signature(object = "NMFfit")}:
+ Computes and return the estimated target matrix from an
+ NMF model fitted with function \code{\link{nmf}}.
+
+ It is a shortcut for \code{fitted(fit(object), ...)},
+ dispatching the call to the \code{fitted} method of the
+ actual NMF model. }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# random standard NMF model
+x <- rnmf(3, 10, 5)
+all.equal(fitted(x), basis(x) \%*\% coef(x))
+}
+\keyword{methods}
+
diff --git a/man/foreach.Rd b/man/foreach.Rd
new file mode 100644
index 0000000..7d282ac
--- /dev/null
+++ b/man/foreach.Rd
@@ -0,0 +1,164 @@
+\docType{methods}
+\name{registerDoBackend}
+\alias{ForeachBackend}
+\alias{ForeachBackend,ANY-method}
+\alias{ForeachBackend,character-method}
+\alias{ForeachBackend,cluster-method}
+\alias{ForeachBackend,doMPI_backend-method}
+\alias{ForeachBackend,doParallel_backend-method}
+\alias{ForeachBackend,doParallelMC_backend-method}
+\alias{ForeachBackend,doParallelSNOW_backend-method}
+\alias{ForeachBackend,doPSOCK_backend-method}
+\alias{ForeachBackend-methods}
+\alias{ForeachBackend,missing-method}
+\alias{ForeachBackend,mpicluster-method}
+\alias{ForeachBackend,NULL-method}
+\alias{ForeachBackend,numeric-method}
+\alias{getDoBackend}
+\alias{getDoParHosts}
+\alias{getDoParHosts,ANY-method}
+\alias{getDoParHosts-methods}
+\alias{getDoParNHosts}
+\alias{register}
+\alias{registerDoBackend}
+\alias{setDoBackend}
+\title{Utilities and Extensions for Foreach Loops}
+\usage{
+ registerDoBackend(object, ...)
+
+ getDoBackend()
+
+ setDoBackend(data, cleanup = FALSE)
+
+ register(x, ...)
+
+ ForeachBackend(object, ...)
+
+ \S4method{ForeachBackend}{doParallel_backend}(object, cl,
+ type = NULL)
+
+ \S4method{ForeachBackend}{doPSOCK_backend}(object, cl)
+
+ \S4method{ForeachBackend}{doMPI_backend}(object, cl)
+
+ getDoParHosts(object, ...)
+
+ getDoParNHosts(object)
+}
+\arguments{
+ \item{object}{specification of a foreach backend, e.g.
+ \sQuote{SEQ}, \sQuote{PAR} (for doParallel),
+ \sQuote{MPI}, etc\ldots}
+
+ \item{...}{extra arguments passed to the backend own
+ registration function.}
+
+ \item{data}{internal data of a foreach \%dopar\%
+ backend.}
+
+ \item{cleanup}{logical that indicates if the previous
+ backend's cleanup procedure should be run,
+ \strong{before} setting the new backend.}
+
+ \item{x}{specification of a foreach backend}
+
+ \item{cl}{cluster specification: a cluster object or a
+ numeric that indicates the number of nodes to use.}
+
+ \item{type}{type of cluster, See
+ \code{\link[parallel]{makeCluster}}.}
+}
+\description{
+ \code{registerDoBackend} is a unified register function
+ for foreach backends.
+
+ \code{getDoBackend} returns the internal data of the
+ currently registered foreach \%dopar\% backend.
+
+ \code{setDoBackend} is identical to
+ \code{\link[foreach]{setDoPar}}, but returns the internal
+ of the previously registered backend.
+
+ \code{register} is a generic function that register
+ objects. It is used to as a unified interface to register
+ foreach backends.
+
+ \code{ForeachBackend} is a factory method for foreach
+ backend objects.
+
+ \code{getDoParHosts} is a generic function that returns
+ the hostname of the worker nodes used by a backend.
+
+ \code{getDoParNHosts} returns the number of hosts used by
+ a backend.
+}
+\section{Methods}{
+ \describe{
+
+ \item{ForeachBackend}{\code{signature(object = "ANY")}:
+ Default method defined to throw an informative error
+ message, when no other method was found. }
+
+ \item{ForeachBackend}{\code{signature(object =
+ "character")}: Creates a foreach backend object based on
+ its name. }
+
+ \item{ForeachBackend}{\code{signature(object =
+ "missing")}: Creates a foreach backend object for the
+ currently registered backend. }
+
+ \item{ForeachBackend}{\code{signature(object = "NULL")}:
+ Dummy method that returns \code{NULL}, defined for
+ correct dispatch. }
+
+ \item{ForeachBackend}{\code{signature(object =
+ "cluster")}: Creates a doParallel foreach backend that
+ uses the cluster described in \code{object}. }
+
+ \item{ForeachBackend}{\code{signature(object =
+ "numeric")}: Creates a doParallel foreach backend with
+ \code{object} processes. }
+
+ \item{ForeachBackend}{\code{signature(object =
+ "doParallel_backend")}: doParallel-specific backend
+ factory }
+
+ \item{ForeachBackend}{\code{signature(object =
+ "doParallelMC_backend")}: doParallel-specific backend
+ factory for multicore (fork) clusters
+
+ This method is needed since version 1.0.7 of
+ \pkg{doParallel}, which removed internal function
+ \code{info} and defined separate backend names for mc and
+ snow clusters. }
+
+ \item{ForeachBackend}{\code{signature(object =
+ "doParallelSNOW_backend")}: doParallel-specific backend
+ factory for SNOW clusters.
+
+ This method is needed since version 1.0.7 of
+ \pkg{doParallel}, which removed internal function
+ \code{info} and defined separate backend names for mc and
+ snow clusters. }
+
+ \item{ForeachBackend}{\code{signature(object =
+ "doPSOCK_backend")}: doSNOW-specific backend factory }
+
+ \item{ForeachBackend}{\code{signature(object =
+ "mpicluster")}: Creates a doMPI foreach backend that uses
+ the MPI cluster described in \code{object}. }
+
+ \item{ForeachBackend}{\code{signature(object =
+ "doMPI_backend")}: doMPI-specific backend factory }
+
+ \item{getDoParHosts}{\code{signature(object = "ANY")}:
+ Default method that tries to heuristaically infer the
+ number of hosts and in last resort temporarly register
+ the backend and performs a foreach loop, to retrieve the
+ nodename from each worker. }
+
+ }
+}
+\keyword{internal}
+\keyword{methods}
+
diff --git a/man/gfile.Rd b/man/gfile.Rd
new file mode 100644
index 0000000..30b47fa
--- /dev/null
+++ b/man/gfile.Rd
@@ -0,0 +1,11 @@
+\name{gfile}
+\alias{gfile}
+\title{Open a File Graphic Device}
+\usage{
+ gfile(filename, width, height, ...)
+}
+\description{
+ Opens a graphic device depending on the file extension
+}
+\keyword{internal}
+
diff --git a/man/grid.Rd b/man/grid.Rd
new file mode 100644
index 0000000..726e838
--- /dev/null
+++ b/man/grid.Rd
@@ -0,0 +1,44 @@
+\name{tryViewport}
+\alias{current.vpPath_patched}
+\alias{tryViewport}
+\alias{.use.grid.patch}
+\title{Internal Grid Extension}
+\usage{
+ tryViewport(name, verbose = FALSE)
+
+ current.vpPath_patched()
+
+ .use.grid.patch()
+}
+\arguments{
+ \item{name}{viewport name}
+
+ \item{verbose}{toggle verbosity}
+}
+\description{
+ These functions enable mixing base and grid graphics in
+ \code{\link{aheatmap}}, by avoiding calls to the grid
+ internal function \code{'L_gridDirty'}. They are not
+ exported (i.e. not tampering core functions) and are only
+ meant for internal use within the \pkg{NMF} package.
+
+ \code{tryViewport} tries to go down to a viewport in the
+ current tree, given its name.
+
+ \code{current.vpPath_patched} aims at substituting
+ \code{\link[grid]{current.vpPath}}, so that the graphic
+ engine is not reset. This is essentially to prevent
+ outputting a blank page at the beginning of PDF graphic
+ engines.
+
+ \code{.use.grid.patch} tells if the user enabled patching
+ grid.
+}
+\details{
+ \code{tryViewport} uses \code{\link[grid]{grid.ls}} and
+ not \code{\link{seekViewport}} as the latter would reset
+ the graphic device and break the mix grid/base graphic
+ capability.
+}
+\keyword{internal}
+
diff --git a/man/heatmaps.Rd b/man/heatmaps.Rd
new file mode 100644
index 0000000..5b9f073
--- /dev/null
+++ b/man/heatmaps.Rd
@@ -0,0 +1,413 @@
+\docType{methods}
+\name{heatmap-NMF}
+\alias{basismap}
+\alias{basismap-methods}
+\alias{basismap,NMFfitX-method}
+\alias{basismap,NMF-method}
+\alias{coefmap}
+\alias{coefmap-methods}
+\alias{coefmap,NMFfitX-method}
+\alias{coefmap,NMF-method}
+\alias{consensusmap}
+\alias{consensusmap,matrix-method}
+\alias{consensusmap-methods}
+\alias{consensusmap,NMFfitX-method}
+\alias{consensusmap,NMF-method}
+\alias{heatmap-NMF}
+\title{Heatmaps of NMF Factors}
+\usage{
+ basismap(object, ...)
+
+ \S4method{basismap}{NMF}(object, color = "YlOrRd:50",
+ scale = "r1", Rowv = TRUE, Colv = NA,
+ subsetRow = FALSE, annRow = NA, annCol = NA,
+ tracks = "basis", main = "Basis components",
+ info = FALSE, ...)
+
+ coefmap(object, ...)
+
+ \S4method{coefmap}{NMF}(object, color = "YlOrRd:50",
+ scale = "c1", Rowv = NA, Colv = TRUE, annRow = NA,
+ annCol = NA, tracks = "basis",
+ main = "Mixture coefficients", info = FALSE, ...)
+
+ consensusmap(object, ...)
+
+ \S4method{consensusmap}{NMFfitX}(object, annRow = NA,
+ annCol = NA,
+ tracks = c("basis:", "consensus:", "silhouette:"),
+ main = "Consensus matrix", info = FALSE, ...)
+
+ \S4method{consensusmap}{matrix}(object,
+ color = "-RdYlBu",
+ distfun = function(x) as.dist(1 - x),
+ hclustfun = "average", Rowv = TRUE, Colv = "Rowv",
+ main = if (is.null(nr) || nr > 1) "Consensus matrix" else "Connectiviy matrix",
+ info = FALSE, ...)
+
+ \S4method{coefmap}{NMFfitX}(object, Colv = TRUE,
+ annRow = NA, annCol = NA,
+ tracks = c("basis", "consensus:"), ...)
+}
+\arguments{
+ \item{object}{an object from which is extracted NMF
+ factors or a consensus matrix}
+
+ \item{...}{extra arguments passed to
+ \code{\link{aheatmap}}.}
+
+ \item{subsetRow}{Argument that specifies how to filter
+ the rows that will appear in the heatmap. When
+ \code{FALSE} (default), all rows are used. Besides the
+ values supported by argument \code{subsetRow} of
+ \code{\link{aheatmap}}, other possible values are:
+
+ \itemize{ \item \code{TRUE}: only the rows that are
+ basis-specific are used. The default selection method is
+ from \cite{KimH2007}. This is equivalent to
+ \code{subsetRow='kim'}.
+
+ \item a single \code{character} string or numeric value
+ that specifies the method to use to select the
+ basis-specific rows, that should appear in the heatmap
+ (cf. argument \code{method} for function
+ \code{\link{extractFeatures}}).
+
+ Note \code{\link{extractFeatures}} is called with
+ argument \code{nodups=TRUE}, so that features that are
+ selected for multiple components only appear once. }}
+
+ \item{tracks}{Special additional annotation tracks to
+ highlight associations between basis components and
+ sample clusters: \describe{ \item{basis}{matches each row
+ (resp. column) to the most contributing basis component
+ in \code{basismap} (resp. \code{coefmap}). In
+ \code{basismap} (resp. \code{coefmap}), adding a track
+ \code{':basis'} to \code{annCol} (resp. \code{annRow})
+ makes the column (resp. row) corresponding to the
+ component being also highlited using the mathcing
+ colours.} }}
+
+ \item{info}{if \code{TRUE} then the name of the algorithm
+ that fitted the NMF model is displayed at the bottom of
+ the plot, if available. Other wise it is passed as is to
+ \code{aheatmap}.}
+
+ \item{color}{colour specification for the heatmap.
+ Default to palette '-RdYlBu2:100', i.e. reversed palette
+ 'RdYlBu2' (a slight modification of RColorBrewer's
+ palette 'RdYlBu') with 100 colors. Possible values are:
+ \itemize{ \item a character/integer vector of length
+ greater than 1 that is directly used and assumed to
+ contain valid R color specifications. \item a single
+ color/integer (between 0 and 8)/other numeric value that
+ gives the dominant colors. Numeric values are converted
+ into a pallete by \code{rev(sequential_hcl(2, h = x, l =
+ c(50, 95)))}. Other values are concatenated with the grey
+ colour '#F1F1F1'. \item one of RColorBrewer's palette
+ name (see \code{\link[RColorBrewer]{display.brewer.all}})
+ , or one of 'RdYlBu2', 'rainbow', 'heat', 'topo',
+ 'terrain', 'cm'. } When the coluor palette is specified
+ with a single value, and is negative or preceded a minus
+ ('-'), the reversed palette is used. The number of breaks
+ can also be specified after a colon (':'). For example,
+ the default colour palette is specified as
+ '-RdYlBu2:100'.}
+
+ \item{scale}{character indicating how the values should
+ scaled in either the row direction or the column
+ direction. Note that the scaling is performed after
+ row/column clustering, so that it has no effect on the
+ row/column ordering. Possible values are: \itemize{ \item
+ \code{"row"}: center and standardize each row separately
+ to row Z-scores \item \code{"column"}: center and
+ standardize each column separately to column Z-scores
+ \item \code{"r1"}: scale each row to sum up to one \item
+ \code{"c1"}: scale each column to sum up to one \item
+ \code{"none"}: no scaling }}
+
+ \item{Rowv}{clustering specification(s) for the rows. It
+ allows to specify the
+ distance/clustering/ordering/display parameters to be
+ used for the \emph{rows only}. Possible values are:
+ \itemize{ \item \code{TRUE} or \code{NULL} (to be
+ consistent with \code{\link{heatmap}}): compute a
+ dendrogram from hierarchical clustering using the
+ distance and clustering methods \code{distfun} and
+ \code{hclustfun}.
+
+ \item \code{NA}: disable any ordering. In this case, and
+ if not otherwise specified with argument
+ \code{revC=FALSE}, the heatmap shows the input matrix
+ with the rows in their original order, with the first row
+ on top to the last row at the bottom. Note that this
+ differ from the behaviour or \code{\link{heatmap}}, but
+ seemed to be a more sensible choice when vizualizing a
+ matrix without reordering.
+
+ \item an integer vector of length the number of rows of
+ the input matrix (\code{nrow(x)}), that specifies the row
+ order. As in the case \code{Rowv=NA}, the ordered matrix
+ is shown first row on top, last row at the bottom.
+
+ \item a character vector or a list specifying values to
+ use instead of arguments \code{distfun}, \code{hclustfun}
+ and \code{reorderfun} when clustering the rows (see the
+ respective argument descriptions for a list of accepted
+ values). If \code{Rowv} has no names, then the first
+ element is used for \code{distfun}, the second (if
+ present) is used for \code{hclustfun}, and the third (if
+ present) is used for \code{reorderfun}.
+
+ \item a numeric vector of weights, of length the number
+ of rows of the input matrix, used to reorder the
+ internally computed dendrogram \code{d} by
+ \code{reorderfun(d, Rowv)}.
+
+ \item \code{FALSE}: the dendrogram \emph{is} computed
+ using methods \code{distfun}, \code{hclustfun}, and
+ \code{reorderfun} but is not shown.
+
+ \item a single integer that specifies how many subtrees
+ (i.e. clusters) from the computed dendrogram should have
+ their root faded out. This can be used to better
+ highlight the different clusters.
+
+ \item a single double that specifies how much space is
+ used by the computed dendrogram. That is that this value
+ is used in place of \code{treeheight}. }}
+
+ \item{Colv}{clustering specification(s) for the columns.
+ It accepts the same values as argument \code{Rowv}
+ (modulo the expected length for vector specifications),
+ and allow specifying the
+ distance/clustering/ordering/display parameters to be
+ used for the \emph{columns only}. \code{Colv} may also be
+ set to \code{"Rowv"}, in which case the dendrogram or
+ ordering specifications applied to the rows are also
+ applied to the columns. Note that this is allowed only
+ for square input matrices, and that the row ordering is
+ in this case by default reversed (\code{revC=TRUE}) to
+ obtain the diagonal in the standard way (from top-left to
+ bottom-right). See argument \code{Rowv} for other
+ possible values.}
+
+ \item{annRow}{specifications of row annotation tracks
+ displayed as coloured columns on the left of the
+ heatmaps. The annotation tracks are drawn from left to
+ right. The same conversion, renaming and colouring rules
+ as for argument \code{annCol} apply.}
+
+ \item{annCol}{specifications of column annotation tracks
+ displayed as coloured rows on top of the heatmaps. The
+ annotation tracks are drawn from bottom to top. A single
+ annotation track can be specified as a single vector;
+ multiple tracks are specified as a list, a data frame, or
+ an
+ \code{\link[Biobase:ExpressionSet-class]{ExpressionSet}}
+ object, in which case the phenotypic data is used
+ (\code{pData(eset)}). Character or integer vectors are
+ converted and displayed as factors. Unnamed tracks are
+ internally renamed into \code{Xi}, with i being
+ incremented for each unamed track, across both column and
+ row annotation tracks. For each track, if no
+ corresponding colour is specified in argument
+ \code{annColors}, a palette or a ramp is automatically
+ computed and named after the track's name.}
+
+ \item{main}{Main title as a character string or a grob.}
+
+ \item{distfun}{default distance measure used in
+ clustering rows and columns. Possible values are:
+ \itemize{ \item all the distance methods supported by
+ \code{\link{dist}} (e.g. "euclidean" or "maximum").
+
+ \item all correlation methods supported by
+ \code{\link{cor}}, such as \code{"pearson"} or
+ \code{"spearman"}. The pairwise distances between
+ rows/columns are then computed as \code{d <- dist(1 -
+ cor(..., method = distfun))}.
+
+ One may as well use the string "correlation" which is an
+ alias for "pearson".
+
+ \item an object of class \code{dist} such as returned by
+ \code{\link{dist}} or \code{\link{as.dist}}. }}
+
+ \item{hclustfun}{default clustering method used to
+ cluster rows and columns. Possible values are: \itemize{
+ \item a method name (a character string) supported by
+ \code{\link{hclust}} (e.g. \code{'average'}). \item an
+ object of class \code{hclust} such as returned by
+ \code{\link{hclust}} \item a dendrogram }}
+}
+\description{
+ The NMF package ships an advanced heatmap engine
+ implemented by the function \code{\link{aheatmap}}. Some
+ convenience heatmap functions have been implemented for
+ NMF models, which redefine default values for some of the
+ arguments of \code{\link{aheatmap}}, hence tuning the
+ output specifically for NMF models.
+}
+\details{
+ \strong{IMPORTANT:} although they essentially have the
+ same set of arguments, their order sometimes differ
+ between them, as well as from \code{\link{aheatmap}}. We
+ therefore strongly recommend to use fully named arguments
+ when calling these functions.
+
+ \code{basimap} default values for the following arguments
+ of \code{\link{aheatmap}}: \itemize{ \item the color
+ palette; \item the scaling specification, which by
+ default scales each row separately so that they sum up to
+ one (\code{scale='r1'}); \item the column ordering which
+ is disabled; \item allowing for passing feature
+ extraction methods in argument \code{subsetRow}, that are
+ passed to \code{\link{extractFeatures}}. See argument
+ description here and therein. \item the addition of a
+ default named annotation track, that shows the dominant
+ basis component for each row (i.e. each feature).
+
+ This track is specified in argument \code{tracks} (see
+ its argument description). By default, a matching column
+ annotation track is also displayed, but may be disabled
+ using \code{tracks=':basis'}.
+
+ \item a suitable title and extra information like the
+ fitting algorithm, when \code{object} is a fitted NMF
+ model. }
+
+ \code{coefmap} redefines default values for the following
+ arguments of \code{\link{aheatmap}}: \itemize{ \item the
+ color palette; \item the scaling specification, which by
+ default scales each column separately so that they sum up
+ to one (\code{scale='c1'}); \item the row ordering which
+ is disabled; \item the addition of a default annotation
+ track, that shows the most contributing basis component
+ for each column (i.e. each sample).
+
+ This track is specified in argument \code{tracks} (see
+ its argument description). By default, a matching row
+ annotation track is also displayed, but can be disabled
+ using \code{tracks='basis:'}. \item a suitable title and
+ extra information like the fitting algorithm, when
+ \code{object} is a fitted NMF model. }
+
+ \code{consensusmap} redefines default values for the
+ following arguments of \code{\link{aheatmap}}: \itemize{
+ \item the colour palette; \item the column ordering which
+ is set equal to the row ordering, since a consensus
+ matrix is symmetric; \item the distance and linkage
+ methods used to order the rows (and columns). The default
+ is to use 1 minus the consensus matrix itself as
+ distance, and average linkage. \item the addition of two
+ special named annotation tracks, \code{'basis:'} and
+ \code{'consensus:'}, that show, for each column (i.e.
+ each sample), the dominant basis component in the best
+ fit and the hierarchical clustering of the consensus
+ matrix respectively (using 1-consensus as distance and
+ average linkage).
+
+ These tracks are specified in argument \code{tracks},
+ which behaves as in \code{\link{basismap}}.
+
+ \item a suitable title and extra information like the
+ type of NMF model or the fitting algorithm, when
+ \code{object} is a fitted NMF model. }
+}
+\section{Methods}{
+ \describe{
+
+ \item{basismap}{\code{signature(object = "NMF")}: Plots a
+ heatmap of the basis matrix of the NMF model
+ \code{object}. This method also works for fitted NMF
+ models (i.e. \code{NMFfit} objects). }
+
+ \item{basismap}{\code{signature(object = "NMFfitX")}:
+ Plots a heatmap of the basis matrix of the best fit in
+ \code{object}. }
+
+ \item{coefmap}{\code{signature(object = "NMF")}: The
+ default method for NMF objects has special default values
+ for some arguments of \code{\link{aheatmap}} (see
+ argument description). }
+
+ \item{coefmap}{\code{signature(object = "NMFfitX")}:
+ Plots a heatmap of the coefficient matrix of the best fit
+ in \code{object}.
+
+ This method adds: \itemize{ \item an extra special column
+ annotation track for multi-run NMF fits,
+ \code{'consensus:'}, that shows the consensus cluster
+ associated to each sample. \item a column sorting schema
+ \code{'consensus'} that can be passed to argument
+ \code{Colv} and orders the columns using the hierarchical
+ clustering of the consensus matrix with average linkage,
+ as returned by \code{\link{consensushc}(object)}. This is
+ also the ordering that is used by default for the heatmap
+ of the consensus matrix as ploted by
+ \code{\link{consensusmap}}. } }
+
+ \item{consensusmap}{\code{signature(object = "NMFfitX")}:
+ Plots a heatmap of the consensus matrix obtained when
+ fitting an NMF model with multiple runs. }
+
+ \item{consensusmap}{\code{signature(object = "NMF")}:
+ Plots a heatmap of the connectivity matrix of an NMF
+ model. }
+
+ \item{consensusmap}{\code{signature(object = "matrix")}:
+ Main method that redefines default values for arguments
+ of \code{\link{aheatmap}}. }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+#----------
+# heatmap-NMF
+#----------
+## More examples are provided in demo `heatmaps`
+\dontrun{
+demo(heatmaps)
+}
+##
+
+# random data with underlying NMF model
+v <- syntheticNMF(20, 3, 10)
+# estimate a model
+x <- nmf(v, 3)
+
+#----------
+# basismap
+#----------
+# show basis matrix
+basismap(x)
+\dontrun{
+# without the default annotation tracks
+basismap(x, tracks=NA)
+}
+
+#----------
+# coefmap
+#----------
+# coefficient matrix
+coefmap(x)
+\dontrun{
+# without the default annotation tracks
+coefmap(x, tracks=NA)
+}
+
+#----------
+# consensusmap
+#----------
+\dontrun{
+res <- nmf(x, 3, nrun=3)
+consensusmap(res)
+}
+}
+\keyword{methods}
+
diff --git a/man/inplace.Rd b/man/inplace.Rd
new file mode 100644
index 0000000..748cc2a
--- /dev/null
+++ b/man/inplace.Rd
@@ -0,0 +1,42 @@
+\name{pmax.inplace}
+\alias{neq.constraints.inplace}
+\alias{pmax.inplace}
+\title{Updating Objects In Place}
+\usage{
+ pmax.inplace(x, lim, skip = NULL)
+
+ neq.constraints.inplace(x, constraints, ratio = NULL,
+ value = NULL, copy = FALSE)
+}
+\arguments{
+ \item{x}{an object to update in place.}
+
+ \item{lim}{lower threshold value}
+
+ \item{skip}{indexes to skip}
+
+ \item{constraints}{constraint specification.}
+
+ \item{ratio}{fixed ratio on which the constraint
+ applies.}
+
+ \item{value}{fixed value to enforce.}
+
+ \item{copy}{a logical that indicates if \code{x} should
+ be updated in place or not.}
+}
+\description{
+ These functions modify objects (mainly matrix objects) in
+ place, i.e. they act directly on the C pointer. Due to
+ their side-effect, they are not meant to be called by the
+ end-user.
+
+ \code{neq.constraints.inplace} apply unequality
+ constraints in place.
+}
+\details{
+ \code{pmax.inplace} is a version of \code{\link{pmax}}
+ that updates its first argument.
+}
+\keyword{internal}
+
diff --git a/man/lsNMF-nmf.Rd b/man/lsNMF-nmf.Rd
new file mode 100644
index 0000000..c005f81
--- /dev/null
+++ b/man/lsNMF-nmf.Rd
@@ -0,0 +1,87 @@
+\name{nmf_update.lsnmf}
+\alias{lsNMF-nmf}
+\alias{nmfAlgorithm.lsNMF}
+\alias{nmf_update.lsnmf}
+\alias{wrss}
+\title{Multiplicative Updates for LS-NMF}
+\usage{
+ nmf_update.lsnmf(i, X, object, weight, eps = 10^-9, ...)
+
+ wrss(object, X, weight)
+
+ nmfAlgorithm.lsNMF(..., .stop = NULL,
+ maxIter = nmf.getOption("maxIter") \%||\% 2000, weight,
+ eps = 10^-9, stationary.th = .Machine$double.eps,
+ check.interval = 5 * check.niter, check.niter = 10L)
+}
+\arguments{
+ \item{i}{current iteration}
+
+ \item{X}{target matrix}
+
+ \item{object}{current NMF model}
+
+ \item{weight}{value for \eqn{\Sigma}{S}, i.e. the weights
+ that are applied to each entry in \code{X} by \code{X *
+ weight} (= entry wise product). Weights are usually
+ specified as a matrix of the same dimension as \code{X}
+ (e.g. uncertainty estimates for each measurement), but
+ may also be passed as a vector, in which case the
+ standard rules for entry wise product between matrices
+ and vectors apply (e.g. recylcing elements).}
+
+ \item{eps}{small number passed to the standard
+ euclidean-based NMF updates (see
+ \code{\link{nmf_update.euclidean}}).}
+
+ \item{...}{extra arguments (not used)}
+
+ \item{.stop}{specification of a stopping criterion, that
+ is used instead of the one associated to the NMF
+ algorithm. It may be specified as: \itemize{ \item the
+ access key of a registered stopping criterion; \item a
+ single integer that specifies the exact number of
+ iterations to perform, which will be honoured unless a
+ lower value is explicitly passed in argument
+ \code{maxIter}. \item a single numeric value that
+ specifies the stationnarity threshold for the objective
+ function, used in with \code{\link{nmf.stop.stationary}};
+ \item a function with signature
+ \code{(object="NMFStrategy", i="integer", y="matrix",
+ x="NMF", ...)}, where \code{object} is the
+ \code{NMFStrategy} object that describes the algorithm
+ being run, \code{i} is the current iteration, \code{y} is
+ the target matrix and \code{x} is the current value of
+ the NMF model. }}
+
+ \item{maxIter}{maximum number of iterations to perform.}
+
+ \item{stationary.th}{maximum absolute value of the
+ gradient, for the objective function to be considered
+ stationary.}
+
+ \item{check.interval}{interval (in number of iterations)
+ on which the stopping criterion is computed.}
+
+ \item{check.niter}{number of successive iteration used to
+ compute the stationnary criterion.}
+}
+\value{
+ updated object \code{object}
+}
+\description{
+ Implementation of the updates for the LS-NMF algorithm
+ from \cite{Wang et al. (2006)}.
+
+ \code{wrss} implements the objective function used by the
+ LS-NMF algorithm.
+}
+\references{
+ Wang G, Kossenkov AV and Ochs MF (2006). "LS-NMF: a
+ modified non-negative matrix factorization algorithm
+ utilizing uncertainty estimates." _BMC bioinformatics_,
+ *7*, pp. 175. ISSN 1471-2105, <URL:
+ http://dx.doi.org/10.1186/1471-2105-7-175>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/16569230>.
+}
+
diff --git a/man/lverbose.Rd b/man/lverbose.Rd
new file mode 100644
index 0000000..d661051
--- /dev/null
+++ b/man/lverbose.Rd
@@ -0,0 +1,17 @@
+\name{lverbose}
+\alias{lverbose}
+\title{Internal verbosity option}
+\usage{
+ lverbose(val)
+}
+\arguments{
+ \item{val}{logical that sets the verbosity level.}
+}
+\value{
+ the old verbose level
+}
+\description{
+ Internal verbosity option
+}
+\keyword{internal}
+
diff --git a/man/match_atrack.Rd b/man/match_atrack.Rd
new file mode 100644
index 0000000..da865be
--- /dev/null
+++ b/man/match_atrack.Rd
@@ -0,0 +1,19 @@
+\name{match_atrack}
+\alias{match_atrack}
+\title{Extending Annotation Vectors}
+\usage{
+ match_atrack(x, data = NULL)
+}
+\arguments{
+ \item{x}{annotation vector}
+
+ \item{data}{reference data}
+}
+\value{
+ a vector of the same type as \code{x}
+}
+\description{
+ Extends a vector used as an annotation track to match the
+ number of rows and the row names of a given data.
+}
+
diff --git a/man/nmf-compare.Rd b/man/nmf-compare.Rd
new file mode 100644
index 0000000..4e5b9a9
--- /dev/null
+++ b/man/nmf-compare.Rd
@@ -0,0 +1,189 @@
+\docType{methods}
+\name{compare-NMF}
+\alias{compare,list-method}
+\alias{compare-NMF}
+\alias{compare,NMFfit-method}
+\alias{consensusmap,list-method}
+\alias{consensusmap,NMF.rank-method}
+\alias{plot,NMFList,missing-method}
+\alias{summary,NMFList-method}
+\title{Comparing Results from Different NMF Runs}
+\usage{
+ \S4method{compare}{NMFfit}(object, ...)
+
+ \S4method{compare}{list}(object, ...)
+
+ \S4method{summary}{NMFList}(object, sort.by = NULL,
+ select = NULL, ...)
+
+ \S4method{plot}{NMFList,missing}(x, y, skip = -1, ...)
+
+ \S4method{consensusmap}{NMF.rank}(object, ...)
+
+ \S4method{consensusmap}{list}(object, layout,
+ Rowv = FALSE, main = names(object), ...)
+}
+\arguments{
+ \item{...}{extra arguments passed by \code{compare} to
+ \code{summary,NMFList} or to the \code{summary} method of
+ each fit.}
+
+ \item{select}{the columns to be output in the result
+ \code{data.frame}. The column are given by their names
+ (partially matched). The column names are the names of
+ the summary measures returned by the \code{summary}
+ methods of the corresponding NMF results.}
+
+ \item{sort.by}{the sorting criteria, i.e. a partial match
+ of a column name, by which the result \code{data.frame}
+ is sorted. The sorting direction (increasing or
+ decreasing) is computed internally depending on the
+ chosen criteria (e.g. decreasing for the cophenetic
+ coefficient, increasing for the residuals).}
+
+ \item{x}{an \code{NMFList} object that contains fits from
+ separate NMF runs.}
+
+ \item{y}{missing}
+
+ \item{layout}{specification of the layout. It may be a
+ single numeric or a numeric couple, to indicate a square
+ or rectangular layout respectively, that is filled row by
+ row. It may also be a matrix that is directly passed to
+ the function \code{\link[graphics]{layout}} from the
+ package \code{graphics}.}
+
+ \item{object}{an object computed using some algorithm, or
+ that describes an algorithm itself.}
+
+ \item{skip}{an integer that indicates the number of
+ points to skip/remove from the beginning of the curve. If
+ \code{skip=1L} (default) only the initial residual --
+ that is computed before any iteration, is skipped, if
+ present in the track (it associated with iteration 0).}
+
+ \item{Rowv}{clustering specification(s) for the rows. It
+ allows to specify the
+ distance/clustering/ordering/display parameters to be
+ used for the \emph{rows only}. Possible values are:
+ \itemize{ \item \code{TRUE} or \code{NULL} (to be
+ consistent with \code{\link{heatmap}}): compute a
+ dendrogram from hierarchical clustering using the
+ distance and clustering methods \code{distfun} and
+ \code{hclustfun}.
+
+ \item \code{NA}: disable any ordering. In this case, and
+ if not otherwise specified with argument
+ \code{revC=FALSE}, the heatmap shows the input matrix
+ with the rows in their original order, with the first row
+ on top to the last row at the bottom. Note that this
+ differ from the behaviour or \code{\link{heatmap}}, but
+ seemed to be a more sensible choice when vizualizing a
+ matrix without reordering.
+
+ \item an integer vector of length the number of rows of
+ the input matrix (\code{nrow(x)}), that specifies the row
+ order. As in the case \code{Rowv=NA}, the ordered matrix
+ is shown first row on top, last row at the bottom.
+
+ \item a character vector or a list specifying values to
+ use instead of arguments \code{distfun}, \code{hclustfun}
+ and \code{reorderfun} when clustering the rows (see the
+ respective argument descriptions for a list of accepted
+ values). If \code{Rowv} has no names, then the first
+ element is used for \code{distfun}, the second (if
+ present) is used for \code{hclustfun}, and the third (if
+ present) is used for \code{reorderfun}.
+
+ \item a numeric vector of weights, of length the number
+ of rows of the input matrix, used to reorder the
+ internally computed dendrogram \code{d} by
+ \code{reorderfun(d, Rowv)}.
+
+ \item \code{FALSE}: the dendrogram \emph{is} computed
+ using methods \code{distfun}, \code{hclustfun}, and
+ \code{reorderfun} but is not shown.
+
+ \item a single integer that specifies how many subtrees
+ (i.e. clusters) from the computed dendrogram should have
+ their root faded out. This can be used to better
+ highlight the different clusters.
+
+ \item a single double that specifies how much space is
+ used by the computed dendrogram. That is that this value
+ is used in place of \code{treeheight}. }}
+
+ \item{main}{Main title as a character string or a grob.}
+}
+\description{
+ The functions documented here allow to compare the fits
+ computed in different NMF runs. The fits do not need to
+ be from the same algorithm, nor have the same dimension.
+}
+\details{
+ The methods \code{compare} enables to compare multiple
+ NMF fits either passed as arguments or as a list of fits.
+ These methods eventually call the method
+ \code{summary,NMFList}, so that all its arguments can be
+ passed \strong{named} in \code{...}.
+}
+\section{Methods}{
+ \describe{
+
+ \item{compare}{\code{signature(object = "NMFfit")}:
+ Compare multiple NMF fits passed as arguments. }
+
+ \item{compare}{\code{signature(object = "list")}:
+ Compares multiple NMF fits passed as a standard list. }
+
+ \item{consensusmap}{\code{signature(object =
+ "NMF.rank")}: Draw a single plot with a heatmap of the
+ consensus matrix obtained for each value of the rank, in
+ the range tested with \code{\link{nmfEstimateRank}}. }
+
+ \item{consensusmap}{\code{signature(object = "list")}:
+ Draw a single plot with a heatmap of the consensus matrix
+ of each element in the list \code{object}. }
+
+ \item{plot}{\code{signature(x = "NMFList", y =
+ "missing")}: \code{plot} plot on a single graph the
+ residuals tracks for each fit in \code{x}. See function
+ \code{\link{nmf}} for details on how to enable the
+ tracking of residuals. }
+
+ \item{summary}{\code{signature(object = "NMFList")}:
+ \code{summary,NMFList} computes summary measures for each
+ NMF result in the list and return them in rows in a
+ \code{data.frame}. By default all the measures are
+ included in the result, and \code{NA} values are used
+ where no data is available or the measure does not apply
+ to the result object (e.g. the dispersion for single' NMF
+ runs is not meaningful). This method is very useful to
+ compare and evaluate the performance of different
+ algorithms. }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+#----------
+# compare,NMFfit-method
+#----------
+x <- rmatrix(20,10)
+res <- nmf(x, 3)
+res2 <- nmf(x, 2, 'lee')
+
+# compare arguments
+compare(res, res2, target=x)
+
+#----------
+# compare,list-method
+#----------
+# compare elements of a list
+compare(list(res, res2), target=x)
+}
+\keyword{methods}
+
diff --git a/man/nmf.Rd b/man/nmf.Rd
new file mode 100644
index 0000000..5d5c8f0
--- /dev/null
+++ b/man/nmf.Rd
@@ -0,0 +1,795 @@
+\docType{methods}
+\name{nmf}
+\alias{nmf}
+\alias{nmf,data.frame,ANY,ANY-method}
+\alias{nmf,formula,ANY,ANY-method}
+\alias{nmf,matrix,data.frame,ANY-method}
+\alias{nmf,matrix,matrix,ANY-method}
+\alias{nmf,matrix,missing,ANY-method}
+\alias{nmf,matrix,NMF,ANY-method}
+\alias{nmf,matrix,NULL,ANY-method}
+\alias{nmf,matrix,numeric,character-method}
+\alias{nmf,matrix,numeric,function-method}
+\alias{nmf,matrix,numeric,list-method}
+\alias{nmf,matrix,numeric,missing-method}
+\alias{nmf,matrix,numeric,NMFStrategy-method}
+\alias{nmf,matrix,numeric,NULL-method}
+\alias{nmf-methods}
+\title{Running NMF algorithms}
+\usage{
+ nmf(x, rank, method, ...)
+
+ \S4method{nmf}{matrix,numeric,NULL}(x, rank, method,
+ seed = NULL, model = NULL, ...)
+
+ \S4method{nmf}{matrix,numeric,list}(x, rank, method, ...,
+ .parameters = list())
+
+ \S4method{nmf}{matrix,numeric,function}(x, rank, method,
+ seed, model = "NMFstd", ..., name,
+ objective = "euclidean", mixed = FALSE)
+
+ \S4method{nmf}{matrix,NMF,ANY}(x, rank, method, seed,
+ ...)
+
+ \S4method{nmf}{matrix,NULL,ANY}(x, rank, method, seed,
+ ...)
+
+ \S4method{nmf}{matrix,matrix,ANY}(x, rank, method, seed,
+ model = list(), ...)
+
+ \S4method{nmf}{formula,ANY,ANY}(x, rank, method, ...,
+ model = NULL)
+
+ \S4method{nmf}{matrix,numeric,NMFStrategy}(x, rank,
+ method, seed = nmf.getOption("default.seed"),
+ rng = NULL, nrun = if (length(rank) > 1) 30 else 1,
+ model = NULL, .options = list(),
+ .pbackend = nmf.getOption("pbackend"),
+ .callback = NULL, ...)
+}
+\arguments{
+ \item{x}{target data to fit, i.e. a matrix-like object}
+
+ \item{rank}{specification of the factorization rank. It
+ is usually a single numeric value, but other type of
+ values are possible (e.g. matrix), for which specific
+ methods are implemented. See for example methods
+ \code{nmf,matrix,matrix,ANY}.
+
+ If \code{rank} is a numeric vector with more than one
+ element, e.g. a range of ranks, then \code{\link{nmf}}
+ performs the estimation procedure described in
+ \code{\link{nmfEstimateRank}}.}
+
+ \item{method}{specification of the NMF algorithm. The
+ most common way of specifying the algorithm is to pass
+ the access key (i.e. a character string) of an algorithm
+ stored in the package's dedicated registry, but methods
+ exists that handle other types of values, such as
+ \code{function} or \code{list} object. See their
+ descriptions in section \emph{Methods}.
+
+ If \code{method} is missing the algorithm to use is
+ obtained from the option
+ \code{nmf.getOption('default.algorithm')}, unless it can
+ be infer from the type of NMF model to fit, if this later
+ is available from other arguments. Factory fresh default
+ value is \sQuote{brunet}, which corresponds to the
+ standard NMF algorithm from \cite{Brunet2004} (see
+ section \emph{Algorithms}).
+
+ Cases where the algorithm is inferred from the call are
+ when an NMF model is passed in arguments \code{rank} or
+ \code{seed} (see description for
+ \code{nmf,matrix,numeric,NULL} in section
+ \emph{Methods}).}
+
+ \item{...}{extra arguments to allow extension of the
+ generic. Arguments that are not used in the chain of
+ internal calls to \code{nmf} methods are passed to the
+ function that effectively implements the algorithm that
+ fits an NMF model on \code{x}.}
+
+ \item{.parameters}{list of method-specific parameters.
+ Its elements must have names matching a single method
+ listed in \code{method}, and be lists of named values
+ that are passed to the corresponding method.}
+
+ \item{name}{name associated with the NMF algorithm
+ implemented by the function \code{method} [only used when
+ \code{method} is a function].}
+
+ \item{objective}{specification of the objective function
+ associated with the algorithm implemented by the function
+ \code{method} [only used when \code{method} is a
+ function].
+
+ It may be either \code{'euclidean'} or \code{'KL'} for
+ specifying the euclidean distance (Frobenius norm) or the
+ Kullback-Leibler divergence respectively, or a function
+ with signature \code{(x="NMF", y="matrix", ...)} that
+ computes the objective value for an NMF model \code{x} on
+ a target matrix \code{y}, i.e. the residuals between the
+ target matrix and its NMF estimate. Any extra argument
+ may be specified, e.g. \code{function(x, y, alpha,
+ beta=2, ...)}.}
+
+ \item{mixed}{a logical that indicates if the algorithm
+ implemented by the function \code{method} support
+ mixed-sign target matrices, i.e. that may contain
+ negative values [only used when \code{method} is a
+ function].}
+
+ \item{seed}{specification of the starting point or
+ seeding method, which will compute a starting point,
+ usually using data from the target matrix in order to
+ provide a good guess.
+
+ The seeding method may be specified in the following way:
+
+ \describe{
+
+ \item{a \code{character} string:}{ giving the name of a
+ \emph{registered} seeding method. The corresponding
+ method will be called to compute the starting point.
+
+ Available methods can be listed via \code{nmfSeed()}. See
+ its dedicated documentation for details on each available
+ registered methods (\code{\link{nmfSeed}}). }
+
+ \item{a \code{list}:}{ giving the name of a
+ \emph{registered} seeding method and, optionally, extra
+ parameters to pass to it.}
+
+ \item{a single \code{numeric}:}{ that is used to seed the
+ random number generator, before generating a random
+ starting point.
+
+ Note that when performing multiple runs, the L'Ecuyer's
+ RNG is used in order to produce a sequence of random
+ streams, that is used in way that ensures that parallel
+ computation are fully reproducible. }
+
+ \item{an object that inherits from
+ \code{\linkS4class{NMF}}:}{ it should contain the data of
+ an initialised NMF model, i.e. it must contain valid
+ basis and mixture coefficient matrices, directly usable
+ by the algorithm's workhorse function.}
+
+ \item{a \code{function}:}{ that computes the starting
+ point. It must have signature \code{(object="NMF",
+ target="matrix", ...)} and return an object that inherits
+ from class \code{NMF}. It is recommended to use argument
+ \code{object} as a template for the returned object, by
+ only updating the basis and coefficient matrices, using
+ \code{\link{basis<-}} and \code{\link{coef<-}}
+ respectively. }
+
+ }}
+
+ \item{rng}{rng specification for the run(s). This
+ argument should be used to set the the RNG seed, while
+ still specifying the seeding method argument \var{seed}.}
+
+ \item{model}{specification of the type of NMF model to
+ use.
+
+ It is used to instantiate the object that inherits from
+ class \code{\linkS4class{NMF}}, that will be passed to
+ the seeding method. The following values are supported:
+ \itemize{
+
+ \item \code{NULL}, the default model associated to the
+ NMF algorithm is instantiated and \code{...} is looked-up
+ for arguments with names that correspond to slots in the
+ model class, which are passed to the function
+ \code{\link{nmfModel}} to instantiate the model.
+ Arguments in \code{...} that do not correspond to slots
+ are passed to the algorithm.
+
+ \item a single \code{character} string, that is the name
+ of the NMF model class to be instantiate. In this case,
+ arguments in \code{...} are handled in the same way as
+ when \code{model} is \code{NULL}.
+
+ \item a \code{list} that contains named values that are
+ passed to the function \code{\link{nmfModel}} to
+ instantiate the model. In this case, \code{...} is not
+ looked-up at all, and passed entirely to the algorithm.
+ This means that all necessary model parameters must be
+ specified in \code{model}.
+
+ }
+
+ \strong{Argument/slot conflicts:} In the case a parameter
+ of the algorithm has the same name as a model slot, then
+ \code{model} MUST be a list -- possibly empty --, if one
+ wants this parameter to be effectively passed to the
+ algorithm.
+
+ If a variable appears in both arguments \code{model} and
+ \code{\dots}, the former will be used to initialise the
+ NMF model, the latter will be passed to the NMF
+ algorithm. See code examples for an illustration of this
+ situation.}
+
+ \item{nrun}{number of runs to perform. It specifies the
+ number of runs to perform. By default only one run is
+ performed, except if \code{rank} is a numeric vector with
+ more than one element, in which case a default of 30 runs
+ per value of the rank are performed, allowing the
+ computation of a consensus matrix that is used in
+ selecting the appropriate rank (see
+ \code{\link{consensus}}).
+
+ When using a random seeding method, multiple runs are
+ generally required to achieve stability and avoid
+ \emph{bad} local minima.}
+
+ \item{.options}{this argument is used to set runtime
+ options.
+
+ It can be a \code{list} containing named options with
+ their values, or, in the case only boolean/integer
+ options need to be set, a character string that specifies
+ which options are turned on/off or their value, in a
+ unix-like command line argument way.
+
+ The string must be composed of characters that correspond
+ to a given option (see mapping below), and modifiers '+'
+ and '-' that toggle options on and off respectively. E.g.
+ \code{.options='tv'} will toggle on options \code{track}
+ and \code{verbose}, while \code{.options='t-v'} will
+ toggle on option \code{track} and toggle off option
+ \code{verbose}.
+
+ Modifiers '+' and '-' apply to all option character found
+ after them: \code{t-vp+k} means \code{track=TRUE},
+ \code{verbose=parallel=FALSE}, and \code{keep.all=TRUE}.
+ The default behaviour is to assume that \code{.options}
+ starts with a '+'.
+
+ for options that accept integer values, the value may be
+ appended to the option's character e.g. \code{'p4'} for
+ asking for 4 processors or \code{'v3'} for showing
+ verbosity message up to level 3.
+
+ The following options are available (the characters after
+ \dQuote{-} are those to use to encode \code{.options} as
+ a string): \describe{
+
+ \item{debug - d}{ Toggle debug mode (default:
+ \code{FALSE}). Like option \code{verbose} but with more
+ information displayed.}
+
+ \item{keep.all - k}{ used when performing multiple runs
+ (\code{nrun}>1): if \code{TRUE}, all factorizations are
+ saved and returned (default: \code{FALSE}). Otherwise
+ only the factorization achieving the minimum residuals is
+ returned.}
+
+ \item{parallel - p}{ this option is useful on multicore
+ *nix or Mac machine only, when performing multiple runs
+ (\code{nrun} > 1) (default: \code{TRUE}). If \code{TRUE},
+ the runs are performed using the parallel foreach backend
+ defined in argument \code{.pbackend}. If this is set to
+ \code{'mc'} or \code{'par'} then \code{nmf} tries to
+ perform the runs using multiple cores with package
+ \code{link[doParallel]{doParallel}} -- which therefore
+ needs to be installed.
+
+ If equal to an integer, then \code{nmf} tries to perform
+ the computation on the specified number of processors.
+ When passing options as a string the number is appended
+ to the option's character e.g. \code{'p4'} for asking for
+ 4 processors.
+
+ If \code{FALSE}, then the computation is performed
+ sequentially using the base function
+ \code{\link{sapply}}.
+
+ Unlike option 'P' (capital 'P'), if the computation
+ cannot be performed in parallel, then it will still be
+ carried on sequentially.
+
+ \strong{IMPORTANT NOTE FOR MAC OS X USERS:} The parallel
+ computation is based on the \code{doMC} and
+ \code{multicore} packages, so the same care should be
+ taken as stated in the vignette of \code{doMC}:
+ \emph{\dQuote{it is not safe to use doMC from R.app on
+ Mac OS X. Instead, you should use doMC from a terminal
+ session, starting R from the command line.}} }
+
+ \item{parallel.required - P}{ Same as \code{p}, but an
+ error is thrown if the computation cannot be performed in
+ parallel or with the specified number of processors.}
+
+ \item{shared.memory - m}{ toggle usage of shared memory
+ (requires the \pkg{synchronicity} package). Default is as
+ defined by \code{nmf.getOption('shared.memory')}.}
+
+ \item{restore.seed - r}{ deprecated option since version
+ 0.5.99. Will throw a warning if used.}
+
+ \item{simplifyCB - S}{ toggle simplification of the
+ callback results. Default is \code{TRUE}}
+
+ \item{track - t}{ enables error tracking (default:
+ FALSE). If \code{TRUE}, the returned object's slot
+ \code{residuals} contains the trajectory of the objective
+ values, which can be retrieved via \code{residuals(res,
+ track=TRUE)} This tracking functionality is available for
+ all built-in algorithms. }
+
+ \item{verbose - v}{ Toggle verbosity (default:
+ \code{FALSE}). If \code{TRUE}, messages about the
+ configuration and the state of the current run(s) are
+ displayed. The level of verbosity may be specified with
+ an integer value, the greater the level the more messages
+ are displayed. Value \code{FALSE} means no messages are
+ displayed, while value \code{TRUE} is equivalent to
+ verbosity level 1. }
+
+ }}
+
+ \item{.pbackend}{specification of the
+ \code{\link{foreach}} parallel backend to register and/or
+ use when running in parallel mode. See options \code{p}
+ and \code{P} in argument \code{.options} for how to
+ enable this mode. Note that any backend that is
+ internally registered is cleaned-up on exit, so that the
+ calling foreach environment should not be affected by a
+ call to \code{nmf} -- except when \code{.pbackend=NULL}.
+
+ Currently it accepts the following values: \describe{
+
+ \item{\sQuote{par}}{ use the backend(s) defined by the
+ package \code{\link{doParallel}};} \item{a numeric
+ value}{ use the specified number of cores with
+ \code{doParallel} backend;} \item{\sQuote{seq}}{ use the
+ foreach sequential backend \code{doSEQ};}
+ \item{\code{NULL}}{ use currently registered backend;}
+ \item{\code{NA}}{ do not compute using a foreach loop --
+ and therefore not in parallel -- but rather use a call to
+ standard \code{\link{sapply}}. This is useful for when
+ developing/debugging NMF algorithms, as foreach loop
+ handling may sometime get in the way.
+
+ Note that this is equivalent to using
+ \code{.options='-p'} or \code{.options='p0'}, but takes
+ precedence over any option specified in \code{.options}:
+ e.g. \code{nmf(..., .options='P10', .pbackend=NA)}
+ performs all runs sequentially using \code{sapply}. Use
+ \code{nmf.options(pbackend=NA)} to completely disable
+ foreach/parallel computations for all subsequent
+ \code{nmf} calls.}
+
+ \item{\sQuote{mc}}{ identical to \sQuote{par} and defined
+ to ensure backward compatibility.} }}
+
+ \item{.callback}{Used when option \code{keep.all=FALSE}
+ (default). It allows to pass a callback function that is
+ called after each run when performing multiple runs (i.e.
+ with \code{nrun>1}). This is useful for example if one is
+ also interested in saving summary measures or process the
+ result of each NMF fit before it gets discarded. After
+ each run, the callback function is called with two
+ arguments, the \code{\linkS4class{NMFfit}} object that as
+ just been fitted and the run number: \code{.callback(res,
+ i)}. For convenience, a function that takes only one
+ argument or has signature \code{(x, ...)} can still be
+ passed in \code{.callback}. It is wrapped internally into
+ a dummy function with two arguments, only the first of
+ which is passed to the actual callback function (see
+ example with \code{summary}).
+
+ The call is wrapped into a tryCatch so that callback
+ errors do not stop the whole computation (see below).
+
+ The results of the different calls to the callback
+ function are stored in a miscellaneous slot accessible
+ using the method \code{$} for \code{NMFfit} objects:
+ \code{res$.callback}. By default \code{nmf} tries to
+ simplify the list of callback result using \code{sapply},
+ unless option \code{'simplifyCB'} is \code{FASE}.
+
+ If no error occurs \code{res$.callback} contains the list
+ of values that resulted from the calling the callback
+ function --, ordered as the fits. If any error occurs in
+ one of the callback calls, then the whole computation is
+ \strong{not} stopped, but the error message is stored in
+ \code{res$.callback}, in place of the result.
+
+ See the examples for sample code.}
+}
+\value{
+ The returned value depends on the run mode:
+
+ \item{Single run:}{An object of class
+ \code{\linkS4class{NMFfit}}.}
+
+ \item{Multiple runs, single method:}{When \code{nrun > 1}
+ and \code{method} is not \code{list}, this method returns
+ an object of class \code{\linkS4class{NMFfitX}}.}
+
+ \item{Multiple runs, multiple methods:}{When \code{nrun >
+ 1} and \code{method} is a \code{list}, this method
+ returns an object of class \code{\linkS4class{NMFList}}.}
+}
+\description{
+ The function \code{nmf} is a S4 generic defines the main
+ interface to run NMF algorithms within the framework
+ defined in package \code{NMF}. It has many methods that
+ facilitates applying, developing and testing NMF
+ algorithms.
+
+ The package vignette \code{vignette('NMF')} contains an
+ introduction to the interface, through a sample data
+ analysis.
+}
+\details{
+ The \code{nmf} function has multiple methods that compose
+ a very flexible interface allowing to: \itemize{ \item
+ combine NMF algorithms with seeding methods and/or
+ stopping/convergence criterion at runtime;
+
+ \item perform multiple NMF runs, which are computed in
+ parallel whenever the host machine allows it;
+
+ \item run multiple algorithms with a common set of
+ parameters, ensuring a consistent environment (notably
+ the RNG settings). }
+
+ The workhorse method is
+ \code{nmf,matrix,numeric,NMFStrategy}, which is
+ eventually called by all other methods. The other methods
+ provides convenient ways of specifying the NMF
+ algorithm(s), the factorization rank, or the seed to be
+ used. Some allow to directly run NMF algorithms on
+ different types of objects, such as \code{data.frame} or
+ \code{\link[Biobase]{ExpressionSet}} objects.
+}
+\section{Methods}{
+ \describe{
+
+ \item{nmf}{\code{signature(x = "data.frame", rank =
+ "ANY", method = "ANY")}: Fits an NMF model on a
+ \code{data.frame}.
+
+ The target \code{data.frame} is coerced into a matrix
+ with \code{\link{as.matrix}}. }
+
+ \item{nmf}{\code{signature(x = "matrix", rank =
+ "numeric", method = "NULL")}: Fits an NMF model using an
+ appropriate algorithm when \code{method} is not supplied.
+
+ This method tries to select an appropriate algorithm
+ amongst the NMF algorithms stored in the internal
+ algorithm registry, which contains the type of NMF models
+ each algorithm can fit. This is possible when the type of
+ NMF model to fit is available from argument \code{seed},
+ i.e. if it is an NMF model itself. Otherwise the
+ algorithm to use is obtained from
+ \code{nmf.getOption('default.algorithm')}.
+
+ This method is provided for internal usage, when called
+ from other \code{nmf} methods with argument \code{method}
+ missing in the top call (e.g.
+ \code{nmf,matrix,numeric,missing}). }
+
+ \item{nmf}{\code{signature(x = "matrix", rank =
+ "numeric", method = "list")}: Fits multiple NMF models on
+ a common matrix using a list of algorithms.
+
+ The models are fitted sequentially with \code{nmf} using
+ the same options and parameters for all algorithms. In
+ particular, irrespective of the way the computation is
+ seeded, this method ensures that all fits are performed
+ using the same initial RNG settings.
+
+ This method returns an object of class
+ \code{\linkS4class{NMFList}}, that is essentially a list
+ containing each fit. }
+
+ \item{nmf}{\code{signature(x = "matrix", rank =
+ "numeric", method = "character")}: Fits an NMF model on
+ \code{x} using an algorithm registered with access key
+ \code{method}.
+
+ Argument \code{method} is partially match against the
+ access keys of all registered algorithms (case
+ insensitive). Available algorithms are listed in section
+ \emph{Algorithms} below or the introduction vignette. A
+ vector of their names may be retrieved via
+ \code{nmfAlgorithm()}. }
+
+ \item{nmf}{\code{signature(x = "matrix", rank =
+ "numeric", method = "function")}: Fits an NMF model on
+ \code{x} using a custom algorithm defined the function
+ \code{method}.
+
+ The supplied function must have signature
+ \code{(x=matrix, start=NMF, ...)} and return an object
+ that inherits from class \code{\linkS4class{NMF}}. It
+ will be called internally by the workhorse \code{nmf}
+ method, with an NMF model to be used as a starting point
+ passed in its argument \code{start}.
+
+ Extra arguments in \code{...} are passed to \code{method}
+ from the top \code{nmf} call. Extra arguments that have
+ no default value in the definition of the function
+ \code{method} are required to run the algorithm (e.g. see
+ argument \code{alpha} of \code{myfun} in the examples).
+
+ If the algorithm requires a specific type of NMF model,
+ this can be specified in argument \code{model} that is
+ handled as in the workhorse \code{nmf} method (see
+ description for this argument). }
+
+ \item{nmf}{\code{signature(x = "matrix", rank = "NMF",
+ method = "ANY")}: Fits an NMF model using the NMF model
+ \code{rank} to seed the computation, i.e. as a starting
+ point.
+
+ This method is provided for convenience as a shortcut for
+ \code{nmf(x, nbasis(object), method, seed=object, ...)}
+ It discards any value passed in argument \code{seed} and
+ uses the NMF model passed in \code{rank} instead. It
+ throws a warning if argument \code{seed} not missing.
+
+ If \code{method} is missing, this method will call the
+ method \code{nmf,matrix,numeric,NULL}, which will infer
+ an algorithm suitable for fitting an NMF model of the
+ class of \code{rank}. }
+
+ \item{nmf}{\code{signature(x = "matrix", rank = "NULL",
+ method = "ANY")}: Fits an NMF model using the NMF model
+ supplied in \code{seed}, to seed the computation, i.e. as
+ a starting point.
+
+ This method is provided for completeness and is
+ equivalent to \code{nmf(x, seed, method, ...)}. }
+
+ \item{nmf}{\code{signature(x = "matrix", rank =
+ "missing", method = "ANY")}: Method defined to ensure the
+ correct dispatch to workhorse methods in case of argument
+ \code{rank} is missing. }
+
+ \item{nmf}{\code{signature(x = "matrix", rank =
+ "numeric", method = "missing")}: Method defined to ensure
+ the correct dispatch to workhorse methods in case of
+ argument \code{method} is missing. }
+
+ \item{nmf}{\code{signature(x = "matrix", rank = "matrix",
+ method = "ANY")}: Fits an NMF model partially seeding the
+ computation with a given matrix passed in \code{rank}.
+
+ The matrix \code{rank} is used either as initial value
+ for the basis or mixture coefficient matrix, depending on
+ its dimension.
+
+ Currently, such partial NMF model is directly used as a
+ seed, meaning that the remaining part is left
+ uninitialised, which is not accepted by all NMF
+ algorithm. This should change in the future, where the
+ missing part of the model will be drawn from some random
+ distribution.
+
+ Amongst built-in algorithms, only \sQuote{snmf/l} and
+ \sQuote{snmf/r} support partial seeds, with only the
+ coefficient or basis matrix initialised respectively. }
+
+ \item{nmf}{\code{signature(x = "matrix", rank =
+ "data.frame", method = "ANY")}: Shortcut for \code{nmf(x,
+ as.matrix(rank), method, ...)}. }
+
+ \item{nmf}{\code{signature(x = "formula", rank = "ANY",
+ method = "ANY")}: This method implements the interface
+ for fitting formula-based NMF models. See
+ \code{\link{nmfModel}}.
+
+ Argument \code{rank} target matrix or formula
+ environment. If not missing, \code{model} must be a
+ \code{list}, a \code{data.frame} or an \code{environment}
+ in which formula variables are searched for. }
+
+ }
+}
+\section{Optimized C++ vs. plain R}{
+ Lee and Seung's multiplicative updates are used by
+ several NMF algorithms. To improve speed and memory
+ usage, a C++ implementation of the specific matrix
+ products is used whenever possible. It directly computes
+ the updates for each entry in the updated matrix, instead
+ of using multiple standard matrix multiplication.
+
+ The algorithms that benefit from this optimization are:
+ 'brunet', 'lee', 'nsNMF' and 'offset'. % and 'lnmf'
+ However there still exists plain R versions for these
+ methods, which implement the updates as standard matrix
+ products. These are accessible by adding the prefix '.R#'
+ to their name: '.R#brunet', '.R#lee', '.R#nsNMF' and
+ '.R#offset'.
+}
+
+\section{Algorithms}{
+ All algorithms are accessible by their respective access
+ key as listed below. The following algorithms are
+ available: \describe{
+
+ \item{\sQuote{brunet}}{ Standard NMF, based on the
+ Kullback-Leibler divergence, from \cite{Brunet et al. (2004)}. It
+ uses simple multiplicative updates from \cite{Lee et al. (2001)},
+ enhanced to avoid numerical underflow.
+
+ Default stopping criterion: invariance of the
+ connectivity matrix (see
+ \code{\link{nmf.stop.connectivity}}). }
+
+ \item{\sQuote{lee}}{ Standard NMF based on the Euclidean
+ distance from \cite{Lee et al. (2001)}. It uses simple
+ multiplicative updates.
+
+ Default stopping criterion: invariance of the
+ connectivity matrix (see
+ \code{\link{nmf.stop.connectivity}}). }
+
+ \item{ls-nmf}{ Least-Square NMF from \cite{Wang et al. (2006)}. It
+ uses modified versions of Lee and Seung's multiplicative
+ updates for the Euclidean distance, which incorporates
+ weights on each entry of the target matrix, e.g. to
+ reflect measurement uncertainty.
+
+ Default stopping criterion: stationarity of the objective
+ function (see \code{\link{nmf.stop.stationary}}). }
+
+ \item{\sQuote{nsNMF}}{ Nonsmooth NMF from
+ \cite{Pascual-Montano et al. (2006)}. It uses a modified version of
+ Lee and Seung's multiplicative updates for the
+ Kullback-Leibler divergence \cite{Lee et al. (2001)}, to fit a
+ extension of the standard NMF model, that includes an
+ intermediate smoothing matrix, meant meant to produce
+ sparser factors.
+
+ Default stopping criterion: invariance of the
+ connectivity matrix (see
+ \code{\link{nmf.stop.connectivity}}). }
+
+ \item{\sQuote{offset}}{ NMF with offset from
+ \cite{Badea (2008)}. It uses a modified version of Lee and
+ Seung's multiplicative updates for Euclidean distance
+ \cite{Lee et al. (2001)}, to fit an NMF model that includes an
+ intercept, meant to capture a common baseline and shared
+ patterns, in order to produce cleaner basis components.
+
+ Default stopping criterion: invariance of the
+ connectivity matrix (see
+ \code{\link{nmf.stop.connectivity}}). }
+
+ \item{\sQuote{pe-nmf}}{ Pattern-Expression NMF from
+ \emph{Zhang2008}. It uses multiplicative updates to
+ minimize an objective function based on the Euclidean
+ distance, that is regularized for effective expression of
+ patterns with basis vectors.
+
+ Default stopping criterion: stationarity of the objective
+ function (see \code{\link{nmf.stop.stationary}}). }
+
+ \item{\sQuote{snmf/r}, \sQuote{snmf/l}}{ Alternating
+ Least Square (ALS) approach from \cite{Kim et al. (2007)}. It
+ applies the nonnegative least-squares algorithm from
+ \cite{Van Benthem et al. (2004)} (i.e. fast combinatorial
+ nonnegative least-squares for multiple right-hand), to
+ estimate the basis and coefficient matrices alternatively
+ (see \code{\link{fcnnls}}). It minimises an
+ Euclidean-based objective function, that is regularized
+ to favour sparse basis matrices (for \sQuote{snmf/l}) or
+ sparse coefficient matrices (for \sQuote{snmf/r}).
+
+ Stopping criterion: built-in within the internal
+ workhorse function \code{nmf_snmf}, based on the KKT
+ optimality conditions. }
+
+ }
+}
+
+\section{Seeding methods}{
+ The purpose of seeding methods is to compute initial
+ values for the factor matrices in a given NMF model. This
+ initial guess will be used as a starting point by the
+ chosen NMF algorithm.
+
+ The seeding method to use in combination with the
+ algorithm can be passed to interface \code{nmf} through
+ argument \code{seed}. The seeding seeding methods
+ available in registry are listed by the function
+ \code{\link{nmfSeed}} (see list therein).
+
+ Detailed examples of how to specify the seeding method
+ and its parameters can be found in the \emph{Examples}
+ section of this man page and in the package's vignette.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# Only basic calls are presented in this manpage.
+# Many more examples are provided in the demo file nmf.R
+\dontrun{
+demo('nmf')
+}
+
+# random data
+x <- rmatrix(20,10)
+
+# run default algorithm with rank 2
+res <- nmf(x, 2)
+
+# specify the algorithm
+res <- nmf(x, 2, 'lee')
+
+# get verbose message on what is going on
+res <- nmf(x, 2, .options='v')
+\dontrun{
+# more messages
+res <- nmf(x, 2, .options='v2')
+# even more
+res <- nmf(x, 2, .options='v3')
+# and so on ...
+}
+}
+\references{
+ Brunet J, Tamayo P, Golub TR and Mesirov JP (2004).
+ "Metagenes and molecular pattern discovery using matrix
+ factorization." _Proceedings of the National Academy of
+ Sciences of the United States of America_, *101*(12), pp.
+ 4164-9. ISSN 0027-8424, <URL:
+ http://dx.doi.org/10.1073/pnas.0308531101>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/15016911>.
+
+ Lee DD and Seung H (2001). "Algorithms for non-negative
+ matrix factorization." _Advances in neural information
+ processing systems_. <URL:
+ http://scholar.google.com/scholar?q=intitle:Algorithms+for+non-negative+matrix+factorization\#0>.
+
+ Wang G, Kossenkov AV and Ochs MF (2006). "LS-NMF: a
+ modified non-negative matrix factorization algorithm
+ utilizing uncertainty estimates." _BMC bioinformatics_,
+ *7*, pp. 175. ISSN 1471-2105, <URL:
+ http://dx.doi.org/10.1186/1471-2105-7-175>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/16569230>.
+
+ Pascual-Montano A, Carazo JM, Kochi K, Lehmann D and
+ Pascual-marqui RD (2006). "Nonsmooth nonnegative matrix
+ factorization (nsNMF)." _IEEE Trans. Pattern Anal. Mach.
+ Intell_, *28*, pp. 403-415.
+
+ Badea L (2008). "Extracting gene expression profiles
+ common to colon and pancreatic adenocarcinoma using
+ simultaneous nonnegative matrix factorization." _Pacific
+ Symposium on Biocomputing. Pacific Symposium on
+ Biocomputing_, *290*, pp. 267-78. ISSN 1793-5091, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/18229692>.
+
+ Kim H and Park H (2007). "Sparse non-negative matrix
+ factorizations via alternating non-negativity-constrained
+ least squares for microarray data analysis."
+ _Bioinformatics (Oxford, England)_, *23*(12), pp.
+ 1495-502. ISSN 1460-2059, <URL:
+ http://dx.doi.org/10.1093/bioinformatics/btm134>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/17483501>.
+
+ Van Benthem M and Keenan MR (2004). "Fast algorithm for
+ the solution of large-scale non-negativity-constrained
+ least squares problems." _Journal of Chemometrics_,
+ *18*(10), pp. 441-450. ISSN 0886-9383, <URL:
+ http://dx.doi.org/10.1002/cem.889>, <URL:
+ http://doi.wiley.com/10.1002/cem.889>.
+}
+\seealso{
+ \code{\link{nmfAlgorithm}}
+}
+\keyword{methods}
+
diff --git a/man/nmf.equal.Rd b/man/nmf.equal.Rd
new file mode 100644
index 0000000..11e467e
--- /dev/null
+++ b/man/nmf.equal.Rd
@@ -0,0 +1,121 @@
+\docType{methods}
+\name{nmf.equal}
+\alias{nmf.equal}
+\alias{nmf.equal,list,list-method}
+\alias{nmf.equal,list,missing-method}
+\alias{nmf.equal-methods}
+\alias{nmf.equal,NMFfit,NMFfit-method}
+\alias{nmf.equal,NMFfit,NMF-method}
+\alias{nmf.equal,NMFfitX1,NMFfitX1-method}
+\alias{nmf.equal,NMFfitX,NMF-method}
+\alias{nmf.equal,NMF,NMFfit-method}
+\alias{nmf.equal,NMF,NMFfitX-method}
+\alias{nmf.equal,NMF,NMF-method}
+\title{Testing Equality of NMF Models}
+\usage{
+ nmf.equal(x, y, ...)
+
+ \S4method{nmf.equal}{NMF,NMF}(x, y, identical = TRUE,
+ ...)
+
+ \S4method{nmf.equal}{list,list}(x, y, ..., all = FALSE,
+ vector = FALSE)
+}
+\arguments{
+ \item{x}{an NMF model or an object that is associated
+ with an NMF model, e.g. the result from a fit with
+ \code{\link{nmf}}.}
+
+ \item{y}{an NMF model or an object that is associated
+ with an NMF model, e.g. the result from a fit with
+ \code{\link{nmf}}.}
+
+ \item{identical}{a logical that indicates if the
+ comparison should be made using the function
+ \code{\link{identical}} (\code{TRUE}) or
+ \code{\link{all.equal}} (\code{FALSE}). See description
+ for method \code{nmf.equal,NMF,NMF}.}
+
+ \item{...}{extra arguments to allow extension, and passed
+ to subsequent calls}
+
+ \item{all}{a logical that indicates if all fits should be
+ compared separately or only the best fits}
+
+ \item{vector}{a logical, only used when \code{all=TRUE},
+ that indicates if all fits must be equal for \code{x} and
+ \code{y} to be declared equal, or if one wants to return
+ the result of each comparison in a vector.}
+}
+\description{
+ The function \code{nmf.equal} tests if two NMF models are
+ the same, i.e. they contain -- almost -- identical data:
+ same basis and coefficient matrices, as well as same
+ extra parameters.
+}
+\details{
+ \code{nmf.equal} compares two NMF models, and return
+ \code{TRUE} iff they are identical acording to the
+ function \code{\link{identical}} when
+ \code{identical=TRUE}, or equal up to some tolerance
+ acording to the function \code{\link{all.equal}}. This
+ means that all data contained in the objects are
+ compared, which includes at least the basis and
+ coefficient matrices, as well as the extra parameters
+ stored in slot \sQuote{misc}.
+
+ If extra arguments are specified in \code{...}, then the
+ comparison is performed using \code{\link{all.equal}},
+ irrespective of the value of argument \code{identical}.
+}
+\section{Methods}{
+ \describe{
+
+ \item{nmf.equal}{\code{signature(x = "NMF", y = "NMF")}:
+ Compares two NMF models.
+
+ Arguments in \code{...} are used only when
+ \code{identical=FALSE} and are passed to
+ \code{all.equal}. }
+
+ \item{nmf.equal}{\code{signature(x = "NMFfit", y =
+ "NMF")}: Compares two NMF models when at least one comes
+ from a NMFfit object, i.e. an object returned by a single
+ run of \code{\link{nmf}}. }
+
+ \item{nmf.equal}{\code{signature(x = "NMF", y =
+ "NMFfit")}: Compares two NMF models when at least one
+ comes from a NMFfit object, i.e. an object returned by a
+ single run of \code{\link{nmf}}. }
+
+ \item{nmf.equal}{\code{signature(x = "NMFfit", y =
+ "NMFfit")}: Compares two fitted NMF models, i.e. objects
+ returned by single runs of \code{\link{nmf}}. }
+
+ \item{nmf.equal}{\code{signature(x = "NMFfitX", y =
+ "NMF")}: Compares two NMF models when at least one comes
+ from multiple NMF runs. }
+
+ \item{nmf.equal}{\code{signature(x = "NMF", y =
+ "NMFfitX")}: Compares two NMF models when at least one
+ comes from multiple NMF runs. }
+
+ \item{nmf.equal}{\code{signature(x = "NMFfitX1", y =
+ "NMFfitX1")}: Compares the NMF models fitted by multiple
+ runs, that only kept the best fits. }
+
+ \item{nmf.equal}{\code{signature(x = "list", y =
+ "list")}: Compares the results of multiple NMF runs.
+
+ This method either compare the two best fit, or all fits
+ separately. All extra arguments in \code{...} are passed
+ to each internal call to \code{nmf.equal}. }
+
+ \item{nmf.equal}{\code{signature(x = "list", y =
+ "missing")}: Compare all elements in \code{x} to
+ \code{x[[1]]}. }
+
+ }
+}
+\keyword{methods}
+
diff --git a/man/nmfAlgorithm.Rd b/man/nmfAlgorithm.Rd
new file mode 100644
index 0000000..7769fa7
--- /dev/null
+++ b/man/nmfAlgorithm.Rd
@@ -0,0 +1,66 @@
+\name{nmfAlgorithm}
+\alias{nmfAlgorithm}
+\title{Listing and Retrieving NMF Algorithms}
+\usage{
+ nmfAlgorithm(name = NULL, version = NULL, all = FALSE,
+ ...)
+}
+\arguments{
+ \item{name}{Access key. If not missing, it must be a
+ single character string that is partially matched against
+ the available algorithms in the registry. In this case,
+ if \code{all=FALSE} (default), then the algorithm is
+ returned as an \code{NMFStrategy} object that can be
+ directly passed to \code{\link{nmf}}. An error is thrown
+ if no matching algorithm is found.
+
+ If missing or \code{NULL}, then access keys of algorithms
+ -- that match the criteria \code{version}, are returned.
+ This argument is assumed to be regular expression if
+ \code{all=TRUE} or \code{version} is not \code{NULL}.}
+
+ \item{version}{version of the algorithm(s) to retrieve.
+ Currently only value \code{'R'} is supported, which
+ searched for plain R implementations.}
+
+ \item{all}{a logical that indicates if all algorithm keys
+ should be returned, including the ones from alternative
+ algorithm versions (e.g. plain R implementations of
+ algorithms, for which a version based on optimised C
+ updates is used by default).}
+
+ \item{...}{extra arguments passed to
+ \code{\link{getNMFMethod}} when \code{name} is not
+ \code{NULL} and \code{all=FALSE}. It is not used
+ otherwise.}
+}
+\value{
+ an \code{\linkS4class{NMFStrategy}} object if \code{name}
+ is not \code{NULL} and \code{all=FALSE}, or a named
+ character vector that contains the access keys of the
+ matching algorithms. The names correspond to the access
+ key of the primary algorithm: e.g. algorithm \sQuote{lee}
+ has two registered versions, one plain R
+ (\sQuote{.R#lee}) and the other uses optimised C updates
+ (\sQuote{lee}), which will all get named \sQuote{lee}.
+}
+\description{
+ \code{nmfAlgorithm} lists access keys or retrieves NMF
+ algorithms that are stored in registry. It allows to list
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# list all main algorithms
+nmfAlgorithm()
+# list all versions of algorithms
+nmfAlgorithm(all=TRUE)
+# list all plain R versions
+nmfAlgorithm(version='R')
+}
+\seealso{
+ Other regalgo: \code{\link{canFit}}
+}
+
diff --git a/man/nmfApply.Rd b/man/nmfApply.Rd
new file mode 100644
index 0000000..8b1a0a4
--- /dev/null
+++ b/man/nmfApply.Rd
@@ -0,0 +1,76 @@
+\name{nmfApply}
+\alias{nmfApply}
+\title{Apply Function for NMF Objects}
+\usage{
+ nmfApply(X, MARGIN, FUN, ..., simplify = TRUE,
+ USE.NAMES = TRUE)
+}
+\arguments{
+ \item{X}{an object that has suitable \code{\link{basis}}
+ and \code{coef} methods, e.g. an NMF model.}
+
+ \item{MARGIN}{a single numeric (integer) value that
+ specifies over which margin(s) the function \code{FUN} is
+ applied. See section \emph{Details} for a list of
+ possible values.}
+
+ \item{FUN}{a function to apply over the specified
+ margins.}
+
+ \item{...}{extra arguments passed to \code{FUN}}
+
+ \item{simplify}{a logical only used when \code{MARGIN=3},
+ that indicates if \code{sapply} should try to simplify
+ result if possible. Since this argument follows
+ \sQuote{...} its name cannot be abbreviated.}
+
+ \item{USE.NAMES}{a logical only used when
+ \code{MARGIN=3}, that indicates if \code{sapply} should
+ use the names of the basis components to name the results
+ if present. Since this argument follows \sQuote{...} its
+ name cannot be abbreviated.}
+}
+\value{
+ a vector or a list. See \code{\link[base]{apply}} and
+ \code{\link[base]{sapply}} for more details on the output
+ format.
+}
+\description{
+ The function \code{nmfApply} provides exteneded
+ \code{apply}-like functionality for objects of class
+ \code{NMF}. It enables to easily apply a function over
+ different margins of NMF models.
+}
+\details{
+ The function \code{FUN} is applied via a call to
+ \code{\link{apply}} or \code{\link{sapply}} according to
+ the value of argument \code{MARGIN} as follows:
+
+ \describe{ \item{MARGIN=1}{ apply \code{FUN} to each
+ \emph{row} of the basis matrix: \code{apply(basis(X), 1L,
+ FUN, ...)}.}
+
+ \item{MARGIN=2}{ apply \code{FUN} to each \emph{column}
+ of the coefficient matrix: \code{apply(coef(X), 2L, FUN,
+ ...)}.}
+
+ \item{MARGIN=3}{ apply \code{FUN} to each \emph{pair} of
+ associated basis component and basis profile: more or
+ less \code{sapply(seq(nbasis(X)), function(i, ...)
+ FUN(basis(X)[,i], coef(X)[i, ], ...), ...)}.
+
+ In this case \code{FUN} must be have at least two
+ arguments, to which are passed each basis components and
+ basis profiles respectively -- as numeric vectors.}
+
+ \item{MARGIN=4}{ apply \code{FUN} to each \emph{column}
+ of the basis matrix, i.e. to each basis component:
+ \code{apply(basis(X), 2L, FUN, ...)}.}
+
+ \item{MARGIN=5}{ apply \code{FUN} to each \emph{row} of
+ the coefficient matrix: \code{apply(coef(X), 1L, FUN,
+ ...)}.}
+
+ }
+}
+
diff --git a/man/nmfCheck.Rd b/man/nmfCheck.Rd
new file mode 100644
index 0000000..7c6b4aa
--- /dev/null
+++ b/man/nmfCheck.Rd
@@ -0,0 +1,41 @@
+\name{nmfCheck}
+\alias{nmfCheck}
+\title{Checking NMF Algorithm}
+\usage{
+ nmfCheck(method = NULL, rank = max(ncol(x)/5, 3),
+ x = NULL, seed = 1234, ...)
+}
+\arguments{
+ \item{method}{name of the NMF algorithm to be tested.}
+
+ \item{rank}{rank of the factorization}
+
+ \item{x}{target data. If \code{NULL}, a random 20 x 10
+ matrix is generated}
+
+ \item{seed}{specifies a seed or seeding method for the
+ computation.}
+
+ \item{...}{other arguments passed to the call to
+ \code{\link{nmf}}.}
+}
+\value{
+ the result of the NMF fit invisibly.
+}
+\description{
+ \code{nmfCheck} enables to quickly check that a given NMF
+ algorithm runs properly, by applying it to some small
+ random data.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# test default algorithm
+nmfCheck()
+
+# test 'lee' algorithm
+nmfCheck('lee')
+}
+
diff --git a/man/nmfEstimateRank.Rd b/man/nmfEstimateRank.Rd
new file mode 100644
index 0000000..4582a09
--- /dev/null
+++ b/man/nmfEstimateRank.Rd
@@ -0,0 +1,198 @@
+\name{nmfEstimateRank}
+\alias{nmfEstimateRank}
+\alias{plot.NMF.rank}
+\title{Estimate Rank for NMF Models}
+\usage{
+ nmfEstimateRank(x, range,
+ method = nmf.getOption("default.algorithm"), nrun = 30,
+ model = NULL, ..., verbose = FALSE, stop = FALSE)
+
+ \method{plot}{NMF.rank} (x, y = NULL,
+ what = c("all", "cophenetic", "rss", "residuals", "dispersion", "evar",
+ "sparseness", "sparseness.basis", "sparseness.coef", "silhouette",
+ "silhouette.coef", "silhouette.basis", "silhouette.consensus"),
+ na.rm = FALSE, xname = "x", yname = "y",
+ xlab = "Factorization rank", ylab = "",
+ main = "NMF rank survey", ...)
+}
+\arguments{
+ \item{x}{For \code{nmfEstimateRank} a target object to be
+ estimated, in one of the format accepted by interface
+ \code{\link{nmf}}.
+
+ For \code{plot.NMF.rank} an object of class
+ \code{NMF.rank} as returned by function
+ \code{nmfEstimateRank}.}
+
+ \item{range}{a \code{numeric} vector containing the ranks
+ of factorization to try. Note that duplicates are removed
+ and values are sorted in increasing order. The results
+ are notably returned in this order.}
+
+ \item{method}{A single NMF algorithm, in one of the
+ format accepted by the function \code{\link{nmf}}.}
+
+ \item{nrun}{a \code{numeric} giving the number of run to
+ perform for each value in \code{range}.}
+
+ \item{model}{model specification passed to each
+ \code{nmf} call. In particular, when \code{x} is a
+ formula, it is passed to argument \code{data} of
+ \code{\link{nmfModel}} to determine the target matrix --
+ and fixed terms.}
+
+ \item{verbose}{toggle verbosity. This parameter only
+ affects the verbosity of the outer loop over the values
+ in \code{range}. To print verbose (resp. debug) messages
+ from each NMF run, one can use \code{.options='v'} (resp.
+ \code{.options='d'}) that will be passed to the function
+ \code{\link{nmf}}.}
+
+ \item{stop}{logical flag for running the estimation
+ process with fault tolerance. When \code{TRUE}, the
+ whole execution will stop if any error is raised. When
+ \code{FALSE} (default), the runs that raise an error will
+ be skipped, and the execution will carry on. The summary
+ measures for the runs with errors are set to NA values,
+ and a warning is thrown.}
+
+ \item{...}{For \code{nmfEstimateRank}, these are extra
+ parameters passed to interface \code{nmf}. Note that the
+ same parameters are used for each value of the rank. See
+ \code{\link{nmf}}.
+
+ For \code{plot.NMF.rank}, these are extra graphical
+ parameter passed to the standard function \code{plot}.
+ See \code{\link{plot}}.}
+
+ \item{y}{reference object of class \code{NMF.rank}, as
+ returned by function \code{nmfEstimateRank}. The measures
+ contained in \code{y} are used and plotted as a
+ reference. It is typically used to plot results obtained
+ from randomized data. The associated curves are drawn in
+ \emph{red} (and \emph{pink}), while those from \code{x}
+ are drawn in \emph{blue} (and \emph{green}).}
+
+ \item{what}{a \code{character} vector whose elements
+ partially match one of the following item, which
+ correspond to the measures computed by
+ \code{\link{summary}} on each -- multi-run -- NMF result:
+ \sQuote{all}, \sQuote{cophenetic}, \sQuote{rss},
+ \sQuote{residuals}, \sQuote{dispersion}, \sQuote{evar},
+ \sQuote{silhouette} (and more specific *.coef, *.basis,
+ *.consensus), \sQuote{sparseness} (and more specific
+ *.coef, *.basis). It specifies which measure must be
+ plotted (\code{what='all'} plots all the measures).}
+
+ \item{na.rm}{single logical that specifies if the rank
+ for which the measures are NA values should be removed
+ from the graph or not (default to \code{FALSE}). This is
+ useful when plotting results which include NAs due to
+ error during the estimation process. See argument
+ \code{stop} for \code{nmfEstimateRank}.}
+
+ \item{xname,yname}{legend labels for the curves
+ corresponding to measures from \code{x} and \code{y}
+ respectively}
+
+ \item{xlab}{x-axis label}
+
+ \item{ylab}{y-axis label}
+
+ \item{main}{main title}
+}
+\value{
+ \code{nmfEstimateRank} returns a S3 object (i.e. a list)
+ of class \code{NMF.rank} with the following elements:
+
+ \item{measures }{a \code{data.frame} containing the
+ quality measures for each rank of factorizations in
+ \code{range}. Each row corresponds to a measure, each
+ column to a rank. } \item{consensus }{ a \code{list} of
+ consensus matrices, indexed by the rank of factorization
+ (as a character string).} \item{fit }{ a \code{list} of
+ the fits, indexed by the rank of factorization (as a
+ character string).}
+}
+\description{
+ A critical parameter in NMF algorithms is the
+ factorization rank \eqn{r}. It defines the number of
+ basis effects used to approximate the target matrix.
+ Function \code{nmfEstimateRank} helps in choosing an
+ optimal rank by implementing simple approaches proposed
+ in the literature.
+
+ Note that from version \emph{0.7}, one can equivalently
+ call the function \code{\link{nmf}} with a range of
+ ranks.
+
+ In the plot generated by \code{plot.NMF.rank}, each curve
+ represents a summary measure over the range of ranks in
+ the survey. The colours correspond to the type of data to
+ which the measure is related: coefficient matrix, basis
+ component matrix, best fit, or consensus matrix.
+}
+\details{
+ Given a NMF algorithm and the target matrix, a common way
+ of estimating \eqn{r} is to try different values, compute
+ some quality measures of the results, and choose the best
+ value according to this quality criteria. See
+ \cite{Brunet et al. (2004)} and \cite{Hutchins et al.
+ (2008)}.
+
+ The function \code{nmfEstimateRank} allows to perform
+ this estimation procedure. It performs multiple NMF runs
+ for a range of rank of factorization and, for each,
+ returns a set of quality measures together with the
+ associated consensus matrix.
+
+ In order to avoid overfitting, it is recommended to run
+ the same procedure on randomized data. The results on the
+ original and the randomised data may be plotted on the
+ same plots, using argument \code{y}.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+if( !isCHECK() ){
+
+set.seed(123456)
+n <- 50; r <- 3; m <- 20
+V <- syntheticNMF(n, r, m)
+
+# Use a seed that will be set before each first run
+res <- nmfEstimateRank(V, seq(2,5), method='brunet', nrun=10, seed=123456)
+# or equivalently
+res <- nmf(V, seq(2,5), method='brunet', nrun=10, seed=123456)
+
+# plot all the measures
+plot(res)
+# or only one: e.g. the cophenetic correlation coefficient
+plot(res, 'cophenetic')
+
+# run same estimation on randomized data
+rV <- randomize(V)
+rand <- nmfEstimateRank(rV, seq(2,5), method='brunet', nrun=10, seed=123456)
+plot(res, rand)
+}
+}
+\references{
+ Brunet J, Tamayo P, Golub TR and Mesirov JP (2004).
+ "Metagenes and molecular pattern discovery using matrix
+ factorization." _Proceedings of the National Academy of
+ Sciences of the United States of America_, *101*(12), pp.
+ 4164-9. ISSN 0027-8424, <URL:
+ http://dx.doi.org/10.1073/pnas.0308531101>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/15016911>.
+
+ Hutchins LN, Murphy SM, Singh P and Graber JH (2008).
+ "Position-dependent motif characterization using
+ non-negative matrix factorization." _Bioinformatics
+ (Oxford, England)_, *24*(23), pp. 2684-90. ISSN
+ 1367-4811, <URL:
+ http://dx.doi.org/10.1093/bioinformatics/btn526>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/18852176>.
+}
+
diff --git a/man/nmfFormals.Rd b/man/nmfFormals.Rd
new file mode 100644
index 0000000..96b178f
--- /dev/null
+++ b/man/nmfFormals.Rd
@@ -0,0 +1,33 @@
+\name{nmfFormals}
+\alias{nmfArgs}
+\alias{nmfFormals}
+\title{Showing Arguments of NMF Algorithms}
+\usage{
+ nmfFormals(x, ...)
+
+ nmfArgs(x)
+}
+\arguments{
+ \item{x}{algorithm specification}
+
+ \item{...}{extra argument to allow extension}
+}
+\description{
+ This function returns the extra arguments that can be
+ passed to a given NMF algorithm in call to
+ \code{\link{nmf}}.
+
+ \code{nmfArgs} is a shortcut for
+ \code{args(nmfWrapper(x))}, to display the arguments of a
+ given NMF algorithm.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# show arguments of an NMF algorithm
+nmfArgs('brunet')
+nmfArgs('snmf/r')
+}
+
diff --git a/man/nmfModel.Rd b/man/nmfModel.Rd
new file mode 100644
index 0000000..c2ce217
--- /dev/null
+++ b/man/nmfModel.Rd
@@ -0,0 +1,454 @@
+\docType{methods}
+\name{nmfModel}
+\alias{nmfModel}
+\alias{nmfModel,data.frame,data.frame-method}
+\alias{nmfModel,formula,ANY-method}
+\alias{nmfModel,matrix,ANY-method}
+\alias{nmfModel,matrix,matrix-method}
+\alias{nmfModel-methods}
+\alias{nmfModel,missing,ANY-method}
+\alias{nmfModel,missing,missing-method}
+\alias{nmfModel,NULL,ANY-method}
+\alias{nmfModel,numeric,matrix-method}
+\alias{nmfModel,numeric,missing-method}
+\alias{nmfModel,numeric,numeric-method}
+\alias{nmfModels}
+\title{Factory Methods NMF Models}
+\usage{
+ nmfModel(rank, target = 0L, ...)
+
+ \S4method{nmfModel}{numeric,numeric}(rank, target,
+ ncol = NULL, model = "NMFstd", W, H, ...,
+ force.dim = TRUE, order.basis = TRUE)
+
+ \S4method{nmfModel}{numeric,matrix}(rank, target, ...,
+ use.names = TRUE)
+
+ \S4method{nmfModel}{formula,ANY}(rank, target, ...,
+ data = NULL, no.attrib = FALSE)
+
+ nmfModels(builtin.only = FALSE)
+}
+\arguments{
+ \item{rank}{specification of the target factorization
+ rank (i.e. the number of components).}
+
+ \item{target}{an object that specifies the dimension of
+ the estimated target matrix.}
+
+ \item{...}{extra arguments to allow extension, that are
+ passed down to the workhorse method
+ \code{nmfModel,numeric.numeric}, where they are used to
+ initialise slots specific to the instantiating NMF model
+ class.}
+
+ \item{ncol}{a numeric value that specifies the number of
+ columns of the target matrix, fitted the NMF model. It is
+ used only if not missing and when argument \code{target}
+ is a single numeric value.}
+
+ \item{model}{the class of the object to be created. It
+ must be a valid class name that inherits from class
+ \code{NMF}. Default is the standard NMF model
+ \code{\linkS4class{NMFstd}}.}
+
+ \item{W}{value for the basis matrix. \code{data.frame}
+ objects are converted into matrices with
+ \code{\link{as.matrix}}.}
+
+ \item{H}{value for the mixture coefficient matrix
+ \code{data.frame} objects are converted into matrices
+ with \code{\link{as.matrix}}.}
+
+ \item{force.dim}{logical that indicates whether the
+ method should try lowering the rank or shrinking
+ dimensions of the input matrices to make them compatible}
+
+ \item{order.basis}{logical that indicates whether the
+ basis components should reorder the rows of the mixture
+ coefficient matrix to match the order of the basis
+ components, based on their respective names. It is only
+ used if the basis and coefficient matrices have common
+ unique column and row names respectively.}
+
+ \item{use.names}{a logical that indicates whether the
+ dimension names of the target matrix should be set on the
+ returned NMF model.}
+
+ \item{data}{Optional argument where to look for the
+ variables used in the formula.}
+
+ \item{no.attrib}{logical that indicate if attributes
+ containing data related to the formula should be attached
+ as attributes. If \code{FALSE} attributes \code{'target'}
+ and \code{'formula'} contain the target matrix, and a
+ list describing each formula part (response, regressors,
+ etc.).}
+
+ \item{builtin.only}{logical that indicates whether only
+ built-in NMF models, i.e. defined within the NMF package,
+ should be listed.}
+}
+\value{
+ an object that inherits from class
+ \code{\linkS4class{NMF}}.
+
+ a list
+}
+\description{
+ \code{nmfModel} is a S4 generic function which provides a
+ convenient way to build NMF models. It implements a
+ unified interface for creating \code{NMF} objects from
+ any NMF models, which is designed to resolve potential
+ dimensions inconsistencies.
+
+ \code{nmfModels} lists all available NMF models currently
+ defined that can be used to create NMF objects, i.e. --
+ more or less -- all S4 classes that inherit from class
+ \code{\linkS4class{NMF}}.
+}
+\details{
+ All \code{nmfModel} methods return an object that
+ inherits from class \code{NMF}, that is suitable for
+ seeding NMF algorithms via arguments \code{rank} or
+ \code{seed} of the \code{\link{nmf}} method, in which
+ case the factorisation rank is implicitly set by the
+ number of basis components in the seeding model (see
+ \code{\link{nmf}}).
+
+ For convenience, shortcut methods and internal
+ conversions for working on \code{data.frame} objects
+ directly are implemented. However, note that conversion
+ of a \code{data.frame} into a \code{matrix} object may
+ take some non-negligible time, for large datasets. If
+ using this method or other NMF-related methods several
+ times, consider converting your data \code{data.frame}
+ object into a matrix once for good, when first loaded.
+}
+\section{Methods}{
+ \describe{
+
+ \item{nmfModel}{\code{signature(rank = "numeric", target
+ = "numeric")}: Main factory method for NMF models
+
+ This method is the workhorse method that is eventually
+ called by all other methods. See section \emph{Main
+ factory method} for more details. }
+
+ \item{nmfModel}{\code{signature(rank = "numeric", target
+ = "missing")}: Creates an empty NMF model of a given
+ rank.
+
+ This call is equivalent to \code{nmfModel(rank, 0L,
+ ...)}, which creates \emph{empty} \code{NMF} object with
+ a basis and mixture coefficient matrix of dimension 0 x
+ \code{rank} and \code{rank} x 0 respectively. }
+
+ \item{nmfModel}{\code{signature(rank = "missing", target
+ = "ANY")}: Creates an empty NMF model of null rank and a
+ given dimension.
+
+ This call is equivalent to \code{nmfModel(0, target,
+ ...)}. }
+
+ \item{nmfModel}{\code{signature(rank = "NULL", target =
+ "ANY")}: Creates an empty NMF model of null rank and
+ given dimension.
+
+ This call is equivalent to \code{nmfModel(0, target,
+ ...)}, and is meant for internal usage only. }
+
+ \item{nmfModel}{\code{signature(rank = "missing", target
+ = "missing")}: Creates an empty NMF model or from
+ existing factors
+
+ This method is equivalent to \code{nmfModel(0, 0, ...,
+ force.dim=FALSE)}. This means that the dimensions of the
+ NMF model will be taken from the optional basis and
+ mixture coefficient arguments \code{W} and \code{H}. An
+ error is thrown if their dimensions are not compatible.
+
+ Hence, this method may be used to generate an NMF model
+ from existing factor matrices, by providing the named
+ arguments \code{W} and/or \code{H}:
+
+ \code{nmfModel(W=w)} or \code{nmfModel(H=h)} or
+ \code{nmfModel(W=w, H=h)}
+
+ Note that this may be achieved using the more convenient
+ interface is provided by the method
+ \code{nmfModel,matrix,matrix} (see its dedicated
+ description).
+
+ See the description of the appropriate method below. }
+
+ \item{nmfModel}{\code{signature(rank = "numeric", target
+ = "matrix")}: Creates an NMF model compatible with a
+ target matrix.
+
+ This call is equivalent to \code{nmfModel(rank,
+ dim(target), ...)}. That is that the returned NMF object
+ fits a target matrix of the same dimension as
+ \code{target}.
+
+ Only the dimensions of \code{target} are used to
+ construct the \code{NMF} object. The matrix slots are
+ filled with \code{NA} values if these are not specified
+ in arguments \code{W} and/or \code{H}. However, dimension
+ names are set on the return NMF model if present in
+ \code{target} and argument \code{use.names=TRUE}. }
+
+ \item{nmfModel}{\code{signature(rank = "matrix", target =
+ "matrix")}: Creates an NMF model based on two existing
+ factors.
+
+ This method is equivalent to \code{nmfModel(0, 0, W=rank,
+ H=target..., force.dim=FALSE)}. This allows for a natural
+ shortcut for wrapping existing \strong{compatible}
+ matrices into NMF models: \samp{nmfModel(w, h)}
+
+ Note that an error is thrown if their dimensions are not
+ compatible. }
+
+ \item{nmfModel}{\code{signature(rank = "data.frame",
+ target = "data.frame")}: Same as \code{nmfModel('matrix',
+ 'matrix')} but for \code{data.frame} objects, which are
+ generally produced by \code{\link{read.delim}}-like
+ functions.
+
+ The input \code{data.frame} objects are converted into
+ matrices with \code{\link{as.matrix}}. }
+
+ \item{nmfModel}{\code{signature(rank = "matrix", target =
+ "ANY")}: Creates an NMF model with arguments \code{rank}
+ and \code{target} swapped.
+
+ This call is equivalent to \code{nmfModel(rank=target,
+ target=rank, ...)}. This allows to call the
+ \code{nmfModel} function with arguments \code{rank} and
+ \code{target} swapped. It exists for convenience:
+ \itemize{ \item allows typing \code{nmfModel(V)} instead
+ of \code{nmfModel(target=V)} to create a model compatible
+ with a given matrix \code{V} (i.e. of dimension
+ \code{nrow(V), 0, ncol(V)}) \item one can pass the
+ arguments in any order (the one that comes to the user's
+ mind first) and it still works as expected. } }
+
+ \item{nmfModel}{\code{signature(rank = "formula", target
+ = "ANY")}: Build a formula-based NMF model, that can
+ incorporate fixed basis or coefficient terms. }
+
+ }
+}
+\section{Main factory method}{
+ The main factory engine of NMF models is implemented by
+ the method with signature \code{numeric, numeric}. Other
+ factory methods provide convenient ways of creating NMF
+ models from e.g. a given target matrix or known
+ basis/coef matrices (see section \emph{Other Factory
+ Methods}).
+
+ This method creates an object of class \code{model},
+ using the extra arguments in \code{...} to initialise
+ slots that are specific to the given model.
+
+ All NMF models implement get/set methods to access the
+ matrix factors (see \code{\link{basis}}), which are
+ called to initialise them from arguments \code{W} and
+ \code{H}. These argument names derive from the definition
+ of all built-in models that inherit derive from class
+ \code{\linkS4class{NMFstd}}, which has two slots, \var{W}
+ and \var{H}, to hold the two factors -- following the
+ notations used in \cite{Lee et al. (1999)}.
+
+ If argument \code{target} is missing, the method creates
+ a standard NMF model of dimension 0x\code{rank}x0. That
+ is that the basis and mixture coefficient matrices,
+ \var{W} and \var{H}, have dimension 0x\code{rank} and
+ \code{rank}x0 respectively.
+
+ If target dimensions are also provided in argument
+ \code{target} as a 2-length vector, then the method
+ creates an \code{NMF} object compatible to fit a target
+ matrix of dimension \code{target[1]}x\code{target[2]}.
+ That is that the basis and mixture coefficient matrices,
+ \var{W} and \var{H}, have dimension
+ \code{target[1]}x\code{rank} and
+ \code{rank}x\code{target[2]} respectively. The target
+ dimensions can also be specified using both arguments
+ \code{target} and \code{ncol} to define the number of
+ rows and the number of columns of the target matrix
+ respectively. If no other argument is provided, these
+ matrices are filled with NAs.
+
+ If arguments \code{W} and/or \code{H} are provided, the
+ method creates a NMF model where the basis and mixture
+ coefficient matrices, \var{W} and \var{H}, are
+ initialised using the values of \code{W} and/or \code{H}.
+
+ The dimensions given by \code{target}, \code{W} and
+ \code{H}, must be compatible. However if
+ \code{force.dim=TRUE}, the method will reduce the
+ dimensions to the achieve dimension compatibility
+ whenever possible.
+
+ When \code{W} and \code{H} are both provided, the
+ \code{NMF} object created is suitable to seed a NMF
+ algorithm in a call to the \code{\link{nmf}} method. Note
+ that in this case the factorisation rank is implicitly
+ set by the number of basis components in the seed.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+#----------
+# nmfModel,numeric,numeric-method
+#----------
+# data
+n <- 20; r <- 3; p <- 10
+V <- rmatrix(n, p) # some target matrix
+
+# create a r-ranked NMF model with a given target dimensions n x p as a 2-length vector
+nmfModel(r, c(n,p)) # directly
+nmfModel(r, dim(V)) # or from an existing matrix <=> nmfModel(r, V)
+# or alternatively passing each dimension separately
+nmfModel(r, n, p)
+
+# trying to create a NMF object based on incompatible matrices generates an error
+w <- rmatrix(n, r)
+h <- rmatrix(r+1, p)
+try( new('NMFstd', W=w, H=h) )
+try( nmfModel(w, h) )
+try( nmfModel(r+1, W=w, H=h) )
+# The factory method can be force the model to match some target dimensions
+# but warnings are thrown
+nmfModel(r, W=w, H=h)
+nmfModel(r, n-1, W=w, H=h)
+
+#----------
+# nmfModel,numeric,missing-method
+#----------
+## Empty model of given rank
+nmfModel(3)
+
+#----------
+# nmfModel,missing,ANY-method
+#----------
+nmfModel(target=10) #square
+nmfModel(target=c(10, 5))
+
+#----------
+# nmfModel,missing,missing-method
+#----------
+# Build an empty NMF model
+nmfModel()
+
+# create a NMF object based on one random matrix: the missing matrix is deduced
+# Note this only works when using factory method NMF
+n <- 50; r <- 3;
+w <- rmatrix(n, r)
+nmfModel(W=w)
+
+# create a NMF object based on random (compatible) matrices
+p <- 20
+h <- rmatrix(r, p)
+nmfModel(H=h)
+
+# specifies two compatible matrices
+nmfModel(W=w, H=h)
+# error if not compatible
+try( nmfModel(W=w, H=h[-1,]) )
+
+#----------
+# nmfModel,numeric,matrix-method
+#----------
+# create a r-ranked NMF model compatible with a given target matrix
+obj <- nmfModel(r, V)
+all(is.na(basis(obj)))
+
+#----------
+# nmfModel,matrix,matrix-method
+#----------
+## From two existing factors
+
+# allows a convenient call without argument names
+w <- rmatrix(n, 3); h <- rmatrix(3, p)
+nmfModel(w, h)
+
+# Specify the type of NMF model (e.g. 'NMFns' for non-smooth NMF)
+mod <- nmfModel(w, h, model='NMFns')
+mod
+
+# One can use such an NMF model as a seed when fitting a target matrix with nmf()
+V <- rmatrix(mod)
+res <- nmf(V, mod)
+nmf.equal(res, nmf(V, mod))
+
+# NB: when called only with such a seed, the rank and the NMF algorithm
+# are selected based on the input NMF model.
+# e.g. here rank was 3 and the algorithm "nsNMF" is used, because it is the default
+# algorithm to fit "NMFns" models (See ?nmf).
+
+#----------
+# nmfModel,matrix,ANY-method
+#----------
+## swapped arguments `rank` and `target`
+V <- rmatrix(20, 10)
+nmfModel(V) # equivalent to nmfModel(target=V)
+nmfModel(V, 3) # equivalent to nmfModel(3, V)
+
+#----------
+# nmfModel,formula,ANY-method
+#----------
+# empty 3-rank model
+nmfModel(~ 3)
+
+# 3-rank model that fits a given data matrix
+x <- rmatrix(20,10)
+nmfModel(x ~ 3)
+
+# add fixed coefficient term defined by a factor
+gr <- gl(2, 5)
+nmfModel(x ~ 3 + gr)
+
+# add fixed coefficient term defined by a numeric covariate
+nmfModel(x ~ 3 + gr + b, data=list(b=runif(10)))
+
+# 3-rank model that fits a given ExpressionSet (with fixed coef terms)
+e <- ExpressionSet(x)
+pData(e) <- data.frame(a=runif(10))
+nmfModel(e ~ 3 + gr + a) # `a` is looked up in the phenotypic data of x pData(x)
+
+#----------
+# nmfModels
+#----------
+# show all the NMF models available (i.e. the classes that inherit from class NMF)
+nmfModels()
+# show all the built-in NMF models available
+nmfModels(builtin.only=TRUE)
+}
+\references{
+ Lee DD and Seung HS (1999). "Learning the parts of
+ objects by non-negative matrix factorization." _Nature_,
+ *401*(6755), pp. 788-91. ISSN 0028-0836, <URL:
+ http://dx.doi.org/10.1038/44565>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/10548103>.
+}
+\seealso{
+ \code{\link{is.empty.nmf}}
+
+ Other NMF-interface: \code{\link{basis}},
+ \code{\link{.basis}}, \code{\link{.basis<-}},
+ \code{\link{basis<-}}, \code{\link{coef}},
+ \code{\link{.coef}}, \code{\link{.coef<-}},
+ \code{\link{coef<-}}, \code{\link{coefficients}},
+ \code{\link{.DollarNames,NMF-method}},
+ \code{\link{loadings,NMF-method}}, \code{\link{misc}},
+ \code{\link{NMF-class}}, \code{\link{$<-,NMF-method}},
+ \code{\link{$,NMF-method}}, \code{\link{rnmf}},
+ \code{\link{scoef}}
+}
+\keyword{methods}
+
diff --git a/man/nmfObject.Rd b/man/nmfObject.Rd
new file mode 100644
index 0000000..e05dad2
--- /dev/null
+++ b/man/nmfObject.Rd
@@ -0,0 +1,26 @@
+\name{nmfObject}
+\alias{nmfObject}
+\title{Updating NMF Objects}
+\usage{
+ nmfObject(object, verbose = FALSE)
+}
+\arguments{
+ \item{object}{an R object created by the NMF package,
+ e.g., an object of class \code{\linkS4class{NMF}} or
+ \code{\linkS4class{NMFfit}}.}
+
+ \item{verbose}{logical to toggle verbose messages.}
+}
+\description{
+ This function serves to update an objects created with
+ previous versions of the NMF package, which would
+ otherwise be incompatible with the current version, due
+ to changes in their S4 class definition.
+}
+\details{
+ This function makes use of heuristics to automatically
+ update object slots, which have been borrowed from the
+ BiocGenerics package, the function
+ \code{updateObjectFromSlots} in particular.
+}
+
diff --git a/man/nmfReport.Rd b/man/nmfReport.Rd
new file mode 100644
index 0000000..a32f87d
--- /dev/null
+++ b/man/nmfReport.Rd
@@ -0,0 +1,58 @@
+\name{nmfReport}
+\alias{nmfReport}
+\title{Run NMF Methods and Generate a Report}
+\usage{
+ nmfReport(x, rank, method, colClass = NULL, ...,
+ output = NULL, template = NULL)
+}
+\arguments{
+ \item{x}{target matrix}
+
+ \item{rank}{factorization rank}
+
+ \item{method}{list of methods to apply}
+
+ \item{colClass}{reference class to assess accuracy}
+
+ \item{...}{extra paramters passed to \code{\link{nmf}}}
+
+ \item{output}{output HTML file}
+
+ \item{template}{template Rmd file}
+}
+\value{
+ a list with the following elements: \item{fits}{the
+ fit(s) for each method and each value of the rank.}
+ \item{accuracy}{a data.frame that contains the summary
+ assessment measures, for each fit.}
+}
+\description{
+ Generates an HTML report from running a set of method on
+ a given target matrix, for a set of factorization ranks.
+}
+\details{
+ The report is based on an .Rmd document
+ \code{'report.Rmd'} stored in the package installation
+ sub-directory \code{scripts/}, and is compiled using
+ \pkg{knitr}.
+
+ At the beginning of the document, a file named
+ \code{'functions.R'} is looked for in the current
+ directory, and sourced if present. This enables the
+ definition of custom NMF methods (see
+ \code{\link{setNMFMethod}}) or setting global options.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+\dontrun{
+
+x <- rmatrix(20, 10)
+gr <- gl(2, 5)
+nmfReport(x, 2:4, method = list('br', 'lee'), colClass = gr, nrun = 5)
+
+}
+}
+
diff --git a/man/nmfSeed.Rd b/man/nmfSeed.Rd
new file mode 100644
index 0000000..0c0da91
--- /dev/null
+++ b/man/nmfSeed.Rd
@@ -0,0 +1,79 @@
+\name{nmfSeed}
+\alias{existsNMFSeed}
+\alias{getNMFSeed}
+\alias{nmfSeed}
+\title{Seeding Strategies for NMF Algorithms}
+\usage{
+ nmfSeed(name = NULL, ...)
+
+ getNMFSeed(name = NULL, ...)
+
+ existsNMFSeed(name, exact = TRUE)
+}
+\arguments{
+ \item{name}{access key of a seeding method stored in
+ registry. If missing, \code{nmfSeed} returns the list of
+ all available seeding methods.}
+
+ \item{...}{extra arguments used for internal calls}
+
+ \item{exact}{a logical that indicates if the access key
+ should be matched exactly or partially.}
+}
+\description{
+ \code{nmfSeed} lists and retrieves NMF seeding methods.
+
+ \code{getNMFSeed} is an alias for \code{nmfSeed}.
+
+ \code{existsNMFSeed} tells if a given seeding method
+ exists in the registry.
+}
+\details{
+ Currently the internal registry contains the following
+ seeding methods, which may be specified to the function
+ \code{\link{nmf}} via its argument \code{seed} using
+ their access keys:
+
+ \describe{ \item{random}{ The entries of each factors are
+ drawn from a uniform distribution over \eqn{[0, max(x)]},
+ where $x$ is the target matrix.} \item{nndsvd}{
+ Nonnegative Double Singular Value Decomposition.
+
+ The basic algorithm contains no randomization and is
+ based on two SVD processes, one approximating the data
+ matrix, the other approximating positive sections of the
+ resulting partial SVD factors utilising an algebraic
+ property of unit rank matrices.
+
+ It is well suited to initialise NMF algorithms with
+ sparse factors. Simple practical variants of the
+ algorithm allows to generate dense factors.
+
+ \strong{Reference:} \cite{Boutsidis et al. (2008)}}
+ \item{ica}{ Uses the result of an Independent Component
+ Analysis (ICA) (from the \code{fastICA} package). Only
+ the positive part of the result are used to initialise
+ the factors.} \item{none}{ Fixed seed.
+
+ This method allows the user to manually provide initial
+ values for both matrix factors.} }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# list all registered seeding methods
+nmfSeed()
+# retrieve one of the methods
+nmfSeed('ica')
+}
+\references{
+ Boutsidis C and Gallopoulos E (2008). "SVD based
+ initialization: A head start for nonnegative matrix
+ factorization." _Pattern Recognition_, *41*(4), pp.
+ 1350-1362. ISSN 00313203, <URL:
+ http://dx.doi.org/10.1016/j.patcog.2007.09.010>, <URL:
+ http://linkinghub.elsevier.com/retrieve/pii/S0031320307004359>.
+}
+
diff --git a/man/nmfWrapper.Rd b/man/nmfWrapper.Rd
new file mode 100644
index 0000000..e28a195
--- /dev/null
+++ b/man/nmfWrapper.Rd
@@ -0,0 +1,73 @@
+\name{nmfWrapper}
+\alias{nmfWrapper}
+\title{Wrapping NMF Algorithms}
+\usage{
+ nmfWrapper(method, ..., .FIXED = FALSE)
+}
+\arguments{
+ \item{method}{Name of the NMF algorithm to be wrapped. It
+ should be the name of a registered algorithm as returned
+ by \code{\link{nmfAlgorithm}}, or an NMF algorithm object
+ (i.e. an instance of \code{\linkS4class{NMFStrategy}}).}
+
+ \item{...}{extra named arguments that define default
+ values for any arguments of \code{\link{nmf}} or the
+ algorithm itself.}
+
+ \item{.FIXED}{a logical that indicates if the default
+ arguments defined in \code{...} must be considered as
+ fixed, i.e. that they are forced to have the defined
+ values and cannot be used in a call to the wrapper
+ function, in which case, a warning about discarding them
+ is thrown if they are used. Non fixed arguments may have
+ their value changed at call time, in which case it is
+ honoured and passed to the \code{nmf} call.
+
+ \code{.FIXED} may also be a character vector that
+ specifies which argument amongst \code{...} should be
+ considered as fixed.}
+}
+\value{
+ a function with argument \code{...} and a set of default
+ arguments defined in \code{...} in the call to
+ \code{nmfWrapper}.
+}
+\description{
+ This function creates a wrapper function for calling the
+ function \code{\link{nmf}} with a given NMF algorithm.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# wrap Lee & Seung algorithm into a function
+lee <- nmfWrapper('lee', seed=12345)
+args(lee)
+
+# test on random data
+x <- rmatrix(100,20)
+res <- nmf(x, 3, 'lee', seed=12345)
+res2 <- lee(x, 3)
+nmf.equal(res, res2)
+res3 <- lee(x, 3, seed=123)
+nmf.equal(res, res3)
+
+\dontshow{
+stopifnot(nmf.equal(res, res2))
+stopifnot( !nmf.equal(res, res3))
+}
+
+# argument 'method' has no effect
+res4 <- lee(x, 3, method='brunet')
+nmf.equal(res, res4)
+
+\dontshow{
+stopifnot(nmf.equal(res, res4))
+}
+}
+\seealso{
+ \code{\link{nmfAlgorithm}}, \code{\link{nmf}}
+}
+\keyword{internal}
+
diff --git a/man/nmf_update_KL.Rd b/man/nmf_update_KL.Rd
new file mode 100644
index 0000000..6f4fc1e
--- /dev/null
+++ b/man/nmf_update_KL.Rd
@@ -0,0 +1,89 @@
+\name{nmf_update.KL.h}
+\alias{nmf_update.KL}
+\alias{nmf_update.KL.h}
+\alias{nmf_update.KL.h_R}
+\alias{nmf_update.KL.w}
+\alias{nmf_update.KL.w_R}
+\title{NMF Multiplicative Updates for Kullback-Leibler Divergence}
+\usage{
+ nmf_update.KL.h(v, w, h, nbterms = 0L, ncterms = 0L,
+ copy = TRUE)
+
+ nmf_update.KL.h_R(v, w, h, wh = NULL)
+
+ nmf_update.KL.w(v, w, h, nbterms = 0L, ncterms = 0L,
+ copy = TRUE)
+
+ nmf_update.KL.w_R(v, w, h, wh = NULL)
+}
+\arguments{
+ \item{v}{target matrix}
+
+ \item{w}{current basis matrix}
+
+ \item{h}{current coefficient matrix}
+
+ \item{nbterms}{number of fixed basis terms}
+
+ \item{ncterms}{number of fixed coefficient terms}
+
+ \item{copy}{logical that indicates if the update should
+ be made on the original matrix directly (\code{FALSE}) or
+ on a copy (\code{TRUE} - default). With \code{copy=FALSE}
+ the memory footprint is very small, and some speed-up may
+ be achieved in the case of big matrices. However, greater
+ care should be taken due the side effect. We recommend
+ that only experienced users use \code{copy=TRUE}.}
+
+ \item{wh}{already computed NMF estimate used to compute
+ the denominator term.}
+}
+\value{
+ a matrix of the same dimension as the input matrix to
+ update (i.e. \code{w} or \code{h}). If \code{copy=FALSE},
+ the returned matrix uses the same memory as the input
+ object.
+}
+\description{
+ Multiplicative updates from \cite{Lee et al. (2001)} for
+ standard Nonnegative Matrix Factorization models \eqn{V
+ \approx W H}, where the distance between the target
+ matrix and its NMF estimate is measured by the
+ Kullback-Leibler divergence.
+
+ \code{nmf_update.KL.w} and \code{nmf_update.KL.h} compute
+ the updated basis and coefficient matrices respectively.
+ They use a \emph{C++} implementation which is optimised
+ for speed and memory usage.
+
+ \code{nmf_update.KL.w_R} and \code{nmf_update.KL.h_R}
+ implement the same updates in \emph{plain R}.
+}
+\details{
+ The coefficient matrix (\code{H}) is updated as follows:
+ \deqn{ H_{kj} \leftarrow H_{kj} \frac{\left( sum_i
+ \frac{W_{ik} V_{ij}}{(WH)_{ij}} \right)}{ sum_i W_{ik} }.
+ }{ H_kj <- H_kj ( sum_i [ W_ik V_ij / (WH)_ij ] ) / (
+ sum_i W_ik ) }
+
+ These updates are used in built-in NMF algorithms
+ \code{\link[=KL-nmf]{KL}} and
+ \code{\link[=brunet-nmf]{brunet}}.
+
+ The basis matrix (\code{W}) is updated as follows: \deqn{
+ W_{ik} \leftarrow W_{ik} \frac{ sum_j [\frac{H_{kj}
+ A_{ij}}{(WH)_{ij}} ] }{sum_j H_{kj} } }{ W_ik <- W_ik (
+ sum_u [H_kl A_il / (WH)_il ] ) / ( sum_l H_kl ) }
+}
+\author{
+ Update definitions by \cite{Lee2001}.
+
+ C++ optimised implementation by Renaud Gaujoux.
+}
+\references{
+ Lee DD and Seung H (2001). "Algorithms for non-negative
+ matrix factorization." _Advances in neural information
+ processing systems_. <URL:
+ http://scholar.google.com/scholar?q=intitle:Algorithms+for+non-negative+matrix+factorization\#0>.
+}
+
diff --git a/man/nmf_update_euclidean.Rd b/man/nmf_update_euclidean.Rd
new file mode 100644
index 0000000..ca24965
--- /dev/null
+++ b/man/nmf_update_euclidean.Rd
@@ -0,0 +1,99 @@
+\name{nmf_update.euclidean.h}
+\alias{nmf_update.euclidean}
+\alias{nmf_update.euclidean.h}
+\alias{nmf_update.euclidean.h_R}
+\alias{nmf_update.euclidean.w}
+\alias{nmf_update.euclidean.w_R}
+\title{NMF Multiplicative Updates for Euclidean Distance}
+\usage{
+ nmf_update.euclidean.h(v, w, h, eps = 10^-9,
+ nbterms = 0L, ncterms = 0L, copy = TRUE)
+
+ nmf_update.euclidean.h_R(v, w, h, wh = NULL, eps = 10^-9)
+
+ nmf_update.euclidean.w(v, w, h, eps = 10^-9,
+ nbterms = 0L, ncterms = 0L, weight = NULL, copy = TRUE)
+
+ nmf_update.euclidean.w_R(v, w, h, wh = NULL, eps = 10^-9)
+}
+\arguments{
+ \item{eps}{small numeric value used to ensure numeric
+ stability, by shifting up entries from zero to this fixed
+ value.}
+
+ \item{wh}{already computed NMF estimate used to compute
+ the denominator term.}
+
+ \item{weight}{numeric vector of sample weights, e.g.,
+ used to normalise samples coming from multiple datasets.
+ It must be of the same length as the number of
+ samples/columns in \code{v} -- and \code{h}.}
+
+ \item{v}{target matrix}
+
+ \item{w}{current basis matrix}
+
+ \item{h}{current coefficient matrix}
+
+ \item{nbterms}{number of fixed basis terms}
+
+ \item{ncterms}{number of fixed coefficient terms}
+
+ \item{copy}{logical that indicates if the update should
+ be made on the original matrix directly (\code{FALSE}) or
+ on a copy (\code{TRUE} - default). With \code{copy=FALSE}
+ the memory footprint is very small, and some speed-up may
+ be achieved in the case of big matrices. However, greater
+ care should be taken due the side effect. We recommend
+ that only experienced users use \code{copy=TRUE}.}
+}
+\value{
+ a matrix of the same dimension as the input matrix to
+ update (i.e. \code{w} or \code{h}). If \code{copy=FALSE},
+ the returned matrix uses the same memory as the input
+ object.
+}
+\description{
+ Multiplicative updates from \cite{Lee et al. (2001)} for
+ standard Nonnegative Matrix Factorization models \eqn{V
+ \approx W H}, where the distance between the target
+ matrix and its NMF estimate is measured by the --
+ euclidean -- Frobenius norm.
+
+ \code{nmf_update.euclidean.w} and
+ \code{nmf_update.euclidean.h} compute the updated basis
+ and coefficient matrices respectively. They use a
+ \emph{C++} implementation which is optimised for speed
+ and memory usage.
+
+ \code{nmf_update.euclidean.w_R} and
+ \code{nmf_update.euclidean.h_R} implement the same
+ updates in \emph{plain R}.
+}
+\details{
+ The coefficient matrix (\code{H}) is updated as follows:
+ \deqn{ H_{kj} \leftarrow \frac{\max(H_{kj} W^T V)_{kj},
+ \varepsilon) }{(W^T W H)_{kj} + \varepsilon} }{ H_kj <-
+ max(H_kj (W^T V)_kj, eps) / ( (W^T W H)_kj + eps ) }
+
+ These updates are used by the built-in NMF algorithms
+ \code{\link[=Frobenius-nmf]{Frobenius}} and
+ \code{\link[=lee-nmf]{lee}}.
+
+ The basis matrix (\code{W}) is updated as follows: \deqn{
+ W_ik \leftarrow \frac{\max(W_ik (V H^T)_ik, \varepsilon)
+ }{ (W H H^T)_ik + \varepsilon} }{ W_ik <- max(W_ik (V
+ H^T)_ik, eps) / ( (W H H^T)_ik + eps ) }
+}
+\author{
+ Update definitions by \cite{Lee2001}.
+
+ C++ optimised implementation by Renaud Gaujoux.
+}
+\references{
+ Lee DD and Seung H (2001). "Algorithms for non-negative
+ matrix factorization." _Advances in neural information
+ processing systems_. <URL:
+ http://scholar.google.com/scholar?q=intitle:Algorithms+for+non-negative+matrix+factorization\#0>.
+}
+
diff --git a/man/nneg.Rd b/man/nneg.Rd
new file mode 100644
index 0000000..a83a1a0
--- /dev/null
+++ b/man/nneg.Rd
@@ -0,0 +1,198 @@
+\docType{methods}
+\name{nneg}
+\alias{nneg}
+\alias{nneg,matrix-method}
+\alias{nneg-methods}
+\alias{nneg,NMF-method}
+\alias{posneg}
+\alias{rposneg}
+\alias{rposneg,matrix-method}
+\alias{rposneg-methods}
+\alias{rposneg,NMF-method}
+\title{Transforming from Mixed-sign to Nonnegative Data}
+\usage{
+ nneg(object, ...)
+
+ \S4method{nneg}{matrix}(object,
+ method = c("pmax", "posneg", "absolute", "min"),
+ threshold = 0, shift = TRUE)
+
+ posneg(...)
+
+ rposneg(object, ...)
+
+ \S4method{rposneg}{matrix}(object, unstack = TRUE)
+}
+\arguments{
+ \item{object}{The data object to transform}
+
+ \item{...}{extra arguments to allow extension or passed
+ down to \code{nneg,matrix} or \code{rposneg,matrix} in
+ subsequent calls.}
+
+ \item{method}{Name of the transformation method to use,
+ that is partially matched against the following possible
+ methods: \describe{ \item{pmax}{Each entry is constrained
+ to be above threshold \code{threshold}.}
+
+ \item{posneg}{The matrix is split into its "positive" and
+ "negative" parts, with the entries of each part
+ constrained to be above threshold \code{threshold}. The
+ result consists in these two parts stacked in rows (i.e.
+ \code{\link{rbind}}-ed) into a single matrix, which has
+ double the number of rows of the input matrix
+ \code{object}.}
+
+ \item{absolute}{The absolute value of each entry is
+ constrained to be above threshold \code{threshold}.}
+
+ \item{min}{Global shift by adding the minimum entry to
+ each entry, only if it is negative, and then apply
+ threshold. }
+
+ }}
+
+ \item{threshold}{Nonnegative lower threshold value
+ (single numeric). See argument \code{shit} for details on
+ how the threshold is used and affects the result.}
+
+ \item{shift}{a logical indicating whether the entries
+ below the threshold value \code{threshold} should be
+ forced (shifted) to 0 (default) or to the threshold value
+ itself. In other words, if \code{shift=TRUE} (default)
+ all entries in the result matrix are either 0 or strictly
+ greater than \code{threshold}. They are all greater or
+ equal than \code{threshold} otherwise.}
+
+ \item{unstack}{Logical indicating whether the positive
+ and negative parts should be unstacked and combined into
+ a matrix as \code{pos - neg}, which contains half the
+ number of rows of \code{object} (default), or left
+ stacked as \code{[pos; -neg]}.}
+}
+\value{
+ an object of the same class as argument \code{object}.
+
+ an object of the same type of \code{object}
+}
+\description{
+ \code{nneg} is a generic function to transform a data
+ objects that contains negative values into a similar
+ object that only contains values that are nonnegative or
+ greater than a given threshold.
+
+ \code{posneg} is a shortcut for \code{nneg(...,
+ method='posneg')}, to split mixed-sign data into its
+ positive and negative part. See description for method
+ \code{"posneg"}, in \code{\link{nneg}}.
+
+ \code{rposneg} performs the "reverse" transformation of
+ the \code{\link{posneg}} function.
+}
+\section{Methods}{
+ \describe{
+
+ \item{nneg}{\code{signature(object = "matrix")}:
+ Transforms a mixed-sign matrix into a nonnegative matrix,
+ optionally apply a lower threshold. This is the workhorse
+ method, that is eventually called by all other methods
+ defined in the \code{\link{NMF}} package. }
+
+ \item{nneg}{\code{signature(object = "NMF")}: Apply
+ \code{nneg} to the basis matrix of an \code{\link{NMF}}
+ object (i.e. \code{basis(object)}). All extra arguments
+ in \code{...} are passed to the method
+ \code{nneg,matrix}. }
+
+ \item{rposneg}{\code{signature(object = "NMF")}: Apply
+ \code{rposneg} to the basis matrix of an
+ \code{\link{NMF}} object. }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+#----------
+# nneg,matrix-method
+#----------
+# random mixed sign data (normal distribution)
+set.seed(1)
+x <- rmatrix(5,5, rnorm, mean=0, sd=5)
+x
+
+# pmax (default)
+nneg(x)
+# using a threshold
+nneg(x, threshold=2)
+# without shifting the entries lower than threshold
+nneg(x, threshold=2, shift=FALSE)
+
+# posneg: split positive and negative part
+nneg(x, method='posneg')
+nneg(x, method='pos', threshold=2)
+
+# absolute
+nneg(x, method='absolute')
+nneg(x, method='abs', threshold=2)
+
+# min
+nneg(x, method='min')
+nneg(x, method='min', threshold=2)
+
+#----------
+# nneg,NMF-method
+#----------
+# random
+M <- nmfModel(x, rmatrix(ncol(x), 3))
+nnM <- nneg(M)
+basis(nnM)
+# mixture coefficients are not affected
+identical( coef(M), coef(nnM) )
+
+#----------
+# posneg
+#----------
+# shortcut for the "posneg" transformation
+posneg(x)
+posneg(x, 2)
+
+#----------
+# rposneg,matrix-method
+#----------
+# random mixed sign data (normal distribution)
+set.seed(1)
+x <- rmatrix(5,5, rnorm, mean=0, sd=5)
+x
+
+# posneg-transform: split positive and negative part
+y <- posneg(x)
+dim(y)
+# posneg-reverse
+z <- rposneg(y)
+identical(x, z)
+rposneg(y, unstack=FALSE)
+
+# But posneg-transformation with a non zero threshold is not reversible
+y1 <- posneg(x, 1)
+identical(rposneg(y1), x)
+
+#----------
+# rposneg,NMF-method
+#----------
+# random mixed signed NMF model
+M <- nmfModel(rmatrix(10, 3, rnorm), rmatrix(3, 4))
+# split positive and negative part
+nnM <- posneg(M)
+M2 <- rposneg(nnM)
+identical(M, M2)
+}
+\seealso{
+ \code{\link{pmax}}
+
+ Other transforms: \code{\link{t.NMF}}
+}
+\keyword{methods}
+
diff --git a/man/nsNMF-nmf.Rd b/man/nsNMF-nmf.Rd
new file mode 100644
index 0000000..3eee174
--- /dev/null
+++ b/man/nsNMF-nmf.Rd
@@ -0,0 +1,121 @@
+\name{nmf_update.ns}
+\alias{nmfAlgorithm.nsNMF}
+\alias{nmfAlgorithm.nsNMF_R}
+\alias{nmf_update.ns}
+\alias{nmf_update.ns_R}
+\alias{nsNMF_R-nmf}
+\title{NMF Multiplicative Update for Nonsmooth Nonnegative Matrix Factorization (nsNMF).}
+\usage{
+ nmf_update.ns(i, v, x, copy = FALSE, ...)
+
+ nmf_update.ns_R(i, v, x, ...)
+
+ nmfAlgorithm.nsNMF_R(..., .stop = NULL,
+ maxIter = nmf.getOption("maxIter") \%||\% 2000,
+ stopconv = 40, check.interval = 10)
+
+ nmfAlgorithm.nsNMF(..., .stop = NULL,
+ maxIter = nmf.getOption("maxIter") \%||\% 2000,
+ copy = FALSE, stopconv = 40, check.interval = 10)
+}
+\arguments{
+ \item{i}{current iteration number.}
+
+ \item{v}{target matrix.}
+
+ \item{x}{current NMF model, as an
+ \code{\linkS4class{NMF}} object.}
+
+ \item{copy}{logical that indicates if the update should
+ be made on the original matrix directly (\code{FALSE}) or
+ on a copy (\code{TRUE} - default). With \code{copy=FALSE}
+ the memory footprint is very small, and some speed-up may
+ be achieved in the case of big matrices. However, greater
+ care should be taken due the side effect. We recommend
+ that only experienced users use \code{copy=TRUE}.}
+
+ \item{...}{extra arguments. These are generally not used
+ and present only to allow other arguments from the main
+ call to be passed to the initialisation and stopping
+ criterion functions (slots \code{onInit} and \code{Stop}
+ respectively).}
+
+ \item{.stop}{specification of a stopping criterion, that
+ is used instead of the one associated to the NMF
+ algorithm. It may be specified as: \itemize{ \item the
+ access key of a registered stopping criterion; \item a
+ single integer that specifies the exact number of
+ iterations to perform, which will be honoured unless a
+ lower value is explicitly passed in argument
+ \code{maxIter}. \item a single numeric value that
+ specifies the stationnarity threshold for the objective
+ function, used in with \code{\link{nmf.stop.stationary}};
+ \item a function with signature
+ \code{(object="NMFStrategy", i="integer", y="matrix",
+ x="NMF", ...)}, where \code{object} is the
+ \code{NMFStrategy} object that describes the algorithm
+ being run, \code{i} is the current iteration, \code{y} is
+ the target matrix and \code{x} is the current value of
+ the NMF model. }}
+
+ \item{maxIter}{maximum number of iterations to perform.}
+
+ \item{stopconv}{number of iterations intervals over which
+ the connectivity matrix must not change for stationarity
+ to be achieved.}
+
+ \item{check.interval}{interval (in number of iterations)
+ on which the stopping criterion is computed.}
+}
+\value{
+ an \code{\linkS4class{NMFns}} model object.
+}
+\description{
+ These update rules, defined for the
+ \code{\linkS4class{NMFns}} model \eqn{V \approx W S H}
+ from \cite{Pascual-Montano et al. (2006)}, that
+ introduces an intermediate smoothing matrix to enhance
+ sparsity of the factors.
+
+ \code{nmf_update.ns} computes the updated nsNMF model. It
+ uses the optimized \emph{C++} implementations
+ \code{\link{nmf_update.KL.w}} and
+ \code{\link{nmf_update.KL.h}} to update \eqn{W} and
+ \eqn{H} respectively.
+
+ \code{nmf_update.ns_R} implements the same updates in
+ \emph{plain R}.
+
+ Algorithms \sQuote{nsNMF} and \sQuote{.R#nsNMF} provide
+ the complete NMF algorithm from \cite{Pascual-Montano et
+ al. (2006)}, using the C++-optimised and plain R updates
+ \code{\link{nmf_update.brunet}} and
+ \code{\link{nmf_update.brunet_R}} respectively. The
+ stopping criterion is based on the stationarity of the
+ connectivity matrix.
+}
+\details{
+ The multiplicative updates are based on the updates
+ proposed by \cite{Brunet et al. (2004)}, except that the
+ NMF estimate \eqn{W H} is replaced by \eqn{W S H} and
+ \eqn{W} (resp. \eqn{H}) is replaced by \eqn{W S} (resp.
+ \eqn{S H}) in the update of \eqn{H} (resp. \eqn{W}).
+
+ See \code{\link{nmf_update.KL}} for more details on the
+ update formula.
+}
+\references{
+ Pascual-Montano A, Carazo JM, Kochi K, Lehmann D and
+ Pascual-marqui RD (2006). "Nonsmooth nonnegative matrix
+ factorization (nsNMF)." _IEEE Trans. Pattern Anal. Mach.
+ Intell_, *28*, pp. 403-415.
+
+ Brunet J, Tamayo P, Golub TR and Mesirov JP (2004).
+ "Metagenes and molecular pattern discovery using matrix
+ factorization." _Proceedings of the National Academy of
+ Sciences of the United States of America_, *101*(12), pp.
+ 4164-9. ISSN 0027-8424, <URL:
+ http://dx.doi.org/10.1073/pnas.0308531101>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/15016911>.
+}
+
diff --git a/man/objective-commaNMFfit-method.Rd b/man/objective-commaNMFfit-method.Rd
new file mode 100644
index 0000000..01caf3a
--- /dev/null
+++ b/man/objective-commaNMFfit-method.Rd
@@ -0,0 +1,24 @@
+\docType{methods}
+\name{objective,NMFfit-method}
+\alias{objective,NMFfit-method}
+\title{Returns the objective function associated with the algorithm that computed the
+fitted NMF model \code{object}, or the objective value with respect to a given
+target matrix \code{y} if it is supplied.}
+\usage{
+ \S4method{objective}{NMFfit}(object, y)
+}
+\arguments{
+ \item{y}{optional target matrix used to compute the
+ objective value.}
+
+ \item{object}{an object computed using some algorithm, or
+ that describes an algorithm itself.}
+}
+\description{
+ Returns the objective function associated with the
+ algorithm that computed the fitted NMF model
+ \code{object}, or the objective value with respect to a
+ given target matrix \code{y} if it is supplied.
+}
+\keyword{methods}
+
diff --git a/man/offset-commaNMFOffset-method.Rd b/man/offset-commaNMFOffset-method.Rd
new file mode 100644
index 0000000..a97de13
--- /dev/null
+++ b/man/offset-commaNMFOffset-method.Rd
@@ -0,0 +1,17 @@
+\docType{methods}
+\name{offset,NMFOffset-method}
+\alias{offset,NMFOffset-method}
+\title{Offsets in NMF Models with Offset}
+\usage{
+ \S4method{offset}{NMFOffset}(object)
+}
+\arguments{
+ \item{object}{an instance of class \code{NMFOffset}.}
+}
+\description{
+ The function \code{offset} returns the offset vector from
+ an NMF model that has an offset, e.g. an \code{NMFOffset}
+ model.
+}
+\keyword{methods}
+
diff --git a/man/offset-commaNMFfit-method.Rd b/man/offset-commaNMFfit-method.Rd
new file mode 100644
index 0000000..e98a6dc
--- /dev/null
+++ b/man/offset-commaNMFfit-method.Rd
@@ -0,0 +1,15 @@
+\docType{methods}
+\name{offset,NMFfit-method}
+\alias{offset,NMFfit-method}
+\title{Returns the offset from the fitted model.}
+\usage{
+ \S4method{offset}{NMFfit}(object)
+}
+\arguments{
+ \item{object}{An offset to be included in a model frame}
+}
+\description{
+ Returns the offset from the fitted model.
+}
+\keyword{methods}
+
diff --git a/man/offset-nmf.Rd b/man/offset-nmf.Rd
new file mode 100644
index 0000000..bfd53d7
--- /dev/null
+++ b/man/offset-nmf.Rd
@@ -0,0 +1,146 @@
+\name{nmf_update.euclidean_offset.h}
+\alias{nmfAlgorithm.offset}
+\alias{nmfAlgorithm.offset_R}
+\alias{nmf_update.euclidean_offset.h}
+\alias{nmf_update.euclidean_offset.w}
+\alias{nmf_update.offset}
+\alias{nmf_update.offset_R}
+\alias{offset_R-nmf}
+\title{NMF Multiplicative Update for NMF with Offset Models}
+\usage{
+ nmf_update.euclidean_offset.h(v, w, h, offset,
+ eps = 10^-9, copy = TRUE)
+
+ nmf_update.euclidean_offset.w(v, w, h, offset,
+ eps = 10^-9, copy = TRUE)
+
+ nmf_update.offset_R(i, v, x, eps = 10^-9, ...)
+
+ nmf_update.offset(i, v, x, copy = FALSE, eps = 10^-9,
+ ...)
+
+ nmfAlgorithm.offset_R(..., .stop = NULL,
+ maxIter = nmf.getOption("maxIter") \%||\% 2000,
+ eps = 10^-9, stopconv = 40, check.interval = 10)
+
+ nmfAlgorithm.offset(..., .stop = NULL,
+ maxIter = nmf.getOption("maxIter") \%||\% 2000,
+ copy = FALSE, eps = 10^-9, stopconv = 40,
+ check.interval = 10)
+}
+\arguments{
+ \item{offset}{current value of the offset/intercept
+ vector. It must be of length equal to the number of rows
+ in the target matrix.}
+
+ \item{v}{target matrix.}
+
+ \item{eps}{small numeric value used to ensure numeric
+ stability, by shifting up entries from zero to this fixed
+ value.}
+
+ \item{copy}{logical that indicates if the update should
+ be made on the original matrix directly (\code{FALSE}) or
+ on a copy (\code{TRUE} - default). With \code{copy=FALSE}
+ the memory footprint is very small, and some speed-up may
+ be achieved in the case of big matrices. However, greater
+ care should be taken due the side effect. We recommend
+ that only experienced users use \code{copy=TRUE}.}
+
+ \item{i}{current iteration number.}
+
+ \item{x}{current NMF model, as an
+ \code{\linkS4class{NMF}} object.}
+
+ \item{...}{extra arguments. These are generally not used
+ and present only to allow other arguments from the main
+ call to be passed to the initialisation and stopping
+ criterion functions (slots \code{onInit} and \code{Stop}
+ respectively).}
+
+ \item{.stop}{specification of a stopping criterion, that
+ is used instead of the one associated to the NMF
+ algorithm. It may be specified as: \itemize{ \item the
+ access key of a registered stopping criterion; \item a
+ single integer that specifies the exact number of
+ iterations to perform, which will be honoured unless a
+ lower value is explicitly passed in argument
+ \code{maxIter}. \item a single numeric value that
+ specifies the stationnarity threshold for the objective
+ function, used in with \code{\link{nmf.stop.stationary}};
+ \item a function with signature
+ \code{(object="NMFStrategy", i="integer", y="matrix",
+ x="NMF", ...)}, where \code{object} is the
+ \code{NMFStrategy} object that describes the algorithm
+ being run, \code{i} is the current iteration, \code{y} is
+ the target matrix and \code{x} is the current value of
+ the NMF model. }}
+
+ \item{maxIter}{maximum number of iterations to perform.}
+
+ \item{stopconv}{number of iterations intervals over which
+ the connectivity matrix must not change for stationarity
+ to be achieved.}
+
+ \item{check.interval}{interval (in number of iterations)
+ on which the stopping criterion is computed.}
+
+ \item{w}{current basis matrix}
+
+ \item{h}{current coefficient matrix}
+}
+\value{
+ an \code{\linkS4class{NMFOffset}} model object.
+}
+\description{
+ These update rules proposed by \cite{Badea (2008)} are
+ modified version of the updates from \cite{Lee et al.
+ (2001)}, that include an offset/intercept vector, which
+ models a common baseline for each feature accross all
+ samples: \deqn{V \approx W H + I}
+
+ \code{nmf_update.euclidean_offset.h} and
+ \code{nmf_update.euclidean_offset.w} compute the updated
+ NMFOffset model, using the optimized \emph{C++}
+ implementations.
+
+ \code{nmf_update.offset_R} implements a complete single
+ update step, using plain R updates.
+
+ \code{nmf_update.offset} implements a complete single
+ update step, using C++-optimised updates.
+
+ Algorithms \sQuote{offset} and \sQuote{.R#offset} provide
+ the complete NMF-with-offset algorithm from \cite{Badea
+ (2008)}, using the C++-optimised and pure R updates
+ \code{\link{nmf_update.offset}} and
+ \code{\link{nmf_update.offset_R}} respectively.
+}
+\details{
+ The associated model is defined as an
+ \code{\linkS4class{NMFOffset}} object. The details of the
+ multiplicative updates can be found in \cite{Badea
+ (2008)}. Note that the updates are the ones defined for a
+ single datasets, not the simultaneous NMF model, which is
+ fit by algorithm \sQuote{siNMF} from formula-based NMF
+ models.
+}
+\author{
+ Original update definition: Liviu Badea
+
+ Port to R and optimisation in C++: Renaud Gaujoux
+}
+\references{
+ Badea L (2008). "Extracting gene expression profiles
+ common to colon and pancreatic adenocarcinoma using
+ simultaneous nonnegative matrix factorization." _Pacific
+ Symposium on Biocomputing. Pacific Symposium on
+ Biocomputing_, *290*, pp. 267-78. ISSN 1793-5091, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/18229692>.
+
+ Lee DD and Seung H (2001). "Algorithms for non-negative
+ matrix factorization." _Advances in neural information
+ processing systems_. <URL:
+ http://scholar.google.com/scholar?q=intitle:Algorithms+for+non-negative+matrix+factorization\#0>.
+}
+
diff --git a/man/options.Rd b/man/options.Rd
new file mode 100644
index 0000000..5c419f6
--- /dev/null
+++ b/man/options.Rd
@@ -0,0 +1,144 @@
+\name{options-NMF}
+\alias{nmf.getOption}
+\alias{nmf.options}
+\alias{nmf.printOptions}
+\alias{nmf.resetOptions}
+\alias{options-NMF}
+\title{NMF Package Specific Options}
+\usage{
+ nmf.options(...)
+
+ nmf.getOption(x, default = NULL)
+
+ nmf.resetOptions(..., ALL = FALSE)
+
+ nmf.printOptions()
+}
+\arguments{
+ \item{...}{option specifications. For \code{nmf.options}
+ this can be named arguments or a single unnamed argument
+ that is a named list (see \code{\link{options}}.
+
+ For \code{nmf.resetOptions}, this must be the names of
+ the options to reset. Note that \pkg{pkgmaker} version >=
+ 0.9.1 is required for this to work correctly, when
+ options other than the default ones have been set after
+ the package is loaded.}
+
+ \item{ALL}{logical that indicates if options that are not
+ part of the default set of options should be removed.
+ Note that in \pkg{pkgmaker <= 0.9} this argument is only
+ taken into account when no other argument is present.
+ This is fixed in version 0.9.1.}
+
+ \item{x}{a character string holding an option name.}
+
+ \item{default}{if the specified option is not set in the
+ options list, this value is returned. This facilitates
+ retrieving an option and checking whether it is set and
+ setting it separately if not.}
+}
+\description{
+ NMF Package Specific Options
+
+ \code{nmf.options} sets/get single or multiple options,
+ that are specific to the NMF package. It behaves in the
+ same way as \code{\link[base]{options}}.
+
+ \code{nmf.getOption} returns the value of a single
+ option, that is specific to the NMF package. It behaves
+ in the same way as \code{\link[base]{getOption}}.
+
+ \code{nmf.resetOptions} reset all NMF specific options to
+ their default values.
+
+ \code{nmf.printOptions} prints all NMF specific options
+ along with their default values, in a relatively compact
+ way.
+}
+\section{Available options}{
+ \describe{
+
+ \item{cores}{Default number of cores to use to perform
+ parallel NMF computations. Note that this option is
+ effectively used only if the global option \code{'cores'}
+ is not set. Moreover, the number of cores can also be set
+ at runtime, in the call to \code{\link{nmf}}, via
+ arguments \code{.pbackend} or \code{.options} (see
+ \code{\link{nmf}} for more details).}
+
+ \item{default.algorithm}{Default NMF algorithm used by
+ the \code{nmf} function when argument \code{method} is
+ missing. The value should the key of one of the
+ registered NMF algorithms or a valid specification of an
+ NMF algorithm. See \code{?nmfAlgorithm}.}
+
+ \item{default.seed}{Default seeding method used by the
+ \code{nmf} function when argument \code{seed} is missing.
+ The value should the key of one of the registered seeding
+ methods or a vallid specification of a seeding method.
+ See \code{?nmfSeed}.}
+
+ \item{track}{Toggle default residual tracking. When
+ \code{TRUE}, the \code{nmf} function compute and store
+ the residual track in the result -- if not otherwise
+ specified in argument \code{.options}. Note that tracking
+ may significantly slow down the computations.}
+
+ \item{track.interval}{Number of iterations between two
+ points in the residual track. This option is relevant
+ only when residual tracking is enabled. See \code{?nmf}.}
+
+ \item{error.track}{this is a symbolic link to option
+ \code{track} for backward compatibility.}
+
+ \item{pbackend}{Default loop/parallel foreach backend
+ used by the \code{nmf} function when argument
+ \code{.pbackend} is missing. Currently the following
+ values are supported: \code{'par'} for multicore,
+ \code{'seq'} for sequential, \code{NA} for standard
+ \code{sapply} (i.e. do not use a foreach loop),
+ \code{NULL} for using the currently registered foreach
+ backend.}
+
+ \item{parallel.backend}{this is a symbolic link to option
+ \code{pbackend} for backward compatibility.}
+
+ \item{gc}{Interval/frequency (in number of runs) at which
+ garbage collection is performed.}
+
+ \item{verbose}{Default level of verbosity.}
+
+ \item{debug}{Toogles debug mode. In this mode the console
+ output may be very -- very -- messy, and is aimed at
+ debugging only.}
+
+ \item{maxIter}{ Default maximum number of iteration to
+ use (default NULL). This option is for internal/technical
+ usage only, to globally speed up examples or tests of NMF
+ algorithms. To be used with care at one's own risk... It
+ is documented here so that advanced users are aware of
+ its existence, and can avoid possible conflict with their
+ own custom options. } } % end description
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# show all NMF specific options
+nmf.printOptions()
+
+# get some options
+nmf.getOption('verbose')
+nmf.getOption('pbackend')
+# set new values
+nmf.options(verbose=TRUE)
+nmf.options(pbackend='mc', default.algorithm='lee')
+nmf.printOptions()
+
+# reset to default
+nmf.resetOptions()
+nmf.printOptions()
+}
+
diff --git a/man/parallel.Rd b/man/parallel.Rd
new file mode 100644
index 0000000..667ab45
--- /dev/null
+++ b/man/parallel.Rd
@@ -0,0 +1,77 @@
+\name{parallel-NMF}
+\alias{gVariable}
+\alias{hostfile}
+\alias{parallel-NMF}
+\alias{ts_eval}
+\alias{ts_tempfile}
+\title{Utilities for Parallel Computations}
+\usage{
+ ts_eval(mutex = synchronicity::boost.mutex(),
+ verbose = FALSE)
+
+ ts_tempfile(pattern = "file", ..., host = TRUE,
+ pid = TRUE)
+
+ hostfile(pattern = "file", tmpdir = tempdir(),
+ fileext = "", host = TRUE, pid = TRUE)
+
+ gVariable(init, shared = FALSE)
+}
+\arguments{
+ \item{mutex}{a mutex or a mutex descriptor. If missing, a
+ new mutex is created via the function
+ \code{\link[synchronicity]{boost.mutex}}.}
+
+ \item{verbose}{a logical that indicates if messages
+ should be printed when locking and unlocking the mutex.}
+
+ \item{...}{extra arguments passed to
+ \code{\link[base]{tempfile}}.}
+
+ \item{host}{logical that indicates if the host machine
+ name should be appear in the filename.}
+
+ \item{pid}{logical that indicates if the current process
+ id be appear in the filename.}
+
+ \item{init}{initial value}
+
+ \item{shared}{a logical that indicates if the variable
+ should be stored in shared memory or in a local
+ environment.}
+
+ \item{pattern}{a non-empty character vector giving the
+ initial part of the name.}
+
+ \item{tmpdir}{a non-empty character vector giving the
+ directory name}
+
+ \item{fileext}{a non-empty character vector giving the
+ file extension}
+}
+\description{
+ Utilities for Parallel Computations
+
+ \code{ts_eval} generates a thread safe version of
+ \code{\link{eval}}. It uses boost mutexes provided by the
+ \code{\link[synchronicity]{synchronicity}} package. The
+ generated function has arguments \code{expr} and
+ \code{envir}, which are passed to \code{\link{eval}}.
+
+ \code{ts_tempfile} generates a \emph{unique} temporary
+ filename that includes the name of the host machine
+ and/or the caller's process id, so that it is thread
+ safe.
+
+ \code{hostfile} generates a temporary filename composed
+ with the name of the host machine and/or the current
+ process id.
+
+ \code{gVariable} generates a function that access a
+ global static variable, possibly in shared memory (only
+ for numeric matrix-coercible data in this case). It is
+ used primarily in parallel computations, to preserve data
+ accross computations that are performed by the same
+ process.
+}
+
diff --git a/man/parse_formula.Rd b/man/parse_formula.Rd
new file mode 100644
index 0000000..0c22f42
--- /dev/null
+++ b/man/parse_formula.Rd
@@ -0,0 +1,21 @@
+\name{parse_formula}
+\alias{parse_formula}
+\title{Simple Parsing of Formula}
+\usage{
+ parse_formula(x)
+}
+\arguments{
+ \item{x}{formula to parse}
+}
+\value{
+ a list with the following elements: \item{response}{
+ logical that indicates if the formula has a response
+ term.} \item{y}{ name of the response variable.}
+ \item{x}{ list of regressor variable names.} \item{n}{
+ number of regressor variables.}
+}
+\description{
+ Formula parser for formula-based NMF models.
+}
+\keyword{internal}
+
diff --git a/man/plot-commaNMFfit-commamissing-method.Rd b/man/plot-commaNMFfit-commamissing-method.Rd
new file mode 100644
index 0000000..ed5cfc1
--- /dev/null
+++ b/man/plot-commaNMFfit-commamissing-method.Rd
@@ -0,0 +1,55 @@
+\docType{methods}
+\name{plot,NMFfit,missing-method}
+\alias{plot,NMFfit,missing-method}
+\title{Plots the residual track computed at regular interval during the fit of
+the NMF model \code{x}.}
+\usage{
+ \S4method{plot}{NMFfit,missing}(x, y, skip = -1, ...)
+}
+\arguments{
+ \item{skip}{an integer that indicates the number of
+ points to skip/remove from the beginning of the curve. If
+ \code{skip=1L} (default) only the initial residual --
+ that is computed before any iteration, is skipped, if
+ present in the track (it associated with iteration 0).}
+
+ \item{x}{the coordinates of points in the plot.
+ Alternatively, a single plotting structure, function or
+ \emph{any \R object with a \code{plot} method} can be
+ provided.}
+
+ \item{y}{the y coordinates of points in the plot,
+ \emph{optional} if \code{x} is an appropriate structure.}
+
+ \item{...}{Arguments to be passed to methods, such as
+ \link{graphical parameters} (see \code{\link{par}}).
+ Many methods will accept the following arguments:
+ \describe{ \item{\code{type}}{what type of plot should be
+ drawn. Possible types are \itemize{ \item \code{"p"} for
+ \bold{p}oints, \item \code{"l"} for \bold{l}ines, \item
+ \code{"b"} for \bold{b}oth, \item \code{"c"} for the
+ lines part alone of \code{"b"}, \item \code{"o"} for both
+ \sQuote{\bold{o}verplotted}, \item \code{"h"} for
+ \sQuote{\bold{h}istogram} like (or \sQuote{high-density})
+ vertical lines, \item \code{"s"} for stair \bold{s}teps,
+ \item \code{"S"} for other \bold{s}teps, see
+ \sQuote{Details} below, \item \code{"n"} for no plotting.
+ } All other \code{type}s give a warning or an error;
+ using, e.g., \code{type = "punkte"} being equivalent to
+ \code{type = "p"} for S compatibility. Note that some
+ methods, e.g. \code{\link{plot.factor}}, do not accept
+ this. } \item{\code{main}}{an overall title for the
+ plot: see \code{\link{title}}.} \item{\code{sub}}{a sub
+ title for the plot: see \code{\link{title}}.}
+ \item{\code{xlab}}{a title for the x axis: see
+ \code{\link{title}}.} \item{\code{ylab}}{a title for the
+ y axis: see \code{\link{title}}.} \item{\code{asp}}{the
+ \eqn{y/x} aspect ratio, see \code{\link{plot.window}}.} }
+ }
+}
+\description{
+ Plots the residual track computed at regular interval
+ during the fit of the NMF model \code{x}.
+}
+\keyword{methods}
+
diff --git a/man/predict.Rd b/man/predict.Rd
new file mode 100644
index 0000000..95b79ac
--- /dev/null
+++ b/man/predict.Rd
@@ -0,0 +1,149 @@
+\docType{methods}
+\name{predict}
+\alias{predict}
+\alias{predict-methods}
+\alias{predict,NMFfitX-method}
+\alias{predict,NMF-method}
+\title{Clustering and Prediction}
+\usage{
+ predict(object, ...)
+
+ \S4method{predict}{NMF}(object,
+ what = c("columns", "rows", "samples", "features"),
+ prob = FALSE, dmatrix = FALSE)
+
+ \S4method{predict}{NMFfitX}(object,
+ what = c("columns", "rows", "samples", "features", "consensus", "chc"),
+ dmatrix = FALSE, ...)
+}
+\arguments{
+ \item{object}{an NMF model}
+
+ \item{what}{a character string that indicates the type of
+ cluster membership should be returned: \sQuote{columns}
+ or \sQuote{rows} for clustering the colmuns or the rows
+ of the target matrix respectively. The values
+ \sQuote{samples} and \sQuote{features} are aliases for
+ \sQuote{colmuns} and \sQuote{rows} respectively.}
+
+ \item{prob}{logical that indicates if the relative
+ contributions of/to the dominant basis component should
+ be computed and returned. See \emph{Details}.}
+
+ \item{dmatrix}{logical that indicates if a dissimiliarity
+ matrix should be attached to the result. This is notably
+ used internally when computing NMF clustering
+ silhouettes.}
+
+ \item{...}{additional arguments affecting the predictions
+ produced.}
+}
+\description{
+ The methods \code{predict} for NMF models return the
+ cluster membership of each sample or each feature.
+ Currently the classification/prediction of new data is
+ not implemented.
+}
+\details{
+ The cluster membership is computed as the index of the
+ dominant basis component for each sample
+ (\code{what='samples' or 'columns'}) or each feature
+ (\code{what='features' or 'rows'}), based on their
+ corresponding entries in the coefficient matrix or basis
+ matrix respectively.
+
+ For example, if \code{what='samples'}, then the dominant
+ basis component is computed for each column of the
+ coefficient matrix as the row index of the maximum within
+ the column.
+
+ If argument \code{prob=FALSE} (default), the result is a
+ \code{factor}. Otherwise a list with two elements is
+ returned: element \code{predict} contains the cluster
+ membership index (as a \code{factor}) and element
+ \code{prob} contains the relative contribution of the
+ dominant component to each sample (resp. the relative
+ contribution of each feature to the dominant basis
+ component):
+
+ \itemize{ \item Samples: \deqn{p_j = x_{k_0} / \sum_k
+ x_k}{p(j) = x(k0) / sum_k x(k)}, for each sample
+ \eqn{1\leq j \leq p}, where \eqn{x_k}{x(k)} is the
+ contribution of the \eqn{k}-th basis component to
+ \eqn{j}-th sample (i.e. \code{H[k ,j]}), and
+ \eqn{x_{k_0}}{x(k0)} is the maximum of these
+ contributions.
+
+ \item Features: \deqn{p_i = y_{k_0} / \sum_k y_k}{p(i) =
+ y(k0) / sum_k y(k)}, for each feature \eqn{1\leq i \leq
+ p}, where \eqn{y_k}{y(k)} is the contribution of the
+ \eqn{k}-th basis component to \eqn{i}-th feature (i.e.
+ \code{W[i, k]}), and \eqn{y_{k_0}}{y(k0)} is the maximum
+ of these contributions.
+
+ }
+}
+\section{Methods}{
+ \describe{
+
+ \item{predict}{\code{signature(object = "NMF")}: Default
+ method for NMF models }
+
+ \item{predict}{\code{signature(object = "NMFfitX")}:
+ Returns the cluster membership index from an NMF model
+ fitted with multiple runs.
+
+ Besides the type of clustering available for any NMF
+ models (\code{'columns', 'rows', 'samples', 'features'}),
+ this method can return the cluster membership index based
+ on the consensus matrix, computed from the multiple NMF
+ runs.
+
+ Argument \code{what} accepts the following extra types:
+ \describe{ \item{\code{'chc'}}{ returns the cluster
+ membership based on the hierarchical clustering of the
+ consensus matrix, as performed by
+ \code{\link{consensushc}}.} \item{\code{'consensus'}}{
+ same as \code{'chc'} but the levels of the membership
+ index are re-labeled to match the order of the clusters
+ as they would be displayed on the associated dendrogram,
+ as re-ordered on the default annotation track in
+ consensus heatmap produced by
+ \code{\link{consensusmap}}.} } }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# random target matrix
+v <- rmatrix(20, 10)
+# fit an NMF model
+x <- nmf(v, 5)
+
+# predicted column and row clusters
+predict(x)
+predict(x, 'rows')
+
+# with relative contributions of each basis component
+predict(x, prob=TRUE)
+predict(x, 'rows', prob=TRUE)
+}
+\references{
+ Brunet J, Tamayo P, Golub TR and Mesirov JP (2004).
+ "Metagenes and molecular pattern discovery using matrix
+ factorization." _Proceedings of the National Academy of
+ Sciences of the United States of America_, *101*(12), pp.
+ 4164-9. ISSN 0027-8424, <URL:
+ http://dx.doi.org/10.1073/pnas.0308531101>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/15016911>.
+
+ Pascual-Montano A, Carazo JM, Kochi K, Lehmann D and
+ Pascual-marqui RD (2006). "Nonsmooth nonnegative matrix
+ factorization (nsNMF)." _IEEE Trans. Pattern Anal. Mach.
+ Intell_, *28*, pp. 403-415.
+}
+\keyword{methods}
+
diff --git a/man/profplot.Rd b/man/profplot.Rd
new file mode 100644
index 0000000..3d6a863
--- /dev/null
+++ b/man/profplot.Rd
@@ -0,0 +1,124 @@
+\name{profplot}
+\alias{profplot}
+\alias{profplot.default}
+\title{Plotting Expression Profiles}
+\usage{
+ profplot(x, ...)
+
+ \method{profplot}{default} (x, y,
+ scale = c("none", "max", "c1"), match.names = TRUE,
+ legend = TRUE, confint = TRUE, Colv, labels,
+ annotation, ..., add = FALSE)
+}
+\arguments{
+ \item{x}{a matrix or an NMF object from which is
+ extracted the mixture coefficient matrix. It is extracted
+ from the best fit if \code{x} is the results from
+ multiple NMF runs.}
+
+ \item{y}{a matrix or an NMF object from which is
+ extracted the mixture coefficient matrix. It is extracted
+ from the best fit if \code{y} is the results from
+ multiple NMF runs.}
+
+ \item{scale}{specifies how the data should be scaled
+ before plotting. If \code{'none'} or \code{NA}, then no
+ scaling is applied and the "raw" data is plotted. If
+ \code{TRUE} or \code{'max'} then each row of both
+ matrices are normalised with their respective maximum
+ values. If \code{'c1'}, then each column of both matrix
+ is scaled into proportions (i.e. to sum up to one).
+ Default is \code{'none'}.}
+
+ \item{match.names}{a logical that indicates if the
+ profiles in \code{y} should be subset and/or re-ordered
+ to match the profile names in \code{x} (i.e. the
+ rownames). This is attempted only when both \code{x} and
+ \code{y} have names.}
+
+ \item{legend}{a logical that specifies whether drawing
+ the legend or not, or coordinates specifications passed
+ to argument \code{x} of \code{\link{legend}}, that
+ specifies the position of the legend.}
+
+ \item{confint}{logical that indicates if confidence
+ intervals for the R-squared should be shown in legend.}
+
+ \item{Colv}{specifies the way the columns of \code{x} are
+ ordered before plotting. It is used only when \code{y} is
+ missing. It can be: \itemize{ \item a single numeric
+ value, specifying the index of a row of \code{x}, that is
+ used to order the columns by \code{x[,
+ order(x[abs(Colv),])]}. Decreasing order is specified
+ with a negative index. \item an integer vector directly
+ specifying the order itself, in which case the columns
+ are ordered by \code{x[, Colv]} \item a factor used to
+ order the columns by \code{x[, order(Colv)]} and as
+ argument \code{annotation} if this latter is missing or
+ not \code{NA}. \item any other object with a suitable
+ \code{order} method. The columns are by \code{x[,
+ order(Colv)]} }}
+
+ \item{labels}{a character vector containing labels for
+ each sample (i.e. each column of \code{x}). These are
+ used for labelling the x-axis.}
+
+ \item{annotation}{a factor annotating each sample (i.e.
+ each column of \code{x}). If not missing, a coloured raw
+ is plotted under the x-axis and annotates each sample
+ accordingly. If argument \code{Colv} is a factor, then it
+ is used to annotate the plot, unless
+ \code{annotation=NA}.}
+
+ \item{...}{graphical parameters passed to
+ \code{\link{matplot}} or \code{\link{matpoints}}.}
+
+ \item{add}{logical that indicates if the plot should be
+ added as points to a previous plot}
+}
+\description{
+ Plotting Expression Profiles
+
+ When using NMF for clustering in particular, one looks
+ for strong associations between the basis and a priori
+ known groups of samples. Plotting the profiles may
+ highlight such patterns.
+}
+\details{
+ The function can also be used to compare the profiles
+ from two NMF models or mixture coefficient matrices. In
+ this case, it draws a scatter plot of the paired
+ profiles.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# create a random target matrix
+v <- rmatrix(50, 10)
+
+# fit a single NMF model
+res <- nmf(v, 3)
+profplot(res)
+
+# ordering according to first profile
+profplot(res, Colv=1) # increasing
+profplot(res, Colv=-1) # decreasing
+
+# fit a multi-run NMF model
+res2 <- nmf(v, 3, nrun=3)
+profplot(res2)
+
+# draw a profile correlation plot: this show how the basis components are
+# returned in an unpredictable order
+profplot(res, res2)
+
+# looking at all the correlations allow to order the components in a "common" order
+profcor(res, res2)
+}
+\seealso{
+ \code{\link{profcor}}
+}
+\keyword{aplot}
+
diff --git a/man/purity.Rd b/man/purity.Rd
new file mode 100644
index 0000000..3b4892a
--- /dev/null
+++ b/man/purity.Rd
@@ -0,0 +1,173 @@
+\docType{methods}
+\name{purity}
+\alias{entropy}
+\alias{entropy,ANY,ANY-method}
+\alias{entropy,factor,ANY-method}
+\alias{entropy-methods}
+\alias{entropy,NMFfitXn,ANY-method}
+\alias{entropy,table,missing-method}
+\alias{purity}
+\alias{purity,ANY,ANY-method}
+\alias{purity,factor,ANY-method}
+\alias{purity-methods}
+\alias{purity,NMFfitXn,ANY-method}
+\alias{purity,table,missing-method}
+\title{Purity and Entropy of a Clustering}
+\usage{
+ purity(x, y, ...)
+
+ entropy(x, y, ...)
+
+ \S4method{purity}{NMFfitXn,ANY}(x, y, method = "best",
+ ...)
+
+ \S4method{entropy}{NMFfitXn,ANY}(x, y, method = "best",
+ ...)
+}
+\arguments{
+ \item{x}{an object that can be interpreted as a factor or
+ can generate such an object, e.g. via a suitable method
+ \code{\link{predict}}, which gives the cluster membership
+ for each sample.}
+
+ \item{y}{a factor or an object coerced into a factor that
+ gives the true class labels for each sample. It may be
+ missing if \code{x} is a contingency table.}
+
+ \item{...}{extra arguments to allow extension, and
+ usually passed to the next method.}
+
+ \item{method}{a character string that specifies how the
+ value is computed. It may be either \code{'best'} or
+ \code{'mean'} to compute the best or mean purity
+ respectively.}
+}
+\value{
+ a single numeric value
+
+ the entropy (i.e. a single numeric value)
+}
+\description{
+ The functions \code{purity} and \code{entropy}
+ respectively compute the purity and the entropy of a
+ clustering given \emph{a priori} known classes.
+
+ The purity and entropy measure the ability of a
+ clustering method, to recover known classes (e.g. one
+ knows the true class labels of each sample), that are
+ applicable even when the number of cluster is different
+ from the number of known classes. \cite{Kim et al.
+ (2007)} used these measures to evaluate the performance
+ of their alternate least-squares NMF algorithm.
+}
+\details{
+ Suppose we are given \eqn{l} categories, while the
+ clustering method generates \eqn{k} clusters.
+
+ The purity of the clustering with respect to the known
+ categories is given by: \deqn{Purity = \frac{1}{n}
+ \sum_{q=1}^k \max_{1 \leq j \leq l} n_q^j} ,
+
+ where: \itemize{ \item \eqn{n} is the total number of
+ samples; \item \eqn{n_q^j} is the number of samples in
+ cluster \eqn{q} that belongs to original class \eqn{j}
+ (\eqn{1 \leq j \leq l}). }
+
+ The purity is therefore a real number in \eqn{[0,1]}. The
+ larger the purity, the better the clustering performance.
+
+ The entropy of the clustering with respect to the known
+ categories is given by: \deqn{Entropy = - \frac{1}{n
+ \log_2 l} \sum_{q=1}^k \sum_{j=1}^l n_q^j \log_2
+ \frac{n_q^j}{n_q}}{ - 1/(n log2(l) ) sum_q sum_j n(q,j)
+ log2( n(q,j) / n_q )},
+
+ where: \itemize{ \item \eqn{n} is the total number of
+ samples; \item \eqn{n}{n_q} is the total number of
+ samples in cluster \eqn{q} (\eqn{1 \leq q \leq k}); \item
+ \eqn{n_q^j}{n(q,j)} is the number of samples in cluster
+ \eqn{q} that belongs to original class \eqn{j} (\eqn{1
+ \leq j \leq l}). }
+
+ The smaller the entropy, the better the clustering
+ performance.
+}
+\section{Methods}{
+ \describe{
+
+ \item{entropy}{\code{signature(x = "table", y =
+ "missing")}: Computes the purity directly from the
+ contingency table \code{x}.
+
+ This is the workhorse method that is eventually called by
+ all other methods. }
+
+ \item{entropy}{\code{signature(x = "factor", y = "ANY")}:
+ Computes the purity on the contingency table of \code{x}
+ and \code{y}, that is coerced into a factor if necessary.
+ }
+
+ \item{entropy}{\code{signature(x = "ANY", y = "ANY")}:
+ Default method that should work for results of clustering
+ algorithms, that have a suitable \code{predict} method
+ that returns the cluster membership vector: the purity is
+ computed between \code{x} and \code{predict{y}} }
+
+ \item{entropy}{\code{signature(x = "NMFfitXn", y =
+ "ANY")}: Computes the best or mean entropy across all NMF
+ fits stored in \code{x}. }
+
+ \item{purity}{\code{signature(x = "table", y =
+ "missing")}: Computes the purity directly from the
+ contingency table \code{x} }
+
+ \item{purity}{\code{signature(x = "factor", y = "ANY")}:
+ Computes the purity on the contingency table of \code{x}
+ and \code{y}, that is coerced into a factor if necessary.
+ }
+
+ \item{purity}{\code{signature(x = "ANY", y = "ANY")}:
+ Default method that should work for results of clustering
+ algorithms, that have a suitable \code{predict} method
+ that returns the cluster membership vector: the purity is
+ computed between \code{x} and \code{predict{y}} }
+
+ \item{purity}{\code{signature(x = "NMFfitXn", y =
+ "ANY")}: Computes the best or mean purity across all NMF
+ fits stored in \code{x}. }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# generate a synthetic dataset with known classes: 50 features, 18 samples (5+5+8)
+n <- 50; counts <- c(5, 5, 8);
+V <- syntheticNMF(n, counts)
+cl <- unlist(mapply(rep, 1:3, counts))
+
+# perform default NMF with rank=2
+x2 <- nmf(V, 2)
+purity(x2, cl)
+entropy(x2, cl)
+# perform default NMF with rank=2
+x3 <- nmf(V, 3)
+purity(x3, cl)
+entropy(x3, cl)
+}
+\references{
+ Kim H and Park H (2007). "Sparse non-negative matrix
+ factorizations via alternating non-negativity-constrained
+ least squares for microarray data analysis."
+ _Bioinformatics (Oxford, England)_, *23*(12), pp.
+ 1495-502. ISSN 1460-2059, <URL:
+ http://dx.doi.org/10.1093/bioinformatics/btm134>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/17483501>.
+}
+\seealso{
+ Other assess: \code{\link{sparseness}}
+}
+\keyword{methods}
+
diff --git a/man/randomize.Rd b/man/randomize.Rd
new file mode 100644
index 0000000..c5fda41
--- /dev/null
+++ b/man/randomize.Rd
@@ -0,0 +1,39 @@
+\name{randomize}
+\alias{randomize}
+\title{Randomizing Data}
+\usage{
+ randomize(x, ...)
+}
+\arguments{
+ \item{x}{data to be permutated. It must be an object
+ suitable to be passed to the function
+ \code{\link{apply}}.}
+
+ \item{...}{extra arguments passed to the function
+ \code{\link{sample}}.}
+}
+\value{
+ a matrix
+}
+\description{
+ \code{randomize} permutates independently the entries in
+ each column of a matrix-like object, to produce random
+ data that can be used in permutation tests or bootstrap
+ analysis.
+}
+\details{
+ In the context of NMF, it may be used to generate random
+ data, whose factorization serves as a reference for
+ selecting a factorization rank, that does not overfit the
+ data.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+x <- matrix(1:32, 4, 8)
+randomize(x)
+randomize(x)
+}
+
diff --git a/man/registry-algorithm.Rd b/man/registry-algorithm.Rd
new file mode 100644
index 0000000..d9cbf11
--- /dev/null
+++ b/man/registry-algorithm.Rd
@@ -0,0 +1,64 @@
+\name{methods-NMF}
+\alias{existsNMFMethod}
+\alias{getNMFMethod}
+\alias{methods-NMF}
+\alias{removeNMFMethod}
+\alias{selectNMFMethod}
+\title{Registry for NMF Algorithms}
+\usage{
+ selectNMFMethod(name, model, load = FALSE, exact = FALSE,
+ all = FALSE, quiet = FALSE)
+
+ getNMFMethod(...)
+
+ existsNMFMethod(name, exact = TRUE)
+
+ removeNMFMethod(name, ...)
+}
+\arguments{
+ \item{name}{name of a registered NMF algorithm}
+
+ \item{model}{class name of an NMF model, i.e. a class
+ that inherits from class \code{\linkS4class{NMF}}.}
+
+ \item{load}{a logical that indicates if the selected
+ algorithms should be loaded into \code{NMFStrategy}
+ objects}
+
+ \item{all}{a logical that indicates if all algorithms
+ that can fit \code{model} should be returned or only the
+ default or first found.}
+
+ \item{quiet}{a logical that indicates if the operation
+ should be performed quietly, without throwing errors or
+ warnings.}
+
+ \item{...}{extra arguments passed to
+ \code{\link[pkgmaker]{pkgreg_fetch}} or
+ \code{\link[pkgmaker]{pkgreg_remove}}.}
+
+ \item{exact}{a logical that indicates if the access key
+ should be matched exactly (\code{TRUE}) or partially
+ (\code{FALSE}).}
+}
+\value{
+ \code{selectNMFMethod} returns a character vector or
+ \code{NMFStrategy} objects, or NULL if no suitable
+ algorithm was found.
+}
+\description{
+ Registry for NMF Algorithms
+
+ \code{selectNMFMethod} tries to select an appropriate NMF
+ algorithm that is able to fit a given the NMF model.
+
+ \code{getNMFMethod} retrieves NMF algorithm objects from
+ the registry.
+
+ \code{existsNMFMethod} tells if an NMF algorithm is
+ registered under the
+
+ \code{removeNMFMethod} removes an NMF algorithm from the
+ registry.
+}
+
diff --git a/man/residuals.Rd b/man/residuals.Rd
new file mode 100644
index 0000000..9bd29d2
--- /dev/null
+++ b/man/residuals.Rd
@@ -0,0 +1,110 @@
+\docType{methods}
+\name{residuals}
+\alias{hasTrack}
+\alias{residuals}
+\alias{residuals<-}
+\alias{residuals<--methods}
+\alias{residuals-methods}
+\alias{residuals<-,NMFfit-method}
+\alias{residuals,NMFfit-method}
+\alias{residuals,NMFfitX-method}
+\alias{trackError}
+\title{Residuals in NMF Models}
+\usage{
+ residuals(object, ...)
+
+ \S4method{residuals}{NMFfit}(object, track = FALSE,
+ niter = NULL, ...)
+
+ residuals(object, ...)<-value
+
+ \S4method{residuals}{NMFfit}(object, ..., niter = NULL,
+ track = FALSE)<-value
+
+ hasTrack(object, niter = NULL)
+
+ trackError(object, value, niter, force = FALSE)
+}
+\arguments{
+ \item{object}{an \code{NMFfit} object as fitted by
+ function \code{\link{nmf}}, in single run mode.}
+
+ \item{...}{extra parameters (not used)}
+
+ \item{track}{a logical that indicates if the complete
+ track of residuals should be returned (if it has been
+ computed during the fit), or only the last value.}
+
+ \item{niter}{specifies the iteration number for which one
+ wants to get/set/test a residual value. This argument is
+ used only if not \code{NULL}}
+
+ \item{value}{residual value}
+
+ \item{force}{logical that indicates if the value should
+ be added to the track even if there already is a value
+ for this iteration number or if the iteration does not
+ conform to the tracking interval
+ \code{nmf.getOption('track.interval')}.}
+}
+\value{
+ \code{residuals} returns a single numeric value if
+ \code{track=FALSE} or a numeric vector containing the
+ residual values at some iterations. The names correspond
+ to the iterations at which the residuals were computed.
+}
+\description{
+ The package NMF defines methods for the function
+ \code{\link[stats]{residuals}} that returns the final
+ residuals of an NMF fit or the track of the residuals
+ along the fit process, computed according to the
+ objective function associated with the algorithm that
+ fitted the model.
+
+ \code{residuals<-} sets the value of the last residuals,
+ or, optionally, of the complete residual track.
+
+ Tells if an \code{NMFfit} object contains a recorded
+ residual track.
+
+ \code{trackError} adds a residual value to the track of
+ residuals.
+}
+\details{
+ When called with \code{track=TRUE}, the whole residuals
+ track is returned, if available. Note that method
+ \code{\link{nmf}} does not compute the residuals track,
+ unless explicitly required.
+
+ It is a S4 methods defined for the associated generic
+ functions from package \code{stats} (See
+ \link[stats]{residuals}).
+}
+\note{
+ Stricly speaking, the method \code{residuals,NMFfit} does
+ not fulfill its contract as defined by the package
+ \code{stats}, but rather acts as function
+ \code{deviance}. The might be changed in a later release
+ to make it behave as it should.
+}
+\section{Methods}{
+ \describe{
+
+ \item{residuals}{\code{signature(object = "NMFfit")}:
+ Returns the residuals -- track -- between the target
+ matrix and the NMF fit \code{object}. }
+
+ \item{residuals}{\code{signature(object = "NMFfitX")}:
+ Returns the residuals achieved by the best fit object,
+ i.e. the lowest residual approximation error achieved
+ across all NMF runs. }
+
+ }
+}
+\seealso{
+ Other stats: \code{\link{deviance}},
+ \code{\link{deviance,NMF-method}},
+ \code{\link{nmfDistance}}
+}
+\keyword{methods}
+
diff --git a/man/revPalette.Rd b/man/revPalette.Rd
new file mode 100644
index 0000000..313c582
--- /dev/null
+++ b/man/revPalette.Rd
@@ -0,0 +1,11 @@
+\name{revPalette}
+\alias{revPalette}
+\title{Flags a Color Palette Specification for Reversion}
+\usage{
+ revPalette(x)
+}
+\description{
+ Flags a Color Palette Specification for Reversion
+}
+\keyword{internal}
+
diff --git a/man/rmatrix.Rd b/man/rmatrix.Rd
new file mode 100644
index 0000000..de2c347
--- /dev/null
+++ b/man/rmatrix.Rd
@@ -0,0 +1,153 @@
+\docType{methods}
+\name{rmatrix}
+\alias{rmatrix}
+\alias{rmatrix,ANY-method}
+\alias{rmatrix-methods}
+\alias{rmatrix,NMF-method}
+\alias{rmatrix,numeric-method}
+\title{Generating Random Matrices}
+\usage{
+ rmatrix(x, ...)
+
+ \S4method{rmatrix}{numeric}(x, y = NULL, dist = runif,
+ byrow = FALSE, dimnames = NULL, ...)
+}
+\arguments{
+ \item{x}{object from which to generate a random matrix}
+
+ \item{y}{optional specification of number of columns}
+
+ \item{dist}{a random distribution function or a numeric
+ seed (see details of method \code{rmatrix,numeric})}
+
+ \item{byrow}{a logical passed in the internal call to the
+ function \code{\link{matrix}}}
+
+ \item{dimnames}{\code{NULL} or a \code{list} passed in
+ the internal call to the function \code{\link{matrix}}}
+
+ \item{...}{extra arguments passed to the distribution
+ function \code{dist}.}
+}
+\description{
+ The S4 generic \code{rmatrix} generates a random matrix
+ from a given object. Methods are provided to generate
+ matrices with entries drawn from any given random
+ distribution function, e.g. \code{\link{runif}} or
+ \code{\link{rnorm}}.
+}
+\section{Methods}{
+ \describe{
+
+ \item{rmatrix}{\code{signature(x = "numeric")}: Generates
+ a random matrix of given dimensions, whose entries are
+ drawn using the distribution function \code{dist}.
+
+ This is the workhorse method that is eventually called by
+ all other methods. It returns a matrix with: \itemize{
+ \item \code{x} rows and \code{y} columns if \code{y} is
+ not missing and not \code{NULL}; \item dimension
+ \code{x[1]} x \code{x[2]} if \code{x} has at least two
+ elements; \item dimension \code{x} (i.e. a square matrix)
+ otherwise. }
+
+ The default is to draw its entries from the standard
+ uniform distribution using the base function
+ \code{\link{runif}}, but any other function that
+ generates random numeric vectors of a given length may be
+ specified in argument \code{dist}. All arguments in
+ \code{...} are passed to the function specified in
+ \code{dist}.
+
+ The only requirement is that the function in \code{dist}
+ is of the following form:
+
+ \samp{ function(n, ...){ # return vector of length n ...
+ }}
+
+ This is the case of all base random draw function such as
+ \code{\link{rnorm}}, \code{\link{rgamma}}, etc\ldots }
+
+ \item{rmatrix}{\code{signature(x = "ANY")}: Default
+ method which calls \code{rmatrix,vector} on the
+ dimensions of \code{x} that is assumed to be returned by
+ a suitable \code{dim} method: it is equivalent to
+ \code{rmatrix(dim(x), y=NULL, ...)}. }
+
+ \item{rmatrix}{\code{signature(x = "NMF")}: Returns the
+ target matrix estimate of the NMF model \code{x},
+ perturbated by adding a random matrix generated using the
+ default method of \code{rmatrix}: it is a equivalent to
+ \code{fitted(x) + rmatrix(fitted(x), ...)}.
+
+ This method can be used to generate random target
+ matrices that depart from a known NMF model to a
+ controlled extend. This is useful to test the robustness
+ of NMF algorithms to the presence of certain types of
+ noise in the data. }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+#----------
+# rmatrix,numeric-method
+#----------
+## Generate a random matrix of a given size
+rmatrix(5, 3)
+\dontshow{ stopifnot( identical(dim(rmatrix(5, 3)), c(5L,3L)) ) }
+
+## Generate a random matrix of the same dimension of a template matrix
+a <- matrix(1, 3, 4)
+rmatrix(a)
+\dontshow{ stopifnot( identical(dim(rmatrix(a)), c(3L,4L)) ) }
+
+## Specificy the distribution to use
+
+# the default is uniform
+a <- rmatrix(1000, 50)
+\dontrun{ hist(a) }
+
+# use normal ditribution
+a <- rmatrix(1000, 50, rnorm)
+\dontrun{ hist(a) }
+
+# extra arguments can be passed to the random variate generation function
+a <- rmatrix(1000, 50, rnorm, mean=2, sd=0.5)
+\dontrun{ hist(a) }
+
+#----------
+# rmatrix,ANY-method
+#----------
+# random matrix of the same dimension as another matrix
+x <- matrix(3,4)
+dim(rmatrix(x))
+
+#----------
+# rmatrix,NMF-method
+#----------
+# generate noisy fitted target from an NMF model (the true model)
+gr <- as.numeric(mapply(rep, 1:3, 3))
+h <- outer(1:3, gr, '==') + 0
+x <- rnmf(10, H=h)
+y <- rmatrix(x)
+\dontrun{
+# show heatmap of the noisy target matrix: block patterns should be clear
+aheatmap(y)
+}
+\dontshow{ stopifnot( identical(dim(y), dim(x)[1:2]) ) }
+
+# test NMF algorithm on noisy data
+# add some noise to the true model (drawn from uniform [0,1])
+res <- nmf(rmatrix(x), 3)
+summary(res)
+
+# add more noise to the true model (drawn from uniform [0,10])
+res <- nmf(rmatrix(x, max=10), 3)
+summary(res)
+}
+\keyword{methods}
+
diff --git a/man/rnmf.Rd b/man/rnmf.Rd
new file mode 100644
index 0000000..2327395
--- /dev/null
+++ b/man/rnmf.Rd
@@ -0,0 +1,395 @@
+\docType{methods}
+\name{rnmf}
+\alias{rnmf}
+\alias{rnmf,ANY,data.frame-method}
+\alias{rnmf,ANY,matrix-method}
+\alias{rnmf,formula,ANY-method}
+\alias{rnmf-methods}
+\alias{rnmf,missing,missing-method}
+\alias{rnmf,NMF,missing-method}
+\alias{rnmf,NMF,numeric-method}
+\alias{rnmf,NMFOffset,numeric-method}
+\alias{rnmf,numeric,missing-method}
+\alias{rnmf,numeric,numeric-method}
+\title{Generating Random NMF Models}
+\usage{
+ rnmf(x, target, ...)
+
+ \S4method{rnmf}{NMF,numeric}(x, target, ncol = NULL,
+ keep.names = TRUE, dist = runif)
+
+ \S4method{rnmf}{ANY,matrix}(x, target, ...,
+ dist = list(max = max(max(target, na.rm = TRUE), 1)),
+ use.dimnames = TRUE)
+
+ \S4method{rnmf}{numeric,missing}(x, target, ..., W, H,
+ dist = runif)
+
+ \S4method{rnmf}{missing,missing}(x, target, ..., W, H)
+
+ \S4method{rnmf}{numeric,numeric}(x, target, ncol = NULL,
+ ..., dist = runif)
+
+ \S4method{rnmf}{formula,ANY}(x, target, ...,
+ dist = runif)
+}
+\arguments{
+ \item{x}{an object that determines the rank, dimension
+ and/or class of the generated NMF model, e.g. a numeric
+ value or an object that inherits from class
+ \code{\linkS4class{NMF}}. See the description of the
+ specific methods for more details on the supported
+ types.}
+
+ \item{target}{optional specification of target
+ dimensions. See section \emph{Methods} for how this
+ parameter is used by the different methods.}
+
+ \item{...}{extra arguments to allow extensions and passed
+ to the next method eventually down to
+ \code{\link{nmfModel}}, where they are used to initialise
+ slots that are specific to the instantiating NMF model.}
+
+ \item{ncol}{single numeric value that specifies the
+ number of columns of the coefficient matrix. Only used
+ when \code{target} is a single numeric value.}
+
+ \item{keep.names}{a logical that indicates if the
+ dimension names of the original NMF object \code{x}
+ should be conserved (\code{TRUE}) or discarded
+ (\code{FALSE}).}
+
+ \item{dist}{specification of the random distribution to
+ use to draw the entries of the basis and coefficient
+ matrices. It may be specified as: \itemize{
+
+ \item a \code{function} which must be a distribution
+ function such as e.g. \code{\link{runif}} that is used to
+ draw the entries of both the basis and coefficient
+ matrices. It is passed in the \code{dist} argument of
+ \code{\link{rmatrix}}.
+
+ \item a \code{list} of arguments that are passed
+ internally to \code{\link{rmatrix}}, via
+ \code{do.call('rmatrix', dist)}.
+
+ \item a \code{character} string that is partially matched
+ to \sQuote{basis} or \sQuote{coef}, that specifies which
+ matrix in should be drawn randomly, the other remaining
+ as in \code{x} -- unchanged.
+
+ \item a \code{list} with elements \sQuote{basis} and/or
+ \sQuote{coef}, which specify the \code{dist} argument
+ separately for the basis and coefficient matrix
+ respectively.
+
+ These elements may be either a distribution function, or
+ a list of arguments that are passed internally to
+ \code{\link{rmatrix}}, via \code{do.call('rmatrix',
+ dist$basis)} or \code{do.call('rmatrix', dist$coef)}. }}
+
+ \item{use.dimnames}{a logical that indicates whether the
+ dimnames of the target matrix should be set on the
+ returned NMF model.}
+
+ \item{W}{value for the basis matrix. \code{data.frame}
+ objects are converted into matrices with
+ \code{\link{as.matrix}}.}
+
+ \item{H}{value for the mixture coefficient matrix
+ \code{data.frame} objects are converted into matrices
+ with \code{\link{as.matrix}}.}
+}
+\value{
+ An NMF model, i.e. an object that inherits from class
+ \code{\linkS4class{NMF}}.
+}
+\description{
+ Generates NMF models with random values drawn from a
+ uniform distribution. It returns an NMF model with basis
+ and mixture coefficient matrices filled with random
+ values. The main purpose of the function \code{rnmf} is
+ to provide a common interface to generate random seeds
+ used by the \code{\link{nmf}} function.
+}
+\details{
+ If necessary, extensions of the standard NMF model or
+ custom models must define a method
+ "rnmf,<NMF.MODEL.CLASS>,numeric" for initialising their
+ specific slots other than the basis and mixture
+ coefficient matrices. In order to benefit from the
+ complete built-in interface, the overloading methods
+ should call the generic version using function
+ \code{\link{callNextMethod}}, prior to set the values of
+ the specific slots. See for example the method
+ \code{\link[=rnmf,NMFOffset,numeric-method]{rnmf}}
+ defined for \code{\linkS4class{NMFOffset}} models:
+ \code{showMethods(rnmf, class='NMFOffset',
+ include=TRUE))}.
+
+ For convenience, shortcut methods for working on
+ \code{data.frame} objects directly are implemented.
+ However, note that conversion of a \code{data.frame} into
+ a \code{matrix} object may take some non-negligible time,
+ for large datasets. If using this method or other
+ NMF-related methods several times, consider converting
+ your data \code{data.frame} object into a matrix once for
+ good, when first loaded.
+}
+\section{Methods}{
+ \describe{
+
+ \item{rnmf}{\code{signature(x = "NMFOffset", target =
+ "numeric")}: Generates a random NMF model with offset,
+ from class \code{NMFOffset}.
+
+ The offset values are drawn from a uniform distribution
+ between 0 and the maximum entry of the basis and
+ coefficient matrices, which are drawn by the next
+ suitable \code{\link{rnmf}} method, which is the
+ workhorse method \code{rnmf,NMF,numeric}. }
+
+ \item{rnmf}{\code{signature(x = "NMF", target =
+ "numeric")}: Generates a random NMF model of the same
+ class and rank as another NMF model.
+
+ This is the workhorse method that is eventually called by
+ all other methods. It generates an NMF model of the same
+ class and rank as \code{x}, compatible with the
+ dimensions specified in \code{target}, that can be a
+ single or 2-length numeric vector, to specify a square or
+ rectangular target matrix respectively.
+
+ The second dimension can also be passed via argument
+ \code{ncol}, so that calling \code{rnmf(x, 20, 10, ...)}
+ is equivalent to \code{rnmf(x, c(20, 10), ...)}, but
+ easier to write.
+
+ The entries are uniformly drawn between \code{0} and
+ \code{max} (optionally specified in \code{...}) that
+ defaults to 1.
+
+ By default the dimnames of \code{x} are set on the
+ returned NMF model. This behaviour is disabled with
+ argument \code{keep.names=FALSE}. See
+ \code{\link{nmfModel}}. }
+
+ \item{rnmf}{\code{signature(x = "ANY", target =
+ "matrix")}: Generates a random NMF model compatible and
+ consistent with a target matrix.
+
+ The entries are uniformly drawn between \code{0} and
+ \code{max(target)}. It is more or less a shortcut for:
+ \samp{ rnmf(x, dim(target), max=max(target), ...)}
+
+ It returns an NMF model of the same class as \code{x}. }
+
+ \item{rnmf}{\code{signature(x = "ANY", target =
+ "data.frame")}: Shortcut for \code{rnmf(x,
+ as.matrix(target))}. }
+
+ \item{rnmf}{\code{signature(x = "NMF", target =
+ "missing")}: Generates a random NMF model of the same
+ dimension as another NMF model.
+
+ It is a shortcut for \code{rnmf(x, nrow(x), ncol(x),
+ ...)}, which returns a random NMF model of the same class
+ and dimensions as \code{x}. }
+
+ \item{rnmf}{\code{signature(x = "numeric", target =
+ "missing")}: Generates a random NMF model of a given
+ rank, with known basis and/or coefficient matrices.
+
+ This methods allow to easily generate partially random
+ NMF model, where one or both factors are known. Although
+ the later case might seems strange, it makes sense for
+ NMF models that have fit extra data, other than the basis
+ and coefficient matrices, that are drawn by an
+ \code{rnmf} method defined for their own class, which
+ should internally call \code{rnmf,NMF,numeric} and let it
+ draw the basis and coefficient matrices. (e.g. see
+ \code{\linkS4class{NMFOffset}} and
+ \code{\link{rnmf,NMFOffset,numeric-method}}).
+
+ Depending on whether arguments \code{W} and/or \code{H}
+ are missing, this method interprets \code{x} differently:
+ \itemize{
+
+ \item \code{W} provided, \code{H} missing: \code{x} is
+ taken as the number of columns that must be drawn to
+ build a random coefficient matrix (i.e. the number of
+ columns in the target matrix).
+
+ \item \code{W} is missing, \code{H} is provided: \code{x}
+ is taken as the number of rows that must be drawn to
+ build a random basis matrix (i.e. the number of rows in
+ the target matrix).
+
+ \item both \code{W} and \code{H} are provided: \code{x}
+ is taken as the target rank of the model to generate.
+ \item Having both \code{W} and \code{H} missing produces
+ an error, as the dimension of the model cannot be
+ determined in this case. }
+
+ The matrices \code{W} and \code{H} are reduced if
+ necessary and possible to be consistent with this value
+ of the rank, by the internal call to
+ \code{\link{nmfModel}}.
+
+ All arguments in \code{...} are passed to the function
+ \code{\link{nmfModel}} which is used to build an initial
+ NMF model, that is in turn passed to
+ \code{rnmf,NMF,numeric} with \code{dist=list(coef=dist)}
+ or \code{dist=list(basis=dist)} when suitable. The type
+ of NMF model to generate can therefore be specified in
+ argument \code{model} (see \code{\link{nmfModel}} for
+ other possible arguments).
+
+ The returned NMF model, has a basis matrix equal to
+ \code{W} (if not missing) and a coefficient matrix equal
+ to \code{H} (if not missing), or drawn according to the
+ specification provided in argument \code{dist} (see
+ method \code{rnmf,NMF,numeric} for details on the
+ supported values for \code{dist}). }
+
+ \item{rnmf}{\code{signature(x = "missing", target =
+ "missing")}: Generates a random NMF model with known
+ basis and coefficient matrices.
+
+ This method is a shortcut for calling
+ \code{rnmf,numeric,missing} with a suitable value for
+ \code{x} (the rank), when both factors are known:
+ code{rnmf(min(ncol(W), nrow(H)), ..., W=W, H=H)}.
+
+ Arguments \code{W} and \code{H} are required. Note that
+ calling this method only makes sense for NMF models that
+ contains data to fit other than the basis and coefficient
+ matrices, e.g. \code{\linkS4class{NMFOffset}}. }
+
+ \item{rnmf}{\code{signature(x = "numeric", target =
+ "numeric")}: Generates a random standard NMF model of
+ given dimensions.
+
+ This is a shortcut for \code{rnmf(nmfModel(x, target,
+ ncol, ...)), dist=dist)}. It generates a standard NMF
+ model compatible with the dimensions passed in
+ \code{target}, that can be a single or 2-length numeric
+ vector, to specify a square or rectangular target matrix
+ respectively. See \code{\link{nmfModel}}. }
+
+ \item{rnmf}{\code{signature(x = "formula", target =
+ "ANY")}: Generate a random formula-based NMF model, using
+ the method \code{\link{nmfModel,formula,ANY-method}}. }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+#----------
+# rnmf,NMFOffset,numeric-method
+#----------
+# random NMF model with offset
+x <- rnmf(2, 3, model='NMFOffset')
+x
+offset(x)
+# from a matrix
+x <- rnmf(2, rmatrix(5,3, max=10), model='NMFOffset')
+offset(x)
+
+#----------
+# rnmf,NMF,numeric-method
+#----------
+## random NMF of same class and rank as another model
+
+x <- nmfModel(3, 10, 5)
+x
+rnmf(x, 20) # square
+rnmf(x, 20, 13)
+rnmf(x, c(20, 13))
+
+# using another distribution
+rnmf(x, 20, dist=rnorm)
+
+# other than standard model
+y <- rnmf(3, 50, 10, model='NMFns')
+y
+\dontshow{ stopifnot( identical(dim(y), c(50L,10L,3L)) ) }
+\dontshow{ stopifnot( is(y, 'NMFns') ) }
+
+#----------
+# rnmf,ANY,matrix-method
+#----------
+# random NMF compatible with a target matrix
+x <- nmfModel(3, 10, 5)
+y <- rmatrix(20, 13)
+rnmf(x, y) # rank of x
+rnmf(2, y) # rank 2
+
+#----------
+# rnmf,NMF,missing-method
+#----------
+## random NMF from another model
+
+a <- nmfModel(3, 100, 20)
+b <- rnmf(a)
+\dontshow{ stopifnot( !nmf.equal(a,b) ) }
+
+#----------
+# rnmf,numeric,missing-method
+#----------
+# random NMF model with known basis matrix
+x <- rnmf(5, W=matrix(1:18, 6)) # 6 x 5 model with rank=3
+basis(x) # fixed
+coef(x) # random
+
+# random NMF model with known coefficient matrix
+x <- rnmf(5, H=matrix(1:18, 3)) # 5 x 6 model with rank=3
+basis(x) # random
+coef(x) # fixed
+
+# random model other than standard NMF
+x <- rnmf(5, H=matrix(1:18, 3), model='NMFOffset')
+basis(x) # random
+coef(x) # fixed
+offset(x) # random
+
+#----------
+# rnmf,missing,missing-method
+#----------
+# random model other than standard NMF
+x <- rnmf(W=matrix(1:18, 6), H=matrix(21:38, 3), model='NMFOffset')
+basis(x) # fixed
+coef(x) # fixed
+offset(x) # random
+
+#----------
+# rnmf,numeric,numeric-method
+#----------
+## random standard NMF of given dimensions
+
+# generate a random NMF model with rank 3 that fits a 100x20 matrix
+rnmf(3, 100, 20)
+\dontshow{ stopifnot( identical(dim(rnmf(3, 100, 20)), c(100L,20L,3L)) ) }
+# generate a random NMF model with rank 3 that fits a 100x100 matrix
+rnmf(3, 100)
+\dontshow{ stopifnot( identical(dim(rnmf(3, 100)), c(100L,100L,3L)) ) }
+}
+\seealso{
+ \code{\link{rmatrix}}
+
+ Other NMF-interface: \code{\link{basis}},
+ \code{\link{.basis}}, \code{\link{.basis<-}},
+ \code{\link{basis<-}}, \code{\link{coef}},
+ \code{\link{.coef}}, \code{\link{.coef<-}},
+ \code{\link{coef<-}}, \code{\link{coefficients}},
+ \code{\link{.DollarNames,NMF-method}},
+ \code{\link{loadings,NMF-method}}, \code{\link{misc}},
+ \code{\link{NMF-class}}, \code{\link{$<-,NMF-method}},
+ \code{\link{$,NMF-method}}, \code{\link{nmfModel}},
+ \code{\link{nmfModels}}, \code{\link{scoef}}
+}
+\keyword{methods}
+
diff --git a/man/rss.Rd b/man/rss.Rd
new file mode 100644
index 0000000..82dd83b
--- /dev/null
+++ b/man/rss.Rd
@@ -0,0 +1,140 @@
+\docType{methods}
+\name{rss}
+\alias{evar}
+\alias{evar,ANY-method}
+\alias{evar-methods}
+\alias{rss}
+\alias{rss,ANY-method}
+\alias{rss,matrix-method}
+\alias{rss-methods}
+\title{Residual Sum of Squares and Explained Variance}
+\usage{
+ rss(object, ...)
+
+ \S4method{rss}{matrix}(object, target)
+
+ evar(object, ...)
+
+ \S4method{evar}{ANY}(object, target, ...)
+}
+\arguments{
+ \item{object}{an R object with a suitable
+ \code{\link{fitted}}, \code{rss} or \code{evar} method.}
+
+ \item{...}{extra arguments to allow extension, e.g.
+ passed to \code{rss} in \code{evar} calls.}
+
+ \item{target}{target matrix}
+}
+\value{
+ a single numeric value
+}
+\description{
+ \code{rss} and \code{evar} are S4 generic functions that
+ respectively computes the Residual Sum of Squares (RSS)
+ and explained variance achieved by a model.
+
+ The explained variance for a target \eqn{V} is computed
+ as: \deqn{evar = 1 - \frac{RSS}{\sum_{i,j} v_{ij}^2}
+ }{evar = 1 - RSS/sum v_{ij}^2},
+}
+\details{
+ where RSS is the residual sum of squares.
+
+ The explained variance is usefull to compare the
+ performance of different models and their ability to
+ accurately reproduce the original target matrix. Note,
+ however, that a possible caveat is that some models
+ explicitly aim at minimizing the RSS (i.e. maximizing the
+ explained variance), while others do not.
+}
+\section{Methods}{
+ \describe{
+
+ \item{evar}{\code{signature(object = "ANY")}: Default
+ method for \code{evar}.
+
+ It requires a suitable \code{rss} method to be defined
+ for \code{object}, as it internally calls
+ \code{rss(object, target, ...)}. }
+
+ \item{rss}{\code{signature(object = "matrix")}: Computes
+ the RSS between a target matrix and its estimate
+ \code{object}, which must be a matrix of the same
+ dimensions as \code{target}.
+
+ The RSS between a target matrix \eqn{V} and its estimate
+ \eqn{v} is computed as: \deqn{RSS = \sum_{i,j} (v_{ij} -
+ V_{ij})^2}
+
+ Internally, the computation is performed using an
+ optimised C++ implementation, that is light in memory
+ usage. }
+
+ \item{rss}{\code{signature(object = "ANY")}: Residual sum
+ of square between a given target matrix and a model that
+ has a suitable \code{\link{fitted}} method. It is
+ equivalent to \code{rss(fitted(object), ...)}
+
+ In the context of NMF, \cite{Hutchins et al. (2008)} used the
+ variation of the RSS in combination with the algorithm
+ from \cite{Lee et al. (1999)} to estimate the correct number of
+ basis vectors. The optimal rank is chosen where the graph
+ of the RSS first shows an inflexion point, i.e. using a
+ screeplot-type criterium. See section \emph{Rank
+ estimation} in \code{\link{nmf}}.
+
+ Note that this way of estimation may not be suitable for
+ all models. Indeed, if the NMF optimisation problem is
+ not based on the Frobenius norm, the RSS is not directly
+ linked to the quality of approximation of the NMF model.
+ However, it is often the case that it still decreases
+ with the rank. }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+#----------
+# rss,matrix-method
+#----------
+# RSS bewteeen random matrices
+x <- rmatrix(20,10, max=50)
+y <- rmatrix(20,10, max=50)
+rss(x, y)
+rss(x, x + rmatrix(x, max=0.1))
+
+#----------
+# rss,ANY-method
+#----------
+# RSS between an NMF model and a target matrix
+x <- rmatrix(20, 10)
+y <- rnmf(3, x) # random compatible model
+rss(y, x)
+
+# fit a model with nmf(): one should do better
+y2 <- nmf(x, 3) # default minimizes the KL-divergence
+rss(y2, x)
+y2 <- nmf(x, 3, 'lee') # 'lee' minimizes the RSS
+rss(y2, x)
+}
+\references{
+ Hutchins LN, Murphy SM, Singh P and Graber JH (2008).
+ "Position-dependent motif characterization using
+ non-negative matrix factorization." _Bioinformatics
+ (Oxford, England)_, *24*(23), pp. 2684-90. ISSN
+ 1367-4811, <URL:
+ http://dx.doi.org/10.1093/bioinformatics/btn526>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/18852176>.
+
+ Lee DD and Seung HS (1999). "Learning the parts of
+ objects by non-negative matrix factorization." _Nature_,
+ *401*(6755), pp. 788-91. ISSN 0028-0836, <URL:
+ http://dx.doi.org/10.1038/44565>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/10548103>.
+}
+\keyword{methods}
+
diff --git a/man/runtime-commaNMFList-method.Rd b/man/runtime-commaNMFList-method.Rd
new file mode 100644
index 0000000..693e349
--- /dev/null
+++ b/man/runtime-commaNMFList-method.Rd
@@ -0,0 +1,25 @@
+\docType{methods}
+\name{runtime,NMFList-method}
+\alias{runtime,NMFList-method}
+\title{Returns the CPU time required to compute all NMF fits in the list.
+It returns \code{NULL} if the list is empty.
+If no timing data are available, the sequential time is returned.}
+\usage{
+ \S4method{runtime}{NMFList}(object, all = FALSE)
+}
+\arguments{
+ \item{all}{logical that indicates if the CPU time of each
+ fit should be returned (\code{TRUE}) or only the total
+ CPU time used to compute all the fits in \code{object}.}
+
+ \item{object}{an object computed using some algorithm, or
+ that describes an algorithm itself.}
+}
+\description{
+ Returns the CPU time required to compute all NMF fits in
+ the list. It returns \code{NULL} if the list is empty. If
+ no timing data are available, the sequential time is
+ returned.
+}
+\keyword{methods}
+
diff --git a/man/runtime.all-commaNMFfitXn-method.Rd b/man/runtime.all-commaNMFfitXn-method.Rd
new file mode 100644
index 0000000..56c893e
--- /dev/null
+++ b/man/runtime.all-commaNMFfitXn-method.Rd
@@ -0,0 +1,29 @@
+\docType{methods}
+\name{runtime.all,NMFfitXn-method}
+\alias{runtime.all,NMFfitXn-method}
+\title{Returns the CPU time used to perform all the NMF fits stored in \code{object}.}
+\usage{
+ \S4method{runtime.all}{NMFfitXn}(object, null = FALSE,
+ warning = TRUE)
+}
+\arguments{
+ \item{null}{a logical that indicates if the sequential
+ time should be returned if no time data is available in
+ slot \sQuote{runtime.all}.}
+
+ \item{warning}{a logical that indicates if a warning
+ should be thrown if the sequential time is returned
+ instead of the real CPU time.}
+
+ \item{object}{an object computed using some algorithm, or
+ that describes an algorithm itself.}
+}
+\description{
+ If no time data is available from in slot
+ \sQuote{runtime.all} and argument \code{null=TRUE}, then
+ the sequential time as computed by \code{\link{seqtime}}
+ is returned, and a warning is thrown unless
+ \code{warning=FALSE}.
+}
+\keyword{methods}
+
diff --git a/man/scale.NMF.Rd b/man/scale.NMF.Rd
new file mode 100644
index 0000000..bd6636f
--- /dev/null
+++ b/man/scale.NMF.Rd
@@ -0,0 +1,75 @@
+\name{scale.NMF}
+\alias{scale.NMF}
+\title{Rescaling NMF Models}
+\usage{
+ \method{scale}{NMF} (x, center = c("basis", "coef"),
+ scale = 1)
+}
+\arguments{
+ \item{x}{an NMF object}
+
+ \item{center}{either a numeric normalising vector
+ \eqn{\delta}{delta}, or either \code{'basis'} or
+ \code{'coef'}, which respectively correspond to using the
+ column sums of the basis matrix or the inverse of the row
+ sums of the coefficient matrix as a normalising vector.
+ If numeric, \code{center} should be a single value or a
+ vector of length the rank of the NMF model, i.e. the
+ number of columns in the basis matrix.}
+
+ \item{scale}{scaling coefficient applied to \eqn{D}, i.e.
+ the value of \eqn{\alpha}{alpha}, or, if
+ \code{center='coef'}, the value of
+ \eqn{1/\alpha}{1/alpha} (see section \emph{Details}).}
+}
+\value{
+ an NMF object
+}
+\description{
+ Rescales an NMF model keeping the fitted target matrix
+ identical.
+}
+\details{
+ Standard NMF models are identifiable modulo a scaling
+ factor, meaning that the basis components and basis
+ profiles can be rescaled without changing the fitted
+ values:
+
+ \deqn{X = W_1 H_1 = (W_1 D) (D^{-1} H_1) = W_2 H_2}{X = W
+ H = (W D) (D^-1 H)} with \eqn{D= \alpha diag(1/\delta_1,
+ \ldots, 1\delta_r)}{D= alpha * diag(1/delta_1, ...,
+ 1/delta_r)}
+
+ The default call \code{scale(object)} rescales the basis
+ NMF object so that each column of the basis matrix sums
+ up to one.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# random 3-rank 10x5 NMF model
+x <- rnmf(3, 10, 5)
+
+# rescale based on basis
+colSums(basis(x))
+colSums(basis(scale(x)))
+
+rx <- scale(x, 'basis', 10)
+colSums(basis(rx))
+rowSums(coef(rx))
+
+# rescale based on coef
+rowSums(coef(x))
+rowSums(coef(scale(x, 'coef')))
+rx <- scale(x, 'coef', 10)
+rowSums(coef(rx))
+colSums(basis(rx))
+
+# fitted target matrix is identical but the factors have been rescaled
+rx <- scale(x, 'basis')
+all.equal(fitted(x), fitted(rx))
+all.equal(basis(x), basis(rx))
+}
+
diff --git a/man/scores.Rd b/man/scores.Rd
new file mode 100644
index 0000000..5ecee32
--- /dev/null
+++ b/man/scores.Rd
@@ -0,0 +1,234 @@
+\docType{methods}
+\name{featureScore}
+\alias{extractFeatures}
+\alias{extractFeatures,matrix-method}
+\alias{extractFeatures-methods}
+\alias{extractFeatures,NMF-method}
+\alias{featureScore}
+\alias{featureScore,matrix-method}
+\alias{featureScore-methods}
+\alias{featureScore,NMF-method}
+\title{Feature Selection in NMF Models}
+\usage{
+ featureScore(object, ...)
+
+ \S4method{featureScore}{matrix}(object,
+ method = c("kim", "max"))
+
+ extractFeatures(object, ...)
+
+ \S4method{extractFeatures}{matrix}(object,
+ method = c("kim", "max"),
+ format = c("list", "combine", "subset"), nodups = TRUE)
+}
+\arguments{
+ \item{object}{an object from which scores/features are
+ computed/extracted}
+
+ \item{...}{extra arguments to allow extension}
+
+ \item{method}{scoring or selection method. It specifies
+ the name of one of the method described in sections
+ \emph{Feature scores} and \emph{Feature selection}.
+
+ Additionally for \code{extractFeatures}, it may be an
+ integer vector that indicates the number of top most
+ contributing features to extract from each column of
+ \code{object}, when ordered in decreasing order, or a
+ numeric value between 0 and 1 that indicates the minimum
+ relative basis contribution above which a feature is
+ selected (i.e. basis contribution threshold). In the case
+ of a single numeric value (integer or percentage), it is
+ used for all columns.
+
+ Note that \code{extractFeatures(x, 1)} means relative
+ contribution threshold of 100\%, to select the top
+ contributing features one must explicitly specify an
+ integer value as in \code{extractFeatures(x, 1L)}.
+ However, if all elements in methods are > 1, they are
+ automatically treated as if they were integers:
+ \code{extractFeatures(x, 2)} means the top-2 most
+ contributing features in each component.}
+
+ \item{format}{output format. The following values are
+ accepted: \describe{ \item{\sQuote{list}}{(default)
+ returns a list with one element per column in
+ \code{object}, each containing the indexes of the
+ selected features, as an integer vector. If \code{object}
+ has row names, these are used to name each index vector.
+ Components for which no feature were selected are
+ assigned a \code{NA} value.}
+
+ \item{\sQuote{combine}}{ returns all indexes in a single
+ vector. Duplicated indexes are made unique if
+ \code{nodups=TRUE} (default).}
+
+ \item{\sQuote{subset}}{ returns an object of the same
+ class as \code{object}, but subset with the selected
+ indexes, so that it contains data only from
+ basis-specific features.} }}
+
+ \item{nodups}{logical that indicates if duplicated
+ indexes, i.e. features selected on multiple basis
+ components (which should in theory not happen), should be
+ only appear once in the result. Only used when
+ \code{format='combine'}.}
+}
+\value{
+ \code{featureScore} returns a numeric vector of the
+ length the number of rows in \code{object} (i.e. one
+ score per feature).
+
+ \code{extractFeatures} returns the selected features as a
+ list of indexes, a single integer vector or an object of
+ the same class as \code{object} that only contains the
+ selected features.
+}
+\description{
+ The function \code{featureScore} implements different
+ methods to computes basis-specificity scores for each
+ feature in the data.
+
+ The function \code{extractFeatures} implements different
+ methods to select the most basis-specific features of
+ each basis component.
+}
+\details{
+ One of the properties of Nonnegative Matrix Factorization
+ is that is tend to produce sparse representation of the
+ observed data, leading to a natural application to
+ bi-clustering, that characterises groups of samples by a
+ small number of features.
+
+ In NMF models, samples are grouped according to the basis
+ components that contributes the most to each sample, i.e.
+ the basis components that have the greatest coefficient
+ in each column of the coefficient matrix (see
+ \code{\link{predict,NMF-method}}). Each group of samples
+ is then characterised by a set of features selected based
+ on basis-specifity scores that are computed on the basis
+ matrix.
+}
+\section{Methods}{
+ \describe{
+
+ \item{extractFeatures}{\code{signature(object =
+ "matrix")}: Select features on a given matrix, that
+ contains the basis component in columns. }
+
+ \item{extractFeatures}{\code{signature(object = "NMF")}:
+ Select basis-specific features from an NMF model, by
+ applying the method \code{extractFeatures,matrix} to its
+ basis matrix. }
+
+ \item{featureScore}{\code{signature(object = "matrix")}:
+ Computes feature scores on a given matrix, that contains
+ the basis component in columns. }
+
+ \item{featureScore}{\code{signature(object = "NMF")}:
+ Computes feature scores on the basis matrix of an NMF
+ model. }
+
+ }
+}
+\section{Feature scores}{
+ The function \code{featureScore} can compute
+ basis-specificity scores using the following methods:
+
+ \describe{
+
+ \item{\sQuote{kim}}{ Method defined by \cite{Kim et al. (2007)}.
+
+ The score for feature \eqn{i} is defined as: \deqn{S_i =
+ 1 + \frac{1}{\log_2 k} \sum_{q=1}^k p(i,q) \log_2
+ p(i,q)}{ S_i = 1 + 1/log2(k) sum_q [ p(i,q) log2( p(i,q)
+ ) ] },
+
+ where \eqn{p(i,q)} is the probability that the \eqn{i}-th
+ feature contributes to basis \eqn{q}: \deqn{p(i,q) =
+ \frac{W(i,q)}{\sum_{r=1}^k W(i,r)} }{ p(i,q) = W(i,q) /
+ (sum_r W(i,r)) }
+
+ The feature scores are real values within the range
+ [0,1]. The higher the feature score the more
+ basis-specific the corresponding feature. }
+
+ \item{\sQuote{max}}{Method defined by
+ \cite{Carmona-Saez et al. (2006)}.
+
+ The feature scores are defined as the row maximums. }
+
+ }
+}
+
+\section{Feature selection}{
+ The function \code{extractFeatures} can select features
+ using the following methods: \describe{
+ \item{\sQuote{kim}}{ uses \cite{Kim et al. (2007)} scoring schema
+ and feature selection method.
+
+ The features are first scored using the function
+ \code{featureScore} with method \sQuote{kim}. Then only
+ the features that fulfil both following criteria are
+ retained:
+
+ \itemize{ \item score greater than \eqn{\hat{\mu} + 3
+ \hat{\sigma}}, where \eqn{\hat{\mu}} and
+ \eqn{\hat{\sigma}} are the median and the median absolute
+ deviation (MAD) of the scores respectively;
+
+ \item the maximum contribution to a basis component is
+ greater than the median of all contributions (i.e. of all
+ elements of W). }
+
+ }
+
+ \item{\sQuote{max}}{ uses the selection method used in
+ the \code{bioNMF} software package and described in
+ \cite{Carmona-Saez et al. (2006)}.
+
+ For each basis component, the features are first sorted
+ by decreasing contribution. Then, one selects only the
+ first consecutive features whose highest contribution in
+ the basis matrix is effectively on the considered basis.
+ }
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# random NMF model
+x <- rnmf(3, 50,20)
+
+# probably no feature is selected
+extractFeatures(x)
+# extract top 5 for each basis
+extractFeatures(x, 5L)
+# extract features that have a relative basis contribution above a threshold
+extractFeatures(x, 0.5)
+# ambiguity?
+extractFeatures(x, 1) # means relative contribution above 100\%
+extractFeatures(x, 1L) # means top contributing feature in each component
+}
+\references{
+ Kim H and Park H (2007). "Sparse non-negative matrix
+ factorizations via alternating non-negativity-constrained
+ least squares for microarray data analysis."
+ _Bioinformatics (Oxford, England)_, *23*(12), pp.
+ 1495-502. ISSN 1460-2059, <URL:
+ http://dx.doi.org/10.1093/bioinformatics/btm134>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/17483501>.
+
+ Carmona-Saez P, Pascual-Marqui RD, Tirado F, Carazo JM
+ and Pascual-Montano A (2006). "Biclustering of gene
+ expression data by Non-smooth Non-negative Matrix
+ Factorization." _BMC bioinformatics_, *7*, pp. 78. ISSN
+ 1471-2105, <URL:
+ http://dx.doi.org/10.1186/1471-2105-7-78>, <URL:
+ http://www.ncbi.nlm.nih.gov/pubmed/16503973>.
+}
+\keyword{methods}
+
diff --git a/man/seed.Rd b/man/seed.Rd
new file mode 100644
index 0000000..edf19f8
--- /dev/null
+++ b/man/seed.Rd
@@ -0,0 +1,113 @@
+\docType{methods}
+\name{seed}
+\alias{seed}
+\alias{seed,ANY,ANY,character-method}
+\alias{seed,ANY,ANY,function-method}
+\alias{seed,ANY,ANY,missing-method}
+\alias{seed,ANY,ANY,NULL-method}
+\alias{seed,ANY,ANY,numeric-method}
+\alias{seed,ANY,list,NMFSeed-method}
+\alias{seed,ANY,numeric,NMFSeed-method}
+\alias{seed,matrix,NMF,NMFSeed-method}
+\alias{seed-methods}
+\title{Interface for NMF Seeding Methods}
+\usage{
+ seed(x, model, method, ...)
+
+ \S4method{seed}{matrix,NMF,NMFSeed}(x, model, method,
+ rng, ...)
+
+ \S4method{seed}{ANY,ANY,function}(x, model, method, name,
+ ...)
+}
+\arguments{
+ \item{x}{target matrix one wants to approximate with NMF}
+
+ \item{model}{specification of the NMF model, e.g., the
+ factorization rank.}
+
+ \item{method}{specification of a seeding method. See each
+ method for details on the supported formats.}
+
+ \item{...}{extra to allow extensions and passed down to
+ the actual seeding method.}
+
+ \item{rng}{rng setting to use. If not missing the RNG
+ settings are set and restored on exit using
+ \code{\link{setRNG}}.
+
+ All arguments in \code{...} are passed to teh seeding
+ strategy.}
+
+ \item{name}{optional name of the seeding method for
+ custom seeding strategies.}
+}
+\value{
+ an \code{\linkS4class{NMFfit}} object.
+}
+\description{
+ The function \code{seed} provides a single interface for
+ calling all seeding methods used to initialise NMF
+ computations. These methods at least set the basis and
+ coefficient matrices of the initial \code{object} to
+ valid nonnegative matrices. They will be used as a
+ starting point by any NMF algorithm that accept
+ initialisation.
+
+ IMPORTANT: this interface is still considered
+ experimental and is subject to changes in future release.
+}
+\section{Methods}{
+ \describe{
+
+ \item{seed}{\code{signature(x = "matrix", model = "NMF",
+ method = "NMFSeed")}: This is the workhorse method that
+ seeds an NMF model object using a given seeding strategy
+ defined by an \code{NMFSeed} object, to fit a given
+ target matrix. }
+
+ \item{seed}{\code{signature(x = "ANY", model = "ANY",
+ method = "function")}: Seeds an NMF model using a custom
+ seeding strategy, defined by a function.
+
+ \code{method} must have signature \code{(x='NMFfit',
+ y='matrix', ...)}, where \code{x} is the unseeded NMF
+ model and \code{y} is the target matrix to fit. It must
+ return an \code{\linkS4class{NMF}} object, that contains
+ the seeded NMF model. }
+
+ \item{seed}{\code{signature(x = "ANY", model = "ANY",
+ method = "missing")}: Seeds the model with the default
+ seeding method given by
+ \code{nmf.getOption('default.seed')} }
+
+ \item{seed}{\code{signature(x = "ANY", model = "ANY",
+ method = "NULL")}: Use NMF method \code{'none'}. }
+
+ \item{seed}{\code{signature(x = "ANY", model = "ANY",
+ method = "numeric")}: Use \code{method} to set the RNG
+ with \code{\link{setRNG}} and use method \dQuote{random}
+ to seed the NMF model.
+
+ Note that in this case the RNG settings are not restored.
+ This is due to some internal technical reasons, and might
+ change in future releases. }
+
+ \item{seed}{\code{signature(x = "ANY", model = "ANY",
+ method = "character")}: Use the registered seeding method
+ whose access key is \code{method}. }
+
+ \item{seed}{\code{signature(x = "ANY", model = "list",
+ method = "NMFSeed")}: Seed a model using the elements in
+ \code{model} to instantiate it with
+ \code{\link{nmfModel}}. }
+
+ \item{seed}{\code{signature(x = "ANY", model = "numeric",
+ method = "NMFSeed")}: Seeds a standard NMF model (i.e. of
+ class \code{\linkS4class{NMFstd}}) of rank \code{model}.
+ }
+
+ }
+}
+\keyword{methods}
+
diff --git a/man/setNMFMethod.Rd b/man/setNMFMethod.Rd
new file mode 100644
index 0000000..b79b4ad
--- /dev/null
+++ b/man/setNMFMethod.Rd
@@ -0,0 +1,54 @@
+\name{setNMFMethod}
+\alias{nmfRegisterAlgorithm}
+\alias{setNMFMethod}
+\title{Registering NMF Algorithms}
+\usage{
+ setNMFMethod(name, method, ...,
+ overwrite = isLoadingNamespace(), verbose = TRUE)
+
+ nmfRegisterAlgorithm(name, method, ...,
+ overwrite = isLoadingNamespace(), verbose = TRUE)
+}
+\arguments{
+ \item{...}{arguments passed to the factory function
+ \code{\link{NMFStrategy}}, which instantiate the
+ \code{\linkS4class{NMFStrategy}} object that is stored in
+ registry.}
+
+ \item{overwrite}{logical that indicates if any existing
+ NMF method with the same name should be overwritten
+ (\code{TRUE}) or not (\code{FALSE}), in which case an
+ error is thrown.}
+
+ \item{verbose}{a logical that indicates if information
+ about the registration should be printed (\code{TRUE}) or
+ not (\code{FALSE}).}
+
+ \item{name}{name/key of an NMF algorithm.}
+
+ \item{method}{definition of the algorithm}
+}
+\description{
+ Adds a new algorithm to the registry of algorithms that
+ perform Nonnegative Matrix Factorization.
+
+ \code{nmfRegisterAlgorithm} is an alias to
+ \code{setNMFMethod} for backward compatibility.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# define/regsiter a new -- dummy -- NMF algorithm with the minimum arguments
+# y: target matrix
+# x: initial NMF model (i.e. the seed)
+# NB: this algorithm simply return the seed unchanged
+setNMFMethod('mynmf', function(y, x, ...){ x })
+
+# check algorithm on toy data
+res <- nmfCheck('mynmf')
+# the NMF seed is not changed
+stopifnot( nmf.equal(res, nmfCheck('mynmf', seed=res)) )
+}
+
diff --git a/man/setNMFSeed.Rd b/man/setNMFSeed.Rd
new file mode 100644
index 0000000..2d53fd4
--- /dev/null
+++ b/man/setNMFSeed.Rd
@@ -0,0 +1,72 @@
+\docType{methods}
+\name{NMFSeed}
+\alias{NMFSeed}
+\alias{NMFSeed,character-method}
+\alias{NMFSeed-methods}
+\alias{NMFSeed,NMFSeed-method}
+\alias{removeNMFSeed}
+\alias{setNMFSeed}
+\title{\code{NMFSeed} is a constructor method that instantiate
+\code{\linkS4class{NMFSeed}} objects.}
+\usage{
+ NMFSeed(key, method, ...)
+
+ setNMFSeed(..., overwrite = isLoadingNamespace(),
+ verbose = TRUE)
+
+ removeNMFSeed(name, ...)
+}
+\arguments{
+ \item{key}{access key as a single character string}
+
+ \item{method}{specification of the seeding method, as a
+ function that takes at least the following arguments:
+ \describe{ \item{object}{uninitialised/empty NMF model,
+ i.e. that it has 0 rows and columns, but has already the
+ rank requested in the call to \code{\link{nmf}} or
+ \code{\link{seed}}.} \item{x}{target matrix}
+ \item{...}{extra arguments} }}
+
+ \item{...}{arguments passed to \code{NMFSeed} and used to
+ initialise slots in the \code{\linkS4class{NMFSeed}}
+ object, or to \code{\link[pkgmaker]{pkgreg_remove}}.}
+
+ \item{name}{name of the seeding method.}
+
+ \item{overwrite}{logical that indicates if any existing
+ NMF method with the same name should be overwritten
+ (\code{TRUE}) or not (\code{FALSE}), in which case an
+ error is thrown.}
+
+ \item{verbose}{a logical that indicates if information
+ about the registration should be printed (\code{TRUE}) or
+ not (\code{FALSE}).}
+}
+\description{
+ \code{NMFSeed} is a constructor method that instantiate
+ \code{\linkS4class{NMFSeed}} objects.
+
+ NMF seeding methods are registered via the function
+ \code{setNMFSeed}, which stores them as
+ \code{\linkS4class{NMFSeed}} objects in a dedicated
+ registry.
+
+ \code{removeNMFSeed} removes an NMF seeding method from
+ the registry.
+}
+\section{Methods}{
+ \describe{
+
+ \item{NMFSeed}{\code{signature(key = "character")}:
+ Default method simply calls \code{\link{new}} with the
+ same arguments. }
+
+ \item{NMFSeed}{\code{signature(key = "NMFSeed")}: Creates
+ an \code{NMFSeed} based on a template object
+ (Constructor-Copy), in particular it uses the
+ \strong{same} name. }
+
+ }
+}
+\keyword{methods}
+
diff --git a/man/setup.Rd b/man/setup.Rd
new file mode 100644
index 0000000..4b9df70
--- /dev/null
+++ b/man/setup.Rd
@@ -0,0 +1,82 @@
+\name{setupBackend}
+\alias{setupBackend}
+\alias{setupLibPaths}
+\alias{setupRNG}
+\alias{setupSharedMemory}
+\alias{setupTempDirectory}
+\title{Computational Setup Functions}
+\usage{
+ setupBackend(spec, backend, optional = FALSE,
+ verbose = FALSE)
+
+ setupSharedMemory(verbose)
+
+ setupTempDirectory(verbose)
+
+ setupLibPaths(pkg = "NMF", verbose = FALSE)
+
+ setupRNG(seed, n, verbose = FALSE)
+}
+\arguments{
+ \item{spec}{target parallel specification: either
+ \code{TRUE} or \code{FALSE}, or a single numeric value
+ that specifies the number of cores to setup.}
+
+ \item{backend}{value from argument \code{.pbackend} of
+ \code{nmf}.}
+
+ \item{optional}{a logical that indicates if the
+ specification must be fully satisfied, throwing an error
+ if it is not, or if one can switch back to sequential,
+ only outputting a verbose message.}
+
+ \item{verbose}{logical or integer level of verbosity for
+ message outputs.}
+
+ \item{pkg}{package name whose path should be exported the
+ workers.}
+
+ \item{seed}{initial RNG seed specification}
+
+ \item{n}{number of RNG seeds to generate}
+}
+\value{
+ Returns \code{FALSE} if no foreach backend is to be used,
+ \code{NA} if the currently registered backend is to be
+ used, or, if this function call registered a new backend,
+ the previously registered backend as a \code{foreach}
+ object, so that it can be restored after the computation
+ is over.
+}
+\description{
+ Functions used internally to setup the computational
+ environment.
+
+ \code{setupBackend} sets up a foreach backend given some
+ specifications.
+
+ \code{setupSharedMemory} checks if one can use the
+ packages \emph{bigmemory} and \emph{sychronicity} to
+ speed-up parallel computations when not keeping all the
+ fits. When both these packages are available, only one
+ result per host is written on disk, with its achieved
+ deviance stored in shared memory, that is accessible to
+ all cores on a same host. It returns \code{TRUE} if both
+ packages are available and NMF option \code{'shared'} is
+ toggled on.
+
+ \code{setupTempDirectory} creates a temporary directory
+ to store the best fits computed on each host. It ensures
+ each worker process has access to it.
+
+ \code{setupLibPaths} add the path to the NMF package to
+ each workers' libPaths.
+
+ \code{setupRNG} sets the RNG for use by the function nmf.
+ It returns the old RNG as an rstream object or the result
+ of set.seed if the RNG is not changed due to one of the
+ following reason: - the settings are not compatible with
+ rstream
+}
+\keyword{internals}
+
diff --git a/man/show-commaNMF-method.Rd b/man/show-commaNMF-method.Rd
new file mode 100644
index 0000000..a3308ab
--- /dev/null
+++ b/man/show-commaNMF-method.Rd
@@ -0,0 +1,15 @@
+\docType{methods}
+\name{show,NMF-method}
+\alias{show,NMF-method}
+\title{Show method for objects of class \code{NMF}}
+\usage{
+ \S4method{show}{NMF}(object)
+}
+\arguments{
+ \item{object}{Any R object}
+}
+\description{
+ Show method for objects of class \code{NMF}
+}
+\keyword{methods}
+
diff --git a/man/show-commaNMFList-method.Rd b/man/show-commaNMFList-method.Rd
new file mode 100644
index 0000000..5895f0e
--- /dev/null
+++ b/man/show-commaNMFList-method.Rd
@@ -0,0 +1,15 @@
+\docType{methods}
+\name{show,NMFList-method}
+\alias{show,NMFList-method}
+\title{Show method for objects of class \code{NMFList}}
+\usage{
+ \S4method{show}{NMFList}(object)
+}
+\arguments{
+ \item{object}{Any R object}
+}
+\description{
+ Show method for objects of class \code{NMFList}
+}
+\keyword{methods}
+
diff --git a/man/show-commaNMFOffset-method.Rd b/man/show-commaNMFOffset-method.Rd
new file mode 100644
index 0000000..9068347
--- /dev/null
+++ b/man/show-commaNMFOffset-method.Rd
@@ -0,0 +1,15 @@
+\docType{methods}
+\name{show,NMFOffset-method}
+\alias{show,NMFOffset-method}
+\title{Show method for objects of class \code{NMFOffset}}
+\usage{
+ \S4method{show}{NMFOffset}(object)
+}
+\arguments{
+ \item{object}{Any R object}
+}
+\description{
+ Show method for objects of class \code{NMFOffset}
+}
+\keyword{methods}
+
diff --git a/man/show-commaNMFSeed-method.Rd b/man/show-commaNMFSeed-method.Rd
new file mode 100644
index 0000000..95d7b11
--- /dev/null
+++ b/man/show-commaNMFSeed-method.Rd
@@ -0,0 +1,15 @@
+\docType{methods}
+\name{show,NMFSeed-method}
+\alias{show,NMFSeed-method}
+\title{Show method for objects of class \code{NMFSeed}}
+\usage{
+ \S4method{show}{NMFSeed}(object)
+}
+\arguments{
+ \item{object}{Any R object}
+}
+\description{
+ Show method for objects of class \code{NMFSeed}
+}
+\keyword{methods}
+
diff --git a/man/show-commaNMFStrategyIterative-method.Rd b/man/show-commaNMFStrategyIterative-method.Rd
new file mode 100644
index 0000000..2214ef3
--- /dev/null
+++ b/man/show-commaNMFStrategyIterative-method.Rd
@@ -0,0 +1,16 @@
+\docType{methods}
+\name{show,NMFStrategyIterative-method}
+\alias{show,NMFStrategyIterative-method}
+\title{Show method for objects of class \code{NMFStrategyIterative}}
+\usage{
+ \S4method{show}{NMFStrategyIterative}(object)
+}
+\arguments{
+ \item{object}{Any R object}
+}
+\description{
+ Show method for objects of class
+ \code{NMFStrategyIterative}
+}
+\keyword{methods}
+
diff --git a/man/show-commaNMFfit-method.Rd b/man/show-commaNMFfit-method.Rd
new file mode 100644
index 0000000..69af1fe
--- /dev/null
+++ b/man/show-commaNMFfit-method.Rd
@@ -0,0 +1,15 @@
+\docType{methods}
+\name{show,NMFfit-method}
+\alias{show,NMFfit-method}
+\title{Show method for objects of class \code{NMFfit}}
+\usage{
+ \S4method{show}{NMFfit}(object)
+}
+\arguments{
+ \item{object}{Any R object}
+}
+\description{
+ Show method for objects of class \code{NMFfit}
+}
+\keyword{methods}
+
diff --git a/man/show-commaNMFfitX-method.Rd b/man/show-commaNMFfitX-method.Rd
new file mode 100644
index 0000000..15efefc
--- /dev/null
+++ b/man/show-commaNMFfitX-method.Rd
@@ -0,0 +1,15 @@
+\docType{methods}
+\name{show,NMFfitX-method}
+\alias{show,NMFfitX-method}
+\title{Show method for objects of class \code{NMFfitX}}
+\usage{
+ \S4method{show}{NMFfitX}(object)
+}
+\arguments{
+ \item{object}{Any R object}
+}
+\description{
+ Show method for objects of class \code{NMFfitX}
+}
+\keyword{methods}
+
diff --git a/man/show-commaNMFfitX1-method.Rd b/man/show-commaNMFfitX1-method.Rd
new file mode 100644
index 0000000..f89f0f2
--- /dev/null
+++ b/man/show-commaNMFfitX1-method.Rd
@@ -0,0 +1,15 @@
+\docType{methods}
+\name{show,NMFfitX1-method}
+\alias{show,NMFfitX1-method}
+\title{Show method for objects of class \code{NMFfitX1}}
+\usage{
+ \S4method{show}{NMFfitX1}(object)
+}
+\arguments{
+ \item{object}{Any R object}
+}
+\description{
+ Show method for objects of class \code{NMFfitX1}
+}
+\keyword{methods}
+
diff --git a/man/show-commaNMFfitXn-method.Rd b/man/show-commaNMFfitXn-method.Rd
new file mode 100644
index 0000000..a1ffced
--- /dev/null
+++ b/man/show-commaNMFfitXn-method.Rd
@@ -0,0 +1,15 @@
+\docType{methods}
+\name{show,NMFfitXn-method}
+\alias{show,NMFfitXn-method}
+\title{Show method for objects of class \code{NMFfitXn}}
+\usage{
+ \S4method{show}{NMFfitXn}(object)
+}
+\arguments{
+ \item{object}{Any R object}
+}
+\description{
+ Show method for objects of class \code{NMFfitXn}
+}
+\keyword{methods}
+
diff --git a/man/show-commaNMFns-method.Rd b/man/show-commaNMFns-method.Rd
new file mode 100644
index 0000000..ff50354
--- /dev/null
+++ b/man/show-commaNMFns-method.Rd
@@ -0,0 +1,15 @@
+\docType{methods}
+\name{show,NMFns-method}
+\alias{show,NMFns-method}
+\title{Show method for objects of class \code{NMFns}}
+\usage{
+ \S4method{show}{NMFns}(object)
+}
+\arguments{
+ \item{object}{Any R object}
+}
+\description{
+ Show method for objects of class \code{NMFns}
+}
+\keyword{methods}
+
diff --git a/man/silhouette.NMF.Rd b/man/silhouette.NMF.Rd
new file mode 100644
index 0000000..ec30357
--- /dev/null
+++ b/man/silhouette.NMF.Rd
@@ -0,0 +1,81 @@
+\name{silhouette.NMF}
+\alias{silhouette.NMF}
+\title{Silhouette of NMF Clustering}
+\usage{
+ \method{silhouette}{NMF} (x, what = NULL, order = NULL,
+ ...)
+}
+\arguments{
+ \item{x}{an NMF object, as returned by
+ \code{\link{nmf}}.}
+
+ \item{what}{defines the type of clustering the computed
+ silhouettes are meant to assess: \code{'samples'} for the
+ clustering of samples (i.e. the columns of the target
+ matrix), \code{'features'} for the clustering of features
+ (i.e. the rows of the target matrix), and \code{'chc'}
+ for the consensus clustering of samples as defined by
+ hierarchical clustering dendrogram, \code{'consensus'}
+ for the consensus clustering of samples, with clustered
+ ordered as in the \strong{default} hierarchical
+ clustering used by \code{\link{consensusmap}} when
+ plotting the heatmap of the consensus matrix (for
+ multi-run NMF fits). That is \code{dist = 1 -
+ consensus(x)}, average linkage and reordering based on
+ row means.}
+
+ \item{order}{integer indexing vector that can be used to
+ force the silhouette order.}
+
+ \item{...}{extra arguments not used.}
+}
+\description{
+ Silhouette of NMF Clustering
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+x <- rmatrix(100, 20, dimnames = list(paste0('a', 1:100), letters[1:20]))
+# NB: using low value for maxIter for the example purpose only
+res <- nmf(x, 4, nrun = 5, maxIter = 50)
+
+# sample clustering from best fit
+plot(silhouette(res))
+
+# from consensus
+plot(silhouette(res, what = 'consensus'))
+
+# feature clustering
+plot(silhouette(res, what = 'features'))
+
+# average silhouette are computed in summary measures
+summary(res)
+
+# consensus silhouettes are ordered as on default consensusmap heatmap
+\dontrun{ op <- par(mfrow = c(1,2)) }
+consensusmap(res)
+si <- silhouette(res, what = 'consensus')
+plot(si)
+\dontrun{ par(op) }
+
+# if the order is based on some custom numeric weights
+\dontrun{ op <- par(mfrow = c(1,2)) }
+cm <- consensusmap(res, Rowv = runif(ncol(res)))
+# NB: use reverse order because silhouettes are plotted top-down
+si <- silhouette(res, what = 'consensus', order = rev(cm$rowInd))
+plot(si)
+\dontrun{ par(op) }
+
+# do the reverse: order the heatmap as a set of silhouettes
+si <- silhouette(res, what = 'features')
+\dontrun{ op <- par(mfrow = c(1,2)) }
+basismap(res, Rowv = si)
+plot(si)
+\dontrun{ par(op) }
+}
+\seealso{
+ \code{\link[NMF]{predict}}
+}
+
diff --git a/man/smoothing.Rd b/man/smoothing.Rd
new file mode 100644
index 0000000..94f1832
--- /dev/null
+++ b/man/smoothing.Rd
@@ -0,0 +1,39 @@
+\name{smoothing}
+\alias{smoothing}
+\title{Smoothing Matrix in Nonsmooth NMF Models}
+\usage{
+ smoothing(x, theta = x at theta, ...)
+}
+\arguments{
+ \item{x}{a object of class \code{NMFns}.}
+
+ \item{theta}{the smoothing parameter (numeric) between 0
+ and 1.}
+
+ \item{...}{extra arguments to allow extension (not used)}
+}
+\value{
+ if \code{x} estimates a \eqn{r}-rank NMF, then the result
+ is a \eqn{r \times r} square matrix.
+}
+\description{
+ The function \code{smoothing} builds a smoothing matrix
+ for using in Nonsmooth NMF models.
+}
+\details{
+ For a \eqn{r}-rank NMF, the smoothing matrix of parameter
+ \eqn{\theta} is built as follows: \deqn{S = (1-\theta)I +
+ \frac{\theta}{r} 11^T ,} where \eqn{I} is the identity
+ matrix and \eqn{1} is a vector of ones (cf.
+ \code{\link{NMFns-class}} for more details).
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+x <- nmfModel(3, model='NMFns')
+smoothing(x)
+smoothing(x, 0.1)
+}
+
diff --git a/man/sparseness.Rd b/man/sparseness.Rd
new file mode 100644
index 0000000..5fb1178
--- /dev/null
+++ b/man/sparseness.Rd
@@ -0,0 +1,81 @@
+\docType{methods}
+\name{sparseness}
+\alias{sparseness}
+\alias{sparseness,matrix-method}
+\alias{sparseness-methods}
+\alias{sparseness,NMF-method}
+\alias{sparseness,numeric-method}
+\title{Sparseness}
+\usage{
+ sparseness(x, ...)
+}
+\arguments{
+ \item{x}{an object whose sparseness is computed.}
+
+ \item{...}{extra arguments to allow extension}
+}
+\value{
+ usually a single numeric value -- in [0,1], or a numeric
+ vector. See each method for more details.
+}
+\description{
+ Generic function that computes the \emph{sparseness} of
+ an object, as defined by \cite{Hoyer (2004)}. The
+ sparseness quantifies how much energy of a vector is
+ packed into only few components.
+}
+\details{
+ In \cite{Hoyer (2004)}, the sparseness is defined for a
+ real vector \eqn{x} as: \deqn{Sparseness(x) =
+ \frac{\sqrt{n} - \frac{\sum |x_i|}{\sqrt{\sum
+ x_i^2}}}{\sqrt{n}-1}}{ (srqt(n) - ||x||_1 / ||x||_2) /
+ (sqrt(n) - 1)}
+
+ , where \eqn{n} is the length of \eqn{x}.
+
+ The sparseness is a real number in \eqn{[0,1]}. It is
+ equal to 1 if and only if \code{x} contains a single
+ nonzero component, and is equal to 0 if and only if all
+ components of \code{x} are equal. It interpolates
+ smoothly between these two extreme values. The closer to
+ 1 is the sparseness the sparser is the vector.
+
+ The basic definition is for a \code{numeric} vector, and
+ is extended for matrices as the mean sparseness of its
+ column vectors.
+}
+\section{Methods}{
+ \describe{
+
+ \item{sparseness}{\code{signature(x = "numeric")}: Base
+ method that computes the sparseness of a numeric vector.
+
+ It returns a single numeric value, computed following the
+ definition given in section \emph{Description}. }
+
+ \item{sparseness}{\code{signature(x = "matrix")}:
+ Computes the sparseness of a matrix as the mean
+ sparseness of its column vectors. It returns a single
+ numeric value. }
+
+ \item{sparseness}{\code{signature(x = "NMF")}: Compute
+ the sparseness of an object of class \code{NMF}, as the
+ sparseness of the basis and coefficient matrices computed
+ separately.
+
+ It returns the two values in a numeric vector with names
+ \sQuote{basis} and \sQuote{coef}. }
+
+ }
+}
+\references{
+ Hoyer P (2004). "Non-negative matrix factorization with
+ sparseness constraints." _The Journal of Machine Learning
+ Research_, *5*, pp. 1457-1469. <URL:
+ http://portal.acm.org/citation.cfm?id=1044709>.
+}
+\seealso{
+ Other assess: \code{\link{entropy}}, \code{\link{purity}}
+}
+\keyword{methods}
+
diff --git a/man/staticVar.Rd b/man/staticVar.Rd
new file mode 100644
index 0000000..271db41
--- /dev/null
+++ b/man/staticVar.Rd
@@ -0,0 +1,31 @@
+\name{staticVar}
+\alias{staticVar}
+\title{Get/Set a Static Variable in NMF Algorithms}
+\usage{
+ staticVar(name, value, init = FALSE)
+}
+\arguments{
+ \item{name}{Name of the static variable (as a single
+ character string)}
+
+ \item{value}{New value of the static variable}
+
+ \item{init}{a logical used when a \code{value} is
+ provided, that specifies if the variable should be set to
+ the new value only if it does not exist yet
+ (\code{init=TRUE}).}
+}
+\value{
+ The value of the static variable
+}
+\description{
+ This function is used in iterative NMF algorithms to
+ manage variables stored in a local workspace, that are
+ accessible to all functions that define the iterative
+ schema described in
+ \code{\linkS4class{NMFStrategyIterative}}.
+
+ It is specially useful for computing stopping criteria,
+ which often require model data from different iterations.
+}
+
diff --git a/man/stop-NMF.Rd b/man/stop-NMF.Rd
new file mode 100644
index 0000000..f7e987a
--- /dev/null
+++ b/man/stop-NMF.Rd
@@ -0,0 +1,136 @@
+\name{NMFStop}
+\alias{NMFStop}
+\alias{nmf.stop.connectivity}
+\alias{nmf.stop.iteration}
+\alias{nmf.stop.stationary}
+\alias{nmf.stop.threshold}
+\alias{stop-NMF}
+\title{Stopping Criteria for NMF Iterative Strategies}
+\usage{
+ NMFStop(s, check = TRUE)
+
+ nmf.stop.iteration(n)
+
+ nmf.stop.threshold(threshold)
+
+ nmf.stop.stationary(object, i, y, x,
+ stationary.th = .Machine$double.eps,
+ check.interval = 5 * check.niter, check.niter = 10L,
+ ...)
+
+ nmf.stop.connectivity(object, i, y, x, stopconv = 40,
+ check.interval = 10, ...)
+}
+\arguments{
+ \item{s}{specification of the stopping criterion. See
+ section \emph{Details} for the supported formats and how
+ they are processed.}
+
+ \item{check}{logical that indicates if the validity of
+ the stopping criterion function should be checked before
+ returning it.}
+
+ \item{n}{maximum number of iteration to perform.}
+
+ \item{threshold}{default stationarity threshold}
+
+ \item{object}{an NMF strategy object}
+
+ \item{i}{the current iteration}
+
+ \item{y}{the target matrix}
+
+ \item{x}{the current NMF model}
+
+ \item{stationary.th}{maximum absolute value of the
+ gradient, for the objective function to be considered
+ stationary.}
+
+ \item{check.interval}{interval (in number of iterations)
+ on which the stopping criterion is computed.}
+
+ \item{check.niter}{number of successive iteration used to
+ compute the stationnary criterion.}
+
+ \item{...}{extra arguments passed to the function
+ \code{\link{objective}}, which computes the objective
+ value between \code{x} and \code{y}.}
+
+ \item{stopconv}{number of iterations intervals over which
+ the connectivity matrix must not change for stationarity
+ to be achieved.}
+}
+\value{
+ a function that can be passed to argument \code{.stop} of
+ function \code{\link{nmf}}, which is typically used when
+ the algorith is implemented as an iterative strategy.
+
+ a function that can be used as a stopping criterion for
+ NMF algorithms defined as
+ \code{\linkS4class{NMFStrategyIterative}} objects. That
+ is a function with arguments \code{(strategy, i, target,
+ data, ...)} that returns \code{TRUE} if the stopping
+ criterion is satisfied -- which in turn stops the
+ iterative process, and \code{FALSE} otherwise.
+}
+\description{
+ The function documented here implement
+ stopping/convergence criteria commonly used in NMF
+ algorithms.
+
+ \code{NMFStop} acts as a factory method that creates
+ stopping criterion functions from different types of
+ values, which are subsequently used by
+ \code{\linkS4class{NMFStrategyIterative}} objects to
+ determine when to stop their iterative process.
+
+ \code{nmf.stop.iteration} generates a function that
+ implements the stopping criterion that limits the number
+ of iterations to a maximum of \code{n}), i.e. that
+ returns \code{TRUE} if \code{i>=n}, \code{FALSE}
+ otherwise.
+
+ \code{nmf.stop.threshold} generates a function that
+ implements the stopping criterion that stops when a given
+ stationarity threshold is achieved by successive
+ iterations. The returned function is identical to
+ \code{nmf.stop.stationary}, but with the default
+ threshold set to \code{threshold}.
+
+ More precisely, the objective function is computed over
+ \eqn{n} successive iterations (specified in argument
+ \code{check.niter}), every \code{check.interval}
+ iterations. The criterion stops when the absolute
+ difference between the maximum and the minimum objective
+ values over these iterations is lower than a given
+ threshold \eqn{\alpha} (specified in
+ \code{stationary.th}):
+
+ \code{nmf.stop.connectivity} implements the stopping
+ criterion that is based on the stationarity of the
+ connectivity matrix.
+}
+\details{
+ \code{NMFStop} can take the following values: \describe{
+ \item{function}{ is returned unchanged, except when it
+ has no arguments, in which case it assumed to be a
+ generator, which is immediately called and should return
+ a function that implements the actual stopping
+ criterion;} \item{integer}{ the value is used to create a
+ stopping criterion that stops at that exact number of
+ iterations via \code{nmf.stop.iteration};}
+ \item{numeric}{ the value is used to create a stopping
+ criterion that stops when at that stationary threshold
+ via \code{nmf.stop.threshold};} \item{character}{ must be
+ a single string which must be an access key for
+ registered criteria (currently available:
+ \dQuote{connectivity} and \dQuote{stationary}), or the
+ name of a function in the global environment or the
+ namespace of the loading package.} }
+
+ \deqn{ \left| \frac{\max_{i- N_s + 1 \leq k \leq i} D_k -
+ \min_{i - N_s +1 \leq k \leq i} D_k}{n} \right| \leq
+ \alpha, }{ | [max( D(i- N_s + 1), ..., D(i) ) - min( D(i-
+ N_s + 1), ..., D(i) )] / n | <= alpha }
+}
+
diff --git a/man/subset-NMF.Rd b/man/subset-NMF.Rd
new file mode 100644
index 0000000..7024e19
--- /dev/null
+++ b/man/subset-NMF.Rd
@@ -0,0 +1,146 @@
+\docType{methods}
+\name{[,NMF-method}
+\alias{[,NMF-method}
+\title{Sub-setting NMF Objects}
+\usage{
+ \S4method{[}{NMF}(x, i, j, ..., drop = FALSE)
+}
+\arguments{
+ \item{i}{index used to subset on the \strong{rows} of the
+ basis matrix (i.e. the features). It can be a
+ \code{numeric}, \code{logical}, or \code{character}
+ vector (whose elements must match the row names of
+ \code{x}). In the case of a \code{logical} vector the
+ entries are recycled if necessary.}
+
+ \item{j}{index used to subset on the \strong{columns} of
+ the mixture coefficient matrix (i.e. the samples). It can
+ be a \code{numeric}, \code{logical}, or \code{character}
+ vector (whose elements must match the column names of
+ \code{x}). In the case of a \code{logical} vector the
+ entries are recycled if necessary.}
+
+ \item{...}{used to specify a third index to subset on the
+ basis components, i.e. on both the columns and rows of
+ the basis matrix and mixture coefficient respectively. It
+ can be a \code{numeric}, \code{logical}, or
+ \code{character} vector (whose elements must match the
+ basis names of \code{x}). In the case of a \code{logical}
+ vector the entries are recycled if necessary.
+
+ Note that only the first extra subset index is used. A
+ warning is thrown if more than one extra argument is
+ passed in \code{...}.}
+
+ \item{drop}{single \code{logical} value used to drop the
+ \code{NMF-class} wrapping and only return subsets of one
+ of the factor matrices (see \emph{Details})}
+
+ \item{x}{ object from which to extract element(s) or in
+ which to replace element(s). }
+}
+\description{
+ This method provides a convenient way of sub-setting
+ objects of class \code{NMF}, using a matrix-like syntax.
+
+ It allows to consistently subset one or both matrix
+ factors in the NMF model, as well as retrieving part of
+ the basis components or part of the mixture coefficients
+ with a reduced amount of code.
+}
+\details{
+ The returned value depends on the number of subset index
+ passed and the value of argument \code{drop}:
+
+ \itemize{ \item No index as in \code{x[]} or \code{x[,]}:
+ the value is the object \code{x} unchanged.
+
+ \item One single index as in \code{x[i]}: the value is
+ the complete NMF model composed of the selected basis
+ components, subset by \code{i}, except if argument
+ \code{drop=TRUE}, or if it is missing and \code{i} is of
+ length 1. Then only the basis matrix is returned with
+ dropped dimensions: \code{x[i, drop=TRUE]} <=>
+ \code{drop(basis(x)[, i])}.
+
+ This means for example that \code{x[1L]} is the first
+ basis vector, and \code{x[1:3, drop = TRUE]} is the
+ matrix composed of the 3 first basis vectors -- in
+ columns.
+
+ Note that in version <= 0.18.3, the call \code{x[i, drop
+ = TRUE.or.FALSE]} was equivalent to \code{basis(x)[, i,
+ drop=TRUE.or.FALSE]}.
+
+ \item More than one index with \code{drop=FALSE}
+ (default) as in \code{x[i,j]}, \code{x[i,]},
+ \code{x[,j]}, \code{x[i,j,k]}, \code{x[i,,k]}, etc...:
+ the value is a \code{NMF} object whose basis and/or
+ mixture coefficient matrices have been subset
+ accordingly. The third index \code{k} affects
+ simultaneously the columns of the basis matrix AND the
+ rows of the mixture coefficient matrix. In this case
+ argument \code{drop} is not used.
+
+ \item More than one index with \code{drop=TRUE} and
+ \code{i} xor \code{j} missing: the value returned is the
+ matrix that is the more affected by the subset index.
+ That is that \code{x[i, , drop=TRUE]} and \code{x[i, , k,
+ drop=TRUE]} return the basis matrix subset by \code{[i,]}
+ and \code{[i,k]} respectively, while \code{x[, j,
+ drop=TRUE]} and \code{x[, j, k, drop=TRUE]} return the
+ mixture coefficient matrix subset by \code{[,j]} and
+ \code{[k,j]} respectively.
+
+ }
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# create a dummy NMF object that highlight the different way of subsetting
+a <- nmfModel(W=outer(seq(1,5),10^(0:2)), H=outer(10^(0:2),seq(-1,-10)))
+basisnames(a) <- paste('b', 1:nbasis(a), sep='')
+rownames(a) <- paste('f', 1:nrow(a), sep='')
+colnames(a) <- paste('s', 1:ncol(a), sep='')
+
+# or alternatively:
+# dimnames(a) <- list( features=paste('f', 1:nrow(a), sep='')
+# , samples=paste('s', 1:ncol(a), sep='')
+# , basis=paste('b', 1:nbasis(a)) )
+
+# look at the resulting NMF object
+a
+basis(a)
+coef(a)
+
+# extract basis components
+a[1]
+a[1, drop=FALSE] # not dropping matrix dimension
+a[2:3]
+
+# subset on the features
+a[1,]
+a[2:4,]
+# dropping the NMF-class wrapping => return subset basis matrix
+a[2:4,, drop=TRUE]
+
+# subset on the samples
+a[,1]
+a[,2:4]
+# dropping the NMF-class wrapping => return subset coef matrix
+a[,2:4, drop=TRUE]
+
+# subset on the basis => subsets simultaneously basis and coef matrix
+a[,,1]
+a[,,2:3]
+a[4:5,,2:3]
+a[4:5,,2:3, drop=TRUE] # return subset basis matrix
+a[,4:5,2:3, drop=TRUE] # return subset coef matrix
+
+# 'drop' has no effect here
+a[,,2:3, drop=TRUE]
+}
+\keyword{methods}
+
diff --git a/man/syntheticNMF.Rd b/man/syntheticNMF.Rd
new file mode 100644
index 0000000..285062c
--- /dev/null
+++ b/man/syntheticNMF.Rd
@@ -0,0 +1,91 @@
+\name{syntheticNMF}
+\alias{syntheticNMF}
+\title{Simulating Datasets}
+\usage{
+ syntheticNMF(n, r, p, offset = NULL, noise = TRUE,
+ factors = FALSE, seed = NULL)
+}
+\arguments{
+ \item{n}{number of rows of the target matrix.}
+
+ \item{r}{specification of the factorization rank. It may
+ be a single \code{numeric}, in which case argument
+ \code{p} is required and \code{r} groups of samples are
+ generated from a draw from a multinomial distribution
+ with equal probabilities, that provides their sizes.
+
+ It may also be a numerical vector, which contains the
+ number of samples in each class (i.e integers). In this
+ case argument \code{p} is discarded and forced to be the
+ sum of \code{r}.}
+
+ \item{p}{number of columns of the synthetic target
+ matrix. Not used if parameter \code{r} is a vector (see
+ description of argument \code{r}).}
+
+ \item{offset}{specification of a common offset to be
+ added to the synthetic target matrix, before
+ noisification. Its may be a numeric vector of length
+ \code{n}, or a single numeric value that is used as the
+ standard deviation of a centred normal distribution from
+ which the actual offset values are drawn.}
+
+ \item{noise}{a logical that indicate if noise should be
+ added to the matrix.}
+
+ \item{factors}{a logical that indicates if the NMF
+ factors should be return together with the matrix.}
+
+ \item{seed}{a single numeric value used to seed the
+ random number generator before generating the matrix. The
+ state of the RNG is restored on exit.}
+}
+\value{
+ a matrix, or a list if argument \code{factors=TRUE}.
+
+ When \code{factors=FALSE}, the result is a matrix object,
+ with the following attributes set: \describe{
+ \item{coefficients}{the true underlying coefficient
+ matrix (i.e. \code{H});} \item{basis}{the true underlying
+ coefficient matrix (i.e. \code{H});} \item{offset}{the
+ offset if any;} \item{pData}{a \code{list} with one
+ element \code{'Group'} that contains a factor that
+ indicates the true groups of samples, i.e. the most
+ contributing basis component for each sample;}
+ \item{fData}{a \code{list} with one element
+ \code{'Group'} that contains a factor that indicates the
+ true groups of features, i.e. the basis component to
+ which each feature contributes the most.} }
+
+ Moreover, the result object is an
+ \code{\link{ExposeAttribute}} object, which means that
+ relevant attributes are accessible via \code{$}, e.g.,
+ \code{res$coefficients}. In particular, methods
+ \code{\link{coef}} and \code{\link{basis}} will work as
+ expected and return the true underlying coefficient and
+ basis matrices respectively.
+}
+\description{
+ The function \code{syntheticNMF} generates random target
+ matrices that follow some defined NMF model, and may be
+ used to test NMF algorithms. It is designed to designed
+ to produce data with known or clear classes of samples.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+# generate a synthetic dataset with known classes: 50 features, 18 samples (5+5+8)
+n <- 50
+counts <- c(5, 5, 8)
+
+# no noise
+V <- syntheticNMF(n, counts, noise=FALSE)
+\dontrun{aheatmap(V)}
+
+# with noise
+V <- syntheticNMF(n, counts)
+\dontrun{aheatmap(V)}
+}
+
diff --git a/man/t.NMF.Rd b/man/t.NMF.Rd
new file mode 100644
index 0000000..e30389a
--- /dev/null
+++ b/man/t.NMF.Rd
@@ -0,0 +1,41 @@
+\name{t.NMF}
+\alias{t.NMF}
+\title{Transformation NMF Model Objects}
+\usage{
+ \method{t}{NMF} (x)
+}
+\arguments{
+ \item{x}{NMF model object.}
+}
+\description{
+ \code{t} transpose an NMF model, by transposing and
+ swapping its basis and coefficient matrices:
+ \eqn{t([W,H]) = [t(H), t(W)]}.
+}
+\details{
+ The function \code{t} is a generic defined in the
+ \pkg{base} package. The method \code{t.NMF} defines the
+ trasnformation for the general NMF interface. This method
+ may need to be overloaded for NMF models, whose structure
+ requires specific handling.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+x <- rnmf(3, 100, 20)
+x
+# transpose
+y <- t(x)
+y
+
+# factors are swapped-transposed
+stopifnot( identical(basis(y), t(coef(x))) )
+stopifnot( identical(coef(y), t(basis(x))) )
+}
+\seealso{
+ Other transforms: \code{\link{nneg}},
+ \code{\link{posneg}}, \code{\link{rposneg}}
+}
+
diff --git a/man/terms-internal.Rd b/man/terms-internal.Rd
new file mode 100644
index 0000000..47302a9
--- /dev/null
+++ b/man/terms-internal.Rd
@@ -0,0 +1,49 @@
+\docType{methods}
+\name{bterms<-}
+\alias{bterms<-}
+\alias{bterms<--methods}
+\alias{bterms<-,NMFstd-method}
+\alias{cterms<-}
+\alias{cterms<--methods}
+\alias{cterms<-,NMFstd-method}
+\title{Fixed Terms in NMF Models}
+\usage{
+ bterms(object)<-value
+
+ cterms(object)<-value
+}
+\arguments{
+ \item{object}{NMF object to be updated.}
+
+ \item{value}{specification of the replacement value for
+ fixed-terms.}
+}
+\description{
+ These functions are for internal use and should not be
+ called by the end-user.
+
+ \code{cterms<-} sets fixed coefficient terms or indexes
+ and should only be called on a newly created NMF object,
+ i.e. in the constructor/factory generic
+ \code{\link{nmfModel}}.
+}
+\details{
+ They use \code{\link{model.matrix}(~ -1 + ., data=value)}
+ to generate suitable term matrices.
+}
+\section{Methods}{
+ \describe{
+
+ \item{bterms<-}{\code{signature(object = "NMFstd")}:
+ Default method tries to coerce \code{value} into a
+ \code{data.frame} with \code{\link{as.data.frame}}. }
+
+ \item{cterms<-}{\code{signature(object = "NMFstd")}:
+ Default method tries to coerce \code{value} into a
+ \code{data.frame} with \code{\link{as.data.frame}}. }
+
+ }
+}
+\keyword{internal}
+\keyword{methods}
+
diff --git a/man/terms.Rd b/man/terms.Rd
new file mode 100644
index 0000000..390614f
--- /dev/null
+++ b/man/terms.Rd
@@ -0,0 +1,120 @@
+\docType{methods}
+\name{ibterms}
+\alias{bterms}
+\alias{cterms}
+\alias{ibasis}
+\alias{ibterms}
+\alias{ibterms-methods}
+\alias{ibterms,NMFfit-method}
+\alias{ibterms,NMFfitX-method}
+\alias{ibterms,NMF-method}
+\alias{ibterms,NMFstd-method}
+\alias{icoef}
+\alias{icterms}
+\alias{icterms-methods}
+\alias{icterms,NMFfit-method}
+\alias{icterms,NMF-method}
+\alias{icterms,NMFstd-method}
+\alias{iterms}
+\alias{nbterms}
+\alias{ncterms}
+\alias{nterms}
+\title{Fixed Terms in NMF Models}
+\usage{
+ ibterms(object, ...)
+
+ icterms(object, ...)
+
+ iterms(object, ...)
+
+ nterms(object)
+
+ nbterms(object)
+
+ ncterms(object)
+
+ bterms(object)
+
+ cterms(object)
+
+ ibasis(object, ...)
+
+ icoef(object, ...)
+}
+\arguments{
+ \item{object}{NMF object}
+
+ \item{...}{extra parameters to allow extension (currently
+ not used)}
+}
+\description{
+ Formula-based NMF models may contain fixed basis and/or
+ coefficient terms. The functions documented here provide
+ access to these data, which are read-only and defined
+ when the model object is instantiated (e.g., see
+ \code{\link[=nmfModel,formula,ANY-method]{nmfModel,formula-method}}).
+
+ \code{ibterms}, \code{icterms} and \code{iterms}
+ respectively return the indexes of the fixed basis terms,
+ the fixed coefficient terms and all fixed terms, within
+ the basis and/or coefficient matrix of an NMF model.
+
+ \code{nterms}, \code{nbterms}, and \code{ncterms} return,
+ respectively, the number of all fixed terms, fixed basis
+ terms and fixed coefficient terms in an NMF model. In
+ particular: i.e. \code{nterms(object) = nbterms(object) +
+ ncterms(object)}.
+
+ \code{bterms} and \code{cterms} return, respectively, the
+ primary data for fixed basis and coefficient terms in an
+ NMF model -- as stored in slots \code{bterms} and
+ \code{cterms} . These are factors or numeric vectors
+ which define fixed basis components, e.g., used for
+ defining separate offsets for different \emph{a priori}
+ groups of samples, or to incorporate/correct for some
+ known covariate.
+
+ \code{ibasis} and \code{icoef} return, respectively, the
+ indexes of all latent basis vectors and estimated
+ coefficients within the basis or coefficient matrix of an
+ NMF model.
+}
+\section{Methods}{
+ \describe{
+
+ \item{ibterms}{\code{signature(object = "NMF")}: Default
+ pure virtual method that ensure a method is defined for
+ concrete NMF model classes. }
+
+ \item{ibterms}{\code{signature(object = "NMFstd")}:
+ Method for standard NMF models, which returns the integer
+ vector that is stored in slot \code{ibterms} when a
+ formula-based NMF model is instantiated. }
+
+ \item{ibterms}{\code{signature(object = "NMFfit")}:
+ Method for single NMF fit objects, which returns the
+ indexes of fixed basis terms from the fitted model. }
+
+ \item{ibterms}{\code{signature(object = "NMFfitX")}:
+ Method for multiple NMF fit objects, which returns the
+ indexes of fixed basis terms from the best fitted model.
+ }
+
+ \item{icterms}{\code{signature(object = "NMF")}: Default
+ pure virtual method that ensure a method is defined for
+ concrete NMF model classes. }
+
+ \item{icterms}{\code{signature(object = "NMFstd")}:
+ Method for standard NMF models, which returns the integer
+ vector that is stored in slot \code{icterms} when a
+ formula-based NMF model is instantiated. }
+
+ \item{icterms}{\code{signature(object = "NMFfit")}:
+ Method for single NMF fit objects, which returns the
+ indexes of fixed coefficient terms from the fitted model.
+ }
+
+ }
+}
+\keyword{methods}
+
diff --git a/man/txtProgressBar.Rd b/man/txtProgressBar.Rd
new file mode 100644
index 0000000..d7937e7
--- /dev/null
+++ b/man/txtProgressBar.Rd
@@ -0,0 +1,56 @@
+\name{txtProgressBar}
+\alias{txtProgressBar}
+\title{Simple Progress Bar}
+\usage{
+ txtProgressBar(min = 0, max = 1, initial = 0, char = "=",
+ width = NA, title = if (style == 3) " ", label,
+ style = 1, file = "", shared = NULL)
+}
+\arguments{
+ \item{shared}{specification of a shared directory to use
+ when the progress bar is to be used by multiple
+ processes.}
+
+ \item{min}{(finite) numeric values for the extremes of
+ the progress bar. Must have \code{min < max}.}
+
+ \item{max}{(finite) numeric values for the extremes of
+ the progress bar. Must have \code{min < max}.}
+
+ \item{initial}{initial or new value for the progress bar.
+ See \sQuote{Details} for what happens with invalid
+ values.}
+
+ \item{char}{the character (or character string) to form
+ the progress bar.}
+
+ \item{width}{the width of the progress bar, as a multiple
+ of the width of \code{char}. If \code{NA}, the default,
+ the number of characters is that which fits into
+ \code{getOption("width")}.}
+
+ \item{title}{ignored, for compatibility with other
+ progress bars.}
+
+ \item{label}{ignored, for compatibility with other
+ progress bars.}
+
+ \item{style}{the \sQuote{style} of the bar -- see
+ \sQuote{Details}.}
+
+ \item{file}{an open connection object or \code{""} which
+ indicates the console: \code{\link{stderr}()} might be
+ useful here.}
+}
+\description{
+ Creates a simple progress bar with title. This function
+ is identical to \code{utils::txtProgressBar} but allow
+ adding a title to the progress bar, and can be shared by
+ multiple processes, e.g., in multicore or multi-hosts
+ computations.
+}
+\author{
+ R Core Team
+}
+\keyword{internal}
+
diff --git a/man/types.Rd b/man/types.Rd
new file mode 100644
index 0000000..ac6f86f
--- /dev/null
+++ b/man/types.Rd
@@ -0,0 +1,149 @@
+\name{is.nmf}
+\alias{hasBasis}
+\alias{hasCoef}
+\alias{is.empty.nmf}
+\alias{is.nmf}
+\alias{isNMFfit}
+\alias{is.partial.nmf}
+\title{Testing NMF Objects}
+\usage{
+ is.nmf(x)
+
+ is.empty.nmf(x, ...)
+
+ hasBasis(x)
+
+ hasCoef(x)
+
+ is.partial.nmf(x)
+
+ isNMFfit(object, recursive = TRUE)
+}
+\arguments{
+ \item{x}{an R object. See section \emph{Details}, for how
+ each function uses this argument.}
+
+ \item{...}{extra parameters to allow extension or passed
+ to subsequent calls}
+
+ \item{object}{any R object.}
+
+ \item{recursive}{if \code{TRUE} and \code{object} is a
+ plain list then \code{isNMFfit} tests each element of the
+ list. Note that the recursive test only applies in the
+ case of lists that are not themselves NMFfit objects,
+ like \code{NMFfitXn} objects for which the result of
+ \code{isNMFfit} will always be \code{TRUE}, although they
+ are list objects (a single logical value).}
+}
+\value{
+ \code{isNMFfit} returns a \code{logical} vector (or a
+ list if \code{object} is a list of list) of the same
+ length as \code{object}.
+}
+\description{
+ The functions documented here tests different
+ characteristics of NMF objects.
+
+ \code{is.nmf} tests if an object is an NMF model or a
+ class that extends the class NMF.
+
+ \code{hasBasis} tests whether an objects contains a basis
+ matrix -- returned by a suitable method \code{basis} --
+ with at least one row.
+
+ \code{hasBasis} tests whether an objects contains a
+ coefficient matrix -- returned by a suitable method
+ \code{coef} -- with at least one column.
+
+ \code{is.partial.nmf} tests whether an NMF model object
+ contains either an empty basis or coefficient matrix. It
+ is a shorcut for \code{!hasCoef(x) || !hasBasis(x)}.
+}
+\details{
+ \code{is.nmf} tests if \code{object} is the name of a
+ class (if a \code{character} string), or inherits from a
+ class, that extends \code{\linkS4class{NMF}}.
+
+ \code{is.empty.nmf} returns \code{TRUE} if the basis and
+ coefficient matrices of \code{x} have respectively zero
+ rows and zero columns. It returns \code{FALSE} otherwise.
+
+ In particular, this means that an empty model can still
+ have a non-zero number of basis components, i.e. a
+ factorization rank that is not null. This happens, for
+ example, in the case of NMF models created calling the
+ factory method \code{\link{nmfModel}} with a value only
+ for the factorization rank.
+
+ \emph{isNMFfit} checks if \code{object} inherits from
+ class \code{\linkS4class{NMFfit}} or
+ \code{\linkS4class{NMFfitX}}, which are the two types of
+ objects returned by the function \code{\link{nmf}}. If
+ \code{object} is a plain \code{list} and
+ \code{recursive=TRUE}, then the test is performed on each
+ element of the list, and the return value is a logical
+ vector (or a list if \code{object} is a list of list) of
+ the same length as \code{object}.
+}
+\note{
+ The function \code{is.nmf} does some extra work with the
+ namespace as this function needs to return correct
+ results even when called in \code{.onLoad}. See
+ discussion on r-devel:
+ \url{https://stat.ethz.ch/pipermail/r-devel/2011-June/061357.html}
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+#----------
+# is.nmf
+#----------
+# test if an object is an NMF model, i.e. that it implements the NMF interface
+is.nmf(1:4)
+is.nmf('NMFstd')
+is.nmf('NMFblah')
+is.nmf( nmfModel(3) )
+is.nmf( nmf(rmatrix(20,10), 3) )
+
+#----------
+# is.empty.nmf
+#----------
+# empty model
+is.empty.nmf( nmfModel(3) )
+# non empty models
+is.empty.nmf( nmfModel(3, 10, 0) )
+is.empty.nmf( rnmf(3, 10, 5) )
+
+#----------
+# isNMFfit
+#----------
+## Testing results of fits
+# generate a random
+V <- rmatrix(20, 10)
+
+# single run -- using very low value for maxIter to speed up the example
+res <- nmf(V, 3, maxIter=3L)
+isNMFfit(res)
+
+# multiple runs - keeping single fit
+resm <- nmf(V, 3, nrun=3, maxIter=3L)
+isNMFfit(resm)
+
+# multiple runs - keeping all fits
+resM <- nmf(V, 3, nrun=3, .opt='k', maxIter=3L)
+isNMFfit(resM)
+
+# with a list of results
+isNMFfit(list(res, resm, resM, 'not a result'))
+isNMFfit(list(res, list(resm, resM), 'not a result')) # list of list
+isNMFfit(list(res, resm, resM, 'not a result'), recursive=FALSE)
+}
+\seealso{
+ \code{\linkS4class{NMFfit}},
+ \code{\linkS4class{NMFfitX}},
+ \code{\linkS4class{NMFfitXn}}
+}
+
diff --git a/man/utils.Rd b/man/utils.Rd
new file mode 100644
index 0000000..27d80b5
--- /dev/null
+++ b/man/utils.Rd
@@ -0,0 +1,28 @@
+\name{utils-NMF}
+\alias{str_args}
+\alias{utils-NMF}
+\title{Utility Function in the NMF Package}
+\usage{
+ str_args(x, exdent = 10L)
+}
+\arguments{
+ \item{x}{a function}
+
+ \item{exdent}{indentation for extra lines if the output
+ takes more than one line.}
+}
+\description{
+ Utility Function in the NMF Package
+
+ \code{str_args} formats the arguments of a function using
+ \code{\link{args}}, but returns the output as a string.
+}
+\examples{
+\dontshow{# roxygen generated flag
+options(R_CHECK_RUNNING_EXAMPLES_=TRUE)
+}
+
+args(library)
+str_args(library)
+}
+
diff --git a/src/distance.cpp b/src/distance.cpp
new file mode 100644
index 0000000..8a7e900
--- /dev/null
+++ b/src/distance.cpp
@@ -0,0 +1,166 @@
+#ifndef NMF_DISTANCE_H // include header only once
+#define NMF_DISTANCE_H
+#include <R.h>
+#include <Rdefines.h>
+#include <R_ext/Error.h>
+
+extern "C" {
+
+ SEXP Euclidean_rss( SEXP x, SEXP y);
+ SEXP KL_divergence( SEXP x, SEXP y);
+
+}
+
+//define helper macro
+#define both_non_NA(a,b) (!ISNAN(a) && !ISNAN(b))
+
+// include versions for double-double storage.mode
+#include "distance.cpp"
+// include versions for double-integer storage.mode
+#define NMF_ARG2_INT
+#include "distance.cpp"
+#undef NMF_ARG2_INT
+
+// include versions for integer-* storage.mode
+#define NMF_ARG1_INT
+ #include "distance.cpp"
+
+ // include versions for integer-integer storage.mode
+ #define NMF_ARG2_INT
+ #include "distance.cpp"
+ #undef NMF_ARG2_INT
+#undef NMF_ARG1_INT
+
+// define the exported version of RSS (for SEXP)
+SEXP Euclidean_rss ( SEXP x, SEXP y){
+
+ // retrieve dimensions
+ int n = INTEGER(GET_DIM(x))[0];
+ int p = INTEGER(GET_DIM(x))[1];
+
+ if( INTEGER(GET_DIM(y))[0] != n )
+ error("non-conformable arrays (rows)");
+ if( INTEGER(GET_DIM(y))[1] != p )
+ error("non-conformable arrays (columns)");
+
+ if( TYPEOF(x) == REALSXP ){// x is double
+ if( TYPEOF(y) == REALSXP )// x and y are double
+ return rss( NUMERIC_POINTER(x), NUMERIC_POINTER(y), n, p);
+ else// x is double, y is integer
+ return rss( NUMERIC_POINTER(x), INTEGER_POINTER(y), n, p);
+ }else{
+ if( TYPEOF(y) == REALSXP ) // x is integer, y is double
+ return rss( INTEGER_POINTER(x), NUMERIC_POINTER(y), n, p);
+ else // x is integer, y is integer
+ return rss( INTEGER_POINTER(x), INTEGER_POINTER(y), n, p);
+ }
+
+}
+
+// define the exported version of KL (for SEXP)
+SEXP KL_divergence ( SEXP x, SEXP y){
+
+ // retrieve dimensions
+ int n = INTEGER(GET_DIM(x))[0];
+ int p = INTEGER(GET_DIM(x))[1];
+
+ if( INTEGER(GET_DIM(y))[0] != n )
+ error("non-conformable arrays (rows)");
+ if( INTEGER(GET_DIM(y))[1] != p )
+ error("non-conformable arrays (columns)");
+
+ if( TYPEOF(x) == REALSXP ){// x is double
+ if( TYPEOF(y) == REALSXP )// x and y are double
+ return KL( NUMERIC_POINTER(x), NUMERIC_POINTER(y), n, p);
+ else// x is double, y is integer
+ return KL( NUMERIC_POINTER(x), INTEGER_POINTER(y), n, p);
+ }else{
+ if( TYPEOF(y) == REALSXP ) // x is integer, y is double
+ return KL( INTEGER_POINTER(x), NUMERIC_POINTER(y), n, p);
+ else // x is integer, y is integer
+ return KL( INTEGER_POINTER(x), INTEGER_POINTER(y), n, p);
+ }
+
+}
+
+#define NMF_DISTANCE_DONE
+#else // END OF NMF_DISTANCE_H
+#ifndef NMF_DISTANCE_DONE // START DEFINITION OF FUNCTIONS
+
+// Internal function that computes the RSS
+SEXP rss(
+ #ifdef NMF_ARG1_INT
+ int*
+ #else
+ double*
+ #endif
+ px,
+ #ifdef NMF_ARG2_INT
+ int*
+ #else
+ double*
+ #endif
+ py
+ , int n, int p){
+
+ double dev=0, dist=0;
+ double xval, yval;
+ //int count = 0;
+ for(int i=n-1; i>=0; --i) {
+ for(int j=p-1; j>=0; --j) {
+ xval = px[i + j*n]; yval = py[i + j*n];
+ if (both_non_NA(xval, yval)) {
+ dev = xval - yval;
+ if (!ISNAN(dev)) {
+ dist += dev * dev;
+ //count++;
+ }
+ else return ScalarReal(NA_REAL);
+ }
+ else return ScalarReal(NA_REAL);
+ }
+ }
+ //if (count == 0) return ScalarReal(NA_REAL);
+ return ScalarReal(dist);
+}
+
+// Internal function that computes the KL divergence
+SEXP KL(
+ #ifdef NMF_ARG1_INT
+ int*
+ #else
+ double*
+ #endif
+ px,
+ #ifdef NMF_ARG2_INT
+ int*
+ #else
+ double*
+ #endif
+ py
+ , int n, int p){
+
+ double dev=0, dist=0;
+ double xval, yval;
+ for(int i=n-1; i>=0; --i) {
+ for(int j=p-1; j>=0; --j) {
+ xval = px[i + j*n]; yval = py[i + j*n];
+ if( xval == 0 )
+ dev = yval;
+ else if (both_non_NA(xval, yval))
+ dev = xval * log((double) xval / yval) - xval + yval;
+ else return ScalarReal(NA_REAL);
+
+ // only add and continue if the term is not NA
+ if ( R_FINITE(dev) )
+ dist += dev;
+ else
+ return ScalarReal(dev);
+ }
+ }
+ return ScalarReal(dist);
+}
+
+#endif //END ifndef NMF_DISTANCE_DONE
+#endif //END ifdef NMF_DISTANCE_H
+
diff --git a/src/divergence.cpp b/src/divergence.cpp
new file mode 100644
index 0000000..e3d86ee
--- /dev/null
+++ b/src/divergence.cpp
@@ -0,0 +1,218 @@
+#ifndef NMF_DIVERGENCE_H // include header only once
+#define NMF_DIVERGENCE_H
+
+#include <R.h>
+#include <Rdefines.h>
+#include <R_ext/Error.h>
+
+extern "C" {
+
+ SEXP divergence_update_H ( SEXP v, SEXP w, SEXP h, SEXP nbterms, SEXP ncterms, SEXP dup);
+ SEXP divergence_update_W ( SEXP v, SEXP w, SEXP h, SEXP nbterms, SEXP ncterms, SEXP dup);
+
+}
+
+// include version for both double/integer storage.mode (defined as templates)
+#include "divergence.cpp"
+
+// define the exported versions (for SEXP)
+SEXP divergence_update_H ( SEXP v, SEXP w, SEXP h
+ , SEXP nbterms=ScalarInteger(0), SEXP ncterms=ScalarInteger(0)
+ , SEXP dup=ScalarLogical(1)) {
+
+ if( TYPEOF(v) == REALSXP ){
+ return divergence_update_H(NUMERIC_POINTER(v), w, h
+ , *INTEGER(nbterms), *INTEGER(ncterms)
+ , *LOGICAL(dup));
+ }else{
+ return divergence_update_H(INTEGER_POINTER(v), w, h
+ , *INTEGER(nbterms), *INTEGER(ncterms)
+ , *LOGICAL(dup));
+ }
+}
+
+SEXP divergence_update_W ( SEXP v, SEXP w, SEXP h
+ , SEXP nbterms=ScalarInteger(0), SEXP ncterms=ScalarInteger(0)
+ , SEXP dup=ScalarLogical(1)) {
+
+ if( TYPEOF(v) == REALSXP )
+ return divergence_update_W(NUMERIC_POINTER(v), w, h
+ , *INTEGER(nbterms), *INTEGER(ncterms)
+ , *LOGICAL(dup));
+ else
+ return divergence_update_W(INTEGER_POINTER(v), w, h
+ , *INTEGER(nbterms), *INTEGER(ncterms)
+ , *LOGICAL(dup));
+}
+
+#define NMF_DIVERGENCE_DONE
+#else // END OF NMF_DIVERGENCE_H
+#ifndef NMF_DIVERGENCE_DONE // START DEFINITION OF FUNCTIONS
+
+/**
+ * Divergence based multiplicative update for the mixture coefficients matrix H
+ * from Brunet et al. algorithm.
+ *
+ * @param pV target matrix
+ * @param w basis vector matrix
+ * @param h mixture coefficient matrix to be updated
+ * @param nbterms number of fixed basis terms
+ * @param ncterms number of fixed coefficient terms
+ * @param dup boolean (flag) that specifies if the update must be perform directly on w or
+ * on a duplicated version of w
+ *
+ * @return the updated mixture coefficient matrix.
+ *
+
+ */
+template <typename T_Rnumeric>
+static SEXP divergence_update_H ( T_Rnumeric* pV, SEXP w, SEXP h, int nbterms=0, int ncterms=0, int dup=1)
+{
+ SEXP res;
+ int nprotect = 0;
+
+ // retrieve dimensions from W and H
+ int n = INTEGER(GET_DIM(w))[0];
+ int r = INTEGER(GET_DIM(w))[1];
+ int p = INTEGER(GET_DIM(h))[1];
+ // get number of non-fixed terms
+ int vr = r - ncterms;
+
+ // duplicate H (keeping attributes) or modify in place
+ PROTECT(res = (dup != 0 ? duplicate(h) : h) ); nprotect++;
+
+ // define internal pointers
+ double* pW = NUMERIC_POINTER(w);
+ double* pH = NUMERIC_POINTER(h);
+ double* p_res = NUMERIC_POINTER(res);
+
+ // allocate internal memory
+ double* sumW = (double*) R_alloc(r, sizeof(double)); // will store column sums of W
+ double* pWH = (double*) R_alloc(n, sizeof(double)); // will store the currently used column of WH
+
+ // Compute update of H column by column
+ for(int jH=0; jH < p; ++jH){
+
+ for (int iH=0; iH < vr; ++iH){ // compute value for H_ij (non-fixed terms only)
+
+ // initialise values
+ double tmp_res = 0.0;
+ double &w_sum = sumW[iH];
+ if( jH == 0 ) w_sum = 0.0;
+
+ // compute cross-product w_.i by (v/wh)_.j
+ for( int u=0; u<n; u++){
+
+ // The jH-th column of WH is used to compute all elements of H_.j
+ // => compute once and store the result for using for the next rows
+ double wh_term = pWH[u];
+ if( iH == 0 ){
+ wh_term = 0.0;
+ for (int k=0; k<r; k++){
+ wh_term += pW[u + k*n] * pH[k + jH*r];
+ }
+ wh_term = pV[u + jH*n] / wh_term;
+ pWH[u] = wh_term;
+ }
+
+ tmp_res += pW[u + iH*n] * wh_term;
+
+ // compute sum of iH-th column of W (done only once)
+ if( jH == 0 ) w_sum += pW[u + iH*n];
+ }
+
+ // multiplicative update
+ p_res[iH + jH*r] = pH[iH + jH*r] * tmp_res / w_sum;
+ }
+ }
+
+ // return result
+ UNPROTECT(nprotect);
+ return res;
+
+}
+
+
+/**
+ * Divergence based multiplicative update for the basis matrix W
+ * from Brunet et al. algorithm.
+ *
+ * @param pV target matrix
+ * @param w basis vector matrix to be updated
+ * @param h mixture coefficient matrix
+ * @param nbterms number of fixed basis terms
+ * @param ncterms number of fixed coefficient terms
+ * @param dup boolean (flag) that specifies if the update must be perform directly on h or
+ * on a duplicated version of h
+ *
+ * @return the updated basis vector matrix.
+ *
+ */
+
+template <typename T_Rnumeric>
+static SEXP divergence_update_W ( T_Rnumeric* pV, SEXP w, SEXP h, int nbterms=0, int ncterms=0, int dup=1)
+{
+
+ SEXP res;
+ int nprotect = 0;
+
+ // retrieve dimensions
+ int n = INTEGER(GET_DIM(w))[0];
+ int r = INTEGER(GET_DIM(w))[1];
+ int p = INTEGER(GET_DIM(h))[1];
+
+ // duplicate W (keeping attributes)
+ PROTECT(res = (dup != 0 ? duplicate(w) : w) ); nprotect++;
+
+ // define internal pointers
+ double* pW = NUMERIC_POINTER(w);
+ double* pH = NUMERIC_POINTER(h);
+ double* p_res = NUMERIC_POINTER(res);
+
+ // allocate internal memory
+ double* sumH = (double*) R_alloc(r, sizeof(double)); // will store the row sums of H
+ double* pWH = (double*) R_alloc(p, sizeof(double)); // will store currently used row of WH
+
+ // Compute update of W row by row
+ for(int iW=0; iW < n; iW++){
+
+ for (int jW=0; jW < r; jW++){ // compute value for W_ij
+
+ // initialise values
+ double tmp_res = 0.0;
+ double &h_sum = sumH[jW];
+ if( iW == 0 ) h_sum = 0.0;
+
+ // compute cross-product (v/wh)_i. by h_j.
+ for( int u=0; u<p; u++){
+
+ // The iW-th row of WH is used to compute all elements of W_i.
+ // => compute once and store the result for using for the next columns
+ if( jW == 0 ){
+ double wh_term = 0.0;
+ for (int k=0; k<r; k++){
+ wh_term += pW[iW + k*n] * pH[k + u*r];
+ }
+ wh_term = pV[iW + u*n] / wh_term;
+ pWH[u] = wh_term;
+ }
+
+ tmp_res += pH[jW + u*r] * pWH[u];
+
+ // compute sum of jW-th row of H (done only once)
+ if( iW == 0 ) h_sum += pH[jW + u*r];
+ }
+
+ // multiplicative update
+ p_res[iW + jW*n] = pW[iW + jW*n] * tmp_res / h_sum;
+ }
+
+ }
+
+ // return result
+ UNPROTECT(nprotect);
+ return res;
+}
+
+#endif //END ifndef NMF_DIVERGENCE_DONE
+#endif //END ifdef NMF_DIVERGENCE_H
diff --git a/src/euclidean.cpp b/src/euclidean.cpp
new file mode 100644
index 0000000..6eb6c56
--- /dev/null
+++ b/src/euclidean.cpp
@@ -0,0 +1,388 @@
+#ifndef NMF_EUCLIDEAN_H // include header only once
+#define NMF_EUCLIDEAN_H
+
+#include <R.h>
+#include <Rdefines.h>
+#include <R_ext/Error.h>
+
+extern "C" {
+
+ // NMF from Lee and Seung (based on Euclidean norm)
+ SEXP euclidean_update_H ( SEXP v, SEXP w, SEXP h, SEXP eps, SEXP nbterms, SEXP ncterms, SEXP dup);
+ SEXP euclidean_update_W ( SEXP v, SEXP w, SEXP h, SEXP eps, SEXP weight, SEXP nbterms, SEXP ncterms, SEXP dup);
+
+ // NMF with offset
+ SEXP offset_euclidean_update_H ( SEXP v, SEXP w, SEXP h, SEXP offset, SEXP eps, SEXP dup);
+ SEXP offset_euclidean_update_W ( SEXP v, SEXP w, SEXP h, SEXP offset, SEXP eps, SEXP dup);
+
+}
+
+//////////////////////////////////
+// STANDARD NMF: LEE
+//////////////////////////////////
+
+// include version for both double/integer storage.mode (defined as templates)
+#include "euclidean.cpp"
+
+// define the exported versions (for SEXP)
+SEXP euclidean_update_H ( SEXP v, SEXP w, SEXP h, SEXP eps
+ , SEXP nbterms=ScalarInteger(0), SEXP ncterms=ScalarInteger(0)
+ , SEXP dup=ScalarLogical(1)){
+
+ if( TYPEOF(v) == REALSXP ){
+ return euclidean_update_H(NUMERIC_POINTER(v), w, h, eps
+ , *INTEGER(nbterms), *INTEGER(ncterms)
+ , *LOGICAL(dup));
+ }else{
+ return euclidean_update_H(INTEGER_POINTER(v), w, h, eps
+ , *INTEGER(nbterms), *INTEGER(ncterms)
+ , *LOGICAL(dup));
+ }
+}
+
+//////////////////////////////////
+// NMF WITH WEIGHT
+//////////////////////////////////
+#define NMF_WITH_WEIGHT
+#include "euclidean.cpp"
+#undef NMF_WITH_WEIGHT
+
+SEXP euclidean_update_W ( SEXP v, SEXP w, SEXP h, SEXP eps
+ , SEXP weight = R_NilValue
+ , SEXP nbterms=ScalarInteger(0), SEXP ncterms=ScalarInteger(0)
+ , SEXP dup=ScalarLogical(1)){
+
+ int nb = *INTEGER(nbterms), nc = *INTEGER(ncterms);
+ bool copy = *LOGICAL(dup);
+ if( TYPEOF(v) == REALSXP ){
+ if( isNull(weight) ){
+ return euclidean_update_W(NUMERIC_POINTER(v), w, h, eps, nb, nc, copy);
+ }else{
+ return weuclidean_update_W(NUMERIC_POINTER(v), w, h, eps, weight, nb, nc, copy);
+ }
+ }else{
+ if( isNull(weight) ){
+ return euclidean_update_W(INTEGER_POINTER(v), w, h, eps, nb, nc, copy);
+ }else{
+ return weuclidean_update_W(INTEGER_POINTER(v), w, h, eps, weight, nb, nc, copy);
+ }
+ }
+}
+
+//////////////////////////////////
+// NMF WITH OFFSET
+//////////////////////////////////
+#define NMF_WITH_OFFSET
+
+// include version for both double/integer storage.mode (defined as templates)
+#include "euclidean.cpp"
+
+#undef NMF_WITH_OFFSET
+
+// define the exported versions (for SEXP)
+SEXP offset_euclidean_update_H ( SEXP v, SEXP w, SEXP h, SEXP offset, SEXP eps, SEXP dup=ScalarLogical(1)){
+
+ if( TYPEOF(v) == REALSXP )
+ return offset_euclidean_update_H(NUMERIC_POINTER(v), w, h, offset, eps, *LOGICAL(dup));
+ else
+ return offset_euclidean_update_H(INTEGER_POINTER(v), w, h, offset, eps, *LOGICAL(dup));
+}
+
+SEXP offset_euclidean_update_W ( SEXP v, SEXP w, SEXP h, SEXP offset, SEXP eps, SEXP dup=ScalarLogical(1)){
+
+ if( TYPEOF(v) == REALSXP )
+ return offset_euclidean_update_W(NUMERIC_POINTER(v), w, h, offset, eps, *LOGICAL(dup));
+ else
+ return offset_euclidean_update_W(INTEGER_POINTER(v), w, h, offset, eps, *LOGICAL(dup));
+}
+
+#define NMF_EUCLIDEAN_DONE
+#else // END OF NMF_EUCLIDEAN_H
+#ifndef NMF_EUCLIDEAN_DONE // START DEFINITION OF FUNCTIONS
+
+/**
+ * Euclidean norm based multiplicative update for the mixture coefficients matrix H
+ * from Lee and Seung.
+ * Also used in the NMF with Offset algorithm
+ *
+ * Note: for performance reason the dimension names are NOT conserved.
+ */
+#ifndef NMF_WITH_WEIGHT
+
+template <typename T_Rnumeric>
+static
+#ifdef NMF_WITH_OFFSET
+SEXP offset_euclidean_update_H (
+#else
+SEXP euclidean_update_H (
+#endif
+ T_Rnumeric* pV, SEXP w, SEXP h
+#ifdef NMF_WITH_OFFSET
+ , SEXP offset
+#endif
+ , SEXP eps
+#ifndef NMF_WITH_OFFSET
+ , int nbterms=0, int ncterms=0
+#endif
+ , int dup=1)
+{
+ SEXP res;
+ int nprotect = 0;
+
+ double eps_val = *NUMERIC_POINTER(eps);
+
+ // retrieve dimensions
+ int n = INTEGER(GET_DIM(w))[0];
+ int r = INTEGER(GET_DIM(w))[1];
+ int p = INTEGER(GET_DIM(h))[1];
+ // get number of non-fixed terms
+ int vr =
+#ifdef NMF_WITH_OFFSET
+ r;
+#else
+ r - ncterms;
+#endif
+
+ // duplicate H (keeping attributes)
+ PROTECT( res = (dup != 0 ? duplicate(h) : h) ); nprotect++;
+
+ // define internal pointers
+ double* pW = NUMERIC_POINTER(w);
+ double* pH = NUMERIC_POINTER(h);
+ double* p_res = NUMERIC_POINTER(res);
+ double* pH_buffer = (double*) R_alloc(r, sizeof(double));
+
+ // extra variables in the case of an optional offset
+ #ifdef NMF_WITH_OFFSET
+ double *pOffset = NULL, *den_addon = NULL;
+
+ if( offset != R_NilValue ){
+ pOffset = NUMERIC_POINTER(offset);
+ den_addon = (double*) R_alloc(r, sizeof(double));
+ //memset(den_addon, 0, r);
+ }
+ #endif
+
+ // auxiliary temporary variable
+ double temp = 0.0;
+
+ // Pre-compute symmetric matrix t(W)W
+ // -> allocate internal memory as a upper triangular in column major
+ double* p_tWW = (double*) R_alloc((int) (r*(r+1))/2, sizeof(double));
+ double* p_row = NULL;
+ for( int i=r-1; i>=0; --i){
+ p_row = pW + i*n;
+
+ #ifdef NMF_WITH_OFFSET
+ den_addon[i] = 0.0;
+ #endif
+
+ for( int j=r-1; j>=0; --j){
+ temp = 0.0;
+ for( int u=n-1; u>=0; --u){
+ temp += p_row[u] * pW[u + j*n];
+
+ #ifdef NMF_WITH_OFFSET
+ if( pOffset != NULL && j==0 )
+ den_addon[i] += p_row[u] * pOffset[u];
+ #endif
+ }
+
+ p_tWW[((j+1)*j)/2 + i] = temp;
+ }
+ }
+
+ // H_au = H_au (W^T V)_au / (W^T W H)_au
+ // Compute update of H column by column
+ for (int j=p-1; j>=0; --j){
+
+ for(int i=vr-1; i>=0; --i){ // compute value for H_ij (only non-fixed entries)
+
+ // numerator
+ double numerator = 0.0;
+ for( int u=n-1; u>=0; --u)
+ numerator += pW[u + i*n] * pV[u + j*n];
+
+ double den = 0.0;
+ for( int l=r-1; l>=0; --l){ // use all entries (fixed and non-fixed)
+ // bufferize jth-column of H, as it can be changed at the end of the current i-loop
+ if( i==vr-1 )
+ pH_buffer[l] = pH[l + j*r];
+ den += p_tWW[i > l ? ((i+1)*i)/2 + l : ((l+1)*l)/2 + i] * pH_buffer[l];
+ }
+
+ // add offset addon if necessary
+ #ifdef NMF_WITH_OFFSET
+ if( pOffset != NULL )
+ den += den_addon[i];
+ #endif
+
+ // multiplicative update
+ p_res[i + j*r] = ((temp = pH_buffer[i] * numerator) > eps_val ? temp : eps_val) / (den + eps_val);
+ }
+ }
+
+ // return result
+ UNPROTECT(nprotect);
+ return res;
+}
+#endif
+
+/**
+ * Euclidean norm based multiplicative update for the basis matrix W
+ * from Lee and Seung.
+ * Also used in the NMF with Offset algorithm
+ *
+ * Note: for performance reason the dimension names are NOT conserved.
+ */
+template <typename T_Rnumeric>
+static SEXP
+#ifdef NMF_WITH_OFFSET
+ offset_euclidean_update_W
+#else
+#ifdef NMF_WITH_WEIGHT
+ weuclidean_update_W
+#else
+ euclidean_update_W
+#endif
+#endif
+ (T_Rnumeric* pV, SEXP w, SEXP h
+#ifdef NMF_WITH_OFFSET
+ , SEXP offset
+#endif
+ , SEXP eps
+#ifdef NMF_WITH_WEIGHT
+ , SEXP weight
+#endif
+#ifndef NMF_WITH_OFFSET
+ , int nbterms=0, int ncterms=0
+#endif
+ , int dup=1)
+{
+ SEXP res;
+ int nprotect = 0;
+
+ // setup variables for enforcing a limit Inf on the entries
+ double limInf = *NUMERIC_POINTER(eps);
+
+ // retrieve dimensions
+ int n = INTEGER(GET_DIM(w))[0];
+ int r = INTEGER(GET_DIM(w))[1];
+ int p = INTEGER(GET_DIM(h))[1];
+
+ // duplicate H (keeping attributes)
+ //PROTECT(res = duplicate(w)); nprotect++;
+ PROTECT(res = (dup != 0 ? duplicate(w) : w) ); nprotect++;
+
+ // define internal pointers to data
+ double* pW = NUMERIC_POINTER(w);
+ double* pH = NUMERIC_POINTER(h);
+ double* p_res = NUMERIC_POINTER(res);
+ double* pW_buffer = (double*) R_alloc(r, sizeof(double));
+
+ // extra variables in the case of an optional offset
+ #ifdef NMF_WITH_OFFSET
+ double *pOffset = NULL, *rowSumsH = NULL;
+
+ if( offset != R_NilValue ){
+ pOffset = NUMERIC_POINTER(offset);
+
+ // pre-compute the row sums of H
+ rowSumsH = (double*) R_alloc(r, sizeof(double));
+ for( int i=r-1; i>=0; --i){
+ rowSumsH[i] = 0.0;
+ for( int j=p-1; j>=0; --j){
+ rowSumsH[i] += pH[i + j*r];
+ }
+ }
+ }
+ #endif
+
+#ifdef NMF_WITH_WEIGHT
+ // take sample weights into account
+ double* p_weight = !isNull(weight) ? NUMERIC_POINTER(weight) : NULL;
+ double beta = -1.0;
+ if( p_weight == NULL ){// <=> no weights
+ beta = 1.0;
+ }
+ else if( length(weight) == 1 ){// all weighted are the same
+ // NB: theoretically this is equivalent to weight=1, but may be used
+ // to test it in practice (with the numerical adjustments via eps)
+ beta = *p_weight;
+ }
+ // fill weight vector with single value
+ if( beta > 0 ){
+ double* pw = p_weight = (double*) R_alloc(p, sizeof(double));
+ for(int i=0; i<p; ++i, ++pw){
+ *pw = beta;
+ }
+ }
+#endif
+
+ // auxiliary temporary variable
+ double temp = 0.0;
+
+ // Pre-compute symetric matrix Ht(H)
+ // -> allocate internal memory as a lower triangular in column major
+ double* p_HtH = (double*) R_alloc((int) (r*(r+1))/2, sizeof(double));
+ for( int j=r-1; j>=0; --j){
+ for( int i=j; i<r; ++i){
+ temp = 0.0;
+ for( int u=p-1; u>=0; --u){
+ temp += pH[j + u*r] * pH[i + u*r]
+#ifdef NMF_WITH_WEIGHT
+ * p_weight[u]
+#endif
+ ;
+ }
+
+ p_HtH[((i+1)*i)/2 + j] = temp;
+ }
+ }
+
+ // W_ia = W_ia (V H^T)_ia / (W H H^T)_ia and columns are rescaled after each iteration
+ // Compute update of W row by row
+ double numerator = 0.0;
+ double den = 0.0;
+ for(int i=n-1; i>=0; --i){
+
+ for (int j=r-1; j>=0; --j){// compute value for W_ij
+
+ // numerator
+ numerator = 0.0;
+ for( int u=p-1; u>=0; --u){
+ numerator += pV[i + u*n] * pH[j + u*r]
+#ifdef NMF_WITH_WEIGHT
+ * p_weight[u]
+#endif
+ ;
+ }
+
+ den = 0.0;
+ for( int l=r-1; l>=0; --l){
+ // bufferize ith-row of W, as it can be changed at the end of the current j-loop
+ if( j==r-1 )
+ pW_buffer[l] = pW[i + l*n];
+ // compute index of the stored value of t(w)w_[iH,l] in column major
+ den += pW_buffer[l] * p_HtH[l < j ? ((j+1)*j)/2 + l : ((l+1)*l)/2 + j];
+ }
+
+ // add offset addon if necessary
+ #ifdef NMF_WITH_OFFSET
+ if( pOffset != NULL )
+ den += pOffset[i] * rowSumsH[j];
+ #endif
+
+ // multiplicative update
+ temp = pW_buffer[j] * numerator;
+ p_res[i + j*n] = ( temp < limInf ? limInf : temp ) / (den + limInf);
+ }
+ }
+
+ // return result
+ UNPROTECT(nprotect);
+ return res;
+}
+
+#endif //END ifndef NMF_EUCLIDEAN_DONE
+#endif //END ifdef NMF_EUCLIDEAN_H
diff --git a/src/utils.cpp b/src/utils.cpp
new file mode 100644
index 0000000..99e199e
--- /dev/null
+++ b/src/utils.cpp
@@ -0,0 +1,276 @@
+#ifndef NMF_UTILS_H // include header only once
+#define NMF_UTILS_H
+
+#include <R.h>
+#include <Rdefines.h>
+#include <R_ext/Error.h>
+
+extern "C" {
+
+ /** Returns the pointer address of 'x' as a character string*/
+ SEXP ptr_address (SEXP x);
+
+ /** Clone an object 'x'*/
+ SEXP clone_object (SEXP x);
+
+ /** pmin in place with 'y' being a single numeric value*/
+ SEXP ptr_pmax (SEXP x, SEXP y, SEXP skip);
+
+ /** Apply inequality constraints in place. */
+ SEXP ptr_neq_constraints(SEXP x, SEXP constraints, SEXP ratio=R_NilValue, SEXP value=R_NilValue);
+
+ /** Minimum per column*/
+ SEXP colMin(SEXP x);
+
+ /** Maximum per row*/
+ SEXP colMax(SEXP x);
+
+ /** Test if an external pointer is null.
+ *
+ * Function taken from the package bigmemory (v4.2.11).
+ */
+ SEXP ptr_isnil(SEXP address)
+ {
+ void *ptr = R_ExternalPtrAddr(address);
+ SEXP ret = PROTECT(NEW_LOGICAL(1));
+ LOGICAL_DATA(ret)[0] = (ptr==NULL) ? (Rboolean)TRUE : Rboolean(FALSE);
+ UNPROTECT(1);
+ return(ret);
+ }
+
+}
+
+// define the exported versions (for SEXP)
+SEXP ptr_address (SEXP x){
+
+ SEXP ans = R_NilValue;
+ char tmp[15];
+ PROTECT(ans = allocVector(STRSXP, 1));
+ sprintf(tmp, "%p", (void *) x);
+ SET_STRING_ELT(ans, 0, mkChar(tmp));
+ UNPROTECT(1);
+ return ans;
+}
+
+SEXP clone_object (SEXP x){
+
+ return Rf_duplicate(x);
+
+}
+
+SEXP ptr_pmax(SEXP x, SEXP y, SEXP skip=R_NilValue){
+
+ int n = length(x);
+ double* p_x = ( isNull(x) ? NULL : NUMERIC_POINTER(x) );
+ double lim = isNull(y) ? -1.0 : *NUMERIC_POINTER(y);
+
+ // backup skipped values
+ int n_skip = length(skip);
+ int ncol = isNull(GET_DIM(x)) ? 1 : INTEGER(GET_DIM(x))[1];
+ int nrow = n / ncol;
+ double* old_value = NULL;
+ int* p_skip = NULL;
+
+ if( !isNull(skip) && n_skip > 0 ){
+ old_value = (double*) R_alloc(n_skip*ncol, sizeof(double));
+ p_skip = INTEGER_POINTER(skip);
+ for(int k=ncol-1; k>=0; --k){
+ for(int i=n_skip-1; i>=0; --i){
+ //Rprintf("skip %i x %i\n", i, k);
+ int is = p_skip[i]-1;
+ double val = p_x[k*nrow + is];
+ old_value[k*n_skip + i] = val;
+ }
+ }
+ }
+
+ // apply limit inf to all values
+ double* p_x2 = p_x + n-1;
+ for(int i=n-1; i>=0; --i){
+ if( *p_x2 < lim )
+ *p_x2 = lim;
+ --p_x2;
+ }
+ p_x2 = NULL;
+
+ // restore skipped values
+ if( !isNull(skip) && n_skip > 0 ){
+ for(int k=ncol-1; k>=0; --k){
+ for(int i=n_skip-1; i>=0; --i){
+ //Rprintf("restore %i x %i\n", i, k);
+ int is = p_skip[i]-1;
+ p_x[k*nrow + is] = old_value[k*n_skip + i];
+ }
+ }
+ }
+
+
+ // return modified x
+ return x;
+}
+
+/** Apply inequality constraints in place. */
+SEXP ptr_neq_constraints(SEXP x, SEXP constraints, SEXP ratio, SEXP value){
+
+ double* p_x = ( isNull(x) ? NULL : NUMERIC_POINTER(x) );
+ double d_ratio = isNull(ratio) ? 0 : *NUMERIC_POINTER(ratio);
+ double* p_value = ( isNull(value) ? NULL : NUMERIC_POINTER(value) );
+ double eps = sqrt(DOUBLE_EPS);
+
+ // get dimensions
+ int ncol = isNull(GET_DIM(x)) ? 1 : INTEGER(GET_DIM(x))[1];
+ int nrow = isNull(GET_DIM(x)) ? length(x) : INTEGER(GET_DIM(x))[0];
+ int nc = length(constraints);
+ if( nc != ncol )
+ error("There must be as many elements in list `constraints` as columns in `x`.");
+
+ // apply each set of constraints (from first to last)
+ double* _xj = p_x; // pointer to marked column
+ double* _x_last = p_x + (ncol - 1) * nrow; // pointer to last column
+ for(int j=0; j<nc; ++j){
+ SEXP c_j = VECTOR_ELT(constraints, j);
+ int n = length(c_j);
+ int* p_i = INTEGER_POINTER(c_j);
+
+ // apply the constraint on each row in the set
+ for(int k=n-1; k>=0; --k){
+ double lim = d_ratio != 0.0 ? _xj[p_i[k]-1] / d_ratio - eps : 0.0;
+ if( lim < 0 )
+ lim = 0;
+
+ // apply constraints on each column
+ // pointer to current row in last column
+ double* _xi = _x_last + p_i[k]-1;
+ for(int l=ncol-1; l>=0; --l){
+ //Rprintf("Before: xi=%f > lim=%f ? => ", lim, *_xi);
+ if( l != j && *_xi > lim ){ // constrain column to 'lim'
+ *_xi = lim;
+ }else if( l == j && p_value != NULL ){ // constrain column to 'value'
+ *_xi = *p_value;
+ }
+ //Rprintf("xi=%f\n", *_xi);
+ // move to previous column
+ _xi -= nrow;
+ }
+ _xi = NULL;
+ }
+ // move to next marked column
+ _xj += nrow;
+ }
+
+ // return modified x
+ return x;
+}
+
+
+template<class T> inline void colMin(T* x, int n, int p, T* res, const T& NA_value){
+
+ // do nothing if there is no data or fill with NAs
+ if( n <= 0 ){
+ if( p <= 0 )
+ return;
+ for(int j=p-1; j>=0; --j, ++res)
+ *res = NA_value;
+ }
+
+ for(int j=p-1; j>=0; --j, ++res){
+ *res = *(x++);
+ for(int i=n-2; i>=0; --i, ++x){
+ if( *res > *x )
+ *res = *x;
+ }
+ }
+
+}
+
+template<class T> inline void colMax(T* x, int n, int p, T* res, const T& NA_value){
+
+ // do nothing if there is no data or fill with NAs
+ if( n <= 0 ){
+ if( p <= 0 )
+ return;
+ for(int j=p-1; j>=0; --j, ++res)
+ *res = NA_value;
+ }
+
+ for(int j=p-1; j>=0; --j, ++res){
+ *res = *(x++);
+ for(int i=n-2; i>=0; --i, ++x){
+ if( *res < *x )
+ *res = *x;
+ }
+ }
+
+}
+
+/**
+ * Minimum per column
+ */
+SEXP colMin(SEXP x){
+
+ SEXP ans, dims;
+
+ // check that the argument is a matrix
+ dims = GET_DIM(x);
+ if (dims == R_NilValue)
+ error("a matrix-like object is required as argument to 'colMin'");
+ // check that it is a numeric data
+ if (!isNumeric(x))
+ error("a numeric object is required as argument to 'colMin'");
+
+ // get the dimension of the input matrix
+ int n = INTEGER(dims)[0];
+ int p = INTEGER(dims)[1];
+
+ if( TYPEOF(x) == REALSXP ){
+ // allocate memory for the result (a vector of length the number of columns of x)
+ PROTECT(ans = allocVector(REALSXP, p));
+ colMin(NUMERIC_POINTER(x), n, p, NUMERIC_POINTER(ans), NA_REAL);
+ UNPROTECT(1);
+ }
+ else{
+ // allocate memory for the result (a vector of length the number of columns of x)
+ PROTECT(ans = allocVector(INTSXP, p));
+ colMin(INTEGER_POINTER(x), n, p, INTEGER_POINTER(ans), NA_INTEGER);
+ UNPROTECT(1);
+ }
+
+ return ans;
+}
+
+/**
+ * Maximum per column
+ */
+SEXP colMax(SEXP x){
+
+ SEXP ans, dims;
+
+ // check that the argument is a matrix
+ dims = GET_DIM(x);
+ if (dims == R_NilValue)
+ error("a matrix-like object is required as argument to 'colMax'");
+ // check that it is a numeric data
+ if (!isNumeric(x))
+ error("a numeric object is required as argument to 'colMax'");
+
+ // get the dimension of the input matrix
+ int n = INTEGER(dims)[0];
+ int p = INTEGER(dims)[1];
+
+ if( TYPEOF(x) == REALSXP ){
+ // allocate memory for the result (a vector of length the number of columns of x)
+ PROTECT(ans = allocVector(REALSXP, p));
+ colMax(NUMERIC_POINTER(x), n, p, NUMERIC_POINTER(ans), NA_REAL);
+ UNPROTECT(1);
+ }
+ else{
+ // allocate memory for the result (a vector of length the number of columns of x)
+ PROTECT(ans = allocVector(INTSXP, p));
+ colMax(INTEGER_POINTER(x), n, p, INTEGER_POINTER(ans), NA_INTEGER);
+ UNPROTECT(1);
+ }
+
+ return ans;
+}
+
+#endif //END ifdef NMF_UTILS_H
diff --git a/tests/doRUnit.R b/tests/doRUnit.R
new file mode 100644
index 0000000..a793fb5
--- /dev/null
+++ b/tests/doRUnit.R
@@ -0,0 +1,62 @@
+# Run all unit tests in installed directory unitTests
+#
+# Author: Renaud Gaujoux
+# Creation: 26 Oct 2011
+###############################################################################
+
+library(pkgmaker)
+
+# Skip checks except if run locally
+if( !isFALSE(Sys.getenv_value('_R_LOCAL_CHECK_')) ){
+
+# skip tests on CRAN checks
+#if( !isCRANcheck() ){
+library(NMF)
+library(RUnit)
+nmf.options(maxIter=100L)
+
+tests <- try( utest('package:NMF', quiet=FALSE) )
+
+if( FALSE ){
+testdir <- pkgmaker:::utestPath(package='package:NMF')
+
+resfile <- list.files(testdir, pattern=".+\\.txt", full.names=TRUE)
+cat("Result files:\n")
+print(resfile)
+
+if( length(resfile) ){
+ # send
+ library(mail)
+ sapply(resfile, function(f){
+
+ # build message
+ msg <- c("**************\nR.version Info\n**************\n", capture.output(R.version))
+ sys <- Sys.info()
+ msg <- c(msg, "**************\nSystem Info\n**************\n"
+ , sapply(names(sys), function(n){ paste(n, ': ', sys[n], sep='')}))
+ msg <- c(msg, "**************\nRESULTS:\n**************\n", readLines(f))
+ # collapse
+ msg <- paste(msg, collapse="\n")
+ # subject
+ subject <- paste("Package NMF: unit test results"
+ , "-", basename(f), "-"
+ , "[", if( is(tests, 'try-error') ) 'ERROR' else "OK", "]"
+ , sep='')
+ if( isCRANcheck() ){
+ subject <- paste('CRAN check -', subject)
+ }
+ # try send email
+ if( !userIs('renaud') ) try( sendmail('renaud at cbio.uct.ac.za', subject, msg) )
+ else write(msg, file=file.path(testdir, paste("check_", basename(f), sep='')))
+ })
+
+}
+
+} # end if NOT CRAN check
+
+# stop if error
+if( is(tests, 'try-error') ){
+ stop(tests)
+}
+
+}
diff --git a/vignettes/.install_extras b/vignettes/.install_extras
new file mode 100644
index 0000000..63997d4
--- /dev/null
+++ b/vignettes/.install_extras
@@ -0,0 +1 @@
+consensus.pdf
\ No newline at end of file
diff --git a/vignettes/NMF-unitTests.Rnw b/vignettes/NMF-unitTests.Rnw
new file mode 100644
index 0000000..70a4d17
--- /dev/null
+++ b/vignettes/NMF-unitTests.Rnw
@@ -0,0 +1,188 @@
+
+\documentclass[10pt]{article}
+%\VignetteDepends{knitr}
+%\VignetteIndexEntry{NMF-unitTests}
+%\VignetteCompiler{knitr}
+%\VignetteEngine{knitr::knitr}
+\usepackage{vmargin}
+\setmargrb{0.75in}{0.75in}{0.75in}{0.75in}
+
+<<setup, include=FALSE>>=
+pkg <- 'NMF'
+require( pkg, character.only=TRUE )
+prettyVersion <- packageDescription(pkg)$Version
+prettyDate <- format(Sys.Date(), '%B %e, %Y')
+authors <- packageDescription(pkg)$Author
+@
+
+\usepackage[colorlinks]{hyperref}
+\author{\Sexpr{authors}}
+\title{\texttt{\Sexpr{pkg}}: Unit testing results\footnote{Vignette computed on Tue Mar 4 13:14:49 2014}}
+\date{\texttt{\Sexpr{pkg}} version \Sexpr{prettyVersion} as of \Sexpr{prettyDate}}
+\begin{document}
+\maketitle
+
+\section{Details}
+\begin{verbatim}
+
+RUNIT TEST PROTOCOL -- Tue Mar 4 13:14:49 2014
+***********************************************
+Number of test functions: 81
+Number of deactivated test functions: 5
+Number of errors: 0
+Number of failures: 0
+
+
+1 Test Suite :
+package:NMF - 81 test functions, 0 errors, 0 failures
+
+
+
+Details
+***************************
+Test Suite: package:NMF
+Test function regexp: ^test.
+Test file regexp: ^runit.*.[rR]$
+Involved directory:
+/tmp/Rpkglib_26ff65706d7b/NMF/tests
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.aheatmap.R
+test.mfrow: (1 checks) ... OK (0.69 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.algorithms.r
+test.brunet: (16 checks) ... OK (4.22 seconds)
+test.cversions.brunet: (1 checks) ... OK (0.87 seconds)
+test.cversions.lee: (1 checks) ... OK (1.03 seconds)
+test.cversions.lnmf : DEACTIVATED, Algorithm 'lnmf' is not fully working.
+test.cversions.ns: (1 checks) ... OK (1.11 seconds)
+test.cversions.offset: (1 checks) ... OK (2.19 seconds)
+test.frobenius: (16 checks) ... OK (5.38 seconds)
+test.KL: (16 checks) ... OK (4.23 seconds)
+test.lee: (16 checks) ... OK (3.72 seconds)
+test.lnmf : DEACTIVATED, Algorithm 'lnmf' is not fully working.
+test.ns: (16 checks) ... OK (3.78 seconds)
+test.offset: (16 checks) ... OK (3.97 seconds)
+test.port_brunet : DEACTIVATED, Package RcppOctave not available.
+test.snmf: (44 checks) ... OK (9.39 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.bioc.r
+test.access: (26 checks) ... OK (0.02 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.distance.r
+test.KL: (9 checks) ... OK (1.44 seconds)
+test.rss: (4 checks) ... OK (0.06 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.interface.r
+test.compare: (5 checks) ... OK (9.3 seconds)
+test.nmf.callback: (22 checks) ... OK (13.81 seconds)
+test.nmf.custom: (87 checks) ... OK (1.5 seconds)
+test.nmf.default: (8 checks) ... OK (0.23 seconds)
+test.nmf.dots: (11 checks) ... OK (0.84 seconds)
+test.nmf.method: (36 checks) ... OK (10.79 seconds)
+test.nmf.model: (22 checks) ... OK (0.62 seconds)
+test.nmfModel.formula: (12 checks) ... OK (0.92 seconds)
+test.nmf.multirank: (10 checks) ... OK (5.68 seconds)
+test.nmf.options: (18 checks) ... OK (5.44 seconds)
+test.nmf.parameters: (53 checks) ... OK (0.81 seconds)
+test.nmf.seed.argument: (149 checks) ... OK (9.4 seconds)
+test.nmf.seed.equivalent: (11 checks) ... OK (10.82 seconds)
+test.nmf.seed.fault: (4 checks) ... OK (2.9 seconds)
+test.nmf.seed.repro: (8 checks) ... OK (14.43 seconds)
+test.nmf.stop: (6 checks) ... OK (2.17 seconds)
+test.parallel: (6 checks) ... OK (12.28 seconds)
+test.registry: (9 checks) ... OK (0.13 seconds)
+test.seed: (33 checks) ... OK (0.13 seconds)
+test.summary: (3 checks) ... OK (2.86 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.NMFclass.r
+test.basis: (2 checks) ... OK (0.01 seconds)
+test.class.NMFns: (65 checks) ... OK (0.03 seconds)
+test.class.NMFstd: (28 checks) ... OK (0.01 seconds)
+test.coef: (2 checks) ... OK (0 seconds)
+test.connectivity: (3 checks) ... OK (0.01 seconds)
+test.deviance: (9 checks) ... OK (0.02 seconds)
+test.dimensions: (4 checks) ... OK (0 seconds)
+test.dimnames: (173 checks) ... OK (0.08 seconds)
+test.entropy: (5 checks) ... OK (0 seconds)
+test.misc: (9 checks) ... OK (0 seconds)
+test.nmfModel: (363 checks) ... OK (0.11 seconds)
+test.NMF.rnmf: (93 checks) ... OK (1.5 seconds)
+test.predict: (10 checks) ... OK (0.01 seconds)
+test.purity: (5 checks) ... OK (0 seconds)
+test.sparseness: (13 checks) ... OK (0.01 seconds)
+test.subset: (50 checks) ... OK (0.05 seconds)
+test.syntheticNMF: (5 checks) ... OK (1.62 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.NMFfit-class.r
+test.deviance: (0 checks) ... OK (0 seconds)
+test.isNMFfit: (6 checks) ... OK (3.59 seconds)
+test.niter: (4 checks) ... OK (1.1 seconds)
+test.nmf.equal: (304 checks) ... OK (1.87 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.NMFSet.r
+test.fit: (9 checks) ... OK (3.85 seconds)
+test.interface: (6 checks) ... OK (1.86 seconds)
+test.join.multipleAndSingleRunsMethods: (2 checks) ... OK (3.32 seconds)
+test.join.multipleRuns: (2 checks) ... OK (4.6 seconds)
+test.join.singleRuns: (7 checks) ... OK (0.7 seconds)
+test.multipleruns: (2 checks) ... OK (1.7 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.NMFStrategy-class.r
+test.accessors: (26 checks) ... OK (0.06 seconds)
+test.constructor: (16 checks) ... OK (0.06 seconds)
+test.constructorMethod: (3 checks) ... OK (0.04 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.options.r
+test.nmf.getOption: (2 checks) ... OK (0 seconds)
+test.nmf.options: (9 checks) ... OK (0 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.parallel.r
+test.ForeachBackend: (4 checks) ... OK (1.37 seconds)
+test.gVariable: (11 checks) ... OK (10.16 seconds)
+test.nmf: (59 checks) ... OK (41.99 seconds)
+test.setupBackend: (4 checks) ... OK (0.05 seconds)
+test.shared_memory_doMC: (12 checks) ... OK (6.1 seconds)
+test.shared_memory_doMPI : DEACTIVATED, NMF shared memory feature does not currently work with doMPI.
+test.shared_memory_doParallel: (12 checks) ... OK (10.88 seconds)
+test.shared_memory_doSEQ: (11 checks) ... OK (6.46 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.seed.r
+test.nndsvd: (10 checks) ... OK (0.04 seconds)
+test.none: (6 checks) ... OK (0.03 seconds)
+test.random: (26 checks) ... OK (0.13 seconds)
+test.restore : DEACTIVATED, The option 'restore.seed' is deprecated. Related tests are now in test.seed.effect
+test.seed.effect: (15 checks) ... OK (16.37 seconds)
+test.zzz.all: (297 checks) ... OK (16.42 seconds)
+---------------------------
+Test file: /tmp/Rpkglib_26ff65706d7b/NMF/tests/runit.utils.r
+test.nmfWrapper: (16 checks) ... OK (0.85 seconds)
+test.rmatrix: (16 checks) ... OK (0.01 seconds)
+
+Total execution time
+***************************
+ user system elapsed
+253.753 31.645 293.297
+
+\end{verbatim}
+
+\section*{Session Information}
+\begin{itemize}\raggedright
+ \item R Under development (unstable) (2014-03-02 r65102), \verb|x86_64-unknown-linux-gnu|
+ \item Locale: \verb|LC_CTYPE=en_US.UTF-8|, \verb|LC_NUMERIC=C|, \verb|LC_TIME=en_US.UTF-8|, \verb|LC_COLLATE=en_US.UTF-8|, \verb|LC_MONETARY=en_US.UTF-8|, \verb|LC_MESSAGES=en_US.UTF-8|, \verb|LC_PAPER=en_US.UTF-8|, \verb|LC_NAME=C|, \verb|LC_ADDRESS=C|, \verb|LC_TELEPHONE=C|, \verb|LC_MEASUREMENT=en_US.UTF-8|, \verb|LC_IDENTIFICATION=C|
+ \item Base packages: base, datasets, graphics, grDevices, methods,
+ parallel, stats, utils
+ \item Other packages: BH~1.51.0-4, bigmemory~4.4.6,
+ bigmemory.sri~0.1.2, Biobase~2.22.0, BiocGenerics~0.8.0,
+ cluster~1.14.4, doMPI~0.2, doParallel~1.0.8, fastICA~1.2-0,
+ foreach~1.4.1, iterators~1.0.6, NMF~0.20.2, pkgmaker~0.17.4,
+ RColorBrewer~1.0-5, Rcpp~0.11.0, registry~0.2, Rmpi~0.6-3,
+ rngtools~1.2.3, RUnit~0.4.26, stringr~0.6.2, synchronicity~1.1.2
+ \item Loaded via a namespace (and not attached): codetools~0.2-8,
+ colorspace~1.2-4, compiler~3.1.0, dichromat~2.0-0, digest~0.6.4,
+ ggplot2~0.9.3.1, grid~3.1.0, gridBase~0.4-7, gtable~0.1.2,
+ labeling~0.2, MASS~7.3-29, munsell~0.4.2, plyr~1.8.1, proto~0.3-10,
+ reshape2~1.2.2, scales~0.2.3, tools~3.1.0, xtable~1.7-1
+\end{itemize}
+
+\end{document}
+
diff --git a/vignettes/NMF-vignette.Rnw b/vignettes/NMF-vignette.Rnw
new file mode 100644
index 0000000..04498a6
--- /dev/null
+++ b/vignettes/NMF-vignette.Rnw
@@ -0,0 +1,1305 @@
+%\VignetteIndexEntry{An introduction to the package NMF}
+%\VignetteDepends{utils,NMF,Biobase,bigmemory,xtable,RColorBrewer,knitr,bibtex}
+%\VignetteKeyword{math}
+%\VignetteCompiler{knitr}
+%\VignetteEngine{knitr::knitr}
+
+\documentclass[a4paper]{article}
+
+%\usepackage[OT1]{fontenc}
+\usepackage[colorlinks]{hyperref} % for hyperlinks
+\usepackage{a4wide}
+\usepackage{xspace}
+\usepackage[all]{hypcap} % for linking to the top of the figures or tables
+
+% add preamble from pkgmaker
+<<pkgmaker_preamble, echo=FALSE, results='asis'>>=
+pkgmaker::latex_preamble()
+@
+
+\newcommand{\nmfpack}{\Rpkg{NMF}}
+\newcommand{\RcppOctave}{\textit{RcppOctave}\xspace}
+\newcommand{\matlab}{Matlab$^\circledR$\xspace}
+\newcommand{\MATLAB}{\matlab}
+\newcommand{\gauss}{GAUSS$^\circledR$\xspace}
+
+\newcommand{\graphwidth}{0.9\columnwidth}
+\newcommand{\refeqn}[1]{(\ref{#1})}
+
+% REFERENCES
+\usepackage[citestyle=authoryear-icomp
+, doi=true
+, url=true
+, maxnames=1
+, maxbibnames=15
+, backref=true
+, backend=bibtex]{biblatex}
+\AtEveryCitekey{\clearfield{url}}
+<<bibliofile, echo=FALSE, results='asis'>>=
+pkgmaker::latex_bibliography('NMF')
+@
+\newcommand{\citet}[1]{\textcite{#1}}
+\renewcommand{\cite}[1]{\parencite{#1}}
+\DefineBibliographyStrings{english}{%
+ backrefpage = {see p.}, % for single page number
+ backrefpages = {see pp.} % for multiple page numbers
+}
+%%
+
+% boxed figures
+\usepackage{float}
+\floatstyle{boxed}
+\restylefloat{figure}
+
+\usepackage{array}
+\usepackage{tabularx}
+\usepackage{xcolor}
+
+\usepackage{url}
+\urlstyle{rm}
+
+<<options, echo=FALSE>>=
+set.seed(123456)
+library(knitr)
+knit_hooks$set(try = pkgmaker::hook_try, backspace = pkgmaker::hook_backspace())
+@
+
+% use cleveref for automatic reference label formatting
+\usepackage[capitalise, noabbrev]{cleveref}
+
+% multiple columns
+\usepackage{multicol}
+
+% define commands for notes
+\usepackage{todonotes}
+\newcommand{\nbnote}[1]{\todo[inline, backgroundcolor=blue!20!white]{\scriptsize\textsf{\textbf{NB:} #1}}\ \\}
+
+% default graphic width
+\setkeys{Gin}{width=0.95\textwidth}
+
+\begin{document}
+
+<<load_library, echo=FALSE, include=FALSE>>=
+# Load
+library(NMF)
+# limit number of cores used
+nmf.options(cores = 2)
+@
+
+\title{An introduction to NMF package\\
+\small Version \Sexpr{utils::packageVersion('NMF')}}
+\author{Renaud Gaujoux}
+% \\Address Computational Biology - University of Cape Town, South Africa,
+
+\maketitle
+
+This vignette presents the \citeCRANpkg{NMF}, which implements a framework
+for Nonnegative Matrix Factorization (NMF) algorithms in R \cite{R}.
+The objective is to provide an implementation of some standard algorithms, while
+allowing the user to easily implement new methods that integrate into a
+common framework, which facilitates analysis, result visualisation or
+performance benchmarking.
+If you use the package \nmfpack in your analysis and publications please cite:
+
+\bigskip
+\todo[inline, backgroundcolor=blue!10!white]{\fullcite{Rpackage:NMF}}
+
+Note that the \nmfpack includes several NMF algorithms, published by different
+authors.
+Please make sure to also cite the paper(s) associated with the algorithm(s)
+you used.
+Citations for those can be found in \cref{tab:algo} and in the dedicated help
+pages \code{?gedAlgorithm.<algorithm>}, e.g., \code{?gedAlgorithm.SNMF\_R}.
+
+\bigskip
+\paragraph{Installation:} The latest stable version of the package can be installed from any
+\href{http://cran.r-project.org}{CRAN} repository mirror:
+<<load_library_fake, eval=FALSE>>=
+# Install
+install.packages('NMF')
+# Load
+library(NMF)
+@
+The \nmfpack is a project hosted on \emph{R-forge}\footnote{\url{https://r-forge.r-project.org/projects/nmf}}.
+The latest development version is available from \url{https://r-forge.r-project.org/R/?group_id=649} and may be installed from there\footnote{\code{install.packages("NMF", repos = "http://R-Forge.R-project.org")}}.
+
+\paragraph{Support:} UseRs interested in this package are encouraged to subscribe to the user mailing list (\href{https://lists.r-forge.r-project.org/mailman/listinfo/nmf-user}{nmf-user at lists.r-forge.r-project.org}), which is the preferred channel for enquiries, bug reports, feature requests, suggestions or NMF-related discussions.
+This will enable better tracking as well as fruitful community exchange.
+
+\paragraph{Important:} Note that some of the classes defined in the NMF package have gained new slots.
+If you need to load objects saved in versions prior 0.8.14 please use:
+
+<<updateObject, eval=FALSE>>=
+# eg., load from some RData file
+load('object.RData')
+# update class definition
+object <- nmfObject(object)
+@
+
+\pagebreak
+\tableofcontents
+\pagebreak
+
+\section{Overview}
+
+\subsection{Package features}
+
+This section provides a quick overview of the \nmfpack package's features.
+\Cref{sec:usecase} provides more details, as well as sample code on how to actually perform common tasks in NMF analysis.
+
+<<features, echo=FALSE>>=
+nalgo <- length(nmfAlgorithm())
+nseed <- length(nmfSeed())
+@
+
+The \nmfpack package provides:
+\begin{itemize}
+\item \Sexpr{nalgo} built-in algorithms;
+\item \Sexpr{nseed} built-in seeding methods;
+\item Single interface to perform all algorithms, and combine them with the seeding methods;
+\item Provides a common framework to test, compare and develop NMF methods;
+\item Accept custom algorithms and seeding methods;
+\item Plotting utility functions to visualize and help in the interpretation of the results;
+\item Transparent parallel computations;
+\item Optimized and memory efficient C++ implementations of the standard algorithms;
+\item Optional layer for bioinformatics using BioConductor \cite{Gentleman2004};
+\end{itemize}
+
+\subsection{Nonnegative Matrix Factorization}
+
+This section gives a formal definition for Nonnegative Matrix Factorization problems, and defines the notations used throughout the vignette.
+
+Let $X$ be a $n \times p$ non-negative matrix, (i.e with $x_{ij} \geq 0$,
+denoted $X \geq 0$), and $r > 0$ an integer. Non-negative Matrix Factorization (NMF) consists in finding an approximation
+\begin{equation}
+X \approx W H\ , \label{NMFstd}
+\end{equation}
+where $W, H$ are $n\times r$ and $r \times p$ non-negative matrices, respectively.
+In practice, the factorization rank $r$ is often chosen such that $r \ll \min(n, p)$.
+The objective behind this choice is to summarize and split the information contained in $X$ into $r$ factors: the columns of $W$.
+
+Depending on the application field, these factors are given different names: basis images, metagenes, source signals. In this vignette we equivalently and alternatively use the terms
+\emph{basis matrix} or \emph{metagenes} to refer to matrix $W$, and \emph{mixture coefficient matrix} and \emph{metagene expression profiles} to refer to matrix $H$.
+
+The main approach to NMF is to estimate matrices $W$ and $H$ as a local minimum:
+\begin{equation}
+\min_{W, H \geq 0}\ \underbrace{[D(X, WH) + R(W, H)]}_{=F(W,H)} \label{nmf_min}
+\end{equation}
+where
+
+\begin{itemize}
+\item $D$ is a loss function that measures the quality of the approximation.
+Common loss functions are based on either the Frobenius distance
+$$D: A,B\mapsto \frac{Tr(AB^t)}{2} = \frac{1}{2} \sum_{ij} (a_{ij} - b_{ij})^2,$$
+or the Kullback-Leibler divergence.
+$$D: A,B\mapsto KL(A||B) = \sum_{i,j} a_{ij} \log \frac{a_{ij}}{b_{ij}} - a_{ij} + b_{ij}.$$
+\item $R$ is an optional regularization function, defined to enforce desirable
+properties on matrices $W$ and $H$, such as smoothness or sparsity
+\cite{Cichocki2008}.
+\end{itemize}
+
+\subsection{Algorithms}
+NMF algorithms generally solve problem \refeqn{nmf_min} iteratively, by building a sequence of matrices $(W_k,H_k)$ that reduces at each step the value of the objective function $F$.
+Beside some variations in the specification of $F$, they also differ in the optimization techniques that are used to compute the updates for $(W_k,H_k)$.
+
+For reviews on NMF algorithms see \cite{Berry2007, Chu2004} and references therein.
+
+The \nmfpack package implements a number of published algorithms, and provides a general framework to implement other ones.
+\Cref{tab:algo} gives a short description of each one of the built-in algorithms:
+
+The built-in algorithms are listed or retrieved with function \code{nmfAlgorithm}.
+A given algorithm is retrieved by its name (a \code{character} key), that is partially matched against the list of available algorithms:
+
+<<nmfAlgorithm>>=
+# list all available algorithms
+nmfAlgorithm()
+# retrieve a specific algorithm: 'brunet'
+nmfAlgorithm('brunet')
+# partial match is also fine
+identical(nmfAlgorithm('br'), nmfAlgorithm('brunet'))
+@
+
+\begin{table}[h!t]
+\begin{tabularx}{\textwidth}{lX}
+\hline
+Key & Description\\
+\hline
+\code{brunet} & Standard NMF. Based on Kullback-Leibler divergence, it uses
+simple multiplicative updates from \cite{Lee2001}, enhanced to avoid numerical underflow.
+
+\begin{eqnarray}
+H_{kj} & \leftarrow & H_{kj} \frac{\left( \sum_l \frac{W_{lk} V_{lj}}{(WH)_{lj}} \right)}{ \sum_l W_{lk} }\\
+W_{ik} & \leftarrow & W_{ik} \frac{ \sum_l [H_{kl} A_{il} / (WH)_{il} ] }{\sum_l H_{kl} }
+\end{eqnarray}
+
+\textbf{Reference:} \cite{Brunet2004}\\
+\hline
+%
+\code{lee} & Standard NMF. Based on euclidean distance, it uses simple multiplicative updates
+
+\begin{eqnarray}
+H_{kj} & \leftarrow & H_{kj} \frac{(W^T V)_{kj}}{(W^T W H)_{kj}}\\
+W_{ik} & \leftarrow & W_{ik} \frac{(V H^T)_{ik}}{(W H H^T)_{ik}}
+\end{eqnarray}
+
+
+\textbf{Reference:} \cite{Lee2001}\\
+\hline
+%
+%\code{lnmf} & Local Nonnegative Matrix Factorization. Based on a
+%regularized Kullback-Leibler divergence, it uses a modified version of
+%Lee and Seung's multiplicative updates.
+%
+%\textbf{Reference:} \cite{Li2001}\\
+%
+\code{nsNMF} & Non-smooth NMF. Uses a modified version of Lee and Seung's multiplicative updates for Kullback-Leibler divergence to fit a extension of the standard NMF model.
+It is meant to give sparser results.
+
+\textbf{Reference:} \cite{Pascual-Montano2006}\\
+\hline
+%
+\code{offset} & Uses a modified version of Lee and Seung's multiplicative updates for euclidean distance, to fit a NMF model that includes an intercept.
+
+\textbf{Reference:} \cite{Badea2008}\\
+\hline
+%
+\code{pe-nmf} & Pattern-Expression NMF. Uses multiplicative updates to minimize an objective function based on the Euclidean distance and regularized for effective expression of patterns with basis vectors.
+
+\textbf{Reference:} \cite{Zhang2008}\\
+\hline
+%
+\code{snmf/r}, \code{snmf/l} & Alternating Least Square (ALS) approach.
+It is meant to be very fast compared to other approaches.
+
+\textbf{Reference:} \cite{KimH2007}\\
+\hline
+\end{tabularx}
+\caption{Description of the implemented NMF algorithms. The first column gives the key to use in
+the call to the \texttt{nmf} function.\label{tab:algo}}
+\end{table}
+
+\subsection{Initialization: seeding methods}
+NMF algorithms need to be initialized with a seed (i.e. a value for $W_0$ and/or
+$H_0$\footnote{Some algorithms only need one matrix factor (either $W$ or $H$) to be initialized. See for example the SNMF/R(L) algorithm of Kim and Park \cite{KimH2007}.}), from which to start the iteration process.
+Because there is no global minimization algorithm, and due to the problem's high dimensionality, the choice of the initialization is in fact very important to ensure meaningful results.
+
+The more common seeding method is to use a random starting point, where the entries of $W$ and/or $H$ are drawn from a uniform distribution, usually within the same range as the target matrix's entries.
+This method is very simple to implement.
+However, a drawback is that to achieve stability one has to perform multiple runs, each with a different starting point.
+This significantly increases the computation time needed to obtain the desired factorization.
+
+To tackle this problem, some methods have been proposed so as to compute a reasonable starting point from the target matrix itself.
+Their objective is to produce deterministic algorithms that need to run only once, still giving meaningful results.
+
+For a review on some existing NMF initializations see \cite{Albright2006} and references therein.
+
+The \nmfpack\ package implements a number of already published seeding methods, and provides a general framework to implement other ones.
+\Cref{tab:seed} gives a short description of each one of the built-in seeding methods:
+
+The built-in seeding methods are listed or retrieved with function \code{nmfSeed}.
+A given seeding method is retrieved by its name (a \code{character} key) that is partially matched against the list of available seeding methods:
+
+<<nmfSeed>>=
+# list all available seeding methods
+nmfSeed()
+# retrieve a specific method: 'nndsvd'
+nmfSeed('nndsvd')
+# partial match is also fine
+identical(nmfSeed('nn'), nmfSeed('nndsvd'))
+@
+
+\begin{table}[h!t]
+\begin{tabularx}{\textwidth}{lX}
+\hline
+Key & Description\\
+\hline
+\code{ica} & Uses the result of an Independent Component Analysis (ICA) (from
+the \citeCRANpkg{fastICA}).
+Only the positive part of the result are used to initialize the factors.\\
+\hline
+%
+\code{nnsvd} & Nonnegative Double Singular Value Decomposition.
+The basic algorithm contains no randomization and is based on two SVD processes, one approximating the data matrix, the other approximating positive sections of the resulting partial SVD factors utilizing an algebraic property of unit rank matrices.
+It is well suited to initialize NMF algorithms with sparse factors. Simple practical variants of the algorithm allows to generate dense factors.
+
+\textbf{Reference:} \cite{Boutsidis2008}\\
+\hline
+%
+\code{none} & Fix seed.
+This method allows the user to manually provide initial values for both matrix factors.\\
+\hline
+%
+\code{random} & The entries of each factors are drawn from a uniform distribution over $[0, max(V)]$, where $V$ is the target matrix.\\
+\hline
+\end{tabularx}
+\caption{Description of the implemented seeding methods to initialize NMF algorithms.
+The first column gives the key to use in the call to the \texttt{nmf} function.\label{tab:seed}}
+\end{table}
+
+\subsection{How to run NMF algorithms}
+
+Method \code{nmf} provides a single interface to run NMF algorithms.
+It can directly perform NMF on object of class \code{matrix} or
+\code{data.frame} and \code{ExpressionSet} -- if the \citeBioCpkg{Biobase} is
+installed.
+The interface has four main parameters:
+
+\medskip
+\fbox{\code{nmf(x, rank, method, seed, ...)}}
+
+\begin{description}
+\item[\code{x}] is the target \code{matrix}, \code{data.frame} or \code{ExpressionSet}
+\footnote{\code{ExpressionSet} is the base class for handling microarray data in
+BioConductor, and is defined in the \pkgname{Biobase} package.}
+\item[\code{rank}] is the factorization rank, i.e. the number of columns in matrix $W$.
+\item[\code{method}] is the algorithm used to estimate the factorization.
+The default algorithm is given by the package specific option \code{'default.algorithm'}, which defaults to \code{'brunet'} on installation \cite{Brunet2004}.
+\item[\code{seed}] is the seeding method used to compute the starting point.
+The default method is given by the package specific option \code{'default.seed'}, which defaults to \code{'random'} on initialization (see method \code{?rnmf} for details on its implementation).
+\end{description}
+
+See also \code{?nmf} for details on the interface and extra parameters.
+
+
+\subsection{Performances}
+
+Since version 0.4, some built-in algorithms are optimized in C++, which results in a significant speed-up and a more efficient memory management, especially on large scale data.
+
+The older R versions of the concerned algorithms are still available, and accessible by adding the prefix \code{'.R\#'} to the algorithms' access keys (e.g. the key \code{'.R\#offset'} corresponds to the R implementation of NMF with offset \cite{Badea2008}).
+Moreover they do not show up in the listing returned by the \code{nmfAlgorithm} function, unless argument \code{all=TRUE}:
+
+<<show_Rversions>>=
+nmfAlgorithm(all=TRUE)
+
+# to get all the algorithms that have a secondary R version
+nmfAlgorithm(version='R')
+@
+
+\Cref{tab:perf} shows the speed-up achieved by the algorithms that benefit from the optimized code.
+All algorithms were run once with a factorization rank equal to 3, on the Golub data set which contains a $5000\times 38$ gene expression matrix.
+The same numeric random seed (\code{seed=123456}) was used for all factorizations.
+The columns \emph{C} and \emph{R} show the elapsed time (in seconds) achieved by the C++ version and R version respectively.
+The column \emph{Speed.up} contains the ratio $R/C$.
+
+<<perftable_setup, cache=TRUE>>=
+# retrieve all the methods that have a secondary R version
+meth <- nmfAlgorithm(version='R')
+meth <- c(names(meth), meth)
+meth
+
+# load the Golub data
+data(esGolub)
+
+# compute NMF for each method
+res <- nmf(esGolub, 3, meth, seed=123456)
+
+# extract only the elapsed time
+t <- sapply(res, runtime)[3,]
+@
+
+<<perftable, echo=FALSE, results='asis'>>=
+# speed-up
+m <- length(res)/2
+su <- cbind( C=t[1:m], R=t[-(1:m)], Speed.up=t[-(1:m)]/t[1:m])
+
+library(xtable)
+xtable(su, caption='Performance speed up achieved by the optimized C++ implementation for some of the NMF algorithms.', label='tab:perf')
+@
+
+
+\subsection{How to cite the package NMF}
+
+To view all the package's bibtex citations, including all vignette(s) and manual(s):
+
+<<citations, eval=FALSE>>=
+# plain text
+citation('NMF')
+
+# or to get the bibtex entries
+toBibtex(citation('NMF'))
+@
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\section{Use case: Golub dataset}\label{sec:usecase}
+We illustrate the functionalities and the usage of the \nmfpack package on the -- now standard -- Golub dataset on leukemia.
+It was used in several papers on NMF \cite{Brunet2004, Gao2005} and is included in the \nmfpack package's data, wrapped into an \code{ExpressionSet} object.
+ For performance reason we use here only the first 200 genes.
+ Therefore the results shown in the following are not meant to be biologically meaningful, but only illustrative:
+
+<<esGolub>>=
+data(esGolub)
+esGolub
+esGolub <- esGolub[1:200,]
+
+# remove the uneeded variable 'Sample' from the phenotypic data
+esGolub$Sample <- NULL
+@
+% TODO: pass to 50 genes for dev
+
+\paragraph{Note:} To run this example, the \code{Biobase} package from BioConductor is required.
+
+\subsection{Single run}\label{sec:single_run}
+
+\subsubsection{Performing a single run}
+To run the default NMF algorithm on data \code{esGolub} with a factorization rank of 3, we call:
+
+<<algo_default, cache=TRUE>>=
+# default NMF algorithm
+res <- nmf(esGolub, 3)
+@
+
+Here we did not specify either the algorithm or the seeding method, so that the computation is done using the default algorithm and is seeded by the
+default seeding methods.
+These defaults are set in the package specific options \code{'default.algorithm'}
+and \code{'default.seed'} respectively.
+
+See also \cref{sec:algo,sec:seed} for how to explicitly specify the algorithm and/or the seeding method.
+
+\subsubsection{Handling the result}
+
+The result of a single NMF run is an object of class \code{NMFfit}, that holds both the fitted NMF model and data about the run:
+
+<<single_show>>=
+res
+@
+
+The fitted model can be retrieved via method \code{fit}, which returns an object of class \code{NMF}:
+
+<<single_show_model>>=
+fit(res)
+@
+
+The estimated target matrix can be retrieved via the generic method \code{fitted}, which returns a -- generally big -- \code{matrix}:
+
+<<single_show_estimate>>=
+V.hat <- fitted(res)
+dim(V.hat)
+@
+
+Quality and performance measures about the factorization are computed by method \code{summary}:
+
+<<singlerun_summary>>=
+summary(res)
+
+# More quality measures are computed, if the target matrix is provided:
+summary(res, target=esGolub)
+@
+
+If there is some prior knowledge of classes present in the data, some other measures about the unsupervised clustering's performance are computed (purity, entropy, \ldots).
+Here we use the phenotypic variable \code{Cell} found in the Golub dataset, that gives the samples' cell-types (it is a factor with levels: T-cell, B-cell or \code{NA}):
+
+<<singlerun_summary_factor>>=
+summary(res, class=esGolub$Cell)
+@
+
+The basis matrix (i.e. matrix $W$ or the metagenes) and the mixture coefficient matrix (i.e matrix $H$ or the metagene expression profiles) are retrieved using methods \code{basis} and \code{coef} respectively:
+
+<<get_matrices>>=
+# get matrix W
+w <- basis(res)
+dim(w)
+
+# get matrix H
+h <- coef(res)
+dim(h)
+@
+
+
+If one wants to keep only part of the factorization, one can directly subset on the \code{NMF} object on features and samples (separately or simultaneously).
+The result is a \code{NMF} object composed of the selected rows and/or columns:
+<<subset>>=
+# keep only the first 10 features
+res.subset <- res[1:10,]
+class(res.subset)
+dim(res.subset)
+# keep only the first 10 samples
+dim(res[,1:10])
+# subset both features and samples:
+dim(res[1:20,1:10])
+@
+
+\subsubsection{Extracting metagene-specific features}
+
+In general NMF matrix factors are sparse, so that the metagenes can usually be characterized by a relatively small set of genes. Those are determined based on
+their relative contribution to each metagene.
+
+Kim and Park \cite{KimH2007} defined a procedure to extract the relevant genes for each metagene, based on a gene scoring schema.
+
+The NMF package implements this procedure in methods \code{featureScore} and \code{extractFeature}:
+
+<<single_extract>>=
+# only compute the scores
+s <- featureScore(res)
+summary(s)
+
+# compute the scores and characterize each metagene
+s <- extractFeatures(res)
+str(s)
+@
+
+\subsection{Specifying the algorithm}\label{sec:algo}
+
+\subsubsection{Built-in algorithms}
+The \nmfpack package provides a number of built-in algorithms, that are listed or retrieved by function \code{nmfAlgorithm}.
+Each algorithm is identified by a unique name.
+The following algorithms are currently implemented (cf. \cref{tab:algo} for more details):
+
+<<algo_list>>=
+nmfAlgorithm()
+@
+
+%\begin{tech}
+%Internally, all algorithms are stored in objects that inherit from class
+%\code{NMFStrategy}. This class defines the minimum interface
+%\end{tech}
+
+The algorithm used to compute the NMF is specified in the third argument (\code{method}).
+For example, to use the NMF algorithm from Lee and Seung \cite{Lee2001} based on
+the Frobenius euclidean norm, one make the following call:
+<<algo_lee, cache=TRUE>>=
+# using Lee and Seung's algorithm
+res <- nmf(esGolub, 3, 'lee')
+algorithm(res)
+@
+
+To use the Nonsmooth NMF algorithm from \cite{Pascual-Montano2006}:
+<<algo_ns, cache=TRUE>>=
+# using the Nonsmooth NMF algorithm with parameter theta=0.7
+res <- nmf(esGolub, 3, 'ns', theta=0.7)
+algorithm(res)
+fit(res)
+@
+
+Or to use the PE-NMF algorithm from \cite{Zhang2008}:
+<<algo_pe, cache=TRUE>>=
+# using the PE-NMF algorithm with parameters alpha=0.01, beta=1
+res <- nmf(esGolub, 3, 'pe', alpha=0.01, beta=1)
+res
+@
+
+%\begin{tech}
+%Although the last two calls looks similar these are handled
+%
+%In the case of the nsNMF algorithm, the fitted model is an object of class
+%\code{NMFns} that extends the standard NMF model \code{NMFstd}, as it introduces
+%a smoothing matrix $S$, parametrised by a real number $\theta \in [0,1]$, such
+%that the fitted model is:
+%$$
+%V \approx W S(\theta) H.
+%$$
+%
+%Hence the call to function \code{nmf}, parameter $\theta$ is used to
+%
+%\end{tech}
+
+
+\subsubsection{Custom algorithms}
+The \nmfpack package provides the user the possibility to define his own algorithms, and benefit from all the functionalities available in the NMF framework.
+There are only few contraints on the way the custom algorithm must be defined.
+See the details in \cref{sec:algo_custom}.
+
+\subsection{Specifying the seeding method}\label{sec:seed}
+The seeding method used to compute the starting point for the chosen algorithm can be set via argument \code{seed}.
+Note that if the seeding method is deterministic there is no need to perform multiple run anymore.
+
+\subsubsection{Built-in seeding methods}
+Similarly to the algorithms, the \code{nmfSeed} function can be used to list or retrieve the built-in seeding methods.
+The following seeding methods are currently implemented:
+
+<<seed_list>>=
+nmfSeed()
+@
+
+To use a specific method to seed the computation of a factorization, one simply passes its name to \code{nmf}:
+
+<<seed, cache=TRUE>>=
+res <- nmf(esGolub, 3, seed='nndsvd')
+res
+@
+
+\subsubsection{Numerical seed}\label{sec:numseed}
+Another possibility, useful when comparing methods or reproducing results, is to set the random number generator (RNG) by passing a numerical value in argument \code{seed}.
+This value is used to set the state of the RNG, and the initialization is performed by the built-in seeding method \code{'random'}.
+When the function \code{nmf} exits, the value of the random seed (\code{.Random.seed}) is restored to its original state -- as before the call.
+
+In the case of a single run (i.e. with \code{nrun=1}), the default is to use the current RNG, set with the R core function \code{set.seed}.
+In the case of multiple runs, the computations use RNGstream, as provided by the core RNG ``L'Ecuyer-CMRG" \cite{Lecuyer2002}, which generates multiple independent random streams (one per run).
+This ensures the complete reproducibility of any given set of runs, even when their computation is performed in parallel.
+Since RNGstream requires a 6-length numeric seed, a random one is generated if only a single numeric value is passed to \code{seed}.
+Moreover, single runs can also use RNGstream by passing a 6-length seed.
+
+<<seed_numeric, cache=TRUE>>=
+# single run and single numeric seed
+res <- nmf(esGolub, 3, seed=123456)
+showRNG(res)
+
+# multiple runs and single numeric seed
+res <- nmf(esGolub, 3, seed=123456, nrun=2)
+showRNG(res)
+
+# single run with a 6-length seed
+res <- nmf(esGolub, 3, seed=rep(123456, 6))
+showRNG(res)
+@
+\nbnote{To show the RNG changes happening during the computation use \texttt{.options='v4'} to turn on verbosity at level 4.\\
+In versions prior 0.6, one could specify option \texttt{restore.seed=FALSE} or \texttt{'-r'}, this option is now deprecated.}
+
+\subsubsection{Fixed factorization}
+Yet another option is to completely specify the initial factorization, by passing values for matrices $W$ and $H$:
+<<seed_WH>>=
+# initialize a "constant" factorization based on the target dimension
+init <- nmfModel(3, esGolub, W=0.5, H=0.3)
+head(basis(init))
+
+# fit using this NMF model as a seed
+res <- nmf(esGolub, 3, seed=init)
+@
+
+
+\subsubsection{Custom function}
+The \nmfpack package provides the user the possibility to define his own seeding method, and benefit from all the functionalities available in the NMF framework.
+There are only few contraints on the way the custom seeding method must be defined.
+See the details in \cref{sec:seed_custom}.
+
+\subsection{Multiple runs}
+
+When the seeding method is stochastic, multiple runs are usually required to achieve stability or a resonable result.
+This can be done by setting argument \code{nrun} to the desired value.
+For performance reason we use \code{nrun=5} here, but a typical choice would lies between 100 and 200:
+
+<<algo_multirun, cache=TRUE>>=
+res.multirun <- nmf(esGolub, 3, nrun=5)
+res.multirun
+@
+
+By default, the returned object only contains the best fit over all the runs.
+That is the factorization that achieved the lowest approximation error (i.e. the lowest objective value).
+Even during the computation, only the current best factorization is kept in memory.
+This limits the memory requirement for performing multiple runs, which in turn allows to perform more runs.
+
+The object \code{res.multirun} is of class \code{NMFfitX1} that extends class \code{NMFfit}, the class returned by single NMF runs.
+It can therefore be handled as the result of a single run and benefit from all the methods defined for single run results.
+
+\medskip
+If one is interested in keeping the results from all the runs, one can set the option \code{keep.all=TRUE}:
+
+<<multirun_keep, cache=TRUE>>=
+# explicitly setting the option keep.all to TRUE
+res <- nmf(esGolub, 3, nrun=5, .options=list(keep.all=TRUE))
+res
+@
+
+<<multirun_keep_alt, eval=FALSE>>=
+# or using letter code 'k' in argument .options
+nmf(esGolub, 3, nrun=5, .options='k')
+@
+
+In this case, the result is an object of class \code{NMFfitXn} that also inherits from class \code{list}.
+
+Note that keeping all the results may be memory consuming.
+For example, a 3-rank \code{NMF} fit\footnote{i.e. the result of a single NMF run with rank equal 3.} for the Golub gene expression matrix ($5000 \times 38$) takes about \Sexpr{round(object.size(fit(res.multirun))/1000)}Kb\footnote{This size might change depending on the architecture (32 or 64 bits)}.
+
+\subsection{Parallel computations}\label{multicore}
+
+To speed-up the analysis whenever possible, the \nmfpack package implements transparent parallel computations when run on multi-core machines.
+It uses the \code{foreach} framework developed by REvolution Computing
+\citeCRANpkg{foreach}, together with the related \code{doParallel} parallel
+backend from the \citeCRANpkg{doParallel} -- based on the
+\pkgname{parallel} package -- to make use of all the CPUs available on the
+system, with each core simultaneously performing part of the runs.
+
+\subsubsection{Memory considerations}
+Running multicore computations increases the required memory linearly
+with the number of cores used.
+When only the best run is of interest, memory usage is
+optimized to only keep the current best factorization.
+On non-Windows machine, further speed improvement are achieved by using shared
+memory and mutex objects from the \citeCRANpkg{bigmemory} and the
+\citeCRANpkg{synchronicity}.
+
+\subsubsection{Parallel foreach backends}
+The default parallel backend used by the \code{nmf} function is defined by the
+package specific option \code{'pbackend'}, which defaults to \code{'par'} -- for
+\code{doParallel}.
+The backend can also be set on runtime via argument \code{.pbackend}.
+
+\medskip
+\paragraph{IMPORTANT NOTE:}
+The parallel computation is based on the \pkgname{doParallel} and
+\pkgname{parallel} packages, and the same care should be taken as stated in the
+vignette of the \citeCRANpkg{doMC}:
+\begin{quote}
+\emph{... it usually isn't safe to run doMC and multicore from a GUI environment.
+In particular, it is not safe to use doMC from R.app on Mac OS X.
+Instead, you should use doMC from a terminal session, starting R from the command line.}
+\end{quote}
+Therefore, the \code{nmf} function does not allow to run multicore computation from the
+MacOS X GUI.
+
+From version 0.8, other parallel backends are supported, and may be specified
+via argument \code{.pbackend}:
+
+\begin{description}
+ \item[\code{.pbackend='mpi'}] uses the parallel backend \citeCRANpkg{doParallel} and \citeCRANpkg{doMPI}
+ \item[\code{.pbackend=NULL}]{}
+\end{description}
+
+It is possible to specify that the currently registered backend should be
+used, by setting argument \code{.pbackend=NULL}.
+This allow to perform parallel computations with ``permanent'' backends that are
+configured externally of the \code{nmf} call.
+
+\subsubsection{Runtime options}
+There are two other runtime options, \code{parallel} and
+\code{parallel.required}, that can be passed via argument \code{.options}, to
+control the behaviour of the parallel computation (see below).
+
+\medskip
+A call for multiple runs will be computed in parallel if one of the following condition is satisfied:
+
+\begin{itemize}
+\item call with option \code{'P'} or \code{parallel.required} set to TRUE (note the upper case in \code{'P'}).
+In this case, if for any reason the computation cannot be run in parallel (packages requirements, OS, ...), then an error is thrown. Use this mode to force the parallel execution.
+\item call with option \code{'p'} or \code{parallel} set to TRUE. In this case if something prevents a parallel computation, the factorizations will be done
+sequentially.
+\item a valid parallel backend is specified in argument \code{.pbackend}.
+For the moment it can either be the string \code{'mc'} or a single \code{numeric} value specifying the number of core to use. Unless option \code{'P'} is specified, it will run using option \code{'p'} (i.e. try-parallel mode).
+\end{itemize}
+
+\nbnote{The number of processors to use can also be specified in the runtime options as e.g. \texttt{.options='p4'} or \texttt{.options='P4'} -- to ask or request 4 CPUs.}
+
+\paragraph{Examples}\ \\
+The following exmaples are run with \code{.options='v'} which turn on verbosity at level 1, that will show which parallell setting is used by each computation.
+Although we do not show the output here, the user is recommended to run these commands on his machine to see the internal differences of each call.
+
+<<parallel_multicore_alt, eval=FALSE>>=
+# the default call will try to run in parallel using all the cores
+# => will be in parallel if all the requirements are satisfied
+nmf(esGolub, 3, nrun=5, .opt='v')
+
+# request a certain number of cores to use => no error if not possible
+nmf(esGolub, 3, nrun=5, .opt='vp8')
+
+# force parallel computation: use option 'P'
+nmf(esGolub, 3, nrun=5, .opt='vP')
+
+# require an improbable number of cores => error
+nmf(esGolub, 3, nrun=5, .opt='vP200')
+@
+
+\subsubsection{High Performance Computing on a cluster}
+
+To achieve further speed-up, the computation can be run on an HPC cluster.
+In our tests we used the \citeCRANpkg{doMPI} to perform 100
+factorizations using hybrid parallel computation on 4 quadri-core machines -- making use of all
+the cores computation on each machine.
+
+<<mpi, eval=FALSE>>=
+# file: mpi.R
+
+## 0. Create and register an MPI cluster
+library(doMPI)
+cl <- startMPIcluster()
+registerDoMPI(cl)
+library(NMF)
+
+# run on all workers using the current parallel backend
+data(esGolub)
+res <- nmf(esGolub, 3, 'brunet', nrun=n, .opt='p', .pbackend=NULL)
+
+# save result
+save(res, file='result.RData')
+
+## 4. Shutdown the cluster and quit MPI
+closeCluster(cl)
+mpi.quit()
+
+@
+
+Passing the following shell script to \emph{qsub} should launch the execution on a Sun Grid Engine HPC cluster, with OpenMPI.
+Some adaptation might be necessary for other queueing systems/installations.
+
+\begin{shaded}
+\small
+\begin{verbatim}
+#!/bin/bash
+#$ -cwd
+#$ -q opteron.q
+#$ -pe mpich_4cpu 16
+echo "Got $NSLOTS slots. $TMP/machines"
+
+orterun -v -n $NSLOTS -hostfile $TMP/machines R --slave -f mpi.R
+\end{verbatim}
+\end{shaded}
+
+\subsubsection{Forcing sequential execution}
+When running on a single core machine, \nmfpack package has no other option than performing the multiple runs sequentially, one after another.
+This is done via the \code{sapply} function.
+
+On multi-core machine, one usually wants to perform the runs in parallel, as it speeds up the computation (cf. \cref{multicore}).
+However in some situation (e.g. while debugging), it might be useful to force the sequential execution of the runs.
+This can be done via the option \code{'p1'} to run on a single core , or with
+\code{.pbackend='seq'} to use the foreach backend \code{doSEQ} or to \code{NA} to use a standard \code{sapply} call:
+
+<<force_seq, cache=TRUE, backspace = TRUE>>=
+# parallel execution on 2 cores (if possible)
+res1 <- nmf(esGolub, 3, nrun=5, .opt='vp2', seed=123)
+
+# or use the doParallel with single core
+res2 <- nmf(esGolub, 3, nrun=5, .opt='vp1', seed=123)
+
+# force sequential computation by sapply: use option '-p' or .pbackend=NA
+res3 <- nmf(esGolub, 3, nrun=5, .opt='v-p', seed=123)
+res4 <- nmf(esGolub, 3, nrun=5, .opt='v', .pbackend=NA, seed=123)
+
+# or use the SEQ backend of foreach: .pbackend='seq'
+res5 <- nmf(esGolub, 3, nrun=5, .opt='v', .pbackend='seq', seed=123)
+
+# all results are all identical
+nmf.equal(list(res1, res2, res3, res4, res5))
+@
+
+
+\subsection{Estimating the factorization rank}
+A critical parameter in NMF is the factorization rank $r$.
+It defines the number of metagenes used to approximate the target matrix.
+Given a NMF method and the target matrix, a common way of deciding on $r$ is to try different values, compute some quality measure of the results, and choose the best value according to this quality criteria.
+
+Several approaches have then been proposed to choose the optimal value of $r$.
+For example, \cite{Brunet2004} proposed to take the first value of $r$ for which the cophenetic coefficient starts decreasing, \cite{Hutchins2008} suggested to choose the first value where the RSS curve presents an inflection point, and \cite{Frigyesi2008} considered the smallest value at which the decrease in the RSS is lower than the decrease of the RSS obtained from random data.
+
+The \nmfpack package provides functions to help implement such procedures and plot the relevant quality measures.
+Note that this can be a lengthy computation, depending on the data size.
+Whereas the standard NMF procedure usually involves several hundreds of random initialization, performing 30-50 runs is considered sufficient to get a robust estimate of the factorization rank \cite{Brunet2004, Hutchins2008}.
+For performance reason, we perform here only 10 runs for each value of the rank.
+
+<<estimate_rank, cache=TRUE>>=
+# perform 10 runs for each value of r in range 2:6
+estim.r <- nmf(esGolub, 2:6, nrun=10, seed=123456)
+@
+
+The result is a S3 object of class \code{NMF.rank}, that contains a \code{data.frame} with the quality measures in column, and the values of $r$ in row.
+It also contains a list of the consensus matrix for each value of $r$.
+
+All the measures can be plotted at once with the method \code{plot} (\cref{fig:estim_all}), and the function \code{consensusmap} generates heatmaps of the consensus matrix for each value of the rank.
+In the context of class discovery, it is useful to see if the clusters obtained correspond to known classes.
+This is why in the particular case of the Golub dataset, we added annotation tracks for the two covariates available ('Cell' and 'ALL.AML').
+Since we removed the variable 'Sample' in the preliminaries, these are the only variables in the phenotypic \code{data.frame} embedded within the \code{ExpressionSet} object, and we can simply pass the whole object to argument \code{annCol} (\cref{fig:estim_all_hm}).
+One can see that at rank 2, the clusters correspond to the ALL and AML samples respectively, while rank 3 separates AML from ALL/T-cell and ALL/B-cell\footnote{Remember that the plots shown in \cref{fig:estim_all_hm} come from only 10 runs, using the 200 first genes in the dataset, which explains the somewhat not so clean clusters.
+The results are in fact much cleaner when using the full dataset (\cref{fig:heatmap_consensus}).}.
+
+\begin{figure}
+<<estimate_rank_plot, fig.width=10, fig.height=6>>=
+plot(estim.r)
+@
+\caption{Estimation of the rank: Quality measures computed from 10 runs for each value of $r$. \label{fig:estim_all}}
+\end{figure}
+
+\begin{figure}
+<<estimate_rank_hm_include, fig.width=14, fig.height=7, fig.keep='last'>>=
+consensusmap(estim.r, annCol=esGolub, labCol=NA, labRow=NA)
+@
+\caption{Estimation of the rank: Consensus matrices computed from 10 runs for each value of $r$. \label{fig:estim_all_hm}}
+\end{figure}
+
+\subsubsection{Overfitting}
+Even on random data, increasing the factorization rank would lead to decreasing residuals, as more variables are available to better fit the data.
+In other words, there is potentially an overfitting problem.
+
+In this context, the approach from \cite{Frigyesi2008} may be useful to prevent or detect overfitting as it takes into account the results for unstructured data.
+However it requires to compute the quality measure(s) for the random data.
+The \nmfpack package provides a function that shuffles the original data, by permuting the rows of each column, using each time a different permutation.
+The rank estimation procedure can then be applied to the randomized data, and the ``random'' measures added to the plot for comparison (\cref{fig:estim_all_rd}).
+
+\begin{figure}
+<<estimate_rank_random, cache=TRUE, fig.width=10, fig.height=6, fig.keep='last'>>=
+# shuffle original data
+V.random <- randomize(esGolub)
+# estimate quality measures from the shuffled data (use default NMF algorithm)
+estim.r.random <- nmf(V.random, 2:6, nrun=10, seed=123456)
+# plot measures on same graph
+plot(estim.r, estim.r.random)
+@
+\caption{Estimation of the rank: Comparison of the quality measures with those obtained from randomized data.
+The curves for the actual data are in blue and green, those for the randomized data are in red and pink.
+The estimation is based on Brunet's algorithm.}
+\label{fig:estim_all_rd}
+\end{figure}
+
+\subsection{Comparing algorithms}
+To compare the results from different algorithms, one can pass a list of methods in argument \code{method}.
+To enable a fair comparison, a deterministic seeding method should also be used.
+Here we fix the random seed to 123456.
+
+<<multimethod, cache=TRUE>>=
+# fit a model for several different methods
+res.multi.method <- nmf(esGolub, 3, list('brunet', 'lee', 'ns'), seed=123456, .options='t')
+@
+
+Passing the result to method \code{compare} produces a \code{data.frame} that contains summary measures for each method. Again, prior knowledge of classes may be used to compute clustering quality measures:
+
+<<compare>>=
+compare(res.multi.method)
+
+# If prior knowledge of classes is available
+compare(res.multi.method, class=esGolub$Cell)
+@
+
+Because the computation was performed with error tracking enabled, an error plot
+can be produced by method \code{plot} (\cref{fig:errorplot}).
+Each track is normalized so that its first value equals one, and stops at the iteration where the method's convergence criterion was fulfilled.
+
+\subsection{Visualization methods}
+
+\subsubsection*{Error track}
+
+If the NMF computation is performed with error tracking enabled -- using argument \code{.options} -- the trajectory of the objective value is computed during the fit.
+This computation is not enabled by default as it induces some overhead.
+
+<<errorplot_compute, cache=TRUE>>=
+# run nmf with .option='t'
+res <- nmf(esGolub, 3, .options='t')
+# or with .options=list(track=TRUE)
+@
+
+The trajectory can be plot with the method \code{plot} (\cref{fig:errorplot}):
+\begin{figure}[!htbp]
+<<errorplot, out.width="0.5\\textwidth", fig.show='hold'>>=
+plot(res)
+plot(res.multi.method)
+@
+\caption{Error track for a single NMF run (left) and multiple method
+runs (right)}
+\label{fig:errorplot}
+\end{figure}
+
+\subsubsection*{Heatmaps}
+
+The methods \code{basismap}, \code{coefmap} and \code{consensusmap} provide an
+easy way to visualize respectively the resulting basis matrix (i.e. metagenes),
+mixture coefficient matrix (i.e. metaprofiles) and the consensus matrix, in the
+case of multiple runs.
+It produces pre-configured heatmaps based on the function \code{aheatmap}, the
+underlying heatmap engine provided with the package NMF.
+The default heatmaps produced by these functions are shown in
+\cref{fig:heatmap_coef_basis,fig:heatmap_consensus}.
+They can be customized in many different ways (colours, annotations, labels).
+See the dedicated vignette \emph{``NMF: generating heatmaps"} or the help pages
+\code{?coefmap} and \code{?aheatmap} for more information.
+
+An important and unique feature of the function \code{aheatmap}, is that it
+makes it possible to combine several heatmaps on the same plot, using the both
+standard layout calls \texttt{par(mfrow=...)} and \texttt{layout(...)}, or grid
+viewports from \texttt{grid} graphics.
+The plotting context is automatically internally detected, and a correct
+behaviour is achieved thanks to the \citeCRANpkg{gridBase}.
+Examples are provided in the dedicated vignette mentioned above.
+
+The rows of the basis matrix often carry the high dimensionality of the data: genes, loci, pixels, features, etc\ldots
+The function \code{basismap} extends the use of argument \code{subsetRow} (from \code{aheatmap}) to the specification of a feature selection method.
+In \cref{fig:heatmap_coef_basis} we simply used \code{subsetRow=TRUE}, which subsets the rows using the method described in \cite{KimH2007}, to only keep the basis-specific features (e.g. the metagene-specific genes).
+We refer to the relevant help pages \code{?basismap} and \code{?aheatmap} for more details about other possible values for this argument.
+
+\begin{figure}[!htbp]
+\centering
+<<heatmap_coef_basis_inc, fig.width=14, fig.height=7, fig.keep='last'>>=
+layout(cbind(1,2))
+# basis components
+basismap(res, subsetRow=TRUE)
+# mixture coefficients
+coefmap(res)
+@
+\caption{Heatmap of the basis and the mixture coefficient matrices. The rows of the basis matrix were selected using the default feature selection method -- described in \cite{KimH2007}.}
+\label{fig:heatmap_coef_basis}
+\end{figure}
+
+In the case of multiple runs the function \code{consensusmap} plots the consensus matrix, i.e. the average connectivity matrix across the runs (see results in \cref{fig:heatmap_consensus} for a consensus matrix obtained with 100 runs of Brunet's algorithm on the complete
+Golub dataset):
+
+\begin{figure}[ht]
+<<heatmap_consensus_inc, out.width="0.49\\textwidth", crop=TRUE, echo=1:2>>=
+# The cell type is used to label rows and columns
+consensusmap(res.multirun, annCol=esGolub, tracks=NA)
+plot(1:10)
+f2 <- fig_path("2.pdf")
+@
+<<hack_consensus, include=FALSE>>=
+file.copy('consensus.pdf', f2, overwrite=TRUE)
+@
+\caption{Heatmap of consensus matrices from 10 runs on the reduced dataset
+(left) and from 100 runs on the complete Golub dataset (right).}
+\label{fig:heatmap_consensus}
+\end{figure}
+
+\section{Extending the package}
+
+We developed the \nmfpack\ package with the objective to facilitate the integration of new NMF methods, trying to impose only few requirements on their implementations.
+All the built-in algorithms and seeding methods are implemented as strategies that are called from within the main interface method \code{nmf}.
+
+The user can define new strategies and those are handled in exactly the same way as the built-in ones, benefiting from the same utility functions to interpret the
+results and assess their performance.
+
+\subsection{Custom algorithm}
+%New NMF algrithms can be defined in two ways:
+%
+%\begin{itemize}
+%\item as a single \code{function}
+%\item as a set of functions that implement a pre-defined \emph{iterative schema}
+%\end{itemize}
+%
+%\subsubsection{Defined as a \code{function}}
+
+\subsubsection{Using a custom algorithm}\label{sec:algo_custom}
+To define a strategy, the user needs to provide a \code{function} that implements the complete algotihm. It must be of the form:
+
+<<custom_algo_sig>>=
+my.algorithm <- function(x, seed, param.1, param.2){
+ # do something with starting point
+ # ...
+
+ # return updated starting point
+ return(seed)
+}
+@
+Where:
+
+\begin{description}
+\item[target] is a \code{matrix};
+\item[start] is an object that inherits from class \code{NMF}.
+This \code{S4} class is used to handle NMF models (matrices \code{W} and \code{H}, objective function, etc\dots);
+\item[param.1, param.2] are extra parameters specific to the algorithms;
+\end{description}
+
+The function must return an object that inherits from class \code{NMF}.
+
+For example:
+<<custom_algo>>=
+my.algorithm <- function(x, seed, scale.factor=1){
+ # do something with starting point
+ # ...
+ # for example:
+ # 1. compute principal components
+ pca <- prcomp(t(x), retx=TRUE)
+
+ # 2. use the absolute values of the first PCs for the metagenes
+ # Note: the factorization rank is stored in object 'start'
+ factorization.rank <- nbasis(seed)
+ basis(seed) <- abs(pca$rotation[,1:factorization.rank])
+ # use the rotated matrix to get the mixture coefficient
+ # use a scaling factor (just to illustrate the use of extra parameters)
+ coef(seed) <- t(abs(pca$x[,1:factorization.rank])) / scale.factor
+
+ # return updated data
+ return(seed)
+}
+@
+
+To use the new method within the package framework, one pass \code{my.algorithm} to main interface \code{nmf} via argument \code{method}.
+Here we apply the algorithm to some matrix \code{V} randomly generated:
+
+<<define_V>>=
+n <- 50; r <- 3; p <- 20
+V <-syntheticNMF(n, r, p)
+@
+
+<<custom_algo_run>>=
+nmf(V, 3, my.algorithm, scale.factor=10)
+@
+
+\subsubsection{Using a custom distance measure}
+The default distance measure is based on the euclidean distance.
+If the algorithm is based on another distance measure, this one can be specified in argument \code{objective}, either as a \code{character} string corresponding to a built-in objective function, or a custom \code{function} definition\footnote{Note that from version 0.8, the arguments for custom objective functions have been swapped: (1) the current NMF model, (2) the target matrix}:
+
+<<custom_algo_run_obj>>=
+# based on Kullback-Leibler divergence
+nmf(V, 3, my.algorithm, scale.factor=10, objective='KL')
+# based on custom distance metric
+nmf(V, 3, my.algorithm, scale.factor=10
+ , objective=function(model, target, ...){
+ ( sum( (target-fitted(model))^4 ) )^{1/4}
+ }
+)
+@
+
+%\subsubsection{Using the iterative schema}
+%
+%NMF algorithms generally implement the following common iterative schema:
+%
+%\begin{enumerate}
+%\item
+%\item
+%\end{enumerate}
+
+\subsubsection{Defining algorithms for mixed sign data}
+All the algorithms implemented in the \nmfpack package assume that the input data is nonnegative.
+However, some methods exist in the litterature that work with relaxed constraints, where the input data and one of the matrix factors ($W$ or $H$) are allowed to have negative entries (eg. semi-NMF \cite{Ding2010, Roux2008}).
+Strictly speaking these methods do not fall into the NMF category, but still solve constrained matrix factorization problems, and could be considered as NMF methods when applied to non-negative data.
+Moreover, we received user requests to enable the development of semi-NMF type methods within the package's framework.
+Therefore, we designed the \nmfpack package so that such algorithms -- that handle negative data -- can be integrated. This section documents how to do it.
+
+By default, as a safe-guard, the sign of the input data is checked before running any method, so that the \code{nmf} function throws an error if applied to data that contain negative entries \footnote{Note that on the other side, the sign of the factors returned by the algorithms is never checked, so that one can always return factors with negative entries.}.
+To extend the capabilities of the \nmfpack package in handling negative data, and plug mixed sign NMF methods into the framework, the user needs to specify the argument \code{mixed=TRUE} in the call to the \code{nmf} function.
+This will skip the sign check of the input data and let the custom algorithm perform the factorization.
+
+As an example, we reuse the previously defined custom algorithm\footnote{As it is defined here, the custom algorithm still returns nonnegative factors, which would not be desirable in a real example, as one would not be able to closely fit the negative entries.}:
+
+<<custom_algo_run_mixed, error = TRUE, try = TRUE>>=
+# put some negative input data
+V.neg <- V; V.neg[1,] <- -1;
+
+# this generates an error
+try( nmf(V.neg, 3, my.algorithm, scale.factor=10) )
+
+# this runs my.algorithm without error
+nmf(V.neg, 3, my.algorithm, mixed=TRUE, scale.factor=10)
+@
+
+\subsubsection{Specifying the NMF model}
+If not specified in the call, the NMF model that is used is the standard one, as defined in \cref{NMFstd}.
+However, some NMF algorithms have different underlying models, such as non-smooth NMF \cite{Pascual-Montano2006} which uses an extra matrix factor that introduces an extra parameter, and change the way the target matrix is approximated.
+
+The NMF models are defined as S4 classes that extends class \code{NMF}. All the available models can be retreived calling the \code{nmfModel()} function with no
+argument:
+
+<<nmf_models>>=
+nmfModel()
+@
+
+One can specify the NMF model to use with a custom algorithm, using argument \code{model}. Here we first adapt a bit the custom algorithm, to justify and illustrate the use of a different model.
+We use model \code{NMFOffset} \cite{Badea2008}, that includes an offset to take into account genes that have constant expression levels accross the samples:
+
+<<custom_algo_NMFoffset>>=
+my.algorithm.offset <- function(x, seed, scale.factor=1){
+ # do something with starting point
+ # ...
+ # for example:
+ # 1. compute principal components
+ pca <- prcomp(t(x), retx=TRUE)
+
+ # retrieve the model being estimated
+ data.model <- fit(seed)
+
+ # 2. use the absolute values of the first PCs for the metagenes
+ # Note: the factorization rank is stored in object 'start'
+ factorization.rank <- nbasis(data.model)
+ basis(data.model) <- abs(pca$rotation[,1:factorization.rank])
+ # use the rotated matrix to get the mixture coefficient
+ # use a scaling factor (just to illustrate the use of extra parameters)
+ coef(data.model) <- t(abs(pca$x[,1:factorization.rank])) / scale.factor
+
+ # 3. Compute the offset as the mean expression
+ data.model at offset <- rowMeans(x)
+
+ # return updated data
+ fit(seed) <- data.model
+ seed
+}
+@
+
+Then run the algorithm specifying it needs model \code{NMFOffset}:
+<<custom_algo_NMFOffset_run>>=
+# run custom algorithm with NMF model with offset
+nmf(V, 3, my.algorithm.offset, model='NMFOffset', scale.factor=10)
+@
+
+
+\subsection{Custom seeding method}\label{sec:seed_custom}
+
+The user can also define custom seeding method as a function of the form:
+
+
+<<custom_seed>>=
+
+# start: object of class NMF
+# target: the target matrix
+my.seeding.method <- function(model, target){
+
+ # use only the largest columns for W
+ w.cols <- apply(target, 2, function(x) sqrt(sum(x^2)))
+ basis(model) <- target[,order(w.cols)[1:nbasis(model)]]
+
+ # initialize H randomly
+ coef(model) <- matrix(runif(nbasis(model)*ncol(target))
+ , nbasis(model), ncol(target))
+
+ # return updated object
+ return(model)
+}
+@
+
+To use the new seeding method:
+<<custom_seed_run>>=
+nmf(V, 3, 'snmf/r', seed=my.seeding.method)
+@
+
+\section{Advanced usage}
+
+\subsection{Package specific options}
+The package specific options can be retieved or changed using the \code{nmf.getOption} and \code{nmf.options} functions.
+These behave similarly as the \code{getOption} and \code{nmf.options} base functions:
+
+<<options_algo, eval=1:6>>=
+#show default algorithm and seeding method
+nmf.options('default.algorithm', 'default.seed')
+
+# retrieve a single option
+nmf.getOption('default.seed')
+
+# All options
+nmf.options()
+@
+
+Currently the following options are available:
+
+<<nmf_options, echo=FALSE, results='asis'>>=
+RdSection2latex('nmf.options', package='NMF')
+@
+
+The default/current values of each options can be displayed using the function
+\code{nmf.printOptions}:
+
+<<print_options>>=
+nmf.printOptions()
+@
+
+%% latex table generated in R 2.10.1 by xtable 1.5-6 package
+%% Wed Apr 7 15:27:05 2010
+%\begin{table}[ht]
+%\begin{center}
+%\begin{tabularx}{\textwidth}{>{\ttfamily}rlX}
+% \hline
+%Option & Default value & Description\\
+%\hline
+%default.algorithm & brunet & Default NMF algorithm used by the \code{nmf} function when argument \code{method} is missing.
+%The value should the key of one of the available NMF algorithms.
+%See \code{?nmfAlgorithm}.\\
+%track.interval & 30 & Number of iterations between two points in the residual track.
+%This option is relevant only when residual tracking is enabled.
+%See \code{?nmf}.\\
+%error.track & FALSE & Toggle default residual tracking.
+%When \code{TRUE}, the \code{nmf} function compute and store the residual track in the result -- if not otherwise specified in argument \code{.options}.
+%Note that tracking may significantly slow down the computations.\\
+%default.seed & random & Default seeding method used by the \code{nmf} function when argument \code{seed} is missing.
+%The value should the key of one of the available seeding methods.
+%See \code{?nmfSeed}.\\
+%backend & mc & Default parallel backend used used by the \code{nmf} function when argument \code{.pbackend} is missing.
+%Currently the following values are supported: \code{'mc'} for multicore, \code{'seq'} for sequential, \code{''} for \code{sapply}.\\
+%verbose & FALSE & Toggle verbosity.\\
+%debug & FALSE & Toggle debug mode, which is an extended verbose mode.\\
+%\hline
+%\end{tabularx}
+%\end{center}
+%\caption{}
+%\end{table}
+
+\pagebreak
+\section{Session Info}
+<<sessionInfo, echo=FALSE, results='asis'>>=
+toLatex(sessionInfo())
+@
+
+\printbibliography[heading=bibintoc]
+
+\end{document}
+
diff --git a/vignettes/consensus.pdf b/vignettes/consensus.pdf
new file mode 100644
index 0000000..9f65ab0
--- /dev/null
+++ b/vignettes/consensus.pdf
@@ -0,0 +1,2745 @@
+%PDF-1.4
+%���ρ�\r
+1 0 obj
+<<
+/CreationDate (D:20111003210125)
+/ModDate (D:20111003210125)
+/Title (R Graphics Output)
+/Producer (R 2.13.1)
+/Creator (R)
+>>
+endobj
+2 0 obj
+<<
+/Type /Catalog
+/Pages 3 0 R
+>>
+endobj
+7 0 obj
+<<
+/Type /Page
+/Parent 3 0 R
+/Contents 8 0 R
+/Resources 4 0 R
+>>
+endobj
+8 0 obj
+<<
+/Length 9 0 R
+>>
+stream
+1 J 1 j q
+Q q
+Q q
+Q q
+Q q 54.99 425.88 326.74 49.49 re W n
+/sRGB CS 0.000 0.000 0.000 SCN
+0.75 w
+[] 0 d
+1 J
+1 j
+10.00 M
+132.36 475.37 m 67.85 475.37 l S
+67.85 475.37 m 67.85 425.88 l S
+67.85 425.88 m 59.29 425.88 l S
+59.29 425.88 m 59.29 425.88 l S
+67.85 425.88 m 76.42 425.88 l S
+76.42 425.88 m 76.42 425.88 l S
+76.42 425.88 m 67.88 425.88 l S
+67.88 425.88 m 67.88 425.88 l S
+76.42 425.88 m 84.95 425.88 l S
+84.95 425.88 m 84.95 425.88 l S
+84.95 425.88 m 76.48 425.88 l S
+76.48 425.88 m 76.48 425.88 l S
+84.95 425.88 m 93.41 425.88 l S
+93.41 425.88 m 93.41 425.88 l S
+93.41 425.88 m 85.08 425.88 l S
+85.08 425.88 m 85.08 425.88 l S
+93.41 425.88 m 101.74 425.88 l S
+101.74 425.88 m 101.74 425.88 l S
+101.74 425.88 m 93.68 425.88 l S
+93.68 425.88 m 93.68 425.88 l S
+101.74 425.88 m 109.80 425.88 l S
+109.80 425.88 m 109.80 425.88 l S
+109.80 425.88 m 102.28 425.88 l S
+102.28 425.88 m 102.28 425.88 l S
+109.80 425.88 m 117.33 425.88 l S
+117.33 425.88 m 117.33 425.88 l S
+117.33 425.88 m 110.88 425.88 l S
+110.88 425.88 m 110.88 425.88 l S
+117.33 425.88 m 123.77 425.88 l S
+123.77 425.88 m 123.77 425.88 l S
+123.77 425.88 m 119.48 425.88 l S
+119.48 425.88 m 119.48 425.88 l S
+123.77 425.88 m 128.07 425.88 l S
+128.07 425.88 m 128.07 425.88 l S
+132.36 475.37 m 196.86 475.37 l S
+196.86 475.37 m 196.86 474.08 l S
+196.86 474.08 m 145.27 474.08 l S
+145.27 474.08 m 145.27 440.73 l S
+145.27 440.73 m 136.67 440.73 l S
+136.67 440.73 m 136.67 425.88 l S
+145.27 440.73 m 153.86 440.73 l S
+153.86 440.73 m 153.86 425.88 l S
+153.86 425.88 m 145.27 425.88 l S
+145.27 425.88 m 145.27 425.88 l S
+153.86 425.88 m 162.45 425.88 l S
+162.45 425.88 m 162.45 425.88 l S
+162.45 425.88 m 153.87 425.88 l S
+153.87 425.88 m 153.87 425.88 l S
+162.45 425.88 m 171.03 425.88 l S
+171.03 425.88 m 171.03 425.88 l S
+171.03 425.88 m 162.47 425.88 l S
+162.47 425.88 m 162.47 425.88 l S
+171.03 425.88 m 179.60 425.88 l S
+179.60 425.88 m 179.60 425.88 l S
+179.60 425.88 m 171.07 425.88 l S
+171.07 425.88 m 171.07 425.88 l S
+179.60 425.88 m 188.13 425.88 l S
+188.13 425.88 m 188.13 425.88 l S
+188.13 425.88 m 179.66 425.88 l S
+179.66 425.88 m 179.66 425.88 l S
+188.13 425.88 m 196.59 425.88 l S
+196.59 425.88 m 196.59 425.88 l S
+196.59 425.88 m 188.26 425.88 l S
+188.26 425.88 m 188.26 425.88 l S
+196.59 425.88 m 204.92 425.88 l S
+204.92 425.88 m 204.92 425.88 l S
+204.92 425.88 m 196.86 425.88 l S
+196.86 425.88 m 196.86 425.88 l S
+204.92 425.88 m 212.98 425.88 l S
+212.98 425.88 m 212.98 425.88 l S
+212.98 425.88 m 205.46 425.88 l S
+205.46 425.88 m 205.46 425.88 l S
+212.98 425.88 m 220.51 425.88 l S
+220.51 425.88 m 220.51 425.88 l S
+220.51 425.88 m 214.06 425.88 l S
+214.06 425.88 m 214.06 425.88 l S
+220.51 425.88 m 226.96 425.88 l S
+226.96 425.88 m 226.96 425.88 l S
+226.96 425.88 m 222.66 425.88 l S
+222.66 425.88 m 222.66 425.88 l S
+226.96 425.88 m 231.26 425.88 l S
+231.26 425.88 m 231.26 425.88 l S
+196.86 474.08 m 248.45 474.08 l S
+248.45 474.08 m 248.45 426.87 l S
+248.45 426.87 m 239.85 426.87 l S
+239.85 426.87 m 239.85 425.88 l S
+248.45 426.87 m 257.05 426.87 l S
+257.05 426.87 m 257.05 425.88 l S
+257.05 425.88 m 248.45 425.88 l S
+248.45 425.88 m 248.45 425.88 l S
+257.05 425.88 m 265.65 425.88 l S
+265.65 425.88 m 265.65 425.88 l S
+265.65 425.88 m 257.05 425.88 l S
+257.05 425.88 m 257.05 425.88 l S
+265.65 425.88 m 274.25 425.88 l S
+274.25 425.88 m 274.25 425.88 l S
+274.25 425.88 m 265.65 425.88 l S
+265.65 425.88 m 265.65 425.88 l S
+274.25 425.88 m 282.84 425.88 l S
+282.84 425.88 m 282.84 425.88 l S
+282.84 425.88 m 274.25 425.88 l S
+274.25 425.88 m 274.25 425.88 l S
+282.84 425.88 m 291.44 425.88 l S
+291.44 425.88 m 291.44 425.88 l S
+291.44 425.88 m 282.85 425.88 l S
+282.85 425.88 m 282.85 425.88 l S
+291.44 425.88 m 300.04 425.88 l S
+300.04 425.88 m 300.04 425.88 l S
+300.04 425.88 m 291.45 425.88 l S
+291.45 425.88 m 291.45 425.88 l S
+300.04 425.88 m 308.63 425.88 l S
+308.63 425.88 m 308.63 425.88 l S
+308.63 425.88 m 300.04 425.88 l S
+300.04 425.88 m 300.04 425.88 l S
+308.63 425.88 m 317.21 425.88 l S
+317.21 425.88 m 317.21 425.88 l S
+317.21 425.88 m 308.64 425.88 l S
+308.64 425.88 m 308.64 425.88 l S
+317.21 425.88 m 325.77 425.88 l S
+325.77 425.88 m 325.77 425.88 l S
+325.77 425.88 m 317.24 425.88 l S
+317.24 425.88 m 317.24 425.88 l S
+325.77 425.88 m 334.30 425.88 l S
+334.30 425.88 m 334.30 425.88 l S
+334.30 425.88 m 325.84 425.88 l S
+325.84 425.88 m 325.84 425.88 l S
+334.30 425.88 m 342.77 425.88 l S
+342.77 425.88 m 342.77 425.88 l S
+342.77 425.88 m 334.44 425.88 l S
+334.44 425.88 m 334.44 425.88 l S
+342.77 425.88 m 351.10 425.88 l S
+351.10 425.88 m 351.10 425.88 l S
+351.10 425.88 m 343.04 425.88 l S
+343.04 425.88 m 343.04 425.88 l S
+351.10 425.88 m 359.16 425.88 l S
+359.16 425.88 m 359.16 425.88 l S
+359.16 425.88 m 351.63 425.88 l S
+351.63 425.88 m 351.63 425.88 l S
+359.16 425.88 m 366.68 425.88 l S
+366.68 425.88 m 366.68 425.88 l S
+366.68 425.88 m 360.23 425.88 l S
+360.23 425.88 m 360.23 425.88 l S
+366.68 425.88 m 373.13 425.88 l S
+373.13 425.88 m 373.13 425.88 l S
+373.13 425.88 m 368.83 425.88 l S
+368.83 425.88 m 368.83 425.88 l S
+373.13 425.88 m 377.43 425.88 l S
+377.43 425.88 m 377.43 425.88 l S
+Q q
+Q q
+Q q
+Q q
+Q q 0.00 19.81 49.49 378.55 re W n
+/sRGB CS 0.000 0.000 0.000 SCN
+0.75 w
+[] 0 d
+1 J
+1 j
+10.00 M
+0.00 308.72 m 0.00 233.99 l S
+0.00 233.99 m 1.30 233.99 l S
+1.30 233.99 m 1.30 174.22 l S
+1.30 174.22 m 48.50 174.22 l S
+48.50 174.22 m 48.50 164.26 l S
+48.50 164.26 m 49.49 164.26 l S
+49.49 164.26 m 49.49 154.29 l S
+49.49 154.29 m 49.49 154.29 l S
+49.49 154.29 m 49.49 144.33 l S
+49.49 144.33 m 49.49 144.33 l S
+49.49 144.33 m 49.49 134.37 l S
+49.49 134.37 m 49.49 134.37 l S
+49.49 134.37 m 49.49 124.41 l S
+49.49 124.41 m 49.49 124.41 l S
+49.49 124.41 m 49.49 114.46 l S
+49.49 114.46 m 49.49 114.46 l S
+49.49 114.46 m 49.49 104.50 l S
+49.49 104.50 m 49.49 104.50 l S
+49.49 104.50 m 49.49 94.56 l S
+49.49 94.56 m 49.49 94.56 l S
+49.49 94.56 m 49.49 84.64 l S
+49.49 84.64 m 49.49 84.64 l S
+49.49 84.64 m 49.49 74.75 l S
+49.49 74.75 m 49.49 74.75 l S
+49.49 74.75 m 49.49 64.95 l S
+49.49 64.95 m 49.49 64.95 l S
+49.49 64.95 m 49.49 55.30 l S
+49.49 55.30 m 49.49 55.30 l S
+49.49 55.30 m 49.49 45.96 l S
+49.49 45.96 m 49.49 45.96 l S
+49.49 45.96 m 49.49 37.24 l S
+49.49 37.24 m 49.49 37.24 l S
+49.49 37.24 m 49.49 29.77 l S
+49.49 29.77 m 49.49 29.77 l S
+49.49 29.77 m 49.49 24.79 l S
+49.49 24.79 m 49.49 24.79 l S
+49.49 29.77 m 49.49 34.75 l S
+49.49 34.75 m 49.49 34.75 l S
+49.49 37.24 m 49.49 44.71 l S
+49.49 44.71 m 49.49 44.71 l S
+49.49 45.96 m 49.49 54.67 l S
+49.49 54.67 m 49.49 54.67 l S
+49.49 55.30 m 49.49 64.64 l S
+49.49 64.64 m 49.49 64.64 l S
+49.49 64.95 m 49.49 74.60 l S
+49.49 74.60 m 49.49 74.60 l S
+49.49 74.75 m 49.49 84.56 l S
+49.49 84.56 m 49.49 84.56 l S
+49.49 84.64 m 49.49 94.52 l S
+49.49 94.52 m 49.49 94.52 l S
+49.49 94.56 m 49.49 104.48 l S
+49.49 104.48 m 49.49 104.48 l S
+49.49 104.50 m 49.49 114.45 l S
+49.49 114.45 m 49.49 114.45 l S
+49.49 114.46 m 49.49 124.41 l S
+49.49 124.41 m 49.49 124.41 l S
+49.49 124.41 m 49.49 134.37 l S
+49.49 134.37 m 49.49 134.37 l S
+49.49 134.37 m 49.49 144.33 l S
+49.49 144.33 m 49.49 144.33 l S
+49.49 144.33 m 49.49 154.29 l S
+49.49 154.29 m 49.49 154.29 l S
+49.49 154.29 m 49.49 164.26 l S
+49.49 164.26 m 49.49 164.26 l S
+49.49 164.26 m 49.49 174.22 l S
+49.49 174.22 m 49.49 174.22 l S
+48.50 174.22 m 48.50 184.18 l S
+48.50 184.18 m 49.49 184.18 l S
+1.30 233.99 m 1.30 293.77 l S
+1.30 293.77 m 34.64 293.77 l S
+34.64 293.77 m 34.64 283.81 l S
+34.64 283.81 m 49.49 283.81 l S
+49.49 283.81 m 49.49 273.86 l S
+49.49 273.86 m 49.49 273.86 l S
+49.49 273.86 m 49.49 263.91 l S
+49.49 263.91 m 49.49 263.91 l S
+49.49 263.91 m 49.49 253.99 l S
+49.49 253.99 m 49.49 253.99 l S
+49.49 253.99 m 49.49 244.11 l S
+49.49 244.11 m 49.49 244.11 l S
+49.49 244.11 m 49.49 234.30 l S
+49.49 234.30 m 49.49 234.30 l S
+49.49 234.30 m 49.49 224.65 l S
+49.49 224.65 m 49.49 224.65 l S
+49.49 224.65 m 49.49 215.31 l S
+49.49 215.31 m 49.49 215.31 l S
+49.49 215.31 m 49.49 206.59 l S
+49.49 206.59 m 49.49 206.59 l S
+49.49 206.59 m 49.49 199.12 l S
+49.49 199.12 m 49.49 199.12 l S
+49.49 199.12 m 49.49 194.14 l S
+49.49 194.14 m 49.49 194.14 l S
+49.49 199.12 m 49.49 204.10 l S
+49.49 204.10 m 49.49 204.10 l S
+49.49 206.59 m 49.49 214.07 l S
+49.49 214.07 m 49.49 214.07 l S
+49.49 215.31 m 49.49 224.03 l S
+49.49 224.03 m 49.49 224.03 l S
+49.49 224.65 m 49.49 233.99 l S
+49.49 233.99 m 49.49 233.99 l S
+49.49 234.30 m 49.49 243.95 l S
+49.49 243.95 m 49.49 243.95 l S
+49.49 244.11 m 49.49 253.91 l S
+49.49 253.91 m 49.49 253.91 l S
+49.49 253.99 m 49.49 263.88 l S
+49.49 263.88 m 49.49 263.88 l S
+49.49 263.91 m 49.49 273.84 l S
+49.49 273.84 m 49.49 273.84 l S
+49.49 273.86 m 49.49 283.80 l S
+49.49 283.80 m 49.49 283.80 l S
+49.49 283.81 m 49.49 293.76 l S
+49.49 293.76 m 49.49 293.76 l S
+34.64 293.77 m 34.64 303.72 l S
+34.64 303.72 m 49.49 303.72 l S
+0.00 308.72 m 0.00 383.46 l S
+0.00 383.46 m 49.49 383.46 l S
+49.49 383.46 m 49.49 373.53 l S
+49.49 373.53 m 49.49 373.53 l S
+49.49 373.53 m 49.49 363.65 l S
+49.49 363.65 m 49.49 363.65 l S
+49.49 363.65 m 49.49 353.84 l S
+49.49 353.84 m 49.49 353.84 l S
+49.49 353.84 m 49.49 344.19 l S
+49.49 344.19 m 49.49 344.19 l S
+49.49 344.19 m 49.49 334.85 l S
+49.49 334.85 m 49.49 334.85 l S
+49.49 334.85 m 49.49 326.14 l S
+49.49 326.14 m 49.49 326.14 l S
+49.49 326.14 m 49.49 318.67 l S
+49.49 318.67 m 49.49 318.67 l S
+49.49 318.67 m 49.49 313.68 l S
+49.49 313.68 m 49.49 313.68 l S
+49.49 318.67 m 49.49 323.65 l S
+49.49 323.65 m 49.49 323.65 l S
+49.49 326.14 m 49.49 333.61 l S
+49.49 333.61 m 49.49 333.61 l S
+49.49 334.85 m 49.49 343.57 l S
+49.49 343.57 m 49.49 343.57 l S
+49.49 344.19 m 49.49 353.53 l S
+49.49 353.53 m 49.49 353.53 l S
+49.49 353.84 m 49.49 363.49 l S
+49.49 363.49 m 49.49 363.49 l S
+49.49 363.65 m 49.49 373.46 l S
+49.49 373.46 m 49.49 373.46 l S
+49.49 373.53 m 49.49 383.42 l S
+49.49 383.42 m 49.49 383.42 l S
+49.49 383.46 m 49.49 393.38 l S
+49.49 393.38 m 49.49 393.38 l S
+Q q
+Q q
+Q q
+/sRGB cs 0.192 0.212 0.584 scn
+55.00 19.79 8.60 9.96 re f
+55.00 29.75 8.60 9.96 re f
+55.00 39.71 8.60 9.96 re f
+55.00 49.67 8.60 9.96 re f
+55.00 59.64 8.60 9.96 re f
+55.00 69.60 8.60 9.96 re f
+55.00 79.56 8.60 9.96 re f
+55.00 89.53 8.60 9.96 re f
+55.00 99.49 8.60 9.96 re f
+55.00 109.45 8.60 9.96 re f
+55.00 119.42 8.60 9.96 re f
+55.00 129.38 8.60 9.96 re f
+55.00 139.34 8.60 9.96 re f
+55.00 149.31 8.60 9.96 re f
+55.00 159.27 8.60 9.96 re f
+55.00 169.23 8.60 9.96 re f
+55.00 179.20 8.60 9.96 re f
+55.00 189.16 8.60 9.96 re f
+55.00 199.12 8.60 9.96 re f
+55.00 209.08 8.60 9.96 re f
+55.00 219.05 8.60 9.96 re f
+55.00 229.01 8.60 9.96 re f
+55.00 238.97 8.60 9.96 re f
+55.00 248.94 8.60 9.96 re f
+55.00 258.90 8.60 9.96 re f
+55.00 268.86 8.60 9.96 re f
+55.00 278.83 8.60 9.96 re f
+55.00 288.79 8.60 9.96 re f
+55.00 298.75 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+55.00 308.72 8.60 9.96 re f
+55.00 318.68 8.60 9.96 re f
+55.00 328.64 8.60 9.96 re f
+55.00 338.61 8.60 9.96 re f
+55.00 348.57 8.60 9.96 re f
+55.00 358.53 8.60 9.96 re f
+55.00 368.49 8.60 9.96 re f
+55.00 378.46 8.60 9.96 re f
+55.00 388.42 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+63.60 19.79 8.60 9.96 re f
+63.60 29.75 8.60 9.96 re f
+63.60 39.71 8.60 9.96 re f
+63.60 49.67 8.60 9.96 re f
+63.60 59.64 8.60 9.96 re f
+63.60 69.60 8.60 9.96 re f
+63.60 79.56 8.60 9.96 re f
+63.60 89.53 8.60 9.96 re f
+63.60 99.49 8.60 9.96 re f
+63.60 109.45 8.60 9.96 re f
+63.60 119.42 8.60 9.96 re f
+63.60 129.38 8.60 9.96 re f
+63.60 139.34 8.60 9.96 re f
+63.60 149.31 8.60 9.96 re f
+63.60 159.27 8.60 9.96 re f
+63.60 169.23 8.60 9.96 re f
+63.60 179.20 8.60 9.96 re f
+63.60 189.16 8.60 9.96 re f
+63.60 199.12 8.60 9.96 re f
+63.60 209.08 8.60 9.96 re f
+63.60 219.05 8.60 9.96 re f
+63.60 229.01 8.60 9.96 re f
+63.60 238.97 8.60 9.96 re f
+63.60 248.94 8.60 9.96 re f
+63.60 258.90 8.60 9.96 re f
+63.60 268.86 8.60 9.96 re f
+63.60 278.83 8.60 9.96 re f
+63.60 288.79 8.60 9.96 re f
+63.60 298.75 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+63.60 308.72 8.60 9.96 re f
+63.60 318.68 8.60 9.96 re f
+63.60 328.64 8.60 9.96 re f
+63.60 338.61 8.60 9.96 re f
+63.60 348.57 8.60 9.96 re f
+63.60 358.53 8.60 9.96 re f
+63.60 368.49 8.60 9.96 re f
+63.60 378.46 8.60 9.96 re f
+63.60 388.42 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+72.20 19.79 8.60 9.96 re f
+72.20 29.75 8.60 9.96 re f
+72.20 39.71 8.60 9.96 re f
+72.20 49.67 8.60 9.96 re f
+72.20 59.64 8.60 9.96 re f
+72.20 69.60 8.60 9.96 re f
+72.20 79.56 8.60 9.96 re f
+72.20 89.53 8.60 9.96 re f
+72.20 99.49 8.60 9.96 re f
+72.20 109.45 8.60 9.96 re f
+72.20 119.42 8.60 9.96 re f
+72.20 129.38 8.60 9.96 re f
+72.20 139.34 8.60 9.96 re f
+72.20 149.31 8.60 9.96 re f
+72.20 159.27 8.60 9.96 re f
+72.20 169.23 8.60 9.96 re f
+72.20 179.20 8.60 9.96 re f
+72.20 189.16 8.60 9.96 re f
+72.20 199.12 8.60 9.96 re f
+72.20 209.08 8.60 9.96 re f
+72.20 219.05 8.60 9.96 re f
+72.20 229.01 8.60 9.96 re f
+72.20 238.97 8.60 9.96 re f
+72.20 248.94 8.60 9.96 re f
+72.20 258.90 8.60 9.96 re f
+72.20 268.86 8.60 9.96 re f
+72.20 278.83 8.60 9.96 re f
+72.20 288.79 8.60 9.96 re f
+72.20 298.75 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+72.20 308.72 8.60 9.96 re f
+72.20 318.68 8.60 9.96 re f
+72.20 328.64 8.60 9.96 re f
+72.20 338.61 8.60 9.96 re f
+72.20 348.57 8.60 9.96 re f
+72.20 358.53 8.60 9.96 re f
+72.20 368.49 8.60 9.96 re f
+72.20 378.46 8.60 9.96 re f
+72.20 388.42 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+80.79 19.79 8.60 9.96 re f
+80.79 29.75 8.60 9.96 re f
+80.79 39.71 8.60 9.96 re f
+80.79 49.67 8.60 9.96 re f
+80.79 59.64 8.60 9.96 re f
+80.79 69.60 8.60 9.96 re f
+80.79 79.56 8.60 9.96 re f
+80.79 89.53 8.60 9.96 re f
+80.79 99.49 8.60 9.96 re f
+80.79 109.45 8.60 9.96 re f
+80.79 119.42 8.60 9.96 re f
+80.79 129.38 8.60 9.96 re f
+80.79 139.34 8.60 9.96 re f
+80.79 149.31 8.60 9.96 re f
+80.79 159.27 8.60 9.96 re f
+80.79 169.23 8.60 9.96 re f
+80.79 179.20 8.60 9.96 re f
+80.79 189.16 8.60 9.96 re f
+80.79 199.12 8.60 9.96 re f
+80.79 209.08 8.60 9.96 re f
+80.79 219.05 8.60 9.96 re f
+80.79 229.01 8.60 9.96 re f
+80.79 238.97 8.60 9.96 re f
+80.79 248.94 8.60 9.96 re f
+80.79 258.90 8.60 9.96 re f
+80.79 268.86 8.60 9.96 re f
+80.79 278.83 8.60 9.96 re f
+80.79 288.79 8.60 9.96 re f
+80.79 298.75 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+80.79 308.72 8.60 9.96 re f
+80.79 318.68 8.60 9.96 re f
+80.79 328.64 8.60 9.96 re f
+80.79 338.61 8.60 9.96 re f
+80.79 348.57 8.60 9.96 re f
+80.79 358.53 8.60 9.96 re f
+80.79 368.49 8.60 9.96 re f
+80.79 378.46 8.60 9.96 re f
+80.79 388.42 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+89.39 19.79 8.60 9.96 re f
+89.39 29.75 8.60 9.96 re f
+89.39 39.71 8.60 9.96 re f
+89.39 49.67 8.60 9.96 re f
+89.39 59.64 8.60 9.96 re f
+89.39 69.60 8.60 9.96 re f
+89.39 79.56 8.60 9.96 re f
+89.39 89.53 8.60 9.96 re f
+89.39 99.49 8.60 9.96 re f
+89.39 109.45 8.60 9.96 re f
+89.39 119.42 8.60 9.96 re f
+89.39 129.38 8.60 9.96 re f
+89.39 139.34 8.60 9.96 re f
+89.39 149.31 8.60 9.96 re f
+89.39 159.27 8.60 9.96 re f
+89.39 169.23 8.60 9.96 re f
+89.39 179.20 8.60 9.96 re f
+89.39 189.16 8.60 9.96 re f
+89.39 199.12 8.60 9.96 re f
+89.39 209.08 8.60 9.96 re f
+89.39 219.05 8.60 9.96 re f
+89.39 229.01 8.60 9.96 re f
+89.39 238.97 8.60 9.96 re f
+89.39 248.94 8.60 9.96 re f
+89.39 258.90 8.60 9.96 re f
+89.39 268.86 8.60 9.96 re f
+89.39 278.83 8.60 9.96 re f
+89.39 288.79 8.60 9.96 re f
+89.39 298.75 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+89.39 308.72 8.60 9.96 re f
+89.39 318.68 8.60 9.96 re f
+89.39 328.64 8.60 9.96 re f
+89.39 338.61 8.60 9.96 re f
+89.39 348.57 8.60 9.96 re f
+89.39 358.53 8.60 9.96 re f
+89.39 368.49 8.60 9.96 re f
+89.39 378.46 8.60 9.96 re f
+89.39 388.42 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+97.99 19.79 8.60 9.96 re f
+97.99 29.75 8.60 9.96 re f
+97.99 39.71 8.60 9.96 re f
+97.99 49.67 8.60 9.96 re f
+97.99 59.64 8.60 9.96 re f
+97.99 69.60 8.60 9.96 re f
+97.99 79.56 8.60 9.96 re f
+97.99 89.53 8.60 9.96 re f
+97.99 99.49 8.60 9.96 re f
+97.99 109.45 8.60 9.96 re f
+97.99 119.42 8.60 9.96 re f
+97.99 129.38 8.60 9.96 re f
+97.99 139.34 8.60 9.96 re f
+97.99 149.31 8.60 9.96 re f
+97.99 159.27 8.60 9.96 re f
+97.99 169.23 8.60 9.96 re f
+97.99 179.20 8.60 9.96 re f
+97.99 189.16 8.60 9.96 re f
+97.99 199.12 8.60 9.96 re f
+97.99 209.08 8.60 9.96 re f
+97.99 219.05 8.60 9.96 re f
+97.99 229.01 8.60 9.96 re f
+97.99 238.97 8.60 9.96 re f
+97.99 248.94 8.60 9.96 re f
+97.99 258.90 8.60 9.96 re f
+97.99 268.86 8.60 9.96 re f
+97.99 278.83 8.60 9.96 re f
+97.99 288.79 8.60 9.96 re f
+97.99 298.75 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+97.99 308.72 8.60 9.96 re f
+97.99 318.68 8.60 9.96 re f
+97.99 328.64 8.60 9.96 re f
+97.99 338.61 8.60 9.96 re f
+97.99 348.57 8.60 9.96 re f
+97.99 358.53 8.60 9.96 re f
+97.99 368.49 8.60 9.96 re f
+97.99 378.46 8.60 9.96 re f
+97.99 388.42 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+106.59 19.79 8.60 9.96 re f
+106.59 29.75 8.60 9.96 re f
+106.59 39.71 8.60 9.96 re f
+106.59 49.67 8.60 9.96 re f
+106.59 59.64 8.60 9.96 re f
+106.59 69.60 8.60 9.96 re f
+106.59 79.56 8.60 9.96 re f
+106.59 89.53 8.60 9.96 re f
+106.59 99.49 8.60 9.96 re f
+106.59 109.45 8.60 9.96 re f
+106.59 119.42 8.60 9.96 re f
+106.59 129.38 8.60 9.96 re f
+106.59 139.34 8.60 9.96 re f
+106.59 149.31 8.60 9.96 re f
+106.59 159.27 8.60 9.96 re f
+106.59 169.23 8.60 9.96 re f
+106.59 179.20 8.60 9.96 re f
+106.59 189.16 8.60 9.96 re f
+106.59 199.12 8.60 9.96 re f
+106.59 209.08 8.60 9.96 re f
+106.59 219.05 8.60 9.96 re f
+106.59 229.01 8.60 9.96 re f
+106.59 238.97 8.60 9.96 re f
+106.59 248.94 8.60 9.96 re f
+106.59 258.90 8.60 9.96 re f
+106.59 268.86 8.60 9.96 re f
+106.59 278.83 8.60 9.96 re f
+106.59 288.79 8.60 9.96 re f
+106.59 298.75 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+106.59 308.72 8.60 9.96 re f
+106.59 318.68 8.60 9.96 re f
+106.59 328.64 8.60 9.96 re f
+106.59 338.61 8.60 9.96 re f
+106.59 348.57 8.60 9.96 re f
+106.59 358.53 8.60 9.96 re f
+106.59 368.49 8.60 9.96 re f
+106.59 378.46 8.60 9.96 re f
+106.59 388.42 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+115.18 19.79 8.60 9.96 re f
+115.18 29.75 8.60 9.96 re f
+115.18 39.71 8.60 9.96 re f
+115.18 49.67 8.60 9.96 re f
+115.18 59.64 8.60 9.96 re f
+115.18 69.60 8.60 9.96 re f
+115.18 79.56 8.60 9.96 re f
+115.18 89.53 8.60 9.96 re f
+115.18 99.49 8.60 9.96 re f
+115.18 109.45 8.60 9.96 re f
+115.18 119.42 8.60 9.96 re f
+115.18 129.38 8.60 9.96 re f
+115.18 139.34 8.60 9.96 re f
+115.18 149.31 8.60 9.96 re f
+115.18 159.27 8.60 9.96 re f
+115.18 169.23 8.60 9.96 re f
+115.18 179.20 8.60 9.96 re f
+115.18 189.16 8.60 9.96 re f
+115.18 199.12 8.60 9.96 re f
+115.18 209.08 8.60 9.96 re f
+115.18 219.05 8.60 9.96 re f
+115.18 229.01 8.60 9.96 re f
+115.18 238.97 8.60 9.96 re f
+115.18 248.94 8.60 9.96 re f
+115.18 258.90 8.60 9.96 re f
+115.18 268.86 8.60 9.96 re f
+115.18 278.83 8.60 9.96 re f
+115.18 288.79 8.60 9.96 re f
+115.18 298.75 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+115.18 308.72 8.60 9.96 re f
+115.18 318.68 8.60 9.96 re f
+115.18 328.64 8.60 9.96 re f
+115.18 338.61 8.60 9.96 re f
+115.18 348.57 8.60 9.96 re f
+115.18 358.53 8.60 9.96 re f
+115.18 368.49 8.60 9.96 re f
+115.18 378.46 8.60 9.96 re f
+115.18 388.42 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+123.78 19.79 8.60 9.96 re f
+123.78 29.75 8.60 9.96 re f
+123.78 39.71 8.60 9.96 re f
+123.78 49.67 8.60 9.96 re f
+123.78 59.64 8.60 9.96 re f
+123.78 69.60 8.60 9.96 re f
+123.78 79.56 8.60 9.96 re f
+123.78 89.53 8.60 9.96 re f
+123.78 99.49 8.60 9.96 re f
+123.78 109.45 8.60 9.96 re f
+123.78 119.42 8.60 9.96 re f
+123.78 129.38 8.60 9.96 re f
+123.78 139.34 8.60 9.96 re f
+123.78 149.31 8.60 9.96 re f
+123.78 159.27 8.60 9.96 re f
+123.78 169.23 8.60 9.96 re f
+123.78 179.20 8.60 9.96 re f
+123.78 189.16 8.60 9.96 re f
+123.78 199.12 8.60 9.96 re f
+123.78 209.08 8.60 9.96 re f
+123.78 219.05 8.60 9.96 re f
+123.78 229.01 8.60 9.96 re f
+123.78 238.97 8.60 9.96 re f
+123.78 248.94 8.60 9.96 re f
+123.78 258.90 8.60 9.96 re f
+123.78 268.86 8.60 9.96 re f
+123.78 278.83 8.60 9.96 re f
+123.78 288.79 8.60 9.96 re f
+123.78 298.75 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+123.78 308.72 8.60 9.96 re f
+123.78 318.68 8.60 9.96 re f
+123.78 328.64 8.60 9.96 re f
+123.78 338.61 8.60 9.96 re f
+123.78 348.57 8.60 9.96 re f
+123.78 358.53 8.60 9.96 re f
+123.78 368.49 8.60 9.96 re f
+123.78 378.46 8.60 9.96 re f
+123.78 388.42 8.60 9.96 re f
+/sRGB cs 0.667 0.847 0.910 scn
+132.38 19.79 8.60 9.96 re f
+132.38 29.75 8.60 9.96 re f
+132.38 39.71 8.60 9.96 re f
+132.38 49.67 8.60 9.96 re f
+132.38 59.64 8.60 9.96 re f
+132.38 69.60 8.60 9.96 re f
+132.38 79.56 8.60 9.96 re f
+132.38 89.53 8.60 9.96 re f
+132.38 99.49 8.60 9.96 re f
+132.38 109.45 8.60 9.96 re f
+132.38 119.42 8.60 9.96 re f
+132.38 129.38 8.60 9.96 re f
+132.38 139.34 8.60 9.96 re f
+132.38 149.31 8.60 9.96 re f
+132.38 159.27 8.60 9.96 re f
+132.38 169.23 8.60 9.96 re f
+/sRGB cs 0.710 0.871 0.922 scn
+132.38 179.20 8.60 9.96 re f
+/sRGB cs 0.992 0.682 0.380 scn
+132.38 189.16 8.60 9.96 re f
+132.38 199.12 8.60 9.96 re f
+132.38 209.08 8.60 9.96 re f
+132.38 219.05 8.60 9.96 re f
+132.38 229.01 8.60 9.96 re f
+132.38 238.97 8.60 9.96 re f
+132.38 248.94 8.60 9.96 re f
+132.38 258.90 8.60 9.96 re f
+132.38 268.86 8.60 9.96 re f
+132.38 278.83 8.60 9.96 re f
+132.38 288.79 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+132.38 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+132.38 308.72 8.60 9.96 re f
+132.38 318.68 8.60 9.96 re f
+132.38 328.64 8.60 9.96 re f
+132.38 338.61 8.60 9.96 re f
+132.38 348.57 8.60 9.96 re f
+132.38 358.53 8.60 9.96 re f
+132.38 368.49 8.60 9.96 re f
+132.38 378.46 8.60 9.96 re f
+132.38 388.42 8.60 9.96 re f
+140.98 19.79 8.60 9.96 re f
+140.98 29.75 8.60 9.96 re f
+140.98 39.71 8.60 9.96 re f
+140.98 49.67 8.60 9.96 re f
+140.98 59.64 8.60 9.96 re f
+140.98 69.60 8.60 9.96 re f
+140.98 79.56 8.60 9.96 re f
+140.98 89.53 8.60 9.96 re f
+140.98 99.49 8.60 9.96 re f
+140.98 109.45 8.60 9.96 re f
+140.98 119.42 8.60 9.96 re f
+140.98 129.38 8.60 9.96 re f
+140.98 139.34 8.60 9.96 re f
+140.98 149.31 8.60 9.96 re f
+140.98 159.27 8.60 9.96 re f
+140.98 169.23 8.60 9.96 re f
+/sRGB cs 0.208 0.259 0.608 scn
+140.98 179.20 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+140.98 189.16 8.60 9.96 re f
+140.98 199.12 8.60 9.96 re f
+140.98 209.08 8.60 9.96 re f
+140.98 219.05 8.60 9.96 re f
+140.98 229.01 8.60 9.96 re f
+140.98 238.97 8.60 9.96 re f
+140.98 248.94 8.60 9.96 re f
+140.98 258.90 8.60 9.96 re f
+140.98 268.86 8.60 9.96 re f
+140.98 278.83 8.60 9.96 re f
+140.98 288.79 8.60 9.96 re f
+/sRGB cs 0.992 0.682 0.380 scn
+140.98 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+140.98 308.72 8.60 9.96 re f
+140.98 318.68 8.60 9.96 re f
+140.98 328.64 8.60 9.96 re f
+140.98 338.61 8.60 9.96 re f
+140.98 348.57 8.60 9.96 re f
+140.98 358.53 8.60 9.96 re f
+140.98 368.49 8.60 9.96 re f
+140.98 378.46 8.60 9.96 re f
+140.98 388.42 8.60 9.96 re f
+149.57 19.79 8.60 9.96 re f
+149.57 29.75 8.60 9.96 re f
+149.57 39.71 8.60 9.96 re f
+149.57 49.67 8.60 9.96 re f
+149.57 59.64 8.60 9.96 re f
+149.57 69.60 8.60 9.96 re f
+149.57 79.56 8.60 9.96 re f
+149.57 89.53 8.60 9.96 re f
+149.57 99.49 8.60 9.96 re f
+149.57 109.45 8.60 9.96 re f
+149.57 119.42 8.60 9.96 re f
+149.57 129.38 8.60 9.96 re f
+149.57 139.34 8.60 9.96 re f
+149.57 149.31 8.60 9.96 re f
+149.57 159.27 8.60 9.96 re f
+149.57 169.23 8.60 9.96 re f
+/sRGB cs 0.208 0.259 0.608 scn
+149.57 179.20 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+149.57 189.16 8.60 9.96 re f
+149.57 199.12 8.60 9.96 re f
+149.57 209.08 8.60 9.96 re f
+149.57 219.05 8.60 9.96 re f
+149.57 229.01 8.60 9.96 re f
+149.57 238.97 8.60 9.96 re f
+149.57 248.94 8.60 9.96 re f
+149.57 258.90 8.60 9.96 re f
+149.57 268.86 8.60 9.96 re f
+149.57 278.83 8.60 9.96 re f
+149.57 288.79 8.60 9.96 re f
+/sRGB cs 0.992 0.682 0.380 scn
+149.57 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+149.57 308.72 8.60 9.96 re f
+149.57 318.68 8.60 9.96 re f
+149.57 328.64 8.60 9.96 re f
+149.57 338.61 8.60 9.96 re f
+149.57 348.57 8.60 9.96 re f
+149.57 358.53 8.60 9.96 re f
+149.57 368.49 8.60 9.96 re f
+149.57 378.46 8.60 9.96 re f
+149.57 388.42 8.60 9.96 re f
+158.17 19.79 8.60 9.96 re f
+158.17 29.75 8.60 9.96 re f
+158.17 39.71 8.60 9.96 re f
+158.17 49.67 8.60 9.96 re f
+158.17 59.64 8.60 9.96 re f
+158.17 69.60 8.60 9.96 re f
+158.17 79.56 8.60 9.96 re f
+158.17 89.53 8.60 9.96 re f
+158.17 99.49 8.60 9.96 re f
+158.17 109.45 8.60 9.96 re f
+158.17 119.42 8.60 9.96 re f
+158.17 129.38 8.60 9.96 re f
+158.17 139.34 8.60 9.96 re f
+158.17 149.31 8.60 9.96 re f
+158.17 159.27 8.60 9.96 re f
+158.17 169.23 8.60 9.96 re f
+/sRGB cs 0.208 0.259 0.608 scn
+158.17 179.20 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+158.17 189.16 8.60 9.96 re f
+158.17 199.12 8.60 9.96 re f
+158.17 209.08 8.60 9.96 re f
+158.17 219.05 8.60 9.96 re f
+158.17 229.01 8.60 9.96 re f
+158.17 238.97 8.60 9.96 re f
+158.17 248.94 8.60 9.96 re f
+158.17 258.90 8.60 9.96 re f
+158.17 268.86 8.60 9.96 re f
+158.17 278.83 8.60 9.96 re f
+158.17 288.79 8.60 9.96 re f
+/sRGB cs 0.992 0.682 0.380 scn
+158.17 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+158.17 308.72 8.60 9.96 re f
+158.17 318.68 8.60 9.96 re f
+158.17 328.64 8.60 9.96 re f
+158.17 338.61 8.60 9.96 re f
+158.17 348.57 8.60 9.96 re f
+158.17 358.53 8.60 9.96 re f
+158.17 368.49 8.60 9.96 re f
+158.17 378.46 8.60 9.96 re f
+158.17 388.42 8.60 9.96 re f
+166.77 19.79 8.60 9.96 re f
+166.77 29.75 8.60 9.96 re f
+166.77 39.71 8.60 9.96 re f
+166.77 49.67 8.60 9.96 re f
+166.77 59.64 8.60 9.96 re f
+166.77 69.60 8.60 9.96 re f
+166.77 79.56 8.60 9.96 re f
+166.77 89.53 8.60 9.96 re f
+166.77 99.49 8.60 9.96 re f
+166.77 109.45 8.60 9.96 re f
+166.77 119.42 8.60 9.96 re f
+166.77 129.38 8.60 9.96 re f
+166.77 139.34 8.60 9.96 re f
+166.77 149.31 8.60 9.96 re f
+166.77 159.27 8.60 9.96 re f
+166.77 169.23 8.60 9.96 re f
+/sRGB cs 0.208 0.259 0.608 scn
+166.77 179.20 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+166.77 189.16 8.60 9.96 re f
+166.77 199.12 8.60 9.96 re f
+166.77 209.08 8.60 9.96 re f
+166.77 219.05 8.60 9.96 re f
+166.77 229.01 8.60 9.96 re f
+166.77 238.97 8.60 9.96 re f
+166.77 248.94 8.60 9.96 re f
+166.77 258.90 8.60 9.96 re f
+166.77 268.86 8.60 9.96 re f
+166.77 278.83 8.60 9.96 re f
+166.77 288.79 8.60 9.96 re f
+/sRGB cs 0.992 0.682 0.380 scn
+166.77 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+166.77 308.72 8.60 9.96 re f
+166.77 318.68 8.60 9.96 re f
+166.77 328.64 8.60 9.96 re f
+166.77 338.61 8.60 9.96 re f
+166.77 348.57 8.60 9.96 re f
+166.77 358.53 8.60 9.96 re f
+166.77 368.49 8.60 9.96 re f
+166.77 378.46 8.60 9.96 re f
+166.77 388.42 8.60 9.96 re f
+175.37 19.79 8.60 9.96 re f
+175.37 29.75 8.60 9.96 re f
+175.37 39.71 8.60 9.96 re f
+175.37 49.67 8.60 9.96 re f
+175.37 59.64 8.60 9.96 re f
+175.37 69.60 8.60 9.96 re f
+175.37 79.56 8.60 9.96 re f
+175.37 89.53 8.60 9.96 re f
+175.37 99.49 8.60 9.96 re f
+175.37 109.45 8.60 9.96 re f
+175.37 119.42 8.60 9.96 re f
+175.37 129.38 8.60 9.96 re f
+175.37 139.34 8.60 9.96 re f
+175.37 149.31 8.60 9.96 re f
+175.37 159.27 8.60 9.96 re f
+175.37 169.23 8.60 9.96 re f
+/sRGB cs 0.208 0.259 0.608 scn
+175.37 179.20 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+175.37 189.16 8.60 9.96 re f
+175.37 199.12 8.60 9.96 re f
+175.37 209.08 8.60 9.96 re f
+175.37 219.05 8.60 9.96 re f
+175.37 229.01 8.60 9.96 re f
+175.37 238.97 8.60 9.96 re f
+175.37 248.94 8.60 9.96 re f
+175.37 258.90 8.60 9.96 re f
+175.37 268.86 8.60 9.96 re f
+175.37 278.83 8.60 9.96 re f
+175.37 288.79 8.60 9.96 re f
+/sRGB cs 0.992 0.682 0.380 scn
+175.37 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+175.37 308.72 8.60 9.96 re f
+175.37 318.68 8.60 9.96 re f
+175.37 328.64 8.60 9.96 re f
+175.37 338.61 8.60 9.96 re f
+175.37 348.57 8.60 9.96 re f
+175.37 358.53 8.60 9.96 re f
+175.37 368.49 8.60 9.96 re f
+175.37 378.46 8.60 9.96 re f
+175.37 388.42 8.60 9.96 re f
+183.96 19.79 8.60 9.96 re f
+183.96 29.75 8.60 9.96 re f
+183.96 39.71 8.60 9.96 re f
+183.96 49.67 8.60 9.96 re f
+183.96 59.64 8.60 9.96 re f
+183.96 69.60 8.60 9.96 re f
+183.96 79.56 8.60 9.96 re f
+183.96 89.53 8.60 9.96 re f
+183.96 99.49 8.60 9.96 re f
+183.96 109.45 8.60 9.96 re f
+183.96 119.42 8.60 9.96 re f
+183.96 129.38 8.60 9.96 re f
+183.96 139.34 8.60 9.96 re f
+183.96 149.31 8.60 9.96 re f
+183.96 159.27 8.60 9.96 re f
+183.96 169.23 8.60 9.96 re f
+/sRGB cs 0.208 0.259 0.608 scn
+183.96 179.20 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+183.96 189.16 8.60 9.96 re f
+183.96 199.12 8.60 9.96 re f
+183.96 209.08 8.60 9.96 re f
+183.96 219.05 8.60 9.96 re f
+183.96 229.01 8.60 9.96 re f
+183.96 238.97 8.60 9.96 re f
+183.96 248.94 8.60 9.96 re f
+183.96 258.90 8.60 9.96 re f
+183.96 268.86 8.60 9.96 re f
+183.96 278.83 8.60 9.96 re f
+183.96 288.79 8.60 9.96 re f
+/sRGB cs 0.992 0.682 0.380 scn
+183.96 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+183.96 308.72 8.60 9.96 re f
+183.96 318.68 8.60 9.96 re f
+183.96 328.64 8.60 9.96 re f
+183.96 338.61 8.60 9.96 re f
+183.96 348.57 8.60 9.96 re f
+183.96 358.53 8.60 9.96 re f
+183.96 368.49 8.60 9.96 re f
+183.96 378.46 8.60 9.96 re f
+183.96 388.42 8.60 9.96 re f
+192.56 19.79 8.60 9.96 re f
+192.56 29.75 8.60 9.96 re f
+192.56 39.71 8.60 9.96 re f
+192.56 49.67 8.60 9.96 re f
+192.56 59.64 8.60 9.96 re f
+192.56 69.60 8.60 9.96 re f
+192.56 79.56 8.60 9.96 re f
+192.56 89.53 8.60 9.96 re f
+192.56 99.49 8.60 9.96 re f
+192.56 109.45 8.60 9.96 re f
+192.56 119.42 8.60 9.96 re f
+192.56 129.38 8.60 9.96 re f
+192.56 139.34 8.60 9.96 re f
+192.56 149.31 8.60 9.96 re f
+192.56 159.27 8.60 9.96 re f
+192.56 169.23 8.60 9.96 re f
+/sRGB cs 0.208 0.259 0.608 scn
+192.56 179.20 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+192.56 189.16 8.60 9.96 re f
+192.56 199.12 8.60 9.96 re f
+192.56 209.08 8.60 9.96 re f
+192.56 219.05 8.60 9.96 re f
+192.56 229.01 8.60 9.96 re f
+192.56 238.97 8.60 9.96 re f
+192.56 248.94 8.60 9.96 re f
+192.56 258.90 8.60 9.96 re f
+192.56 268.86 8.60 9.96 re f
+192.56 278.83 8.60 9.96 re f
+192.56 288.79 8.60 9.96 re f
+/sRGB cs 0.992 0.682 0.380 scn
+192.56 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+192.56 308.72 8.60 9.96 re f
+192.56 318.68 8.60 9.96 re f
+192.56 328.64 8.60 9.96 re f
+192.56 338.61 8.60 9.96 re f
+192.56 348.57 8.60 9.96 re f
+192.56 358.53 8.60 9.96 re f
+192.56 368.49 8.60 9.96 re f
+192.56 378.46 8.60 9.96 re f
+192.56 388.42 8.60 9.96 re f
+201.16 19.79 8.60 9.96 re f
+201.16 29.75 8.60 9.96 re f
+201.16 39.71 8.60 9.96 re f
+201.16 49.67 8.60 9.96 re f
+201.16 59.64 8.60 9.96 re f
+201.16 69.60 8.60 9.96 re f
+201.16 79.56 8.60 9.96 re f
+201.16 89.53 8.60 9.96 re f
+201.16 99.49 8.60 9.96 re f
+201.16 109.45 8.60 9.96 re f
+201.16 119.42 8.60 9.96 re f
+201.16 129.38 8.60 9.96 re f
+201.16 139.34 8.60 9.96 re f
+201.16 149.31 8.60 9.96 re f
+201.16 159.27 8.60 9.96 re f
+201.16 169.23 8.60 9.96 re f
+/sRGB cs 0.208 0.259 0.608 scn
+201.16 179.20 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+201.16 189.16 8.60 9.96 re f
+201.16 199.12 8.60 9.96 re f
+201.16 209.08 8.60 9.96 re f
+201.16 219.05 8.60 9.96 re f
+201.16 229.01 8.60 9.96 re f
+201.16 238.97 8.60 9.96 re f
+201.16 248.94 8.60 9.96 re f
+201.16 258.90 8.60 9.96 re f
+201.16 268.86 8.60 9.96 re f
+201.16 278.83 8.60 9.96 re f
+201.16 288.79 8.60 9.96 re f
+/sRGB cs 0.992 0.682 0.380 scn
+201.16 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+201.16 308.72 8.60 9.96 re f
+201.16 318.68 8.60 9.96 re f
+201.16 328.64 8.60 9.96 re f
+201.16 338.61 8.60 9.96 re f
+201.16 348.57 8.60 9.96 re f
+201.16 358.53 8.60 9.96 re f
+201.16 368.49 8.60 9.96 re f
+201.16 378.46 8.60 9.96 re f
+201.16 388.42 8.60 9.96 re f
+209.76 19.79 8.60 9.96 re f
+209.76 29.75 8.60 9.96 re f
+209.76 39.71 8.60 9.96 re f
+209.76 49.67 8.60 9.96 re f
+209.76 59.64 8.60 9.96 re f
+209.76 69.60 8.60 9.96 re f
+209.76 79.56 8.60 9.96 re f
+209.76 89.53 8.60 9.96 re f
+209.76 99.49 8.60 9.96 re f
+209.76 109.45 8.60 9.96 re f
+209.76 119.42 8.60 9.96 re f
+209.76 129.38 8.60 9.96 re f
+209.76 139.34 8.60 9.96 re f
+209.76 149.31 8.60 9.96 re f
+209.76 159.27 8.60 9.96 re f
+209.76 169.23 8.60 9.96 re f
+/sRGB cs 0.208 0.259 0.608 scn
+209.76 179.20 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+209.76 189.16 8.60 9.96 re f
+209.76 199.12 8.60 9.96 re f
+209.76 209.08 8.60 9.96 re f
+209.76 219.05 8.60 9.96 re f
+209.76 229.01 8.60 9.96 re f
+209.76 238.97 8.60 9.96 re f
+209.76 248.94 8.60 9.96 re f
+209.76 258.90 8.60 9.96 re f
+209.76 268.86 8.60 9.96 re f
+209.76 278.83 8.60 9.96 re f
+209.76 288.79 8.60 9.96 re f
+/sRGB cs 0.992 0.682 0.380 scn
+209.76 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+209.76 308.72 8.60 9.96 re f
+209.76 318.68 8.60 9.96 re f
+209.76 328.64 8.60 9.96 re f
+209.76 338.61 8.60 9.96 re f
+209.76 348.57 8.60 9.96 re f
+209.76 358.53 8.60 9.96 re f
+209.76 368.49 8.60 9.96 re f
+209.76 378.46 8.60 9.96 re f
+209.76 388.42 8.60 9.96 re f
+218.35 19.79 8.60 9.96 re f
+218.35 29.75 8.60 9.96 re f
+218.35 39.71 8.60 9.96 re f
+218.35 49.67 8.60 9.96 re f
+218.35 59.64 8.60 9.96 re f
+218.35 69.60 8.60 9.96 re f
+218.35 79.56 8.60 9.96 re f
+218.35 89.53 8.60 9.96 re f
+218.35 99.49 8.60 9.96 re f
+218.35 109.45 8.60 9.96 re f
+218.35 119.42 8.60 9.96 re f
+218.35 129.38 8.60 9.96 re f
+218.35 139.34 8.60 9.96 re f
+218.35 149.31 8.60 9.96 re f
+218.35 159.27 8.60 9.96 re f
+218.35 169.23 8.60 9.96 re f
+/sRGB cs 0.208 0.259 0.608 scn
+218.35 179.20 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+218.35 189.16 8.60 9.96 re f
+218.35 199.12 8.60 9.96 re f
+218.35 209.08 8.60 9.96 re f
+218.35 219.05 8.60 9.96 re f
+218.35 229.01 8.60 9.96 re f
+218.35 238.97 8.60 9.96 re f
+218.35 248.94 8.60 9.96 re f
+218.35 258.90 8.60 9.96 re f
+218.35 268.86 8.60 9.96 re f
+218.35 278.83 8.60 9.96 re f
+218.35 288.79 8.60 9.96 re f
+/sRGB cs 0.992 0.682 0.380 scn
+218.35 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+218.35 308.72 8.60 9.96 re f
+218.35 318.68 8.60 9.96 re f
+218.35 328.64 8.60 9.96 re f
+218.35 338.61 8.60 9.96 re f
+218.35 348.57 8.60 9.96 re f
+218.35 358.53 8.60 9.96 re f
+218.35 368.49 8.60 9.96 re f
+218.35 378.46 8.60 9.96 re f
+218.35 388.42 8.60 9.96 re f
+226.95 19.79 8.60 9.96 re f
+226.95 29.75 8.60 9.96 re f
+226.95 39.71 8.60 9.96 re f
+226.95 49.67 8.60 9.96 re f
+226.95 59.64 8.60 9.96 re f
+226.95 69.60 8.60 9.96 re f
+226.95 79.56 8.60 9.96 re f
+226.95 89.53 8.60 9.96 re f
+226.95 99.49 8.60 9.96 re f
+226.95 109.45 8.60 9.96 re f
+226.95 119.42 8.60 9.96 re f
+226.95 129.38 8.60 9.96 re f
+226.95 139.34 8.60 9.96 re f
+226.95 149.31 8.60 9.96 re f
+226.95 159.27 8.60 9.96 re f
+226.95 169.23 8.60 9.96 re f
+/sRGB cs 0.208 0.259 0.608 scn
+226.95 179.20 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+226.95 189.16 8.60 9.96 re f
+226.95 199.12 8.60 9.96 re f
+226.95 209.08 8.60 9.96 re f
+226.95 219.05 8.60 9.96 re f
+226.95 229.01 8.60 9.96 re f
+226.95 238.97 8.60 9.96 re f
+226.95 248.94 8.60 9.96 re f
+226.95 258.90 8.60 9.96 re f
+226.95 268.86 8.60 9.96 re f
+226.95 278.83 8.60 9.96 re f
+226.95 288.79 8.60 9.96 re f
+/sRGB cs 0.992 0.682 0.380 scn
+226.95 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+226.95 308.72 8.60 9.96 re f
+226.95 318.68 8.60 9.96 re f
+226.95 328.64 8.60 9.96 re f
+226.95 338.61 8.60 9.96 re f
+226.95 348.57 8.60 9.96 re f
+226.95 358.53 8.60 9.96 re f
+226.95 368.49 8.60 9.96 re f
+226.95 378.46 8.60 9.96 re f
+226.95 388.42 8.60 9.96 re f
+/sRGB cs 0.686 0.035 0.149 scn
+235.55 19.79 8.60 9.96 re f
+235.55 29.75 8.60 9.96 re f
+235.55 39.71 8.60 9.96 re f
+235.55 49.67 8.60 9.96 re f
+235.55 59.64 8.60 9.96 re f
+235.55 69.60 8.60 9.96 re f
+235.55 79.56 8.60 9.96 re f
+235.55 89.53 8.60 9.96 re f
+235.55 99.49 8.60 9.96 re f
+235.55 109.45 8.60 9.96 re f
+235.55 119.42 8.60 9.96 re f
+235.55 129.38 8.60 9.96 re f
+235.55 139.34 8.60 9.96 re f
+235.55 149.31 8.60 9.96 re f
+235.55 159.27 8.60 9.96 re f
+235.55 169.23 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+235.55 179.20 8.60 9.96 re f
+/sRGB cs 0.208 0.259 0.608 scn
+235.55 189.16 8.60 9.96 re f
+235.55 199.12 8.60 9.96 re f
+235.55 209.08 8.60 9.96 re f
+235.55 219.05 8.60 9.96 re f
+235.55 229.01 8.60 9.96 re f
+235.55 238.97 8.60 9.96 re f
+235.55 248.94 8.60 9.96 re f
+235.55 258.90 8.60 9.96 re f
+235.55 268.86 8.60 9.96 re f
+235.55 278.83 8.60 9.96 re f
+235.55 288.79 8.60 9.96 re f
+/sRGB cs 0.710 0.871 0.922 scn
+235.55 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+235.55 308.72 8.60 9.96 re f
+235.55 318.68 8.60 9.96 re f
+235.55 328.64 8.60 9.96 re f
+235.55 338.61 8.60 9.96 re f
+235.55 348.57 8.60 9.96 re f
+235.55 358.53 8.60 9.96 re f
+235.55 368.49 8.60 9.96 re f
+235.55 378.46 8.60 9.96 re f
+235.55 388.42 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+244.15 19.79 8.60 9.96 re f
+244.15 29.75 8.60 9.96 re f
+244.15 39.71 8.60 9.96 re f
+244.15 49.67 8.60 9.96 re f
+244.15 59.64 8.60 9.96 re f
+244.15 69.60 8.60 9.96 re f
+244.15 79.56 8.60 9.96 re f
+244.15 89.53 8.60 9.96 re f
+244.15 99.49 8.60 9.96 re f
+244.15 109.45 8.60 9.96 re f
+244.15 119.42 8.60 9.96 re f
+244.15 129.38 8.60 9.96 re f
+244.15 139.34 8.60 9.96 re f
+244.15 149.31 8.60 9.96 re f
+244.15 159.27 8.60 9.96 re f
+244.15 169.23 8.60 9.96 re f
+/sRGB cs 0.686 0.035 0.149 scn
+244.15 179.20 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+244.15 189.16 8.60 9.96 re f
+244.15 199.12 8.60 9.96 re f
+244.15 209.08 8.60 9.96 re f
+244.15 219.05 8.60 9.96 re f
+244.15 229.01 8.60 9.96 re f
+244.15 238.97 8.60 9.96 re f
+244.15 248.94 8.60 9.96 re f
+244.15 258.90 8.60 9.96 re f
+244.15 268.86 8.60 9.96 re f
+244.15 278.83 8.60 9.96 re f
+244.15 288.79 8.60 9.96 re f
+/sRGB cs 0.667 0.847 0.910 scn
+244.15 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+244.15 308.72 8.60 9.96 re f
+244.15 318.68 8.60 9.96 re f
+244.15 328.64 8.60 9.96 re f
+244.15 338.61 8.60 9.96 re f
+244.15 348.57 8.60 9.96 re f
+244.15 358.53 8.60 9.96 re f
+244.15 368.49 8.60 9.96 re f
+244.15 378.46 8.60 9.96 re f
+244.15 388.42 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+252.75 19.79 8.60 9.96 re f
+252.75 29.75 8.60 9.96 re f
+252.75 39.71 8.60 9.96 re f
+252.75 49.67 8.60 9.96 re f
+252.75 59.64 8.60 9.96 re f
+252.75 69.60 8.60 9.96 re f
+252.75 79.56 8.60 9.96 re f
+252.75 89.53 8.60 9.96 re f
+252.75 99.49 8.60 9.96 re f
+252.75 109.45 8.60 9.96 re f
+252.75 119.42 8.60 9.96 re f
+252.75 129.38 8.60 9.96 re f
+252.75 139.34 8.60 9.96 re f
+252.75 149.31 8.60 9.96 re f
+252.75 159.27 8.60 9.96 re f
+252.75 169.23 8.60 9.96 re f
+/sRGB cs 0.686 0.035 0.149 scn
+252.75 179.20 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+252.75 189.16 8.60 9.96 re f
+252.75 199.12 8.60 9.96 re f
+252.75 209.08 8.60 9.96 re f
+252.75 219.05 8.60 9.96 re f
+252.75 229.01 8.60 9.96 re f
+252.75 238.97 8.60 9.96 re f
+252.75 248.94 8.60 9.96 re f
+252.75 258.90 8.60 9.96 re f
+252.75 268.86 8.60 9.96 re f
+252.75 278.83 8.60 9.96 re f
+252.75 288.79 8.60 9.96 re f
+/sRGB cs 0.667 0.847 0.910 scn
+252.75 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+252.75 308.72 8.60 9.96 re f
+252.75 318.68 8.60 9.96 re f
+252.75 328.64 8.60 9.96 re f
+252.75 338.61 8.60 9.96 re f
+252.75 348.57 8.60 9.96 re f
+252.75 358.53 8.60 9.96 re f
+252.75 368.49 8.60 9.96 re f
+252.75 378.46 8.60 9.96 re f
+252.75 388.42 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+261.34 19.79 8.60 9.96 re f
+261.34 29.75 8.60 9.96 re f
+261.34 39.71 8.60 9.96 re f
+261.34 49.67 8.60 9.96 re f
+261.34 59.64 8.60 9.96 re f
+261.34 69.60 8.60 9.96 re f
+261.34 79.56 8.60 9.96 re f
+261.34 89.53 8.60 9.96 re f
+261.34 99.49 8.60 9.96 re f
+261.34 109.45 8.60 9.96 re f
+261.34 119.42 8.60 9.96 re f
+261.34 129.38 8.60 9.96 re f
+261.34 139.34 8.60 9.96 re f
+261.34 149.31 8.60 9.96 re f
+261.34 159.27 8.60 9.96 re f
+261.34 169.23 8.60 9.96 re f
+/sRGB cs 0.686 0.035 0.149 scn
+261.34 179.20 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+261.34 189.16 8.60 9.96 re f
+261.34 199.12 8.60 9.96 re f
+261.34 209.08 8.60 9.96 re f
+261.34 219.05 8.60 9.96 re f
+261.34 229.01 8.60 9.96 re f
+261.34 238.97 8.60 9.96 re f
+261.34 248.94 8.60 9.96 re f
+261.34 258.90 8.60 9.96 re f
+261.34 268.86 8.60 9.96 re f
+261.34 278.83 8.60 9.96 re f
+261.34 288.79 8.60 9.96 re f
+/sRGB cs 0.667 0.847 0.910 scn
+261.34 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+261.34 308.72 8.60 9.96 re f
+261.34 318.68 8.60 9.96 re f
+261.34 328.64 8.60 9.96 re f
+261.34 338.61 8.60 9.96 re f
+261.34 348.57 8.60 9.96 re f
+261.34 358.53 8.60 9.96 re f
+261.34 368.49 8.60 9.96 re f
+261.34 378.46 8.60 9.96 re f
+261.34 388.42 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+269.94 19.79 8.60 9.96 re f
+269.94 29.75 8.60 9.96 re f
+269.94 39.71 8.60 9.96 re f
+269.94 49.67 8.60 9.96 re f
+269.94 59.64 8.60 9.96 re f
+269.94 69.60 8.60 9.96 re f
+269.94 79.56 8.60 9.96 re f
+269.94 89.53 8.60 9.96 re f
+269.94 99.49 8.60 9.96 re f
+269.94 109.45 8.60 9.96 re f
+269.94 119.42 8.60 9.96 re f
+269.94 129.38 8.60 9.96 re f
+269.94 139.34 8.60 9.96 re f
+269.94 149.31 8.60 9.96 re f
+269.94 159.27 8.60 9.96 re f
+269.94 169.23 8.60 9.96 re f
+/sRGB cs 0.686 0.035 0.149 scn
+269.94 179.20 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+269.94 189.16 8.60 9.96 re f
+269.94 199.12 8.60 9.96 re f
+269.94 209.08 8.60 9.96 re f
+269.94 219.05 8.60 9.96 re f
+269.94 229.01 8.60 9.96 re f
+269.94 238.97 8.60 9.96 re f
+269.94 248.94 8.60 9.96 re f
+269.94 258.90 8.60 9.96 re f
+269.94 268.86 8.60 9.96 re f
+269.94 278.83 8.60 9.96 re f
+269.94 288.79 8.60 9.96 re f
+/sRGB cs 0.667 0.847 0.910 scn
+269.94 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+269.94 308.72 8.60 9.96 re f
+269.94 318.68 8.60 9.96 re f
+269.94 328.64 8.60 9.96 re f
+269.94 338.61 8.60 9.96 re f
+269.94 348.57 8.60 9.96 re f
+269.94 358.53 8.60 9.96 re f
+269.94 368.49 8.60 9.96 re f
+269.94 378.46 8.60 9.96 re f
+269.94 388.42 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+278.54 19.79 8.60 9.96 re f
+278.54 29.75 8.60 9.96 re f
+278.54 39.71 8.60 9.96 re f
+278.54 49.67 8.60 9.96 re f
+278.54 59.64 8.60 9.96 re f
+278.54 69.60 8.60 9.96 re f
+278.54 79.56 8.60 9.96 re f
+278.54 89.53 8.60 9.96 re f
+278.54 99.49 8.60 9.96 re f
+278.54 109.45 8.60 9.96 re f
+278.54 119.42 8.60 9.96 re f
+278.54 129.38 8.60 9.96 re f
+278.54 139.34 8.60 9.96 re f
+278.54 149.31 8.60 9.96 re f
+278.54 159.27 8.60 9.96 re f
+278.54 169.23 8.60 9.96 re f
+/sRGB cs 0.686 0.035 0.149 scn
+278.54 179.20 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+278.54 189.16 8.60 9.96 re f
+278.54 199.12 8.60 9.96 re f
+278.54 209.08 8.60 9.96 re f
+278.54 219.05 8.60 9.96 re f
+278.54 229.01 8.60 9.96 re f
+278.54 238.97 8.60 9.96 re f
+278.54 248.94 8.60 9.96 re f
+278.54 258.90 8.60 9.96 re f
+278.54 268.86 8.60 9.96 re f
+278.54 278.83 8.60 9.96 re f
+278.54 288.79 8.60 9.96 re f
+/sRGB cs 0.667 0.847 0.910 scn
+278.54 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+278.54 308.72 8.60 9.96 re f
+278.54 318.68 8.60 9.96 re f
+278.54 328.64 8.60 9.96 re f
+278.54 338.61 8.60 9.96 re f
+278.54 348.57 8.60 9.96 re f
+278.54 358.53 8.60 9.96 re f
+278.54 368.49 8.60 9.96 re f
+278.54 378.46 8.60 9.96 re f
+278.54 388.42 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+287.14 19.79 8.60 9.96 re f
+287.14 29.75 8.60 9.96 re f
+287.14 39.71 8.60 9.96 re f
+287.14 49.67 8.60 9.96 re f
+287.14 59.64 8.60 9.96 re f
+287.14 69.60 8.60 9.96 re f
+287.14 79.56 8.60 9.96 re f
+287.14 89.53 8.60 9.96 re f
+287.14 99.49 8.60 9.96 re f
+287.14 109.45 8.60 9.96 re f
+287.14 119.42 8.60 9.96 re f
+287.14 129.38 8.60 9.96 re f
+287.14 139.34 8.60 9.96 re f
+287.14 149.31 8.60 9.96 re f
+287.14 159.27 8.60 9.96 re f
+287.14 169.23 8.60 9.96 re f
+/sRGB cs 0.686 0.035 0.149 scn
+287.14 179.20 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+287.14 189.16 8.60 9.96 re f
+287.14 199.12 8.60 9.96 re f
+287.14 209.08 8.60 9.96 re f
+287.14 219.05 8.60 9.96 re f
+287.14 229.01 8.60 9.96 re f
+287.14 238.97 8.60 9.96 re f
+287.14 248.94 8.60 9.96 re f
+287.14 258.90 8.60 9.96 re f
+287.14 268.86 8.60 9.96 re f
+287.14 278.83 8.60 9.96 re f
+287.14 288.79 8.60 9.96 re f
+/sRGB cs 0.667 0.847 0.910 scn
+287.14 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+287.14 308.72 8.60 9.96 re f
+287.14 318.68 8.60 9.96 re f
+287.14 328.64 8.60 9.96 re f
+287.14 338.61 8.60 9.96 re f
+287.14 348.57 8.60 9.96 re f
+287.14 358.53 8.60 9.96 re f
+287.14 368.49 8.60 9.96 re f
+287.14 378.46 8.60 9.96 re f
+287.14 388.42 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+295.73 19.79 8.60 9.96 re f
+295.73 29.75 8.60 9.96 re f
+295.73 39.71 8.60 9.96 re f
+295.73 49.67 8.60 9.96 re f
+295.73 59.64 8.60 9.96 re f
+295.73 69.60 8.60 9.96 re f
+295.73 79.56 8.60 9.96 re f
+295.73 89.53 8.60 9.96 re f
+295.73 99.49 8.60 9.96 re f
+295.73 109.45 8.60 9.96 re f
+295.73 119.42 8.60 9.96 re f
+295.73 129.38 8.60 9.96 re f
+295.73 139.34 8.60 9.96 re f
+295.73 149.31 8.60 9.96 re f
+295.73 159.27 8.60 9.96 re f
+295.73 169.23 8.60 9.96 re f
+/sRGB cs 0.686 0.035 0.149 scn
+295.73 179.20 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+295.73 189.16 8.60 9.96 re f
+295.73 199.12 8.60 9.96 re f
+295.73 209.08 8.60 9.96 re f
+295.73 219.05 8.60 9.96 re f
+295.73 229.01 8.60 9.96 re f
+295.73 238.97 8.60 9.96 re f
+295.73 248.94 8.60 9.96 re f
+295.73 258.90 8.60 9.96 re f
+295.73 268.86 8.60 9.96 re f
+295.73 278.83 8.60 9.96 re f
+295.73 288.79 8.60 9.96 re f
+/sRGB cs 0.667 0.847 0.910 scn
+295.73 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+295.73 308.72 8.60 9.96 re f
+295.73 318.68 8.60 9.96 re f
+295.73 328.64 8.60 9.96 re f
+295.73 338.61 8.60 9.96 re f
+295.73 348.57 8.60 9.96 re f
+295.73 358.53 8.60 9.96 re f
+295.73 368.49 8.60 9.96 re f
+295.73 378.46 8.60 9.96 re f
+295.73 388.42 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+304.33 19.79 8.60 9.96 re f
+304.33 29.75 8.60 9.96 re f
+304.33 39.71 8.60 9.96 re f
+304.33 49.67 8.60 9.96 re f
+304.33 59.64 8.60 9.96 re f
+304.33 69.60 8.60 9.96 re f
+304.33 79.56 8.60 9.96 re f
+304.33 89.53 8.60 9.96 re f
+304.33 99.49 8.60 9.96 re f
+304.33 109.45 8.60 9.96 re f
+304.33 119.42 8.60 9.96 re f
+304.33 129.38 8.60 9.96 re f
+304.33 139.34 8.60 9.96 re f
+304.33 149.31 8.60 9.96 re f
+304.33 159.27 8.60 9.96 re f
+304.33 169.23 8.60 9.96 re f
+/sRGB cs 0.686 0.035 0.149 scn
+304.33 179.20 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+304.33 189.16 8.60 9.96 re f
+304.33 199.12 8.60 9.96 re f
+304.33 209.08 8.60 9.96 re f
+304.33 219.05 8.60 9.96 re f
+304.33 229.01 8.60 9.96 re f
+304.33 238.97 8.60 9.96 re f
+304.33 248.94 8.60 9.96 re f
+304.33 258.90 8.60 9.96 re f
+304.33 268.86 8.60 9.96 re f
+304.33 278.83 8.60 9.96 re f
+304.33 288.79 8.60 9.96 re f
+/sRGB cs 0.667 0.847 0.910 scn
+304.33 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+304.33 308.72 8.60 9.96 re f
+304.33 318.68 8.60 9.96 re f
+304.33 328.64 8.60 9.96 re f
+304.33 338.61 8.60 9.96 re f
+304.33 348.57 8.60 9.96 re f
+304.33 358.53 8.60 9.96 re f
+304.33 368.49 8.60 9.96 re f
+304.33 378.46 8.60 9.96 re f
+304.33 388.42 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+312.93 19.79 8.60 9.96 re f
+312.93 29.75 8.60 9.96 re f
+312.93 39.71 8.60 9.96 re f
+312.93 49.67 8.60 9.96 re f
+312.93 59.64 8.60 9.96 re f
+312.93 69.60 8.60 9.96 re f
+312.93 79.56 8.60 9.96 re f
+312.93 89.53 8.60 9.96 re f
+312.93 99.49 8.60 9.96 re f
+312.93 109.45 8.60 9.96 re f
+312.93 119.42 8.60 9.96 re f
+312.93 129.38 8.60 9.96 re f
+312.93 139.34 8.60 9.96 re f
+312.93 149.31 8.60 9.96 re f
+312.93 159.27 8.60 9.96 re f
+312.93 169.23 8.60 9.96 re f
+/sRGB cs 0.686 0.035 0.149 scn
+312.93 179.20 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+312.93 189.16 8.60 9.96 re f
+312.93 199.12 8.60 9.96 re f
+312.93 209.08 8.60 9.96 re f
+312.93 219.05 8.60 9.96 re f
+312.93 229.01 8.60 9.96 re f
+312.93 238.97 8.60 9.96 re f
+312.93 248.94 8.60 9.96 re f
+312.93 258.90 8.60 9.96 re f
+312.93 268.86 8.60 9.96 re f
+312.93 278.83 8.60 9.96 re f
+312.93 288.79 8.60 9.96 re f
+/sRGB cs 0.667 0.847 0.910 scn
+312.93 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+312.93 308.72 8.60 9.96 re f
+312.93 318.68 8.60 9.96 re f
+312.93 328.64 8.60 9.96 re f
+312.93 338.61 8.60 9.96 re f
+312.93 348.57 8.60 9.96 re f
+312.93 358.53 8.60 9.96 re f
+312.93 368.49 8.60 9.96 re f
+312.93 378.46 8.60 9.96 re f
+312.93 388.42 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+321.53 19.79 8.60 9.96 re f
+321.53 29.75 8.60 9.96 re f
+321.53 39.71 8.60 9.96 re f
+321.53 49.67 8.60 9.96 re f
+321.53 59.64 8.60 9.96 re f
+321.53 69.60 8.60 9.96 re f
+321.53 79.56 8.60 9.96 re f
+321.53 89.53 8.60 9.96 re f
+321.53 99.49 8.60 9.96 re f
+321.53 109.45 8.60 9.96 re f
+321.53 119.42 8.60 9.96 re f
+321.53 129.38 8.60 9.96 re f
+321.53 139.34 8.60 9.96 re f
+321.53 149.31 8.60 9.96 re f
+321.53 159.27 8.60 9.96 re f
+321.53 169.23 8.60 9.96 re f
+/sRGB cs 0.686 0.035 0.149 scn
+321.53 179.20 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+321.53 189.16 8.60 9.96 re f
+321.53 199.12 8.60 9.96 re f
+321.53 209.08 8.60 9.96 re f
+321.53 219.05 8.60 9.96 re f
+321.53 229.01 8.60 9.96 re f
+321.53 238.97 8.60 9.96 re f
+321.53 248.94 8.60 9.96 re f
+321.53 258.90 8.60 9.96 re f
+321.53 268.86 8.60 9.96 re f
+321.53 278.83 8.60 9.96 re f
+321.53 288.79 8.60 9.96 re f
+/sRGB cs 0.667 0.847 0.910 scn
+321.53 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+321.53 308.72 8.60 9.96 re f
+321.53 318.68 8.60 9.96 re f
+321.53 328.64 8.60 9.96 re f
+321.53 338.61 8.60 9.96 re f
+321.53 348.57 8.60 9.96 re f
+321.53 358.53 8.60 9.96 re f
+321.53 368.49 8.60 9.96 re f
+321.53 378.46 8.60 9.96 re f
+321.53 388.42 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+330.12 19.79 8.60 9.96 re f
+330.12 29.75 8.60 9.96 re f
+330.12 39.71 8.60 9.96 re f
+330.12 49.67 8.60 9.96 re f
+330.12 59.64 8.60 9.96 re f
+330.12 69.60 8.60 9.96 re f
+330.12 79.56 8.60 9.96 re f
+330.12 89.53 8.60 9.96 re f
+330.12 99.49 8.60 9.96 re f
+330.12 109.45 8.60 9.96 re f
+330.12 119.42 8.60 9.96 re f
+330.12 129.38 8.60 9.96 re f
+330.12 139.34 8.60 9.96 re f
+330.12 149.31 8.60 9.96 re f
+330.12 159.27 8.60 9.96 re f
+330.12 169.23 8.60 9.96 re f
+/sRGB cs 0.686 0.035 0.149 scn
+330.12 179.20 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+330.12 189.16 8.60 9.96 re f
+330.12 199.12 8.60 9.96 re f
+330.12 209.08 8.60 9.96 re f
+330.12 219.05 8.60 9.96 re f
+330.12 229.01 8.60 9.96 re f
+330.12 238.97 8.60 9.96 re f
+330.12 248.94 8.60 9.96 re f
+330.12 258.90 8.60 9.96 re f
+330.12 268.86 8.60 9.96 re f
+330.12 278.83 8.60 9.96 re f
+330.12 288.79 8.60 9.96 re f
+/sRGB cs 0.667 0.847 0.910 scn
+330.12 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+330.12 308.72 8.60 9.96 re f
+330.12 318.68 8.60 9.96 re f
+330.12 328.64 8.60 9.96 re f
+330.12 338.61 8.60 9.96 re f
+330.12 348.57 8.60 9.96 re f
+330.12 358.53 8.60 9.96 re f
+330.12 368.49 8.60 9.96 re f
+330.12 378.46 8.60 9.96 re f
+330.12 388.42 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+338.72 19.79 8.60 9.96 re f
+338.72 29.75 8.60 9.96 re f
+338.72 39.71 8.60 9.96 re f
+338.72 49.67 8.60 9.96 re f
+338.72 59.64 8.60 9.96 re f
+338.72 69.60 8.60 9.96 re f
+338.72 79.56 8.60 9.96 re f
+338.72 89.53 8.60 9.96 re f
+338.72 99.49 8.60 9.96 re f
+338.72 109.45 8.60 9.96 re f
+338.72 119.42 8.60 9.96 re f
+338.72 129.38 8.60 9.96 re f
+338.72 139.34 8.60 9.96 re f
+338.72 149.31 8.60 9.96 re f
+338.72 159.27 8.60 9.96 re f
+338.72 169.23 8.60 9.96 re f
+/sRGB cs 0.686 0.035 0.149 scn
+338.72 179.20 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+338.72 189.16 8.60 9.96 re f
+338.72 199.12 8.60 9.96 re f
+338.72 209.08 8.60 9.96 re f
+338.72 219.05 8.60 9.96 re f
+338.72 229.01 8.60 9.96 re f
+338.72 238.97 8.60 9.96 re f
+338.72 248.94 8.60 9.96 re f
+338.72 258.90 8.60 9.96 re f
+338.72 268.86 8.60 9.96 re f
+338.72 278.83 8.60 9.96 re f
+338.72 288.79 8.60 9.96 re f
+/sRGB cs 0.667 0.847 0.910 scn
+338.72 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+338.72 308.72 8.60 9.96 re f
+338.72 318.68 8.60 9.96 re f
+338.72 328.64 8.60 9.96 re f
+338.72 338.61 8.60 9.96 re f
+338.72 348.57 8.60 9.96 re f
+338.72 358.53 8.60 9.96 re f
+338.72 368.49 8.60 9.96 re f
+338.72 378.46 8.60 9.96 re f
+338.72 388.42 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+347.32 19.79 8.60 9.96 re f
+347.32 29.75 8.60 9.96 re f
+347.32 39.71 8.60 9.96 re f
+347.32 49.67 8.60 9.96 re f
+347.32 59.64 8.60 9.96 re f
+347.32 69.60 8.60 9.96 re f
+347.32 79.56 8.60 9.96 re f
+347.32 89.53 8.60 9.96 re f
+347.32 99.49 8.60 9.96 re f
+347.32 109.45 8.60 9.96 re f
+347.32 119.42 8.60 9.96 re f
+347.32 129.38 8.60 9.96 re f
+347.32 139.34 8.60 9.96 re f
+347.32 149.31 8.60 9.96 re f
+347.32 159.27 8.60 9.96 re f
+347.32 169.23 8.60 9.96 re f
+/sRGB cs 0.686 0.035 0.149 scn
+347.32 179.20 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+347.32 189.16 8.60 9.96 re f
+347.32 199.12 8.60 9.96 re f
+347.32 209.08 8.60 9.96 re f
+347.32 219.05 8.60 9.96 re f
+347.32 229.01 8.60 9.96 re f
+347.32 238.97 8.60 9.96 re f
+347.32 248.94 8.60 9.96 re f
+347.32 258.90 8.60 9.96 re f
+347.32 268.86 8.60 9.96 re f
+347.32 278.83 8.60 9.96 re f
+347.32 288.79 8.60 9.96 re f
+/sRGB cs 0.667 0.847 0.910 scn
+347.32 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+347.32 308.72 8.60 9.96 re f
+347.32 318.68 8.60 9.96 re f
+347.32 328.64 8.60 9.96 re f
+347.32 338.61 8.60 9.96 re f
+347.32 348.57 8.60 9.96 re f
+347.32 358.53 8.60 9.96 re f
+347.32 368.49 8.60 9.96 re f
+347.32 378.46 8.60 9.96 re f
+347.32 388.42 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+355.92 19.79 8.60 9.96 re f
+355.92 29.75 8.60 9.96 re f
+355.92 39.71 8.60 9.96 re f
+355.92 49.67 8.60 9.96 re f
+355.92 59.64 8.60 9.96 re f
+355.92 69.60 8.60 9.96 re f
+355.92 79.56 8.60 9.96 re f
+355.92 89.53 8.60 9.96 re f
+355.92 99.49 8.60 9.96 re f
+355.92 109.45 8.60 9.96 re f
+355.92 119.42 8.60 9.96 re f
+355.92 129.38 8.60 9.96 re f
+355.92 139.34 8.60 9.96 re f
+355.92 149.31 8.60 9.96 re f
+355.92 159.27 8.60 9.96 re f
+355.92 169.23 8.60 9.96 re f
+/sRGB cs 0.686 0.035 0.149 scn
+355.92 179.20 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+355.92 189.16 8.60 9.96 re f
+355.92 199.12 8.60 9.96 re f
+355.92 209.08 8.60 9.96 re f
+355.92 219.05 8.60 9.96 re f
+355.92 229.01 8.60 9.96 re f
+355.92 238.97 8.60 9.96 re f
+355.92 248.94 8.60 9.96 re f
+355.92 258.90 8.60 9.96 re f
+355.92 268.86 8.60 9.96 re f
+355.92 278.83 8.60 9.96 re f
+355.92 288.79 8.60 9.96 re f
+/sRGB cs 0.667 0.847 0.910 scn
+355.92 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+355.92 308.72 8.60 9.96 re f
+355.92 318.68 8.60 9.96 re f
+355.92 328.64 8.60 9.96 re f
+355.92 338.61 8.60 9.96 re f
+355.92 348.57 8.60 9.96 re f
+355.92 358.53 8.60 9.96 re f
+355.92 368.49 8.60 9.96 re f
+355.92 378.46 8.60 9.96 re f
+355.92 388.42 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+364.51 19.79 8.60 9.96 re f
+364.51 29.75 8.60 9.96 re f
+364.51 39.71 8.60 9.96 re f
+364.51 49.67 8.60 9.96 re f
+364.51 59.64 8.60 9.96 re f
+364.51 69.60 8.60 9.96 re f
+364.51 79.56 8.60 9.96 re f
+364.51 89.53 8.60 9.96 re f
+364.51 99.49 8.60 9.96 re f
+364.51 109.45 8.60 9.96 re f
+364.51 119.42 8.60 9.96 re f
+364.51 129.38 8.60 9.96 re f
+364.51 139.34 8.60 9.96 re f
+364.51 149.31 8.60 9.96 re f
+364.51 159.27 8.60 9.96 re f
+364.51 169.23 8.60 9.96 re f
+/sRGB cs 0.686 0.035 0.149 scn
+364.51 179.20 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+364.51 189.16 8.60 9.96 re f
+364.51 199.12 8.60 9.96 re f
+364.51 209.08 8.60 9.96 re f
+364.51 219.05 8.60 9.96 re f
+364.51 229.01 8.60 9.96 re f
+364.51 238.97 8.60 9.96 re f
+364.51 248.94 8.60 9.96 re f
+364.51 258.90 8.60 9.96 re f
+364.51 268.86 8.60 9.96 re f
+364.51 278.83 8.60 9.96 re f
+364.51 288.79 8.60 9.96 re f
+/sRGB cs 0.667 0.847 0.910 scn
+364.51 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+364.51 308.72 8.60 9.96 re f
+364.51 318.68 8.60 9.96 re f
+364.51 328.64 8.60 9.96 re f
+364.51 338.61 8.60 9.96 re f
+364.51 348.57 8.60 9.96 re f
+364.51 358.53 8.60 9.96 re f
+364.51 368.49 8.60 9.96 re f
+364.51 378.46 8.60 9.96 re f
+364.51 388.42 8.60 9.96 re f
+/sRGB cs 0.647 0.000 0.149 scn
+373.11 19.79 8.60 9.96 re f
+373.11 29.75 8.60 9.96 re f
+373.11 39.71 8.60 9.96 re f
+373.11 49.67 8.60 9.96 re f
+373.11 59.64 8.60 9.96 re f
+373.11 69.60 8.60 9.96 re f
+373.11 79.56 8.60 9.96 re f
+373.11 89.53 8.60 9.96 re f
+373.11 99.49 8.60 9.96 re f
+373.11 109.45 8.60 9.96 re f
+373.11 119.42 8.60 9.96 re f
+373.11 129.38 8.60 9.96 re f
+373.11 139.34 8.60 9.96 re f
+373.11 149.31 8.60 9.96 re f
+373.11 159.27 8.60 9.96 re f
+373.11 169.23 8.60 9.96 re f
+/sRGB cs 0.686 0.035 0.149 scn
+373.11 179.20 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+373.11 189.16 8.60 9.96 re f
+373.11 199.12 8.60 9.96 re f
+373.11 209.08 8.60 9.96 re f
+373.11 219.05 8.60 9.96 re f
+373.11 229.01 8.60 9.96 re f
+373.11 238.97 8.60 9.96 re f
+373.11 248.94 8.60 9.96 re f
+373.11 258.90 8.60 9.96 re f
+373.11 268.86 8.60 9.96 re f
+373.11 278.83 8.60 9.96 re f
+373.11 288.79 8.60 9.96 re f
+/sRGB cs 0.667 0.847 0.910 scn
+373.11 298.75 8.60 9.96 re f
+/sRGB cs 0.192 0.212 0.584 scn
+373.11 308.72 8.60 9.96 re f
+373.11 318.68 8.60 9.96 re f
+373.11 328.64 8.60 9.96 re f
+373.11 338.61 8.60 9.96 re f
+373.11 348.57 8.60 9.96 re f
+373.11 358.53 8.60 9.96 re f
+373.11 368.49 8.60 9.96 re f
+373.11 378.46 8.60 9.96 re f
+373.11 388.42 8.60 9.96 re f
+Q q
+Q q
+BT
+/sRGB cs 0.000 0.000 0.000 scn
+/F2 1 Tf 0.00 -5.00 5.00 0.00 57.50 14.79 Tm (27) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 66.10 14.79 Tm (26) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 74.70 14.79 Tm (25) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 83.30 14.79 Tm (24) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 91.89 14.79 Tm (23) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 100.49 14.79 Tm (22) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 109.09 14.79 Tm (21) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 117.69 14.79 Tm (10) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 126.28 14.79 Tm (20) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 134.88 14.79 Tm (6) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 143.48 14.79 Tm (38) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 152.08 14.79 Tm (37) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 160.68 14.79 Tm (36) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 169.27 14.79 Tm (35) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 177.87 14.79 Tm (34) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 186.47 14.79 Tm (33) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 195.07 14.79 Tm (32) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 203.66 14.79 Tm (31) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 212.26 14.79 Tm (30) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 220.86 14.79 Tm (28) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 229.46 14.79 Tm (29) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 238.05 14.79 Tm (17) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 246.65 14.79 Tm (19) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 255.25 14.79 Tm (18) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 263.85 14.79 Tm (16) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 272.44 14.79 Tm (15) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 281.04 14.79 Tm (14) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 289.64 14.79 Tm (13) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 298.24 14.79 Tm (12) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 306.83 14.79 Tm (11) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 315.43 14.79 Tm (9) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 324.03 14.79 Tm (8) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 332.63 14.79 Tm (7) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 341.23 14.79 Tm (5) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 349.82 14.79 Tm (4) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 358.42 14.79 Tm (3) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 367.02 14.79 Tm (1) Tj
+ET
+BT
+/F2 1 Tf 0.00 -5.00 5.00 0.00 375.62 14.79 Tm (2) Tj
+ET
+Q q
+Q q
+BT
+/sRGB cs 0.000 0.000 0.000 scn
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 22.61 Tm (2) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 32.58 Tm (1) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 42.54 Tm (3) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 52.50 Tm (4) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 62.47 Tm (5) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 72.43 Tm (7) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 82.39 Tm (8) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 92.35 Tm (9) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 102.32 Tm (11) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 112.28 Tm (12) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 122.24 Tm (13) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 132.21 Tm (14) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 142.17 Tm (15) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 152.13 Tm (16) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 162.10 Tm (18) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 172.06 Tm (19) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 182.02 Tm (17) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 191.99 Tm (29) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 201.95 Tm (28) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 211.91 Tm (30) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 221.88 Tm (31) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 231.84 Tm (32) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 241.80 Tm (33) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 251.76 Tm (34) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 261.73 Tm (35) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 271.69 Tm (36) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 281.65 Tm (37) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 291.62 Tm (38) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 301.58 Tm (6) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 311.54 Tm (20) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 321.51 Tm (10) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 331.47 Tm (21) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 341.43 Tm (22) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 351.40 Tm (23) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 361.36 Tm (24) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 371.32 Tm (25) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 381.29 Tm (26) Tj
+ET
+BT
+/F2 1 Tf 6.00 0.00 -0.00 6.00 386.71 391.25 Tm (27) Tj
+ET
+Q q
+Q q
+/sRGB cs 0.616 0.624 1.000 scn
+55.00 400.38 8.60 8.00 re f
+/sRGB cs 0.827 0.545 1.000 scn
+55.00 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+63.60 400.38 8.60 8.00 re f
+/sRGB cs 0.827 0.545 1.000 scn
+63.60 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+72.20 400.38 8.60 8.00 re f
+/sRGB cs 0.827 0.545 1.000 scn
+72.20 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+80.79 400.38 8.60 8.00 re f
+/sRGB cs 0.827 0.545 1.000 scn
+80.79 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+89.39 400.38 8.60 8.00 re f
+/sRGB cs 0.827 0.545 1.000 scn
+89.39 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+97.99 400.38 8.60 8.00 re f
+/sRGB cs 0.827 0.545 1.000 scn
+97.99 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+106.59 400.38 8.60 8.00 re f
+/sRGB cs 0.827 0.545 1.000 scn
+106.59 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+115.18 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+115.18 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+123.78 400.38 8.60 8.00 re f
+/sRGB cs 0.827 0.545 1.000 scn
+123.78 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+132.38 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+132.38 410.38 8.60 8.00 re f
+/sRGB cs 0.961 0.482 1.000 scn
+140.98 400.38 8.60 8.00 re f
+149.57 400.38 8.60 8.00 re f
+158.17 400.38 8.60 8.00 re f
+166.77 400.38 8.60 8.00 re f
+175.37 400.38 8.60 8.00 re f
+183.96 400.38 8.60 8.00 re f
+192.56 400.38 8.60 8.00 re f
+201.16 400.38 8.60 8.00 re f
+209.76 400.38 8.60 8.00 re f
+218.35 400.38 8.60 8.00 re f
+226.95 400.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+235.55 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+235.55 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+244.15 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+244.15 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+252.75 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+252.75 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+261.34 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+261.34 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+269.94 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+269.94 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+278.54 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+278.54 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+287.14 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+287.14 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+295.73 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+295.73 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+304.33 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+304.33 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+312.93 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+312.93 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+321.53 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+321.53 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+330.12 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+330.12 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+338.72 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+338.72 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+347.32 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+347.32 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+355.92 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+355.92 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+364.51 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+364.51 410.38 8.60 8.00 re f
+/sRGB cs 0.616 0.624 1.000 scn
+373.11 400.38 8.60 8.00 re f
+/sRGB cs 0.227 0.694 1.000 scn
+373.11 410.38 8.60 8.00 re f
+Q q
+Q q
+BT
+/sRGB cs 0.000 0.000 0.000 scn
+/F3 1 Tf 10.00 0.00 -0.00 10.00 455.12 391.20 Tm (ALL.AML) Tj
+ET
+/sRGB cs 0.616 0.624 1.000 scn
+455.12 380.43 7.18 7.18 re f
+BT
+/sRGB cs 0.000 0.000 0.000 scn
+/F2 1 Tf 10.00 0.00 -0.00 10.00 464.45 380.43 Tm (ALL) Tj
+ET
+/sRGB cs 0.961 0.482 1.000 scn
+455.12 369.66 7.18 7.18 re f
+BT
+/sRGB cs 0.000 0.000 0.000 scn
+/F2 1 Tf 10.00 0.00 -0.00 10.00 464.45 369.66 Tm (AML) Tj
+ET
+BT
+/F3 1 Tf 10.00 0.00 -0.00 10.00 455.12 348.12 Tm (Cell) Tj
+ET
+/sRGB cs 0.227 0.694 1.000 scn
+455.12 337.35 7.18 7.18 re f
+BT
+/sRGB cs 0.000 0.000 0.000 scn
+/F2 1 Tf 10.00 0.00 -0.00 10.00 464.45 337.35 Tm (B-cell) Tj
+ET
+/sRGB cs 0.827 0.545 1.000 scn
+455.12 326.58 7.18 7.18 re f
+BT
+/sRGB cs 0.000 0.000 0.000 scn
+/F2 1 Tf 10.00 0.00 -0.00 10.00 464.45 326.58 Tm (T-cell) Tj
+ET
+Q q
+Q q
+/sRGB cs 0.192 0.212 0.584 scn
+402.38 248.38 10.00 2.94 re f
+/sRGB cs 0.208 0.259 0.608 scn
+402.38 251.33 10.00 2.94 re f
+/sRGB cs 0.220 0.310 0.631 scn
+402.38 254.27 10.00 2.94 re f
+/sRGB cs 0.235 0.357 0.655 scn
+402.38 257.21 10.00 2.94 re f
+/sRGB cs 0.255 0.408 0.678 scn
+402.38 260.15 10.00 2.94 re f
+/sRGB cs 0.271 0.459 0.706 scn
+402.38 263.09 10.00 2.94 re f
+/sRGB cs 0.306 0.502 0.725 scn
+402.38 266.03 10.00 2.94 re f
+/sRGB cs 0.341 0.545 0.749 scn
+402.38 268.97 10.00 2.94 re f
+/sRGB cs 0.380 0.588 0.773 scn
+402.38 271.91 10.00 2.94 re f
+/sRGB cs 0.416 0.631 0.796 scn
+402.38 274.85 10.00 2.94 re f
+/sRGB cs 0.455 0.678 0.820 scn
+402.38 277.80 10.00 2.94 re f
+/sRGB cs 0.494 0.710 0.835 scn
+402.38 280.74 10.00 2.94 re f
+/sRGB cs 0.537 0.745 0.855 scn
+402.38 283.68 10.00 2.94 re f
+/sRGB cs 0.580 0.780 0.875 scn
+402.38 286.62 10.00 2.94 re f
+/sRGB cs 0.627 0.816 0.894 scn
+402.38 289.56 10.00 2.94 re f
+/sRGB cs 0.667 0.847 0.910 scn
+402.38 292.50 10.00 2.94 re f
+/sRGB cs 0.710 0.871 0.922 scn
+402.38 295.44 10.00 2.94 re f
+/sRGB cs 0.753 0.890 0.937 scn
+402.38 298.38 10.00 2.94 re f
+/sRGB cs 0.792 0.910 0.949 scn
+402.38 301.33 10.00 2.94 re f
+/sRGB cs 0.835 0.929 0.957 scn
+402.38 304.27 10.00 2.94 re f
+/sRGB cs 0.878 0.953 0.973 scn
+402.38 307.21 10.00 2.94 re f
+/sRGB cs 0.902 0.961 0.925 scn
+402.38 310.15 10.00 2.94 re f
+/sRGB cs 0.925 0.969 0.882 scn
+402.38 313.09 10.00 2.94 re f
+/sRGB cs 0.949 0.980 0.835 scn
+402.38 316.03 10.00 2.94 re f
+/sRGB cs 0.973 0.988 0.792 scn
+402.38 318.97 10.00 2.94 re f
+/sRGB cs 1.000 1.000 0.749 scn
+402.38 321.91 10.00 2.94 re f
+/sRGB cs 0.996 0.973 0.710 scn
+402.38 324.85 10.00 2.94 re f
+/sRGB cs 0.996 0.949 0.675 scn
+402.38 327.80 10.00 2.94 re f
+/sRGB cs 0.996 0.925 0.635 scn
+402.38 330.74 10.00 2.94 re f
+/sRGB cs 0.996 0.902 0.600 scn
+402.38 333.68 10.00 2.94 re f
+/sRGB cs 0.996 0.878 0.565 scn
+402.38 336.62 10.00 2.94 re f
+/sRGB cs 0.992 0.839 0.525 scn
+402.38 339.56 10.00 2.94 re f
+/sRGB cs 0.992 0.800 0.490 scn
+402.38 342.50 10.00 2.94 re f
+/sRGB cs 0.992 0.761 0.451 scn
+402.38 345.44 10.00 2.94 re f
+/sRGB cs 0.992 0.722 0.416 scn
+402.38 348.38 10.00 2.94 re f
+/sRGB cs 0.992 0.682 0.380 scn
+402.38 351.33 10.00 2.94 re f
+/sRGB cs 0.984 0.631 0.357 scn
+402.38 354.27 10.00 2.94 re f
+/sRGB cs 0.976 0.580 0.333 scn
+402.38 357.21 10.00 2.94 re f
+/sRGB cs 0.969 0.529 0.310 scn
+402.38 360.15 10.00 2.94 re f
+/sRGB cs 0.961 0.478 0.286 scn
+402.38 363.09 10.00 2.94 re f
+/sRGB cs 0.957 0.427 0.263 scn
+402.38 366.03 10.00 2.94 re f
+/sRGB cs 0.933 0.376 0.239 scn
+402.38 368.97 10.00 2.94 re f
+/sRGB cs 0.910 0.329 0.216 scn
+402.38 371.91 10.00 2.94 re f
+/sRGB cs 0.886 0.282 0.196 scn
+402.38 374.85 10.00 2.94 re f
+/sRGB cs 0.863 0.235 0.173 scn
+402.38 377.80 10.00 2.94 re f
+/sRGB cs 0.843 0.188 0.153 scn
+402.38 380.74 10.00 2.94 re f
+/sRGB cs 0.800 0.149 0.149 scn
+402.38 383.68 10.00 2.94 re f
+/sRGB cs 0.765 0.110 0.149 scn
+402.38 386.62 10.00 2.94 re f
+/sRGB cs 0.725 0.075 0.149 scn
+402.38 389.56 10.00 2.94 re f
+/sRGB cs 0.686 0.035 0.149 scn
+402.38 392.50 10.00 2.94 re f
+/sRGB cs 0.647 0.000 0.149 scn
+402.38 395.44 10.00 2.94 re f
+BT
+/sRGB cs 0.000 0.000 0.000 scn
+/F2 1 Tf 10.00 0.00 -0.00 10.00 414.38 244.79 Tm (0) Tj
+ET
+BT
+/F2 1 Tf 10.00 0.00 -0.00 10.00 414.38 274.79 Tm (0.2) Tj
+ET
+BT
+/F2 1 Tf 10.00 0.00 -0.00 10.00 414.38 304.79 Tm (0.4) Tj
+ET
+BT
+/F2 1 Tf 10.00 0.00 -0.00 10.00 414.38 334.79 Tm (0.6) Tj
+ET
+BT
+/F2 1 Tf 10.00 0.00 -0.00 10.00 414.38 364.79 Tm (0.8) Tj
+ET
+BT
+/F2 1 Tf 10.00 0.00 -0.00 10.00 414.38 394.79 Tm (1) Tj
+ET
+Q q
+Q q
+Q q
+BT
+/sRGB cs 0.000 0.000 0.000 scn
+/F3 1 Tf 12.00 0.00 -0.00 12.00 166.34 485.38 Tm (Consensus matrix) Tj
+ET
+Q q
+Q q
+Q q
+Q
+endstream
+endobj
+9 0 obj
+68611
+endobj
+3 0 obj
+<<
+/Type /Pages
+/Kids [
+7 0 R
+]
+/Count 1
+/MediaBox [0 0 504 503]
+>>
+endobj
+4 0 obj
+<<
+/ProcSet [/PDF /Text]
+/Font <</F2 11 0 R /F3 12 0 R >>
+/ExtGState << >>
+/ColorSpace << /sRGB 5 0 R >>
+>>
+endobj
+5 0 obj
+[/ICCBased 6 0 R]
+endobj
+6 0 obj
+<< /N 3 /Alternate /DeviceRGB /Length 9433 /Filter /ASCIIHexDecode >>
+stream
+00 00 0c 48 4c 69 6e 6f 02 10 00 00 6d 6e 74 72
+52 47 42 20 58 59 5a 20 07 ce 00 02 00 09 00 06
+00 31 00 00 61 63 73 70 4d 53 46 54 00 00 00 00
+49 45 43 20 73 52 47 42 00 00 00 00 00 00 00 00
+00 00 00 00 00 00 f6 d6 00 01 00 00 00 00 d3 2d
+48 50 20 20 00 00 00 00 00 00 00 00 00 00 00 00
+00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
+00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
+00 00 00 11 63 70 72 74 00 00 01 50 00 00 00 33
+64 65 73 63 00 00 01 84 00 00 00 6c 77 74 70 74
+00 00 01 f0 00 00 00 14 62 6b 70 74 00 00 02 04
+00 00 00 14 72 58 59 5a 00 00 02 18 00 00 00 14
+67 58 59 5a 00 00 02 2c 00 00 00 14 62 58 59 5a
+00 00 02 40 00 00 00 14 64 6d 6e 64 00 00 02 54
+00 00 00 70 64 6d 64 64 00 00 02 c4 00 00 00 88
+76 75 65 64 00 00 03 4c 00 00 00 86 76 69 65 77
+00 00 03 d4 00 00 00 24 6c 75 6d 69 00 00 03 f8
+00 00 00 14 6d 65 61 73 00 00 04 0c 00 00 00 24
+74 65 63 68 00 00 04 30 00 00 00 0c 72 54 52 43
+00 00 04 3c 00 00 08 0c 67 54 52 43 00 00 04 3c
+00 00 08 0c 62 54 52 43 00 00 04 3c 00 00 08 0c
+74 65 78 74 00 00 00 00 43 6f 70 79 72 69 67 68
+74 20 28 63 29 20 31 39 39 38 20 48 65 77 6c 65
+74 74 2d 50 61 63 6b 61 72 64 20 43 6f 6d 70 61
+6e 79 00 00 64 65 73 63 00 00 00 00 00 00 00 12
+73 52 47 42 20 49 45 43 36 31 39 36 36 2d 32 2e
+31 00 00 00 00 00 00 00 00 00 00 00 12 73 52 47
+42 20 49 45 43 36 31 39 36 36 2d 32 2e 31 00 00
+00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
+00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
+00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
+58 59 5a 20 00 00 00 00 00 00 f3 51 00 01 00 00
+00 01 16 cc 58 59 5a 20 00 00 00 00 00 00 00 00
+00 00 00 00 00 00 00 00 58 59 5a 20 00 00 00 00
+00 00 6f a2 00 00 38 f5 00 00 03 90 58 59 5a 20
+00 00 00 00 00 00 62 99 00 00 b7 85 00 00 18 da
+58 59 5a 20 00 00 00 00 00 00 24 a0 00 00 0f 84
+00 00 b6 cf 64 65 73 63 00 00 00 00 00 00 00 16
+49 45 43 20 68 74 74 70 3a 2f 2f 77 77 77 2e 69
+65 63 2e 63 68 00 00 00 00 00 00 00 00 00 00 00
+16 49 45 43 20 68 74 74 70 3a 2f 2f 77 77 77 2e
+69 65 63 2e 63 68 00 00 00 00 00 00 00 00 00 00
+00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
+00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
+00 00 00 00 64 65 73 63 00 00 00 00 00 00 00 2e
+49 45 43 20 36 31 39 36 36 2d 32 2e 31 20 44 65
+66 61 75 6c 74 20 52 47 42 20 63 6f 6c 6f 75 72
+20 73 70 61 63 65 20 2d 20 73 52 47 42 00 00 00
+00 00 00 00 00 00 00 00 2e 49 45 43 20 36 31 39
+36 36 2d 32 2e 31 20 44 65 66 61 75 6c 74 20 52
+47 42 20 63 6f 6c 6f 75 72 20 73 70 61 63 65 20
+2d 20 73 52 47 42 00 00 00 00 00 00 00 00 00 00
+00 00 00 00 00 00 00 00 00 00 00 00 64 65 73 63
+00 00 00 00 00 00 00 2c 52 65 66 65 72 65 6e 63
+65 20 56 69 65 77 69 6e 67 20 43 6f 6e 64 69 74
+69 6f 6e 20 69 6e 20 49 45 43 36 31 39 36 36 2d
+32 2e 31 00 00 00 00 00 00 00 00 00 00 00 2c 52
+65 66 65 72 65 6e 63 65 20 56 69 65 77 69 6e 67
+20 43 6f 6e 64 69 74 69 6f 6e 20 69 6e 20 49 45
+43 36 31 39 36 36 2d 32 2e 31 00 00 00 00 00 00
+00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
+00 00 00 00 76 69 65 77 00 00 00 00 00 13 a4 fe
+00 14 5f 2e 00 10 cf 14 00 03 ed cc 00 04 13 0b
+00 03 5c 9e 00 00 00 01 58 59 5a 20 00 00 00 00
+00 4c 09 56 00 50 00 00 00 57 1f e7 6d 65 61 73
+00 00 00 00 00 00 00 01 00 00 00 00 00 00 00 00
+00 00 00 00 00 00 00 00 00 00 02 8f 00 00 00 02
+73 69 67 20 00 00 00 00 43 52 54 20 63 75 72 76
+00 00 00 00 00 00 04 00 00 00 00 05 00 0a 00 0f
+00 14 00 19 00 1e 00 23 00 28 00 2d 00 32 00 37
+00 3b 00 40 00 45 00 4a 00 4f 00 54 00 59 00 5e
+00 63 00 68 00 6d 00 72 00 77 00 7c 00 81 00 86
+00 8b 00 90 00 95 00 9a 00 9f 00 a4 00 a9 00 ae
+00 b2 00 b7 00 bc 00 c1 00 c6 00 cb 00 d0 00 d5
+00 db 00 e0 00 e5 00 eb 00 f0 00 f6 00 fb 01 01
+01 07 01 0d 01 13 01 19 01 1f 01 25 01 2b 01 32
+01 38 01 3e 01 45 01 4c 01 52 01 59 01 60 01 67
+01 6e 01 75 01 7c 01 83 01 8b 01 92 01 9a 01 a1
+01 a9 01 b1 01 b9 01 c1 01 c9 01 d1 01 d9 01 e1
+01 e9 01 f2 01 fa 02 03 02 0c 02 14 02 1d 02 26
+02 2f 02 38 02 41 02 4b 02 54 02 5d 02 67 02 71
+02 7a 02 84 02 8e 02 98 02 a2 02 ac 02 b6 02 c1
+02 cb 02 d5 02 e0 02 eb 02 f5 03 00 03 0b 03 16
+03 21 03 2d 03 38 03 43 03 4f 03 5a 03 66 03 72
+03 7e 03 8a 03 96 03 a2 03 ae 03 ba 03 c7 03 d3
+03 e0 03 ec 03 f9 04 06 04 13 04 20 04 2d 04 3b
+04 48 04 55 04 63 04 71 04 7e 04 8c 04 9a 04 a8
+04 b6 04 c4 04 d3 04 e1 04 f0 04 fe 05 0d 05 1c
+05 2b 05 3a 05 49 05 58 05 67 05 77 05 86 05 96
+05 a6 05 b5 05 c5 05 d5 05 e5 05 f6 06 06 06 16
+06 27 06 37 06 48 06 59 06 6a 06 7b 06 8c 06 9d
+06 af 06 c0 06 d1 06 e3 06 f5 07 07 07 19 07 2b
+07 3d 07 4f 07 61 07 74 07 86 07 99 07 ac 07 bf
+07 d2 07 e5 07 f8 08 0b 08 1f 08 32 08 46 08 5a
+08 6e 08 82 08 96 08 aa 08 be 08 d2 08 e7 08 fb
+09 10 09 25 09 3a 09 4f 09 64 09 79 09 8f 09 a4
+09 ba 09 cf 09 e5 09 fb 0a 11 0a 27 0a 3d 0a 54
+0a 6a 0a 81 0a 98 0a ae 0a c5 0a dc 0a f3 0b 0b
+0b 22 0b 39 0b 51 0b 69 0b 80 0b 98 0b b0 0b c8
+0b e1 0b f9 0c 12 0c 2a 0c 43 0c 5c 0c 75 0c 8e
+0c a7 0c c0 0c d9 0c f3 0d 0d 0d 26 0d 40 0d 5a
+0d 74 0d 8e 0d a9 0d c3 0d de 0d f8 0e 13 0e 2e
+0e 49 0e 64 0e 7f 0e 9b 0e b6 0e d2 0e ee 0f 09
+0f 25 0f 41 0f 5e 0f 7a 0f 96 0f b3 0f cf 0f ec
+10 09 10 26 10 43 10 61 10 7e 10 9b 10 b9 10 d7
+10 f5 11 13 11 31 11 4f 11 6d 11 8c 11 aa 11 c9
+11 e8 12 07 12 26 12 45 12 64 12 84 12 a3 12 c3
+12 e3 13 03 13 23 13 43 13 63 13 83 13 a4 13 c5
+13 e5 14 06 14 27 14 49 14 6a 14 8b 14 ad 14 ce
+14 f0 15 12 15 34 15 56 15 78 15 9b 15 bd 15 e0
+16 03 16 26 16 49 16 6c 16 8f 16 b2 16 d6 16 fa
+17 1d 17 41 17 65 17 89 17 ae 17 d2 17 f7 18 1b
+18 40 18 65 18 8a 18 af 18 d5 18 fa 19 20 19 45
+19 6b 19 91 19 b7 19 dd 1a 04 1a 2a 1a 51 1a 77
+1a 9e 1a c5 1a ec 1b 14 1b 3b 1b 63 1b 8a 1b b2
+1b da 1c 02 1c 2a 1c 52 1c 7b 1c a3 1c cc 1c f5
+1d 1e 1d 47 1d 70 1d 99 1d c3 1d ec 1e 16 1e 40
+1e 6a 1e 94 1e be 1e e9 1f 13 1f 3e 1f 69 1f 94
+1f bf 1f ea 20 15 20 41 20 6c 20 98 20 c4 20 f0
+21 1c 21 48 21 75 21 a1 21 ce 21 fb 22 27 22 55
+22 82 22 af 22 dd 23 0a 23 38 23 66 23 94 23 c2
+23 f0 24 1f 24 4d 24 7c 24 ab 24 da 25 09 25 38
+25 68 25 97 25 c7 25 f7 26 27 26 57 26 87 26 b7
+26 e8 27 18 27 49 27 7a 27 ab 27 dc 28 0d 28 3f
+28 71 28 a2 28 d4 29 06 29 38 29 6b 29 9d 29 d0
+2a 02 2a 35 2a 68 2a 9b 2a cf 2b 02 2b 36 2b 69
+2b 9d 2b d1 2c 05 2c 39 2c 6e 2c a2 2c d7 2d 0c
+2d 41 2d 76 2d ab 2d e1 2e 16 2e 4c 2e 82 2e b7
+2e ee 2f 24 2f 5a 2f 91 2f c7 2f fe 30 35 30 6c
+30 a4 30 db 31 12 31 4a 31 82 31 ba 31 f2 32 2a
+32 63 32 9b 32 d4 33 0d 33 46 33 7f 33 b8 33 f1
+34 2b 34 65 34 9e 34 d8 35 13 35 4d 35 87 35 c2
+35 fd 36 37 36 72 36 ae 36 e9 37 24 37 60 37 9c
+37 d7 38 14 38 50 38 8c 38 c8 39 05 39 42 39 7f
+39 bc 39 f9 3a 36 3a 74 3a b2 3a ef 3b 2d 3b 6b
+3b aa 3b e8 3c 27 3c 65 3c a4 3c e3 3d 22 3d 61
+3d a1 3d e0 3e 20 3e 60 3e a0 3e e0 3f 21 3f 61
+3f a2 3f e2 40 23 40 64 40 a6 40 e7 41 29 41 6a
+41 ac 41 ee 42 30 42 72 42 b5 42 f7 43 3a 43 7d
+43 c0 44 03 44 47 44 8a 44 ce 45 12 45 55 45 9a
+45 de 46 22 46 67 46 ab 46 f0 47 35 47 7b 47 c0
+48 05 48 4b 48 91 48 d7 49 1d 49 63 49 a9 49 f0
+4a 37 4a 7d 4a c4 4b 0c 4b 53 4b 9a 4b e2 4c 2a
+4c 72 4c ba 4d 02 4d 4a 4d 93 4d dc 4e 25 4e 6e
+4e b7 4f 00 4f 49 4f 93 4f dd 50 27 50 71 50 bb
+51 06 51 50 51 9b 51 e6 52 31 52 7c 52 c7 53 13
+53 5f 53 aa 53 f6 54 42 54 8f 54 db 55 28 55 75
+55 c2 56 0f 56 5c 56 a9 56 f7 57 44 57 92 57 e0
+58 2f 58 7d 58 cb 59 1a 59 69 59 b8 5a 07 5a 56
+5a a6 5a f5 5b 45 5b 95 5b e5 5c 35 5c 86 5c d6
+5d 27 5d 78 5d c9 5e 1a 5e 6c 5e bd 5f 0f 5f 61
+5f b3 60 05 60 57 60 aa 60 fc 61 4f 61 a2 61 f5
+62 49 62 9c 62 f0 63 43 63 97 63 eb 64 40 64 94
+64 e9 65 3d 65 92 65 e7 66 3d 66 92 66 e8 67 3d
+67 93 67 e9 68 3f 68 96 68 ec 69 43 69 9a 69 f1
+6a 48 6a 9f 6a f7 6b 4f 6b a7 6b ff 6c 57 6c af
+6d 08 6d 60 6d b9 6e 12 6e 6b 6e c4 6f 1e 6f 78
+6f d1 70 2b 70 86 70 e0 71 3a 71 95 71 f0 72 4b
+72 a6 73 01 73 5d 73 b8 74 14 74 70 74 cc 75 28
+75 85 75 e1 76 3e 76 9b 76 f8 77 56 77 b3 78 11
+78 6e 78 cc 79 2a 79 89 79 e7 7a 46 7a a5 7b 04
+7b 63 7b c2 7c 21 7c 81 7c e1 7d 41 7d a1 7e 01
+7e 62 7e c2 7f 23 7f 84 7f e5 80 47 80 a8 81 0a
+81 6b 81 cd 82 30 82 92 82 f4 83 57 83 ba 84 1d
+84 80 84 e3 85 47 85 ab 86 0e 86 72 86 d7 87 3b
+87 9f 88 04 88 69 88 ce 89 33 89 99 89 fe 8a 64
+8a ca 8b 30 8b 96 8b fc 8c 63 8c ca 8d 31 8d 98
+8d ff 8e 66 8e ce 8f 36 8f 9e 90 06 90 6e 90 d6
+91 3f 91 a8 92 11 92 7a 92 e3 93 4d 93 b6 94 20
+94 8a 94 f4 95 5f 95 c9 96 34 96 9f 97 0a 97 75
+97 e0 98 4c 98 b8 99 24 99 90 99 fc 9a 68 9a d5
+9b 42 9b af 9c 1c 9c 89 9c f7 9d 64 9d d2 9e 40
+9e ae 9f 1d 9f 8b 9f fa a0 69 a0 d8 a1 47 a1 b6
+a2 26 a2 96 a3 06 a3 76 a3 e6 a4 56 a4 c7 a5 38
+a5 a9 a6 1a a6 8b a6 fd a7 6e a7 e0 a8 52 a8 c4
+a9 37 a9 a9 aa 1c aa 8f ab 02 ab 75 ab e9 ac 5c
+ac d0 ad 44 ad b8 ae 2d ae a1 af 16 af 8b b0 00
+b0 75 b0 ea b1 60 b1 d6 b2 4b b2 c2 b3 38 b3 ae
+b4 25 b4 9c b5 13 b5 8a b6 01 b6 79 b6 f0 b7 68
+b7 e0 b8 59 b8 d1 b9 4a b9 c2 ba 3b ba b5 bb 2e
+bb a7 bc 21 bc 9b bd 15 bd 8f be 0a be 84 be ff
+bf 7a bf f5 c0 70 c0 ec c1 67 c1 e3 c2 5f c2 db
+c3 58 c3 d4 c4 51 c4 ce c5 4b c5 c8 c6 46 c6 c3
+c7 41 c7 bf c8 3d c8 bc c9 3a c9 b9 ca 38 ca b7
+cb 36 cb b6 cc 35 cc b5 cd 35 cd b5 ce 36 ce b6
+cf 37 cf b8 d0 39 d0 ba d1 3c d1 be d2 3f d2 c1
+d3 44 d3 c6 d4 49 d4 cb d5 4e d5 d1 d6 55 d6 d8
+d7 5c d7 e0 d8 64 d8 e8 d9 6c d9 f1 da 76 da fb
+db 80 dc 05 dc 8a dd 10 dd 96 de 1c de a2 df 29
+df af e0 36 e0 bd e1 44 e1 cc e2 53 e2 db e3 63
+e3 eb e4 73 e4 fc e5 84 e6 0d e6 96 e7 1f e7 a9
+e8 32 e8 bc e9 46 e9 d0 ea 5b ea e5 eb 70 eb fb
+ec 86 ed 11 ed 9c ee 28 ee b4 ef 40 ef cc f0 58
+f0 e5 f1 72 f1 ff f2 8c f3 19 f3 a7 f4 34 f4 c2
+f5 50 f5 de f6 6d f6 fb f7 8a f8 19 f8 a8 f9 38
+f9 c7 fa 57 fa e7 fb 77 fc 07 fc 98 fd 29 fd ba
+fe 4b fe dc ff 6d ff ff >
+endstream
+endobj
+10 0 obj
+<<
+/Type /Encoding
+/BaseEncoding /WinAnsiEncoding
+/Differences [ 45/minus 96/quoteleft
+144/dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent
+/dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron /space]
+>>
+endobj
+11 0 obj <<
+/Type /Font
+/Subtype /Type1
+/Name /F2
+/BaseFont /Helvetica
+/Encoding 10 0 R
+>> endobj
+12 0 obj <<
+/Type /Font
+/Subtype /Type1
+/Name /F3
+/BaseFont /Helvetica-Bold
+/Encoding 10 0 R
+>> endobj
+xref
+0 13
+0000000000 65535 f
+0000000021 00000 n
+0000000164 00000 n
+0000068977 00000 n
+0000069060 00000 n
+0000069183 00000 n
+0000069216 00000 n
+0000000213 00000 n
+0000000293 00000 n
+0000068956 00000 n
+0000078752 00000 n
+0000079010 00000 n
+0000079108 00000 n
+trailer
+<<
+/Size 13
+/Info 1 0 R
+/Root 2 0 R
+>>
+startxref
+79211
+%%EOF
diff --git a/vignettes/heatmaps.Rnw b/vignettes/heatmaps.Rnw
new file mode 100644
index 0000000..ad1947d
--- /dev/null
+++ b/vignettes/heatmaps.Rnw
@@ -0,0 +1,481 @@
+%\VignetteIndexEntry{NMF: generating heatmaps}
+%\VignetteDepends{utils,NMF,RColorBrewer,knitr,bibtex}
+%\VignetteKeyword{aplot}
+%\VignetteCompiler{knitr}
+%\VignetteEngine{knitr::knitr}
+
+\documentclass[a4paper]{article}
+
+%\usepackage[OT1]{fontenc}
+\usepackage[colorlinks]{hyperref}
+\usepackage{a4wide}
+\usepackage{xspace}
+\usepackage[all]{hypcap} % for linking to the top of the figures or tables
+
+% add preamble from pkgmaker
+<<pkgmaker_preamble, echo=FALSE, results='asis'>>=
+pkgmaker::latex_preamble()
+@
+
+\newcommand{\nmfpack}{\pkgname{NMF}}
+\newcommand{\MATLAB}{MATLAB\textsuperscript{\textregistered}\xspace}
+\newcommand{\refeqn}[1]{(\ref{#1})}
+
+% REFERENCES
+\usepackage[citestyle=authoryear-icomp
+, doi=true
+, url=true
+, maxnames=1
+, maxbibnames=15
+, backref=true
+, backend=bibtex]{biblatex}
+\AtEveryCitekey{\clearfield{url}}
+<<bibliofile, echo=FALSE, results='asis'>>=
+pkgmaker::latex_bibliography('NMF')
+@
+\newcommand{\citet}[1]{\textcite{#1}}
+\renewcommand{\cite}[1]{\parencite{#1}}
+\DefineBibliographyStrings{english}{%
+ backrefpage = {see p.}, % for single page number
+ backrefpages = {see pp.} % for multiple page numbers
+}
+%
+
+% boxed figures
+\usepackage{float}
+\floatstyle{boxed}
+\restylefloat{figure}
+
+\usepackage{array}
+\usepackage{tabularx}
+\usepackage{mathabx}
+
+\usepackage{url}
+\urlstyle{rm}
+
+% use cleveref for automatic reference label formatting
+\usepackage[capitalise, noabbrev]{cleveref}
+
+% define commands for notes
+\usepackage{todonotes}
+\newcommand{\nbnote}[1]{\ \bigskip\todo[inline, backgroundcolor=blue!20!white]{\scriptsize\textsf{\textbf{NB:} #1}}\ \\}
+
+% put table of contents on two columns
+\usepackage[toc]{multitoc}
+
+\setkeys{Gin}{width=0.95\textwidth}
+
+\begin{document}
+
+<<options, include=FALSE, verbose=TRUE>>=
+#options(prompt=' ')
+#options(continue=' ')
+set.seed(123456)
+library(NMF)
+@
+
+\title{Generating heatmaps for Nonnegative Matrix Factorization\\
+\small Package \nmfpack\ - Version \Sexpr{utils::packageVersion('NMF')}}
+\author{Renaud Gaujoux}
+
+\maketitle
+
+\begin{abstract}
+This vignette describes how to produce different informative heatmaps from NMF objects,
+such as returned by the function \code{nmf} in the \citeCRANpkg{NMF}.
+The main drawing engine is implemented by the function \code{aheatmap}, which is
+a highly enhanced modification of the function \code{pheatmap} from the \CRANpkg{pheatmap},
+and provides convenient and quick ways of producing high quality and customizable annotated heatmaps.
+Currently this function is part of the package \nmfpack, but may eventually
+compose a separate package on its own.
+\end{abstract}
+
+{\small \tableofcontents}
+
+\section{Preliminaries}
+
+\subsection{Quick reminder on NMF models}
+
+Given a nonnegative target matrix $X$ of dimension $n\times p$, NMF algorithms
+aim at finding a rank $k$ approximation of the form:
+$$
+X \approx W H,
+$$
+where $W$ and $H$ are nonnegative matrices of dimensions $n\times k$ and $k\times p$
+respectively.
+
+The matrix $W$ is the basis matrix, whose columns are the basis components.
+The matrix $H$ is the mixture coefficient or weight matrix, whose columns contain
+the contribution of each basis component to the corresponding column of $X$.
+We call the rows of $H$ the basis profiles.
+
+\subsection{Heatmaps for NMF}
+
+Because NMF objects essentially wrap up a pair of matrices, heatmaps are convenient
+to visualise the results of NMF runs.
+The package \nmfpack provides several specialised heatmap functions, designed to produce
+heatmaps with sensible default configurations according to the data being drawn.
+Being all based on a common drawing engine, they share almost identical interfaces
+and capabilities.
+The following specialised functions are currently implemented:
+
+\begin{description}
+\item[\code{basismap}] draws heatmaps of the basis matrix
+\item[\code{coefmap}] draws heatmaps of the mixture coefficient matrix
+\item[\code{consensusmap}] draws heatmaps of the consensus matrix, for results
+of multiple NMF runs.
+\end{description}
+
+\subsection{Heatmap engine}
+
+All the above functions eventually call a common heatmap engine, with
+different default parameters, chosen to be relevant for the given underlying data.
+The engine is implemented by the function \code{aheatmap}.
+Its development started as modification of the function \code{pheatmap} from
+the \pkgname{pheatmap} package.
+The initial objective was to improve and increase its capabilities, as well as
+defining a simplified interface, more consistent with the R core function \code{heatmap}.
+We eventually aim at providing a general, flexible, powerful and easy to use engine
+for drawing annotated heatmaps.
+
+The function \code{aheatmap} has many advantages compared to other heatmap functions
+such as \code{heatmap}, \code{gplots::heatmap2}, \code{heatmap.plus::heatmap.plus}
+, or even \code{pheatmap}:
+
+\begin{itemize}
+\item Annotations: unlimited number of annotation tracks can be added to
+\emph{both} columns and rows, with automated colouring for categorical and
+numeric variables.
+\item Compatibility with both base and grid graphics: the function can be
+directly called in drawing contexts such as grid, mfrow or layout.
+This is a feature many R users were looking for, and that was strictly
+impossible with base heatmaps.
+\item Legends: default automatic legend and colouring;
+\item Customisation: clustering methods, annotations, colours and legend can all
+be customised, even separately for rows and columns;
+\item Convenient interface: many arguments provide multiple ways of
+specifying their value(s), which speeds up developping/writing and reduce the
+amount of code required to generate customised plots (e.g. see
+\cref{sec:colour_spec}).
+\item Aesthetics: the heatmaps look globally cleaner, the image and text components
+are by default well proportioned relatively to each other, and all fit within
+the graphic device.
+\end{itemize}
+
+\subsection{Data and model}
+\label{sec:data}
+
+For the purpose of illustrating the use of each heatmap function, we generate a
+random target matrix, as well as some annotations or covariates:
+
+<<data>>=
+# random data that follow an 3-rank NMF model (with quite some noise: sd=2)
+X <- syntheticNMF(100, 3, 20, noise=2)
+
+# row annotations and covariates
+n <- nrow(X)
+d <- rnorm(n)
+e <- unlist(mapply(rep, c('X', 'Y', 'Z'), 10))
+e <- c(e, rep(NA, n-length(e)))
+rdata <- data.frame(Var=d, Type=e)
+
+# column annotations and covariates
+p <- ncol(X)
+a <- sample(c('alpha', 'beta', 'gamma'), p, replace=TRUE)
+# define covariates: true groups and some numeric variable
+c <- rnorm(p)
+# gather them in a data.frame
+covariates <- data.frame(a, X$pData, c)
+@
+
+%\SweaveOpts{fig.width=14,fig.height=7}
+<<figoptions, include=FALSE>>=
+library(knitr)
+opts_chunk$set(fig.width=14, fig.height=7)
+@
+Note that in the code above, the object \code{X} returned by \code{syntheticNMF} \emph{really is} a matrix object, but wrapped through the function \code{ExposedAttribute} object, which exposes its attributes via a more friendly and access controlled interface \code{\$}.
+Of particular interests are attributes \code{'pData'} and \code{'fData'}, which are lists that contain a factor named \code{'Group'} that indicates the true underlying clusters.
+These are respectively defined as each sample's most contrbuting basis component and the basis component to which each feature contributes the most.
+They are useful to annotate heatmaps and assess the ability of NMF methods to recover the true clusters.
+
+As an example, one can conveniently visualize the target matrix as a heatmap, with or without the relevant sample and feature annotations, using simple calls to the \code{aheatmap} function:
+<<heatmap_data>>=
+par(mfrow=c(1,2))
+aheatmap(X, annCol=covariates, annRow=X$fData)
+aheatmap(X)
+@
+
+Then, we fit an NMF model using multiple runs, that will be used throughtout this vignette to illustrate the use of NMF heatmaps:
+
+<<model, cache=TRUE>>=
+res <- nmf(X, 3, nrun=10)
+res
+@
+
+\nbnote{To keep the vignette simple, we always use the default NMF method
+(i.e. \code{'brunet'}), but all steps could be performed using a different method,
+or multiple methods in order to compare their perfromances.}
+
+\section{Mixture Coefficient matrix: \texttt{coefmap}}
+
+The coefficient matrix of the result can be plotted using the function
+\code{coefmap}.
+The default behaviour for multiple NMF runs is to add two annotation tracks that
+show the clusters obtained by the best fit and the hierarchical clustering of
+the consensus matrix\footnote{The hierarchical clustering is computed using the
+consensus matrix itself as a similarity measure, and average linkage. See
+\code{?consensushc}.}.
+In the legend, these tracks are named \emph{basis} and \emph{consensus} respectively.
+For single NMF run or NMF model objects, no consensus data are available, and
+only the clusters from the fit are displayed.
+
+<<coefmap_res, fig.keep='last'>>=
+opar <- par(mfrow=c(1,2))
+# coefmap from multiple run fit: includes a consensus track
+coefmap(res)
+# coefmap of a single run fit: no consensus track
+coefmap(minfit(res))
+par(opar)
+@
+
+\nbnote{Note how both heatmaps were drawn on the same plot, simply using the standard
+call to \code{par(mfrow=c(1,2)}.
+This is impossible to achieve with the R core function \code{heatmap}.
+See \cref{sec:aheatmap} for more details about compatibility with base
+and grid graphics.}
+
+By default:
+\begin{itemize}
+\item the rows are not ordered;
+\item the columns use the default ordering of \code{aheatmap}, but may easily be
+ordered according to the clusters defined by the dominant basis component for
+each column with \code{Colv="basis"}, or according to those implied by the
+consensus matrix, i.e. as in \code{consensusmap}, with \code{Colv="consensus"};
+\item each column is scaled to sum up to one;
+\item the color palette used is \code{'YlOrRd'} from the
+\citeCRANpkg{RColorBrewer}, with 50 breaks.
+\end{itemize}
+
+In term of arguments passed to the heatmap engine \code{aheatmap}, these default
+settings translate as:
+
+<<coefmap_default, eval=FALSE>>=
+Rowv = NA
+Colv = TRUE
+scale = 'c1'
+color = 'YlOrRd:50'
+annCol = predict(object) + predict(object, 'consensus')
+@
+
+If the ordering does not come from a hierarchical clustering (e.g., if
+\code{Colv='basis'}), then no dendrogram is displayed.
+The default behaviour of \code{aheatmap} can be obtained by setting arguments
+\code{Rowv=TRUE, Colv=TRUE, scale='none'}.
+
+\medskip
+The automatic annotation tracks can be hidden all together by setting argument
+\code{tracks=NA}, displayed separately by passing only one of the given names
+(e.g. \code{tracks=':basis'} or \code{tracks='basis:'} for the row or column respectively),
+and their legend names may be changed by
+specifying e.g. \code{tracks=c(Metagene=':basis', 'consensus')}.
+Beside this, they are handled by the heatmap engine function \code{aheatmap}
+and can be customised as any other annotation tracks -- that can be added via
+the same argument \code{annCol} (see \cref{sec:aheatmap} or \code{?aheatmap} for
+more details).
+
+<<coefmap_custom, fig.keep='last', tidy=FALSE>>=
+opar <- par(mfrow=c(1,2))
+# removing all automatic annotation tracks
+coefmap(res, tracks=NA)
+# customized plot
+coefmap(res, Colv = 'euclidean'
+ , main = "Metagene contributions in each sample", labCol = NULL
+ , annRow = list(Metagene=':basis'), annCol = list(':basis', Class=a, Index=c)
+ , annColors = list(Metagene='Set2')
+ , info = TRUE)
+par(opar)
+@
+
+\nbnote{The feature that allows to display some information about the fit
+at the bottom of the plot via argument \code{info=TRUE} is still experimental.
+It is helpful mostly when developing algorithms or doing an analysis, but
+would seldom be used in publications.}
+
+\section{Basis matrix: \texttt{basismap}}
+
+The basis matrix can be plotted using the function \code{basismap}.
+The default behaviour is to add an annotation track that shows for each row
+the dominant basis component.
+That is, for each row, the index of the basis component with the highest
+loading.
+
+This track can be disabled by setting \code{tracks=NA}, and extra
+row annotations can be added using the same argument \code{annRow}.
+
+<<basismap_res, fig.keep='last'>>=
+opar <- par(mfrow=c(1,2))
+# default plot
+basismap(res)
+# customized plot: only use row special annotation track.
+basismap(res, main="Metagenes", annRow=list(d, e), tracks=c(Metagene=':basis'))
+par(opar)
+@
+
+By default:
+\begin{itemize}
+\item the columns are not ordered;
+\item the rows are ordered by hierarchical clustering using default distance and
+linkage methods (\code{'eculidean'} and \code{'complete'});
+\item each row is scaled to sum up to one;
+\item the color palette used is \code{'YlOrRd'} from the
+\citeCRANpkg{RColorBrewer}, with 50 breaks.
+\end{itemize}
+
+In term of arguments passed to the heatmap engine \code{aheatmap}, these default
+settings translate as:
+
+<<basismap_default, eval=FALSE>>=
+Colv = NA
+scale = 'r1'
+color = 'YlOrRd:50'
+annRow = predict(object, 'features')
+@
+
+\section{Consensus matrix: \texttt{consensusmap}}
+
+When doing clustering with NMF, a common way of assessing the stability of the
+clusters obtained for a given rank is to consider the consensus matrix
+computed over multiple independent NMF runs, which is the average of the connectivity
+matrices of each separate run
+\footnote{Hence, stability here means robustness with regards to the initial starting point,
+and shall not be interpreted as in e.g. cross-validation/bootstrap analysis.
+However, one can argue that having very consistent clusters across runs somehow supports
+for a certain regularity or the presence of an underlying pattern in the data.}.
+This procedure is usually repeated over a certain range of factorization ranks,
+and the results are compared to identify which rank gives the best clusters,
+possibly in the light of some extra knowledge one could have about the samples
+(e.g. covariates).
+The functions \code{nmf} and \code{consensusmap} make it easy to implement
+this whole process.
+
+\nbnote{The consensus plots can also be generated for fits obtained from single NMF runs,
+in which case the consensus matrix simply reduces to a single connectivity matrix.
+This is a binary matrix (i.e. entries are either 0 or 1), that will always produce
+a bi-colour heatmap, and by default clear blocks for each cluster.}
+
+\subsection{Single fit}
+In section \cref{sec:data}, the NMF fit \code{res} was computed with argument
+\code{nrun=10}, and therefore contains the best fit over 10 runs, as well as
+the consensus matrix computed over all the runs
+\footnote{If one were interested in keeping the fits from all the runs, the
+function \code{nmf} should have been called with argument \code{.options='k'}.
+See section \emph{Options} in \code{?nmf}.
+The downstream hanlding of the result would remain identical.}.
+This can be ploted using the function \code{consensusmap}, which allows for the
+same kind of customization as the other NMF heatmap functions:
+
+<<consensusmap_res, fig.keep='last'>>=
+opar <- par(mfrow=c(1,2))
+# default plot
+consensusmap(res)
+# customized plot
+consensusmap(res, annCol=covariates, annColors=list(c='blue')
+ , labCol='sample ', main='Cluster stability'
+ , sub='Consensus matrix and all covariates')
+par(opar)
+@
+
+By default:
+\begin{itemize}
+\item the rows and columns of the consensus heatmap are symmetrically
+ordered by hierarchical clustering using the consensus matrix as a similarity
+measure and average linkage, and the associated dendrogram is displayed;
+\item the color palette used is the reverse of \code{'RdYlBu'} from the \citeCRANpkg{RColorBrewer}.
+\end{itemize}
+
+In term of arguments passed to the heatmap engine \code{aheatmap}, these default
+settings translate as:
+
+<<cmap_default, eval=FALSE>>=
+distfun = function(x) as.dist(1-x) # x being the consensus matrix
+hclustfun = 'average'
+Rowv = TRUE
+Colv = "Rowv"
+color = '-RdYlBu'
+@
+
+\subsection{Single method over a range of ranks}
+
+The function \code{nmf} accepts a range of value for the rank (argument \code{rank}),
+making it fit NMF models for each value in the given range
+\footnote{Before version 0.6, this feature was provided by the function \code{nmfEstimateRank}.
+From version 0.6, the function \code{nmf} accepts ranges of ranks, and internally
+calls the function \code{nmfEstimateRank} -- that remains exported and can still
+be called directly.
+See documentation \code{?nmfEstimateRank} for more details on the returned value.}:
+
+<<estimate, cache=TRUE>>=
+res2_7 <- nmf(X, 2:7, nrun=10, .options='v')
+class(res2_7)
+@
+
+The result \code{res2\_7} is an S3 object of class \code{'NMF.rank'},
+that contains -- amongst other data -- a list of the best fits obtained for each
+value of the rank in range $\ldbrack 2, 7\rdbrack]$.
+The method of \code{consensusmap} defined for class \code{'NMF.rank'},
+which plots all the consensus matrices on the same plot:
+
+<<consensusmap_estimate, fig.keep='last'>>=
+consensusmap(res2_7)
+@
+
+\nbnote{ The main title of each consensus heatmap can be customized by passing
+to argument \code{main} a character vector or a list whose elements specify each title.
+All other arguments are used in each internal call to consensusmap, and will
+therefore affect all the plots simultaneously.
+The layout can be specified via argument \code{layout} as a numeric vector
+giving the number of rows and columns in a \code{mfrow}-like way, or as a
+matrix that will be passed to R core function \code{layout}.
+See \code{?consensusmap} for more details and example code.
+}
+
+\subsection{Single rank over a range of methods}
+If one is interested in comparing methods, for a given factorization rank, then
+on can fit an NMF model for each method by providing the function \code{nmf} with
+a \code{list} in argument \code{method}:
+
+<<fit_methods, cache=TRUE>>=
+res_methods <- nmf(X, 3, list('lee', 'brunet', 'nsNMF'), nrun=10)
+class(res_methods)
+@
+
+The result \code{res\_methods} is an S4 object of class \code{NMFList}, which
+is essentially a named list, that contains each fits and the CPU time required
+by the whole computation.
+As previously, the sequence of consensus matrices is plotted with \code{consensusmap}:
+
+<<consensusmap_methods, fig.width=10, fig.height=7, fig.keep='last'>>=
+consensusmap(res_methods)
+@
+
+\section{Generic heatmap engine: \texttt{aheatmap}}
+\label{sec:aheatmap}
+
+This section still needs to be written, but many examples of annotated heatmaps can be found in the demos \code{'aheatmap'} and \code{'heatmaps'}:
+<<demo_hm, eval=FALSE>>=
+demo('aheatmap')
+# or
+demo('heatmaps')
+@
+
+These demos and the plots they generate can also be browsed online at \url{http://nmf.r-forge.r-project.org/_DEMOS.html}.
+
+\section{Session Info}
+<<sessionInfo, echo=FALSE, results='asis'>>=
+toLatex(sessionInfo())
+@
+
+\printbibliography[heading=bibintoc]
+
+
+\end{document}
diff --git a/vignettes/src/bmc.R b/vignettes/src/bmc.R
new file mode 100644
index 0000000..f95e884
--- /dev/null
+++ b/vignettes/src/bmc.R
@@ -0,0 +1,47 @@
+# Scripts runs to produce the figures in the BMC paper
+#
+# Author: renaud
+###############################################################################
+
+# install and load NMF package
+lib.dir <- 'lib'
+dir.create(lib.dir, showWarnings=FALSE)
+install.packages('NMF_0.1.tar.gz', repos=NULL, lib=lib.dir)
+library(NMF, lib=lib.dir)
+
+# define a seed
+.seed <- 123456
+
+# load Golub data
+data(esGolub)
+#esGolub <- syntheticNMF(500, 3, 20, noise=TRUE)
+
+# estimate rank for Golub dataset
+rank.nrun <- 50
+rank.range <- seq(2,6)
+res.estimate <- nmfEstimateRank(esGolub, rank.range, method='brunet'
+ , nrun=rank.nrun, conf.interval=TRUE, seed=.seed)
+save(res.estimate, file='res.estimate.rda')
+
+# Full run of Brunet algorithm
+nmf.nrun <- 200
+res.brunet <- nmf(esGolub, 3, 'brunet', nrun=nmf.nrun, seed=.seed, .options='tv')
+save(res.brunet, file='res.brunet.rda')
+
+# Comparison of methods
+res.comp <- nmf(esGolub, 3, list('brunet', 'lee', 'ns', 'lnmf'), seed='nndsvd', .options='tv')
+save(res.comp, file='res.comp.rda')
+
+# save all in one file
+save(res.estimate, res.brunet, res.comp, file='res.bmc.rda')
+
+if( FALSE ){
+# generate plots
+png('consensus.png')
+metaHeatmap(res.brunet, class=esGolub$Cell)
+dev.off()
+
+png('metagenes.png')
+metaHeatmap(fit(res.brunet), class=esGolub$Cell)
+dev.off()
+}
\ No newline at end of file
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-med/r-cran-nmf.git
More information about the debian-med-commit
mailing list