[med-svn] [r-cran-ade4] 07/12: New upstream version 1.7-8
Andreas Tille
tille at debian.org
Wed Nov 29 13:30:49 UTC 2017
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository r-cran-ade4.
commit 73a6e11649335ce39818e56b0b8503918c9231ef
Author: Andreas Tille <tille at debian.org>
Date: Wed Nov 29 14:25:46 2017 +0100
New upstream version 1.7-8
---
ChangeLog | 2354 +++++++++++++++++++++++++++++
DESCRIPTION | 21 +
MD5 | 618 ++++++++
NAMESPACE | 286 ++++
R/EH.R | 22 +
R/PI2newick.R | 64 +
R/RV.rtest.R | 25 +
R/RVdist.randtest.R | 18 +
R/add.scatter.R | 90 ++
R/amova.R | 217 +++
R/apqe.R | 100 ++
R/area.plot.R | 277 ++++
R/as.taxo.R | 43 +
R/bca.rlq.R | 137 ++
R/between.R | 139 ++
R/betweencoinertia.R | 173 +++
R/betwitdpcoa.R | 261 ++++
R/bicenter.wt.R | 21 +
R/cailliez.R | 26 +
R/coinertia.R | 278 ++++
R/combine.4thcorner.R | 94 ++
R/corkdist.R | 176 +++
R/costatis.R | 101 ++
R/disc.R | 68 +
R/discrimin.R | 134 ++
R/discrimin.coa.R | 68 +
R/dist.binary.R | 94 ++
R/dist.dudi.R | 30 +
R/dist.genet.R | 104 ++
R/dist.ktab.R | 3350 +++++++++++++++++++++++++++++++++++++++++
R/dist.neig.R | 18 +
R/dist.prop.R | 83 +
R/dist.quant.R | 55 +
R/divc.R | 26 +
R/divcmax.R | 101 ++
R/dotchart.phylog.R | 102 ++
R/dotcircle.R | 44 +
R/dpcoa.R | 160 ++
R/dudi.R | 269 ++++
R/dudi.acm.R | 116 ++
R/dudi.coa.R | 27 +
R/dudi.dec.R | 33 +
R/dudi.fca.R | 133 ++
R/dudi.hillsmith.R | 100 ++
R/dudi.mix.R | 126 ++
R/dudi.nsc.R | 19 +
R/dudi.pca.R | 32 +
R/dudi.pco.R | 112 ++
R/foucart.R | 179 +++
R/fourthcorner.R | 291 ++++
R/fourthcorner.rlq.R | 310 ++++
R/fourthcorner2.R | 218 +++
R/fuzzygenet.R | 143 ++
R/gearymoran.R | 28 +
R/genet.R | 375 +++++
R/gridrowcol.R | 107 ++
R/inertia.dudi.R | 161 ++
R/is.euclid.R | 31 +
R/kdist.R | 269 ++++
R/kdist2ktab.R | 47 +
R/kdisteuclid.R | 64 +
R/kplot.R | 3 +
R/kplot.foucart.R | 28 +
R/kplot.mcoa.R | 61 +
R/kplot.mfa.R | 39 +
R/kplot.pta.R | 72 +
R/kplot.sepan.R | 104 ++
R/kplot.statis.R | 48 +
R/krandboot.R | 32 +
R/krandtest.R | 120 ++
R/krandxval.R | 40 +
R/ktab.R | 332 ++++
R/ktab.data.frame.R | 43 +
R/ktab.list.df.R | 51 +
R/ktab.list.dudi.R | 44 +
R/ktab.match2ktabs.R | 58 +
R/ktab.within.R | 41 +
R/lingoes.R | 24 +
R/mantel.randtest.R | 15 +
R/mantel.rtest.R | 38 +
R/mbpcaiv.R | 248 +++
R/mbpls.R | 239 +++
R/mcoa.R | 331 ++++
R/mdpcoa.R | 226 +++
R/mfa.R | 231 +++
R/mld.R | 136 ++
R/mstree.R | 17 +
R/multiblock.R | 216 +++
R/multispati.R | 211 +++
R/multispati.randtest.R | 35 +
R/multispati.rtest.R | 33 +
R/neig.R | 228 +++
R/newick2phylog.R | 570 +++++++
R/niche.R | 159 ++
R/nipals.R | 134 ++
R/optimEH.R | 39 +
R/originality.R | 146 ++
R/orisaved.R | 27 +
R/orthobasis.R | 351 +++++
R/orthogram.R | 183 +++
R/p.adjust.4thcorner.R | 40 +
R/pcaiv.R | 189 +++
R/pcaivortho.R | 82 +
R/pcoscaled.R | 27 +
R/phylog.R | 281 ++++
R/plot.4thcorner.R | 235 +++
R/plot.phylog.R | 263 ++++
R/print.4thcorner.R | 46 +
R/procuste.R | 149 ++
R/procuste.randtest.R | 25 +
R/procuste.rtest.R | 29 +
R/pta.R | 298 ++++
R/quasieuclid.R | 17 +
R/randEH.R | 30 +
R/randboot.R | 29 +
R/randtest-internal.R | 146 ++
R/randtest.R | 78 +
R/randtest.amova.R | 34 +
R/randtest.between.R | 24 +
R/randtest.coinertia.R | 81 +
R/randtest.discrimin.R | 26 +
R/randtest.dpcoa.R | 50 +
R/randtest.pcaiv.R | 27 +
R/randtest.pcaivortho.R | 29 +
R/randtest.rlq.R | 121 ++
R/randxval.R | 26 +
R/reconst.R | 51 +
R/rlq.R | 199 +++
R/rtest.R | 3 +
R/rtest.between.R | 38 +
R/rtest.discrimin.R | 47 +
R/s.arrow.R | 45 +
R/s.chull.R | 28 +
R/s.class.R | 50 +
R/s.corcircle.R | 91 ++
R/s.distri.R | 48 +
R/s.hist.R | 89 ++
R/s.image.R | 51 +
R/s.kde2d.R | 52 +
R/s.label.R | 39 +
R/s.logo.R | 83 +
R/s.match.R | 57 +
R/s.match.class.R | 81 +
R/s.multinom.R | 112 ++
R/s.traject.R | 81 +
R/s.value.R | 89 ++
R/scalewt.R | 173 +++
R/scatter.R | 2 +
R/scatter.acm.R | 24 +
R/scatter.coa.R | 38 +
R/scatter.dudi.R | 25 +
R/scatter.fca.R | 15 +
R/scatterutil.R | 689 +++++++++
R/sco.boxplot.R | 79 +
R/sco.class.R | 106 ++
R/sco.distri.R | 83 +
R/sco.gauss.R | 57 +
R/sco.label.R | 91 ++
R/sco.match.R | 100 ++
R/sco.quant.R | 34 +
R/score.R | 65 +
R/score.acm.R | 34 +
R/score.coa.R | 185 +++
R/score.mix.R | 78 +
R/score.pca.R | 31 +
R/sepan.R | 151 ++
R/statico.R | 77 +
R/statis.R | 206 +++
R/summary.4thcorner.R | 38 +
R/supcol.R | 36 +
R/supdist.R | 66 +
R/suprow.R | 143 ++
R/symbols.phylog.R | 146 ++
R/table.cont.R | 62 +
R/table.dist.R | 21 +
R/table.paint.R | 28 +
R/table.phylog.R | 139 ++
R/table.value.R | 208 +++
R/testdim.R | 42 +
R/triangle.class.R | 95 ++
R/triangle.plot.R | 285 ++++
R/uniquewt.df.R | 15 +
R/utilities.R | 48 +
R/variance.phylog.R | 58 +
R/varipart.R | 57 +
R/wca.rlq.R | 137 ++
R/within.R | 134 ++
R/withincoinertia.R | 178 +++
R/withinpca.R | 56 +
R/witwit.R | 126 ++
R/witwitsepan.R | 57 +
data/abouheif.eg.rda | Bin 0 -> 414 bytes
data/acacia.rda | Bin 0 -> 614 bytes
data/aminoacyl.rda | Bin 0 -> 3359 bytes
data/apis108.rda | Bin 0 -> 2004 bytes
data/aravo.rda | Bin 0 -> 6151 bytes
data/ardeche.rda | Bin 0 -> 1594 bytes
data/arrival.rda | Bin 0 -> 790 bytes
data/atlas.rda | Bin 0 -> 6145 bytes
data/atya.rda | Bin 0 -> 1928 bytes
data/avijons.rda | Bin 0 -> 15850 bytes
data/avimedi.rda | Bin 0 -> 3871 bytes
data/aviurba.rda | Bin 0 -> 2679 bytes
data/bacteria.rda | Bin 0 -> 9468 bytes
data/banque.rda | Bin 0 -> 7765 bytes
data/baran95.rda | Bin 0 -> 2581 bytes
data/bf88.rda | Bin 0 -> 4271 bytes
data/bordeaux.rda | Bin 0 -> 280 bytes
data/bsetal97.rda | Bin 0 -> 6955 bytes
data/buech.rda | Bin 0 -> 3303 bytes
data/butterfly.rda | Bin 0 -> 2153 bytes
data/capitales.rda | Bin 0 -> 608370 bytes
data/carni19.rda | Bin 0 -> 651 bytes
data/carni70.rda | Bin 0 -> 1992 bytes
data/carniherbi49.rda | Bin 0 -> 2934 bytes
data/casitas.rda | Bin 0 -> 927 bytes
data/chatcat.rda | Bin 0 -> 395 bytes
data/chats.rda | Bin 0 -> 282 bytes
data/chazeb.rda | Bin 0 -> 631 bytes
data/chevaine.rda | Bin 0 -> 3618 bytes
data/chickenk.rda | Bin 0 -> 18607 bytes
data/clementines.rda | Bin 0 -> 1146 bytes
data/cnc2003.rda | Bin 0 -> 3791 bytes
data/coleo.rda | Bin 0 -> 3769 bytes
data/corvus.rda | Bin 0 -> 585 bytes
data/datalist | 108 ++
data/deug.rda | Bin 0 -> 2113 bytes
data/doubs.rda | Bin 0 -> 2872 bytes
data/dunedata.rda | Bin 0 -> 966 bytes
data/ecg.rda | Bin 0 -> 3644 bytes
data/ecomor.rda | Bin 0 -> 7470 bytes
data/elec88.rda | Bin 0 -> 368813 bytes
data/escopage.rda | Bin 0 -> 1971 bytes
data/euro123.rda | Bin 0 -> 1156 bytes
data/fission.rda | Bin 0 -> 423 bytes
data/friday87.rda | Bin 0 -> 1917 bytes
data/fruits.rda | Bin 0 -> 1586 bytes
data/ggtortoises.rda | Bin 0 -> 13845 bytes
data/granulo.rda | Bin 0 -> 1107 bytes
data/hdpg.rda | Bin 0 -> 353916 bytes
data/housetasks.rda | Bin 0 -> 388 bytes
data/humDNAm.rda | Bin 0 -> 1479 bytes
data/ichtyo.rda | Bin 0 -> 955 bytes
data/irishdata.rda | Bin 0 -> 20874 bytes
data/julliot.rda | Bin 0 -> 9042 bytes
data/jv73.rda | Bin 0 -> 5609 bytes
data/kcponds.rda | Bin 0 -> 7379 bytes
data/lascaux.rda | Bin 0 -> 27748 bytes
data/lizards.rda | Bin 0 -> 883 bytes
data/macaca.rda | Bin 0 -> 1003 bytes
data/macon.rda | Bin 0 -> 447 bytes
data/macroloire.rda | Bin 0 -> 3126 bytes
data/mafragh.rda | Bin 0 -> 23386 bytes
data/maples.rda | Bin 0 -> 2030 bytes
data/mariages.rda | Bin 0 -> 337 bytes
data/meau.rda | Bin 0 -> 1324 bytes
data/meaudret.rda | Bin 0 -> 1375 bytes
data/microsatt.rda | Bin 0 -> 2607 bytes
data/mjrochet.rda | Bin 0 -> 2384 bytes
data/mollusc.rda | Bin 0 -> 2468 bytes
data/monde84.rda | Bin 0 -> 1064 bytes
data/morphosport.rda | Bin 0 -> 2116 bytes
data/newick.eg.rda | Bin 0 -> 5277 bytes
data/njplot.rda | Bin 0 -> 1046 bytes
data/olympic.rda | Bin 0 -> 1397 bytes
data/oribatid.rda | Bin 0 -> 3609 bytes
data/ours.rda | Bin 0 -> 539 bytes
data/palm.rda | Bin 0 -> 3447 bytes
data/pap.rda | Bin 0 -> 1394 bytes
data/pcw.rda | Bin 0 -> 800003 bytes
data/perthi02.rda | Bin 0 -> 14530 bytes
data/piosphere.rda | Bin 0 -> 49493 bytes
data/presid2002.rda | Bin 0 -> 9313 bytes
data/procella.rda | Bin 0 -> 1156 bytes
data/rankrock.rda | Bin 0 -> 828 bytes
data/rhizobium.rda | Bin 0 -> 7380 bytes
data/rhone.rda | Bin 0 -> 2133 bytes
data/rpjdl.rda | Bin 0 -> 4642 bytes
data/santacatalina.rda | Bin 0 -> 532 bytes
data/sarcelles.rda | Bin 0 -> 1236 bytes
data/seconde.rda | Bin 0 -> 572 bytes
data/skulls.rda | Bin 0 -> 1383 bytes
data/steppe.rda | Bin 0 -> 4364 bytes
data/syndicats.rda | Bin 0 -> 232 bytes
data/t3012.rda | Bin 0 -> 43350 bytes
data/tarentaise.rda | Bin 0 -> 8669 bytes
data/taxo.eg.rda | Bin 0 -> 1094 bytes
data/tintoodiel.rda | Bin 0 -> 4134 bytes
data/tithonia.rda | Bin 0 -> 921 bytes
data/tortues.rda | Bin 0 -> 573 bytes
data/toxicity.rda | Bin 0 -> 1221 bytes
data/trichometeo.rda | Bin 0 -> 2231 bytes
data/ungulates.rda | Bin 0 -> 724 bytes
data/vegtf.rda | Bin 0 -> 12400 bytes
data/veuvage.rda | Bin 0 -> 1177 bytes
data/westafrica.rda | Bin 0 -> 11316 bytes
data/woangers.rda | Bin 0 -> 2969 bytes
data/worksurv.rda | Bin 0 -> 1818 bytes
data/yanomama.rda | Bin 0 -> 2099 bytes
data/zealand.rda | Bin 0 -> 1207 bytes
debian/README.source | 40 -
debian/changelog | 28 -
debian/compat | 1 -
debian/control | 25 -
debian/copyright | 28 -
debian/rules | 4 -
debian/source/format | 1 -
debian/upstream/metadata | 10 -
debian/watch | 2 -
inst/CITATION | 53 +
inst/pictures/atyacarto.pnm | Bin 0 -> 199644 bytes
inst/pictures/atyadigi.pnm | Bin 0 -> 199644 bytes
inst/pictures/avijonseau.pnm | Bin 0 -> 100091 bytes
inst/pictures/avijonsrou.pnm | Bin 0 -> 100485 bytes
inst/pictures/avijonsveg.pnm | Bin 0 -> 100091 bytes
inst/pictures/avijonsvil.pnm | Bin 0 -> 100091 bytes
inst/pictures/butterfly.pnm | Bin 0 -> 55515 bytes
inst/pictures/capitales.pnm | Bin 0 -> 117451 bytes
inst/pictures/fatala.pnm | Bin 0 -> 44527 bytes
inst/pictures/france_sm00.pnm | Bin 0 -> 396996 bytes
inst/pictures/ireland.pnm | Bin 0 -> 62211 bytes
inst/pictures/paris.pnm | Bin 0 -> 244735 bytes
inst/pictures/sarcelles.pnm | Bin 0 -> 66902 bytes
inst/pictures/tintoodiel.pnm | Bin 0 -> 416655 bytes
man/EH.Rd | 33 +
man/PI2newick.Rd | 36 +
man/RV.rtest.Rd | 32 +
man/RVdist.randtest.Rd | 24 +
man/abouheif.eg.Rd | 43 +
man/acacia.Rd | 39 +
man/add.scatter.Rd | 119 ++
man/ade4-deprecated.Rd | 9 +
man/ade4-internal.Rd | 21 +
man/ade4.package.Rd | 21 +
man/adegraphicsLoaded.Rd | 14 +
man/aminoacyl.Rd | 36 +
man/amova.Rd | 47 +
man/apis108.Rd | 25 +
man/apqe.Rd | 46 +
man/aravo.Rd | 61 +
man/ardeche.Rd | 39 +
man/area.plot.Rd | 179 +++
man/arrival.Rd | 26 +
man/as.taxo.Rd | 40 +
man/atlas.Rd | 86 ++
man/atya.Rd | 37 +
man/avijons.Rd | 91 ++
man/avimedi.Rd | 61 +
man/aviurba.Rd | 41 +
man/bacteria.Rd | 37 +
man/banque.Rd | 163 ++
man/baran95.Rd | 76 +
man/bca.rlq.Rd | 63 +
man/between.Rd | 87 ++
man/betweencoinertia.Rd | 62 +
man/bf88.Rd | 46 +
man/bicenter.wt.Rd | 28 +
man/bordeaux.Rd | 23 +
man/bsetal97.Rd | 58 +
man/buech.Rd | 48 +
man/butterfly.Rd | 52 +
man/bwca.dpcoa.Rd | 83 +
man/cailliez.Rd | 47 +
man/capitales.Rd | 57 +
man/carni19.Rd | 27 +
man/carni70.Rd | 43 +
man/carniherbi49.Rd | 40 +
man/casitas.Rd | 37 +
man/chatcat.Rd | 35 +
man/chats.Rd | 46 +
man/chazeb.Rd | 26 +
man/chevaine.Rd | 61 +
man/chickenk.Rd | 26 +
man/clementines.Rd | 56 +
man/cnc2003.Rd | 35 +
man/coinertia.Rd | 86 ++
man/coleo.Rd | 49 +
man/combine.4thcorner.Rd | 77 +
man/corkdist.Rd | 59 +
man/corvus.Rd | 38 +
man/costatis.Rd | 41 +
man/costatis.randtest.Rd | 34 +
man/deug.Rd | 36 +
man/disc.Rd | 42 +
man/discrimin.Rd | 54 +
man/discrimin.coa.Rd | 35 +
man/dist.binary.Rd | 49 +
man/dist.dudi.Rd | 29 +
man/dist.genet.Rd | 97 ++
man/dist.ktab.Rd | 157 ++
man/dist.neig.Rd | 28 +
man/dist.prop.Rd | 61 +
man/dist.quant.Rd | 53 +
man/divc.Rd | 43 +
man/divcmax.Rd | 83 +
man/dotchart.phylog.Rd | 59 +
man/dotcircle.Rd | 29 +
man/doubs.Rd | 88 ++
man/dpcoa.Rd | 84 ++
man/dudi.Rd | 79 +
man/dudi.acm.Rd | 91 ++
man/dudi.coa.Rd | 50 +
man/dudi.dec.Rd | 36 +
man/dudi.fca.Rd | 73 +
man/dudi.hillsmith.Rd | 53 +
man/dudi.mix.Rd | 60 +
man/dudi.nsc.Rd | 36 +
man/dudi.pca.Rd | 85 ++
man/dudi.pco.Rd | 56 +
man/dunedata.Rd | 26 +
man/ecg.Rd | 43 +
man/ecomor.Rd | 87 ++
man/elec88.Rd | 75 +
man/escopage.Rd | 34 +
man/euro123.Rd | 44 +
man/fission.Rd | 26 +
man/foucart.Rd | 77 +
man/fourthcorner.Rd | 170 +++
man/friday87.Rd | 33 +
man/fruits.Rd | 71 +
man/fuzzygenet.Rd | 46 +
man/gearymoran.Rd | 70 +
man/genet.Rd | 76 +
man/ggtortoises.Rd | 53 +
man/granulo.Rd | 42 +
man/gridrowcol.Rd | 54 +
man/hdpg.Rd | 74 +
man/housetasks.Rd | 29 +
man/humDNAm.Rd | 30 +
man/ichtyo.Rd | 33 +
man/inertia.dudi.Rd | 56 +
man/irishdata.Rd | 72 +
man/is.euclid.Rd | 40 +
man/julliot.Rd | 96 ++
man/jv73.Rd | 53 +
man/kcponds.Rd | 66 +
man/kdist.Rd | 87 ++
man/kdist2ktab.Rd | 44 +
man/kdisteuclid.Rd | 61 +
man/kplot.Rd | 20 +
man/kplot.foucart.Rd | 35 +
man/kplot.mcoa.Rd | 42 +
man/kplot.mfa.Rd | 37 +
man/kplot.pta.Rd | 47 +
man/kplot.sepan.Rd | 74 +
man/kplot.statis.Rd | 43 +
man/krandtest.Rd | 45 +
man/ktab.Rd | 91 ++
man/ktab.data.frame.Rd | 39 +
man/ktab.list.df.Rd | 38 +
man/ktab.list.dudi.Rd | 53 +
man/ktab.match2ktabs.Rd | 41 +
man/ktab.within.Rd | 35 +
man/lascaux.Rd | 60 +
man/lingoes.Rd | 46 +
man/lizards.Rd | 41 +
man/macaca.Rd | 41 +
man/macon.Rd | 17 +
man/macroloire.Rd | 80 +
man/mafragh.Rd | 112 ++
man/mantel.randtest.Rd | 31 +
man/mantel.rtest.Rd | 34 +
man/maples.Rd | 42 +
man/mariages.Rd | 43 +
man/mbpcaiv.Rd | 70 +
man/mbpls.Rd | 68 +
man/mcoa.Rd | 70 +
man/mdpcoa.Rd | 156 ++
man/meau.Rd | 58 +
man/meaudret.Rd | 58 +
man/mfa.Rd | 69 +
man/microsatt.Rd | 49 +
man/mjrochet.Rd | 47 +
man/mld.Rd | 63 +
man/mollusc.Rd | 46 +
man/monde84.Rd | 34 +
man/morphosport.Rd | 34 +
man/mstree.Rd | 49 +
man/multiblock.Rd | 27 +
man/multispati.Rd | 181 +++
man/multispati.randtest.Rd | 46 +
man/multispati.rtest.Rd | 46 +
man/neig.Rd | 147 ++
man/newick.eg.Rd | 42 +
man/newick2phylog.Rd | 113 ++
man/niche.Rd | 98 ++
man/nipals.Rd | 101 ++
man/njplot.Rd | 32 +
man/olympic.Rd | 51 +
man/optimEH.Rd | 51 +
man/oribatid.Rd | 54 +
man/originality.Rd | 57 +
man/orisaved.Rd | 47 +
man/orthobasis.Rd | 148 ++
man/orthogram.Rd | 110 ++
man/ours.Rd | 91 ++
man/palm.Rd | 44 +
man/pap.Rd | 30 +
man/pcaiv.Rd | 147 ++
man/pcaivortho.Rd | 87 ++
man/pcoscaled.Rd | 33 +
man/pcw.Rd | 51 +
man/perthi02.Rd | 27 +
man/phylog.Rd | 73 +
man/piosphere.Rd | 38 +
man/plot.between.Rd | 64 +
man/plot.phylog.Rd | 123 ++
man/plot.within.Rd | 60 +
man/presid2002.Rd | 72 +
man/procella.Rd | 45 +
man/procuste.Rd | 105 ++
man/procuste.randtest.Rd | 34 +
man/procuste.rtest.Rd | 38 +
man/pta.Rd | 68 +
man/quasieuclid.Rd | 34 +
man/randEH.Rd | 54 +
man/randboot.Rd | 51 +
man/randboot.multiblock.Rd | 41 +
man/randtest.Rd | 59 +
man/randtest.amova.Rd | 34 +
man/randtest.between.Rd | 31 +
man/randtest.coinertia.Rd | 47 +
man/randtest.discrimin.Rd | 41 +
man/randtest.dpcoa.Rd | 45 +
man/randtest.pcaiv.Rd | 37 +
man/randxval.Rd | 54 +
man/rankrock.Rd | 22 +
man/reconst.Rd | 58 +
man/rhizobium.Rd | 78 +
man/rhone.Rd | 38 +
man/rlq.Rd | 104 ++
man/rpjdl.Rd | 53 +
man/rtest.Rd | 28 +
man/rtest.between.Rd | 31 +
man/rtest.discrimin.Rd | 41 +
man/s.arrow.Rd | 46 +
man/s.chull.Rd | 56 +
man/s.class.Rd | 85 ++
man/s.corcircle.Rd | 45 +
man/s.distri.Rd | 72 +
man/s.hist.Rd | 33 +
man/s.image.Rd | 80 +
man/s.kde2d.Rd | 68 +
man/s.label.Rd | 73 +
man/s.logo.Rd | 65 +
man/s.match.Rd | 58 +
man/s.match.class.Rd | 97 ++
man/s.multinom.Rd | 77 +
man/s.traject.Rd | 58 +
man/s.value.Rd | 73 +
man/santacatalina.Rd | 36 +
man/sarcelles.Rd | 41 +
man/scalewt.Rd | 57 +
man/scatter.Rd | 45 +
man/scatter.acm.Rd | 31 +
man/scatter.coa.Rd | 48 +
man/scatter.dudi.Rd | 43 +
man/scatter.fca.Rd | 40 +
man/scatterutil.Rd | 94 ++
man/sco.boxplot.Rd | 45 +
man/sco.class.Rd | 53 +
man/sco.distri.Rd | 67 +
man/sco.gauss.Rd | 52 +
man/sco.label.Rd | 48 +
man/sco.match.Rd | 49 +
man/sco.quant.Rd | 30 +
man/score.Rd | 39 +
man/score.acm.Rd | 28 +
man/score.coa.Rd | 62 +
man/score.mix.Rd | 26 +
man/score.pca.Rd | 32 +
man/seconde.Rd | 31 +
man/sepan.Rd | 55 +
man/skulls.Rd | 40 +
man/statico.Rd | 45 +
man/statico.krandtest.Rd | 41 +
man/statis.Rd | 71 +
man/steppe.Rd | 35 +
man/supcol.Rd | 49 +
man/supdist.Rd | 86 ++
man/suprow.Rd | 80 +
man/symbols.phylog.Rd | 41 +
man/syndicats.Rd | 26 +
man/t3012.Rd | 34 +
man/table.cont.Rd | 54 +
man/table.dist.Rd | 26 +
man/table.paint.Rd | 43 +
man/table.phylog.Rd | 48 +
man/table.value.Rd | 42 +
man/tarentaise.Rd | 50 +
man/taxo.eg.Rd | 39 +
man/testdim.Rd | 52 +
man/testdim.multiblock.Rd | 45 +
man/tintoodiel.Rd | 41 +
man/tithonia.Rd | 44 +
man/tortues.Rd | 29 +
man/toxicity.Rd | 35 +
man/triangle.class.Rd | 59 +
man/triangle.plot.Rd | 76 +
man/trichometeo.Rd | 44 +
man/ungulates.Rd | 45 +
man/uniquewt.df.Rd | 32 +
man/variance.phylog.Rd | 48 +
man/varipart.Rd | 77 +
man/vegtf.Rd | 48 +
man/veuvage.Rd | 32 +
man/wca.rlq.Rd | 62 +
man/westafrica.Rd | 103 ++
man/within.Rd | 85 ++
man/withincoinertia.Rd | 65 +
man/withinpca.Rd | 50 +
man/witwit.coa.Rd | 67 +
man/woangers.Rd | 98 ++
man/worksurv.Rd | 85 ++
man/yanomama.Rd | 42 +
man/zealand.Rd | 52 +
src/Makevars | 2 +
src/adesub.c | 1443 ++++++++++++++++++
src/adesub.h | 53 +
src/divsub.c | 735 +++++++++
src/divsub.h | 23 +
src/fourthcorner.c | 2171 ++++++++++++++++++++++++++
src/init.c | 52 +
src/phylog.c | 291 ++++
src/testamova.c | 432 ++++++
src/testdim.c | 297 ++++
src/testrlq.c | 321 ++++
src/tests.c | 1179 +++++++++++++++
628 files changed, 49805 insertions(+), 139 deletions(-)
diff --git a/ChangeLog b/ChangeLog
new file mode 100644
index 0000000..40179e5
--- /dev/null
+++ b/ChangeLog
@@ -0,0 +1,2354 @@
+2017-08-09 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * DESCRIPTION: ---------- release of ade4 1.7-8 ----------
+
+2017-08-09 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/divcmax.Rd: Update the example in 'divcmax' with correction
+ sent by Sandrine Pavoine
+
+2017-08-09 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * DESCRIPTION: Extend the 'Description' field as requested by Uwe
+ Ligges
+
+2017-07-20 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * ChangeLog: ---------- release of ade4 1.7-7 ----------
+
+2017-07-20 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * DESCRIPTION: ---------- release of ade4 1.7-7 ----------
+
+2017-07-19 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * NAMESPACE, R/varipart.R, man/varipart.Rd: Implement a very simple
+ version of variation partitioning (useful for msr method in
+ adespatial)
+
+2017-07-11 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/randtest.pcaiv.R, R/randtest.pcaivortho.R: Solve a bug to deal
+ properly with 'strange' variables names (environmental variables in
+ mafragh)
+
+2017-07-04 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/supdist.R: Add 'drop' argrument to deal with cases where only
+ one supplementary individual is considered.
+
+2017-06-29 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/multiblock.R: The '...' argument is now passed to the
+ as.krandboot function
+
+2017-06-29 Jean Thioulouse <jean.thioulouse at univ-lyon1.fr>
+
+ * man/statico.krandtest.Rd: species data must be in the second ktab
+
+2017-06-29 Jean Thioulouse <jean.thioulouse at univ-lyon1.fr>
+
+ * R/statico.R: species data should not be restandardized in each
+ table
+
+2017-06-23 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/atlas.Rd, man/elec88.Rd, man/irishdata.Rd: Update the help
+ files of 'atlas', 'elec88' and 'irishdata'
+
+2017-06-23 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/mafragh.Rd: Update the mafragh data set: spenames is now a
+ data frame with short names and a new Spatial.contour object is
+ added.
+
+2017-06-23 Jean Thioulouse <jean.thioulouse at univ-lyon1.fr>
+
+ * README.md: Update README.md
+
+2017-06-23 Jean Thioulouse <jean.thioulouse at univ-lyon1.fr>
+
+ * README.md: Update README.md
+
+2017-06-20 Jean Thioulouse <jean.thioulouse at univ-lyon1.fr>
+
+ * README.md: Update README.md
+
+2017-06-20 Jean Thioulouse <jean.thioulouse at univ-lyon1.fr>
+
+ * README.md: Update README.md
+
+2017-06-19 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/supdist.Rd: Clean the 'supdist' help file
+
+2017-06-18 Jean Thioulouse <jean.thioulouse at univ-lyon1.fr>
+
+ * NAMESPACE: added function supdist to project additional items in a
+ PCO analysis
+
+2017-06-18 Jean Thioulouse <jean.thioulouse at univ-lyon1.fr>
+
+ * man/supdist.Rd: Projection of additional items in a PCO analysis
+
+2017-06-18 Jean Thioulouse <jean.thioulouse at univ-lyon1.fr>
+
+ * R/supdist.R: Projection of additional items in a PCO analysis
+
+2017-06-15 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/mafragh.Rd: Correct the mafragh bibliography
+
+2017-06-02 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/mafragh.Rd: Update the 'mafragh' data set
+
+2017-05-12 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/krandtest.R, R/randtest.R: Update as.randtest/as.krandtest
+ functions to deal with cases with 0 repetitions (useful for
+ msr.4thcorner method implemented in adespatial)
+
+2017-04-21 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * NAMESPACE, R/ade4toR.R, man/ade4toR.Rd: The 'ade4toR' and
+ 'Rtoade4' unused functions are removed.
+
+2017-04-21 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * NAMESPACE, R/cca.R, R/randtest.cca.R: The 'cca' function is
+ removed.
+
+2017-04-21 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * NAMESPACE, R/cca.R, R/pcaiv.R, R/randtest.cca.R,
+ R/randtest.pcaiv.R, man/arrival.Rd, man/cca.Rd, man/pcaiv.Rd,
+ man/randtest.pcaiv.Rd, man/rpjdl.Rd: The 'cca' function is no longer
+ used.
+
+2017-04-11 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/s.logo.Rd: Update the example of the 's.logo' function
+
+2017-04-07 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/between.R: Correct a small bug to deal with weights in wca plots
+
+2017-03-23 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * ChangeLog: ---------- release of ade4 1.7-6 ----------
+
+2017-03-23 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * DESCRIPTION: ---------- release of ade4 1.7-6 ----------
+
+2017-03-23 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * NAMESPACE: Fix an error with C routines in a Linux configuration
+
+2017-03-22 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * NAMESPACE, src/init.c: Fix an error with C routines in a Windows
+ configuration (32bit)
+
+2017-03-22 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/divcmax.Rd: Example in divcmax becomes 'dontrun', pending
+ correction
+
+2017-03-20 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * NAMESPACE, src/init.c: Register native routines (new
+ recommendations in R-3.4.0)
+
+2017-02-24 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/dist.ktab.R: Remove some useless checks
+
+2017-02-16 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/casitas.Rd: Update an invalid URL
+
+2017-02-14 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/dist.ktab.R: Revert commit
+ 0894456972fea6668635069832ef6a7739c1f150 (bug was not fixed by the
+ previous corrections).
+
+2017-02-14 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * NAMESPACE, R/RV.rtest.R, R/RVdist.randtest.R, R/betwitdpcoa.R,
+ R/combine.4thcorner.R, R/corkdist.R, R/costatis.R,
+ R/fourthcorner.R, R/fourthcorner.rlq.R, R/fourthcorner2.R,
+ R/gearymoran.R, R/krandtest.R, R/mantel.randtest.R,
+ R/mantel.rtest.R, R/multispati.randtest.R, R/multispati.rtest.R,
+ R/niche.R, R/orthogram.R, R/plot.4thcorner.R, R/procuste.R,
+ R/procuste.randtest.R, R/procuste.rtest.R, R/randtest.R,
+ R/randtest.amova.R, R/randtest.between.R, R/randtest.cca.R,
+ R/randtest.coinertia.R, R/randtest.discrimin.R, R/randtest.dpcoa.R,
+ R/randtest.pcaiv.R, R/randtest.pcaivortho.R, R/randtest.rlq.R,
+ R/rtest.R, R/rtest.between.R, R/rtest.discrimin.R, R/statico.R,
+ R/testdim.R, man/RV.rtest.Rd, man/RVdist.randtest.Rd,
+ man/combine.4thcorner.Rd, man/corkdist.Rd,
+ man/costatis.randtest.Rd, man/fourthcorner.Rd, man/krandtest.Rd,
+ man/mantel.randtest.Rd, man/mantel.rtest.Rd,
+ man/multispati.randtest.Rd, man/multispati.rtest.Rd,
+ man/orthogram.Rd, man/procuste.randtest.Rd, man/procuste.rtest.Rd,
+ man/randtest.Rd, man/rtest.Rd, man/statico.krandtest.Rd: Modify the
+ structures of classes (randtest and rtest) to store outputs of
+ randomization procedures
+
+2017-02-10 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/dist.ktab.R: Correct a bug in the management of fuzzy data.
+ Message of Jean-Yves BARNAGAUD on adelist (08/02/2017).
+
+2017-02-10 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/dist.ktab.R: Reindent lines
+
+2017-02-01 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/divc.Rd, man/divcmax.Rd, man/lizards.Rd, man/newick.eg.Rd,
+ man/randboot.Rd, man/randxval.Rd: Correct some typo
+
+2017-01-31 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/bwca.dpcoa.Rd, man/fourthcorner.Rd, man/mafragh.Rd,
+ man/phylog.Rd: Update bibliographic references (in press)
+
+2017-01-23 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/bwca.dpcoa.Rd, man/julliot.Rd, man/mafragh.Rd,
+ man/multispati.Rd, man/nipals.Rd, man/olympic.Rd, man/pcw.Rd,
+ man/sarcelles.Rd: Solve errors in examples not runned
+
+2017-01-18 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/area.plot.Rd, man/atya.Rd, man/avijons.Rd, man/julliot.Rd:
+ Correct the import of functions of the suggested packages used in
+ some examples.
+
+2017-01-18 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/acacia.Rd, man/area.plot.Rd, man/avijons.Rd, man/between.Rd,
+ man/butterfly.Rd, man/capitales.Rd, man/cca.Rd, man/corvus.Rd,
+ man/doubs.Rd, man/dudi.fca.Rd, man/euro123.Rd, man/gearymoran.Rd,
+ man/ggtortoises.Rd, man/gridrowcol.Rd, man/julliot.Rd,
+ man/kcponds.Rd, man/lascaux.Rd, man/mafragh.Rd, man/meau.Rd,
+ man/multispati.Rd, man/nipals.Rd, man/olympic.Rd,
+ man/orthobasis.Rd, man/pcaivortho.Rd, man/pcw.Rd,
+ man/plot.between.Rd, man/plot.within.Rd, man/presid2002.Rd,
+ man/procuste.Rd, man/randEH.Rd, man/santacatalina.Rd,
+ man/scatter.coa.Rd, man/t3012.Rd, man/trichometeo.Rd,
+ man/westafrica.Rd, man/witwit.coa.Rd, man/zealand.Rd: Complete some
+ T/F in TRUE/FALSE
+
+2017-01-18 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * DESCRIPTION, man/area.plot.Rd, man/atlas.Rd, man/atya.Rd,
+ man/avijons.Rd, man/buech.Rd, man/butterfly.Rd, man/capitales.Rd,
+ man/elec88.Rd, man/ggtortoises.Rd, man/irishdata.Rd,
+ man/julliot.Rd, man/jv73.Rd, man/kcponds.Rd, man/mafragh.Rd,
+ man/maples.Rd, man/mdpcoa.Rd, man/multispati.Rd,
+ man/multispati.randtest.Rd, man/multispati.rtest.Rd, man/neig.Rd,
+ man/nipals.Rd, man/olympic.Rd, man/oribatid.Rd, man/phylog.Rd,
+ man/rhizobium.Rd, man/s.image.Rd, man/s.kde2d.Rd, man/s.logo.Rd,
+ man/t3012.Rd, man/tintoodiel.Rd, man/vegtf.Rd, man/westafrica.Rd:
+ 'quiet' parameter becomes 'quietly' in the 'requireNamespace'
+ function. Add 'adephylo' in the suggested packages. Correct the
+ import of functions of the suggested packages used in examples.
+
+2017-01-13 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/between.R: use weights to properly darw ellipses when
+ non-uniform row weights are used.
+
+2017-01-13 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/within.R: Correct a small bug in plot of wca. Use weights to
+ plot ellipses (this allow that ellipses are centred on 0 when coa is
+ used). Thanks to Sylvain Dolédec.
+
+2017-01-12 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/chats.Rd: Correct typos in a help file
+
+2016-12-20 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/rpjdl.Rd: Correct the species number in the help file of rpjdl
+
+2016-12-13 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * ChangeLog: ---------- release of ade4 1.7-5 ----------
+
+2016-12-13 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * DESCRIPTION: ---------- release of ade4 1.7-5 ----------
+
+2016-12-13 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * README.md: Add badge
+
+2016-11-28 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/PI2newick.Rd, man/ade4.package.Rd, man/adegraphicsLoaded.Rd,
+ man/aminoacyl.Rd, man/apqe.Rd, man/ardeche.Rd, man/as.taxo.Rd,
+ man/atlas.Rd, man/atya.Rd, man/avijons.Rd, man/aviurba.Rd,
+ man/banque.Rd, man/baran95.Rd, man/bca.rlq.Rd, man/between.Rd,
+ man/betweencoinertia.Rd, man/buech.Rd, man/bwca.dpcoa.Rd,
+ man/cailliez.Rd, man/carni70.Rd, man/carniherbi49.Rd,
+ man/casitas.Rd, man/cca.Rd, man/chatcat.Rd, man/chats.Rd,
+ man/clementines.Rd, man/coinertia.Rd, man/combine.4thcorner.Rd,
+ man/corkdist.Rd, man/costatis.Rd, man/costatis.randtest.Rd,
+ man/discrimin.Rd, man/discrimin.coa.Rd, man/dist.binary.Rd,
+ man/dist.dudi.Rd, man/dist.genet.Rd, man/dist.ktab.Rd,
+ man/dist.neig.Rd, man/dist.prop.Rd, man/dist.quant.Rd,
+ man/divcmax.Rd, man/dotchart.phylog.Rd, man/doubs.Rd, man/dpcoa.Rd,
+ man/dudi.Rd, man/dudi.acm.Rd, man/dudi.coa.Rd, man/dudi.dec.Rd,
+ man/dudi.fca.Rd, man/dudi.hillsmith.Rd, man/dudi.mix.Rd,
+ man/dudi.nsc.Rd, man/dudi.pca.Rd, man/dudi.pco.Rd, man/escopage.Rd,
+ man/euro123.Rd, man/foucart.Rd, man/fourthcorner.Rd, man/fruits.Rd,
+ man/gearymoran.Rd, man/granulo.Rd, man/gridrowcol.Rd,
+ man/ichtyo.Rd, man/inertia.dudi.Rd, man/is.euclid.Rd,
+ man/julliot.Rd, man/jv73.Rd, man/kdist.Rd, man/kdist2ktab.Rd,
+ man/kdisteuclid.Rd, man/krandtest.Rd, man/ktab.Rd,
+ man/ktab.data.frame.Rd, man/ktab.list.df.Rd, man/ktab.list.dudi.Rd,
+ man/ktab.match2ktabs.Rd, man/ktab.within.Rd, man/lascaux.Rd,
+ man/lingoes.Rd, man/macon.Rd, man/macroloire.Rd,
+ man/mantel.rtest.Rd, man/mariages.Rd, man/mbpcaiv.Rd, man/mbpls.Rd,
+ man/mcoa.Rd, man/mdpcoa.Rd, man/meau.Rd, man/meaudret.Rd,
+ man/mfa.Rd, man/microsatt.Rd, man/mjrochet.Rd, man/mld.Rd,
+ man/mollusc.Rd, man/monde84.Rd, man/morphosport.Rd,
+ man/multiblock.Rd, man/multispati.randtest.Rd,
+ man/multispati.rtest.Rd, man/newick.eg.Rd, man/newick2phylog.Rd,
+ man/niche.Rd, man/nipals.Rd, man/njplot.Rd, man/originality.Rd,
+ man/orthobasis.Rd, man/orthogram.Rd, man/ours.Rd, man/palm.Rd,
+ man/pcaiv.Rd, man/pcaivortho.Rd, man/phylog.Rd,
+ man/plot.between.Rd, man/plot.phylog.Rd, man/plot.within.Rd,
+ man/procuste.Rd, man/procuste.rtest.Rd, man/pta.Rd,
+ man/quasieuclid.Rd, man/randboot.multiblock.Rd,
+ man/randtest.coinertia.Rd, man/randtest.pcaiv.Rd, man/reconst.Rd,
+ man/rhone.Rd, man/rlq.Rd, man/rpjdl.Rd, man/s.match.class.Rd,
+ man/sarcelles.Rd, man/scalewt.Rd, man/scatter.Rd,
+ man/scatter.fca.Rd, man/scatterutil.Rd, man/sco.class.Rd,
+ man/sco.gauss.Rd, man/sco.label.Rd, man/sco.match.Rd,
+ man/statico.Rd, man/statico.krandtest.Rd, man/steppe.Rd,
+ man/supcol.Rd, man/suprow.Rd, man/symbols.phylog.Rd,
+ man/syndicats.Rd, man/t3012.Rd, man/table.phylog.Rd,
+ man/tarentaise.Rd, man/testdim.Rd, man/testdim.multiblock.Rd,
+ man/trichometeo.Rd, man/ungulates.Rd, man/variance.phylog.Rd,
+ man/veuvage.Rd, man/wca.rlq.Rd, man/westafrica.Rd, man/within.Rd,
+ man/withincoinertia.Rd, man/withinpca.Rd, man/witwit.coa.Rd,
+ man/woangers.Rd, man/worksurv.Rd, src/adesub.c: Correct encoding of
+ Rd files
+
+2016-11-25 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * man/gearymoran.Rd, man/mafragh.Rd, man/multispati.Rd,
+ man/multispati.randtest.Rd, man/multispati.rtest.Rd: Update and
+ clean 'mafragh' data
+
+2016-11-21 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * : Merge pull request #4 from zkamvar/zkamvar-patch-1 Fix bug in randtest.amova
+
+2016-11-20 Zhian N. Kamvar <kamvarz at science.oregonstate.edu>
+
+ * R/randtest.amova.R: fix bug in randtest.amova This bug came up in
+ https://groups.google.com/forum/#!topic/poppr/D1gpqgQM2F0 There is no issue when comparing three hierarchical levels, but when
+ there are four or more, the alternate hypothesis for every fourth
+ level is incorrect due to the recycling of c("less", "greater",
+ "greater").
+
+2016-10-18 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/nipals.R: Correct a small bug identified by Denis Clot in the
+ rescaling of sd
+
+2016-09-27 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/orthobasis.R: Correct a minor bug in the print method of
+ orthobasis objects
+
+2016-09-12 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * README.md: Update homepage
+
+2016-07-22 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * man/dist.ktab.Rd: Update the doc to indicate that ordered
+ variables are not yet considered.
+
+2016-06-10 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * : commit 7a4a263d8ac2822ee89f1cf167e4e118c03b4023 Author:
+ Stéphane Dray <stephane.dray at univ-lyon1.fr> Date: Fri Jun 10
+ 15:50:04 2016 +0200
+
+2016-05-20 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * .Rbuildignore, man/pcw.Rd: Update Rbuildignore
+
+2016-05-13 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/scatterutil.R: Correct a bug when covariance is null (ellipses
+ were reversed)
+
+2016-05-13 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/dudi.pco.R: Correct a bug in the scaling of normed components
+ with non-uniform weights
+
+2016-05-02 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * NAMESPACE, R/inertia.dudi.R, man/inertia.dudi.Rd: The function
+ 'inertia.dudi' now becomes a method. It returns object of class
+ 'inertia' with 'print' and 'summary' methods
+
+2016-03-21 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * man/elec88.Rd: Update the doc and add informations on nb, Spatial
+ and Spatialcontour
+
+2016-03-04 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * NAMESPACE, R/suprow.R, man/suprow.Rd: New methods suprow.acm,
+ suprow.mix and predict.dudi
+
+2016-03-04 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/dudi.hillsmith.R: Function dudi.hillsmith now returns vectors
+ center and norm (useful for the suprow.mix function)
+
+2016-03-01 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * : DESCRIPTION: ---------- release of ade4 1.7-4 ----------
+
+2016-02-24 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * : Merge pull request #3 from Rekyt/patch-1 Correct Reference with DOI
+
+2016-02-22 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * .gitignore: Add a configure file to ignore some files in the Git
+ repository
+
+2016-02-21 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * : commit 93fe29b91eb21adeb4f08e07b432b3b61d54e07a Author:
+ Stéphane Dray <stephane.dray at univ-lyon1.fr> Date: Sun Feb 21
+ 14:33:14 2016 +0100
+
+2016-01-22 Jean Thioulouse <jean.thioulouse at univ-lyon1.fr>
+
+ * R/mfa.R: print.mfa print mfa object class
+
+2015-12-16 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * : commit e983689cedf4c297aae70ee4dcce8cecca1a6b54 Author:
+ Stéphane Dray <stephane.dray at univ-lyon1.fr> Date: Wed Dec 16
+ 10:45:46 2015 +0100
+
+2015-11-26 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * README.md: Add references to the binary packages
+
+2015-11-24 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/dpcoa.R: Update the plot function to represent species (and
+ sites or their diversity according to RaoDecomp argument)
+
+2015-11-24 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/dpcoa.R: Correct a small bug in the handling of species names
+
+2015-11-24 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * : commit 4691e39258ac4c2f743d97f94cbc2b6d94d53ec1 Author:
+ Stéphane Dray <stephane.dray at univ-lyon1.fr> Date: Tue Nov 24
+ 13:58:43 2015 +0100
+
+2015-11-24 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/randtest.dpcoa.R, man/randtest.dpcoa.Rd: Add new function
+ randtest.dpcoa
+
+2015-11-10 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * DESCRIPTION: Add BugReports field
+
+2015-11-10 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * ChangeLog: ---------- release of ade4 1.7-3 ----------
+
+2015-11-10 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * : commit 13ff73165e429972dbfaa2d44f8eaef4ca826324 Author:
+ Stéphane Dray <stephane.dray at univ-lyon1.fr> Date: Tue Nov 10
+ 10:04:42 2015 +0100
+
+2015-11-10 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * DESCRIPTION: ---------- release of ade4 1.7-3 ----------
+
+2015-10-19 Jean Thioulouse <jean.thioulouse at univ-lyon1.fr>
+
+ * R/ktab.R: Change ktab.util.names to allow for ktabs with varying
+ numbers of rows (columns)
+
+2015-10-14 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * DESCRIPTION: Suggest the 'CircStats' package which is used in Rd
+ cross-references
+
+2015-09-21 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/randtest-internal.R, R/randtest.discrimin.R,
+ src/fourthcorner.c, src/tests.c: Remove some unused variables in C
+ code
+
+2015-09-18 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * README.md: Add badges and informations for Mac and Windows users
+
+2015-09-18 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * .travis.yml: Change setting for travis(error was produced due to
+ unchanged dates and version numbers)
+
+2015-09-18 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * .Rbuildignore, appveyor.yml: Add windows check (via appveyor)
+
+2015-09-18 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/mbpcaiv.R, R/mbpls.R, R/multiblock.R: Udate multiblock methods
+ to deal with non-centred data
+
+2015-09-18 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * .Rbuildignore: Add README.md to .Rbuildignore
+
+2015-09-15 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/scalewt.R, man/scalewt.Rd: Correct a bug to allow scaling
+ without centring
+
+2015-09-09 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * : Reorder the levels of season (spring as first)
+
+2015-09-09 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/randtest.rlq.R: Correct a bug to deal with a single trait and/or
+ environmental variable (email by C. ter Braak 28/08/2015)
+
+2015-09-09 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * .Rbuildignore, .travis.yml, README.md: Add travis support and
+ README
+
+2015-08-27 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * R/dudi.R: Use make.unique instead of make.names to produce
+ row.names for outputs. The second is devoted to names (e.g., by
+ avoiding integer which are authorized as row.names)
+
+2015-08-26 Jean Thioulouse <jean.thioulouse at univ-lyon1.fr>
+
+ * R/pta.R: Modify the levels names of supTI
+
+2015-07-15 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * : Reorder the levels of the 'design' factor (use temporal instead
+ of alphabetic order)
+
+2015-07-02 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * DESCRIPTION, NAMESPACE: The default packages other than 'base' are
+ now imported (new item for r-devel)
+
+2015-06-12 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * R/dudi.fca.R, R/utilities.R: Modify the '$call' in 'dudi.fpca'
+
+2015-06-08 Stéphane Dray <stephane.dray at univ-lyon1.fr>
+
+ * NAMESPACE, R/cca.R, man/cca.Rd: New summary method for 'cca'
+ objects
+
+2015-06-01 Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+
+ * DESCRIPTION, man/add.scatter.Rd: Update an exemple which uses the
+ new function 'plotEig' of 'adegraphics'
+
+2015-04-14 07:38 aursiber
+
+ * DESCRIPTION: ---------- release of ade4 1.7-2 ----------
+
+2015-04-08 13:27 aursiber
+
+ * DESCRIPTION: ---------- release of ade4 1.7-1 ----------
+
+2015-04-08 09:25 sdray
+
+ * DESCRIPTION, NAMESPACE, R/orthobasis.R, man/orthobasis.Rd: Add
+ new functions to handle orthobasis objects. The orthobasis.listw
+ function is removed and will be available in the forthcoming
+ adespatial
+
+2015-04-03 16:28 aursiber
+
+ * man/kplot.sepan.Rd: The 'kplot.sepan.coa' function becomes
+ 'kplotsepan.coa' in 'adegraphics' also
+
+2015-04-03 14:30 aursiber
+
+ * NAMESPACE, R/kplot.sepan.R, man/kplot.sepan.Rd: The
+ 'kplot.sepan.coa' function becomes 'kplotsepan.coa'
+
+2015-04-03 14:04 aursiber
+
+ * DESCRIPTION, man/abouheif.eg.Rd, man/avijons.Rd, man/baran95.Rd,
+ man/bsetal97.Rd, man/capitales.Rd, man/chevaine.Rd,
+ man/cnc2003.Rd, man/doubs.Rd, man/ecomor.Rd, man/euro123.Rd,
+ man/ggtortoises.Rd, man/hdpg.Rd, man/jv73.Rd, man/lascaux.Rd,
+ man/lizards.Rd, man/mafragh.Rd, man/maples.Rd, man/microsatt.Rd,
+ man/mjrochet.Rd, man/newick.eg.Rd, man/oribatid.Rd, man/pap.Rd,
+ man/presid2002.Rd, man/procella.Rd, man/rpjdl.Rd,
+ man/tarentaise.Rd, man/trichometeo.Rd: Remove invalid url in man
+ files
+
+2015-03-29 11:59 sdray
+
+ * R/combine.4thcorner.R, R/plot.4thcorner.R: Update the outputs of
+ the combine.4thcorner functions to avoid bugs when the 'D' stat
+ can not be computed (factor with only one level)
+
+2015-03-23 15:40 aursiber
+
+ * DESCRIPTION: ---------- release of ade4 1.7-0 ----------
+
+2015-03-23 10:52 sdray
+
+ * DESCRIPTION: Aurelie is the new official maintainer
+
+2015-03-23 08:45 sdray
+
+ * R/coinertia.R, R/rlq.R: Improve the outputs of the RLQ/coinertia
+ analysis
+
+2015-03-20 09:13 aursiber
+
+ * DESCRIPTION, R/mbpcaiv.R, R/mbpls.R, R/multispati.R,
+ R/orthobasis.R, R/s.image.R, R/s.kde2d.R, R/s.logo.R,
+ man/area.plot.Rd, man/atlas.Rd, man/atya.Rd, man/avijons.Rd,
+ man/buech.Rd, man/butterfly.Rd, man/capitales.Rd, man/ecg.Rd,
+ man/elec88.Rd, man/ggtortoises.Rd, man/irishdata.Rd,
+ man/julliot.Rd, man/jv73.Rd, man/kcponds.Rd, man/mafragh.Rd,
+ man/maples.Rd, man/mdpcoa.Rd, man/multispati.Rd,
+ man/multispati.randtest.Rd, man/multispati.rtest.Rd, man/neig.Rd,
+ man/nipals.Rd, man/olympic.Rd, man/oribatid.Rd, man/pcw.Rd,
+ man/phylog.Rd, man/rhizobium.Rd, man/s.image.Rd, man/s.kde2d.Rd,
+ man/s.logo.Rd, man/sarcelles.Rd, man/score.coa.Rd, man/t3012.Rd,
+ man/tintoodiel.Rd, man/vegtf.Rd, man/westafrica.Rd: Update the
+ use of packages listed in 'Suggests' according with R-3.1.3
+
+2015-03-18 14:07 sdray
+
+ * R/between.R: Correct a bug in 1D plot of plot.between (message of
+ Matthieu Salpeteur 18/03/2015 on adelist)
+
+2015-02-19 19:03 sdray
+
+ * R/dist.dudi.R: Correct a bug to deal with null distances (message
+ of Robin Cura on adelist 16/02/2015
+
+2015-02-18 15:03 sdray
+
+ * R/krandboot.R, R/krandxval.R, R/mbpcaiv.R, R/mbpls.R,
+ R/multiblock.R, R/randxval.R, man/mbpcaiv.Rd, man/mbpls.Rd,
+ man/multiblock.Rd, man/randboot.multiblock.Rd,
+ man/testdim.multiblock.Rd: Update some functions related to
+ multiblock methods. Use 'ginv' to deal with matrices are not of
+ full rank.
+
+2015-01-15 11:50 sdray
+
+ * NAMESPACE, R/betwitdpcoa.R, man/bwca.dpcoa.Rd: Add new functions
+ to perform between- within dpcoa (Dray et al. 2015, MER)
+
+2015-01-09 12:35 sdray
+
+ * src/adesub.c: remove the unused variable 'seed'
+
+2015-01-08 16:47 aursiber
+
+ * man/add.scatter.Rd, man/area.plot.Rd, man/atlas.Rd,
+ man/capitales.Rd, man/chats.Rd, man/corvus.Rd, man/divcmax.Rd,
+ man/gridrowcol.Rd, man/irishdata.Rd, man/mstree.Rd,
+ man/orthobasis.Rd, man/pcw.Rd, man/randxval.Rd, man/rtest.Rd,
+ man/s.class.Rd, man/s.corcircle.Rd, man/s.distri.Rd,
+ man/s.image.Rd, man/s.label.Rd, man/s.logo.Rd, man/s.match.Rd,
+ man/s.traject.Rd, man/s.value.Rd, man/santacatalina.Rd,
+ man/scatterutil.Rd, man/score.Rd, man/table.value.Rd,
+ man/toxicity.Rd, man/triangle.class.Rd, man/westafrica.Rd,
+ man/worksurv.Rd: Modify examples due to modifications in
+ adegraphics
+
+2015-01-08 16:36 sdray
+
+ * src/adesub.c, src/adesub.h: Remove calls to C random number
+ generators (now use R RNG)
+
+2015-01-08 13:59 thioulouse
+
+ * NAMESPACE, R/costatis.R, R/ktab.R, R/pta.R, R/statico.R,
+ man/costatis.Rd, man/costatis.randtest.Rd, man/statico.Rd,
+ man/statico.krandtest.Rd: Added statico.krandtest and
+ costatis.randtest funtions for permutation tests
+
+2014-12-08 14:33 sdray
+
+ * R/fourthcorner.R, R/fourthcorner.rlq.R, R/print.4thcorner.R:
+ Correct a bug to display properly the outputs in the case of 1
+ trait x 1 env variable
+
+2014-11-28 09:38 aursiber
+
+ * man/scatter.coa.Rd: Correct the documentation of the used method
+ in 'scatter.coa'
+
+2014-11-14 08:42 sdray
+
+ * R/mdpcoa.R: correct the call to dist.dna of the ape package
+
+2014-11-14 08:41 sdray
+
+ * NAMESPACE, R/dpcoa.R, R/mdpcoa.R, man/dpcoa.Rd, man/humDNAm.Rd:
+ Update the dpcoa function: names of outputs are modified and the
+ df argument shoul be a site-by-species nor a species-by-sites
+ matrix. This allows to be more coherent with other methods
+
+2014-11-05 15:32 sdray
+
+ * man/atlas.Rd, man/butterfly.Rd, man/chats.Rd, man/dpcoa.Rd,
+ man/gearymoran.Rd, man/gridrowcol.Rd, man/orthobasis.Rd: Modify
+ examples due to modifications in adegraphics
+
+2014-10-30 15:04 sdray
+
+ * data/capitales.rda, man/capitales.Rd: Transform the Spatial
+ component from SpatialPolygonsDataFrame to SpatialPolygons
+
+2014-09-11 14:50 sdray
+
+ * NAMESPACE, R/procuste.R, man/macaca.Rd, man/procuste.Rd: Change
+ names of arguments and outputs of 'procuste' function and add a
+ method 'randtest' for procuste class
+
+2014-09-02 12:04 sdray
+
+ * data/pcw.rda, man/pcw.Rd: Add new dataset (distribution of trees
+ in forest plots along the panama canal)
+
+2014-07-23 14:09 sdray
+
+ * R/fourthcorner.rlq.R: Correct a small bug (used names instead of
+ colnames on a matrix)
+
+2014-06-18 15:26 aursiber
+
+ * DESCRIPTION, NAMESPACE, man/acacia.Rd, man/add.scatter.Rd,
+ man/aravo.Rd, man/ardeche.Rd, man/area.plot.Rd, man/atlas.Rd,
+ man/atya.Rd, man/avijons.Rd, man/avimedi.Rd, man/bacteria.Rd,
+ man/banque.Rd, man/baran95.Rd, man/between.Rd,
+ man/betweencoinertia.Rd, man/bf88.Rd, man/buech.Rd,
+ man/butterfly.Rd, man/capitales.Rd, man/carni70.Rd, man/cca.Rd,
+ man/chats.Rd, man/chazeb.Rd, man/chevaine.Rd, man/clementines.Rd,
+ man/coinertia.Rd, man/coleo.Rd, man/corkdist.Rd, man/corvus.Rd,
+ man/deug.Rd, man/discrimin.Rd, man/dist.prop.Rd,
+ man/dist.quant.Rd, man/doubs.Rd, man/dpcoa.Rd, man/dudi.acm.Rd,
+ man/dudi.coa.Rd, man/dudi.fca.Rd, man/dudi.hillsmith.Rd,
+ man/dudi.mix.Rd, man/dudi.nsc.Rd, man/dudi.pca.Rd, man/ecomor.Rd,
+ man/elec88.Rd, man/euro123.Rd, man/foucart.Rd, man/friday87.Rd,
+ man/fruits.Rd, man/gearymoran.Rd, man/ggtortoises.Rd,
+ man/granulo.Rd, man/gridrowcol.Rd, man/hdpg.Rd,
+ man/housetasks.Rd, man/humDNAm.Rd, man/irishdata.Rd,
+ man/julliot.Rd, man/jv73.Rd, man/kcponds.Rd, man/kdist2ktab.Rd,
+ man/kdisteuclid.Rd, man/kplot.foucart.Rd, man/kplot.mcoa.Rd,
+ man/kplot.mfa.Rd, man/kplot.pta.Rd, man/kplot.sepan.Rd,
+ man/kplot.statis.Rd, man/ktab.Rd, man/ktab.list.df.Rd,
+ man/ktab.list.dudi.Rd, man/lascaux.Rd, man/macaca.Rd,
+ man/macroloire.Rd, man/mafragh.Rd, man/mariages.Rd, man/meau.Rd,
+ man/meaudret.Rd, man/microsatt.Rd, man/mollusc.Rd, man/mstree.Rd,
+ man/multiblock.Rd, man/multispati.Rd, man/neig.Rd, man/niche.Rd,
+ man/nipals.Rd, man/olympic.Rd, man/oribatid.Rd,
+ man/orthobasis.Rd, man/ours.Rd, man/pcaivortho.Rd,
+ man/plot.between.Rd, man/plot.within.Rd, man/presid2002.Rd,
+ man/procuste.Rd, man/pta.Rd, man/rankrock.Rd, man/rpjdl.Rd,
+ man/s.chull.Rd, man/s.image.Rd, man/s.kde2d.Rd,
+ man/s.match.class.Rd, man/santacatalina.Rd, man/sarcelles.Rd,
+ man/scatter.acm.Rd, man/scatter.coa.Rd, man/scatter.dudi.Rd,
+ man/scatter.fca.Rd, man/sco.distri.Rd, man/score.acm.Rd,
+ man/score.pca.Rd, man/seconde.Rd, man/skulls.Rd, man/statis.Rd,
+ man/supcol.Rd, man/suprow.Rd, man/t3012.Rd, man/table.paint.Rd,
+ man/tintoodiel.Rd, man/tortues.Rd, man/toxicity.Rd,
+ man/triangle.plot.Rd, man/trichometeo.Rd, man/vegtf.Rd,
+ man/wca.rlq.Rd, man/westafrica.Rd, man/within.Rd,
+ man/withincoinertia.Rd, man/withinpca.Rd, man/witwit.coa.Rd,
+ man/worksurv.Rd, man/zealand.Rd: Update the examples to become
+ effective when 'adegraphics' is loaded
+
+2014-05-20 13:30 sdray
+
+ * R/add.scatter.R, man/EH.Rd, man/PI2newick.Rd, man/add.scatter.Rd,
+ man/aminoacyl.Rd, man/amova.Rd, man/as.taxo.Rd, man/bacteria.Rd,
+ man/between.Rd, man/betweencoinertia.Rd, man/cailliez.Rd,
+ man/cca.Rd, man/coinertia.Rd, man/corkdist.Rd, man/disc.Rd,
+ man/discrimin.Rd, man/discrimin.coa.Rd, man/dist.binary.Rd,
+ man/dist.dudi.Rd, man/dist.genet.Rd, man/dist.neig.Rd,
+ man/dist.prop.Rd, man/dist.quant.Rd, man/divc.Rd, man/divcmax.Rd,
+ man/dotchart.phylog.Rd, man/dpcoa.Rd, man/dudi.Rd,
+ man/dudi.acm.Rd, man/dudi.coa.Rd, man/dudi.dec.Rd,
+ man/dudi.fca.Rd, man/dudi.hillsmith.Rd, man/dudi.mix.Rd,
+ man/dudi.nsc.Rd, man/dudi.pca.Rd, man/dudi.pco.Rd,
+ man/foucart.Rd, man/gearymoran.Rd, man/gridrowcol.Rd,
+ man/inertia.dudi.Rd, man/is.euclid.Rd, man/kdist.Rd,
+ man/kdist2ktab.Rd, man/kdisteuclid.Rd, man/krandtest.Rd,
+ man/ktab.Rd, man/ktab.data.frame.Rd, man/ktab.list.df.Rd,
+ man/ktab.list.dudi.Rd, man/ktab.within.Rd, man/lingoes.Rd,
+ man/mantel.randtest.Rd, man/mantel.rtest.Rd, man/mcoa.Rd,
+ man/mfa.Rd, man/mld.Rd, man/multispati.Rd,
+ man/multispati.randtest.Rd, man/multispati.rtest.Rd,
+ man/newick.eg.Rd, man/newick2phylog.Rd, man/niche.Rd,
+ man/nipals.Rd, man/njplot.Rd, man/optimEH.Rd, man/originality.Rd,
+ man/orisaved.Rd, man/orthobasis.Rd, man/orthogram.Rd,
+ man/palm.Rd, man/pcaiv.Rd, man/pcaivortho.Rd, man/phylog.Rd,
+ man/plot.between.Rd, man/plot.phylog.Rd, man/plot.within.Rd,
+ man/procuste.Rd, man/procuste.randtest.Rd, man/procuste.rtest.Rd,
+ man/pta.Rd, man/quasieuclid.Rd, man/randEH.Rd,
+ man/randtest.amova.Rd, man/randtest.between.Rd,
+ man/randtest.coinertia.Rd, man/randtest.discrimin.Rd,
+ man/randtest.pcaiv.Rd, man/reconst.Rd, man/rlq.Rd, man/s.logo.Rd,
+ man/s.match.class.Rd, man/scatterutil.Rd, man/sco.class.Rd,
+ man/sco.gauss.Rd, man/sco.label.Rd, man/sco.match.Rd,
+ man/supcol.Rd, man/suprow.Rd, man/symbols.phylog.Rd,
+ man/table.phylog.Rd, man/testdim.Rd, man/variance.phylog.Rd,
+ man/westafrica.Rd, man/within.Rd, man/withincoinertia.Rd,
+ man/withinpca.Rd, man/witwit.coa.Rd: Update email addresses
+
+2014-05-16 15:38 sdray
+
+ * NAMESPACE, R/between.R, R/within.R, man/plot.between.Rd,
+ man/plot.within.Rd: New summary method for within and between
+ classes
+
+2014-05-16 15:19 sdray
+
+ * R/randtest.between.R: Clean the code
+
+2014-04-18 15:50 aursiber
+
+ * R/scatterutil.R, man/area.plot.Rd, man/carni70.Rd,
+ man/divcmax.Rd, man/dudi.acm.Rd, man/ecomor.Rd, man/julliot.Rd,
+ man/microsatt.Rd, man/newick2phylog.Rd, man/orthogram.Rd,
+ man/presid2002.Rd, man/score.Rd: Correct the examples which are
+ not run
+
+2014-04-17 15:44 sdray
+
+ * NAMESPACE, R/krandboot.R, R/krandxval.R, R/mbpcaiv.R, R/mbpls.R,
+ R/multiblock.R, R/randboot.R, R/randxval.R, man/mbpcaiv.Rd,
+ man/mbpls.Rd, man/multiblock.Rd, man/randboot.Rd,
+ man/randboot.multiblock.Rd, man/randxval.Rd,
+ man/testdim.multiblock.Rd: Add new functions for multiblock
+ analysis (coll. with S. Bougeard): multiblock pcaiv and
+ multiblock pls. Add new functions and classes to manage results
+ of two-fold cross-validation and bootstrap
+
+2014-04-17 15:39 sdray
+
+ * data/chickenk.rda, man/chickenk.Rd: New data set chickenk
+
+2014-04-17 15:24 sdray
+
+ * R/testdim.R, man/testdim.Rd: Change argument name for testdim
+ method
+
+2014-04-17 15:22 sdray
+
+ * NAMESPACE, man/bacteria.Rd, man/dudi.acm.Rd,
+ man/dudi.hillsmith.Rd, man/dudi.mix.Rd, man/santacatalina.Rd,
+ man/scatter.coa.Rd: Unexport methods for generic functions
+ scatter and score
+
+2014-04-17 15:19 sdray
+
+ * NAMESPACE, man/adegraphicsLoaded.Rd: Export the function
+ adegraphicsLoaded
+
+2014-04-17 08:19 sdray
+
+ * R/utilities.R: New function 'adegraphicsLoaded' to test if
+ adegraphics is loaded
+
+2014-04-15 08:41 sdray
+
+ * NAMESPACE, R/dudi.R, R/ktab.R, man/dudi.Rd, man/ktab.Rd: Improve
+ '[.ktab' and add '[.dudi': extraction methods allow to select
+ rows and/or columns of dudi and ktab objects
+
+2014-04-15 07:44 sdray
+
+ * ., NAMESPACE, R/ktab.R, R/ktab.data.frame.R, R/ktab.list.df.R,
+ R/ktab.list.dudi.R, R/ktab.match2ktabs.R, R/ktab.within.R,
+ man/ktab.Rd: Clean the building of TL, TC, T4 (they contain names
+ and not numbers) and remove two bugs (building of TC and in
+ [.ktab)
+
+2014-04-11 07:45 sdray
+
+ * R/fourthcorner.rlq.R: Correct a typo
+
+2014-03-13 17:36 sdray
+
+ * R/randtest.rlq.R, src/fourthcorner.c, src/tests.c: Correct some
+ minor bugs and typos
+
+2014-01-14 15:27 thioulouse
+
+ * R/foucart.R, R/kplot.foucart.R, R/kplot.mcoa.R, R/kplot.mfa.R,
+ R/kplot.pta.R, R/kplot.sepan.R, R/kplot.statis.R, R/ktab.R,
+ R/ktab.data.frame.R, R/ktab.list.df.R, R/ktab.list.dudi.R,
+ R/ktab.match2ktabs.R, R/ktab.within.R, R/mcoa.R, R/mdpcoa.R,
+ R/mfa.R, R/pta.R, R/sepan.R, R/statis.R: Global update of TL TC
+ and T4 ktab elements
+
+2014-01-07 15:16 thioulouse
+
+ * R/ktab.R, R/pta.R: row names correction of supIX and supIY in a
+ kcoinertia pta
+
+2013-12-03 13:22 sdray
+
+ * data/mafragh.rda: Modify the order of the sites in the
+ 'SpatialPoints' object to be coherent with the 'nb' object
+
+2013-11-19 15:58 sdray
+
+ * DESCRIPTION: ---------- release of ade4 1.6-2 ----------
+
+2013-11-19 15:56 sdray
+
+ * NAMESPACE: Re-export some internal/utility functions that are
+ used by other packages
+
+2013-11-19 15:55 sdray
+
+ * TITLE: Remove the TITLE file which is no more used
+
+2013-11-15 22:41 sdray
+
+ * DESCRIPTION: ---------- release of ade4 1.6-1 ----------
+
+2013-11-15 22:43 sdray
+
+ * man/add.scatter.Rd, man/capitales.Rd, man/dist.ktab.Rd,
+ man/dotchart.phylog.Rd, man/fourthcorner.Rd, man/nipals.Rd,
+ man/s.match.class.Rd, man/scatter.Rd: Reduce line widths
+
+2013-11-14 12:47 sdray
+
+ * DESCRIPTION: ---------- release of ade4 1.6-0 ----------
+
+2013-10-30 12:23 sdray
+
+ * NAMESPACE, man/acacia.Rd, man/add.scatter.Rd, man/ade4toR.Rd,
+ man/as.taxo.Rd, man/avimedi.Rd, man/baran95.Rd,
+ man/combine.4thcorner.Rd, man/costatis.Rd, man/fourthcorner.Rd,
+ man/granulo.Rd, man/kplot.pta.Rd, man/kplot.sepan.Rd,
+ man/kplot.statis.Rd, man/ktab.match2ktabs.Rd, man/ktab.within.Rd,
+ man/meau.Rd, man/meaudret.Rd, man/pcaivortho.Rd, man/phylog.Rd,
+ man/plot.phylog.Rd, man/randtest.amova.Rd, man/reconst.Rd,
+ man/rhone.Rd, man/rlq.Rd, man/rtest.between.Rd,
+ man/scatterutil.Rd, man/statico.Rd, man/statis.Rd, man/supcol.Rd,
+ man/suprow.Rd, man/taxo.eg.Rd, man/ungulates.Rd: The NAMESPACE
+ file (which exported all functions) has be completely rewritten.
+ Utilities and deprecated functions are not exported. S3 methods
+ are declared. Several help pages have been modified to manage
+ these changes.
+
+2013-10-30 12:20 sdray
+
+ * R/rtest.between.R: Now the rtest.between can handle objects
+ created with between and bca functions
+
+2013-10-30 12:19 sdray
+
+ * R/supcol.R, R/suprow.R: suprow.default and supcol.default become
+ suprow.dudi and supcol.dudi
+
+2013-10-28 13:55 sdray
+
+ * R/statis.R: Improve the speed of statis function. Thanks to
+ Benoit Thieurmel (email sent 11/01/2013)
+
+2013-10-28 12:53 sdray
+
+ * R/mcoa.R: Correct a bug in the scaling of Tl1. Thanks to P. Bady,
+ adelist 3/10/2013
+
+2013-10-03 11:26 sdray
+
+ * R/ktab.within.R: Correct a bug in ktab.within: column names were
+ not handle correctly in some cases (Thanks to Pierre Bady,
+ message on adelist 3/10/2013). Moreover, the order of bloc is
+ given by levels and nor unique
+
+2013-09-19 15:58 sdray
+
+ * data/atlas.rda, data/atya.rda, data/avijons.rda, data/buech.rda,
+ data/butterfly.rda, data/capitales.rda, data/elec88.rda,
+ data/ggtortoises.rda, data/irishdata.rda, data/julliot.rda,
+ data/jv73.rda, data/kcponds.rda, data/mafragh.rda,
+ data/sarcelles.rda, data/t3012.rda, data/tintoodiel.rda,
+ data/vegtf.rda, data/zealand.rda, man/cailliez.Rd,
+ man/capitales.Rd, man/lingoes.Rd, man/s.logo.Rd: Correct a small
+ bug in data files and update the help files to pass R CMD check
+
+2013-09-19 11:39 sdray
+
+ * data/atlas.rda, data/atya.rda, data/avijons.rda, data/buech.rda,
+ data/butterfly.rda, data/capitales.rda, data/elec88.rda,
+ data/ggtortoises.rda, data/irishdata.rda, data/julliot.rda,
+ data/jv73.rda, data/kcponds.rda, data/mafragh.rda,
+ data/sarcelles.rda, data/t3012.rda, data/tintoodiel.rda,
+ data/vegtf.rda, data/zealand.rda: Add Spatial/nb objects in data
+ files to prepare the future deprecation of area/neig/contour
+ objects. Moreover, spatial information in data sets 't3012',
+ 'elec88' and 'capitales' has been updated (coordinate system,
+ city names, etc).
+
+2013-09-17 15:08 sdray
+
+ * R/scalewt.R: Correct a small bug in scalewt
+
+2013-07-23 22:24 sdray
+
+ * R/plot.4thcorner.R, man/fourthcorner.Rd: Add colors in
+ fourthcorner plots
+
+2013-05-28 08:10 sdray
+
+ * R/scalewt.R: correct a small bug in scalewt when scale = FALSE
+
+2013-05-07 21:45 sdray
+
+ * R/combine.4thcorner.R, R/fourthcorner.R, R/fourthcorner.rlq.R,
+ R/fourthcorner2.R, R/p.adjust.4thcorner.R, R/plot.4thcorner.R,
+ R/print.4thcorner.R, R/summary.4thcorner.R, R/table.value.R,
+ man/combine.4thcorner.Rd, man/fourthcorner.Rd, man/rlq.Rd,
+ src/fourthcorner.c: Complete reimplementation of the outputs of
+ fourthcorner functions. Now they return krandtest/randtest
+ objects and adjustments for multiple tests can be used.
+ Experimental fourthcorner.rlq
+
+2013-05-07 19:51 sdray
+
+ * data/aravo.rda, man/aravo.Rd: New dataset: aravo
+
+2013-05-03 16:01 sdray
+
+ * R/scatterutil.R: New argument 'bg' for scatterutil.base function
+
+2013-04-30 21:07 sdray
+
+ * R/randtest-internal.R, R/randtest.coinertia.R, R/randtest.rlq.R,
+ R/rlq.R, man/rlq.Rd, src/adesub.c, src/adesub.h, src/testrlq.c,
+ src/tests.c: Use the new 'dudi.type' function. New 'modeltype'
+ argument for randtest.rlq. New function 'combine.randtest.rlq'.
+
+2013-04-29 15:55 sdray
+
+ * R/krandtest.R, man/krandtest.Rd: Update the doc of krandtest
+
+2013-04-29 15:29 sdray
+
+ * R/dudi.acm.R: Use the new fac2disj utility function
+
+2013-04-29 15:28 sdray
+
+ * R/dudi.acm.R, R/dudi.hillsmith.R, R/dudi.mix.R, R/fourthcorner.R,
+ R/fourthcorner2.R, R/rlq.R, R/s.class.R, R/s.match.class.R,
+ R/triangle.class.R, man/ade4-internal.Rd: Use the new fac2disj
+ utility function
+
+2013-04-29 13:14 sdray
+
+ * R/krandtest.R: krandtest can now handle adjustments for multiple
+ testing
+
+2013-04-26 15:31 sdray
+
+ * R/coinertia.R: Correct a small bug in the choice of the number of
+ kept axes
+
+2013-04-26 15:26 sdray
+
+ * R/dudi.acm.R, R/utilities.R, man/ade4-internal.Rd,
+ man/randtest-internal.Rd: New utilities functions
+
+2013-04-26 15:03 sdray
+
+ * R/scalewt.R, man/scalewt.Rd: New functions to compute weighted
+ mean/var/cov for the levels of a factor
+
+2013-04-26 11:38 sdray
+
+ * R/dpcoa.R: dpcoa now returns
+
+2013-04-05 12:31 sdray
+
+ * DESCRIPTION: ---------- release of ade4 1.5-2 ----------
+
+2013-01-09 14:42 sdray
+
+ * R/procuste.R, man/procuste.Rd: value 'nfact' is renamed 'nf'
+
+2012-10-18 10:27 thioulouse
+
+ * man/coinertia.Rd: Small typo fix
+
+2012-10-18 10:26 thioulouse
+
+ * R/betweencoinertia.R: Fixed a bug introduced in print.betcoi
+ function
+
+2012-10-17 16:29 sdray
+
+ * src/tests.c: Correct a small bug in loops for the acm case
+
+2012-10-17 15:49 sdray
+
+ * R/randtest-internal.R, src/testrlq.c, src/tests.c: Clean the C
+ code and correct a small bug (R strings were transformed in
+ integers in C) that provokes problems on Mac OS X (thanks to
+ Vincent Miele for his help)
+
+2012-10-17 15:47 sdray
+
+ * R/rlq.R: Correct the number of repetitions in randtest.rlq (was
+ nrepet+1 instead of nrepet)
+
+2012-10-16 13:32 thioulouse
+
+ * R/betweencoinertia.R, R/coinertia.R, man/coinertia.Rd: Edited
+ print functions for coinertia and betweencoinertia analyses
+
+2012-10-16 13:30 thioulouse
+
+ * R/scatter.fca.R: Bug correction in the call to s.distri: needed
+ to be pass the xax and yax params
+
+2012-09-21 16:02 sdray
+
+ * R/sco.gauss.R: Correct a bug: dnorm has 'sd' as arguments and not
+ 'var' (Thanks to Alice Julien-Laferriere)
+
+2012-09-14 11:21 sdray
+
+ * DESCRIPTION: ---------- release of ade4 1.5-1 ----------
+
+2012-09-14 11:19 sdray
+
+ * R/randtest.cca.R, R/randtest.pcaiv.R, R/randtest.pcaivortho.R:
+ Calls to Fortran routine 'dqrls' are replaced by public 'lm.wfit'
+
+2012-07-27 14:49 sdray
+
+ * R/bca.rlq.R, R/between.R, R/betweencoinertia.R, R/coinertia.R,
+ R/corkdist.R, R/discrimin.R, R/dpcoa.R, R/dudi.R, R/dudi.acm.R,
+ R/kplot.sepan.R, R/mcoa.R, R/multispati.R, R/niche.R,
+ R/randtest.coinertia.R, R/randtest.discrimin.R, R/rlq.R,
+ R/rtest.between.R, R/rtest.discrimin.R, R/scatter.acm.R,
+ R/scatter.fca.R, R/score.acm.R, R/score.coa.R, R/score.mix.R,
+ R/score.pca.R, R/testdim.R, R/wca.rlq.R, R/withincoinertia.R,
+ R/witwit.R, R/witwitsepan.R: Use eval.parent(..) instead of
+ eval(.., sys.frame(0)) to allow the call of ade4 functions inside
+ other functions
+
+2012-07-25 13:30 sdray
+
+ * R/coinertia.R: Update the summary.coinertia function that now
+ returns invisible results
+
+2012-07-25 13:28 sdray
+
+ * R/dudi.R: To avoid confusion, the term 'Explained' is replaced by
+ 'Projected' in the summary.dudi function
+
+2012-07-25 12:47 sdray
+
+ * R/pcaiv.R, R/pcaivortho.R, man/pcaiv.Rd, man/pcaivortho.Rd: New
+ functions 'summary.pcaiv' and 'summary.pcaivortho'
+
+2012-07-25 12:46 sdray
+
+ * R/dudi.R, man/dudi.Rd: New function 'summary.dudi'
+
+2012-07-25 10:53 sdray
+
+ * R/variance.phylog.R, man/variance.phylog.Rd: Returned is now an
+ 'anova' object (was 'table')
+
+2012-07-25 09:23 sdray
+
+ * R/bca.rlq.R, R/between.R, R/betweencoinertia.R, R/coinertia.R,
+ R/discrimin.R, R/dpcoa.R, R/dudi.R, R/foucart.R, R/ktab.R,
+ R/mcoa.R, R/mfa.R, R/multispati.R, R/niche.R, R/nipals.R,
+ R/pcaiv.R, R/pcaivortho.R, R/pta.R, R/rlq.R, R/sepan.R,
+ R/statis.R, R/variance.phylog.R, R/wca.rlq.R, R/within.R,
+ R/withincoinertia.R, R/witwit.R: Outputs produced by print.*
+ functions are now matrices (were table)
+
+2012-07-10 12:03 thioulouse
+
+ * R/coinertia.R: Fix the problem of complex eigenvalues sometimes
+ returned by eigen in the case n < (p, q)
+
+2012-06-01 07:23 jombart
+
+ * R/orthogram.R, man/ade4-deprecated.Rd, man/orthogram.Rd:
+ Orthogram function is now deprecated.
+
+2012-04-23 12:29 sdray
+
+ * src/testdim.c: Correct a small bug (void function cannot return
+ values)
+
+2012-04-23 07:59 sdray
+
+ * man/neig.Rd: Modify an example due to a change in the deldir
+ package
+
+2012-04-19 11:11 sdray
+
+ * DESCRIPTION: ---------- release of ade4 1.5-0 ----------
+
+2012-04-17 15:23 sdray
+
+ * R/bca.rlq.R, R/wca.rlq.R, data/piosphere.rda, man/bca.rlq.Rd,
+ man/piosphere.Rd, man/wca.rlq.Rd: Add functions/data for partial
+ RLQ analysis proposed by Wesuls et al (2012)
+
+2012-04-16 13:06 sdray
+
+ * R/ade4toR.R, R/amova.R, R/area.plot.R, R/between.R,
+ R/betweencoinertia.R, R/cailliez.R, R/coinertia.R, R/corkdist.R,
+ R/costatis.R, R/discrimin.R, R/dist.quant.R, R/dotcircle.R,
+ R/dpcoa.R, R/dudi.acm.R, R/dudi.hillsmith.R, R/dudi.pco.R,
+ R/foucart.R, R/gearymoran.R, R/is.euclid.R, R/kdisteuclid.R,
+ R/kplot.foucart.R, R/kplot.mcoa.R, R/kplot.mfa.R, R/kplot.pta.R,
+ R/kplot.sepan.R, R/kplot.statis.R, R/lingoes.R, R/mcoa.R,
+ R/mdpcoa.R, R/mfa.R, R/multispati.R, R/neig.R, R/newick2phylog.R,
+ R/niche.R, R/nipals.R, R/orthobasis.R, R/orthogram.R, R/pcaiv.R,
+ R/pcaivortho.R, R/plot.phylog.R, R/procuste.R, R/pta.R,
+ R/quasieuclid.R, R/rlq.R, R/s.arrow.R, R/s.corcircle.R,
+ R/s.hist.R, R/s.kde2d.R, R/s.match.R, R/s.multinom.R,
+ R/s.traject.R, R/s.value.R, R/scatter.acm.R, R/scatter.coa.R,
+ R/scatter.dudi.R, R/scatter.fca.R, R/scatterutil.R,
+ R/sco.quant.R, R/score.acm.R, R/score.mix.R, R/sepan.R,
+ R/statis.R, R/symbols.phylog.R, R/table.cont.R, R/table.dist.R,
+ R/table.paint.R, R/table.phylog.R, R/table.value.R,
+ R/triangle.plot.R, R/within.R, R/withincoinertia.R, R/witwit.R,
+ R/witwitsepan.R: Use full argument names to avoid partial
+ matching
+
+2012-04-07 21:29 sdray
+
+ * DESCRIPTION: ---------- release of ade4 1.4-18 ----------
+
+2012-04-07 21:16 sdray
+
+ * R/testdim.R, src/testdim.c: Modify testdim functions to avoid
+ calls to 'exit' in C code
+
+2012-04-07 21:13 sdray
+
+ * NAMESPACE, R/ade4.R: Remove .FirstLib and use NAMESPACE
+ (UseDynLib) to load DLL
+
+2012-04-02 16:23 sdray
+
+ * data/bacteria.rda, data/capitales.rda, data/elec88.rda,
+ data/hdpg.rda, data/irishdata.rda, data/lascaux.rda,
+ data/mafragh.rda, data/perthi02.rda, data/tarentaise.rda,
+ data/vegtf.rda: resave some data files to improve file
+ compression
+
+2012-03-16 05:55 sdray
+
+ * DESCRIPTION: Update email addresses
+
+2012-01-20 12:45 jombart
+
+ * DESCRIPTION, NAMESPACE: Added a namespace (the default one
+ generated by R 2.14.1) to ensure compatibility with older R
+ release. Now stating the dependency on R >= 2.10 in DESCRIPTION.
+
+2011-11-07 15:21 sdray
+
+ * R/mantel.rtest.R: Improve the performance (speed) of the
+ permutation procedure (suggestion by Josh Wiley jwiley.psych at
+ gmail.com)
+
+2011-05-11 11:31 sdray
+
+ * INDEX: Delete INDEX file so that it would be generated and
+ updated automatically
+
+2011-04-22 11:13 sdray
+
+ * R/randtest.between.R, man/randtest.between.Rd: Update the
+ function to deal with objects created by the new bca function
+
+2011-04-11 14:23 sdray
+
+ * DESCRIPTION: ---------- release of ade4 1.4-17 ----------
+
+2011-04-07 12:00 sdray
+
+ * R/pcaiv.R: Correct a bug: intercept is not included in 'cor'
+ to avoid a warning produced by scalewt
+
+2011-04-07 11:32 sdray
+
+ * R/mfa.R, man/mfa.Rd, man/statis.Rd: Correct the documentation
+ (suggestion by D. Laloe) and improve the code of mfa (use of
+ match.arg to consider the argument 'option'
+
+2011-04-07 11:10 sdray
+
+ * R/withinpca.R, man/withinpca.Rd: Improve the documentation
+ (suggestion by L. Dubroca on adelist 01/03/2011) and the code
+ (suggestion by D. Laloe)
+
+2011-04-07 07:45 sdray
+
+ * R/between.R, R/betweencoinertia.R, R/within.R,
+ R/withincoinertia.R, man/between.Rd, man/betweencoinertia.Rd,
+ man/plot.between.Rd, man/plot.within.Rd, man/within.Rd,
+ man/withincoinertia.Rd: Functions within, withincoinertia,
+ betwee, betweencoinertia are now deprecated to avoid a conflict
+ names with the base:::within. New generic bca, wca with methods
+ bca.dudi, bca.coinertia, wca.dudi and wca.coinertia should be
+ used instead.
+
+2011-04-06 16:06 sdray
+
+ * man/scatter.Rd: Correct a typo
+
+2011-04-06 16:06 sdray
+
+ * man/scatter.Rd: Add the doc for the 'main' argument
+
+2011-04-06 14:33 sdray
+
+ * R/dudi.R, man/scatter.Rd: New generic functions 'biplot' and
+ 'screeplot' to plot the outputs of an analysis (class dudi)
+
+2011-02-24 14:11 sdray
+
+ * data/macroloire.rda, data/rhizobium.rda, data/woangers.rda:
+ Compress some ASCII data files
+
+2011-02-24 14:00 sdray
+
+ * R/quasieuclid.R: Attributes of the original dist object are
+ preserved
+
+2011-02-24 13:55 sdray
+
+ * R/cailliez.R, R/lingoes.R, man/cailliez.Rd, man/lingoes.Rd: Add
+ an argument to correct (or not) null distances
+
+2011-02-24 13:47 sdray
+
+ * R/is.euclid.R: Add a warning for null distances
+
+2010-09-27 14:42 sdray
+
+ * man/corvus.Rd: Correct a typo concerning the units of two
+ variables (cm -> mm). Thanks to Peter Saly
+
+2010-08-18 15:25 sdray
+
+ * ChangeLog: ---------- release of ade4 1.4-16 ----------
+
+2010-08-18 15:10 sdray
+
+ * DESCRIPTION: ---------- release of ade4 1.4-16 ----------
+
+2010-05-08 05:41 thioulouse
+
+ * data/meaudret.rda: Updated meaudret environmental dataframe names
+
+2010-05-06 16:16 sdray
+
+ * man/triangle.class.Rd: Remove auto-generated content in the
+ documentation
+
+2010-04-29 14:49 sdray
+
+ * R/s.class.R: argument 'pch' is now recycled so that one symbol
+ could be assigned to each point. Thanks to Vincent Le Garrec for
+ his question.
+
+2010-04-12 08:10 sdray
+
+ * man/dist.binary.Rd: Correct some bibliographic references. Thanks
+ to Pierre Legendre.
+
+2010-03-19 13:19 sdray
+
+ * R/dist.ktab.R: Correct a small bug in the ldist.ktab function
+
+2010-03-10 09:13 thioulouse
+
+ * man/ktab.match2ktabs.Rd: removed deprecated email address in
+ ktab.match2ktabs documentation file
+
+2010-03-05 15:06 jombart
+
+ * R/scalewt.R: Fixed a bug in the scaling of multivariate data
+ using scalewt: when units of the variable were too heterogeneous,
+ variables with the smallest variances were not scaled. This did
+ not affect dudi.pca, but other functions such as discrimin.
+
+2010-02-10 12:12 sdray
+
+ * man/rlq.Rd: Correct a typo in the description
+
+2010-02-10 12:00 sdray
+
+ * man/rlq.Rd: Correct a typo in the description
+
+2009-12-18 08:46 sdray
+
+ * man/fourthcorner.Rd: Add information on the outputs of the print
+ and summary functions
+
+2009-12-09 14:49 sdray
+
+ * man/banque.Rd, man/dudi.fca.Rd, man/fruits.Rd, man/meau.Rd,
+ man/meaudret.Rd, man/monde84.Rd, man/ours.Rd, man/rhizobium.Rd,
+ man/woangers.Rd, man/worksurv.Rd: Correct the use of the command
+ '\item' in '\enumerate' environment
+
+2009-12-04 13:33 sdray
+
+ * R/plot.4thcorner.R, man/fourthcorner.Rd, src/fourthcorner.c: The
+ argument 'type' in plot.4thcorner can now takes the value D2 to
+ plot correlation instead of homogeneity statistics in the case of
+ qualitative / quantitative association
+
+2009-12-04 13:28 sdray
+
+ * man/dist.ktab.Rd, man/woangers.Rd: Put some examples in
+ '\dontrun' to speed up the checking of example
+
+2009-12-03 13:27 sdray
+
+ * ChangeLog: ---------- release of ade4 1.4-14 ----------
+
+2009-12-03 13:22 sdray
+
+ * DESCRIPTION: ---------- release of ade4 1.4-14 ----------
+
+2009-12-01 10:01 sdray
+
+ * DESCRIPTION, man/area.plot.Rd, man/neig.Rd, man/oribatid.Rd: Use
+ the package 'deldir' instead of 'tripack' which has serious
+ license issues. Correct the use of the class polylist which is
+ not exported in the new version of maptools (0.7-27)
+
+2009-11-12 12:08 thioulouse
+
+ * R/costatis.R: changes to the costatis function to remove cat
+ outputs in non-interactive mode (i.e., when scannf = FALSE)
+
+2009-11-12 08:40 sdray
+
+ * R/s.match.class.R, man/s.match.class.Rd: Add new function
+ 's.match.class' to represent two systems of coordinates and a
+ partitioning
+
+2009-11-12 08:38 sdray
+
+ * R/betweencoinertia.R, R/withincoinertia.R, man/betweencoinertia.Rd,
+ man/withincoinertia.Rd: Add new functions
+ 'betweencoinertia' and 'withincoinertia' for between- and
+ within-coinertia analysis
+
+2009-11-09 12:06 thioulouse
+
+ * R/costatis.R, R/statico.R, man/costatis.Rd, man/statico.Rd,
+ man/wgcoia.Rd: New functions to perform STATICO and CO-STATIS
+
+2009-10-30 08:49 sdray
+
+ * R/kdisteuclid.R: Use 'match.arg' to evaluate the value of the
+ 'method' argument
+
+2009-10-29 08:56 sdray
+
+ * DESCRIPTION: ---------- release of ade4 1.4-13 ----------
+
+2009-10-28 15:29 abdufour
+
+ * data/meaudret.rda: addition of the species names in the dataset
+
+2009-10-28 15:08 abdufour
+
+ * man/meau.Rd, man/meaudret.Rd: information about the link between
+ the two datasets meau and meaudret has been added
+
+2009-10-28 14:13 sdray
+
+ * R/phylog.R, R/plot.phylog.R: Correct bug in the use of basic
+ regular expressions (argument 'extended' is deprecated R 2.11.0)
+
+2009-10-27 14:50 spavoine
+
+ * R/originality.R, man/originality.Rd: new methods have been added
+ in the originality function
+
+2009-10-27 14:08 spavoine
+
+ * data/woangers.rda, man/woangers.Rd, man/rhizobium.Rd, data/rhizobium.rda,
+ data/macroloire.rda, man/macroloire.Rd: three new data sets added
+
+2009-10-27 14:05 spavoine
+
+ * R/dist.ktab.R, man/dist.ktab.Rd: new functions of distance for
+ multiple types of variables
+
+2009-10-27 14:01 spavoine
+
+ * R/apqe.R, man/apqe.Rd: new functions for diversity partitioning
+
+2009-10-27 13:59 spavoine
+
+ * R/mdpcoa.R, man/mdpcoa.Rd: new functions for multiple dpcoa
+
+2009-10-23 12:21 sdray
+
+ * ChangeLog: ---------- release of ade4 1.4-12 ----------
+
+2009-10-23 12:19 sdray
+
+ * DESCRIPTION: ---------- release of ade4 1.4-12 ----------
+
+2009-10-21 14:18 sdray
+
+ * data/toxicity.rda, man/toxicity.Rd: Correct species names and
+ table dimensions (thanks to Jean Lobry)
+
+2009-10-21 13:34 thioulouse
+
+ * R/dudi.R: bug on row.names in as.dudi (thanks to Jean Lobry)
+
+2009-10-20 14:18 sdray
+
+ * R/newick2phylog.R: Correct bug in the use of basic regular
+ expressions
+
+2009-10-20 14:15 sdray
+
+ * man/multispati.Rd, man/multispati.randtest.Rd,
+ man/multispati.rtest.Rd: update links to spdep functions in the
+ documentation
+
+2009-10-02 09:07 simonpenel
+
+ * R/newick2phylog.R, man/s.value.Rd, man/variance.phylog.Rd: Minor
+ bugs have been fixes. Replace extended = FALSE by fixed = TRUE
+
+2009-09-22 08:10 thioulouse
+
+ * man/scatter.dudi.Rd: added some precision about biplots in
+ scatter.dudi.Rd
+
+2009-07-24 14:53 thioulouse
+
+ * R/pta.R: corrected a small bug in row names of supIX and supIY df
+
+2009-05-11 09:19 sdray
+
+ * R/dist.binary.R, man/dist.binary.Rd: Numeric matrix can be used
+ for the 'df' argument (request of E. Paradis)
+
+2009-04-20 15:53 sdray
+
+ * R/area.plot.R: argument nclasslegend is now active. bug
+ identified by C. Calenge
+
+2009-04-01 11:11 sdray
+
+ * ChangeLog: ---------- release of ade4 1.4-11 ----------
+
+2009-04-01 11:07 sdray
+
+ * DESCRIPTION: ---------- release of ade4 1.4-11 ----------
+
+2009-03-26 14:14 sdray
+
+ * man/buech.Rd, man/corvus.Rd, man/dist.binary.Rd,
+ man/dist.prop.Rd, man/dist.quant.Rd, man/kplot.mcoa.Rd,
+ man/kplot.pta.Rd, man/ktab.Rd, man/maples.Rd, man/mcoa.Rd,
+ man/mfa.Rd, man/njplot.Rd, man/orthogram.Rd, man/phylog.Rd,
+ man/randtest.coinertia.Rd, man/scatter.fca.Rd,
+ man/scatterutil.Rd, man/supcol.Rd, man/withinpca.Rd: Make Rd
+ files pass R-2.9.0 (devel) parser 2 checks
+
+2009-02-03 12:39 abdufour
+
+ * man/randEH.Rd: replace PD in EH
+
+2009-02-03 12:32 abdufour
+
+ * man/optimEH.Rd: replace PD in EH
+
+2008-12-12 14:04 sdray
+
+ * ChangeLog: ---------- release of ade4 1.4-10 ----------
+
+2008-12-12 14:03 sdray
+
+ * DESCRIPTION: ---------- release of ade4 1.4-10 ----------
+
+2008-12-11 14:45 sdray
+
+ * R/combine.4thcorner.R, R/fourthcorner.R, R/fourthcorner2.R,
+ R/plot.4thcorner.R, R/print.4thcorner.R, R/summary.4thcorner.R,
+ man/fourthcorner.Rd, src/fourthcorner.c: new functions
+ implementing the fourthcorner method and extensions presented in
+ Dray and Legendre (2008)
+
+2008-12-11 13:23 sdray
+
+ * src/adesub.c, src/adesub.h, src/testdim.c: new functions to
+ permute matrices used in testdim and fourthcorner are now in
+ adesub
+
+2008-12-11 13:14 sdray
+
+ * man/RVdist.randtest.Rd, man/randtest-internal.Rd,
+ man/scatterutil.Rd: remove empty sections
+
+2008-12-11 13:05 sdray
+
+ * man/dudi.fca.Rd: add a second argument to the \item macro
+
+2008-12-11 13:04 sdray
+
+ * man/witwit.coa.Rd: remove invalid whitespaces
+
+2008-12-01 15:34 jombart
+
+ * R/gearymoran.R: small typo repared
+
+2008-12-01 15:19 jombart
+
+ * R/gearymoran.R: Added a match.arg to gearymoran (in multivariate
+ case, was messed up.
+
+2008-06-30 10:55 sdray
+
+ * R/niche.R: Add a global test of the average marginality for all
+ species
+
+2008-06-13 10:33 jombart
+
+ * R/dudi.acm.R, R/dudi.coa.R, R/dudi.dec.R, R/dudi.fca.R,
+ R/dudi.hillsmith.R, R/dudi.mix.R, R/dudi.nsc.R, R/dudi.pca.R:
+ Added a as.data.frame(df) to dudi methods.
+
+2008-06-11 11:04 sdray
+
+ * data/abouheif.eg.rda: new data files
+
+2008-06-11 10:59 sdray
+
+ * data/acacia.rda, data/aminoacyl.rda, data/apis108.rda,
+ data/ardeche.rda, data/arrival.rda, data/atlas.rda,
+ data/atya.rda, data/avijons.rda, data/avimedi.rda,
+ data/aviurba.rda, data/bacteria.rda, data/banque.rda,
+ data/baran95.rda, data/bf88.rda, data/bordeaux.rda,
+ data/bsetal97.rda, data/buech.rda, data/butterfly.rda,
+ data/capitales.rda, data/carni19.rda, data/carni70.rda,
+ data/carniherbi49.rda, data/casitas.rda, data/chatcat.rda,
+ data/chats.rda, data/chazeb.rda, data/chevaine.rda,
+ data/clementines.rda, data/cnc2003.rda, data/coleo.rda,
+ data/corvus.rda, data/deug.rda, data/doubs.rda,
+ data/dunedata.rda, data/ecg.rda, data/ecomor.rda,
+ data/elec88.rda, data/escopage.rda, data/euro123.rda,
+ data/fission.rda, data/friday87.rda, data/fruits.rda,
+ data/ggtortoises.rda, data/granulo.rda, data/hdpg.rda,
+ data/housetasks.rda, data/humDNAm.rda, data/ichtyo.rda,
+ data/irishdata.rda, data/julliot.rda, data/jv73.rda,
+ data/kcponds.rda, data/lascaux.rda, data/lizards.rda,
+ data/macaca.rda, data/macon.rda, data/mafragh.rda,
+ data/maples.rda, data/mariages.rda, data/meau.rda,
+ data/meaudret.rda, data/microsatt.rda, data/mjrochet.rda,
+ data/mollusc.rda, data/monde84.rda, data/morphosport.rda,
+ data/newick.eg.rda, data/njplot.rda, data/olympic.rda,
+ data/oribatid.rda, data/ours.rda, data/palm.rda, data/pap.rda,
+ data/perthi02.rda, data/presid2002.rda, data/procella.rda,
+ data/rankrock.rda, data/rhone.rda, data/rpjdl.rda,
+ data/santacatalina.rda, data/sarcelles.rda, data/seconde.rda,
+ data/skulls.rda, data/steppe.rda, data/syndicats.rda,
+ data/t3012.rda, data/tarentaise.rda, data/taxo.eg.rda,
+ data/tintoodiel.rda, data/tithonia.rda, data/tortues.rda,
+ data/toxicity.rda, data/trichometeo.rda, data/ungulates.rda,
+ data/vegtf.rda, data/veuvage.rda, data/westafrica.rda,
+ data/worksurv.rda, data/yanomama.rda, data/zealand.rda: new data
+ files
+
+2008-06-11 10:58 sdray
+
+ * data/abouheif.eg.rda, data/acacia.rda, data/aminoacyl.rda,
+ data/apis108.rda, data/ardeche.rda, data/arrival.rda,
+ data/atlas.rda, data/atya.rda, data/avijons.rda,
+ data/avimedi.rda, data/aviurba.rda, data/bacteria.rda,
+ data/banque.rda, data/baran95.rda, data/bf88.rda,
+ data/bordeaux.rda, data/bsetal97.rda, data/buech.rda,
+ data/butterfly.rda, data/capitales.rda, data/carni19.rda,
+ data/carni70.rda, data/carniherbi49.rda, data/casitas.rda,
+ data/chatcat.rda, data/chats.rda, data/chazeb.rda,
+ data/chevaine.rda, data/clementines.rda, data/cnc2003.rda,
+ data/coleo.rda, data/corvus.rda, data/deug.rda, data/doubs.rda,
+ data/dunedata.rda, data/ecg.rda, data/ecomor.rda,
+ data/elec88.rda, data/escopage.rda, data/euro123.rda,
+ data/fission.rda, data/friday87.rda, data/fruits.rda,
+ data/ggtortoises.rda, data/granulo.rda, data/hdpg.rda,
+ data/housetasks.rda, data/humDNAm.rda, data/ichtyo.rda,
+ data/irishdata.rda, data/julliot.rda, data/jv73.rda,
+ data/kcponds.rda, data/lascaux.rda, data/lizards.rda,
+ data/macaca.rda, data/macon.rda, data/mafragh.rda,
+ data/maples.rda, data/mariages.rda, data/meau.rda,
+ data/meaudret.rda, data/microsatt.rda, data/mjrochet.rda,
+ data/mollusc.rda, data/monde84.rda, data/morphosport.rda,
+ data/newick.eg.rda, data/njplot.rda, data/olympic.rda,
+ data/oribatid.rda, data/ours.rda, data/palm.rda, data/pap.rda,
+ data/perthi02.rda, data/presid2002.rda, data/procella.rda,
+ data/rankrock.rda, data/rhone.rda, data/rpjdl.rda,
+ data/santacatalina.rda, data/sarcelles.rda, data/seconde.rda,
+ data/skulls.rda, data/steppe.rda, data/syndicats.rda,
+ data/t3012.rda, data/tarentaise.rda, data/taxo.eg.rda,
+ data/tintoodiel.rda, data/tithonia.rda, data/tortues.rda,
+ data/toxicity.rda, data/trichometeo.rda, data/ungulates.rda,
+ data/vegtf.rda, data/veuvage.rda, data/westafrica.rda,
+ data/worksurv.rda, data/yanomama.rda, data/zealand.rda: remove
+ corrupted data files
+
+2008-06-10 14:12 sdray
+
+ * ChangeLog, DESCRIPTION, INDEX, R, TITLE, data, inst, man, src:
+ move from trunk to pkg after initial import using cvs2svn
+
+2008-06-10 14:01 sdray
+
+ * man: remove man folder
+
+2008-06-10 14:01 sdray
+
+ * R: remove R folder
+
+2008-06-10 14:12 sdray
+
+ * ChangeLog, DESCRIPTION, INDEX, R, TITLE, data, inst, man, src:
+ move from trunk to pkg after initial import using cvs2svn
+
+2008-05-23 14:12 dray
+
+ * ChangeLog, DESCRIPTION: ---------- release of ade4 1.4-9
+ ----------
+
+2008-05-23 12:12 dray
+
+ * R/niche.R: Correct a syntax error
+
+2008-05-23 12:00 dray
+
+ * R/mantel.randtest.R, R/procuste.randtest.R: Correct a bug. The
+ number of repetitions was not correct ((nrepet + 1) instead of
+ nrepet)
+
+2008-05-23 11:53 dray
+
+ * R/niche.R, R/randtest.between.R, R/randtest.coinertia.R,
+ R/randtest.discrimin.R: Correct a bug. The number of repetitions
+ was not correct ((nrepet + 1) instead of nrepet)
+
+2008-05-23 11:46 dray
+
+ * R/krandtest.R, R/randtest.amova.R, man/krandtest.Rd: the class
+ krandtest now accepts a vector of alternative hypotheses instead
+ of a common alternative hypothesis for the k tests (email of Kim
+ Milferstedt on RHelp)
+
+2008-05-16 13:54 dray
+
+ * ChangeLog, DESCRIPTION: ---------- release of ade4 1.4-8
+ ----------
+
+2008-05-07 11:29 jthioulo
+
+ * R/dudi.acm.R: bug correction (mail of JR Lobry on adelist):
+ (any(row.w) < 0) vs. (any(row.w < 0))
+
+2008-05-07 11:27 jthioulo
+
+ * R/dudi.R: bug correction (mail of JR Lobry on adelist):
+ any(col.w) < 0 vs. any(col.w < 0)
+
+2008-04-18 14:37 penel
+
+ * data/ggtortoises.rda: pixmap S3 objects transformed into S4 class
+
+2008-04-18 13:33 dray
+
+ * ChangeLog, DESCRIPTION: ---------- release of ade4 1.4-7
+ ----------
+
+2008-04-18 13:31 dray
+
+ * data/capitales.rda: pixmap S3 objects transformed into S4 class
+
+2008-04-17 11:05 dray
+
+ * ChangeLog, DESCRIPTION: ---------- release of ade4 1.4-6
+ ----------
+
+2008-04-16 17:02 dray
+
+ * R/phylog.R: Correct a bug in phylog.extract (mail of S. Ollier)
+
+2008-04-16 16:36 dray
+
+ * src/adesub.c, src/adesub.h, src/testrlq.c: matcentragehi in now
+ in adesub
+
+2008-04-16 16:33 dray
+
+ * R/nipals.R, man/nipals.Rd: New function for NIPALS algorithm,
+ i.e. PCA with (or without) NA
+
+2008-04-16 16:31 dray
+
+ * man/randtest.Rd: add some words about the computation of pvalues
+ for two-sided test
+
+2008-04-16 13:18 dufour
+
+ * man/ade4.package.Rd: *** empty log message ***
+
+2008-04-16 10:12 dufour
+
+ * man/pcaiv.Rd: *** empty log message ***
+
+2008-04-14 12:41 penel
+
+ * man/table.phylog.Rd: Example table.phylog set to dontrun
+
+2008-04-02 11:16 dray
+
+ * man/multispati.Rd, man/vegtf.Rd: Update the source reference:
+ Dray et al. (2008)
+
+2008-03-27 14:28 dufour
+
+ * man/dudi.pca.Rd: Modifications : explanations about values (cent
+ and norm) ; it{} into emph{}.
+
+2008-03-27 13:47 dufour
+
+ * man/dudi.pca.Rd: Modification of explanations ($cent and $norm)
+
+2008-03-26 10:29 dray
+
+ * R/sco.distri.R: correct a bug (identified by S. Pavoine): default
+ label argument was badly considered when one column contains only
+ O's
+
+2008-03-20 15:10 dray
+
+ * R/scatter.R, R/scatterutil.R, man/scatter.Rd, man/scatterutil.Rd:
+ New utility function scatterutil.sco and scatterutil.convrot90
+ for 1D graphical representation
+
+2008-03-20 15:06 dray
+
+ * R/sco.gauss.R, man/sco.gauss.Rd: New function sco.gauss for 1D
+ graphical representation
+
+2008-03-20 15:05 dray
+
+ * R/sco.match.R, man/sco.match.Rd: New function sco.match for 1D
+ graphical representation
+
+2008-03-20 15:05 dray
+
+ * R/sco.class.R, man/sco.class.Rd: New function sco.class for 1D
+ graphical representation
+
+2008-03-20 15:05 dray
+
+ * R/sco.label.R, man/sco.label.Rd: New function sco.label for 1D
+ graphical representation
+
+2008-03-19 16:00 dray
+
+ * R/sco.qual.R: Functions of this file are now in sco.label.R and
+ sco.gauss.R
+
+2008-03-18 14:18 dray
+
+ * inst/CITATION: Add two new references to the CITATION file
+
+2008-03-17 15:47 dray
+
+ * R/randtest.cca.R, R/randtest.pcaiv.R, R/randtest.pcaivortho.R,
+ man/randtest.pcaiv.Rd: News functions for permutation tests in
+ constrained analysis
+
+2008-02-05 13:26 dray
+
+ * src/testdim.c: Correct a bug in memory allocation of the function
+ svdd
+
+2008-01-29 15:07 jthioulo
+
+ * man/sco.label.Rd: added function: Draws evenly spaced labels,
+ each label linked to the corresponding value of a numeric score
+
+2008-01-29 15:07 jthioulo
+
+ * man/sco.gauss.Rd: added function: Draws Gauss curves with the
+ same mean and variance as the scores of indivivuals belonging to
+ categories of several factors
+
+2008-01-29 15:04 jthioulo
+
+ * man/veuvage.Rd: Correstion of illegal accented character in
+ exemple code
+
+2008-01-29 15:04 jthioulo
+
+ * R/sco.qual.R: adds two functions: sco.gauss and sco.label (draw
+ Gauss curves on a score by categories of several factors)
+
+2007-11-09 17:19 dray
+
+ * R/newick2phylog.R: Correct a bug. In newick2phylog.addtools,
+ eigen does not return an orthogonal basis when there are null
+ eigenvalues (Wscores). Vectors are now orthogonalized using qr
+
+2007-10-16 14:41 penel
+
+ * DESCRIPTION: Change License to GPL (>=2)
+
+2007-10-16 14:35 penel
+
+ * ChangeLog: *** empty log message ***
+
+2007-10-12 11:37 penel
+
+ * ChangeLog, DESCRIPTION: ---------- release of ade4 1.4-5
+ ----------
+
+2007-10-11 15:50 penel
+
+ * man/dunedata.Rd, man/steppe.Rd: Replace non_function by Doctype
+
+2007-10-09 10:54 penel
+
+ * src/testdim.c, src/tests.c: Correction of a bug in the
+ declaration of variables
+
+2007-09-25 11:16 dray
+
+ * ChangeLog: ---------- release of ade4 1.4-4 ----------
+
+2007-09-25 11:10 dray
+
+ * DESCRIPTION: ---------- release of ade4 1.4-4 ----------
+
+2007-09-20 15:48 dray
+
+ * R/coinertia.R, R/dudi.R, R/dudi.pco.R: Modification of the call
+ of the imported function chooseaxes for the use of the ade4TkGUI
+ package
+
+2007-09-17 16:23 dray
+
+ * R/within.pca.R, R/withinpca.R, man/ktab.Rd,
+ man/ktab.match2ktabs.Rd, man/pta.Rd, man/statis.Rd,
+ man/within.pca.Rd, man/withinpca.Rd: The function within.pca is
+ renamed withinpca
+
+2007-09-17 15:12 dray
+
+ * R/ktab.R, man/ktab.Rd: Change the names of the arguments of the
+ function '[.ktab'
+
+2007-09-17 13:05 dray
+
+ * man/amova.Rd, man/between.Rd, man/coinertia.Rd, man/corkdist.Rd,
+ man/discrimin.Rd, man/dpcoa.Rd, man/dudi.Rd, man/dudi.acm.Rd,
+ man/dudi.pco.Rd, man/foucart.Rd, man/is.euclid.Rd,
+ man/kplot.foucart.Rd, man/kplot.mcoa.Rd, man/kplot.mfa.Rd,
+ man/kplot.pta.Rd, man/kplot.sepan.Rd, man/kplot.statis.Rd,
+ man/krandtest.Rd, man/ktab.Rd, man/mcoa.Rd, man/mfa.Rd,
+ man/multispati.Rd, man/neig.Rd, man/niche.Rd, man/orthobasis.Rd,
+ man/pcaiv.Rd, man/phylog.Rd, man/plot.phylog.Rd, man/procuste.Rd,
+ man/pta.Rd, man/randtest.Rd, man/randtest.amova.Rd,
+ man/randtest.between.Rd, man/randtest.coinertia.Rd,
+ man/randtest.discrimin.Rd, man/reconst.Rd, man/rlq.Rd,
+ man/rtest.Rd, man/rtest.between.Rd, man/rtest.discrimin.Rd,
+ man/scatter.acm.Rd, man/scatter.coa.Rd, man/scatter.dudi.Rd,
+ man/scatter.fca.Rd, man/score.acm.Rd, man/score.coa.Rd,
+ man/score.mix.Rd, man/score.pca.Rd, man/sepan.Rd, man/statis.Rd,
+ man/supcol.Rd, man/suprow.Rd, man/testdim.Rd, man/within.Rd,
+ man/witwit.coa.Rd: Correct usage entries for S3 methods
+
+2007-09-14 11:58 jthioulo
+
+ * DESCRIPTION: suggests ade4TkGUI
+
+2007-09-14 09:15 jthioulo
+
+ * R/randtest.between.R: modif eval pour ne pas chercher dans
+ l'environnement global directement
+
+2007-09-13 11:57 dray
+
+ * src/Makevars: replace CRLF (DOS) by LF (Unix)
+
+2007-09-13 11:18 jthioulo
+
+ * R/coinertia.R, R/dudi.R, R/dudi.pco.R: modif pour variable
+ globale ade4TkGUIFlag
+
+2007-09-06 17:08 dray
+
+ * man/PI2newick.Rd, man/RV.rtest.Rd, man/RVdist.randtest.Rd,
+ man/aminoacyl.Rd, man/ardeche.Rd, man/area.plot.Rd,
+ man/as.taxo.Rd, man/atlas.Rd, man/atya.Rd, man/avijons.Rd,
+ man/aviurba.Rd, man/baran95.Rd, man/between.Rd,
+ man/bicenter.wt.Rd, man/buech.Rd, man/cailliez.Rd,
+ man/carni70.Rd, man/casitas.Rd, man/cca.Rd, man/chatcat.Rd,
+ man/chats.Rd, man/clementines.Rd, man/coinertia.Rd,
+ man/corkdist.Rd, man/discrimin.Rd, man/discrimin.coa.Rd,
+ man/dist.binary.Rd, man/dist.dudi.Rd, man/dist.genet.Rd,
+ man/dist.neig.Rd, man/dist.prop.Rd, man/dist.quant.Rd,
+ man/divcmax.Rd, man/dotchart.phylog.Rd, man/dotcircle.Rd,
+ man/doubs.Rd, man/dpcoa.Rd, man/dudi.Rd, man/dudi.acm.Rd,
+ man/dudi.coa.Rd, man/dudi.dec.Rd, man/dudi.fca.Rd,
+ man/dudi.mix.Rd, man/dudi.nsc.Rd, man/dudi.pca.Rd,
+ man/dudi.pco.Rd, man/escopage.Rd, man/euro123.Rd, man/fruits.Rd,
+ man/fuzzygenet.Rd, man/gearymoran.Rd, man/genet.Rd,
+ man/granulo.Rd, man/gridrowcol.Rd, man/ichtyo.Rd,
+ man/inertia.dudi.Rd, man/is.euclid.Rd, man/julliot.Rd,
+ man/jv73.Rd, man/kdist.Rd, man/kdist2ktab.Rd, man/kdisteuclid.Rd,
+ man/kplot.foucart.Rd, man/kplot.mcoa.Rd, man/kplot.mfa.Rd,
+ man/kplot.pta.Rd, man/kplot.sepan.Rd, man/kplot.statis.Rd,
+ man/ktab.Rd, man/ktab.data.frame.Rd, man/ktab.list.df.Rd,
+ man/ktab.list.dudi.Rd, man/ktab.match2ktabs.Rd,
+ man/ktab.within.Rd, man/lascaux.Rd, man/lingoes.Rd, man/macon.Rd,
+ man/mafragh.Rd, man/mantel.rtest.Rd, man/mariages.Rd,
+ man/mcoa.Rd, man/meau.Rd, man/meaudret.Rd, man/mfa.Rd,
+ man/microsatt.Rd, man/mjrochet.Rd, man/mld.Rd, man/mollusc.Rd,
+ man/monde84.Rd, man/morphosport.Rd, man/mstree.Rd,
+ man/multispati.Rd, man/multispati.randtest.Rd,
+ man/multispati.rtest.Rd, man/neig.Rd, man/newick.eg.Rd,
+ man/newick2phylog.Rd, man/niche.Rd, man/njplot.Rd,
+ man/orthobasis.Rd, man/orthogram.Rd, man/ours.Rd, man/palm.Rd,
+ man/pcaiv.Rd, man/pcaivortho.Rd, man/pcoscaled.Rd, man/phylog.Rd,
+ man/plot.phylog.Rd, man/procuste.Rd, man/procuste.rtest.Rd,
+ man/pta.Rd, man/quasieuclid.Rd, man/reconst.Rd, man/rhone.Rd,
+ man/rpjdl.Rd, man/rtest.Rd, man/rtest.between.Rd,
+ man/rtest.discrimin.Rd, man/s.arrow.Rd, man/s.chull.Rd,
+ man/s.class.Rd, man/s.corcircle.Rd, man/s.distri.Rd,
+ man/s.hist.Rd, man/s.image.Rd, man/s.kde2d.Rd, man/s.label.Rd,
+ man/s.logo.Rd, man/s.match.Rd, man/s.multinom.Rd,
+ man/s.traject.Rd, man/s.value.Rd, man/sarcelles.Rd,
+ man/scalewt.Rd, man/scatter.Rd, man/scatter.acm.Rd,
+ man/scatter.coa.Rd, man/scatter.dudi.Rd, man/scatter.fca.Rd,
+ man/sco.boxplot.Rd, man/sco.distri.Rd, man/sco.quant.Rd,
+ man/score.Rd, man/score.acm.Rd, man/score.coa.Rd,
+ man/score.mix.Rd, man/score.pca.Rd, man/sepan.Rd, man/statis.Rd,
+ man/steppe.Rd, man/supcol.Rd, man/suprow.Rd,
+ man/symbols.phylog.Rd, man/t3012.Rd, man/table.cont.Rd,
+ man/table.dist.Rd, man/table.paint.Rd, man/table.phylog.Rd,
+ man/table.value.Rd, man/tarentaise.Rd, man/triangle.class.Rd,
+ man/triangle.plot.Rd, man/trichometeo.Rd, man/ungulates.Rd,
+ man/uniquewt.df.Rd, man/variance.phylog.Rd, man/veuvage.Rd,
+ man/westafrica.Rd, man/within.Rd, man/within.pca.Rd,
+ man/witwit.coa.Rd, man/worksurv.Rd: Added the encoding of Rd
+ files and remove the email of Daniel Chessel (he is retired)
+
+2007-09-06 15:11 dray
+
+ * R/scatter.acm.R: Clean R files: replace T by TRUE.
+
+2007-09-06 15:03 dray
+
+ * R/newick2phylog.R: Clean R files: remove multiple function
+ definitions (floc1(s) becomes floc1,floc2,floc3. Thanks to
+ UsagePackageCheck of codetools
+
+2007-09-06 14:55 dray
+
+ * R/multispati.R, R/multispati.randtest.R, R/multispati.rtest.R,
+ R/neig.R, R/orthobasis.R, R/s.image.R, R/s.kde2d.R, R/s.logo.R:
+ Clean R files: correct imported function definition. Thanks to
+ UsagePackageCheck of codetools
+
+2007-09-06 13:53 dray
+
+ * R/orthogram.R: Correct a bug: test for the choice between
+ orthobas, neig or phylog
+
+2007-09-06 12:21 dray
+
+ * R/scatter.acm.R: Correct a bug: replace score. by score.acm
+
+2007-09-06 12:19 dray
+
+ * R/kplot.foucart.R, R/kplot.mfa.R, R/mcoa.R, R/rlq.R,
+ R/score.coa.R, R/sepan.R, R/variance.phylog.R: Clean R files:
+ remove local variables assigned but not used. Thanks to
+ checkUsagePackage of codetools
+
+2007-09-06 11:58 dray
+
+ * R/PI2newick.R, R/RV.rtest.R, R/RVdist.randtest.R, R/amova.R,
+ R/area.plot.R, R/as.taxo.R, R/between.R, R/coinertia.R,
+ R/corkdist.R, R/disc.R, R/discrimin.R, R/discrimin.coa.R,
+ R/dist.dudi.R, R/dist.genet.R, R/dotcircle.R, R/dudi.coa.R,
+ R/dudi.dec.R, R/dudi.nsc.R, R/foucart.R, R/fuzzygenet.R,
+ R/genet.R, R/gridrowcol.R, R/kplot.foucart.R, R/kplot.mfa.R,
+ R/kplot.statis.R, R/ktab.R, R/ktab.list.dudi.R,
+ R/ktab.match2ktabs.R, R/ktab.within.R, R/lingoes.R, R/mcoa.R,
+ R/mld.R, R/multispati.R, R/newick2phylog.R, R/niche.R,
+ R/optimEH.R, R/orthobasis.R, R/orthogram.R, R/pcaiv.R,
+ R/phylog.R, R/plot.phylog.R, R/procuste.R, R/rlq.R,
+ R/rtest.between.R, R/s.corcircle.R, R/s.hist.R, R/s.image.R,
+ R/scatter.R, R/sco.distri.R, R/score.acm.R, R/score.coa.R,
+ R/score.mix.R, R/sepan.R, R/statis.R, R/symbols.phylog.R,
+ R/table.cont.R, R/table.phylog.R, R/uniquewt.df.R,
+ R/variance.phylog.R, R/within.R, R/within.pca.R: Clean R files:
+ remove local variables assigned but not used. Thanks to
+ checkUsagePackage of codetools
+
+2007-09-06 08:08 dray
+
+ * man/bordeaux.Rd, man/cca.Rd, man/dudi.hillsmith.Rd,
+ man/elec88.Rd, man/seconde.Rd: Clean Rd files: remove unmatched
+ right brace
+
+2007-09-04 16:12 dray
+
+ * R/testdim.R, man/testdim.Rd, src/Makevars, src/testdim.c: New
+ function testdim to estimate the number of axes in multivariate
+ analysis
+
+2007-09-04 15:07 dray
+
+ * R/gearymoran.R, R/krandtest.R, R/niche.R, R/orthogram.R,
+ R/randtest.amova.R, man/gearymoran.Rd, man/krandtest.Rd,
+ man/niche.Rd, man/orthogram.Rd: reimplementation of the class
+ krandtest and new function as.krandtest
+
+2007-09-04 14:50 dray
+
+ * man/vegtf.Rd: correction of a bug in the example section
+
+2007-09-03 16:53 dray
+
+ * R/score.coa.R, man/score.coa.Rd: new function reciprocal.coa (see
+ http://listes.univ-lyon1.fr/wws/arc/adelist/2007-07/msg00007.html)
+
+2007-09-03 16:26 dray
+
+ * R/sco.distri.R, man/sco.distri.Rd: sco.distri returns a
+ data.frame with means and variances (see
+ http://listes.univ-lyon1.fr/wws/arc/adelist/2007-06/msg00018.html)
+
+2007-09-03 15:24 dray
+
+ * R/scatter.R, R/sepan.R, R/witwitsepan.R: Add yaxt argument to
+ scatterutil.eigen (see
+ http://listes.univ-lyon1.fr/wws/arc/adelist/2007-07/msg00022.html)
+
+2007-09-03 15:04 dray
+
+ * R/multispati.R: Correct legend in plot.multispati
+
+2007-09-03 14:58 dray
+
+ * data/vegtf.rda, man/vegtf.Rd: New vegetation data set to
+ illustrate multispati analysis
+
+2007-09-03 14:51 dray
+
+ * R/niche.R, man/niche.Rd: New functions niche.param and
+ rtest.niche
+
+2007-08-29 16:20 dray
+
+ * R/area.plot.R: the function area2poly is modified to export the
+ bbox attribute for each polygon
+
+2007-08-29 16:00 dray
+
+ * R/s.corcircle.R: correct bug of the grid argument. see
+ http://listes.univ-lyon1.fr/wws/arc/adelist/2007-07/msg00001.html
+
+2007-08-29 15:47 dray
+
+ * R/randtest-internal.R, R/rlq.R: correct bugs in memory allocation
+ (C interface). These bugs have been identified using valgrind by
+ B. Ripley (12/06/2007)
+
+2007-06-15 07:49 dray
+
+ * man/dunedata.Rd: correct the number of rows and columns in the
+ help file
+
+2007-04-16 12:56 dray
+
+ * ChangeLog, DESCRIPTION: ---------- release of ade4 1.4-3
+ ----------
+
+2007-04-12 13:39 dray
+
+ * man/suprow.Rd: correct the example section
+
+2007-04-12 13:08 dray
+
+ * ChangeLog: New ChangeLog
+
+2007-04-12 12:58 dray
+
+ * data/atlas.rda, data/avijons.rda, data/aviurba.rda,
+ data/baran95.rda, data/bf88.rda, data/chevaine.rda,
+ data/cnc2003.rda, data/elec88.rda, data/monde84.rda,
+ data/rankrock.rda, data/rpjdl.rda, data/sarcelles.rda,
+ data/steppe.rda, data/t3012.rda, data/tarentaise.rda,
+ data/veuvage.rda, data/westafrica.rda: remove non ASCII
+ characters in data
+
+2007-03-26 16:47 jombart
+
+ * ChangeLog, R/dudi.pco.R: reviewed by: <delete if not using a
+ buddy>
+ * R/dudi.pco.R: sub and csub arguments are now actually passed to
+ s.label
+
+2007-03-12 14:34 jombart
+
+ * ChangeLog, R/add.scatter.R, man/add.scatter.Rd, man/scatter.Rd: *
+ R/scatter.R: removed add.scatter.eig
+ * man/scatter.Rd: removed add.scatter.eig
+ * R/add.scatter.R: new functions add.scatter and add.scatter.eig
+ * man/add.scatter.Rd: doc for add.scatter and add.scatter.eig
+
+2007-03-12 14:27 jombart
+
+ * R/scatter.add.R, man/scatter.add.Rd: *** empty log message ***
+
+2007-03-12 14:06 jombart
+
+ * ChangeLog, R/add.graph.R: reviewed by: <delete if not using a
+ buddy>
+ * R/add.graph.R:
+ * R/dpcoa.R:
+ * R/dudi.pco.R:
+ * R/kplot.sepan.R:
+ * R/mfa.R:
+ * R/pta.R:
+ * R/scatter.R:
+ * R/scatter.add.R:
+ * R/scatter.coa.R:
+ * R/scatter.dudi.R:
+ * R/statis.R:
+ * man/scatter.Rd:
+ * man/scatter.add.Rd:
+
+2007-03-12 14:04 jombart
+
+ * ChangeLog, R/dpcoa.R, R/dudi.pco.R, R/kplot.sepan.R, R/mfa.R,
+ R/pta.R, R/scatter.R, R/scatter.add.R, R/scatter.coa.R,
+ R/scatter.dudi.R, R/statis.R, man/add.graph.Rd, man/scatter.Rd,
+ man/scatter.add.Rd: reviewed by: <delete if not using a buddy>
+ * R/dpcoa.R:
+ * R/dudi.pco.R:
+ * R/kplot.sepan.R:
+ * R/mfa.R:
+ * R/pta.R:
+ * R/scatter.R:
+ * R/scatter.add.R:
+ * R/scatter.coa.R:
+ * R/scatter.dudi.R:
+ * R/statis.R:
+ * man/add.graph.Rd:
+ * man/scatter.Rd:
+ * man/scatter.add.Rd:
+
+2007-03-10 10:38 jombart
+
+ * ChangeLog, R/add.graph.R, R/dpcoa.R, R/dudi.pco.R,
+ R/kplot.sepan.R, R/mfa.R, R/pta.R, R/scatter.R, R/scatter.coa.R,
+ R/scatter.dudi.R, R/statis.R, man/add.graph.Rd, man/dudi.pca.Rd,
+ man/scatter.Rd, man/scatter.dudi.Rd: reviewed by: <delete if not
+ using a buddy>
+ * R/add.graph.R: ajout de la fonction (contient add.graph et la
+ nouvelle version de add.scatter.eig)
+ * man/add.graph.Rd: ajout de la doc (add.graph et
+ add.scatter.eig)
+ * R/dpcoa.R: appel de add.scatter.eig: nf supprime
+ * R/dudi.pco.R: appel de add.scatter.eig: nf supprime
+ * R/kplot.sepan.R: appel de add.scatter.eig: nf supprime
+ * R/mfa.R: appel de add.scatter.eig: nf supprime
+ * R/pta.R: appel de add.scatter.eig: nf supprime
+ * R/scatter.R: add.scatter.eig supprime (migre vers add.graph.R)
+ * R/scatter.coa.R: appel de add.scatter.eig: nf supprime
+ * R/scatter.dudi.R: appel de add.scatter.eig: nf supprime
+ * R/statis.R: appel de add.scatter.eig: nf supprime
+ * man/dudi.pca.Rd: modifications faites par Anne
+ * man/scatter.Rd: enleve add.scatter.eig de la doc (migre vers
+ add.graph.Rd)
+ * man/scatter.dudi.Rd: appel de add.scatter.eig: nf supprime
+
+2007-03-07 18:46 jombart
+
+ * ChangeLog, data/rpjdl.rda: reviewed by: <delete if not using a
+ buddy>
+ * data/rpjdl.rda: removed accents
+
+2007-02-19 09:53 jthioulo
+
+ * ChangeLog, R/s.arrow.R, man/s.arrow.Rd: * R/s.arrow.R: added the
+ "boxes" argument
+ * man/s.arrow.Rd: added the "boxes" argument
+
+2007-02-16 09:13 dray
+
+ * ChangeLog, man/orthogram.Rd: * man/orthogram.Rd: update the
+ reference to Ollier et al.
+
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..6c67ad3
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,21 @@
+Package: ade4
+Version: 1.7-8
+Date: 2017-08-09
+Title: Analysis of Ecological Data : Exploratory and Euclidean Methods
+ in Environmental Sciences
+Author: Stéphane Dray <stephane.dray at univ-lyon1.fr>, Anne-Béatrice Dufour <anne-beatrice.dufour at univ-lyon1.fr>, and Jean Thioulouse <jean.thioulouse at univ-lyon1.fr>, with contributions from Thibaut Jombart, Sandrine Pavoine, Jean R. Lobry, Sébastien Ollier, and Aurélie Siberchicot. Based on earlier work by Daniel Chessel.
+Maintainer: Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
+Depends: R (>= 2.10)
+Imports: graphics, grDevices, methods, stats, utils
+Suggests: ade4TkGUI, adegraphics, adephylo, ape, CircStats, deldir,
+ lattice, maptools, MASS, pixmap, sp, spdep, splancs, waveslim
+Description: Tools for multivariate data analysis. Several methods are provided for the analysis (i.e., ordination) of one-table (e.g., principal component analysis, correspondence analysis), two-table (e.g., coinertia analysis, redundancy analysis), three-table (e.g., RLQ analysis) and K-table (e.g., STATIS, multiple coinertia analysis). The philosophy of the package is described in Dray and Dufour (2007) <doi:10.18637/jss.v022.i04>.
+License: GPL (>= 2)
+URL: http://pbil.univ-lyon1.fr/ADE-4, Mailing list:
+ http://listes.univ-lyon1.fr/wws/info/adelist
+BugReports: https://github.com/sdray/ade4/issues
+Encoding: UTF-8
+NeedsCompilation: yes
+Packaged: 2017-08-09 13:05:58 UTC; aurelie
+Repository: CRAN
+Date/Publication: 2017-08-09 20:31:18 UTC
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..2b4c6f2
--- /dev/null
+++ b/MD5
@@ -0,0 +1,618 @@
+7db63f1daa2b0663a04567438d973c60 *ChangeLog
+a997861f7234d52e6a3af900f3e0cc1b *DESCRIPTION
+0f42b8e97b5fb004627f5f4634c078d2 *NAMESPACE
+634ee9a9f7891f2f7d6962980adfd111 *R/EH.R
+6b677d2c1862d14d17ab0760f9760dcc *R/PI2newick.R
+6997af57a25d43dc445092f3e845f2f1 *R/RV.rtest.R
+8d43bff953af1f5d49b5e0fb16930a34 *R/RVdist.randtest.R
+1fdb71cdc0f09024023a31cca767b3fa *R/add.scatter.R
+37c6a7f3ff5716e26988e23536784027 *R/amova.R
+502c2b9fe7384a6d6d943775d23fcdde *R/apqe.R
+7c7f969bf79e951b76459a2698dea1d4 *R/area.plot.R
+d10254f930b2a6a1c3a507d970be7440 *R/as.taxo.R
+5a937fd30b98a03aebd50605c074eb89 *R/bca.rlq.R
+d664acb9621908187560552f615bee2f *R/between.R
+ecfcfceb038662ea02f7022babbcea18 *R/betweencoinertia.R
+f860364cf5a51defe284ab21a88526f2 *R/betwitdpcoa.R
+4489dabaa47765166b862d92290a057d *R/bicenter.wt.R
+8dd0cd8dbf02182874ef72baeef006f1 *R/cailliez.R
+2d9e78e0529cd84cc000aa8aef662297 *R/coinertia.R
+97425c6e480c2d00d7e601784350b55a *R/combine.4thcorner.R
+f0cc6df07e1c34e4d40080be726cd705 *R/corkdist.R
+c261b9d96653ab1d25f145db848a51e5 *R/costatis.R
+9adbb2fcae2d3358747b872c126dc2d5 *R/disc.R
+762df1c0044c90877cac71e453700e9d *R/discrimin.R
+217c5464655177b2f2e3bedee5bc41c9 *R/discrimin.coa.R
+4f5a9560442fa3b5c60ada9e99ba9ab6 *R/dist.binary.R
+6a6eb7ef3a48d06ff13a5d16037cd2d0 *R/dist.dudi.R
+f21db3d93d57e3ed8b373983f1d2fc77 *R/dist.genet.R
+c480be1a9a83c30518dac71f9a98d1a1 *R/dist.ktab.R
+cd4d8a3837676bb9d15f841a71514603 *R/dist.neig.R
+73f5fd3c1ff02495564a1ee5956a8d9f *R/dist.prop.R
+ed17c38210a61edefa8d99ce1660b4ce *R/dist.quant.R
+066c74aeba262b3c77d83739bd535d40 *R/divc.R
+450778247278a7850aefbd03df04c018 *R/divcmax.R
+d1f0a2ec832232c3949b1d4068686239 *R/dotchart.phylog.R
+7a9423dfee35852fc3545c3339d02414 *R/dotcircle.R
+23b6e2f26e12f6e321bb4787760920f4 *R/dpcoa.R
+e2fbec3cc4771594315bff15c13dba33 *R/dudi.R
+5d0c689352e79593b6b6b5bbeb3af82a *R/dudi.acm.R
+0b90142b4febc9a98b702c5e7d3c3bcb *R/dudi.coa.R
+a4b3f615781a3b1c8e44ad4942cb9165 *R/dudi.dec.R
+50c539904d02771ba1bc2d8eb82dec29 *R/dudi.fca.R
+61fd028d5ac9f33fc708617fb9ffb64f *R/dudi.hillsmith.R
+3231e0b65f469855b69afb92b6dfd7d0 *R/dudi.mix.R
+3eca194874645a2361ae28ac402478a7 *R/dudi.nsc.R
+80d3bfcd008d5b1d9711fe5818a10081 *R/dudi.pca.R
+fa8abb20a1bda8af602298b325942043 *R/dudi.pco.R
+2f0de677c0dbf6a52cd0d9e601e9925d *R/foucart.R
+8088980976b1cd67f9759db87789062b *R/fourthcorner.R
+60336b42bd5ee95f3ae4145506d31979 *R/fourthcorner.rlq.R
+89a593d1a3097687949a2e59bbcfdd38 *R/fourthcorner2.R
+f4447492956c2639ee7d551caf3e458e *R/fuzzygenet.R
+d2f63c500851905fe0398b3fa4dae7ab *R/gearymoran.R
+9fbdc97c6205499a6acb7fc90ecc41b9 *R/genet.R
+4b51d288b3c7c57a485f7728676e0c56 *R/gridrowcol.R
+4449446215358d5427ed3dd9c5d2f39f *R/inertia.dudi.R
+acf786e3e3c41f3820cae2ec95b94607 *R/is.euclid.R
+0ba557d20dd2b8a01c4e0c7f9cc1e334 *R/kdist.R
+167e53424152b046f2561f4cba06872f *R/kdist2ktab.R
+242af7a73495c2e49f6f2ab7a1b0b716 *R/kdisteuclid.R
+4ca5a0f36f5ca08f490e6b77f313d0ee *R/kplot.R
+e65a05209dd28ad95d88317e5d337154 *R/kplot.foucart.R
+cb3eaec7d1072769e1278736dcdc65b7 *R/kplot.mcoa.R
+1fb6e092daa52d9946284c5085b8bb65 *R/kplot.mfa.R
+4c200de691bde98b9066efbef53379ac *R/kplot.pta.R
+dabf8b637a1eb66f1208dcdc920504f3 *R/kplot.sepan.R
+4c71c804258b9bc07e9bf8311a8dbcec *R/kplot.statis.R
+ebf1adeb0f4edeb226c99e22d31523ca *R/krandboot.R
+e692563dd969dc8c9f433d7048fe986d *R/krandtest.R
+bd8808a1e276364ec39159e3f0c20519 *R/krandxval.R
+85deed07d28fe236504f0c13eacf1b67 *R/ktab.R
+255ee82b258fe012a20bd04b37522ec6 *R/ktab.data.frame.R
+fe0c5da3c6f3a120ecde9f7ba600bf8b *R/ktab.list.df.R
+eb9fd47df55510b979820e3f3e528aab *R/ktab.list.dudi.R
+9d4a9f10a538cbf896a72535ea0961b3 *R/ktab.match2ktabs.R
+d7b3319992f78918e90fcd49bf16e23e *R/ktab.within.R
+6aa6c74464a2d1a55b2562561795cdc2 *R/lingoes.R
+bce8031d226cb002efca591875906371 *R/mantel.randtest.R
+18712987f7b126df865e4422352a4c5c *R/mantel.rtest.R
+e2475394debffc7d487142bdba8aa82b *R/mbpcaiv.R
+5219636213955b7639c1aeb71d0ceb0c *R/mbpls.R
+4c71398b79c1d8c752475eeccd957fb1 *R/mcoa.R
+7df34204586cf5a1d8851262ccf62b0b *R/mdpcoa.R
+7c3bc2cbb167182b3fcddbd2d882c628 *R/mfa.R
+bc8897b6d8e662fa44e5b162fed075cb *R/mld.R
+c1e78e310e6e2bc4466825be29723bec *R/mstree.R
+82a4db3fb1d4f4b2b70ca516f542d599 *R/multiblock.R
+0c55807e7babb664dfce4c61bd40470c *R/multispati.R
+c27c23c9df3020fbab16df8c5177ca67 *R/multispati.randtest.R
+ede7143b536c3c385b3f02685273a718 *R/multispati.rtest.R
+0beb439167940efc89826a46821b217b *R/neig.R
+fd838d2e4e5dfd6fe33a979856943fe3 *R/newick2phylog.R
+5b6be61c1ce090ebc3d7c2fad52e9a1b *R/niche.R
+080ac14882098cbebc5ef9c6c3f41fc7 *R/nipals.R
+2bbed4e363c6a16a64887c0853e8f12f *R/optimEH.R
+e66347d5ded70e8e4e7813992cc61db1 *R/originality.R
+e2b0c14300a21d1e4a931159c62b05a3 *R/orisaved.R
+eaaf0a1ed8290aa79fec770472d9cda6 *R/orthobasis.R
+4ae68a5aebe904fa60ff6bec67187e59 *R/orthogram.R
+521653f773c0cd262df985b09fb16b48 *R/p.adjust.4thcorner.R
+c55d5f7719d4967dca129e6442923802 *R/pcaiv.R
+430d40e502d64d32b46514eef65b1b77 *R/pcaivortho.R
+9c5939393dc9d930a76ed5198ca13dbb *R/pcoscaled.R
+7fb5aae46168406971e84d0ab89029fc *R/phylog.R
+c3a560292c8d32a4255facfa5fdfbd92 *R/plot.4thcorner.R
+3096ec927cccc0f3884de2589da19a98 *R/plot.phylog.R
+348263fd55483db1486392c794f10f87 *R/print.4thcorner.R
+912cf5227f77a178e3a816c7ac722a32 *R/procuste.R
+d3da45b867073b05dcff18c59e7aa4c7 *R/procuste.randtest.R
+36ed83c95f350afb554284f83ee73e0b *R/procuste.rtest.R
+b9ea3592cbc6bd086555067572cdf291 *R/pta.R
+83adfebc61e4cf82a35faa164fbfdec0 *R/quasieuclid.R
+f2904844386d33f5d31c33476e2748e9 *R/randEH.R
+724fb865747d7a8e3d135b34f3f2dc55 *R/randboot.R
+78de2c2c0e973cd080e01a5d96c94414 *R/randtest-internal.R
+7b814399531ebeff7f64d5a0a975c328 *R/randtest.R
+07f51d6442a757fd5317b7e61389e13e *R/randtest.amova.R
+02c2e72ec7f369bf34a1691e8db38832 *R/randtest.between.R
+b59ad08ad77ab61c9415d1d37f5899fc *R/randtest.coinertia.R
+9c990f7f1bb883b8bf50d47c13ff67ba *R/randtest.discrimin.R
+6fbbc2e6e94a170efa9864c9eb38f5e5 *R/randtest.dpcoa.R
+21bfc6b5eb7358408a6b64de4606881b *R/randtest.pcaiv.R
+d494a580b2eb22f88afc106cde1a0ac0 *R/randtest.pcaivortho.R
+35e9b020452713720e3c6a51d937c152 *R/randtest.rlq.R
+2c43d2ad5a0a2c0508d5df3ad671707f *R/randxval.R
+7702275332a65be5ac06e6c9239d06fa *R/reconst.R
+fa9691864887eca71e7c0b26e3f8b3d1 *R/rlq.R
+0f0308ccb9f7888ad2f97d8f1b13de9a *R/rtest.R
+83e60a3ab815d5dddcdbf97d74bc2bfe *R/rtest.between.R
+1c3f5d3b4ce4db19cc4842035fc7c75f *R/rtest.discrimin.R
+37f03878e48caf84b7e21949c0403372 *R/s.arrow.R
+ee7438d4ae55f221a0d5fd5e2673ae42 *R/s.chull.R
+2354f21cf9e15b3d6a558a5d3be3c291 *R/s.class.R
+aca9b2053b00c8a285477b1d82497e8a *R/s.corcircle.R
+b11ecd30666290a614164d1c9e933ac5 *R/s.distri.R
+3097b3b56620aef1a0268c218134cb3b *R/s.hist.R
+2dd98e6fd768f9193ee7db30ba44fef2 *R/s.image.R
+30040634d23602a4194d20d55d0ce34d *R/s.kde2d.R
+be929b7c75019b547824ed6ec8319a45 *R/s.label.R
+724ecfed04fce15e683a466ddf8d1f1c *R/s.logo.R
+c74d15198a58d51c8a7fdd71a7b386e3 *R/s.match.R
+4b690bf8b363093006d16f245905037d *R/s.match.class.R
+00fe604bc5ee1e759955d7c4921ecd00 *R/s.multinom.R
+5476ea737de231e36c59555006f6d8d4 *R/s.traject.R
+22c03c187ff4696e5b8c786f9b6c7a96 *R/s.value.R
+f2c8fbdd4f688cf81a6012d27b6b8244 *R/scalewt.R
+a33c87d64739e5a33918a6d23a1c0829 *R/scatter.R
+b8c39feef57fc4df49f577e6f93d16ac *R/scatter.acm.R
+75ee34c98af22b79254625ad67e04270 *R/scatter.coa.R
+c13595137e55e094a400e873921a74af *R/scatter.dudi.R
+0d2c370a3abd0e4715c2b49ad2979a65 *R/scatter.fca.R
+57b4cc465aa38d950e9972b9305dcc89 *R/scatterutil.R
+31b7f139c1a72ed48b150058424dbb21 *R/sco.boxplot.R
+fee5ae7ff8af4dd378d7a942f4d2b694 *R/sco.class.R
+9ef8135934d952ba979d9ee5632df19e *R/sco.distri.R
+7e509c1b0ae74783603be56049ef56af *R/sco.gauss.R
+19e7719adf1d4879e96c1c23e9a53049 *R/sco.label.R
+f46b610e8da21161bf7092671fc38ddd *R/sco.match.R
+7847c55980e360e43a983958804d02cb *R/sco.quant.R
+bc1f1118378060e2c1d355373a9f678e *R/score.R
+f0baedc9da6b042275c3319b4cca3e02 *R/score.acm.R
+dacda9698d458c48c8b8c49e838e7b1e *R/score.coa.R
+db96b4cbb4c11ca86b0a544075255b9a *R/score.mix.R
+9e9449fffafbff1d9c12ca85bca86bde *R/score.pca.R
+d67e8a64c7a071245ace529759b5d933 *R/sepan.R
+de0654a2aee115e8ae7fc40fb244886e *R/statico.R
+3e14cbfd0cf8913d861a6bd2052d0013 *R/statis.R
+91c6e96e5a83ae05746a1de1288c145c *R/summary.4thcorner.R
+834b2cb4dffc468ba24caaeb0283c40c *R/supcol.R
+75906367d78ef6392d01d1768daf8f79 *R/supdist.R
+8c84c48245078c6c0b8a51b698edb1a5 *R/suprow.R
+19128aaadc6cb691920aaeb97679551c *R/symbols.phylog.R
+bc70ddf20e036e5273144e0628a20165 *R/table.cont.R
+471ba8b286985e644cf15d7ff3f2bdb7 *R/table.dist.R
+5cf4e431a04010a26419c634a0098ffa *R/table.paint.R
+d0b935b44a81934e3f4c89bb14cc4265 *R/table.phylog.R
+3f7d897a61a6cd27d87c8567f544db25 *R/table.value.R
+98c9a30099d8ed5c8201fdde18741876 *R/testdim.R
+cfb7cb01b37b71aa72172191bb85e38a *R/triangle.class.R
+faf7e25c608e2b48cd4162840d6cd414 *R/triangle.plot.R
+86ade522f518bf2f86527fdd34fc488d *R/uniquewt.df.R
+268638a11be5d2bd36d2a0b6bf94e62a *R/utilities.R
+a5e3adba52299bbc266614bfb129c5dc *R/variance.phylog.R
+d4f5741d0dfc866ca1965151a21e7cb7 *R/varipart.R
+fc7ad0d60c544e7fb0cda0fbb4f1c0a1 *R/wca.rlq.R
+51928d5c709ebeb571d924dbfdbca59f *R/within.R
+c1ea208da1ac10900d290ebefdc4bb0f *R/withincoinertia.R
+ae76386dca7368d10a0fe45f5359b695 *R/withinpca.R
+6dc08edd27a3613101e7d5cb8a8fd166 *R/witwit.R
+120a205bd4dd852cb90b6e3cadd2c5cd *R/witwitsepan.R
+c06998c47095079d17dd3cd12e08a21e *data/abouheif.eg.rda
+e0cd641217952ecfc5a848b94eba4c09 *data/acacia.rda
+2ca97a8b530f94fc412e0ba8d1967934 *data/aminoacyl.rda
+ddf7f1a15044529ff08ae157d528d460 *data/apis108.rda
+9a6731c18c01ba678c35477a35d552a5 *data/aravo.rda
+85ddd5f1083fd1ffea26364971b0b4ea *data/ardeche.rda
+60bff6ac74b649f60434b86119915b80 *data/arrival.rda
+baaf2393a8bf4630f06255e7d58525c4 *data/atlas.rda
+00bf611f96db4e5cf4ddc1b993853a18 *data/atya.rda
+6e85f7cd5c140429cbca04b53e119257 *data/avijons.rda
+714b789d5c33d57e095985b91ad6ee89 *data/avimedi.rda
+c201b7c166f8f914e213276102febb5e *data/aviurba.rda
+995d8041ebf53149d9b51ae3e4f4f322 *data/bacteria.rda
+3ff3565706153bba0aa8afd05ddcbdfe *data/banque.rda
+f4c9d1b93bf3d6044f18ec25a89e0977 *data/baran95.rda
+2831bfb86a947a8775e4bbb94bb6eac1 *data/bf88.rda
+a492cdc12034ec1bffc719895179b3be *data/bordeaux.rda
+39b9e5073f77c1eb3da496cc9ba33158 *data/bsetal97.rda
+de02bb44d29e9724b7fef4cc9ec680a3 *data/buech.rda
+293123afc55f8fd4af350a34ce5c95b1 *data/butterfly.rda
+3a2da41103bf31ec31ef9daa782c0c79 *data/capitales.rda
+fb47d6532985c28847275ecc7fedfc0b *data/carni19.rda
+c09984a0fbefea5a3f817cf606146584 *data/carni70.rda
+84cc2eb9ff3e4ff524dd35eb82d3768b *data/carniherbi49.rda
+36f3715058d30cac5eeb03bffe608984 *data/casitas.rda
+13f3afae64fc9fde7d4c32ae0d991491 *data/chatcat.rda
+5173982c5d87f689dd7d3c8dd50d3e6d *data/chats.rda
+5a29afed782ef8691fb71e4091790ab0 *data/chazeb.rda
+77e300127ee8fa1efa881c370a50cc68 *data/chevaine.rda
+f205a37d806899850cdeb864871592c9 *data/chickenk.rda
+c9db3e21c3bf21931517c7017d9704be *data/clementines.rda
+da954f02932de9549e1be4de4578fb85 *data/cnc2003.rda
+f9163193c51ca5fe0d240658081a63bb *data/coleo.rda
+185b1d8aa1697eb0e9058ba644761b4e *data/corvus.rda
+1a95a113ec1093c3365d1fe0d6e4eefb *data/datalist
+95616ce8d746e812ebfbb2b87335edb4 *data/deug.rda
+b31d118f38cc7320dc7c321af9ff3137 *data/doubs.rda
+6a9950d11a5bbe60211bc6e44fa0d4e6 *data/dunedata.rda
+e32092be2dfac9d9177c130d2ce01404 *data/ecg.rda
+04e6a1ae9ed040d9067e657356c3dac3 *data/ecomor.rda
+353c4cfae2a2adb79a9e8f0f66b40e20 *data/elec88.rda
+8cada6d2d5221694d00ff3ea82f47cd9 *data/escopage.rda
+d833e03cf7cb5fc4b2012d975efd93ef *data/euro123.rda
+385270f3002c5de9db96705ca6e40908 *data/fission.rda
+82eef08fc1975120e6e183edef19ebbf *data/friday87.rda
+a10686bc396f59063a152426f2b47ee9 *data/fruits.rda
+c17e1f4d322a5811abb42a798b6a9db3 *data/ggtortoises.rda
+16312dde9b3940f84fda2d0099e05e23 *data/granulo.rda
+941ac27ed358b66e73eca2973f8d2ced *data/hdpg.rda
+c8b4793917873e0ba1b2b41b4be7bf27 *data/housetasks.rda
+3c94d9c413d82bc9ddf6380357eefe74 *data/humDNAm.rda
+35dccfdb5e933712ec2e5ef2058925e5 *data/ichtyo.rda
+ef60fda084e593c7c6ac266844e70a6d *data/irishdata.rda
+04e7a6403832f9cc8ed968128aafece3 *data/julliot.rda
+8e21cf3fd4f3f1ad49f147e0b15a3391 *data/jv73.rda
+b62c1dc15942b5ddb2d9163f64cc99d9 *data/kcponds.rda
+5cf1ca3b1d313e7448e125427c33a8f2 *data/lascaux.rda
+d31937e2535ffe6fe6c0d72d25347aa4 *data/lizards.rda
+8b0e617649b8c3b09b0f77ccd513c273 *data/macaca.rda
+fb0125ffc901336a5a54272b71687cec *data/macon.rda
+278ba53cc2f0b50a2f6a70a2b8866a7d *data/macroloire.rda
+efd9c8ab4579e9631e2c030db1273ad9 *data/mafragh.rda
+54f190b119437306366726f1706a003d *data/maples.rda
+40d2bd58d9455ac595caf066fb24280a *data/mariages.rda
+54c19ca68460205ffad1cb5b66ff1c1d *data/meau.rda
+8dc0b8a7473e67c8cdf2644ff3a99e31 *data/meaudret.rda
+e581cf483d88f2cd3d3fcf13cf59886a *data/microsatt.rda
+f9b33e218603ee0ab52f253996e22fe5 *data/mjrochet.rda
+c5d7c2c9762f51845c2305bdd32d38b2 *data/mollusc.rda
+b970f77213d53e337775de895f08cdf8 *data/monde84.rda
+1a6ae42c36bba890770a037a38b2c27e *data/morphosport.rda
+3df25195c0f6b47833b7bfec7bd1c139 *data/newick.eg.rda
+21a9dac9147550b1818c0f6d223d0d2a *data/njplot.rda
+14c3816b86c150044ba874685f9d0647 *data/olympic.rda
+c2b7754b8a9f9048565b443dd258925c *data/oribatid.rda
+70d32a1186c9b3dd0dbb7e2cefa31248 *data/ours.rda
+dcf24d8a524b736c8e9bafe76ab56e06 *data/palm.rda
+80fc6faa84e9cb3f2f2cc8f114773fbe *data/pap.rda
+218316e327f2876faa054d4b43cc7c40 *data/pcw.rda
+22b873e3ba7543183adb5ca6f0e8992e *data/perthi02.rda
+7b7c1a8fbfce35281b31641dd671fcfb *data/piosphere.rda
+8c4dd064c8401a5e1816ab34c95a5af0 *data/presid2002.rda
+09955da04f6c0d7ce2cdaa0be3fe694f *data/procella.rda
+b185edf10d338f98b831feb73213974d *data/rankrock.rda
+cfcb6aade1f15e4838c608613ed7986a *data/rhizobium.rda
+687a7a973b9cae96c3589493bcfb1639 *data/rhone.rda
+ba73041332b4802db7e475336ab8cede *data/rpjdl.rda
+e1746c3cdbbea94e22f55ff22db1cad8 *data/santacatalina.rda
+1c4dcff821765ad3f03e17baa63b9d56 *data/sarcelles.rda
+5a350431bafaa85f65723526397aa2f3 *data/seconde.rda
+2b1850fa88fa8dba364698a57acf3938 *data/skulls.rda
+bce6c68208129721faa086c1ec962763 *data/steppe.rda
+850c34b67025bed8a26f14f5c8963209 *data/syndicats.rda
+cee374da7a165f0295ed916fa00294ac *data/t3012.rda
+847055f5f129e0ec9f265542bd447c6a *data/tarentaise.rda
+3e48c8e9f0be80a55435b610d8ed6e10 *data/taxo.eg.rda
+a8f4ddbaee7768272dbdf96cb8bb2e87 *data/tintoodiel.rda
+5f589f8835b6ded6a70dfe8312be8817 *data/tithonia.rda
+1a2da3050df84b4f88847a28934b952b *data/tortues.rda
+3e4395cfb385380204db2569cb0f4407 *data/toxicity.rda
+f933701b341a9a8774537b4024b6af9b *data/trichometeo.rda
+e30d7b713ffad63530009e2233314dea *data/ungulates.rda
+e1d273fdc612332e6befb89cd3776561 *data/vegtf.rda
+32c9418b646e5ab74c9c992f084603f0 *data/veuvage.rda
+c9a9bbcebcfd8761e29065a97e6d0b6d *data/westafrica.rda
+1f59b5375c15279995bf64273d079550 *data/woangers.rda
+53df52b0b8de963f7cd1ed72ff171da5 *data/worksurv.rda
+55cd9d01e39691f67acfd1ffdd607652 *data/yanomama.rda
+f19df1a99aa3d39631422b7b247f4511 *data/zealand.rda
+e53d1eac07e3fef177efccf1b28c2e6f *inst/CITATION
+a134ce28598a2867b151d0cf11e944b7 *inst/pictures/atyacarto.pnm
+6a427fa2a11dc07d5b2686fa50405d28 *inst/pictures/atyadigi.pnm
+d62a9968f404a5d984e336ebd95f68e9 *inst/pictures/avijonseau.pnm
+0941cfeae8504c03218ced2d60e242b9 *inst/pictures/avijonsrou.pnm
+7934a9b9ce8a7ede9a352db4d3285751 *inst/pictures/avijonsveg.pnm
+f4f9d4748e332ffe2df9aff488a5f0af *inst/pictures/avijonsvil.pnm
+2ca9e0460d805cc86e18f393bb9a0356 *inst/pictures/butterfly.pnm
+b8cba30aa7aade7e983120a365353fec *inst/pictures/capitales.pnm
+fd5e6efc32eea941728ba23444038fad *inst/pictures/fatala.pnm
+b370622c8bf09dfe071a7ffeb46ba05d *inst/pictures/france_sm00.pnm
+bae85092a512c2dcb7898f35626c9a69 *inst/pictures/ireland.pnm
+53343ad8450770f6033539cc253665da *inst/pictures/paris.pnm
+ddc70df388a9749473b91e043cd9241c *inst/pictures/sarcelles.pnm
+87829cd565c28ba216b7be12d9e54bf9 *inst/pictures/tintoodiel.pnm
+346bdec65933f5f4047269c84d5f731f *man/EH.Rd
+2ca9eaa8028226469e5b1784c7ab109c *man/PI2newick.Rd
+fec860e43d6d6501d35097506c112ecc *man/RV.rtest.Rd
+b8dafab047ca08f8950974ebf8bbc54a *man/RVdist.randtest.Rd
+8d654e1dedf1443cb5e90b1f13678fdd *man/abouheif.eg.Rd
+ff29b060033e5dce219e38dc81825a7f *man/acacia.Rd
+c7e90a20b622ba479c37187eb255a7db *man/add.scatter.Rd
+295a005fb4c212021b8b1ef8a19f3ad2 *man/ade4-deprecated.Rd
+b1507f756729f1164a1efd34a3b626b9 *man/ade4-internal.Rd
+f36894b1db378ea7ef4bbb95bfc8ab38 *man/ade4.package.Rd
+e3b0339a997676fb728a424b20db4ebe *man/adegraphicsLoaded.Rd
+a8af05ea4d586e8c7b625a1f0339682f *man/aminoacyl.Rd
+249b4c19f78f6aa3474ecc5f7e177075 *man/amova.Rd
+f7a565f2113fce262a2ff36368425080 *man/apis108.Rd
+208ec14214b92c594f5cfe076af1cac8 *man/apqe.Rd
+18ca41e0078353333d595ad74220dc6a *man/aravo.Rd
+2b3a479de8f346040a701a4cb10d3d98 *man/ardeche.Rd
+8bee26454ffd2b230fa7fa45eaeada18 *man/area.plot.Rd
+4ffac3a403122350d3bf25b048d22108 *man/arrival.Rd
+26759451a77308d6f556575ec677e0d7 *man/as.taxo.Rd
+d48c9dd29ea109fc24fd73d9b82ec60e *man/atlas.Rd
+695b3a0ff21bc437ff3cd5a31bc22901 *man/atya.Rd
+5f7ef7668aca87197da730e52dd63536 *man/avijons.Rd
+5b46f1b3eb76344f4bb52728b124c7be *man/avimedi.Rd
+dabc0712d7712db91faa37724853c41e *man/aviurba.Rd
+7c5d3194045544ba067d8ee5fd5c78a0 *man/bacteria.Rd
+3bc4630371d25aa72f07bf1f7b866479 *man/banque.Rd
+820bd2c569ba9044f27a5159f8b3ce41 *man/baran95.Rd
+0f75a3e12fa45b42c763b204b74c6d33 *man/bca.rlq.Rd
+f98e6e60907b4db21fc66b50fbf448f6 *man/between.Rd
+46698c2cd4ed652ecc27ccdfd956d11b *man/betweencoinertia.Rd
+d87c50343421d615eec0183992e282c5 *man/bf88.Rd
+0880389fbba8c8cd00662898e49456bd *man/bicenter.wt.Rd
+070c77d1a50db9af402a00411374540e *man/bordeaux.Rd
+658377f307a06c176d610177a928a71f *man/bsetal97.Rd
+01cfd25cfec09d1694448cffe61517fe *man/buech.Rd
+03e9edd8d39395ced0aa460076d921e4 *man/butterfly.Rd
+c29141ff24a81ba211d3a1e2222ac9bc *man/bwca.dpcoa.Rd
+6ffb638f5a058ab25cae4894ee002dc8 *man/cailliez.Rd
+9b9123e6099f94ac1ae11d54295f8220 *man/capitales.Rd
+d0ab9fd2335bbc6fc9ccf329c3e79b7b *man/carni19.Rd
+220d24559049231ae59c66785a93f5be *man/carni70.Rd
+8db45c0d262f6993068d8a78141550bf *man/carniherbi49.Rd
+f356254b1f57a940c3465a14d7128f69 *man/casitas.Rd
+36917a4def5673847ad737e21ca0ff09 *man/chatcat.Rd
+148d03c767a82f8d666d5862eaaa3b46 *man/chats.Rd
+db6510a81935c5bb821a0f631a001db0 *man/chazeb.Rd
+55a059411ffbb9e2e329c64a4dba2ff6 *man/chevaine.Rd
+ba42eda2b1386ec657937901943ca286 *man/chickenk.Rd
+303f97951f27ed47f4b1c2d972960a96 *man/clementines.Rd
+5b4f9b96b33f6b48c86eb5abef0f5491 *man/cnc2003.Rd
+b9cfd25c0a5c666048798f1619febd3f *man/coinertia.Rd
+51c3ef8a67231886efec2490346394c8 *man/coleo.Rd
+9d545c250b95c360a40d8a5e3e672e80 *man/combine.4thcorner.Rd
+d97ed33dbd06ae7dccf149e0574a014c *man/corkdist.Rd
+1bc1d38379b7e4daf4d83b41a79848ea *man/corvus.Rd
+b436dd64c87718dcebeaded19a4a3c88 *man/costatis.Rd
+10c185d7d25ce53ca6478f3c8327ec8d *man/costatis.randtest.Rd
+bf6d529b62f5005a0892368041cf16a0 *man/deug.Rd
+b707cfe0f6f33b2355c6653dadfbc815 *man/disc.Rd
+1c3f434d90018336b808c1a286143d30 *man/discrimin.Rd
+30c9421e4bb3c2adcd0a4bbb568ab3f4 *man/discrimin.coa.Rd
+722ea45480bc97122a7a5e2285a9486f *man/dist.binary.Rd
+ef1758a31c80808665c088526667bcae *man/dist.dudi.Rd
+5520a02e92bdd3325a6f076f5fb2a1df *man/dist.genet.Rd
+a708afe91c8b9bebc8bf46cf68df8f44 *man/dist.ktab.Rd
+5ccf470ce27b4a31abf024f13cc08e2b *man/dist.neig.Rd
+74cc1ac08c5cae5d0695e07ed2e40487 *man/dist.prop.Rd
+0a8a26a56402c536e2e39aad6e8665aa *man/dist.quant.Rd
+94453f0cf98a70313df87f6f1d4cc518 *man/divc.Rd
+5f91f9182629a0ccb925b2b169824bde *man/divcmax.Rd
+339344fbce5bd0c61335905b96f56f8e *man/dotchart.phylog.Rd
+0176997c403c432a383e50bc1be21167 *man/dotcircle.Rd
+8678be67589a18ccb09cbdb3e9d91b19 *man/doubs.Rd
+6bf1dae5e7ff35dc6b82855aa0c5212c *man/dpcoa.Rd
+5cb31aacec4e5a5cedf8dc73f63e0a11 *man/dudi.Rd
+48c88109b49496de6fc3ae2258e53624 *man/dudi.acm.Rd
+789c707ec785d9bfaa0ee93395be8dc6 *man/dudi.coa.Rd
+e40e83d83a2b6a59cff2760838b99642 *man/dudi.dec.Rd
+842ee0f2df3ab14d0d0192adb0dd86ff *man/dudi.fca.Rd
+d63c6d6c11fd20cbcb05b9be4f67e822 *man/dudi.hillsmith.Rd
+de3017b09b056bf751c4c66217b81743 *man/dudi.mix.Rd
+405e040667a89cfb8e760505c09ec518 *man/dudi.nsc.Rd
+6017431cc04ba009531fd20f33a70038 *man/dudi.pca.Rd
+c3e278b9d1dd0e24b61e4238a76b60f1 *man/dudi.pco.Rd
+ed0ad98b7d8dc3cb78b34d0c9018b326 *man/dunedata.Rd
+81b756ac1f475729660d896041568336 *man/ecg.Rd
+92dacd83d6238b53a3d2d74c68245f66 *man/ecomor.Rd
+7e080e0b43590830e8832066b73f161e *man/elec88.Rd
+f68bf1a1d100b206d6a10f29e2543ebe *man/escopage.Rd
+02c85de52e3cb2703dc8d4e7537e2134 *man/euro123.Rd
+4a3db474ec918ed1eb517b9d65605982 *man/fission.Rd
+2d9e0e91e23b9c28a9eb80b4079a1692 *man/foucart.Rd
+2107a61245d9c09a5a3df1784778ad2f *man/fourthcorner.Rd
+3adeabc79ad58a8adf4fbb9353ce07f5 *man/friday87.Rd
+e2bea0a520462821a036f271409f33f8 *man/fruits.Rd
+b479fea4a1903202abb5f42d1d52ab08 *man/fuzzygenet.Rd
+c90c906094000915af6e610beb8fc0d8 *man/gearymoran.Rd
+cb69a5691c64f9bf4328b3382df098ac *man/genet.Rd
+7ad4516709f45cd0238526931b511595 *man/ggtortoises.Rd
+600bfb1450a9c03464de8198195d6f82 *man/granulo.Rd
+84be71d00e16e4663e27d66786f39b6d *man/gridrowcol.Rd
+c617fccd9ed44d9de41ebceef9827589 *man/hdpg.Rd
+657fa22c3ec73f707d87bc3a1aa4dad4 *man/housetasks.Rd
+34ede9cd77aadc0483270ce83d94f3c8 *man/humDNAm.Rd
+329d66616200815109272f705f9c3721 *man/ichtyo.Rd
+9de216de377c2be16c405158eb077676 *man/inertia.dudi.Rd
+9510846b2922a95bbf1c2d282317b2b8 *man/irishdata.Rd
+d8932e7c9545fb802e44acaee5e715c2 *man/is.euclid.Rd
+d7388290500a212e279f001133e5f017 *man/julliot.Rd
+2b2ff5e54ce7607a8836d0b412a129e5 *man/jv73.Rd
+e16deafd166206849c1261d2637a0812 *man/kcponds.Rd
+a0693ed8183307bc121d3787ea5f0598 *man/kdist.Rd
+b0961249596434ce3a0159a22b41af52 *man/kdist2ktab.Rd
+30ee8d5bdf4c64570a3736fc31b76802 *man/kdisteuclid.Rd
+ea9e77da2931e615fed14ccd10c32182 *man/kplot.Rd
+53c3dcbe1d9f87d9ef79a254c73cdf1f *man/kplot.foucart.Rd
+d92e7fefc64d4187c7072ef645c6539d *man/kplot.mcoa.Rd
+ae5401351ae377a42eccede83c644d3c *man/kplot.mfa.Rd
+868a49832171df02105a2159a34029f3 *man/kplot.pta.Rd
+671cc100f0f4fec221fb23c26b6a5f2f *man/kplot.sepan.Rd
+2caa270bbf015958aeae072475d64cc4 *man/kplot.statis.Rd
+168deecf33ce2e4989691e6d3bc15efb *man/krandtest.Rd
+178ec4ef0849a18731765c8fefe50a25 *man/ktab.Rd
+8794927f88fd6a392b53fd9ff91ccb65 *man/ktab.data.frame.Rd
+798f0ef80c974286bd5024505ca2641e *man/ktab.list.df.Rd
+8231d3791679798e63bed555ab5feb8f *man/ktab.list.dudi.Rd
+ab8a36023c98addf300753ed0d827d7c *man/ktab.match2ktabs.Rd
+70785906914389698f7427b66c7bebaa *man/ktab.within.Rd
+8079d383b8fe439a05b5327598c2d8c0 *man/lascaux.Rd
+a60aec1e73f6e5e44469dc5cae1b6515 *man/lingoes.Rd
+d4c0558a22707b775e0ff79c7771adf3 *man/lizards.Rd
+ffb4c26da7697a5ed7b1e1edec99d13e *man/macaca.Rd
+2e0a5f29e020638da962402a07c41c94 *man/macon.Rd
+738d6ad074c9750d7f583d3580886a35 *man/macroloire.Rd
+39d39640fe4dc5490748196bfd2a954e *man/mafragh.Rd
+1788956ebdf5d538cbf564ace0d3cbec *man/mantel.randtest.Rd
+8b4cdae21e7d8f90d7fcaa9a5250a054 *man/mantel.rtest.Rd
+e2f8e0146d8ac725ca6f3019db24b9f0 *man/maples.Rd
+e5bd6190c3964632a6eac8982a5244c9 *man/mariages.Rd
+5cc13ff1a843974f0b90d81be4f3ef69 *man/mbpcaiv.Rd
+197dafeaa7534875f29e387196cbc20a *man/mbpls.Rd
+4fff9cfa974199382a0386f57f28f21a *man/mcoa.Rd
+faf07f3c20cd21f6fac74cc9aeecac1d *man/mdpcoa.Rd
+701ca4c18001cbe33d42124c74595898 *man/meau.Rd
+2355ad84cecb81f9ce4049f03cd6e0c8 *man/meaudret.Rd
+ac960a48feb4766da9573ff16151f247 *man/mfa.Rd
+0e88267c33091f0751d7e888a694076f *man/microsatt.Rd
+1ffbbfb63e3ecdf0831216e068395125 *man/mjrochet.Rd
+35ed0115f52f10d23c74000ef76018e3 *man/mld.Rd
+f31cd1638fb6c92a04344cc4f6f232da *man/mollusc.Rd
+5ae787bce8773ba944d9daffc2ac6640 *man/monde84.Rd
+aa0678333c8ba7621a3470615cd2a9f1 *man/morphosport.Rd
+e5c6a90a580066a1cb959074111a49bd *man/mstree.Rd
+19dfd88abdfd28a862706046624e2ef8 *man/multiblock.Rd
+4898d49b8570d33bd4289d238d77f533 *man/multispati.Rd
+3aef8a9a8b18b5d051bb7a9eea207390 *man/multispati.randtest.Rd
+60d8028f4435badc92184cfedcb2611c *man/multispati.rtest.Rd
+9ffa076252e07bdb74b4c48c51e29c7d *man/neig.Rd
+325c49fee3e2a9e96334ce6cf5ab4ac6 *man/newick.eg.Rd
+d7bcade1864c48d2b12ac37fc293069c *man/newick2phylog.Rd
+df1d19ece13db1186c4d62deacce8829 *man/niche.Rd
+3eb9fb98b456ccd5b2eeffefff2833d7 *man/nipals.Rd
+f02b2779f45cf6fd48bf2925804aa82a *man/njplot.Rd
+d9c4a1e91ba04f2a2eb913dd6d2fa695 *man/olympic.Rd
+9f95978ec77fd67096e3f60becce685c *man/optimEH.Rd
+0ea029ae19803ca758031d0518270d82 *man/oribatid.Rd
+4f57c9b6bb73c1a91f282680be86b243 *man/originality.Rd
+3706900690c603af1f421a8a744eec20 *man/orisaved.Rd
+2ac35f9847a9d073a9e8430d5846e3bf *man/orthobasis.Rd
+d72e8495c495ae554236a9deb69d8f57 *man/orthogram.Rd
+379903c55f52fde22eaafe09521c9386 *man/ours.Rd
+d8dc36347a569adfba3d16b03107cb55 *man/palm.Rd
+768133bce2da5715356183b211eb76f5 *man/pap.Rd
+b33e7fc3381597afc498baead8ca5047 *man/pcaiv.Rd
+0fd2c833f564dc8b178b8328c0573d70 *man/pcaivortho.Rd
+e5af7e7dca04d7a7914bdae08c680c55 *man/pcoscaled.Rd
+d4a610cb68738e3538148f6836eac7ee *man/pcw.Rd
+0608d931a3b59ae1577b1b39560db4d1 *man/perthi02.Rd
+568f545e65ad7feb3b70f9b725af2690 *man/phylog.Rd
+2696ba19f5ba9f562ba5f3ba2ad0833d *man/piosphere.Rd
+1002aa586842dd548805751aaaf8e59d *man/plot.between.Rd
+e2d88196076415810091c8368d110dd2 *man/plot.phylog.Rd
+1ecaf862a6ae3394050be4b63ee96ab9 *man/plot.within.Rd
+9cee92f46a8db2514211816cb6f16e98 *man/presid2002.Rd
+1e74d3ade86110c4032df7c415a8c3e0 *man/procella.Rd
+dec90bd68c3510fb1b3aa8f763513309 *man/procuste.Rd
+4baf94d13d9feb9f5d82a1af9e857d42 *man/procuste.randtest.Rd
+fa31dc1287612217fae3ac3d8589324e *man/procuste.rtest.Rd
+92f7f004083ccb02f0a6c54342127372 *man/pta.Rd
+b497a56dd3ede8cd6c40d7316397a682 *man/quasieuclid.Rd
+cfc166813afb93e515c03b706568ce37 *man/randEH.Rd
+dbabb33255dfdbc2a709b9f43b16c644 *man/randboot.Rd
+511b4cfb7563ad499700eb4b8e50d904 *man/randboot.multiblock.Rd
+76e69cc32af1f11f01950a2bfe928711 *man/randtest.Rd
+2146def722f2489173b73281f8f7eb5b *man/randtest.amova.Rd
+1d37cb1c819aa6421c568e977eb13787 *man/randtest.between.Rd
+98604c474760ad89b67a8b974a70e095 *man/randtest.coinertia.Rd
+10a0f0962fd8f6bd115b4a3112686ce4 *man/randtest.discrimin.Rd
+b2a46aef9825a8a962ca987ce017abdf *man/randtest.dpcoa.Rd
+91a19c1a4b2c57b93f32f755dd564898 *man/randtest.pcaiv.Rd
+82d7f423171d3aaad0ff11c740e3362a *man/randxval.Rd
+f5ce90e1dae92961860a0309aea92340 *man/rankrock.Rd
+441fd1709665d44ff5456cdc95ddcbfb *man/reconst.Rd
+35cf26198b4ca8737e051a2655273e58 *man/rhizobium.Rd
+a068b5837203265eb7012a9a1bd61f28 *man/rhone.Rd
+1233ef0ae7fd4262559be81b05ce3c69 *man/rlq.Rd
+474ec9251055e58191346ebe5fee402e *man/rpjdl.Rd
+b4ad2dad4b74501f452f59563b138a98 *man/rtest.Rd
+02bfc1370d63102629e8f7edb7bfc76d *man/rtest.between.Rd
+9c7b66c21c5d4f32662fe905fe3bc12d *man/rtest.discrimin.Rd
+75cfe60badb83d52fdaf2d3908652b67 *man/s.arrow.Rd
+adedd8cd01431202e894ad79a0177a2f *man/s.chull.Rd
+4987f998e8500c73d077c9d9f43eba42 *man/s.class.Rd
+b6a38cfcf4b0ca26692e1077c155dccb *man/s.corcircle.Rd
+7e446aecefbca6590e7572252d027a7a *man/s.distri.Rd
+2a7e048a9a7a20bc350e2a9d8ad7dd27 *man/s.hist.Rd
+42603cdc29372482b4979b4a5e13bdc0 *man/s.image.Rd
+80c0bd018dbd97bd792bf355ba4e43c5 *man/s.kde2d.Rd
+8ab446112c535068bd8cc452f830599d *man/s.label.Rd
+970aa00c1f1866dcf169062589f3c010 *man/s.logo.Rd
+eeebdfc6d77794d7f360ce7088c67dec *man/s.match.Rd
+e8ce1fe0be8a0b4d5058d8c81fa3bbbc *man/s.match.class.Rd
+18c41aa3fcedc0469aa6079555f6845c *man/s.multinom.Rd
+f8025fb61bf804fc9e081f8edfc020e6 *man/s.traject.Rd
+55e61133e6e8a6b9787769816216460c *man/s.value.Rd
+73a771465fb9492a137f8cad033d2dd0 *man/santacatalina.Rd
+73f2b1fb3e5b886a61eb2929e1d2f974 *man/sarcelles.Rd
+b136f551f263a4d26610cb4213f538e9 *man/scalewt.Rd
+42e9ab9e0d7594ed094881850e02e181 *man/scatter.Rd
+b8b85a697a1c1ba4cfb03dfad676e145 *man/scatter.acm.Rd
+c8034596c0bca197e7a689bd45be5fe9 *man/scatter.coa.Rd
+5e3db1c877c39b924e6d0e0c063c3f85 *man/scatter.dudi.Rd
+f7cecc1a6d7e418f92f18f46a6b7a252 *man/scatter.fca.Rd
+adf482c4778f67ccaca56028c58b61b4 *man/scatterutil.Rd
+26b859f8c11cf01acb18f2eca360ad80 *man/sco.boxplot.Rd
+5da43fdc6e9e027391b469f9f019da72 *man/sco.class.Rd
+45c53593c5dd8ded54cdfae6b6f6595f *man/sco.distri.Rd
+071abca8a4e36cdea2725d6824549dbb *man/sco.gauss.Rd
+25e8ea1e87af4dc20c21c9141aabe39e *man/sco.label.Rd
+1fcc29ad6bb4340d9c22b0cde95a6d8e *man/sco.match.Rd
+5931a415d98abfafbe8720e95f467b5b *man/sco.quant.Rd
+aed87c3484cbf079ec9b2ba53f2fa756 *man/score.Rd
+6927cab2a6b4469a433b7822367799d4 *man/score.acm.Rd
+3248b760ebfd7fda6104a0d6763e50dc *man/score.coa.Rd
+3abba411d10073654e78d88d72403dd9 *man/score.mix.Rd
+cbd5e28da2093acd082e1923f82906f0 *man/score.pca.Rd
+18ea79b764e5a8bea14b8f06e962c25c *man/seconde.Rd
+bb6f2336d57376429a2e84ec462744d8 *man/sepan.Rd
+16351ed0f5c40dd8b128271b179c0aa7 *man/skulls.Rd
+5ecf543f433718af31e3eb57654091ef *man/statico.Rd
+9740b09dbad578d527d7cd536a570806 *man/statico.krandtest.Rd
+17a8cc9d63d55909ecfe70bdd7468d0c *man/statis.Rd
+715910d3844db60390d7db3042ab4442 *man/steppe.Rd
+e7bb33c3766623f999c645948417efbe *man/supcol.Rd
+a3e6a34dd8837531d1d88578af895761 *man/supdist.Rd
+d6c53581db44f7db02c4d4cf2f41bc68 *man/suprow.Rd
+ebe8f79b0d7da4bd698db7a34a9f9637 *man/symbols.phylog.Rd
+7f17d062ca1a936f7d1bf014ee68211c *man/syndicats.Rd
+c9ead23f79bc9cc8a33244d530b1d0c1 *man/t3012.Rd
+c3b3418666f768284734aba678e4bfb7 *man/table.cont.Rd
+7f6c33833a5afee6817b23c39af0ad33 *man/table.dist.Rd
+7c49125e5c9d4fffcfb86bdff089261f *man/table.paint.Rd
+37ea5dccf8b175379d8eb3ccbb4f1117 *man/table.phylog.Rd
+c66f9faac41f71051012371bbce689be *man/table.value.Rd
+5dda2bd3b7a9baec7611872a472320d0 *man/tarentaise.Rd
+49707fd1338711908204bc755bff9b74 *man/taxo.eg.Rd
+a52e54243d7afbe5ede4597a081c7637 *man/testdim.Rd
+b3cd93153416e926605985da603946d0 *man/testdim.multiblock.Rd
+b2f0316d92dcf88369d1e753ade0e054 *man/tintoodiel.Rd
+0873ff2c03cfa3379873314253f90b90 *man/tithonia.Rd
+1234e35f8fdc5cae3b06ff17652f6f78 *man/tortues.Rd
+b5132611cbe8e6b8d1f9ee36f8f45baf *man/toxicity.Rd
+fc6642ac2232b0d4203eac93cea1ff4f *man/triangle.class.Rd
+590a7ba738e054b1f98a3b5d7535f22a *man/triangle.plot.Rd
+072319bb6d874d9cce400f88a83c42a6 *man/trichometeo.Rd
+61e3e37758337d3e63b8bcca82ca659d *man/ungulates.Rd
+77ba948fc7720a971e8c3724e0f0a023 *man/uniquewt.df.Rd
+f297046118e4b628347a9b2ad9dd1f90 *man/variance.phylog.Rd
+637be78a917a156553f111e95c285f0b *man/varipart.Rd
+cc6213d6f392964123af6842b00c7ed3 *man/vegtf.Rd
+ba7ac081a6b0ab9ad0dcd1fe5671a2d5 *man/veuvage.Rd
+2f25eb71ec39a2079827111ce0d8715c *man/wca.rlq.Rd
+c9b8af02f0a4a32ab9e0c3ac301cb0c4 *man/westafrica.Rd
+41ebeb8fbc68607e239d44e0c3bf5240 *man/within.Rd
+fab85936dc68f36c1914d2ca09dc07f1 *man/withincoinertia.Rd
+30c006e5a414bf773a09acbe345addd2 *man/withinpca.Rd
+34b753759df0c097d0fc1dfe64eb06d1 *man/witwit.coa.Rd
+9079945124583c41853266f4a304f761 *man/woangers.Rd
+35411625d5ade47e15a7f7e7fd2cedd7 *man/worksurv.Rd
+b978356bfee2c64f580b00627871d74b *man/yanomama.Rd
+88b146822c115b81b445d9383e1bd791 *man/zealand.Rd
+f009e46fcf131d28ea4ead122961b7bd *src/Makevars
+59abb5710b0205fc3d0eb2eb9e4968fe *src/adesub.c
+8e83ec3b39df34630603252541e3be32 *src/adesub.h
+70502ca4cdafe52d2ee60a011beecfaa *src/divsub.c
+bf3fa1832a9ebe1627b7bb8a57ea5b55 *src/divsub.h
+76b73e7de30910fd7666940f0282643f *src/fourthcorner.c
+ed585e22ef9df65e023b54dc4b6086aa *src/init.c
+e3fec5314fbc54452665e4f36f4c266f *src/phylog.c
+599529f6552210ac430a65607ffcec84 *src/testamova.c
+3e4345a9feeb0a988171bdd8428960bf *src/testdim.c
+e076cea18e7ee8f858376b48061a7fdf *src/testrlq.c
+8a604cec2e96f73cd96c55281b88a466 *src/tests.c
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..dda050b
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,286 @@
+#####################################
+## Load DLL ##
+#####################################
+useDynLib(ade4, .registration = TRUE, .fixes = "C_")
+
+
+#####################################
+## S3 methods ##
+#####################################
+S3method("[","dudi")
+S3method("[","kdist")
+S3method("[","ktab")
+S3method("as.data.frame","kdist")
+S3method("bca","coinertia")
+S3method("bca","dpcoa")
+S3method("bca","dudi")
+S3method("bca","rlq")
+S3method("biplot","dudi")
+S3method("boxplot","acm")
+S3method("c","kdist")
+S3method("c","ktab")
+S3method("col.names<-","ktab")
+S3method("col.names","ktab")
+S3method("inertia","dudi")
+S3method("kplot","foucart")
+S3method("kplot","mcoa")
+S3method("kplot","mfa")
+S3method("kplot","pta")
+S3method("kplot","sepan")
+S3method("kplot","statis")
+S3method("plot","4thcorner")
+S3method("plot","betcoi")
+S3method("plot","betrlq")
+S3method("plot","between")
+S3method("plot","coinertia")
+S3method("plot","corkdist")
+S3method("plot","discrimin")
+S3method("plot","dpcoa")
+S3method("plot","foucart")
+S3method("plot","krandtest")
+S3method("plot","mcoa")
+S3method("plot","mfa")
+S3method("plot","multispati")
+S3method("plot","niche")
+S3method("plot","orthobasis")
+S3method("plot","pcaiv")
+S3method("plot","phylog")
+S3method("plot","procuste")
+S3method("plot","pta")
+S3method("plot","randtest")
+S3method("plot","rlq")
+S3method("plot","sepan")
+S3method("plot","statis")
+S3method("plot","witcoi")
+S3method("plot","within")
+S3method("plot","witrlq")
+S3method("predict","dudi")
+S3method("print","4thcorner")
+S3method("print","amova")
+S3method("print","apqe")
+S3method("print","betcoi")
+S3method("print","betdpcoa")
+S3method("print","betrlq")
+S3method("print","between")
+S3method("print","coinertia")
+S3method("print","corkdist")
+S3method("print","discrimin")
+S3method("print","dpcoa")
+S3method("print","dudi")
+S3method("print","foucart")
+S3method("print","kdist")
+S3method("print","krandboot")
+S3method("print","krandtest")
+S3method("print","krandxval")
+S3method("print","ktab")
+S3method("print","inertia")
+S3method("print","mcoa")
+S3method("print","mfa")
+S3method("print","multiblock")
+S3method("print","multispati")
+S3method("print","neig")
+S3method("print","niche")
+S3method("print","nipals")
+S3method("print","orthobasis")
+S3method("print","pcaiv")
+S3method("print","phylog")
+S3method("print","procuste")
+S3method("print","pta")
+S3method("print","randboot")
+S3method("print","randtest")
+S3method("print","randxval")
+S3method("print","rlq")
+S3method("print","sepan")
+S3method("print","statis")
+S3method("print","witcoi")
+S3method("print","within")
+S3method("print","witrlq")
+S3method("print","witdpcoa")
+S3method("randboot","multiblock")
+S3method("randtest","amova")
+S3method("randtest","betwit")
+S3method("randtest","between")
+S3method("randtest","coinertia")
+S3method("randtest","discrimin")
+S3method("randtest","dpcoa")
+S3method("randtest","pcaiv")
+S3method("randtest","pcaivortho")
+S3method("randtest","procuste")
+S3method("randtest","rlq")
+S3method("reconst","coa")
+S3method("reconst","pca")
+S3method("row.names<-","ktab")
+S3method("row.names","ktab")
+S3method("rtest","between")
+S3method("rtest","discrimin")
+S3method("rtest","niche")
+S3method("scatter","acm")
+S3method("scatter","coa")
+S3method("scatter","dudi")
+S3method("scatter","fca")
+S3method("scatter","nipals")
+S3method("scatter","pco")
+S3method("score","acm")
+S3method("score","coa")
+S3method("score","mix")
+S3method("score","pca")
+S3method("screeplot","dudi")
+S3method("summary","4thcorner")
+S3method("summary","between")
+S3method("summary","betwit")
+S3method("summary","coinertia")
+S3method("summary","corkdist")
+S3method("summary","dist")
+S3method("summary","dpcoa")
+S3method("summary","dudi")
+S3method("summary","mcoa")
+S3method("summary","mfa")
+S3method("summary","inertia")
+S3method("summary","multiblock")
+S3method("summary","multispati")
+S3method("summary","neig")
+S3method("summary","orthobasis")
+S3method("summary","pcaiv")
+S3method("summary","pcaivortho")
+S3method("summary","rlq")
+S3method("summary","sepan")
+S3method("summary","within")
+S3method("summary","witwit")
+S3method("supcol","coa")
+S3method("supcol","dudi")
+S3method("suprow","acm")
+S3method("suprow","coa")
+S3method("suprow","dudi")
+S3method("suprow","mix")
+S3method("suprow","pca")
+S3method("t","dudi")
+S3method("t","ktab")
+S3method("tab.names<-","ktab")
+S3method("tab.names","ktab")
+S3method("testdim","multiblock")
+S3method("testdim","pca")
+S3method("wca","coinertia")
+S3method("wca","dudi")
+S3method("wca","dpcoa")
+S3method("wca","rlq")
+
+
+
+#####################################
+## Import ##
+#####################################
+importFrom("graphics", "abline", "arrows", "axis", "barplot", "box", "boxplot", "frame", "hist", "image", "layout", "lines", "mtext", "par", "plot.default", "plot", "plot.new", "points", "polygon", "rect", "segments", "strheight", "strwidth", "symbols", "text", "title")
+importFrom("grDevices", "chull", "dev.cur", "gray", "grey", "n2mfrow")
+importFrom("stats", "anova", "as.dist", "as.formula", "biplot", "coefficients", "cor", "cov", "cutree", "density", "dist", "dnorm", "hclust", "is.ts", "lm", "lm.wfit", "loess", "model.frame", "model.matrix", "na.omit", "p.adjust", "p.adjust.methods", "pf", "plot.ts", "poly", "ppoints", "predict", "quantile", "residuals", "screeplot", "sd", "symnum", "ts", "ts.union", "var", "weighted.mean")
+importFrom("utils", "modifyList", "read.table", "write.table")
+importFrom("methods", "setOldClass")
+
+
+#####################################
+## Export ##
+#####################################
+
+## ******* diversity *******
+export("amova", "apqe", "disc", "divc", "divcmax", "dpcoa" )
+
+## ******* utilities and misc *******
+export("acm.burt", "acm.disjonctif", "adegraphicsLoaded", "as.krandboot", "as.krandtest", "as.krandxval", "as.randboot", "as.randtest", "as.randxval", "uniquewt.df")
+export("bicenter.wt", "covfacwt", "covwt", "meanfacwt", "scalefacwt", "scalewt", "varfacwt", "varwt")
+
+## ******* dist *******
+export("cailliez", "dist.binary", "dist.ktab", "dist.prop", "dist.quant", "is.euclid", "lingoes", "quasieuclid", "supdist")
+
+## ******* generic *******
+export("bca", "col.names", "col.names<-", "inertia", "kplot", "reconst", "randboot", "randtest", "rtest", "scatter", "score", "supcol", "suprow", "tab.names", "tab.names<-", "testdim", "wca" )
+
+## ******* graphics *******
+export("s.arrow", "s.class", "s.chull", "s.corcircle", "s.distri", "s.hist", "s.image", "s.kde2d", "s.label", "s.logo", "s.match", "s.match.class", "s.multinom", "s.traject", "s.value")
+## export("scatter.acm", "scatter.coa", "scatter.dudi", "scatter.fca", "scatter.nipals", "scatter.pco")
+export("sco.boxplot", "sco.class", "sco.distri", "sco.gauss", "sco.label", "sco.match", "sco.quant")
+## export("score.acm", "score.coa", "score.mix", "score.pca")
+export("add.scatter", "dotcircle")
+export("table.cont", "table.dist", "table.paint", "table.value")
+export("triangle.biplot", "triangle.class", "triangle.plot")
+
+## ******* 1-table methods *******
+export("dudi.acm", "dudi.coa", "dudi.dec", "dudi.fca", "dudi.fpca", "dudi.hillsmith", "dudi.mix", "dudi.nsc", "dudi.pca", "dudi.pco", "pcoscaled", "nipals")
+export("as.dudi", "dist.dudi", "dudi.type","inertia.dudi", "is.dudi", "prep.fuzzy.var", "reciprocal.coa", "redo.dudi")
+
+## ******* 2/3-table methods *******
+export("coinertia", "discrimin", "discrimin.coa", "fourthcorner", "fourthcorner2", "fourthcorner.rlq", "niche", "pcaiv", "pcaivortho", "procuste", "rlq", "varipart", "withinpca", "witwit.coa", "witwitsepan")
+export("combine.4thcorner", "combine.randtest.rlq", "mantel.randtest", "mantel.rtest", "niche.param", "p.adjust.4thcorner", "procuste.randtest", "procuste.rtest", "RVdist.randtest")
+
+## ******* K-table methods *******
+export("costatis", "costatis.randtest", "foucart", "mcoa", "mbpcaiv", "mbpls", "mdpcoa", "mfa", "pta", "sepan", "statico", "statico.krandtest", "statis")
+export("is.ktab", "kdist", "kdist2ktab", "kdist.cor", "kdisteuclid", "kplotX.mdpcoa", "kplotsepan.coa", "ktab.data.frame", "ktab.list.df", "ktab.list.dudi", "ktab.match2ktabs", "ktab.within", "ldist.ktab", "mantelkdist", "prep.binary", "prep.circular", "prep.fuzzy", "prep.mdpcoa", "RVkdist", "RV.rtest")
+
+## ******* genet *******
+export("char2genet", "count2genet", "dist.genet", "freq2genet", "fuzzygenet")
+
+## ******* phylog *******
+export("as.taxo", "dist.taxo", "dotchart.phylog", "enum.phylog", "gearymoran", "hclust2phylog", "newick2phylog", "orthogram", "phylog.extract", "phylog.permut", "PI2newick", "radial.phylog","symbols.phylog", "table.phylog", "taxo2phylog", "variance.phylog")
+export("EH", "randEH", "optimEH", "originality", "orisaved")
+
+## ******* orthobasis *******
+export("haar2level", "mld", "orthobasis.circ", "orthobasis.haar", "orthobasis.line", "orthobasis.mat", "orthobasis.neig", "is.orthobasis")
+
+## ******* spatial *******
+export("area2link", "area2poly", "area.plot", "dist.neig", "gridrowcol", "multispati", "multispati.randtest", "mstree", "multispati.rtest", "nb2neig", "neig", "neig2mat", "neig2nb", "poly2area", "scores.neig")
+
+## ******* misc *********
+export("bwca.dpcoa")
+
+#####################################
+## Not Exported ##
+#####################################
+
+## ******* deprecated *******
+## "between"
+## "betweencoinertia"
+## "within"
+## "withincoinertia"
+
+## ******* internal utilities *******
+
+## Re-export the following functions to avoid the breaking of several other packages (19/11/2013)
+export("add.scatter.eig", "scatterutil.base", "scatterutil.chull", "scatterutil.convrot90", "scatterutil.eigen", "scatterutil.ellipse", "scatterutil.eti", "scatterutil.eti.circ", "scatterutil.grid", "scatterutil.legend.bw.square" , "scatterutil.legendgris", "scatterutil.legend.square.grey", "scatterutil.logo", "scatterutil.scaling", "scatterutil.sco", "scatterutil.star", "scatterutil.sub")
+
+## "add.position.triangle"
+## "add.scatter.eig"
+## "area.util.contour"
+## "area.util.xy"
+## "area.util.class"
+## "fac2disj"
+## "neig.util.GtoL"
+## "neig.util.LtoG"
+## "ktab.util.addfactor"
+## "ktab.util.names"
+## "newick2phylog.addtools"
+## "scatterutil.base"
+## "scatterutil.chull"
+## "scatterutil.convrot90"
+## "scatterutil.eigen"
+## "scatterutil.ellipse"
+## "scatterutil.eti"
+## "scatterutil.eti.circ"
+## "scatterutil.grid"
+## "scatterutil.legend.bw.square"
+## "scatterutil.legendgris"
+## "scatterutil.legend.square.grey"
+## "scatterutil.logo"
+## "scatterutil.scaling"
+## "scatterutil.sco"
+## "scatterutil.star"
+## "scatterutil.sub"
+## "scoreutil.base"
+## "table.prepare"
+## "testdiscrimin"
+## "testertrace"
+## "testertracenu"
+## "testertracenubis"
+## "testertracerlq"
+## "testinter"
+## "testmantel"
+## "testprocuste"
+## "triangle.param"
+## "triangle.posipoint"
diff --git a/R/EH.R b/R/EH.R
new file mode 100644
index 0000000..060b94b
--- /dev/null
+++ b/R/EH.R
@@ -0,0 +1,22 @@
+"EH" <- function(phyl, select = NULL)
+{
+ if (!inherits(phyl, "phylog")) stop("unconvenient phyl")
+ if(is.null(phyl$Wdist)) phyl <- newick2phylog.addtools(phyl)
+ if (is.null(select))
+ return(sum(phyl$leaves) + sum(phyl$nodes))
+ else {
+ if(!is.numeric(select)) stop("unconvenient select")
+ select <- unique(select)
+ nbesp <- length(phyl$leaves)
+ nbselect <- length(select)
+ if(any(is.na(match(select, 1:nbesp)))) stop("unconvenient select")
+ phyl.D <- as.matrix(phyl$Wdist^2 / 2)
+ if(length(select)==1) return(max(phyl.D))
+ if(length(select)==2) return(phyl.D[select[1], select[2]] + max(phyl.D))
+ fun <- function(i) {
+ min(phyl.D[select[i], select[1:(i - 1)]])
+ }
+ res <- phyl.D[select[1], select[2]] + max(phyl.D) + sum(sapply(3:nbselect, fun))
+ return(res)
+ }
+}
diff --git a/R/PI2newick.R b/R/PI2newick.R
new file mode 100644
index 0000000..7fad7cd
--- /dev/null
+++ b/R/PI2newick.R
@@ -0,0 +1,64 @@
+"PI2newick" <- function(x){
+# cette fonction permet de convertir les fichiers d'entrée du logiciel PI
+# d'Abouheif au format newick (on récupère également les valeurs associées
+# aux feuilles)
+# x est une matrice qui vient de la lecture des fichiers .txt: x <- read.table("PI1.txt", h = FALSE)
+# il a autant de lignes qu'il y a de feuilles-1; dans le cas d'une phylogénie résolue, c'est le nombre de noeuds
+# il y a 6 colonnes: Contrast value/ Left tip value/ Right tip value/ Left node name/ Right node name/ Unresolved nodes group
+
+# on prépare le terrain
+nodes.group <- as.factor(x[, 6])
+x <- x[, -c(1,6)]
+x[,c(3,4)] <-x[,c(3,4)] + 1
+x[x == -99] <- 0
+nleaves <- nrow(x) + 1
+nnodes <- sum(nodes.group==0)+length(levels(nodes.group))-1
+
+# on récuupère les valeurs associées aux feuilles
+values <- as.vector(t(as.matrix(x[,c(1,2)])))
+values <- values[values!=0]
+for (i in 1:nleaves)
+ x[x==values[i]] <- i
+#print(x)
+
+# on construit la chaine de charactère au format newick
+names(x) <- c("Ext", "Ext", "I", "I")
+tre <- NULL
+if (nodes.group[1]==0){
+ u <- x[1,]
+ v <- names(x)[u!=0]
+ w <- u[u!=0]
+ u <- paste(v, w, sep="")
+ tre <- paste("(", u[1], ",", u[2], ")Root;", sep="")
+ }
+ else
+ stop("the Root must be resolved: will be programmed later") # le cas ou il y a plusieurs feuilles et un noeud reste à faire
+j <- 2
+for (i in 2:nnodes){
+ if (nodes.group[j]==0){
+ u <- x[j,]
+ v <- names(x)[u!=0]
+ w <- u[u!=0]
+ u <- paste(v, w, sep="")
+ u <- paste("(", u[1], ",", u[2], ")", paste("I", i,sep=""), sep="")
+ tre <- gsub(paste("I", j,sep=""), u, tre)
+ j <- j + 1
+ }
+ else{
+ u <- nodes.group[j]
+ v <- sum(nodes.group==u)
+ w <- x[j:(j+v-1), 1:2]
+ w <- as.vector(as.matrix(w))
+ w <- w[w!=0]
+ w <- sort(w)
+ y <- paste(rep("Ext", v+1), w, sep="")
+ z <- y[1]
+ for (i in 2:(v+1)) z <- paste(z, y[i], sep=",")
+ z <- paste("(", z, ")", paste("I", j,sep=""), sep="")
+ tre <- gsub(paste("I", j,sep=""), z, tre)
+ j <- j + v
+ }
+ }
+
+return(list(tre = tre, trait = values))
+}
diff --git a/R/RV.rtest.R b/R/RV.rtest.R
new file mode 100644
index 0000000..79716ad
--- /dev/null
+++ b/R/RV.rtest.R
@@ -0,0 +1,25 @@
+"RV.rtest" <- function (df1, df2, nrepet = 99, ...) {
+ if (!is.data.frame(df1))
+ stop("data.frame expected")
+ if (!is.data.frame(df2))
+ stop("data.frame expected")
+ l1 <- nrow(df1)
+ if (nrow(df2) != l1)
+ stop("Row numbers are different")
+ if (any(row.names(df2) != row.names(df1)))
+ stop("row names are different")
+ X <- scale(df1, scale = FALSE)
+ Y <- scale(df2, scale = FALSE)
+ X <- X/(sum(svd(X)$d^4)^0.25)
+ Y <- Y/(sum(svd(Y)$d^4)^0.25)
+ X <- as.matrix(X)
+ Y <- as.matrix(Y)
+ obs <- sum(svd(t(X) %*% Y)$d^2)
+ if (nrepet == 0)
+ return(obs)
+ perm <- matrix(0, nrow = nrepet, ncol = 1)
+ perm <- apply(perm, 1, function(x) sum(svd(t(X) %*% Y[sample(l1),
+ ])$d^2))
+ w <- as.randtest(obs = obs, sim = perm, call = match.call(), ...)
+ return(w)
+}
diff --git a/R/RVdist.randtest.R b/R/RVdist.randtest.R
new file mode 100644
index 0000000..c310b1b
--- /dev/null
+++ b/R/RVdist.randtest.R
@@ -0,0 +1,18 @@
+"RVdist.randtest" <- function (m1, m2, nrepet=999, ...) {
+ if (!inherits(m1, "dist"))
+ stop("Object of class 'dist' expected")
+ if (!inherits(m2, "dist"))
+ stop("Object of class 'dist' expected")
+ if (!is.euclid(m1)) stop ("Euclidean matrices expected")
+ if (!is.euclid(m2)) stop ("Euclidean matrices expected")
+ n <- attr(m1, "Size")
+ if (n != attr(m2, "Size"))
+ stop("Non convenient dimension")
+ m1 <- as.matrix(m1)
+ m2 <- as.matrix(m2)
+ res <- .C("testdistRV", as.integer(nrepet), as.integer (n), as.double(m1),
+ as.double(m2), RV=double(nrepet+1),PACKAGE="ade4")$RV
+ obs=res[1]
+ return(as.randtest(sim = res[-1], obs = obs, call = match.call(), ...))
+}
+
diff --git a/R/add.scatter.R b/R/add.scatter.R
new file mode 100644
index 0000000..fa10c30
--- /dev/null
+++ b/R/add.scatter.R
@@ -0,0 +1,90 @@
+######################################################
+# Function to add sub-graphics to an existing plot
+# Thibaut Jombart 2007
+# (t.jombart at imperial.ac.uk)
+######################################################
+
+# Note: this function uses par("plt"), which interacts with other par()
+# otions
+# When addgraph is used with a function which uses par(), it is safer to
+# add along other options: par([other options],plt=par("plt"))
+
+#######################
+# Function add.scatter
+#######################
+add.scatter <- function(func,posi=c("bottomleft","bottomright","topleft","topright"),ratio=.2,inset=.01,bg.col='white'){
+
+ if(tolower(posi[1])=="none") return()
+
+ if(ratio>.99) ratio <- .99
+ if(ratio<0) ratio <- .2
+
+ # set inset in x and y
+ if(length(inset)==2) {
+ inset.x <- inset[1]
+ inset.y <- inset[2]
+ } else{
+ inset.x <- inset[1]
+ inset.y <- inset[1]
+ }
+
+ inset[inset<0] <- 0
+
+ plotreg0 <- par('plt')
+ plotreg <- plotreg0 + c(inset.x,-inset.x,inset.y,-inset.y)
+
+ # restore full plot region and previous graphic parameters on exit
+ on.exit(par(plt=plotreg0))
+
+ # handle position
+ # "top" and "bottom" are considered as "topleft" and "bottomleft"
+ posi <- tolower(posi[1])
+
+ if(posi=="bottomleft" || posi=="bottom") {
+ x1 <- plotreg[1]
+ y1 <- plotreg[3]
+ }else if(posi=="topleft" || posi=="top") {
+ x1 <- plotreg[1]
+ y1 <- plotreg[4]-ratio
+ }else if(posi=="bottomright") {
+ x1 <- plotreg[2]-ratio
+ y1 <- plotreg[3]
+ }else if(posi=="topright") {
+ x1 <- plotreg[2]-ratio
+ y1 <- plotreg[4]-ratio
+ }else stop("Unknown position required")
+
+ x2 <- x1+ratio
+ y2 <- y1+ratio
+
+ # clean subplot region
+ par(plt=c(x1,x2,y1,y2),new=TRUE)
+ plot.new()
+ polygon(c(-0.1, 1.1, 1.1, -0.1), c(-0.1, -0.1, 1.1, 1.1), border = NA, col = bg.col)
+
+ # draw the subplot
+ # beware: if func uses par, it must specify "par(...,plt=par("plt",...)"
+ # (due to weired par interaction, e.g. with par(mar))
+ par(plt=c(x1,x2,y1,y2),new=TRUE)
+ eval(func)
+
+ return(invisible(match.call()))
+
+} # end add.scatter
+
+
+###########################
+# Function add.scatter.eig
+###########################
+"add.scatter.eig" <- function (w, nf=NULL, xax, yax, posi = "bottomleft", ratio = .25, inset = .01, sub="Eigenvalues",csub=2*ratio){
+ opar <- par("mar","xaxt","yaxt")
+ on.exit(par(opar))
+ par(mar=rep(.1,4),xaxt="n",yaxt="n")
+
+ fgraph <- function(){
+ scatterutil.eigen(w, nf=nf, wsel=c(xax,yax), sub=sub, csub=csub, box=TRUE)
+ }
+
+ add.scatter( fgraph(), posi=posi, ratio=ratio, inset=inset)
+
+} # end add.scatter.eig
diff --git a/R/amova.R b/R/amova.R
new file mode 100644
index 0000000..cdc4705
--- /dev/null
+++ b/R/amova.R
@@ -0,0 +1,217 @@
+amova <- function(samples, distances = NULL, structures = NULL) {
+ # checking of user's data and initialization.
+ if (!inherits(samples, "data.frame")) stop("Non convenient samples")
+ if (any(samples < 0)) stop("Negative value in samples")
+ nhap <- nrow(samples) ;
+ if (!is.null(distances)) {
+ if (!inherits(distances, "dist")) stop("Object of class 'dist' expected for distances")
+ if (!is.euclid(distances)) stop("Euclidean property is expected for distances")
+ distances <- as.matrix(distances)^2
+ if (nrow(samples)!= nrow(distances)) stop("Non convenient samples")
+ }
+ if (is.null(distances)) distances <- (matrix(1, nhap, nhap) - diag(rep(1, nhap))) * 2
+ if (!is.null(structures)) {
+ if (!inherits(structures, "data.frame")) stop("Non convenient structures")
+ m <- match(apply(structures, 2, function(x) length(x)), ncol(samples), 0)
+ if (length(m[m == 1]) != ncol(structures)) stop("Non convenient structures")
+ m <- match(tapply(1:ncol(structures), as.factor(1:ncol(structures)), function(x) is.factor(structures[, x])), TRUE , 0)
+ if (length(m[m == 1]) != ncol(structures)) stop("Non convenient structures")
+ }
+ # intern functions (computations of the sums of squares and mean squares) :
+ #Diversity <- function(d2, nbhaplotypes, freq) {
+ # diversity index according to Rao s quadratic entropy
+ # div <- nbhaplotypes / 2 * (t(freq) %*% d2 %*% freq)
+ # return(div)
+ #}
+ Ssd.util <- function(dp2, Np, unit) {
+ # Deductions of the distances between two groups.
+ # Deductions of the weight and composition of a group.
+ if (!is.null(unit)) {
+ modunit <- model.matrix(~ -1 + unit)
+ sumcol <- apply(Np, 2, sum)
+ Ng <- modunit * sumcol
+ lesnoms <- levels(unit)
+ }
+ else {
+ Ng <- as.matrix(Np)
+ lesnoms <- colnames(Np)
+ }
+ sumcol <- apply(Ng, 2, sum)
+ Lg <- t(t(Ng)/sumcol)
+ colnames(Lg) <- lesnoms
+ Pg <- as.matrix(apply(Ng, 2, sum) / nbhaplotypes)
+ rownames(Pg) <- lesnoms
+ deltag <- as.matrix(apply(Lg, 2, function(x) t(x) %*% dp2 %*% x))
+ ug <- matrix(1, ncol(Lg), 1)
+ dg2 <- t(Lg) %*% dp2 %*% Lg - 1 / 2 * (deltag %*% t(ug) + ug %*% t(deltag))
+ colnames(dg2) <- lesnoms
+ rownames(dg2) <- lesnoms
+ return(list(dg2 = dg2, Ng = Ng, Pg = Pg))
+ }
+ Ssd <- function(distances, nbhaplotypes, samples, structures) {
+ # Computation of the sum of squared deviation.
+ Ph <- as.matrix(apply(samples, 1, sum) / nbhaplotypes)
+ ssdt <- nbhaplotypes / 2 * t(Ph) %*% distances %*% Ph
+ ssdutil <- list(0)
+ ssdutil[[1]] <- Ssd.util(dp2 = distances, Np = samples, NULL)
+ if (!is.null(structures)) {
+ for (i in 1:length(structures)) {
+ if (i != 1) {
+ unit <- structures[(1:length(structures[, i])) [!duplicated(structures[, i - 1])], i]
+ unit <- factor(unit, levels = unique(unit))
+ }
+ else unit <- factor(structures[, i], levels = unique(structures[, i]))
+ ssdutil[[i + 1]] <- Ssd.util(ssdutil[[i]]$dg2, ssdutil[[i]]$Ng, unit)
+ }
+ }
+ diversity <- c(ssdt, unlist(lapply(ssdutil, function(x) nbhaplotypes / 2 * t(x$Pg) %*% x$dg2 %*% x$Pg)))
+ diversity2 <- c(diversity[-1], 0)
+ ssdtemp <- diversity - diversity2
+ ssd <- c(ssdtemp[length(ssdtemp):1], ssdt)
+ return(ssd)
+ }
+ Nbunits <- function(structures2) {
+ # nb of units in each levels.
+ return(apply(structures2, 2, function(x) length(levels(as.factor(x)))))
+ }
+ Ddl <- function(nbunits, nbhaplotypes) {
+ # degrees of freedom.
+ ddl1 <- c(nbunits, nbhaplotypes, nbhaplotypes)
+ ddl2 <- c(1, nbunits, 1)
+ ddl <- ddl1 - ddl2
+ return(as.vector(ddl))
+ }
+ N <- function(structures, samples, nbhaplotypes, ddl) {
+ # n values.
+ nbind1temp <- apply(samples, 2, sum)
+ nbind1 <- rep(nbind1temp, nbind1temp)
+ nbhapl <- rep(nbhaplotypes, nbhaplotypes)
+ if (!is.null(structures)) {
+ nbind <- lapply(as.list(structures), function(x) tapply(nbind1temp, x, sum)[as.numeric(x)])
+ nbind <- lapply(nbind, function(x) rep(x, nbind1temp))
+ nbind <- c(list(nbhapl), nbind[length(nbind):1], list(nbind1))
+ }
+ else nbind <- c(list(nbhapl), list(nbind1))
+ n1 <- as.vector(tapply((2:length(nbind)), as.factor(2:length(nbind)), function(x) (nbhaplotypes - (sum((nbind[[x]]) / nbind[[x-1]])))))
+ ddlutil <- ddl[(length(ddl) - 2):1]
+ if (!is.null(structures)) {
+ N2 <- function(x) {
+ tapply((x + 1):length(nbind), as.factor((x + 1):length(nbind)), function(i) sum(nbind[[i]] * (1 / nbind[[x]] - 1 / nbind[[x - 1]])))
+ }
+ n <- rep(0, sum(1:(dim(structures)[2] + 1)))
+ n1 <- n1[length(n1):1]
+ n[cumsum(1:(dim(structures)[2] + 1))] <- n1
+ if ((length(nbind) - 1) >= 2) {
+ n2 <- as.vector(unlist(tapply(2:(length(nbind) - 1), as.factor(2:(length(nbind) - 1)), N2)))
+ n2 <- n2[length(n2):1]
+ n[-(cumsum(1:(dim(structures)[2] + 1)))] <- n2
+ }
+ ddlutil <- ddlutil[rep(1:(dim(structures)[2] + 1), 1:(dim(structures)[2] + 1))]
+ }
+ else n <- n1
+ n <- n / ddlutil
+ return(n)
+ }
+ Cm <- function(ssd, ddl) {
+ # mean squares.
+ return(c(ssd / ddl))
+ }
+ Sigma <- function(cm, n) {
+ # covariance components.
+ cmutil <- cm[(length(cm) - 1):1]
+ sigma2W <- cmutil[1]
+ res <- rep(0, length(cm) - 1)
+ res[1] <- sigma2W
+ res[2] <- (cmutil[2] - sigma2W) / n[1]
+ if (length(res) > 2) {
+ for (i in 3:(length(cm) - 1)) {
+ index <- cumsum(c(2, (2:(length(cm) - 1))))
+ ni <- n[index[i - 2]:(index[i - 1] - 2)]
+ nj <- n[index[i - 1] - 1]
+ si <- ni * res[2:(i - 1)]
+ res[i] <- (cmutil[i] - sigma2W - sum(si)) / nj
+ }
+ }
+ sigma2t <- sum(res)
+ return(c(res[length(res):1], sigma2t))
+ }
+ Pourcent <- function(sigma) {
+ # covariance percentages.
+ return(sigma / sigma[length(sigma)] * 100)
+ }
+ Procedure <- function(distances, nbhaplotypes, samples, structures, ddl) {
+ ssd <- Ssd(distances, nbhaplotypes, samples, structures)
+ cm <- Cm(ssd, ddl)
+ n <- N(structures, samples, nbhaplotypes, ddl)
+ sigma <- Sigma(cm, n)
+ return(list(ssd = ssd, cm = cm, sigma = sigma, n = n))
+ }
+ Statphi <- function(sigma) {
+ # Phi-statistics.
+ f <- rep(0, length(sigma) - 1)
+ if (length(sigma) == 3) {
+ f <- rep(0, 1)
+ }
+ f[1] <- (sigma[length(sigma)] - sigma[length(sigma) - 1]) / sigma[length(sigma)]
+ if (length(f) > 1) {
+ s1 <- cumsum(sigma[(length(sigma) - 1):2])[-1]
+ s2 <- sigma[(length(sigma) - 2):2]
+ f[length(f)] <- sigma[1] / sigma[length(sigma)]
+ f[2:(length(f) - 1)] <- s2 / s1
+ }
+ return(f)
+ }
+ # main procedure.
+ nbhaplotypes <- sum(samples)
+ if (!is.null(structures)) {
+ structures2 <- cbind.data.frame(structures[length(structures):1], as.factor(colnames(samples, do.NULL = FALSE)))
+ }
+ else structures2 <- as.data.frame(as.factor(colnames(samples, do.NULL = FALSE)))
+ nbunits <- Nbunits(structures2)
+ ddl <- Ddl(nbunits, nbhaplotypes)
+ proc <- Procedure(distances, nbhaplotypes, samples, structures, ddl)
+ ssd <- proc$ssd
+ cm <- proc$cm
+ sigma <- proc$sigma
+
+ # Interface.
+ if (!is.null(structures)) {
+ lesnoms1 <- rep("Between", ncol(structures) + 1)
+ lesnoms2 <- c(names(structures)[ncol(structures):1], "samples")
+ lesnoms3 <- c("", rep("Within", ncol(structures)))
+ lesnoms4 <- c("", names(structures)[ncol(structures):1])
+ lesnoms <- c(paste(lesnoms1, lesnoms2, lesnoms3, lesnoms4), "Within samples", "Total")
+ }
+ else lesnoms <- c("Between samples", "Within samples", "Total")
+ pourcent <- Pourcent(sigma)
+ results <- data.frame(ddl, ssd, cm)
+ names(results) <- c("Df", "Sum Sq", "Mean Sq")
+ rownames(results) <- lesnoms
+ sourceofvariation <- c(paste("Variations ", rownames(results)[1:(nrow(results) - 1)]), "Total variations")
+ componentsofcovariance <- data.frame(sigma, pourcent)
+ names(componentsofcovariance) <- c("Sigma", "%")
+ rownames(componentsofcovariance) <- sourceofvariation
+ call <- match.call()
+ res <- list(call = call, results = results, componentsofcovariance = componentsofcovariance, distances = as.dist(distances), samples = samples, structures = structures)
+ f <- Statphi(sigma)
+ statphi <- as.data.frame(f)
+ names(statphi) <- "Phi"
+ lesnoms1 <- c(rep("Phi", length(f)))
+ if (length(f) == 1) {
+ lesnoms2 <- c("samples")
+ lesnoms3 <- c("total")
+ }
+ else {
+ lesnoms2 <- c(rep("samples", 2), names(structures))
+ lesnoms3 <- c("total", names(structures), "total")
+ }
+ rownames(statphi) <- paste(lesnoms1, lesnoms2, lesnoms3, sep = "-")
+ res <- list(call = call, results = results, componentsofcovariance = componentsofcovariance, statphi = statphi, distances = as.dist(distances), samples = samples, structures = structures)
+ class(res) <- "amova"
+ return(res)
+}
+
+print.amova <- function(x, full = FALSE, ...) {
+ if (full == TRUE) print(x)
+ else print(x[-((length(x) - 2):length(x))])
+}
diff --git a/R/apqe.R b/R/apqe.R
new file mode 100644
index 0000000..3413ddd
--- /dev/null
+++ b/R/apqe.R
@@ -0,0 +1,100 @@
+apqe <- function(samples, dis = NULL, structures = NULL){
+
+ # checking of user's data and initialization.
+ if (!inherits(samples, "data.frame")) stop("Non convenient samples")
+
+ if (any(as.matrix(samples) <= -1e-8)) stop("Negative value in samples")
+
+ nhap <- nrow(samples) ; nsam <- ncol(samples)
+
+ if (!is.null(dis)) {
+ if (!inherits(dis, "dist")) stop("Object of class 'dist' expected for distance")
+ if (!is.euclid(dis)) stop("Euclidean property is expected for distance")
+ dis <- as.matrix(dis)^2
+ if (nrow(samples)!= nrow(dis)) stop("Non convenient samples")
+ }
+ if (is.null(dis)) dis <- (matrix(1, nhap, nhap) - diag(rep(1, nhap))) * 2
+ if (!is.null(structures)) {
+ if (!inherits(structures, "data.frame")) stop("Non convenient structures")
+ m <- match(apply(structures, 2, function(x) length(x)), ncol(samples), 0)
+ if (length(m[m == 1]) != ncol(structures)) stop("Non convenient structures")
+ m <- match(tapply(1:ncol(structures), as.factor(1:ncol(structures)), function(x) is.factor(structures[, x])), TRUE , 0)
+ if (length(m[m == 1]) != ncol(structures)) stop("Non convenient structures")
+ }
+ # intern functions (computations of the sums of squares and mean squares):
+ Diversity <- function(d2, nbhaplotypes, freq){
+ # diversity index according to Rao s quadratic entropy
+ div <- nbhaplotypes / 2 * (t(freq) %*% d2 %*% freq)
+ }
+ Ssd.util <- function(dp2, Np, unit){
+ # Dissimilarity between two groups. Weight and composition of a group.
+ if (!is.null(unit)) {
+ modunit <- model.matrix(~ -1 + unit)
+ sumcol <- apply(Np, 2, sum)
+ Ng <- modunit * sumcol
+ lesnoms <- levels(unit)
+ }
+ else{
+ Ng <- as.matrix(Np)
+ lesnoms <- colnames(Np)
+ }
+ sumcol <- apply(Ng, 2, sum)
+ Lg <- t(t(Ng) / sumcol)
+ colnames(Lg) <- lesnoms
+ Pg <- as.matrix(apply(Ng, 2, sum) / nbhaplotypes)
+ rownames(Pg) <- lesnoms
+ deltag <- as.matrix(apply(Lg, 2, function(x) t(x) %*% dp2 %*% x))
+ ug <- matrix(1, ncol(Lg), 1)
+ dg2 <- t(Lg) %*% dp2 %*% Lg - 1 / 2 * (deltag %*% t(ug) + ug %*% t(deltag))
+ colnames(dg2) <- lesnoms
+ rownames(dg2) <- lesnoms
+ return(list(dg2 = dg2, Ng = Ng, Pg = Pg))
+ }
+ Ssd <- function(dis, nbhaplotypes, samples, structures) {
+ # Computation of the sum of squared deviation.
+ Ph <- as.matrix(apply(samples, 1, sum) / nbhaplotypes)
+ ssdt <- nbhaplotypes / 2 * t(Ph) %*% dis %*% Ph
+ ssdutil <- list(0)
+ ssdutil[[1]] <- Ssd.util(dp2 = dis, Np = samples, NULL)
+ if (!is.null(structures)) {
+ for (i in 1:length(structures)) {
+ if (i != 1) {
+ unit <- structures[(1:length(structures[, i]))[!duplicated(structures[, i - 1])], i]
+ unit <- factor(unit, levels = unique(unit))
+ }
+ else unit <- factor(structures[, i], levels = unique(structures[, i]))
+ ssdutil[[i + 1]] <- Ssd.util(ssdutil[[i]]$dg2, ssdutil[[i]]$Ng, unit)
+ }
+ }
+ diversity <- c(ssdt, unlist(lapply(ssdutil, function(x) nbhaplotypes / 2 * t(x$Pg) %*% x$dg2 %*% x$Pg)))
+ diversity2 <- c(diversity[-1], 0)
+ ssdtemp <- diversity - diversity2
+ ssd <- c(ssdtemp[length(ssdtemp):1], ssdt)
+ return(ssd)
+ }
+ # main procedure.
+ nbhaplotypes <- sum(samples)
+ ssd <- Ssd(dis, nbhaplotypes, samples, structures) / nbhaplotypes
+ # Interface.
+ if (!is.null(structures)) {
+ lesnoms1 <- rep("Between", ncol(structures) + 1)
+ lesnoms2 <- c(names(structures)[ncol(structures):1], "samples")
+ lesnoms3 <- c("", rep("Within", ncol(structures)))
+ lesnoms4 <- c("", names(structures)[ncol(structures):1])
+ lesnoms <- c(paste(lesnoms1, lesnoms2, lesnoms3, lesnoms4), "Within samples", "Total")
+ }
+ else lesnoms <- c("Between samples", "Within samples", "Total")
+ results <- data.frame(ssd)
+ names(results) <- c("diversity")
+ rownames(results) <- lesnoms
+ sourceofvariation <- c(paste("Variations ", rownames(results)[1:(nrow(results) - 1)]), "Total variations")
+ call <- match.call()
+ res <- list(call = call, results = results, dis = as.dist(dis), samples = samples, structures = structures)
+ class(res) <- "apqe"
+ return(res)
+}
+
+print.apqe <- function(x, full = FALSE, ...){
+ if (full == TRUE) print(x)
+ else print(x[-((length(x) - 2):length(x))])
+}
diff --git a/R/area.plot.R b/R/area.plot.R
new file mode 100644
index 0000000..9970eed
--- /dev/null
+++ b/R/area.plot.R
@@ -0,0 +1,277 @@
+########### area.plot ################
+########### area.util.contour ################
+########### area.util.xy ################
+########### area2poly ################
+########### poly2area ################
+########### area2link ################
+########### area.util.class ################
+
+"area.plot" <- function (x, center= NULL, values = NULL, graph = NULL, lwdgraph = 2, nclasslegend = 8,
+ clegend = 0.75, sub = "", csub = 1, possub = "topleft", cpoint = 0,
+ label = NULL, clabel = 0, ...)
+{
+ # modif vendredi, mars 28, 2003 at 07:35 ajout de l'argument center
+ # doit contenir les centres des polygones (autant de coordonnées que de classes dans area[,1])
+ # si il est nul et utilisé il est calculé comme centre de gravité des sommets du polygones
+ # avec area.util.xy(x)
+ # si il est non nul, doit être de dimensions (nombre de niveaux de x[,1] , 2) et
+ # contenir les coordonnées dans l'ordre de unique(x[,1])
+ x.area <- x
+ if(dev.cur() == 1) plot.new()
+ opar <- par(mar = par("mar")) #, new = par("new")
+ on.exit(par(opar))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ if (!is.factor(x.area[, 1]))
+ stop("Factor expected in x.area[1,]")
+ fac <- x.area[, 1]
+ lev.poly <- unique(fac)
+ nlev <- nlevels(lev.poly)
+ x1 <- x.area[, 2]
+ x2 <- x.area[, 3]
+ r1 <- range(x1)
+ r2 <- range(x2)
+ plot(r1, r2, type = "n", asp = 1, xlab = "", ylab = "", xaxt = "n",
+ yaxt = "n", frame.plot = FALSE)
+ if (!is.null(values)) {
+ if (!is.vector(values))
+ values <- as.vector(values)
+ if (length(values) != nlev)
+ values <- rep(values, le = nlev)
+ br0 <- pretty(values, nclasslegend - 1)
+ nborn <- length(br0)
+ h <- diff(range(x1))/20
+ numclass <- cut.default(values, br0, include.lowest = TRUE,
+ labels = FALSE, right = TRUE)
+ valgris <- seq(1, 0, le = (nborn - 1))
+ }
+ if (!is.null(graph)) {
+ if (class(graph) != "neig")
+ stop("graph need an object of class 'ng'")
+ }
+ if (cpoint != 0)
+ points(x1, x2, pch = 20, cex = par("cex") * cpoint)
+ for (i in 1:nlev) {
+ a1 <- x1[fac == lev.poly[i]]
+ a2 <- x2[fac == lev.poly[i]]
+ if (!is.null(values))
+ polygon(a1, a2, col = grey(valgris[numclass[i]]))
+ else polygon(a1, a2)
+ }
+ if (!is.null(graph) | (clabel > 0)) {
+ if (!is.null(center)) {
+ center = as.matrix(center)
+ if (ncol(center)!=2) center <- NULL
+ if (nrow(center)!=length(lev.poly)) center <-NULL
+ }
+ if (!is.null(center)) w=list(x=center[,1],y=center[,2]) else
+ w <- area.util.xy(x.area)
+ }
+ if (!is.null(graph)) {
+ for (i in 1:nrow(graph)) {
+ segments(w$x[graph[i, 1]], w$y[graph[i, 1]], w$x[graph[i,
+ 2]], w$y[graph[i, 2]], lwd = lwdgraph)
+ }
+ }
+ if (clabel > 0) {
+ if (is.null(label))
+ label <- as.character(unique(x.area[,1]))
+ scatterutil.eti(w$x, w$y, label, clabel = clabel)
+ }
+ scatterutil.sub(sub, csub, possub)
+ if (!is.null(values))
+ scatterutil.legend.square.grey(br0, valgris, h, clegend)
+}
+
+"area.util.contour" <- function (area) {
+ poly <- area[, 1]
+ x <- area[, 2]
+ y <- area[, 3]
+ res <- NULL
+ f1 <- function(x) {
+ if (x[1] > x[3]) {
+ s <- x[1]
+ x[1] <- x[3]
+ x[3] <- s
+ s <- x[2]
+ x[2] <- x[4]
+ x[4] <- s
+ }
+ if (x[1] == x[3]) {
+ if (x[2] > x[4]) {
+ s <- x[2]
+ x[2] <- x[4]
+ x[4] <- s
+ }
+ }
+ return(paste(x[1], x[2], x[3], x[4], sep = "A"))
+ }
+ for (i in 1:(nlevels(poly))) {
+ xx <- x[poly == levels(poly)[i]]
+ yy <- y[poly == levels(poly)[i]]
+ n0 <- length(xx)
+ xx <- c(xx, xx[1])
+ yy <- c(yy, yy[1])
+ z <- cbind(xx[1:n0], yy[1:n0], xx[2:(n0 + 1)], yy[2:(n0 +
+ 1)])
+ z <- apply(z, 1, f1)
+ res <- c(res, z)
+ }
+ res <- res[table(res)[res] < 2]
+ res <- unlist(lapply(res, function(x) as.numeric(unlist(strsplit(x,
+ "A")))))
+ res <- matrix(res, ncol = 4, byrow = TRUE)
+ res <- data.frame(res)
+ names(res) <- c("x1", "y1", "x2", "y2")
+ return(res)
+}
+
+"area.util.xy" <- function (area) {
+ fac <- area[, 1]
+ lev.poly <- unique(fac)
+ npoly <- length(lev.poly)
+ x <- rep(0, npoly)
+ y <- rep(0, npoly)
+ for (i in 1:npoly) {
+ lev <- lev.poly[i]
+ a1 <- area[fac == lev, 2]
+ a2 <- area[fac == lev, 3]
+ x[i] <- mean(a1)
+ y[i] <- mean(a2)
+ }
+ cbind.data.frame(x = x, y = y, row.names = as.character(lev.poly))
+}
+
+"area2poly" <- function (area) {
+ if (!is.factor(area[, 1]))
+ stop("Factor expected in area[,1]")
+ fac <- area[, 1]
+ lev.poly <- unique(fac)
+ nlev <- nlevels(lev.poly)
+ label.poly <- as.character(lev.poly)
+ x1 <- area[, 2]
+ x2 <- area[, 3]
+ res <- list()
+ for (i in 1:nlev) {
+ a1 <- x1[fac == lev.poly[i]]
+ a2 <- x2[fac == lev.poly[i]]
+ res <- c(res, list(as.matrix(cbind(a1, a2))))
+ attr(res[[i]],"bbox") <- c(min(res[[i]][,1]),min(res[[i]][,2]),max(res[[i]][,1]),max(res[[i]][,2]))
+ }
+ r0 <- matrix(0, nlev, 4)
+ r0[, 1] <- tapply(x1, fac, min)
+ r0[, 2] <- tapply(x2, fac, min)
+ r0[, 3] <- tapply(x1, fac, max)
+ r0[, 4] <- tapply(x2, fac, max)
+ class(res) <- "polylist"
+ attr(res, "region.id") <- label.poly
+ attr(res, "region.rect") <- r0
+ # message de Stéphane Dray du 06/02/2004
+ attr(res,"maplim") <- list(x=range(x1),y=range(x2))
+ return(res)
+}
+
+"poly2area" <- function (polys) {
+ if (!inherits(polys, "polylist"))
+ stop("Non convenient data")
+ if (!is.null(attr(polys, "region.id")))
+ reg.names <- attr(polys, "region.id")
+ else reg.names <- paste("R", 1:length(polys), sep = "")
+ area <- data.frame(polys[[1]])
+ area <- cbind(rep(reg.names[1], nrow(area)), area)
+ names(area) <- c("reg", "x", "y")
+ for (i in 2:length(polys)) {
+ provi <- data.frame(polys[[i]])
+ provi <- cbind(rep(reg.names[i], nrow(provi)), provi)
+ names(provi) <- c("reg", "x", "y")
+ area <- rbind.data.frame(area, provi)
+ }
+ area$reg <- factor(area$reg)
+ return(area)
+}
+
+"area2link" <- function(area) {
+ # création vendredi, mars 28, 2003 at 14:49
+ if (!is.factor(area[, 1]))
+ stop("Factor expected in area[,1]")
+ fac <- area[, 1]
+ levpoly <- unique(fac)
+ npoly <- length(levpoly)
+ res <- matrix(0,npoly,npoly)
+ dimnames(res) <- list(as.character(levpoly),as.character(levpoly))
+ fun1 <- function(niv) {
+ # X est un n-2 système de coordonnées xy
+ # On vérifie que c'est une boucle (sommaire)
+ X <- area[fac == niv, 2:3]
+ n <- nrow(X)
+ if (any(X[1,]!=X[n,])) X <- rbind(X,X[1,])
+ n <- nrow(X)
+ w <- paste(X[1:(n-1),1],X[1:(n-1),2],X[2:(n),1],X[2:(n),2],sep="/")
+ w <- c(w,paste(X[2:(n),1],X[2:(n),2],X[1:(n-1),1],X[1:(n-1),2],sep="/"))
+ }
+ w <- lapply(levpoly,fun1)
+ # w est une liste de vecteurs qui donnent les arêtes des polygones en charactères
+ # du type x1/y1/x2/y2
+ fun2 <- function (cha) {
+ w <- as.numeric(strsplit(cha,"/")[[1]])
+ res <- sqrt((w[1]-w[3])^2+(w[2]-w[4])^2)
+ res
+ }
+ res <- matrix(0,npoly,npoly)
+ x1 <- col(res)[col(res) < row(res)]
+ x2 <- row(res)[col(res) < row(res)]
+ lw <- cbind(x1,x2)
+ fun3 <- function (x) {
+ a <- w[[x[1]]]
+ b <- w[[x[2]]]
+ wd <- 0
+ wab <- unlist(lapply(a, function(x) x%in%b))
+ if (sum(wab)>0) wd <- sum(unlist(lapply(a[wab], fun2)))
+ wd/2
+ }
+ w <- apply(lw,1,fun3)
+ res[col(res) < row(res) ] <- w
+ res <- res+t(res)
+ dimnames(res) <- list(as.character(levpoly),as.character(levpoly))
+ return(res)
+}
+
+"area.util.class" <- function (area,fac) {
+ if (nlevels(area[,1]!= length(fac))) stop ("non convenient matching")
+ lreg <- split (as.character(unique(area[,1])),fac)
+ "contour2poly" <- function(x) {
+ a <- paste(x[,1],x[,2],sep="_")
+ b <- paste(x[,3],x[,4],sep="_")
+ a <- cbind(a,b)
+ points <- a[1,1]
+ rowcur <- 1
+ colcur <- 1
+ npts <- nrow(x)
+ for (k in (1:(npts-2))) {
+ colnew <- 3-colcur
+ curnew <- a[rowcur,colnew]
+ points <- c(points,curnew)
+ a <- a[-rowcur,]
+ coo <- which(a==curnew, arr.ind=TRUE)
+ rowcur <- coo[1,1]
+ colcur <- coo[1,2]
+ }
+ colnew <- 3-colcur
+ curnew <- a[rowcur,colnew]
+ points <- c(points,curnew)
+ return(matrix(as.numeric(unlist(strsplit(points,"_"))), ncol=2, byrow=TRUE))
+ }
+ "souscontour" <- function(k) {
+ sel <- unlist(lapply(lreg[[k]],function(x) which(area[,1]==x)))
+ area.sel <- area[sel,]
+ area.sel[,1] <- as.factor(as.character(area.sel[,1]))
+ w <- area.util.contour(area.sel)
+ w <- contour2poly(w)
+ w <- cbind(rep(k,nrow(w)),w)
+ return(w)
+ }
+ lcontour <- lapply(1:nlevels(fac),souscontour)
+ w <- lcontour[[1]]
+ for (k in 2:length(lcontour)) w <- rbind.data.frame(w,lcontour[[k]])
+ w[,1] <- as.factor(levels(fac)[w[,1]])
+ return(w)
+}
diff --git a/R/as.taxo.R b/R/as.taxo.R
new file mode 100644
index 0000000..c9b6b42
--- /dev/null
+++ b/R/as.taxo.R
@@ -0,0 +1,43 @@
+"as.taxo" <-
+function (df)
+{
+ if (!inherits(df, "data.frame"))
+ stop("df is not a data.frame")
+ nc <- ncol(df)
+ for (i in 1:nc) {
+ w <- df[, i]
+ if (!is.factor(w)) stop(paste("column", i, "of" ,deparse(substitute(df)),"is not a factor"))
+ if (nlevels(w) == 1) stop(paste("One level in column", i, "of" ,deparse(substitute(df))))
+ if (nlevels(w) == length(w)) stop(paste("Column", i, "of" ,deparse(substitute(df)),"has one row in each class"))
+ }
+ for (i in 1:(nc - 1)) {
+ t <- table(df[, c(i, i + 1)])
+ w <- apply(t, 1, function(x) sum(x != 0))
+ if (any(w != 1)) {
+ print(w)
+ stop(paste("non hierarchical design", i, "in", i +
+ 1))
+ }
+ }
+ fac <- as.character(df[, nc])
+ for (i in (nc - 1):1) fac <- paste(fac,as.character(df[, i]),sep=":")
+ df <- df[order(fac), ]
+ class(df) <- c("data.frame", "taxo")
+ return(df)
+}
+
+"dist.taxo" <-
+function(taxo)
+{
+ if (!inherits(taxo, "taxo"))
+ stop("class 'taxo' expected")
+ distance<-matrix(2,nrow(taxo),nrow(taxo))
+ diag(distance)<-0
+ for (k in ncol(taxo):1) {
+ toto=as.matrix( acm.disjonctif(as.data.frame(taxo[,k])))
+ distance = distance + 2*(1-toto%*%t(toto))
+ }
+ dimnames(distance) <- list(row.names(taxo),row.names(taxo))
+ return(as.dist(sqrt(distance)))
+}
+
diff --git a/R/bca.rlq.R b/R/bca.rlq.R
new file mode 100644
index 0000000..f899131
--- /dev/null
+++ b/R/bca.rlq.R
@@ -0,0 +1,137 @@
+"bca.rlq" <- function (x, fac, scannf = TRUE, nf = 2, ...)
+{
+ if (!inherits(x, "rlq"))
+ stop("Object of class rlq expected")
+ if (!is.factor(fac))
+ stop("factor expected")
+ appel <- as.list(x$call)
+ dudiR <- eval.parent(appel$dudiR)
+ dudiL <- eval.parent(appel$dudiL)
+ dudiQ <- eval.parent(appel$dudiQ)
+ ligR <- nrow(dudiR$tab)
+ if (length(fac) != ligR)
+ stop("Non convenient dimension")
+ cla.w <- tapply(dudiR$lw, fac, sum)
+ mean.w <- function(x, w, fac, cla.w) {
+ z <- x * w
+ z <- tapply(z, fac, sum)/cla.w
+ return(z)
+ }
+ tabmoyR <- apply(dudiR$tab, 2, mean.w, w = dudiR$lw, fac = fac,
+ cla.w = cla.w)
+ tabmoyR <- data.frame(tabmoyR)
+ row.names(tabmoyR) <- levels(fac)
+ names(tabmoyR) <- names(dudiR$tab)
+ tabmoyL <- apply(dudiL$tab, 2, mean.w, w = dudiL$lw, fac = fac,
+ cla.w = cla.w)
+ tabmoyL <- data.frame(tabmoyL)
+ row.names(tabmoyL) <- levels(fac)
+ names(tabmoyL) <- names(dudiL$tab)
+ dudimoyR <- as.dudi(tabmoyR, dudiR$cw, as.vector(cla.w), scannf = FALSE,
+ nf = nf, call = match.call(), type = "bet")
+ dudimoyL <- as.dudi(tabmoyL, dudiL$cw, as.vector(cla.w), scannf = FALSE,
+ nf = nf, call = match.call(), type = "coa")
+ res <- rlq(dudimoyR, dudimoyL, dudiQ, scannf = scannf,
+ nf = nf)
+ res$call <- match.call()
+
+ U <- as.matrix(res$l1) * unlist(res$lw)
+ U <- data.frame(as.matrix(dudiR$tab) %*% U)
+ row.names(U) <- row.names(dudiR$tab)
+ names(U) <- names(res$l1)
+ res$lsR <- U
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(t(as.matrix(x$c1)) %*% U)
+ row.names(U) <- names(x$c1)
+ names(U) <- names(res$c1)
+ res$acQ <- U
+
+ U <- as.matrix(res$l1) * unlist(res$lw)
+ U <- data.frame(t(as.matrix(x$l1)) %*% U)
+ row.names(U) <- names(x$l1)
+ names(U) <- names(res$l1)
+ res$acR <- U
+
+ class(res) <- c("betrlq", "dudi")
+ return(res)
+}
+
+
+
+"print.betrlq" <- function (x, ...)
+{
+ if (!inherits(x, "betrlq"))
+ stop("to be used with 'betrlq' object")
+ cat("Between RLQ analysis\n")
+ cat("call: ")
+ print(x$call)
+ cat("class: ")
+ cat(class(x), "\n")
+ cat("\n$rank (rank):", x$rank)
+ cat("\n$nf (axis saved):", x$nf)
+ cat("\n\neigen values: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n\n")
+ else cat("\n\n")
+ sumry <- array("", c(3, 4), list(1:3, c("vector", "length",
+ "mode", "content")))
+ sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
+ sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weigths (crossed array)")
+ sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), "col weigths (crossed array)")
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(14, 4), list(1:14, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "crossed array (CA)")
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "R col = CA row: coordinates")
+ sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "R col = CA row: normed scores")
+ sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "Q col = CA column: coordinates")
+ sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "Q col = CA column: normed scores")
+ sumry[6, ] <- c("$lR", nrow(x$lR), ncol(x$lR), "class coordinates (R)")
+ sumry[7, ] <- c("$lsR", nrow(x$lsR), ncol(x$lsR), "supplementary row coordinates (R)")
+ sumry[8, ] <- c("$mR", nrow(x$mR), ncol(x$mR), "class normed scores (R)")
+ sumry[9, ] <- c("$lQ", nrow(x$lQ), ncol(x$lQ), "row coordinates (Q)")
+ sumry[10, ] <- c("$mQ", nrow(x$mQ), ncol(x$mQ), "normed row scores (Q)")
+ sumry[11, ] <- c("$aR", nrow(x$aR), ncol(x$aR), "axes onto between-RLQ axes (R)")
+ sumry[12, ] <- c("$aQ", nrow(x$aQ), ncol(x$aQ), "axes onto between-RLQ axes (Q)")
+ sumry[13, ] <- c("$acR", nrow(x$acR), ncol(x$acR), "RLQ axes onto between-RLQ axes (R)")
+ sumry[14, ] <- c("$acQ", nrow(x$acQ), ncol(x$acQ), "RLQ axes onto between-RLQ axes (Q)")
+ print(sumry, quote = FALSE)
+ cat("\n")
+}
+
+
+
+"plot.betrlq" <- function (x, xax = 1, yax = 2, ...)
+{
+ if (!inherits(x, "betrlq"))
+ stop("Use only with 'betrlq' objects")
+ if (x$nf == 1) {
+ warnings("One axis only : not yet implemented")
+ return(invisible())
+ }
+ if (xax > x$nf)
+ stop("Non convenient xax")
+ if (yax > x$nf)
+ stop("Non convenient yax")
+ fac <- eval.parent(as.list(x$call)$fac)
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ layout(matrix(c(1, 1, 3, 1, 1, 4, 2, 2, 5, 2, 2, 6, 8, 8,
+ 7), 3, 5), respect = TRUE)
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ s.class(x$lsR[, c(xax, yax)], fac = fac, sub = "R row scores and classes", csub = 2,
+ clabel = 1.25)
+ s.label(x$lQ[, c(xax, yax)], sub = "Q row scores", csub = 2,
+ clabel = 1.25)
+ s.corcircle(x$aR, xax, yax, sub = "R axes", csub = 2, clabel = 1.25)
+ s.arrow(x$l1, xax = xax, yax = yax, sub = "R Canonical weights",
+ csub = 2, clabel = 1.25)
+ s.corcircle(x$aQ, xax, yax, sub = "Q axes", csub = 2, clabel = 1.25)
+ s.arrow(x$c1, xax = xax, yax = yax, sub = "Q Canonical weights",
+ csub = 2, clabel = 1.25)
+ scatterutil.eigen(x$eig, wsel = c(xax, yax))
+}
+
diff --git a/R/between.R b/R/between.R
new file mode 100644
index 0000000..eec711d
--- /dev/null
+++ b/R/between.R
@@ -0,0 +1,139 @@
+"bca" <- function (x, ...) UseMethod("bca")
+
+"bca.dudi" <- function (x, fac, scannf = TRUE, nf = 2, ...) {
+ if (!inherits(x, "dudi"))
+ stop("Object of class dudi expected")
+ if (!is.factor(fac))
+ stop("factor expected")
+ lig <- nrow(x$tab)
+ if (length(fac) != lig)
+ stop("Non convenient dimension")
+ cla.w <- tapply(x$lw, fac, sum)
+ mean.w <- function(x, w, fac, cla.w) {
+ z <- x * w
+ z <- tapply(z, fac, sum)/cla.w
+ return(z)
+ }
+ tabmoy <- apply(x$tab, 2, mean.w, w = x$lw, fac = fac,
+ cla.w = cla.w)
+ tabmoy <- data.frame(tabmoy)
+ row.names(tabmoy) <- levels(fac)
+ names(tabmoy) <- names(x$tab)
+ res <- as.dudi(tabmoy, x$cw, as.vector(cla.w), scannf = scannf,
+ nf = nf, call = match.call(), type = "bet")
+ res$ratio <- sum(res$eig)/sum(x$eig)
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(as.matrix(x$tab) %*% U)
+ row.names(U) <- row.names(x$tab)
+ names(U) <- names(res$c1)
+ res$ls <- U
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(t(as.matrix(x$c1)) %*% U)
+ row.names(U) <- names(x$li)
+ names(U) <- names(res$li)
+ res$as <- U
+ class(res) <- c("between", "dudi")
+ return(res)
+}
+
+"between" <- function (dudi, fac, scannf = TRUE, nf = 2) {
+ .Deprecated("bca", "ade4", "To avoid some name conflicts, the 'between' function is now deprecated. Please use 'bca' instead")
+ res <- bca(x=dudi, fac=fac, scannf = scannf, nf = nf)
+ res$call <- match.call()
+ return(res)
+}
+
+
+"plot.between" <- function (x, xax = 1, yax = 2, ...) {
+ bet <- x
+ if (!inherits(bet, "between"))
+ stop("Use only with 'between' objects")
+ appel <- as.list(bet$call)
+ fac <- eval.parent(appel$fac)
+ dudi <- eval.parent(appel$x)
+ if ((bet$nf == 1) || (xax == yax)) {
+ lig <- nrow(dudi$tab)
+ if (length(fac) != lig)
+ stop("Non convenient dimension")
+ sco.quant(bet$ls[, 1], dudi$tab, fac = fac)
+ return(invisible())
+ }
+ if (xax > bet$nf)
+ stop("Non convenient xax")
+ if (yax > bet$nf)
+ stop("Non convenient yax")
+
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3),
+ respect = TRUE)
+ par(mar = c(0.2, 0.2, 0.2, 0.2))
+ s.arrow(bet$c1, xax = xax, yax = yax, sub = "Canonical weights",
+ csub = 2, clabel = 1.25)
+ s.arrow(bet$co, xax = xax, yax = yax, sub = "Variables",
+ csub = 2, cgrid = 0, clabel = 1.25)
+ scatterutil.eigen(bet$eig, wsel = c(xax, yax))
+ s.class(bet$ls, fac, wt = dudi$lw, xax = xax, yax = yax, sub = "Scores and classes",
+ csub = 2, clabel = 1.25)
+ s.corcircle(bet$as, xax = xax, yax = yax, sub = "Inertia axes",
+ csub = 2, cgrid = 0, clabel = 1.25)
+ s.label(bet$li, xax = xax, yax = yax, sub = "Classes",
+ csub = 2, clabel = 1.25)
+}
+
+"print.between" <- function (x, ...) {
+ if (!inherits(x, "between"))
+ stop("to be used with 'between' object")
+ cat("Between analysis\n")
+ cat("call: ")
+ print(x$call)
+ cat("class: ")
+ cat(class(x), "\n")
+ cat("\n$nf (axis saved) :", x$nf)
+ cat("\n$rank: ", x$rank)
+ cat("\n$ratio: ", x$ratio)
+ cat("\n\neigen values: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n\n")
+ else cat("\n\n")
+ sumry <- array("", c(3, 4), list(1:3, c("vector", "length",
+ "mode", "content")))
+ sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
+ sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "group weigths")
+ sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), "col weigths")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(7, 4), list(1:7, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "array class-variables")
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "class coordinates")
+ sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "class normed scores")
+ sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates")
+ sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores")
+ sumry[6, ] <- c("$ls", nrow(x$ls), ncol(x$ls), "row coordinates")
+ sumry[7, ] <- c("$as", nrow(x$as), ncol(x$as), "inertia axis onto between axis")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+}
+
+
+summary.between <- function(object, ...){
+ thetitle <- "Between-class analysis"
+ cat(thetitle)
+ cat("\n\n")
+ NextMethod()
+ appel <- as.list(object$call)
+ dudi <- eval.parent(appel$x)
+ cat(paste("Total unconstrained inertia (", deparse(appel$x),
+ "): ", sep = ""))
+ cat(signif(sum(dudi$eig), 4))
+ cat("\n\n")
+ cat(paste("Inertia of", deparse(appel$x), "explained by",
+ deparse(appel$fac), "(%): "))
+ cat(signif(object$ratio * 100, 4))
+ cat("\n\n")
+}
diff --git a/R/betweencoinertia.R b/R/betweencoinertia.R
new file mode 100644
index 0000000..aa48cc5
--- /dev/null
+++ b/R/betweencoinertia.R
@@ -0,0 +1,173 @@
+bca.coinertia <-
+function (x, fac, scannf = TRUE, nf = 2, ...)
+{
+ if (!inherits(x, "coinertia"))
+ stop("Xect of class coinertia expected")
+ if (!is.factor(fac))
+ stop("factor expected")
+ appel <- as.list(x$call)
+ dudiX <- eval.parent(appel$dudiX)
+ dudiY <- eval.parent(appel$dudiY)
+ ligX <- nrow(dudiX$tab)
+ if (length(fac) != ligX)
+ stop("Non convenient dimension")
+
+ mean.w <- function(x, w, fac, cla.w) {
+ z <- x * w
+ z <- tapply(z, fac, sum)/cla.w
+ return(z)
+ }
+ cla.w <- tapply(dudiX$lw, fac, sum)
+ tabmoyX <- apply(dudiX$tab, 2, mean.w, w = dudiX$lw, fac = fac,
+ cla.w = cla.w)
+ tabmoyX <- data.frame(tabmoyX)
+ row.names(tabmoyX) <- levels(fac)
+ names(tabmoyX) <- names(dudiX$tab)
+ tabmoyY <- apply(dudiY$tab, 2, mean.w, w = dudiY$lw, fac = fac,
+ cla.w = cla.w)
+ tabmoyY <- data.frame(tabmoyY)
+ row.names(tabmoyY) <- levels(fac)
+ names(tabmoyY) <- names(dudiY$tab)
+ dudimoyX <- as.dudi(tabmoyX, dudiX$cw, as.vector(cla.w), scannf = FALSE,
+ nf = nf, call = match.call(), type = "bet")
+ dudimoyY <- as.dudi(tabmoyY, dudiY$cw, as.vector(cla.w), scannf = FALSE,
+ nf = nf, call = match.call(), type = "coa")
+ res <- coinertia(dudimoyX, dudimoyY, scannf = scannf,
+ nf = nf)
+ res$call <- match.call()
+ ## cov=covB+covW, donc ce n'est pas vrai pour les carres et donc la coinertie
+ ##res$ratio <- sum(res$eig)/sum(x$eig)
+ U <- as.matrix(res$l1) * unlist(res$lw)
+ U <- data.frame(as.matrix(dudiY$tab) %*% U)
+ row.names(U) <- row.names(dudiY$tab)
+ names(U) <- names(res$lY)
+ res$lsY <- U
+
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(as.matrix(dudiX$tab) %*% U)
+ row.names(U) <- row.names(dudiX$tab)
+ names(U) <- names(res$lX)
+ res$lsX <- U
+
+ ratioX<-unlist(res$mX[1,]/res$lX[1,])
+ res$msX<-data.frame(t(t(res$lsX)*ratioX))
+ row.names(res$msX) <- row.names(res$lsX)
+ names(res$msX) <- names(res$mX)
+
+ ratioY<-unlist(res$mY[1,]/res$lY[1,])
+ res$msY<-data.frame(t(t(res$lsY)*ratioY))
+ row.names(res$msY) <- row.names(res$lsY)
+ names(res$msY) <- names(res$mY)
+
+ U <- as.matrix(res$l1) * unlist(res$lw)
+ U <- data.frame(t(as.matrix(x$l1)) %*% U)
+ row.names(U) <- paste("AxcY", (1:x$nf), sep = "")
+ names(U) <- paste("AxbcY", (1:res$nf), sep = "")
+ res$acY <- U
+ names(res$aY)<-names(res$lY)<-names(res$lsY)<-names(res$acY)
+
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(t(as.matrix(x$c1)) %*% U)
+ row.names(U) <- paste("AxcX", (1:x$nf), sep = "")
+ names(U) <- paste("AxbcX", (1:res$nf), sep = "")
+ res$acX <- U
+ names(res$aX)<-names(res$lX)<-names(res$lsX)<-names(res$acX)
+
+ class(res) <- c("betcoi", "dudi")
+ return(res)
+}
+
+betweencoinertia <-
+function (obj, fac, scannf = TRUE, nf = 2) {
+ .Deprecated("bca", "ade4", "To avoid some name conflicts, the 'betweencoinertia' function is now deprecated. Please use 'bca.coinertia' instead")
+ res <- bca(x=obj, fac=fac, scannf = scannf, nf = nf)
+ res$call <- match.call()
+ return(res)
+}
+
+plot.betcoi <-
+function(x, xax = 1, yax = 2, ...) {
+ if (!inherits(x, "betcoi"))
+ stop("Use only with 'betcoi' objects")
+ if (x$nf == 1) {
+ warnings("One axis only : not yet implemented")
+ return(invisible())
+ }
+ if (xax > x$nf)
+ stop("Non convenient xax")
+ if (yax > x$nf)
+ stop("Non convenient yax")
+ appel <- as.list(x$call)
+ fac <- eval.parent(appel$fac)
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ nf <- layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3),
+ respect = TRUE)
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ s.arrow(x$aX, xax, yax, sub = "X axes", csub = 2, clabel = 1.25)
+ s.arrow(x$aY, xax, yax, sub = "Y axes", csub = 2, clabel = 1.25)
+ scatterutil.eigen(x$eig, wsel = c(xax, yax))
+ s.match.class(df1xy = x$msX, df2xy = x$msY, fac = fac, clabel = 1.5) # wt?
+
+ s.arrow(x$l1, xax = xax, yax = yax, sub = "Y Canonical weights",
+ csub = 2, clabel = 1.25)
+ s.arrow(x$c1, xax = xax, yax = yax, sub = "X Canonical weights",
+ csub = 2, clabel = 1.25)
+
+}
+
+print.betcoi <-
+function (x, ...) {
+ if (!inherits(x, "betcoi"))
+ stop("to be used with 'betcoi' object")
+ cat("Between coinertia analysis\n")
+ cat("call: ")
+ print(x$call)
+ cat("class: ")
+ cat(class(x), "\n")
+ cat("\n$rank (rank) :", x$rank)
+ cat("\n$nf (axis saved) :", x$nf)
+ cat("\n$RV (RV coeff) :", x$RV)
+ cat("\n\neigenvalues: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n\n")
+ else cat("\n\n")
+ sumry <- array("", c(3, 4), list(1:3, c("vector", "length",
+ "mode", "content")))
+ sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "Eigenvalues")
+ sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), paste("Row weigths (for ", eval(x$call[[2]])$call[[3]], " cols)", sep=""))
+ sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), paste("Col weigths (for ", eval(x$call[[2]])$call[[2]], " cols)", sep=""))
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(17, 4), list(1:17, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "Crossed Table (CT)")
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), paste("CT row scores (cols of ", eval(x$call[[2]])$call[[3]], ")", sep=""))
+ sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), paste("CT normed row scores (cols of ", eval(x$call[[2]])$call[[3]], ")", sep=""))
+ sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), paste("CT col scores (cols of ", eval(x$call[[2]])$call[[2]], ")", sep=""))
+ sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), paste("CT normed col scores (cols of ", eval(x$call[[2]])$call[[2]], ")", sep=""))
+ sumry[6, ] <- c("$lX", nrow(x$lX), ncol(x$lX), paste("Class scores (for ", eval(x$call[[2]])$call[[2]], ")", sep=""))
+ sumry[7, ] <- c("$mX", nrow(x$mX), ncol(x$mX), paste("Normed class scores (for ", eval(x$call[[2]])$call[[2]], ")", sep=""))
+ sumry[8, ] <- c("$lY", nrow(x$lY), ncol(x$lY), paste("Class scores (for ", eval(x$call[[2]])$call[[3]], ")", sep=""))
+ sumry[9, ] <- c("$mY", nrow(x$mY), ncol(x$mY), paste("Normed class scores (for ", eval(x$call[[2]])$call[[3]], ")", sep=""))
+ sumry[10, ] <- c("$lsX", nrow(x$lsX), ncol(x$lsX), paste("Row scores (rows of ", eval(x$call[[2]])$call[[2]], ")", sep=""))
+ sumry[11, ] <- c("$msX", nrow(x$msX), ncol(x$msX), paste("Normed row scores (rows of ", eval(x$call[[2]])$call[[2]], ")", sep=""))
+ sumry[12, ] <- c("$lsY", nrow(x$lsY), ncol(x$lsY), paste("Row scores (rows of ", eval(x$call[[2]])$call[[3]], ")", sep=""))
+ sumry[13, ] <- c("$msY", nrow(x$msY), ncol(x$msY), paste("Normed row scores (rows of ", eval(x$call[[2]])$call[[3]], ")", sep=""))
+ sumry[14, ] <- c("$aX", nrow(x$aX), ncol(x$aX),
+ paste("Corr ", eval(x$call[[2]])$call[[2]], " axes / betcoi axes", sep=""))
+ sumry[15, ] <- c("$aY", nrow(x$aY), ncol(x$aY),
+ paste("Corr ", eval(x$call[[2]])$call[[3]], " axes / betcoi axes", sep=""))
+ sumry[16, ] <- c("$acX", nrow(x$acX), ncol(x$acX),
+ paste("Corr ", eval(x$call[[2]])$call[[2]], " coinertia axes / betcoi axes", sep=""))
+ sumry[17, ] <- c("$acY", nrow(x$acY), ncol(x$acY),
+ paste("Corr ", eval(x$call[[2]])$call[[3]], " coinertia axes / betcoi axes", sep=""))
+
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+}
+
diff --git a/R/betwitdpcoa.R b/R/betwitdpcoa.R
new file mode 100644
index 0000000..ae38eed
--- /dev/null
+++ b/R/betwitdpcoa.R
@@ -0,0 +1,261 @@
+wca.dpcoa <- function (x, fac, scannf = TRUE, nf = 2, ...){
+
+ if (!inherits(x, "dpcoa"))
+ stop("Object of class dpcoa expected")
+ if (!is.factor(fac))
+ stop("factor expected")
+ tabw <- tapply(x$lw, fac, sum)
+ tabw <- tabw/sum(tabw)
+
+ tabwit <- scalefacwt(x$tab, fac = fac, wt = x$lw, scale = FALSE, drop = FALSE)
+ res <- as.dudi(tabwit, x$cw, x$lw, scannf = scannf, nf = nf, call = match.call(), type = "witdpcoa")
+ res$ratio <- sum(res$eig)/sum(x$eig)
+
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(as.matrix(x$tab) %*% U)
+ row.names(U) <- row.names(x$tab)
+ names(U) <- names(res$li)
+ res$ls <- U
+
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(t(as.matrix(x$c1)) %*% U)
+ row.names(U) <- names(x$li)
+ names(U) <- names(res$li)
+ res$as <- U
+
+ res$tabw <- tabw
+ res$fac <- fac
+
+ res$co <- res$l1 <- NULL
+
+ ## add species information
+ res$dw <- x$dw
+ dis <- eval.parent(as.list(x$call)$dis)
+
+ U <- as.matrix(dudi.pco(dis, row.w = x$dw, full = TRUE)$li) %*% as.matrix(res$c1)
+ U <- data.frame(U)
+ row.names(U) <- attr(dis, "Labels")
+ res$dls <- U
+ class(res) <- c("witdpcoa", "within", "dudi")
+ return(res)
+}
+
+
+bca.dpcoa <- function(x, fac, scannf = TRUE, nf = 2, ...){
+ if (!inherits(x, "dpcoa"))
+ stop("Object of class dpcoa expected")
+ if (!is.factor(fac))
+ stop("factor expected")
+ tabw <- tapply(x$lw, fac, sum)
+ tabw <- as.vector(tabw/sum(tabw))
+
+ tabmoy <- meanfacwt(df = x$tab, fac = fac, wt = x$lw, drop = FALSE)
+
+ res <- as.dudi(data.frame(tabmoy), x$cw, tabw, scannf = scannf, nf = nf, call = match.call(), type = "betdpcoa")
+ res$ratio <- sum(res$eig)/sum(x$eig)
+
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(as.matrix(x$tab) %*% U)
+ row.names(U) <- row.names(x$tab)
+ names(U) <- names(res$li)
+ res$ls <- U
+
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(t(as.matrix(x$c1)) %*% U)
+ row.names(U) <- names(x$li)
+ names(U) <- names(res$li)
+ res$as <- U
+
+ res$fac <- fac
+
+ res$co <- res$l1 <- NULL
+
+ ## add species information
+ res$dw <- x$dw
+ dis <- eval.parent(as.list(x$call)$dis)
+
+ U <- as.matrix(dudi.pco(dis, row.w = x$dw, full = TRUE)$li) %*% as.matrix(res$c1)
+ U <- data.frame(U)
+ row.names(U) <- attr(dis, "Labels")
+ res$dls <- U
+ class(res) <- c("betdpcoa", "between", "dudi")
+ return(res)
+}
+
+
+bwca.dpcoa <- function(x, fac, cofac, scannf = TRUE, nf = 2, ...){
+
+ if (!inherits(x, "dpcoa"))
+ stop("Object of class dpcoa expected")
+ if (!is.factor(fac) || !is.factor(cofac) )
+ stop("factor expected")
+
+ cofac01 <- model.matrix( ~ -1 + cofac)
+ fac01 <- model.matrix( ~ -1 + fac)
+ x.resid <- lm.wfit(x = cofac01, y = fac01, w = x$lw)$residuals
+ tab <- lm.wfit(x = x.resid, y = as.matrix(x$tab), w = x$lw)$fitted.values
+ res <- as.dudi(data.frame(tab), x$cw, x$lw, scannf = scannf, nf = nf, call = match.call(), type = "betwitdpcoa")
+
+ res$ratio <- sum(res$eig)/sum(x$eig)
+
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(as.matrix(x$tab) %*% U)
+ row.names(U) <- row.names(x$tab)
+ names(U) <- names(res$li)
+ res$ls <- U
+
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(t(as.matrix(x$c1)) %*% U)
+ row.names(U) <- names(x$li)
+ names(U) <- names(res$li)
+ res$as <- U
+
+ res$fac <- fac
+ res$cofac <- cofac
+
+ res$co <- res$l1 <- NULL
+
+ ## add species information
+ res$dw <- x$dw
+ dis <- eval.parent(as.list(x$call)$dis)
+
+ U <- as.matrix(dudi.pco(dis, row.w = x$dw, full = TRUE)$li) %*% as.matrix(res$c1)
+ U <- data.frame(U)
+ row.names(U) <- attr(dis, "Labels")
+ res$dls <- U
+ class(res) <- c("betwitdpcoa", "betwit", "dudi")
+ return(res)
+}
+
+
+
+
+
+randtest.betwit <- function(xtest, nrepet = 999, ...){
+ if (!inherits(xtest, "betwit"))
+ stop("Object of class 'betwit' expected")
+ appel <- as.list(xtest$call)
+ dudi1 <- eval.parent(appel$x)
+ fac <- eval.parent(appel$fac)
+ cofac <- eval.parent(appel$cofac)
+ inertot <- sum(dudi1$eig)
+ cofac01 <- model.matrix( ~ -1 + cofac)
+ fac01 <- model.matrix( ~ -1 + fac)
+ x.resid <- lm.wfit(x = cofac01, y = fac01, w = dudi1$lw)$residuals
+
+ lm1 <- lm.wfit(x = cofac01, y = as.matrix(dudi1$tab), w = dudi1$lw)
+ Y.r <- lm1$residuals
+ Y.f <- lm1$fitted.values
+
+ wt <- outer(sqrt(dudi1$lw), sqrt(dudi1$cw))
+ obs <- sum((lm.wfit(y = Y.f + Y.r, x = x.resid, w = dudi1$lw)$fitted.values * wt)^2)/inertot
+ isim <- c()
+ ## permutation under reduced-model
+ for (i in 1:nrepet)
+ isim[i] <- sum((lm.wfit(y = Y.f + Y.r[sample(nrow(Y.r)), ], x = x.resid, w = dudi1$lw)$fitted.values * wt)^2)/inertot
+ return(as.randtest(isim, obs, call = match.call(), ...))
+}
+
+
+
+
+
+
+summary.betwit <- function(object, ...){
+ thetitle <- "Between within-class analysis"
+ cat(thetitle)
+ cat("\n\n")
+ NextMethod()
+ appel <- as.list(object$call)
+ dudi <- eval.parent(appel$x)
+ cat(paste("Total unconstrained inertia (", deparse(appel$x),
+ "): ", sep = ""))
+ cat(signif(sum(dudi$eig), 4))
+ cat("\n\n")
+ cat(paste("Inertia of", deparse(appel$x), "independent of",
+ deparse(appel$cofac), "explained by", deparse(appel$fac), "(%): "))
+ cat(signif(object$ratio * 100, 4))
+ cat("\n\n")
+}
+
+
+
+print.witdpcoa <- function (x, ...){
+ if (!inherits(x, "witdpcoa"))
+ stop("to be used with 'witdpcoa' object")
+ cat("Within double principal coordinate analysis\n")
+ cat("call: ")
+ print(x$call)
+ cat("class: ")
+ cat(class(x), "\n")
+ cat("\n$nf (axis saved) :", x$nf)
+ cat("\n$rank: ", x$rank)
+ cat("\n$ratio: ", x$ratio)
+ cat("\n\neigen values: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n\n")
+ else cat("\n\n")
+
+ sumry <- array("", c(5, 4), list(1:5, c("vector", "length",
+ "mode", "content")))
+ sumry[1, ] <- c("$dw", length(x$dw), mode(x$dw), "category weights")
+ sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "collection weights")
+ sumry[3, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
+ sumry[4, ] <- c("$tabw", length(x$tabw), mode(x$tabw), "class weigths")
+ sumry[5, ] <- c("$fac", length(x$fac), mode(x$fac), "factor for grouping")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+
+ sumry <- array("", c(5, 4), list(1:5, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$dls", nrow(x$dls), ncol(x$dls), "coordinates of the categories")
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "coordinates of the collections")
+ sumry[3, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "scores of the principal axes of the categories")
+ sumry[4, ] <- c("$ls", nrow(x$ls), ncol(x$ls), "projection of the original collections")
+ sumry[5, ] <- c("$as", nrow(x$as), ncol(x$as), "dpcoa axes onto wca axes")
+
+ print(sumry, quote = FALSE)
+}
+
+
+print.betdpcoa <- function (x, ...){
+ if (!inherits(x, "betdpcoa"))
+ stop("to be used with 'betdpcoa' object")
+ cat("Between double principal coordinate analysis\n")
+ cat("call: ")
+ print(x$call)
+ cat("class: ")
+ cat(class(x), "\n")
+ cat("\n$nf (axis saved) :", x$nf)
+ cat("\n$rank: ", x$rank)
+ cat("\n$ratio: ", x$ratio)
+ cat("\n\neigen values: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n\n")
+ else cat("\n\n")
+
+ sumry <- array("", c(4, 4), list(1:4, c("vector", "length",
+ "mode", "content")))
+ sumry[1, ] <- c("$dw", length(x$dw), mode(x$dw), "category weights")
+ sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "collection weights")
+ sumry[3, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
+ sumry[4, ] <- c("$fac", length(x$fac), mode(x$fac), "factor for grouping")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+
+ sumry <- array("", c(5, 4), list(1:5, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$dls", nrow(x$dls), ncol(x$dls), "coordinates of the categories")
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "coordinates of the classes")
+ sumry[3, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "scores of the principal axes of the categories")
+ sumry[4, ] <- c("$ls", nrow(x$ls), ncol(x$ls), "coordinates of the collections")
+ sumry[5, ] <- c("$as", nrow(x$as), ncol(x$as), "dpcoa axes onto wca axes")
+
+ print(sumry, quote = FALSE)
+}
diff --git a/R/bicenter.wt.R b/R/bicenter.wt.R
new file mode 100644
index 0000000..9123d54
--- /dev/null
+++ b/R/bicenter.wt.R
@@ -0,0 +1,21 @@
+"bicenter.wt" <- function (X, row.wt = rep(1, nrow(X)), col.wt = rep(1, ncol(X))) {
+ X <- as.matrix(X)
+ n <- nrow(X)
+ p <- ncol(X)
+ if (length(row.wt) != n)
+ stop("length of row.wt must equal the number of rows in x")
+ if (any(row.wt < 0) || (sr <- sum(row.wt)) == 0)
+ stop("weights must be non-negative and not all zero")
+ row.wt <- row.wt/sr
+ if (length(col.wt) != p)
+ stop("length of col.wt must equal the number of columns in x")
+ if (any(col.wt < 0) || (st <- sum(col.wt)) == 0)
+ stop("weights must be non-negative and not all zero")
+ col.wt <- col.wt/st
+ row.mean <- apply(row.wt * X, 2, sum)
+ col.mean <- apply(col.wt * t(X), 2, sum)
+ col.mean <- col.mean - sum(row.mean * col.wt)
+ X <- sweep(X, 2, row.mean)
+ X <- t(sweep(t(X), 2, col.mean))
+ return(X)
+}
diff --git a/R/cailliez.R b/R/cailliez.R
new file mode 100644
index 0000000..71826a7
--- /dev/null
+++ b/R/cailliez.R
@@ -0,0 +1,26 @@
+"cailliez" <- function (distmat, print = FALSE, tol = 1e-07, cor.zero = TRUE) {
+ if (is.euclid(distmat)) {
+ warning("Euclidean distance found : no correction need")
+ return(distmat)
+ }
+ distmat <- as.matrix(distmat)
+ size <- ncol(distmat)
+ m1 <- matrix(0, size, size)
+ m1 <- rbind(m1, -diag(size))
+ m2 <- -bicenter.wt(distmat * distmat)
+ m2 <- rbind(m2, 2 * bicenter.wt(distmat))
+ m1 <- cbind(m1, m2)
+ lambda <- eigen(m1, only.values = TRUE)$values
+ c <- max(Re(lambda)[Im(lambda) < tol])
+ if (print)
+ cat(paste("Cailliez constant =", round(c, digits = 5), "\n"))
+ if(cor.zero){
+ distmat[distmat > tol] <- distmat[distmat > tol] + c
+ distmat <- as.dist(distmat)
+ } else {
+ distmat <- as.dist(distmat + c)
+ }
+ attr(distmat, "call") <- match.call()
+ attr(distmat, "method") <- "Cailliez"
+ return(distmat)
+}
diff --git a/R/coinertia.R b/R/coinertia.R
new file mode 100644
index 0000000..c56485b
--- /dev/null
+++ b/R/coinertia.R
@@ -0,0 +1,278 @@
+"coinertia" <- function (dudiX, dudiY, scannf = TRUE, nf = 2) {
+ normalise.w <- function(X, w) {
+ # Correction d'un bug siganle par Sandrine Pavoine le 21/10/2006
+ f2 <- function(v) sqrt(sum(v * v * w))
+ norm <- apply(X, 2, f2)
+ X <- sweep(X, 2, norm, "/")
+ return(X)
+ }
+ if (!inherits(dudiX, "dudi"))
+ stop("Object of class dudi expected")
+ lig1 <- nrow(dudiX$tab)
+ col1 <- ncol(dudiX$tab)
+ if (!inherits(dudiY, "dudi"))
+ stop("Object of class dudi expected")
+ lig2 <- nrow(dudiY$tab)
+ col2 <- ncol(dudiY$tab)
+ if (lig1 != lig2)
+ stop("Non equal row numbers")
+ if (any((dudiX$lw - dudiY$lw)^2 > 1e-07))
+ stop("Non equal row weights")
+ tabcoiner <- t(as.matrix(dudiY$tab)) %*% (as.matrix(dudiX$tab) *
+ dudiX$lw)
+ tabcoiner <- data.frame(tabcoiner)
+ names(tabcoiner) <- names(dudiX$tab)
+ row.names(tabcoiner) <- names(dudiY$tab)
+ if (nf > dudiX$rank)
+ nf <- dudiX$rank
+ if (nf > dudiY$rank)
+ nf <- dudiY$rank
+ if ((lig1<col1) & (lig1<col2)) {
+ tol <- 1e-07
+ w1 <- t(dudiX$tab)*dudiX$cw
+ w1 <- as.matrix(dudiX$tab)%*%w1
+ w1 <- dudiX$lw*w1
+ w2 <- t(dudiY$tab)*dudiY$cw
+ w2 <- as.matrix(dudiY$tab)%*%w2
+ w2 <- dudiY$lw*w2
+ w1 <- w1%*%w2
+ w1 <- eigen(w1)
+ # correction d'un bug signale par E. Prestat - juillet 2012
+ # Dans le cas d'une matrice non symetrique, eigen renvoie
+ # parfois des elements propres complexes possedant une partie
+ # imaginaire tres petite ou nulle.
+ w1$values <- Re(w1$values)
+ w1$vectors <- Re(w1$vectors)
+ res <- list(tab = tabcoiner, cw = dudiX$cw, lw = dudiY$cw)
+ rank <- sum((w1$values/w1$values[1]) > tol)
+ if (scannf) {
+ if (exists("ade4TkGUIFlag")) {
+ nf <- ade4TkGUI::chooseaxes(w1$values, rank)
+ } else {
+ barplot(w1$values[1:rank])
+ cat("Select the number of axes: ")
+ nf <- as.integer(readLines(n = 1))
+ }
+ }
+ if (nf <= 0)
+ nf <- 2
+ if (nf > rank)
+ nf <- rank
+ res$eig <- w1$values[1:rank]
+ res$rank <- rank
+ res$nf <- nf
+ w1 <- w1$vectors[,1:nf]
+ U <- t(dudiY$tab)%*%w1
+ U <- normalise.w(U, dudiY$cw)
+ res$l1 <- U
+ res$l1 <- as.data.frame(res$l1)
+ names(res$l1) <- paste("RS", (1:nf), sep = "")
+ row.names(res$l1) <- names(dudiY$tab)
+ U <- t(t(U)*sqrt(res$eig[1:nf]))
+ res$li <- U
+ res$li <- as.data.frame(res$li)
+ names(res$li) <- paste("Axis", (1:nf), sep = "")
+ row.names(res$li) <- names(dudiY$tab)
+ U <- as.matrix(dudiY$tab)
+ U <- U*dudiY$lw
+ U <- U%*%(as.matrix(res$l1)*dudiY$cw)
+ U <- t(dudiX$tab)%*%U
+ res$co <- U
+ res$co <- as.data.frame(res$co)
+ names(res$co) <- paste("Comp", (1:nf), sep = "")
+ row.names(res$co) <- names(dudiX$tab)
+ U <- t(t(U)/sqrt(res$eig[1:nf]))
+ res$c1 <- U
+ res$c1 <- as.data.frame(res$c1)
+ names(res$c1) <- paste("CS", (1:nf), sep = "")
+ row.names(res$c1) <- names(dudiX$tab)
+
+ U <- as.matrix(res$c1) * dudiX$cw
+ U <- data.frame(as.matrix(dudiX$tab) %*% U)
+ row.names(U) <- row.names(dudiX$tab)
+ names(U) <- paste("AxcX", (1:res$nf), sep = "")
+ res$lX <- U
+ U <- normalise.w(U, dudiX$lw)
+ names(U) <- paste("NorS", (1:res$nf), sep = "")
+ res$mX <- U
+ U <- as.matrix(res$l1) * dudiY$cw
+ U <- data.frame(as.matrix(dudiY$tab) %*% U)
+ row.names(U) <- row.names(dudiY$tab)
+ names(U) <- paste("AxcY", (1:res$nf), sep = "")
+ res$lY <- U
+ U <- normalise.w(U, dudiY$lw)
+ names(U) <- paste("NorS", (1:res$nf), sep = "")
+ res$mY <- U
+ U <- as.matrix(res$c1) * dudiX$cw
+ U <- data.frame(t(as.matrix(dudiX$c1)) %*% U)
+ row.names(U) <- paste("Ax", (1:dudiX$nf), sep = "")
+ names(U) <- paste("AxcX", (1:res$nf), sep = "")
+ res$aX <- U
+ U <- as.matrix(res$l1) * dudiY$cw
+ U <- data.frame(t(as.matrix(dudiY$c1)) %*% U)
+ row.names(U) <- paste("Ax", (1:dudiY$nf), sep = "")
+ names(U) <- paste("AxcY", (1:res$nf), sep = "")
+ res$aY <- U
+ res$call <- match.call()
+ class(res) <- c("coinertia", "dudi")
+ } else {
+ res <- as.dudi(tabcoiner, dudiX$cw, dudiY$cw, scannf = scannf,
+ nf = nf, call = match.call(), type = "coinertia")
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(as.matrix(dudiX$tab) %*% U)
+ row.names(U) <- row.names(dudiX$tab)
+ names(U) <- paste("AxcX", (1:res$nf), sep = "")
+ res$lX <- U
+ U <- normalise.w(U, dudiX$lw)
+ names(U) <- paste("NorS", (1:res$nf), sep = "")
+ res$mX <- U
+ U <- as.matrix(res$l1) * unlist(res$lw)
+ U <- data.frame(as.matrix(dudiY$tab) %*% U)
+ row.names(U) <- row.names(dudiY$tab)
+ names(U) <- paste("AxcY", (1:res$nf), sep = "")
+ res$lY <- U
+ U <- normalise.w(U, dudiY$lw)
+ names(U) <- paste("NorS", (1:res$nf), sep = "")
+ res$mY <- U
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(t(as.matrix(dudiX$c1)) %*% U)
+ row.names(U) <- paste("Ax", (1:dudiX$nf), sep = "")
+ names(U) <- paste("AxcX", (1:res$nf), sep = "")
+ res$aX <- U
+ U <- as.matrix(res$l1) * unlist(res$lw)
+ U <- data.frame(t(as.matrix(dudiY$c1)) %*% U)
+ row.names(U) <- paste("Ax", (1:dudiY$nf), sep = "")
+ names(U) <- paste("AxcY", (1:res$nf), sep = "")
+ res$aY <- U
+ }
+ RV <- sum(res$eig)/sqrt(sum(dudiX$eig^2))/sqrt(sum(dudiY$eig^2))
+ res$RV <- RV
+ return(res)
+}
+
+"plot.coinertia" <- function (x, xax = 1, yax = 2, ...) {
+ if (!inherits(x, "coinertia"))
+ stop("Use only with 'coinertia' objects")
+ if (x$nf == 1) {
+ warnings("One axis only : not yet implemented")
+ return(invisible())
+ }
+ if (xax > x$nf)
+ stop("Non convenient xax")
+ if (yax > x$nf)
+ stop("Non convenient yax")
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3),
+ respect = TRUE)
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ s.corcircle(x$aX, xax, yax, sub = "X axes", csub = 2,
+ clabel = 1.25)
+ s.corcircle(x$aY, xax, yax, sub = "Y axes", csub = 2,
+ clabel = 1.25)
+ scatterutil.eigen(x$eig, wsel = c(xax, yax))
+ s.match(x$mX, x$mY, xax, yax, clabel = 1.5)
+ s.arrow(x$l1, xax = xax, yax = yax, sub = "Y Canonical weights",
+ csub = 2, clabel = 1.25)
+ s.arrow(x$c1, xax = xax, yax = yax, sub = "X Canonical weights",
+ csub = 2, clabel = 1.25)
+}
+
+"print.coinertia" <- function (x, ...) {
+ if (!inherits(x, "coinertia"))
+ stop("to be used with 'coinertia' object")
+ cat("Coinertia analysis\n")
+ cat("call: ")
+ print(x$call)
+ cat("class: ")
+ cat(class(x), "\n")
+ cat("\n$rank (rank) :", x$rank)
+ cat("\n$nf (axis saved) :", x$nf)
+ cat("\n$RV (RV coeff) :", x$RV)
+ cat("\n\neigenvalues: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n\n")
+ else cat("\n\n")
+ sumry <- array("", c(3, 4), list(1:3, c("vector", "length",
+ "mode", "content")))
+ sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "Eigenvalues")
+ sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), paste("Row weigths (for", x$call[[3]], "cols)"))
+ sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), paste("Col weigths (for", x$call[[2]], "cols)"))
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(11, 4), list(1:11, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), paste("Crossed Table (CT): cols(", x$call[[3]], ") x cols(", x$call[[2]], ")", sep=""))
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), paste("CT row scores (cols of ", x$call[[3]], ")", sep=""))
+ sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), paste("Principal components (loadings for ", x$call[[3]], " cols)", sep=""))
+ sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), paste("CT col scores (cols of ", x$call[[2]], ")", sep=""))
+ sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), paste("Principal axes (loadings for ", x$call[[2]], ")", sep=""))
+ sumry[6, ] <- c("$lX", nrow(x$lX), ncol(x$lX), paste("Row scores (rows of ", x$call[[2]], " cols)", sep=""))
+ sumry[7, ] <- c("$mX", nrow(x$mX), ncol(x$mX), paste("Normed row scores (rows of ", x$call[[2]], ")", sep=""))
+ sumry[8, ] <- c("$lY", nrow(x$lY), ncol(x$lY), paste("Row scores (rows of ", x$call[[3]], ")", sep=""))
+ sumry[9, ] <- c("$mY", nrow(x$mY), ncol(x$mY), paste("Normed row scores (rows of ", x$call[[3]], ")", sep=""))
+ sumry[10, ] <- c("$aX", nrow(x$aX), ncol(x$aX), paste("Corr ", x$call[[2]], " axes / coinertia axes", sep=""))
+ sumry[11, ] <- c("$aY", nrow(x$aY), ncol(x$aY), paste("Corr ", x$call[[3]], " axes / coinertia axes", sep=""))
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ cat(paste("CT rows = cols of ", x$call[[3]], " (", nrow(x$li), ") / CT cols = cols of ", x$call[[2]], " (", nrow(x$co),")", sep=""))
+ cat("\n")
+}
+
+"summary.coinertia" <- function (object, ...) {
+ if (!inherits(object, "coinertia"))
+ stop("to be used with 'coinertia' object")
+
+ thetitle <- "Coinertia analysis"
+ cat(thetitle)
+ cat("\n\n")
+ NextMethod()
+
+ appel <- as.list(object$call)
+ dudiX <- eval.parent(appel$dudiX)
+ dudiY <- eval.parent(appel$dudiY)
+ norm.w <- function(X, w) {
+ f2 <- function(v) sqrt(sum(v * v * w)/sum(w))
+ norm <- apply(X, 2, f2)
+ return(norm)
+ }
+ util <- function(n) {
+ x <- "1"
+ for (i in 2:n) x[i] <- paste(x[i - 1], i, sep = "")
+ return(x)
+ }
+ eig <- object$eig[1:object$nf]
+ covar <- sqrt(eig)
+ sdX <- norm.w(object$lX, dudiX$lw)
+ sdY <- norm.w(object$lY, dudiX$lw)
+ corr <- covar/sdX/sdY
+ U <- cbind.data.frame(eig, covar, sdX, sdY, corr)
+ row.names(U) <- as.character(1:object$nf)
+ res <- list(EigDec = U)
+ cat("Eigenvalues decomposition:\n")
+ print(U)
+ cat(paste("\nInertia & coinertia X (", deparse(appel$dudiX),"):\n", sep=""))
+ inertia <- cumsum(sdX^2)
+ max <- cumsum(dudiX$eig[1:object$nf])
+ ratio <- inertia/max
+ U <- cbind.data.frame(inertia, max, ratio)
+ row.names(U) <- util(object$nf)
+ res$InerX <- U
+ print(U)
+ cat(paste("\nInertia & coinertia Y (", deparse(appel$dudiY),"):\n", sep=""))
+ inertia <- cumsum(sdY^2)
+ max <- cumsum(dudiY$eig[1:object$nf])
+ ratio <- inertia/max
+ U <- cbind.data.frame(inertia, max, ratio)
+ row.names(U) <- util(object$nf)
+ res$InerY <- U
+ print(U)
+ RV <- sum(object$eig)/sqrt(sum(dudiX$eig^2))/sqrt(sum(dudiY$eig^2))
+ cat("\nRV:\n", RV, "\n")
+ res$RV <- RV
+ invisible(res)
+}
diff --git a/R/combine.4thcorner.R b/R/combine.4thcorner.R
new file mode 100644
index 0000000..07a99b4
--- /dev/null
+++ b/R/combine.4thcorner.R
@@ -0,0 +1,94 @@
+combine.4thcorner <- function(four1,four2){
+ if(!inherits(four1, "4thcorner") || !inherits(four2, "4thcorner") )
+ stop("objects must be of class '4thcorner'")
+ if(four1$call[[1]] != four2$call[[1]])
+ stop("can not combine objects created by different functions")
+ if(four1$call[[1]]=="fourthcorner.rlq"){
+ if(four1$call$xtest != four2$call$xtest)
+ stop("can not combine objects: different 'rlq' objects")
+ } else {
+ if(four1$call$tabR != four2$call$tabR)
+ stop("can not combine objects: different tables R")
+ if(four1$call$tabL != four2$call$tabL)
+ stop("can not combine objects: different tables L")
+ if(four1$call$tabQ != four2$call$tabQ)
+ stop("can not combine objects: different tables Q")
+ }
+
+ ## test longueur (i.e. meme tableaux pour lignes et colonnes)
+ ## test adjustment
+
+ res <- four1
+ ## For tabG
+ if(four1$tabG$adj.method != four2$tabG$adj.method)
+ stop("can not combine objects: diferent adjustment methods for tabG")
+ for(i in 1:length(res$tabG$names)){
+ idx <- ifelse(four2$tabG$adj.pvalue[i] > four1$tabG$adj.pvalue[i], 1, 2)
+ if(idx==1) {
+ tmp <- four2
+ } else if(idx==2){
+ tmp <- four1
+ }
+ res$tabG$expvar[i,] <- tmp$tabG$expvar[i,]
+ res$tabG$pvalue[i] <- tmp$tabG$pvalue[i]
+ res$tabG$adj.pvalue[i] <- tmp$tabG$adj.pvalue[i]
+ res$tabG$plot[[i]] <- tmp$tabG$plot[[i]]
+ if(!inherits(res$tabG, "lightkrandtest"))
+ res$tabG$sim[,i] <- tmp$tabG$sim[,i]
+ }
+ res$tabG$call <- match.call()
+
+ if(!inherits(res, "4thcorner.rlq")){
+ if(four1$tabD$adj.method != four2$tabD$adj.method)
+ stop("can not combine objects: diferent adjustment methods for tabD")
+ if(four1$tabD2$adj.method != four2$tabD2$adj.method)
+ stop("can not combine objects: diferent adjustment methods for tabD2")
+ for(i in 1:length(res$tabD$names)){
+ ## For tabD
+ idx <- ifelse(four2$tabD$adj.pvalue[i] > four1$tabD$adj.pvalue[i], 1, 2)
+ idx <- ifelse(is.na(idx), 1, idx) ## NA could occur in the case of factor with one level. In this case, return the first output
+ if(idx == 1) {
+ tmp <- four2
+ } else if(idx == 2){
+ tmp <- four1
+ }
+ res$tabD$expvar[i,] <- tmp$tabD$expvar[i,]
+ res$tabD$pvalue[i] <- tmp$tabD$pvalue[i]
+ res$tabD$adj.pvalue[i] <- tmp$tabD$adj.pvalue[i]
+ res$tabD$plot[[i]] <- tmp$tabD$plot[[i]]
+ if(!inherits(res$tabD, "lightkrandtest"))
+ res$tabD$sim[,i] <- tmp$tabD$sim[,i]
+
+ ## For tabD2
+ idx <- ifelse(four2$tabD2$adj.pvalue[i] > four1$tabD2$adj.pvalue[i], 1, 2)
+ if(idx==1) {
+ tmp <- four2
+ } else if(idx==2){
+ tmp <- four1
+ }
+ res$tabD2$expvar[i,] <- tmp$tabD2$expvar[i,]
+ res$tabD2$pvalue[i] <- tmp$tabD2$pvalue[i]
+ res$tabD2$adj.pvalue[i] <- tmp$tabD2$adj.pvalue[i]
+ res$tabD2$plot[[i]] <- tmp$tabD2$plot[[i]]
+ if(!inherits(res$tabD2, "lightkrandtest"))
+ res$tabD2$sim[,i] <- tmp$tabD2$sim[,i]
+ }
+ res$tabD2$call <- res$tabD$call <- match.call()
+ } else {
+ ## For trRLQ
+ idx <- ifelse(four2$trRLQ$pvalue > four1$trRLQ$pvalue, 1, 2)
+ if(idx==1) {
+ tmp <- four2
+ } else if(idx==2){
+ tmp <- four1
+ }
+ res$trRLQ <- tmp$trRLQ
+ res$trRLQ$call <- match.call()
+ }
+
+ res$call <- match.call()
+ res$model <- paste("Comb.", four1$model, "and", four2$model)
+ class(res) <- c(class(res), "combine")
+ return(res)
+
+}
diff --git a/R/corkdist.R b/R/corkdist.R
new file mode 100644
index 0000000..0e75374
--- /dev/null
+++ b/R/corkdist.R
@@ -0,0 +1,176 @@
+########## mantelkdist ###############
+########## RVkdist ###################
+########## print.corkdist ############
+########## summary.corkdist ##########
+########## plot.corkdist #############
+
+"mantelkdist" <- function(kd, nrepet = 999, ...) {
+ if (!inherits(kd,"kdist")) stop ("Object of class 'kdist' expected")
+ res <- list()
+ ndist <- length(kd)
+ nind <- attr(kd, "size")
+ if (nrepet<=99) nrepet <- 99
+ w <- matrix(0,ndist,ndist)
+ numrow <- row(w)[row(w)>col(w)]
+ numcol <- col(w)[row(w)>col(w)]
+ w <- cbind.data.frame(I = numrow,J = numcol)
+ numrow <- attr(kd, "names")[numrow]
+ numcol <- attr(kd, "names")[numcol]
+ cha <- paste(numrow,numcol,sep="-")
+ row.names(w) <- cha
+ attr(res,"design") <- w
+
+ kdistelem2dist <- function (i) {
+ m1 <- matrix(0, nind, nind)
+ m1[row(m1) > col(m1)] <- kd[[i]]
+ m1 <- m1 + t(m1)
+ m1 <- as.dist(m1)
+ m1
+ }
+ k <- 0
+ for(i in 1:(ndist-1)) {
+ m1 <- kdistelem2dist(i)
+ for(j in (i+1):ndist) {
+ m2 <- kdistelem2dist(j)
+ k <- k+1
+ w <- mantel.randtest (m1, m2, nrepet, ...)
+ w$call <- match.call()
+ res[[k]] <- w
+ }
+ }
+ names (res) <- cha
+ attr (res,"call") <- match.call()
+ attr (res,"test") <- "Mantel's tests"
+ class(res) <- c("corkdist","list")
+ return(res)
+}
+
+"RVkdist" <- function(kd, nrepet = 999, ...) {
+ if (!inherits(kd,"kdist")) stop ("Object of class 'kdist' expected")
+ if (any(!attr(kd,"euclid"))) stop ("Euclidean matrices expected")
+ res=list()
+ ndist <- length(kd)
+ nind <- attr(kd, "size")
+ if (nrepet<=99) nrepet <- 99
+ w <- matrix(0,ndist,ndist)
+ numrow <- row(w)[row(w)>col(w)]
+ numcol <- col(w)[row(w)>col(w)]
+ w <- cbind.data.frame(I = numrow,J = numcol)
+ numrow <- attr(kd, "names")[numrow]
+ numcol <- attr(kd, "names")[numcol]
+ cha <- paste(numrow,numcol,sep="-")
+ row.names(w) <- cha
+ attr(res,"design") <- w
+
+ kdistelem2dist <- function (i) {
+ m1 <- matrix(0, nind, nind)
+ m1[row(m1) > col(m1)] <- kd[[i]]
+ m1 <- m1 + t(m1)
+ m1 <- as.dist(m1)
+ m1
+ }
+ k <- 0
+ for(i in 1:(ndist-1)) {
+ m1 <- kdistelem2dist(i)
+ for(j in (i+1):ndist) {
+ m2 <- kdistelem2dist(j)
+ k <- k+1
+ w <- RVdist.randtest (m1, m2, nrepet, ...)
+ w$call <- match.call()
+ res[[k]] <- w
+ }
+ }
+ names (res) <- cha
+ attr (res,"call") <- match.call()
+ attr (res,"test") <- "RV tests"
+ class(res) <- c("corkdist","list")
+ return(res)
+}
+
+"print.corkdist" <- function (x, ...) {
+ if (!inherits(x,"corkdist")) stop ("Object 'corkdist' expected")
+ cat(attr (x,"test"),"for 'kdist' object\n")
+ cat("class: ") ; cat(class(x),"\n")
+ cat ("Call: ") ; print(attr (x,"call"))
+ cat("\n") ; cat(names(x)[1],"\n")
+ print.randtest (x[[1]])
+ if (length(x)>2) {
+ cat("\n") ; cat(names(x)[2],"\n")
+ print.randtest (x[[2]])
+ }
+ if (length(x)==3) {
+ cat("\n") ; cat(names(x)[3],"\n")
+ print.randtest (x[[3]])
+ }
+ if (length(x)>3) {
+ cat("...\n")
+ }
+ cat("list of",length (x), "'randtest' objects\n")
+}
+
+summary.corkdist <- function (object, ...) {
+ if (!inherits(object,"corkdist")) stop ("Object 'corkdist' expected")
+ design <- attr(object, "design")
+ cat(attr (object,"test"),"for 'kdist' object\n")
+ cat ("Call: ") ; print(attr (object,"call"))
+ ndig0 <- nchar(as.character(as.integer(object[[1]]$rep)))
+ pval <- round(unlist(lapply(object, function(x) x$pvalue)), digits = ndig0)
+ ndist <- max(design$I)
+ res <- matrix(0,ndist,ndist)
+ res[row(res) <= col(res)] <- NA
+ dist.names <- names(eval.parent(as.list(attr(object,"call"))$kd))
+ dimnames(res) <- list(dist.names, as.character(1:length(dist.names)))
+ res[row(res) > col(res)] <- pval
+ cat("Simulated p-values:\n")
+ print(res, na = "-", ...)
+}
+
+
+plot.corkdist <- function (x, whichinrow = NULL, whichincol = NULL, gap = 4, nclass = 10, ...) {
+
+ kdistelem2delta <- function (i) {
+ m1 <- matrix(0, nind, nind)
+ m1[row(m1) > col(m1)] <- kd[[i]]
+ m1 <- m1 + t(m1)
+ m1 <- -m1*m1/2
+ m1 <- bicenter.wt(m1)
+ return(m1[row(m1) > col(m1)])
+ }
+
+ if (!inherits(x,"corkdist")) stop ("Object of class 'corkdist' expected")
+ kd <- eval.parent(as.list(attr(x,"call"))$kd)
+ design <- attr(x, "design")
+ ndist <- length (kd)
+ if (is.null(whichinrow)) whichinrow <- 1:ndist
+ if (is.null(whichincol)) whichincol <- 1:ndist
+ labels = names(kd)
+ nind <- attr(kd, "size")
+ old.par <- par(no.readonly = TRUE)
+ on.exit(par(old.par))
+ oma <- c(2, 2, 1, 1)
+ par(mfrow = c(length(whichinrow), length(whichincol)), mar = rep(gap/2, 4), oma = oma)
+ for (i in whichinrow) {
+ for (j in whichincol) {
+ if (i==j) {
+ plot.default(0,0,type="n",asp=1, xlab="", ylab="",xaxt="n",yaxt="n",
+ xlim=c(0,1), ylim=c(0,1), xaxs="i", yaxs="i", frame.plot=FALSE)
+ l.wid <- strwidth(labels, "user")
+ cex.labels <- max(0.8, min(2, 0.9/max(l.wid)))
+ text(0.5, 0.5, labels[i], cex = cex.labels, font = 1)
+ } else if (i>j) {
+ n0 <- (1:nrow(design))[design$I==i & design$J==j]
+ titre <- row.names(design)[n0]
+ plot(x[[n0]], main = titre, nclass = nclass)
+ } else if (j>i) {
+ if (attr(x,"test")=="Mantel's tests")
+ plot(kd[[i]],kd[[j]])
+ else {
+ plot(kdistelem2delta(i),kdistelem2delta(j))
+
+ }
+ }
+ }
+ }
+}
+
+
diff --git a/R/costatis.R b/R/costatis.R
new file mode 100755
index 0000000..37fb06b
--- /dev/null
+++ b/R/costatis.R
@@ -0,0 +1,101 @@
+"costatis" <- function (KTX, KTY, scannf = TRUE) {
+####
+#### COSTATIS analysis
+#### coinertia analysis of the compromises of two ktabs
+#### Jean Thioulouse, 06 Nov 2009
+#### This function takes 2 ktabs. It does a partial triadic analysis on each ktab,
+#### and does a coinertia analysis on the compromises of the PTAs.
+####
+ normalise.w <- function(X, w) {
+ # Correction d'un bug signale par Sandrine Pavoine le 21/10/2006
+ f2 <- function(v) sqrt(sum(v * v * w))
+ norm <- apply(X, 2, f2)
+ X <- sweep(X, 2, norm, "/")
+ return(X)
+ }
+ if (!inherits(KTX, "ktab")) stop("The first argument must be a 'ktab'")
+ if (!inherits(KTY, "ktab")) stop("The second argument must be a 'ktab'")
+#### Parameters of first ktab
+ lwX <- KTX$lw
+ cwX <- KTX$cw
+ ncolX <- length(cwX)
+ bloX <- KTX$blo
+ ntabX <- length(KTX$blo)
+#### Parameters of second ktab
+ lwY <- KTY$lw
+ nligY <- length(lwY)
+ cwY <- KTY$cw
+ ncolY <- length(cwY)
+ bloY <- KTY$blo
+ ntabY <- length(KTY$blo)
+#### Tests of coherence of the two ktabs
+ if (ncolX != ncolY) stop("The two ktabs must have the same column numbers")
+ if (any(cwX != cwY)) stop("The two ktabs must have the same column weights")
+ if (ntabX != ntabY) stop("The two ktabs must have the same number of tables")
+ if (!all(bloX == bloY)) stop("The two tables of one pair must have the same number of columns")
+#### pta on KTX
+ if (scannf) cat("PTA of first KTab\n")
+ ptaX <- pta(KTX, scannf = scannf)
+#### pta on KTY
+ if (scannf) cat("PTA of second KTab\n")
+ ptaY <- pta(KTY, scannf = scannf)
+#### coinertia analysis of compromises
+ acpX=dudi.pca(t(ptaX$tab), center=FALSE, scannf=FALSE, nf=ptaX$nf)
+ acpY=dudi.pca(t(ptaY$tab), center=FALSE, scannf=FALSE, nf=ptaY$nf)
+ if (scannf) cat("Coinertia analysis of the two compromises\n")
+ res <- coinertia(acpX, acpY, scannf = scannf)
+#### projection of the rows of the two original ktables
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ supIX <- normalise.w(t(as.matrix(KTX[[1]])) %*% U, acpX$lw)
+ for (i in 2:ntabX) {
+ supIX <- rbind(supIX, normalise.w(as.matrix(t(KTX[[i]])) %*% U, acpX$lw))
+ }
+ row.names(supIX) <- paste(KTX$TC[,1],KTX$TC[,2], sep="")
+ res$supIX <- as.data.frame(supIX)
+ names(res$supIX) <- paste("XNorS", (1:res$nf), sep = "")
+
+ U <- as.matrix(res$l1) * unlist(res$lw)
+ supIY <- normalise.w(t(as.matrix(KTY[[1]])) %*% U, acpY$lw)
+ for (i in 2:ntabY) {
+ supIY <- rbind(supIY, normalise.w(as.matrix(t(KTY[[i]])) %*% U, acpY$lw))
+ }
+ row.names(supIY) <- paste(KTY$TC[,1],KTY$TC[,2], sep="")
+ res$supIY <- as.data.frame(supIY)
+ names(res$supIY) <- paste("YNorS", (1:res$nf), sep = "")
+
+# class(res) <- c("costatis", class(res))
+ return(res)
+}
+
+"costatis.randtest" <- function (KTX, KTY, nrepet = 999, ...) {
+ if (!inherits(KTX, "ktab")) stop("The first argument must be a 'ktab'")
+ if (!inherits(KTY, "ktab")) stop("The second argument must be a 'ktab'")
+#### Parameters of first ktab
+ lwX <- KTX$lw
+ cwX <- KTX$cw
+ ncolX <- length(cwX)
+ bloX <- KTX$blo
+ ntabX <- length(KTX$blo)
+#### Parameters of second ktab
+ lwY <- KTY$lw
+ nligY <- length(lwY)
+ cwY <- KTY$cw
+ ncolY <- length(cwY)
+ bloY <- KTY$blo
+ ntabY <- length(KTY$blo)
+#### Tests of coherence of the two ktabs
+ if (ncolX != ncolY) stop("The two ktabs must have the same column numbers")
+ if (any(cwX != cwY)) stop("The two ktabs must have the same column weights")
+ if (ntabX != ntabY) stop("The two ktabs must have the same number of tables")
+ if (!all(bloX == bloY)) stop("The two tables of one pair must have the same number of columns")
+#### pta on KTX
+ ptaX <- pta(KTX, scannf = FALSE)
+#### pta on KTY
+ ptaY <- pta(KTY, scannf = FALSE)
+#### coinertia analysis of compromises
+ acpX=dudi.pca(t(ptaX$tab), center=FALSE, scannf=FALSE, nf=ptaX$nf)
+ acpY=dudi.pca(t(ptaY$tab), center=FALSE, scannf=FALSE, nf=ptaY$nf)
+ res <- coinertia(acpX, acpY, scannf = FALSE)
+ rtest1 <- randtest(res, nrepet = nrepet, ...)
+ return(rtest1)
+}
diff --git a/R/disc.R b/R/disc.R
new file mode 100644
index 0000000..78b79cb
--- /dev/null
+++ b/R/disc.R
@@ -0,0 +1,68 @@
+disc <- function(samples, dis = NULL, structures=NULL){
+ # checking of user's data and initialization.
+ if (!inherits(samples, "data.frame")) stop("Non convenient samples")
+ if (any(samples < 0)) stop("Negative value in samples")
+ if (any(apply(samples, 2, sum) < 1e-16)) stop("Empty samples")
+ if (!is.null(dis)) {
+ if (!inherits(dis, "dist")) stop("Object of class 'dist' expected for distance")
+ if (!is.euclid(dis)) stop("Euclidean property is expected for distance")
+ dis <- as.matrix(dis)
+ if (nrow(samples)!= nrow(dis)) stop("Non convenient samples")
+ }
+ if (is.null(dis)) dis <- (matrix(1, nrow(samples), nrow(samples)) - diag(rep(1, nrow(samples)))) * sqrt(2)
+ if (!is.null(structures)){
+ if (!inherits(structures, "data.frame")) stop("Non convenient structures")
+ m <- match(apply(structures, 2, function(x) length(x)), ncol(samples), 0 )
+ if (length(m[m == 1]) != ncol(structures)) stop ("Non convenient structures")
+ m <- match(tapply(1:ncol(structures), as.factor(1:ncol(structures)), function(x) is.factor(structures[, x])), TRUE , 0)
+ if(length(m[m == 1]) != ncol(structures)) stop ("Non convenient structures")
+ }
+ # Intern functions :
+ ##Diversity <- function(d2, nbhaplotypes, freq) {
+ ## div <- nbhaplotypes/2*(t(freq)%*%d2%*%freq)
+ ##}
+ Structutil <- function(dp2, Np, unit){
+ if (!is.null(unit)) {
+ modunit <- model.matrix(~ -1 + unit)
+ sumcol <- apply(Np, 2, sum)
+ Ng <- modunit * sumcol
+ lesnoms <- levels(unit)
+ }
+ else{
+ Ng <- as.matrix(Np)
+ lesnoms <- colnames(Np)
+ }
+ sumcol <- apply(Ng, 2, sum)
+ Lg <- t(t(Ng) / sumcol)
+ colnames(Lg) <- lesnoms
+ Pg <- as.matrix(apply(Ng, 2, sum) / nbhaplotypes)
+ rownames(Pg) <- lesnoms
+ deltag <- as.matrix(apply(Lg, 2, function(x) t(x) %*% dp2 %*% x))
+ ug <- matrix(1, ncol(Lg), 1)
+ dg2 <- t(Lg) %*% dp2 %*% Lg - 1 / 2 * (deltag %*% t(ug) + ug %*% t(deltag))
+ colnames(dg2) <- lesnoms
+ rownames(dg2) <- lesnoms
+ return(list(dg2 = dg2, Ng = Ng, Pg = Pg))
+ }
+ Diss <- function(dis, nbhaplotypes, samples, structures){
+ structutil <- list(0)
+ structutil[[1]] <- Structutil(dp2 = dis, Np = samples, NULL)
+ diss <- list(sqrt(as.dist(structutil[[1]]$dg2)))
+ if(!is.null(structures)){
+ for(i in 1:length(structures)){
+ structutil[[i+1]] <- Structutil(structutil[[1]]$dg2, structutil[[1]]$Ng, structures[,i])
+ }
+ diss <- c(diss, tapply(1:length(structures), factor(1:length(structures)), function(x) sqrt(as.dist(structutil[[x + 1]]$dg2))))
+ }
+ return(diss)
+ }
+ # main procedure.
+ nbhaplotypes <- sum(samples)
+ diss <- Diss(dis^2, nbhaplotypes, samples, structures)
+ names(diss) <- c("samples", names(structures))
+ # Interface.
+ if (!is.null(structures)) {
+ return(diss)
+ }
+ return(diss$samples)
+}
diff --git a/R/discrimin.R b/R/discrimin.R
new file mode 100644
index 0000000..5348081
--- /dev/null
+++ b/R/discrimin.R
@@ -0,0 +1,134 @@
+"discrimin" <- function (dudi, fac, scannf = TRUE, nf = 2) {
+ if (!inherits(dudi, "dudi"))
+ stop("Object of class dudi expected")
+ if (!is.factor(fac))
+ stop("factor expected")
+ lig <- nrow(dudi$tab)
+ if (length(fac) != lig)
+ stop("Non convenient dimension")
+ rank <- dudi$rank
+ dudi <- redo.dudi(dudi, rank)
+ deminorm <- as.matrix(dudi$c1) * dudi$cw
+ deminorm <- t(t(deminorm)/sqrt(dudi$eig))
+ cla.w <- tapply(dudi$lw, fac, sum)
+ mean.w <- function(x) {
+ z <- x * dudi$lw
+ z <- tapply(z, fac, sum)/cla.w
+ return(z)
+ }
+ tabmoy <- apply(dudi$l1, 2, mean.w)
+ tabmoy <- data.frame(tabmoy)
+ row.names(tabmoy) <- levels(fac)
+ cla.w <- cla.w/sum(cla.w)
+ X <- as.dudi(tabmoy, rep(1, rank), as.vector(cla.w), scannf = scannf,
+ nf = nf, call = match.call(), type = "dis")
+ res <- list()
+ res$eig <- X$eig
+ res$nf <- X$nf
+ res$fa <- deminorm %*% as.matrix(X$c1)
+ res$li <- as.matrix(dudi$tab) %*% res$fa
+ w <- scalewt(dudi$tab, dudi$lw)
+ res$va <- t(as.matrix(w)) %*% (res$li * dudi$lw)
+ res$cp <- t(as.matrix(dudi$l1)) %*% (dudi$lw * res$li)
+ res$fa <- data.frame(res$fa)
+ row.names(res$fa) <- names(dudi$tab)
+ names(res$fa) <- paste("DS", 1:X$nf, sep = "")
+ res$li <- data.frame(res$li)
+ row.names(res$li) <- row.names(dudi$tab)
+ names(res$li) <- names(res$fa)
+ w <- apply(res$li, 2, mean.w)
+ res$gc <- data.frame(w)
+ row.names(res$gc) <- as.character(levels(fac))
+ names(res$gc) <- names(res$fa)
+ res$cp <- data.frame(res$cp)
+ row.names(res$cp) <- names(dudi$l1)
+ names(res$cp) <- names(res$fa)
+ res$call <- match.call()
+ class(res) <- "discrimin"
+ return(res)
+}
+
+"plot.discrimin" <- function (x, xax = 1, yax = 2, ...) {
+ if (!inherits(x, "discrimin"))
+ stop("Use only with 'discrimin' objects")
+ if ((x$nf == 1) || (xax == yax)) {
+ if (inherits(x, "coadisc")) {
+ appel <- as.list(x$call)
+ df <- eval.parent(appel$df)
+ fac <- eval.parent(appel$fac)
+ lig <- nrow(df)
+ if (length(fac) != lig)
+ stop("Non convenient dimension")
+ lig.w <- apply(df, 1, sum)
+ lig.w <- lig.w/sum(lig.w)
+ cla.w <- as.vector(tapply(lig.w, fac, sum))
+ mean.w <- function(x) {
+ z <- x * lig.w
+ z <- tapply(z, fac, sum)/cla.w
+ return(z)
+ }
+ w <- apply(df, 2, mean.w)
+ w <- data.frame(t(w))
+ sco.distri(x$fa[, xax], w, clabel = 1, xlim = NULL,
+ grid = TRUE, cgrid = 1, include.origin = TRUE, origin = 0,
+ sub = NULL, csub = 1)
+ return(invisible())
+ }
+ appel <- as.list(x$call)
+ dudi <- eval.parent(appel$dudi)
+ fac <- eval.parent(appel$fac)
+ lig <- nrow(dudi$tab)
+ if (length(fac) != lig)
+ stop("Non convenient dimension")
+ sco.quant(x$li[, 1], dudi$tab, fac = fac)
+ return(invisible())
+ }
+ if (xax > x$nf)
+ stop("Non convenient xax")
+ if (yax > x$nf)
+ stop("Non convenient yax")
+ fac <- eval.parent(as.list(x$call)$fac)
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3),
+ respect = TRUE)
+ par(mar = c(0.2, 0.2, 0.2, 0.2))
+ s.arrow(x$fa, xax = xax, yax = yax, sub = "Canonical weights",
+ csub = 2, clabel = 1.25)
+ s.corcircle(x$va, xax = xax, yax = yax, sub = "Cos(variates,canonical variates)",
+ csub = 2, cgrid = 0, clabel = 1.25)
+ scatterutil.eigen(x$eig, wsel = c(xax, yax))
+ s.class(x$li, fac, xax = xax, yax = yax, sub = "Scores and classes",
+ csub = 2, clabel = 1.5)
+ s.corcircle(x$cp, xax = xax, yax = yax, sub = "Cos(components,canonical variates)",
+ csub = 2, cgrid = 0, clabel = 1.25)
+ s.label(x$gc, xax = xax, yax = yax, sub = "Class scores",
+ csub = 2, clabel = 1.25)
+}
+
+"print.discrimin" <- function (x, ...) {
+ if (!inherits(x, "discrimin"))
+ stop("to be used with 'discrimin' object")
+ cat("Discriminant analysis\n")
+ cat("call: ")
+ print(x$call)
+ cat("class: ")
+ cat(class(x), "\n")
+ cat("\n$nf (axis saved) :", x$nf)
+ cat("\n\neigen values: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n\n")
+ else cat("\n\n")
+ sumry <- array("", c(5, 4), list(1:5, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$fa", nrow(x$fa), ncol(x$fa), "loadings / canonical weights")
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "canonical scores")
+ sumry[3, ] <- c("$va", nrow(x$va), ncol(x$va), "cos(variables, canonical scores)")
+ sumry[4, ] <- c("$cp", nrow(x$cp), ncol(x$cp), "cos(components, canonical scores)")
+ sumry[5, ] <- c("$gc", nrow(x$gc), ncol(x$gc), "class scores")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+}
diff --git a/R/discrimin.coa.R b/R/discrimin.coa.R
new file mode 100644
index 0000000..57f9e50
--- /dev/null
+++ b/R/discrimin.coa.R
@@ -0,0 +1,68 @@
+"discrimin.coa" <- function (df, fac, scannf = TRUE, nf = 2) {
+ if (!is.factor(fac))
+ stop("factor expected")
+ lig <- nrow(df)
+ if (length(fac) != lig)
+ stop("Non convenient dimension")
+ dudi.coarp <- function(df) {
+ if (!is.data.frame(df))
+ stop("data.frame expected")
+ if (any(df < 0))
+ stop("negative entries in table")
+ if ((N <- sum(df)) == 0)
+ stop("all frequencies are zero")
+ df <- df/N
+ row.w <- apply(df, 1, sum)
+ col.w <- apply(df, 2, sum)
+ if (any(col.w == 0))
+ stop("null column found in data")
+ df <- df/row.w
+ df <- sweep(df, 2, col.w)
+ X <- as.dudi(df, 1/col.w, row.w, scannf = FALSE, nf = 2,
+ call = match.call(), type = "coarp", full = TRUE)
+ X$N <- N
+ class(X) <- "dudi"
+ return(X)
+ }
+ dudi <- dudi.coarp(df)
+ rank <- dudi$rank
+ deminorm <- as.matrix(dudi$c1) * dudi$cw
+ deminorm <- t(t(deminorm)/sqrt(dudi$eig))
+ cla.w <- as.vector(tapply(dudi$lw, fac, sum))
+ mean.w <- function(x) {
+ z <- x * dudi$lw
+ z <- tapply(z, fac, sum)/cla.w
+ return(z)
+ }
+ tabmoy <- apply(dudi$l1, 2, mean.w)
+ tabmoy <- data.frame(tabmoy)
+ row.names(tabmoy) <- levels(fac)
+ X <- as.dudi(tabmoy, rep(1, rank), cla.w, scannf = scannf,
+ nf = nf, call = match.call(), type = "dis")
+ res <- list(eig = X$eig)
+ res$nf <- X$nf
+ res$fa <- deminorm %*% as.matrix(X$c1)
+ res$li <- as.matrix(dudi$tab) %*% res$fa
+ w <- scalewt(dudi$tab, dudi$lw)
+ res$va <- t(as.matrix(w)) %*% (res$li * dudi$lw)
+ res$cp <- t(as.matrix(dudi$l1)) %*% (dudi$lw * res$li)
+ res$fa <- data.frame(res$fa)
+ row.names(res$fa) <- names(dudi$tab)
+ names(res$fa) <- paste("DS", 1:X$nf, sep = "")
+ res$li <- data.frame(res$li)
+ row.names(res$li) <- row.names(dudi$tab)
+ names(res$li) <- names(res$fa)
+ w <- apply(res$li, 2, mean.w)
+ res$gc <- data.frame(w)
+ row.names(res$gc) <- as.character(levels(fac))
+ names(res$gc) <- names(res$fa)
+ res$va <- data.frame(res$va)
+ row.names(res$va) <- names(dudi$tab)
+ names(res$va) <- names(res$fa)
+ res$cp <- data.frame(res$cp)
+ row.names(res$cp) <- names(dudi$l1)
+ names(res$cp) <- names(res$fa)
+ res$call <- match.call()
+ class(res) <- c("coadisc", "discrimin")
+ return(res)
+}
diff --git a/R/dist.binary.R b/R/dist.binary.R
new file mode 100644
index 0000000..3291544
--- /dev/null
+++ b/R/dist.binary.R
@@ -0,0 +1,94 @@
+"dist.binary" <- function (df, method = NULL, diag = FALSE, upper = FALSE) {
+ METHODS <- c("JACCARD S3", "SOCKAL & MICHENER S4", "SOCKAL & SNEATH S5",
+ "ROGERS & TANIMOTO S6", "CZEKANOWSKI S7", "GOWER & LEGENDRE S9", "OCHIAI S12", "SOKAL & SNEATH S13",
+ "Phi of PEARSON S14", "GOWER & LEGENDRE S2")
+ if (!(inherits(df, "data.frame") | inherits(df, "matrix")))
+ stop("df is not a data.frame or a matrix")
+ df <- as.matrix(df)
+ if(!is.numeric(df))
+ stop("df must contain numeric values")
+ if (any(df < 0))
+ stop("non negative value expected in df")
+ nlig <- nrow(df)
+ d.names <- row.names(df)
+ if(is.null(d.names))
+ d.names <- 1:nlig
+ nlig <- nrow(df)
+ df <- as.matrix(1 * (df > 0))
+ if (is.null(method)) {
+ cat("1 = JACCARD index (1901) S3 coefficient of GOWER & LEGENDRE\n")
+ cat("s1 = a/(a+b+c) --> d = sqrt(1 - s)\n")
+ cat("2 = SOCKAL & MICHENER index (1958) S4 coefficient of GOWER & LEGENDRE \n")
+ cat("s2 = (a+d)/(a+b+c+d) --> d = sqrt(1 - s)\n")
+ cat("3 = SOCKAL & SNEATH(1963) S5 coefficient of GOWER & LEGENDRE\n")
+ cat("s3 = a/(a+2(b+c)) --> d = sqrt(1 - s)\n")
+ cat("4 = ROGERS & TANIMOTO (1960) S6 coefficient of GOWER & LEGENDRE\n")
+ cat("s4 = (a+d)/(a+2(b+c)+d) --> d = sqrt(1 - s)\n")
+ cat("5 = CZEKANOWSKI (1913) or SORENSEN (1948) S7 coefficient of GOWER & LEGENDRE\n")
+ cat("s5 = 2*a/(2*a+b+c) --> d = sqrt(1 - s)\n")
+ cat("6 = S9 index of GOWER & LEGENDRE (1986)\n")
+ cat("s6 = (a-(b+c)+d)/(a+b+c+d) --> d = sqrt(1 - s)\n")
+ cat("7 = OCHIAI (1957) S12 coefficient of GOWER & LEGENDRE\n")
+ cat("s7 = a/sqrt((a+b)(a+c)) --> d = sqrt(1 - s)\n")
+ cat("8 = SOKAL & SNEATH (1963) S13 coefficient of GOWER & LEGENDRE\n")
+ cat("s8 = ad/sqrt((a+b)(a+c)(d+b)(d+c)) --> d = sqrt(1 - s)\n")
+ cat("9 = Phi of PEARSON = S14 coefficient of GOWER & LEGENDRE\n")
+ cat("s9 = ad-bc)/sqrt((a+b)(a+c)(b+d)(d+c)) --> d = sqrt(1 - s)\n")
+ cat("10 = S2 coefficient of GOWER & LEGENDRE\n")
+ cat("s10 = a/(a+b+c+d) --> d = sqrt(1 - s) and unit self-similarity\n")
+ cat("Select an integer (1-10): ")
+ method <- as.integer(readLines(n = 1))
+ }
+
+ a <- df %*% t(df)
+ b <- df %*% (1 - t(df))
+ c <- (1 - df) %*% t(df)
+ d <- ncol(df) - a - b - c
+
+ if (method == 1) {
+ d <- a/(a + b + c)
+ }
+ else if (method == 2) {
+ d <- (a + d)/(a + b + c + d)
+ }
+ else if (method == 3) {
+ d <- a/(a + 2 * (b + c))
+ }
+ else if (method == 4) {
+ d <- (a + d)/(a + 2 * (b + c) + d)
+ }
+ # correction d'un bug signalé par Christian Düring <c.duering at web.de>
+ else if (method == 5) {
+ d <- 2*a/(2 * a + b + c)
+ }
+ else if (method == 6) {
+ d <- (a - (b + c) + d)/(a + b + c + d)
+
+ }
+ else if (method == 7) {
+ d <- a/sqrt((a+b)*(a+c))
+ }
+ else if (method == 8) {
+ d <- a * d/sqrt((a + b) * (a + c) * (d + b) * (d + c))
+ }
+ else if (method == 9) {
+ d <- (a * d - b * c)/sqrt((a + b) * (a + c) * (b + d) *
+ (d + c))
+ }
+ else if (method == 10) {
+ d <- a/(a + b + c + d)
+ diag(d) <- 1
+ }
+ else stop("Non convenient method")
+ d <- sqrt(1 - d)
+ # if (sum(diag(d)^2)>0) stop("diagonale non nulle")
+ d <- as.dist(d)
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- diag
+ attr(d, "Upper") <- upper
+ attr(d, "method") <- METHODS[method]
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+}
diff --git a/R/dist.dudi.R b/R/dist.dudi.R
new file mode 100644
index 0000000..f783ae5
--- /dev/null
+++ b/R/dist.dudi.R
@@ -0,0 +1,30 @@
+"dist.dudi" <- function (dudi, amongrow = TRUE) {
+ if (!inherits(dudi, "dudi"))
+ stop("Object of class 'dudi' expected")
+ if (amongrow) {
+ x <- t(t(dudi$tab) * sqrt(dudi$cw))
+ x <- x %*% t(x)
+ y <- diag(x)
+ x <- (-2) * x + y
+ x <- t(t(x) + y)
+ x <- (x + t(x))/2
+ diag(x) <- 0
+ x <- as.dist(sqrt(abs(x)))
+ attr(x, "Labels") <- row.names(dudi$tab)
+ attr(x, "method") <- "DUDI"
+ return(x)
+ }
+ else {
+ x <- as.matrix(dudi$tab) * sqrt(dudi$lw)
+ x <- t(x) %*% x
+ y <- diag(x)
+ x <- (-2) * x + y
+ x <- t(t(x) + y)
+ x <- (x + t(x))/2
+ diag(x) <- 0
+ x <- as.dist(sqrt(abs(x)))
+ attr(x, "Labels") <- names(dudi$tab)
+ attr(x, "method") <- "DUDI"
+ return(x)
+ }
+}
diff --git a/R/dist.genet.R b/R/dist.genet.R
new file mode 100644
index 0000000..452db5b
--- /dev/null
+++ b/R/dist.genet.R
@@ -0,0 +1,104 @@
+"dist.genet" <- function (genet, method = 1, diag = FALSE, upper = FALSE) {
+ METHODS = c("Nei","Edwards","Reynolds","Rodgers","Provesti")
+ if (all((1:5)!=method)) {
+ cat("1 = Nei 1972\n")
+ cat("2 = Edwards 1971\n")
+ cat("3 = Reynolds, Weir and Coockerman 1983\n")
+ cat("4 = Rodgers 1972\n")
+ cat("5 = Provesti 1975\n")
+ cat("Select an integer (1-5): ")
+ method <- as.integer(readLines(n = 1))
+ }
+ if (all((1:5)!=method)) (stop ("Non convenient method number"))
+ if (!inherits(genet,"genet"))
+ stop("list of class 'genet' expected")
+ df <- genet$tab
+ col.blocks <- genet$loc.blocks
+ nloci <- length(col.blocks)
+ d.names <- genet$pop.names
+ nlig <- nrow(df)
+
+ if (is.null(names(col.blocks))) {
+ names(col.blocks) <- paste("L", as.character(1:nloci), sep = "")
+ }
+ f1 <- function(x) {
+ a <- sum(x)
+ if (is.na(a))
+ return(rep(0, length(x)))
+ if (a == 0)
+ return(rep(0, length(x)))
+ return(x/a)
+ }
+ k2 <- 0
+ for (k in 1:nloci) {
+ k1 <- k2 + 1
+ k2 <- k2 + col.blocks[k]
+ X <- df[, k1:k2]
+ X <- t(apply(X, 1, f1))
+ X.marge <- apply(X, 1, sum)
+ if (any(sum(X.marge)==0)) stop ("Null row found")
+ X.marge <- X.marge/sum(X.marge)
+ df[, k1:k2] <- X
+ }
+ # df contient un tableau de fréquence
+ df <- as.matrix(df)
+ if (method == 1) {
+ d <- df%*%t(df)
+ vec <- sqrt(diag(d))
+ d <- d/vec[col(d)]
+ d <- d/vec[row(d)]
+ d <- -log(d)
+ d <- as.dist(d)
+ } else if (method == 2) {
+ df <- sqrt(df)
+ d <- df%*%t(df)
+ d <- 1-d/nloci
+ diag(d) <- 0
+ d <- sqrt(d)
+ d <- as.dist(d)
+ } else if (method == 3) {
+ denomi <- df%*%t(df)
+ vec <- apply(df,1,function(x) sum(x*x))
+ d <- -2*denomi + vec[col(denomi)] + vec[row(denomi)]
+ diag(d) <- 0
+ denomi <- 2*nloci - 2*denomi
+ diag(denomi) <- 1
+ d <- d/denomi
+ d <- sqrt(d)
+ d <- as.dist(d)
+ } else if (method == 4) {
+ loci.fac <- rep( names(col.blocks),col.blocks)
+ loci.fac <- as.factor(loci.fac)
+ ltab <- lapply(split(df,loci.fac[col(df)]),matrix,nrow=nlig)
+ "dcano" <- function (mat) {
+ daux <- mat%*%t(mat)
+ vec <- diag(daux)
+ daux <- -2*daux+vec[col(daux)]
+ daux <- daux + vec[row(daux)]
+ diag(daux) <- 0
+ daux <- sqrt(daux/2)
+ d <<- d+daux
+ }
+ d <- matrix(0,nlig,nlig)
+ lapply(ltab, dcano)
+ d <- d/length(ltab)
+ d <- as.dist(d)
+ } else if (method ==5) {
+ w0 <- 1:(nlig-1)
+ "loca" <- function (k) {
+ w1 <- (k+1):nlig
+ resloc <- unlist(lapply(w1, function(x) sum(abs(df[k,]-df[x,]))))
+ return(resloc/2/nloci)
+ }
+ d <- unlist(lapply(w0,loca))
+ }
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- diag
+ attr(d, "Upper") <- upper
+ attr(d, "method") <- METHODS[method]
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+
+}
diff --git a/R/dist.ktab.R b/R/dist.ktab.R
new file mode 100644
index 0000000..0639ed6
--- /dev/null
+++ b/R/dist.ktab.R
@@ -0,0 +1,3350 @@
+dist.ktab <- function(x, type, option = c("scaledBYrange", "scaledBYsd", "noscale"), scann = FALSE, tol = 1e-8) {
+
+ #******************************************************#
+ # Parameters are checked #
+ #******************************************************#
+
+ if(!inherits(x, "ktab"))
+ stop("x is not an object of class ktab")
+ if(any(is.na(match(type, c("Q", "O", "N", "D", "F", "B", "C")))))
+ stop("incorrect type: available values for type are O, Q, N, D, F, B and C")
+ if(length(x$blo) != length(type))
+ stop("incorrect length for type")
+ if(!is.numeric(tol))
+ stop("tol is not a numeric")
+
+ #*****************************************************#
+ # If scann is TRUE, the functions of distance #
+ #*****************************************************#
+
+ if(scann == TRUE){
+ if(any(type == "F")){
+ cat("Choose your metric for fuzzy variables\n")
+ cat("1 = d1 Manly\n")
+ cat("d1 = Sum|p(i)-q(i)|/2\n")
+ cat("2 = Overlap index Manly\n")
+ cat("d2 = 1-Sum(p(i)q(i))/sqrt(Sum(p(i)^2))/sqrt(Sum(q(i)^2))\n")
+ cat("3 = Rogers 1972 (one locus)\n")
+ cat("d3 = sqrt(0.5*Sum(p(i)-q(i)^2))\n")
+ cat("4 = Edwards 1971 (one locus)\n")
+ cat("d4 = sqrt(1-(Sum(sqrt(p(i)q(i)))))\n")
+ cat("Selec an integer (1-4): ")
+ methodF <- as.integer(readLines(n = 1))
+ if (methodF == 4)
+ methodF <- 5
+ }
+ if(any(type == "B")){
+ cat("Choose your metric for binary variables\n")
+ cat("1 = JACCARD index (1901) S3 coefficient of GOWER &
+LEGENDRE\n")
+ cat("s1 = a/(a+b+c) --> d = sqrt(1 - s)\n")
+ cat("2 = SOCKAL & MICHENER index (1958) S4 coefficient of GOWER & LEGENDRE \n")
+ cat("s2 = (a+d)/(a+b+c+d) --> d = sqrt(1 - s)\n")
+ cat("3 = SOCKAL & SNEATH(1963) S5 coefficient of GOWER &
+LEGENDRE\n")
+ cat("s3 = a/(a+2(b+c)) --> d = sqrt(1 - s)\n")
+ cat("4 = ROGERS & TANIMOTO (1960) S6 coefficient of GOWER &
+LEGENDRE\n")
+ cat("s4 = (a+d)/(a+2(b+c)+d) --> d = sqrt(1 - s)\n")
+ cat("5 = CZEKANOWSKI (1913) or SORENSEN (1948) S7 coefficient of GOWER & LEGENDRE\n")
+ cat("s5 = 2*a/(2*a+b+c) --> d = sqrt(1 - s)\n")
+ cat("6 = S9 index of GOWER & LEGENDRE (1986)\n")
+ cat("s6 = (a-(b+c)+d)/(a+b+c+d) --> d = sqrt(1 - s)\n")
+ cat("7 = OCHIAI (1957) S12 coefficient of GOWER & LEGENDRE\n")
+ cat("s7 = a/sqrt((a+b)(a+c)) --> d = sqrt(1 - s)\n")
+ cat("8 = SOKAL & SNEATH (1963) S13 coefficient of GOWER &
+LEGENDRE\n")
+ cat("s8 = ad/sqrt((a+b)(a+c)(d+b)(d+c)) --> d = sqrt(1 - s)\n")
+ cat("9 = Phi of PEARSON = S14 coefficient of GOWER & LEGENDRE\n")
+ cat("s9 = (ad-bc)/sqrt((a+b)(a+c)(b+d)(d+c)) --> d = sqrt(1 -
+s)\n")
+ cat("10 = S2 coefficient of GOWER & LEGENDRE\n")
+ cat("s10 = a/(a+b+c+d) --> d = sqrt(1 - s) and unit
+self-similarity\n")
+ cat("Select an integer (1-10): ")
+ methodB <- as.integer(readLines(n = 1))
+ }
+ methodO <- 0
+ if(any(type == "O")){
+ cat("Choose your metric for ordinal variables\n")
+ cat("1 = ranked variables treated as quantitative variables\n")
+ cat("2 = Podani (1999)'s formula\n")
+ cat("Select an integer (1-2): ")
+ methodO <- as.integer(readLines(n = 1))
+ }
+ if(any(c(type == "Q", methodO == 1))){
+ cat("Choose your metric for quantitative variables\n")
+ cat("1 = Euclidean\n")
+ cat("d1 = Sum((x(i)-y(i))^2)/n\n")
+ cat("2 = Manhattan\n")
+ cat("d2= Sum(|x(i)-y(i)|)/n\n")
+ cat("Select an integer (1-2): ")
+ methodQ <- as.integer(readLines(n = 1))
+ }
+ }
+
+ else{
+ methodQ <- 1
+ methodF <- 2
+ methodB <- 1
+ methodO <- 1
+ }
+
+ nlig <- nrow(x[[1]])
+ ntype <- length(unique(type))
+ if(any(type=="D")) napres <- TRUE
+ else
+ napres <- any(is.na(unlist(x[(1:length(x$blo))])))
+ d.names <- rownames(x[[1]])
+
+ treatment <- function(i)
+ {
+
+ #*****************************************************#
+ # Ordinal data #
+ #*****************************************************#
+
+ if(type[i] == "O"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ transrank <- function(u){
+ return(rank(u, na.last = "keep"))
+ }
+ df <- apply(x[[i]], 2, transrank)
+
+ #*****************************************************#
+
+ if(methodO == 1){
+ if(!any(is.na(df))){
+ cmax <- apply(df, 2, max, na.rm = TRUE)
+ cmin <- apply(df, 2, min, na.rm = TRUE)
+ df <- as.data.frame(scale(df, center = cmin, scale = (cmax - cmin)))
+ if(methodQ == 1){
+ thedis <- dist.quant(df, method = 1)
+ }
+ else{
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+ fun1.OQ <- function(tab){
+ fun2.OQ <- function(u) {
+ # start
+ return(sqrt(sum(abs(tab[u[1], ] - tab[u[2], ]))))
+ # end
+ }
+ d <- unlist(apply(index, 1, fun2.OQ))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "quantitative"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ thedis <- fun1.OQ(df)
+ }
+ thedis[thedis < tol] <- 0
+ nbvar <- ncol(x[[i]])
+ if(napres){
+ ntvar <- matrix(ncol(df), nrow(df), nrow(df))
+ }
+ }
+ else{
+ cmax <- apply(df, 2, max, na.rm = TRUE)
+ cmin <- apply(df, 2, min, na.rm = TRUE)
+ df <- as.data.frame(scale(df, center = cmin, scale = ifelse((cmax - cmin)<tol,
+ 1, cmax - cmin)))
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+
+ fun1.ONA <- function(vect){
+ fun2.ONA <- function(u) {
+ if(methodQ ==1)
+ return((vect[u[1]] - vect[u[2]])^2)
+
+ else
+ return(abs(vect[u[1]] - vect[u[2]]))
+ }
+ d <- unlist(apply(index, 1, fun2.ONA))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "quantitative"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ if(ncol(df) == 1)
+ lis <- list(df[, 1])
+ else
+ lis <- as.list(df)
+ listdis <- lapply(lis, fun1.ONA)
+
+ listmat <- lapply(listdis, as.matrix)
+ funfin1.ONA <- function(u){
+ u[!is.na(u)] <- 1
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ interm <- lapply(listmat, funfin1.ONA)
+ mat <- interm[[1]]
+ if(length(interm) > 1){
+ for (k in 2:length(interm)){
+ mat <- interm[[k]] + mat
+ }
+ }
+ ntvar <- mat
+ # calculation of the sum of distances
+ funfin2.ONA <- function(u){
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ res <- lapply(listdis, funfin2.ONA)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ }
+ }
+ else{
+ #####################################################
+ # Podani's distance #
+ #####################################################
+
+ df2 <- cbind.data.frame(df[, apply(df, 2, function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("one of the quantitative data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the quantitative or ordinal data set ", i)
+ df <- as.data.frame(df2)
+ }
+ if(!all(unlist(lapply(df, is.numeric))))
+ stop("Incorrect definition of the quantitative variables")
+
+ #*****************************************************#
+ cmax <- apply(df, 2, max, na.rm = TRUE)
+ cmin <- apply(df, 2, min, na.rm = TRUE)
+ if(ncol(df)>1)
+ granks <- apply(df, 2, table)
+ else
+ granks <- list(as.vector(apply(df, 2, table)))
+ grankmax <- as.vector(unlist(lapply(granks, function(u) u[length(u)])))
+ grankmin <- as.vector(unlist(lapply(granks, function(u) u[1])))
+ if(ncol(df)>1)
+ uranks <- apply(df, 2, function(u) sort(unique(u)))
+ else
+ uranks <- list(as.vector(apply(df, 2, function(u) sort(unique(u)))))
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+ fun1.OP <- function(k){
+ r <- df
+ fun2.OP <- function(u){
+ if(any(is.na(c(r[u[1], k], r[u[2], k])))){
+ return(NA)}
+ else{
+ if(r[u[1], k] == r[u[2], k]){
+ return(0)}
+ else{
+ val <- (abs(r[u[1], k] - r[u[2], k]) - (granks[[k]][uranks[[k]] == r[u[1], k]] - 1)/2 -
+ (granks[[k]][uranks[[k]] == r[u[2], k]] - 1)/2) / ((cmax[k] - cmin[k]) -
+ (grankmax[k] - 1)/2 - (grankmin[k] - 1)/2)
+ return(val)
+ }
+ }
+ }
+ d <- unlist(apply(index, 1, fun2.OP))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "quantitative"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ lis <- as.list(1:ncol(df))
+ listdis <- lapply(lis, fun1.OP)
+ if(napres){
+ listmat <- lapply(listdis, as.matrix)
+ funfin1.OP <- function(u){
+ u[!is.na(u)] <- 1
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ interm <- lapply(listmat, funfin1.OP)
+ mat <- interm[[1]]
+ if(length(interm) > 1){
+ for (k in 2:length(interm)){
+ mat <- interm[[k]] + mat
+ }
+ }
+ ntvar <- mat
+ }
+ else
+ nbvar <- ncol(x[[i]])
+ # calculation of the sum of distances
+ funfin2.OP <- function(u){
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ res <- lapply(listdis, funfin2.OP)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ }
+ }
+
+ #*****************************************************#
+ # Quantitative data #
+ #*****************************************************#
+
+ if(type[i] == "Q"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ df <- x[[i]]
+ df2 <- cbind.data.frame(df[, apply(df, 2, function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("one of the quantitative data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the quantitative or ordinal data set ", i)
+ df <- as.data.frame(df2)
+ }
+ if(!all(unlist(lapply(df, is.numeric))))
+ stop("Incorrect definition of the quantitative variables")
+
+ #*****************************************************#
+
+ if(option[1] == "scaledBYsd"){
+ df <- as.data.frame(scale(df))
+ if(length(unique(type)) > 1)
+ warning("the option scaledBYsd should not be chosen in case of mixed variables")
+ }
+ if(option[1] == "scaledBYrange")
+ {
+ cmax <- apply(df, 2, max, na.rm = TRUE)
+ cmin <- apply(df, 2, min, na.rm = TRUE)
+ df <- as.data.frame(scale(df, center = cmin, scale = ifelse((cmax - cmin)<tol,
+ 1, cmax - cmin)))
+ }
+
+ if(!any(is.na(df))){
+ if(methodQ == 1){
+ thedis <- dist.quant(df, method = methodQ)
+ }
+ else{
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+ fun1.Q <- function(tab){
+ fun2.Q <- function(u) {
+ # start
+ return(sqrt(sum(abs(tab[u[1], ] - tab[u[2], ]))))
+ # end
+ }
+ d <- unlist(apply(index, 1, fun2.Q))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "quantitative"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ thedis <- fun1.Q(df)
+ }
+ thedis[thedis < tol] <- 0
+ nbvar <- ncol(x[[i]])
+ if(napres){
+ ntvar <- matrix(ncol(df), nrow(df), nrow(df))
+ }
+ }
+ else{
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+
+ fun1.QNA <- function(vect){
+ fun2.QNA <- function(u) {
+ if(methodQ == 1)
+ return((vect[u[1]] - vect[u[2]])^2)
+ else
+ return(abs(vect[u[1]] - vect[u[2]]))
+ }
+ d <- unlist(apply(index, 1, fun2.QNA))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "quantitative"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ if(ncol(df) == 1)
+ lis <- list(df[, 1])
+ else
+ lis <- as.list(df)
+ listdis <- lapply(lis, fun1.QNA)
+
+ listmat <- lapply(listdis, as.matrix)
+ funfin1.QNA <- function(u){
+ u[!is.na(u)] <- 1
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ interm <- lapply(listmat, funfin1.QNA)
+ mat <- interm[[1]]
+ if(length(interm) > 1){
+ for (k in 2:length(interm)){
+ mat <- interm[[k]] + mat
+ }
+ }
+ ntvar <- mat
+ # calculation of the sum of distances
+ funfin2.QNA <- function(u){
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ res <- lapply(listdis, funfin2.QNA)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ }
+ }
+
+ #*****************************************************#
+ # Nominal data #
+ #*****************************************************#
+
+ if(type[i] == "N"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ df <- x[[i]]
+ df2 <- cbind.data.frame(df[, apply(df, 2, function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("one of the nominal data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the nominal data sets")
+ df <- as.data.frame(df2)
+ }
+
+ verif <- function(u){
+ if(!is.factor(u)){
+ if(!is.character(u))
+ stop("Incorrect definition of the nominal variables")
+ }
+ }
+
+ lapply(df, verif)
+
+ #*****************************************************#
+
+ if(!any(is.na(df))){
+ FUN <- function(u){
+ m <- model.matrix(~-1 + as.factor(u))
+ return(dist(m) / sqrt(2))
+ }
+ lis <- as.list(df)
+ res <- lapply(lis, FUN)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ nbvar <- ncol(df)
+ if(napres){
+ ntvar <- matrix(ncol(df), nrow(df), nrow(df))
+ }
+ }
+ else{
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+ fun1.NNA <- function(vect){
+ fun2.NNA <- function(u) {
+ if(any(is.na(c(vect[u[1]], vect[u[2]])))) return(NA)
+ else{
+ if(vect[u[1]] == vect[u[2]]){
+ return(0)
+ }
+ else return(1)
+ }
+ }
+ d <- unlist(apply(index, 1, fun2.NNA))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "nominal"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ if(ncol(df) == 1)
+ lis <- list(df[, 1])
+ else
+ lis <- as.list(df)
+ listdis <- lapply(lis, fun1.NNA)
+
+ listmat <- lapply(listdis, as.matrix)
+ funfin1.NNA <- function(u){
+ u[!is.na(u)] <- 1
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ interm <- lapply(listmat, funfin1.NNA)
+ mat <- interm[[1]]
+ if(length(interm) > 1){
+ for (k in 2:length(interm)){
+ mat <- interm[[k]] + mat
+ }
+ }
+ ntvar <- mat
+ # calculation of the sum of distances
+ funfin2.NNA <- function(u){
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ res <- lapply(listdis, funfin2.NNA)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ }
+ }
+
+ #*****************************************************#
+ # Dichotomous data #
+ #*****************************************************#
+
+ if(type[i] == "D"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ df <- x[[i]]
+ df2 <- cbind.data.frame(df[, apply(df, 2, function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("one of the nominal data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the dichotomous data sets")
+ df <- as.data.frame(df2)
+ }
+
+ verif <- function(u){
+ if(any(is.na(match(u, c(0, 1)))))
+ stop("Dichotomous variables should have only 0, and 1")
+ }
+
+ lapply(df, verif)
+
+ #*****************************************************#
+
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+ fun1.D <- function(vect){
+ fun2.D <- function(u) {
+ if(any(is.na(c(vect[u[1]], vect[u[2]])))) return(NA)
+ else{
+ if(vect[u[1]] == vect[u[2]]){
+ if(vect[u[1]] == 1)
+ return(0)
+ else return(NA)
+ }
+ else
+ return(1)
+ }
+ }
+ d <- unlist(apply(index, 1, fun2.D))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "nominal"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ if(ncol(df) == 1)
+ lis <- list(df[, 1])
+ else
+ lis <- as.list(df)
+ listdis <- lapply(lis, fun1.D)
+
+ listmat <- lapply(listdis, as.matrix)
+ funfin1.D <- function(u){
+ u[!is.na(u)] <- 1
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ interm <- lapply(listmat, funfin1.D)
+ mat <- interm[[1]]
+ if(length(interm) > 1){
+ for (k in 2:length(interm)){
+ mat <- interm[[k]] + mat
+ }
+ }
+ ntvar <- mat
+ # calculation of the sum of distances
+ funfin2.D <- function(u){
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ res <- lapply(listdis, funfin2.D)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ }
+
+ #*****************************************************#
+ # Fuzzy data #
+ #*****************************************************#
+
+ if(type[i] == "F"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+ df <- x[[i]]
+ df2 <- df[, apply(df, 2, function(u) !all(is.na(u)))]
+ if(ncol(df2) == 0) stop("one of the fuzzy data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ stop("a column full of NA in the fuzzy data sets")
+ }
+
+ if(!all(unlist(lapply(df, is.numeric))))
+ stop("Incorrect definition of the fuzzy variables")
+
+ if(is.null(attributes(df)$col.blocks))
+ stop("The fuzzy data set must be prepared with the function prep.fuzzy")
+
+
+ #*****************************************************#
+
+ blocs <- attributes(x[[i]])$col.blocks
+ fac <- as.factor(rep(1:length(blocs), blocs))
+ lis <- split(as.data.frame(t(x[[i]])), fac)
+ lis <- lapply(lis, t)
+ lis <- lapply(lis, cbind.data.frame)
+
+ if(!any(is.na(x[[i]]))){
+ if(methodF!=3 & methodF!=4)
+ res <- lapply(lis, function(u) dist.prop(u, method = methodF))
+ else
+ res <- lapply(lis, function(u) dist.prop(u, method = methodF)^2)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ nbvar <- length(blocs)
+ if(napres){
+ ntvar <- matrix(length(blocs), nrow(df), nrow(df))
+ }
+ }
+ else{
+ fun1.FNA <- function(mtflo){
+ res <- matrix(0, nlig, nlig)
+ positions <- apply(mtflo, 1, function(u) any(is.na(u)))
+ dfsansna <- mtflo[!positions, ]
+ if(methodF!=3 & methodF!=4)
+ resdis <- as.matrix(dist.prop(dfsansna, method = methodF))
+ else
+ resdis <- as.matrix(dist.prop(dfsansna, method = methodF)^2)
+ res[!positions, !positions] <- as.vector(resdis)
+ res[positions, ] <- NA
+ res[, positions] <- NA
+ return(as.dist(res))
+ }
+ listdis <- lapply(lis, fun1.FNA)
+
+ listmat <- lapply(listdis, as.matrix)
+ funfin1.FNA <- function(u){
+ u[!is.na(u)] <- 1
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ interm <- lapply(listmat, funfin1.FNA)
+ mat <- interm[[1]]
+ if(length(interm) > 1){
+ for (k in 2:length(interm)){
+ mat <- interm[[k]] + mat
+ }
+ }
+ ntvar <- mat
+ # calculation of the sum of distances
+ funfin2.FNA <- function(u){
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ res <- lapply(listdis, funfin2.FNA)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ }
+ }
+
+ #*****************************************************#
+ # Binary data #
+ #*****************************************************#
+
+ if(type[i] == "B"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ if(!all(unlist(lapply(x[[i]], is.numeric))))
+ stop("Incorrect definition of the binary variables")
+
+ if(is.null(attributes(x[[i]])$col.blocks))
+ stop("The binary data set must be prepared with the function prep.binary")
+
+ if(any(is.na(match(as.vector(as.matrix(x[[i]])), c(0, 1, NA)))))
+ stop("The binary data set must be prepared with the function prep.binary")
+
+ #*****************************************************#
+
+ blocs <- attributes(x[[i]])$col.blocks
+ fac <- as.factor(rep(1:length(blocs), blocs))
+ lis <- split(as.data.frame(t(x[[i]])), fac)
+ lis <- lapply(lis, t)
+ lis <- lapply(lis, cbind.data.frame)
+
+ if(!any(is.na(x[[i]]))){
+ res <- lapply(lis, function(u) dist.binary(u, method = methodB)^2)
+ if(any(is.na(unlist(res))))
+ stop("Rows of zero for binary variables")
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ nbvar <- length(blocs)
+ if(napres){
+ ntvar <- matrix(length(blocs), nlig, nlig)
+ }
+ }
+ else{
+ fun1.BNA <- function(mtbin){
+ res <- matrix(0, nlig, nlig)
+ positions <- apply(mtbin, 1, function(u) any(is.na(u)))
+ dfsansna <- mtbin[!positions, ]
+ resdis <- as.matrix(dist.binary(dfsansna, method = methodB)^2)
+ res[!positions, !positions] <- as.vector(resdis)
+ res[positions, ] <- NA
+ res[, positions] <- NA
+ return(as.dist(res))
+ }
+ listdis <- lapply(lis, fun1.BNA)
+
+ listmat <- lapply(listdis, as.matrix)
+ funfin1.BNA <- function(u){
+ u[!is.na(u)] <- 1
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ interm <- lapply(listmat, funfin1.BNA)
+ mat <- interm[[1]]
+ if(length(interm) > 1){
+ for (k in 2:length(interm)){
+ mat <- interm[[k]] + mat
+ }
+ }
+ ntvar <- mat
+ # calculation of the sum of distances
+ funfin2.BNA <- function(u){
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ res <- lapply(listdis, funfin2.BNA)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ }
+ }
+
+ #*****************************************************#
+ # Circular data #
+ #*****************************************************#
+
+ if(type[i] == "C"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ df <- x[[i]]
+ df2 <- cbind.data.frame(df[, apply(df, 2,
+ function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("the circular data frames ", i, " is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the circular data sets")
+ df <- as.data.frame(df2)
+ }
+
+ if(is.null(attributes(df)$max))
+ stop("The circular data sets must be prepared with the function prep.circular")
+
+ verif <- function(u){
+ if(any(u[!is.na(u)] < 0)) stop("negative values in circular variables")
+ }
+ lapply(df, verif)
+
+ #*****************************************************#
+
+ d.names <- row.names(x[[i]])
+ nlig <- nrow(x[[i]])
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)],
+ row(mat)[col(mat) < row(mat)])
+ odd <- function(u){
+ ifelse(abs(u/2 - floor(u/2)) < 1e-08, FALSE, TRUE)
+ }
+ if(!any(is.na(df))){
+ fun1.C <- function(nucol){
+ vect <- x[[i]][, nucol]
+ maxi <- attributes(df)$max[nucol]
+ vect <- vect / maxi
+ fun2.C <- function(u) {
+ if(odd(maxi))
+ return((2 * maxi /(maxi - 1)) *
+ min(c(abs(vect[u[1]] - vect[u[2]]),
+ (1 - abs(vect[u[1]] - vect[u[2]]))),
+ na.rm = TRUE))
+ else
+ return(2 * min(c(abs(vect[u[1]] - vect[u[2]]),
+ (1 - abs(vect[u[1]] - vect[u[2]]))),
+ na.rm = TRUE))
+ }
+ d <- unlist(apply(index, 1, fun2.C))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "circular"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ lis <- as.list(1:ncol(df))
+ res <- lapply(lis, fun1.C)
+
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ nbvar <- ncol(x[[i]])
+ if(napres){
+ ntvar <- matrix(ncol(x[[i]]), nrow(df), nrow(df))
+ }
+ }
+ else{
+ fun1.CNA <- function(nucol){
+ vect <- x[[i]][, nucol]
+ maxi <- attributes(df)$max[nucol]
+ vect <- vect / maxi
+ fun2.CNA <- function(u){
+ if(any(is.na(c(vect[u[1]], vect[u[2]])))) return(NA)
+ else{
+ if(odd(maxi))
+ return((2 * maxi /(maxi - 1)) *
+ min(c(abs(vect[u[1]] - vect[u[2]]),
+ (1 - abs(vect[u[1]] - vect[u[2]]))),
+ na.rm = TRUE))
+ else
+ return(2 * min(c(abs(vect[u[1]] - vect[u[2]]),
+ (1 - abs(vect[u[1]] - vect[u[2]]))),
+ na.rm = TRUE))
+ }
+ }
+ d <- unlist(apply(index, 1, fun2.CNA))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "circular"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ lis <- as.list(1:ncol(df))
+ listdis <- lapply(lis, fun1.CNA)
+
+ listmat <- lapply(listdis, as.matrix)
+ funfin1.CNA <- function(u){
+ u[!is.na(u)] <- 1
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ interm <- lapply(listmat, funfin1.CNA)
+ mat <- interm[[1]]
+ if(length(interm) > 1){
+ for (k in 2:length(interm)){
+ mat <- interm[[k]] + mat
+ }
+ }
+ ntvar <- mat
+ # calculation of the sum of distances
+ funfin2.CNA <- function(u){
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ res <- lapply(listdis, funfin2.CNA)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ }
+ }
+
+ if(!napres)
+ return(list(nbvar, thedis))
+ else
+ return(list(ntvar, thedis))
+ }
+
+ # Last calculations
+
+ interm <- as.list(1:length(x$blo))
+ names(interm) <- paste("iteration", 1:length(x$blo), sep="")
+ res <- lapply(interm, treatment)
+ if(!napres)
+ nbvar <- sum(unlist(lapply(res, function(u) u[[1]])))
+ else{
+ listntvar <- lapply(res, function(u) u[[1]])
+ mat <- listntvar[[1]]
+ if(length(listntvar) > 1){
+ for (k in 2:length(listntvar)){
+ mat <- listntvar[[k]] + mat
+ }
+ }
+ ntvar <- mat + diag(rep(1, nlig))
+ }
+ dis <- lapply(res, function(u) u[[2]])
+ mat <- dis[[1]]^2
+ if(length(dis) > 1){
+ for (k in 2:length(dis)){
+ mat <- dis[[k]]^2 + mat
+ }
+ }
+ if(!napres){
+ disglobal <- sqrt(mat / nbvar)
+ }
+ else{
+ disglobal <- as.dist(sqrt(as.matrix(mat) / ntvar))
+ }
+
+ attributes(disglobal)$Labels <- d.names
+
+ return(disglobal)
+}
+
+prep.binary <- function (df, col.blocks, labels = paste("B", 1:length(col.blocks), sep = ""))
+{
+ if (!is.data.frame(df))
+ stop("data.frame expected")
+
+ if (sum(col.blocks) != ncol(df)) {
+ stop("non convenient data in col.blocks")
+ }
+
+ if (is.null(names(col.blocks))) {
+ names(col.blocks) <- paste("FV", as.character(1:length(col.blocks)),
+ sep = "")
+ }
+ df2 <- df[, apply(df, 2, function(u) !all(is.na(u)))]
+ bloc <- rep(1:length(col.blocks), col.blocks)
+ bloc <- as.factor(bloc[apply(df, 2, function(u) !all(is.na(u)))])
+ col.blocks <- as.vector(table(bloc))
+ df <- df2
+ if (any(df[!is.na(df)] < 0))
+ stop("non negative value expected in df")
+ d.names <- row.names(df)
+ nlig <- nrow(df)
+ df <- as.matrix(1 * (df > 0))
+ f1 <- function(x, k) {
+ a <- sum(x)
+ if (is.na(a)) {
+ return(rep(NA, length(x)))
+ cat("missing data found in block", k, "\n")
+ }
+ if (a == 0)
+ return(rep(NA, length(x)))
+ return(x)
+ }
+ k2 <- 0
+ for (k in 1:(length(col.blocks))) {
+ k1 <- k2 + 1
+ k2 <- k2 + col.blocks[k]
+ X <- df[, k1:k2]
+ X <- t(apply(X, 1, f1, k = k))
+ df[, k1:k2] <- X
+ }
+ df <- as.data.frame(df)
+ attr(df, "col.blocks") <- col.blocks
+ col.num <- factor(rep((1:length(col.blocks)), col.blocks))
+ attr(df, "col.num") <- col.num
+ attr(df, "Labels") <- labels
+ return(df)
+}
+
+prep.circular <-
+ function (df, rangemin = apply(df, 2, min, na.rm = TRUE), rangemax = apply(df, 2, max, na.rm = TRUE))
+ {
+ if (!is.data.frame(df))
+ stop("data.frame expected")
+ veriffun <- function(i){
+ if(rangemin[i] > min(df[i], na.rm = TRUE)) stop("Incorrect minimum in rangemin")
+ if(rangemax[i] < max(df[i], na.rm = TRUE)) stop("Incorrect maximum in rangemax")
+ }
+ sapply(1:ncol(df), veriffun)
+ df1 <- sweep(df, 2, rangemin, "-")
+ max2 <- rangemax - rangemin
+ attr(df1, "max") <- max2 + 1
+ return(df1)
+ }
+
+prep.fuzzy <-
+ function (df, col.blocks, row.w = rep(1, nrow(df)), labels = paste("F", 1:length(col.blocks), sep = ""))
+ {
+ if (!is.data.frame(df))
+ stop("data.frame expected")
+ if (!is.null(row.w)) {
+ if (length(row.w) != nrow(df))
+ stop("non convenient dimension")
+ }
+ if (sum(col.blocks) != ncol(df)) {
+ stop("non convenient data in col.blocks")
+ }
+ df2 <- df[, apply(df, 2, function(u) !all(is.na(u)))]
+ bloc <- rep(1:length(col.blocks), col.blocks)
+ bloc <- as.factor(bloc[apply(df, 2, function(u) !all(is.na(u)))])
+ col.blocks <- as.vector(table(bloc))
+ df <- df2
+ if (is.null(row.w))
+ row.w <- rep(1, nrow(df))/nrow(df)
+ row.w <- row.w/sum(row.w)
+ if (is.null(names(col.blocks))) {
+ names(col.blocks) <- paste("FV", as.character(1:length(col.blocks)),
+ sep = "")
+ }
+ f1 <- function(x, k) {
+ a <- sum(x)
+ if (is.na(a)) {
+ return(rep(NA, length(x)))
+ cat("missing data found in block", k, "\n")
+ }
+ if (a == 0)
+ return(rep(NA, length(x)))
+ return(x/a)
+ }
+ k2 <- 0
+ col.w <- rep(1, ncol(df))
+ for (k in 1:(length(col.blocks))) {
+ k1 <- k2 + 1
+ k2 <- k2 + col.blocks[k]
+ X <- df[, k1:k2]
+ X <- t(apply(X, 1, f1, k = k))
+ X.marge <- apply(X, 1, sum, na.rm = TRUE)
+
+ X.marge <- X.marge * row.w
+ X.marge <- X.marge/sum(X.marge, na.rm = TRUE)
+ X.mean <- apply(X * X.marge, 2, sum)
+ df[, k1:k2] <- X
+ col.w[k1:k2] <- X.mean
+ }
+ attr(df, "col.blocks") <- col.blocks
+ attr(df, "row.w") <- row.w
+ attr(df, "col.freq") <- col.w
+ attr(df, "Labels") <- labels
+ col.num <- factor(rep((1:length(col.blocks)), col.blocks))
+ attr(df, "col.num") <- col.num
+ return(df)
+ }
+
+ldist.ktab <- function(x, type, option = c("scaledBYrange", "scaledBYsd", "noscale"), scann = FALSE, tol = 1e-8) {
+
+ #******************************************************#
+ # Parameters are checked #
+ #******************************************************#
+
+ if(!inherits(x, "ktab"))
+ stop("x is not an object of class ktab")
+ if(any(is.na(match(type, c("Q", "O", "N", "D", "F", "B", "C")))))
+ stop("incorrect type: available values for type are O, Q, N, D, F, B and C")
+ if(length(x$blo)!=length(type))
+ stop("incorrect length for type")
+ if(!is.numeric(tol))
+ stop("tol is not a numeric")
+
+ #*****************************************************#
+ # If scann is TRUE, the functions of distance #
+ #*****************************************************#
+
+ if(scann == TRUE){
+ if(any(type == "F")){
+ cat("Choose your metric for fuzzy variables\n")
+ cat("1 = d1 Manly\n")
+ cat("d1 = Sum|p(i)-q(i)|/2\n")
+ cat("2 = Overlap index Manly\n")
+ cat("d2 = 1-Sum(p(i)q(i))/sqrt(Sum(p(i)^2))/sqrt(Sum(q(i)^2))\n")
+ cat("3 = Rogers 1972 (one locus)\n")
+ cat("d3 = sqrt(0.5*Sum(p(i)-q(i)^2))\n")
+ cat("4 = Edwards 1971 (one locus)\n")
+ cat("d4 = sqrt(1 - (Sum(sqrt(p(i)q(i)))))\n")
+ cat("Selec an integer (1-4): ")
+ methodF <- as.integer(readLines(n = 1))
+ if (methodF == 4)
+ methodF <- 5
+ }
+ if(any(type == "B")){
+ cat("Choose your metric for binary variables\n")
+ cat("1 = JACCARD index (1901) S3 coefficient of GOWER &
+LEGENDRE\n")
+ cat("s1 = a/(a+b+c) --> d = sqrt(1 - s)\n")
+ cat("2 = SOCKAL & MICHENER index (1958) S4 coefficient of GOWER & LEGENDRE \n")
+ cat("s2 = (a+d)/(a+b+c+d) --> d = sqrt(1 - s)\n")
+ cat("3 = SOCKAL & SNEATH(1963) S5 coefficient of GOWER &
+LEGENDRE\n")
+ cat("s3 = a/(a+2(b+c)) --> d = sqrt(1 - s)\n")
+ cat("4 = ROGERS & TANIMOTO (1960) S6 coefficient of GOWER &
+LEGENDRE\n")
+ cat("s4 = (a+d)/(a+2(b+c)+d) --> d = sqrt(1 - s)\n")
+ cat("5 = CZEKANOWSKI (1913) or SORENSEN (1948) S7 coefficient of GOWER & LEGENDRE\n")
+ cat("s5 = 2*a/(2*a+b+c) --> d = sqrt(1 - s)\n")
+ cat("6 = S9 index of GOWER & LEGENDRE (1986)\n")
+ cat("s6 = (a-(b+c)+d)/(a+b+c+d) --> d = sqrt(1 - s)\n")
+ cat("7 = OCHIAI (1957) S12 coefficient of GOWER & LEGENDRE\n")
+ cat("s7 = a/sqrt((a+b)(a+c)) --> d = sqrt(1 - s)\n")
+ cat("8 = SOKAL & SNEATH (1963) S13 coefficient of GOWER &
+LEGENDRE\n")
+ cat("s8 = ad/sqrt((a+b)(a+c)(d+b)(d+c)) --> d = sqrt(1 - s)\n")
+ cat("9 = Phi of PEARSON = S14 coefficient of GOWER & LEGENDRE\n")
+ cat("s9 = (ad-bc)/sqrt((a+b)(a+c)(b+d)(d+c)) --> d = sqrt(1 -
+s)\n")
+ cat("10 = S2 coefficient of GOWER & LEGENDRE\n")
+ cat("s10 = a/(a+b+c+d) --> d = sqrt(1 - s) and unit
+self-similarity\n")
+ cat("Select an integer (1-10): ")
+ methodB <- as.integer(readLines(n = 1))
+ }
+ methodO <- 0
+ if(any(type == "O")){
+ cat("Choose your metric for ordinal variables\n")
+ cat("1 = ranked variables treated as quantitative variables\n")
+ cat("2 = Podani (1999)'s formula\n")
+ cat("Select an integer (1-2): ")
+ methodO <- as.integer(readLines(n = 1))
+ }
+ if(any(c(type == "Q", methodO == 1))){
+ cat("Choose your metric for quantitative variables\n")
+ cat("1 = Euclidean\n")
+ cat("d1 = Sum((x(i)-y(i))^2)/n\n")
+ cat("2 = Manhattan\n")
+ cat("d2= Sum(|x(i)-y(i)|)/n\n")
+ cat("Select an integer (1-2): ")
+ methodQ <- as.integer(readLines(n = 1))
+ }
+ }
+
+ else{
+ methodQ <- 1
+ methodF <- 2
+ methodB <- 1
+ methodO <- 1
+ }
+
+ nlig <- nrow(x[[1]])
+ ntype <- length(unique(type))
+ if(any(type=="D")) napres <- TRUE
+ else
+ napres <- any(is.na(unlist(x[(1:length(x$blo))])))
+ d.names <- rownames(x[[1]])
+
+ treatment <- function(i)
+ {
+
+ #*****************************************************#
+ # Ordinal data #
+ #*****************************************************#
+
+ if(type[i] == "O"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ transrank <- function(u){
+ return(rank(u, na.last = "keep"))
+ }
+ df <- apply(x[[i]], 2, transrank)
+
+ #*****************************************************#
+
+ if(methodO == 1){
+ cmax <- apply(df, 2, max, na.rm = TRUE)
+ cmin <- apply(df, 2, min, na.rm = TRUE)
+ df <- as.data.frame(scale(df, center = cmin, scale = ifelse((cmax - cmin)<tol,
+ 1, cmax - cmin)))
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+
+ fun1.O <- function(vect){
+ fun2.O <- function(u) {
+ if(methodQ ==1)
+ return(ifelse(abs(vect[u[1]] - vect[u[2]]) < tol, 0, abs(vect[u[1]] - vect[u[2]])))
+
+ else
+ return(ifelse(sqrt(abs(vect[u[1]] - vect[u[2]])) < tol, 0, sqrt(abs(vect[u[1]] - vect[u[2]]))))
+ }
+ d <- unlist(apply(index, 1, fun2.O))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "quantitative"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ if(ncol(df) == 1)
+ lis <- list(df[, 1])
+ else
+ lis <- as.list(df)
+ thedis <- lapply(lis, fun1.O)
+ names(thedis) <- names(x[[i]])
+ }
+ else{
+ #####################################################
+ # Podani's distance #
+ #####################################################
+
+ df2 <- cbind.data.frame(df[, apply(df, 2, function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("one of the ordinal data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the ordinal data set ", i)
+ df <- as.data.frame(df2)
+ }
+ if(!all(unlist(lapply(df, is.numeric))))
+ stop("Incorrect definition of the ordinal variables")
+
+ #*****************************************************#
+ cmax <- apply(df, 2, max, na.rm = TRUE)
+ cmin <- apply(df, 2, min, na.rm = TRUE)
+ if(ncol(df)>1)
+ granks <- apply(df, 2, table)
+ else
+ granks <- list(as.vector(apply(df, 2, table)))
+ grankmax <- as.vector(unlist(lapply(granks, function(u) u[length(u)])))
+ grankmin <- as.vector(unlist(lapply(granks, function(u) u[1])))
+ if(ncol(df)>1)
+ uranks <- apply(df, 2, function(u) sort(unique(u)))
+ else
+ uranks <- list(as.vector(apply(df, 2, function(u) sort(unique(u)))))
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+ fun1.OP <- function(k){
+ r <- df
+ fun2.OP <- function(u){
+ if(any(is.na(c(r[u[1], k], r[u[2], k])))){
+ return(NA)}
+ else{
+ if(r[u[1], k] == r[u[2], k]){
+ return(0)}
+ else{
+ val <- (abs(r[u[1], k] - r[u[2], k]) - (granks[[k]][uranks[[k]] == r[u[1], k]] - 1)/2 -
+ (granks[[k]][uranks[[k]] == r[u[2], k]]-1)/2) / ((cmax[k] - cmin[k]) -
+ (grankmax[k] - 1)/2 - (grankmin[k] - 1)/2)
+ return(ifelse(sqrt(val) < tol, 0, sqrt(val)))
+ }
+ }
+ }
+ d <- unlist(apply(index, 1, fun2.OP))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "quantitative"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ lis <- as.list(1:ncol(df))
+ thedis <- lapply(lis, fun1.OP)
+ names(thedis) <- names(x[[i]])
+ }
+ }
+
+ #*****************************************************#
+ # Quantitative data #
+ #*****************************************************#
+
+ if(type[i] == "Q"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ df <- x[[i]]
+ df2 <- cbind.data.frame(df[, apply(df, 2, function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("one of the quantitative data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the quantitative data set ", i)
+ df <- as.data.frame(df2)
+ }
+ if(!all(unlist(lapply(df, is.numeric))))
+ stop("Incorrect definition of the quantitative variables")
+
+ #*****************************************************#
+
+ if(option[1] == "scaledBYsd")
+ df <- as.data.frame(scale(df))
+ if(option[1] == "scaledBYrange")
+ {
+ cmax <- apply(df, 2, max, na.rm = TRUE)
+ cmin <- apply(df, 2, min, na.rm = TRUE)
+ df <- as.data.frame(scale(df, center = cmin, scale = ifelse((cmax - cmin)<tol,
+ 1, cmax - cmin)))
+ }
+
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+
+ fun1.Q <- function(vect){
+ fun2.Q <- function(u) {
+ if(methodQ == 1)
+ return(ifelse(abs(vect[u[1]] - vect[u[2]]) < tol, 0, abs(vect[u[1]] - vect[u[2]])))
+ else
+ return(ifelse(sqrt(abs(vect[u[1]] - vect[u[2]])) < tol, 0, sqrt(abs(vect[u[1]] - vect[u[2]]))))
+ }
+ d <- unlist(apply(index, 1, fun2.Q))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "quantitative"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ if(ncol(df) == 1)
+ lis <- list(df[, 1])
+ else
+ lis <- as.list(df)
+ thedis <- lapply(lis, fun1.Q)
+ names(thedis) <- names(x[[i]])
+ }
+
+ #*****************************************************#
+ # Nominal data #
+ #*****************************************************#
+
+ if(type[i] == "N"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ df <- x[[i]]
+ df2 <- cbind.data.frame(df[, apply(df, 2, function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("one of the nominal data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the nominal data sets")
+ df <- as.data.frame(df2)
+ }
+
+ verif <- function(u){
+ if(!is.factor(u)){
+ if(!is.character(u))
+ stop("Incorrect definition of the nominal variables")
+ }
+ }
+
+ lapply(df, verif)
+
+ #*****************************************************#
+
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+ fun1.N <- function(vect){
+ fun2.N <- function(u) {
+ if(any(is.na(c(vect[u[1]], vect[u[2]])))) return(NA)
+ else{
+ if(vect[u[1]] == vect[u[2]]){
+ return(0)
+ }
+ else return(1)
+ }
+ }
+ d <- unlist(apply(index, 1, fun2.N))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "nominal"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ if(ncol(df) == 1)
+ lis <- list(df[, 1])
+ else
+ lis <- as.list(df)
+ thedis <- lapply(lis, fun1.N)
+ names(thedis) <- names(x[[i]])
+ }
+
+ #*****************************************************#
+ # Dichotomous data #
+ #*****************************************************#
+
+ if(type[i] == "D"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ df <- x[[i]]
+ df2 <- cbind.data.frame(df[, apply(df, 2, function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("one of the nominal data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the dichotomous data sets")
+ df <- as.data.frame(df2)
+ }
+
+ verif <- function(u){
+ if(any(is.na(match(u, c(0, 1)))))
+ stop("Dichotomous variables should have only 0, and 1")
+ }
+
+ lapply(df, verif)
+
+ #*****************************************************#
+
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+ fun1.D <- function(vect){
+ fun2.D <- function(u) {
+ if(any(is.na(c(vect[u[1]], vect[u[2]])))) return(NA)
+ else{
+ if(vect[u[1]] == vect[u[2]]){
+ if(vect[u[1]] == 1)
+ return(0)
+ else return(NA)
+ }
+ else
+ return(1)
+ }
+ }
+ d <- unlist(apply(index, 1, fun2.D))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "nominal"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ if(ncol(df) == 1)
+ lis <- list(df[, 1])
+ else
+ lis <- as.list(df)
+ thedis <- lapply(lis, fun1.D)
+ names(thedis) <- names(x[[i]])
+ }
+
+ #*****************************************************#
+ # Fuzzy data #
+ #*****************************************************#
+
+ if(type[i] == "F"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+ df <- x[[i]]
+ df2 <- df[, apply(df, 2, function(u) !all(is.na(u)))]
+ if(ncol(df2) == 0) stop("one of the fuzzy data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ stop("a column full of NA in the fuzzy data sets")
+ }
+
+ if(!all(unlist(lapply(df, is.numeric))))
+ stop("Incorrect definition of the fuzzy variables")
+
+ if(is.null(attributes(df)$col.blocks))
+ stop("The fuzzy data set must be prepared with the function prep.fuzzy")
+
+ #*****************************************************#
+
+ blocs <- attributes(x[[i]])$col.blocks
+ fac <- as.factor(rep(1:length(blocs), blocs))
+ lis <- split(as.data.frame(t(x[[i]])), fac)
+ lis <- lapply(lis, t)
+ lis <- lapply(lis, cbind.data.frame)
+
+ if(!any(is.na(x[[i]]))){
+ if(methodF!=3 & methodF!=4)
+ res <- lapply(lis, function(u) sqrt(dist.prop(u, method = methodF)))
+ else
+ res <- lapply(lis, function(u) dist.prop(u, method = methodF))
+ funfor0 <- function(x){
+ x[x < tol] <- 0
+ return(x)
+ }
+ thedis <- lapply(res, funfor0)
+ names(thedis) <- attributes(x[[i]])$Labels
+ }
+ else{
+ fun1.F <- function(mtflo){
+ res <- matrix(0, nlig, nlig)
+ positions <- apply(mtflo, 1, function(u) any(is.na(u)))
+ dfsansna <- mtflo[!positions, ]
+ if(methodF!=3 & methodF!=4)
+ resdis <- as.matrix(sqrt(dist.prop(dfsansna, method = methodF)))
+ else
+ resdis <- as.matrix(dist.prop(dfsansna, method = methodF))
+ res[!positions, !positions] <- as.vector(resdis)
+ res[positions, ] <- NA
+ res[, positions] <- NA
+ return(as.dist(res))
+ }
+ listdis <- lapply(lis, fun1.F)
+ funfor0 <- function(x){
+ x[x < tol] <- 0
+ return(x)
+ }
+ thedis <- lapply(listdis, funfor0)
+ names(thedis) <- attributes(x[[i]])$Labels
+ }
+ }
+
+ #*****************************************************#
+ # Binary data #
+ #*****************************************************#
+
+ if(type[i] == "B"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ if(!all(unlist(lapply(x[[i]], is.numeric))))
+ stop("Incorrect definition of the binary variables")
+
+ if(is.null(attributes(x[[i]])$col.blocks))
+ stop("The binary data set must be prepared with the function prep.binary")
+
+ if(any(is.na(match(as.vector(as.matrix(x[[i]])), c(0, 1, NA)))))
+ stop("The binary data set must be prepared with the function prep.binary")
+
+ #*****************************************************#
+
+ blocs <- attributes(x[[i]])$col.blocks
+ fac <- as.factor(rep(1:length(blocs), blocs))
+ lis <- split(as.data.frame(t(x[[i]])), fac)
+ lis <- lapply(lis, t)
+ lis <- lapply(lis, cbind.data.frame)
+
+ if(!any(is.na(x[[i]]))){
+ res <- lapply(lis, function(u) dist.binary(u, method = methodB))
+ if(any(is.na(unlist(res))))
+ stop("Rows of zero for binary variables")
+ funfor0 <- function(x){
+ x[x < tol] <- 0
+ return(x)
+ }
+ thedis <- lapply(res, funfor0)
+ names(thedis) <- attributes(x[[i]])$Labels
+ }
+ else{
+ fun1.B <- function(mtbin){
+ res <- matrix(0, nlig, nlig)
+ positions <- apply(mtbin, 1, function(u) any(is.na(u)))
+ dfsansna <- mtbin[!positions, ]
+ resdis <- as.matrix(dist.binary(dfsansna, method = methodB))
+ res[!positions, !positions] <- as.vector(resdis)
+ res[positions, ] <- NA
+ res[, positions] <- NA
+ return(as.dist(res))
+ }
+ listdis <- lapply(lis, fun1.B)
+ funfor0 <- function(x){
+ x[x < tol] <- 0
+ return(x)
+ }
+ thedis <- lapply(listdis, funfor0)
+ names(thedis) <- attributes(x[[i]])$Labels
+ }
+ }
+
+ #*****************************************************#
+ # Circular data #
+ #*****************************************************#
+
+ if(type[i] == "C"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ df <- x[[i]]
+ df2 <- cbind.data.frame(df[, apply(df, 2,
+ function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("the circular data frames ", i, " is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the circular data sets")
+ df <- as.data.frame(df2)
+ }
+
+ if(is.null(attributes(df)$max))
+ stop("The circular data sets must be prepared with the function prep.circular")
+
+ verif <- function(u){
+ if(any(u[!is.na(u)] < 0)) stop("negative values in circular variables")
+ }
+ lapply(df, verif)
+
+ #*****************************************************#
+
+ d.names <- row.names(x[[i]])
+ nlig <- nrow(x[[i]])
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)],
+ row(mat)[col(mat) < row(mat)])
+ odd <- function(u){
+ ifelse(abs(u/2 - floor(u/2)) < 1e-08, FALSE, TRUE)
+ }
+ if(!any(is.na(df))){
+ fun1.C <- function(nucol){
+ vect <- x[[i]][, nucol]
+ maxi <- attributes(df)$max[nucol]
+ vect <- vect / maxi
+ fun2.C <- function(u) {
+ if(odd(maxi))
+ return(sqrt((2 * maxi /(maxi - 1)) *
+ min(c(abs(vect[u[1]] - vect[u[2]]),
+ (1 - abs(vect[u[1]] - vect[u[2]]))),
+ na.rm = TRUE)))
+ else
+ return(sqrt(2 * min(c(abs(vect[u[1]] - vect[u[2]]),
+ (1 - abs(vect[u[1]] - vect[u[2]]))),
+ na.rm = TRUE)))
+ }
+ d <- unlist(apply(index, 1, fun2.C))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "circular"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ lis <- as.list(1:ncol(df))
+ res <- lapply(lis, fun1.C)
+ funfor0 <- function(x){
+ x[x < tol] <- 0
+ return(x)
+ }
+ thedis <- lapply(res, funfor0)
+ names(thedis) <- names(x[[i]])
+ }
+ else{
+ fun1.CNA <- function(nucol){
+ vect <- x[[i]][, nucol]
+ maxi <- attributes(df)$max[nucol]
+ vect <- vect / maxi
+ fun2.CNA <- function(u){
+ if(any(is.na(c(vect[u[1]], vect[u[2]])))) return(NA)
+ else{
+ if(odd(maxi))
+ return(sqrt((2 * maxi /(maxi - 1)) *
+ min(c(abs(vect[u[1]] - vect[u[2]]),
+ (1 - abs(vect[u[1]] - vect[u[2]]))),
+ na.rm = TRUE)))
+ else
+ return(sqrt(2 * min(c(abs(vect[u[1]] - vect[u[2]]),
+ (1 - abs(vect[u[1]] - vect[u[2]]))),
+ na.rm = TRUE)))
+ }
+ }
+ d <- unlist(apply(index, 1, fun2.CNA))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "circular"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ lis <- as.list(1:ncol(df))
+ listdis <- lapply(lis, fun1.CNA)
+ funfor0 <- function(x){
+ x[x < tol] <- 0
+ return(x)
+ }
+ thedis <- lapply(listdis, funfor0)
+ names(thedis) <- names(x[[i]])
+ }
+ }
+ return(thedis)
+ }
+
+ # Last calculations
+
+ interm <- as.list(1:length(x$blo))
+ names(interm) <- paste("iteration", 1:length(x$blo), sep="")
+ dispervar <- lapply(interm, treatment)
+ namesv <- unlist(lapply(dispervar, names))
+ dispervar <- do.call("c", dispervar)
+ names(dispervar) <- namesv
+ return(dispervar)
+}
+
+kdist.cor <- function(x, type, option = c("scaledBYrange", "scaledBYsd", "noscale"), scann = FALSE, tol = 1e-8, squared = TRUE){
+
+ #******************************************************#
+ # Parameters are checked #
+ #******************************************************#
+
+ if(!inherits(x, "ktab"))
+ stop("x is not an object of class ktab")
+ if(any(is.na(match(type, c("Q", "O", "N", "D", "F", "B", "C")))))
+ stop("incorrect type: available values for type are O, Q, N, D, F, B and C")
+ if(length(x$blo) != length(type))
+ stop("incorrect length for type")
+ if(!is.numeric(tol))
+ stop("tol is not a numeric")
+
+ #*****************************************************#
+ # If scann is TRUE, the functions of distance #
+ #*****************************************************#
+
+ if(scann == TRUE){
+ if(any(type == "F")){
+ cat("Choose your metric for fuzzy variables\n")
+ cat("1 = d1 Manly\n")
+ cat("d1 = Sum|p(i)-q(i)|/2\n")
+ cat("2 = Overlap index Manly\n")
+ cat("d2 = 1-Sum(p(i)q(i))/sqrt(Sum(p(i)^2))/sqrt(Sum(q(i)^2))\n")
+ cat("3 = Rogers 1972 (one locus)\n")
+ cat("d3 = sqrt(0.5*Sum(p(i)-q(i)^2))\n")
+ cat("4 = Edwards 1971 (one locus)\n")
+ cat("d4 = sqrt(1 - (Sum(sqrt(p(i)q(i)))))\n")
+ cat("Selec an integer (1-4): ")
+ methodF <- as.integer(readLines(n = 1))
+ if (methodF == 4)
+ methodF <- 5
+ }
+ if(any(type == "B")){
+ cat("Choose your metric for binary variables\n")
+ cat("1 = JACCARD index (1901) S3 coefficient of GOWER &
+LEGENDRE\n")
+ cat("s1 = a/(a+b+c) --> d = sqrt(1 - s)\n")
+ cat("2 = SOCKAL & MICHENER index (1958) S4 coefficient of GOWER & LEGENDRE \n")
+ cat("s2 = (a+d)/(a+b+c+d) --> d = sqrt(1 - s)\n")
+ cat("3 = SOCKAL & SNEATH(1963) S5 coefficient of GOWER &
+LEGENDRE\n")
+ cat("s3 = a/(a+2(b+c)) --> d = sqrt(1 - s)\n")
+ cat("4 = ROGERS & TANIMOTO (1960) S6 coefficient of GOWER &
+LEGENDRE\n")
+ cat("s4 = (a+d)/(a+2(b+c)+d) --> d = sqrt(1 - s)\n")
+ cat("5 = CZEKANOWSKI (1913) or SORENSEN (1948) S7 coefficient of GOWER & LEGENDRE\n")
+ cat("s5 = 2*a/(2*a+b+c) --> d = sqrt(1 - s)\n")
+ cat("6 = S9 index of GOWER & LEGENDRE (1986)\n")
+ cat("s6 = (a-(b+c)+d)/(a+b+c+d) --> d = sqrt(1 - s)\n")
+ cat("7 = OCHIAI (1957) S12 coefficient of GOWER & LEGENDRE\n")
+ cat("s7 = a/sqrt((a+b)(a+c)) --> d = sqrt(1 - s)\n")
+ cat("8 = SOKAL & SNEATH (1963) S13 coefficient of GOWER &
+LEGENDRE\n")
+ cat("s8 = ad/sqrt((a+b)(a+c)(d+b)(d+c)) --> d = sqrt(1 - s)\n")
+ cat("9 = Phi of PEARSON = S14 coefficient of GOWER & LEGENDRE\n")
+ cat("s9 = (ad-bc)/sqrt((a+b)(a+c)(b+d)(d+c)) --> d = sqrt(1 -
+s)\n")
+ cat("10 = S2 coefficient of GOWER & LEGENDRE\n")
+ cat("s10 = a/(a+b+c+d) --> d = sqrt(1 - s) and unit
+self-similarity\n")
+ cat("Select an integer (1-10): ")
+ methodB <- as.integer(readLines(n = 1))
+ }
+ methodO <- 0
+ if(any(type == "O")){
+ cat("Choose your metric for ordinal variables\n")
+ cat("1 = ranked variables treated as quantitative variables\n")
+ cat("2 = Podani (1999)'s formula\n")
+ cat("Select an integer (1-2): ")
+ methodO <- as.integer(readLines(n = 1))
+ }
+ if(any(c(type == "Q", methodO == 1))){
+ cat("Choose your metric for quantitative variables\n")
+ cat("1 = Euclidean\n")
+ cat("d1 = Sum((x(i)-y(i))^2)/n\n")
+ cat("2 = Manhattan\n")
+ cat("d2= Sum(|x(i)-y(i)|)/n\n")
+ cat("Select an integer (1-2): ")
+ methodQ <- as.integer(readLines(n = 1))
+ }
+ }
+
+ else{
+ methodQ <- 1
+ methodF <- 2
+ methodB <- 1
+ methodO <- 1
+ }
+
+ nlig <- nrow(x[[1]])
+ ntype <- length(unique(type))
+ if(any(type=="D")) napres <- TRUE
+ else
+ napres <- any(is.na(unlist(x[(1:length(x$blo))])))
+ d.names <- rownames(x[[1]])
+
+
+ ldist.ktab2 <- function(x, type, option = c("scaledBYrange", "scaledBYsd", "noscale"), tol = 1e-8) {
+
+ treatment <- function(i)
+ {
+
+ #*****************************************************#
+ # Ordinal data #
+ #*****************************************************#
+
+ if(type[i] == "O"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ transrank <- function(u){
+ return(rank(u, na.last = "keep"))
+ }
+ df <- apply(x[[i]], 2, transrank)
+
+ #*****************************************************#
+
+ if(methodO == 1){
+ cmax <- apply(df, 2, max, na.rm = TRUE)
+ cmin <- apply(df, 2, min, na.rm = TRUE)
+ df <- as.data.frame(scale(df, center = cmin, scale = ifelse((cmax - cmin)<tol,
+ 1, cmax - cmin)))
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+
+ fun1.O <- function(vect){
+ fun2.O <- function(u) {
+ if(methodQ ==1)
+ return(ifelse(abs(vect[u[1]] - vect[u[2]]) < tol, 0, abs(vect[u[1]] - vect[u[2]])))
+
+ else
+ return(ifelse(sqrt(abs(vect[u[1]] - vect[u[2]])) < tol, 0, sqrt(abs(vect[u[1]] - vect[u[2]]))))
+ }
+ d <- unlist(apply(index, 1, fun2.O))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "quantitative"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ if(ncol(df) == 1)
+ lis <- list(df[, 1])
+ else
+ lis <- as.list(df)
+ thedis <- lapply(lis, fun1.O)
+ names(thedis) <- names(x[[i]])
+ }
+ else{
+ #####################################################
+ # Podani's distance #
+ #####################################################
+
+ df2 <- cbind.data.frame(df[, apply(df, 2, function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("one of the ordinal data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the ordinal data set ", i)
+ df <- as.data.frame(df2)
+ }
+ if(!all(unlist(lapply(df, is.numeric))))
+ stop("Incorrect definition of the ordinal variables")
+
+ #*****************************************************#
+ cmax <- apply(df, 2, max, na.rm = TRUE)
+ cmin <- apply(df, 2, min, na.rm = TRUE)
+ if(ncol(df)>1)
+ granks <- apply(df, 2, table)
+ else
+ granks <- list(as.vector(apply(df, 2, table)))
+ grankmax <- as.vector(unlist(lapply(granks, function(u) u[length(u)])))
+ grankmin <- as.vector(unlist(lapply(granks, function(u) u[1])))
+ if(ncol(df)>1)
+ uranks <- apply(df, 2, function(u) sort(unique(u)))
+ else
+ uranks <- list(as.vector(apply(df, 2, function(u) sort(unique(u)))))
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+ fun1.OP <- function(k){
+ r <- df
+ fun2.OP <- function(u){
+ if(any(is.na(c(r[u[1], k], r[u[2], k])))){
+ return(NA)}
+ else{
+ if(r[u[1], k] == r[u[2], k]){
+ return(0)}
+ else{
+ val <- (abs(r[u[1], k] - r[u[2], k]) - (granks[[k]][uranks[[k]]==r[u[1], k]] - 1)/2 -
+ (granks[[k]][uranks[[k]]==r[u[2], k]]-1)/2) / ((cmax[k]-cmin[k]) -
+ (grankmax[k] - 1)/2 - (grankmin[k] - 1)/2)
+ return(ifelse(sqrt(val) < tol, 0, sqrt(val)))
+ }
+ }
+ }
+ d <- unlist(apply(index, 1, fun2.OP))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "quantitative"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ lis <- as.list(1:ncol(df))
+ thedis <- lapply(lis, fun1.OP)
+ names(thedis) <- names(x[[i]])
+ }
+ }
+
+ #*****************************************************#
+ # Quantitative data #
+ #*****************************************************#
+
+ if(type[i] == "Q"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ df <- x[[i]]
+ df2 <- cbind.data.frame(df[, apply(df, 2, function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("one of the quantitative data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the quantitative data set ", i)
+ df <- as.data.frame(df2)
+ }
+ if(!all(unlist(lapply(df, is.numeric))))
+ stop("Incorrect definition of the quantitative variables")
+
+ #*****************************************************#
+
+ if(option[1] == "scaledBYsd")
+ df <- as.data.frame(scale(df))
+ if(option[1] == "scaledBYrange")
+ {
+ cmax <- apply(df, 2, max, na.rm = TRUE)
+ cmin <- apply(df, 2, min, na.rm = TRUE)
+ df <- as.data.frame(scale(df, center = cmin, scale = ifelse((cmax - cmin)<tol,
+ 1, cmax - cmin)))
+ }
+
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+
+ fun1.Q <- function(vect){
+ fun2.Q <- function(u) {
+ if(methodQ == 1)
+ return(ifelse(abs(vect[u[1]] - vect[u[2]]) < tol, 0, abs(vect[u[1]] - vect[u[2]])))
+ else
+ return(ifelse(sqrt(abs(vect[u[1]] - vect[u[2]])) < tol, 0, sqrt(abs(vect[u[1]] - vect[u[2]]))))
+ }
+ d <- unlist(apply(index, 1, fun2.Q))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "quantitative"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ if(ncol(df) == 1)
+ lis <- list(df[, 1])
+ else
+ lis <- as.list(df)
+ thedis <- lapply(lis, fun1.Q)
+ names(thedis) <- names(x[[i]])
+ }
+
+ #*****************************************************#
+ # Nominal data #
+ #*****************************************************#
+
+ if(type[i] == "N"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ df <- x[[i]]
+ df2 <- cbind.data.frame(df[, apply(df, 2, function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("one of the nominal data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the nominal data sets")
+ df <- as.data.frame(df2)
+ }
+
+ verif <- function(u){
+ if(!is.factor(u)){
+ if(!is.character(u))
+ stop("Incorrect definition of the nominal variables")
+ }
+ }
+
+ lapply(df, verif)
+
+ #*****************************************************#
+
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+ fun1.N <- function(vect){
+ fun2.N <- function(u) {
+ if(any(is.na(c(vect[u[1]], vect[u[2]])))) return(NA)
+ else{
+ if(vect[u[1]] == vect[u[2]]){
+ return(0)
+ }
+ else return(1)
+ }
+ }
+ d <- unlist(apply(index, 1, fun2.N))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "nominal"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ if(ncol(df) == 1)
+ lis <- list(df[, 1])
+ else
+ lis <- as.list(df)
+ thedis <- lapply(lis, fun1.N)
+ names(thedis) <- names(x[[i]])
+ }
+
+ #*****************************************************#
+ # Dichotomous data #
+ #*****************************************************#
+
+ if(type[i] == "D"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ df <- x[[i]]
+ df2 <- cbind.data.frame(df[, apply(df, 2, function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("one of the nominal data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the dichotomous data sets")
+ df <- as.data.frame(df2)
+ }
+
+ verif <- function(u){
+ if(any(is.na(match(u, c(0,1)))))
+ stop("Dichotomous variables should have only 0, and 1")
+ }
+
+ lapply(df, verif)
+
+ #*****************************************************#
+
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+ fun1.D <- function(vect){
+ fun2.D <- function(u) {
+ if(any(is.na(c(vect[u[1]], vect[u[2]])))) return(NA)
+ else{
+ if(vect[u[1]] == vect[u[2]]){
+ if(vect[u[1]] == 1)
+ return(0)
+ else return(NA)
+ }
+ else
+ return(1)
+ }
+ }
+ d <- unlist(apply(index, 1, fun2.D))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "nominal"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ if(ncol(df) == 1)
+ lis <- list(df[, 1])
+ else
+ lis <- as.list(df)
+ thedis <- lapply(lis, fun1.D)
+ names(thedis) <- names(x[[i]])
+ }
+
+ #*****************************************************#
+ # Fuzzy data #
+ #*****************************************************#
+
+ if(type[i] == "F"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+ df <- x[[i]]
+ df2 <- df[, apply(df, 2, function(u) !all(is.na(u)))]
+ if(ncol(df2) == 0) stop("one of the fuzzy data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ stop("a column full of NA in the fuzzy data sets")
+ }
+
+ if(!all(unlist(lapply(df, is.numeric))))
+ stop("Incorrect definition of the fuzzy variables")
+
+ if(is.null(attributes(df)$col.blocks))
+ stop("The fuzzy data set must be prepared with the function prep.fuzzy")
+
+
+ #*****************************************************#
+
+ blocs <- attributes(x[[i]])$col.blocks
+ fac <- as.factor(rep(1:length(blocs), blocs))
+ lis <- split(as.data.frame(t(x[[i]])), fac)
+ lis <- lapply(lis, t)
+ lis <- lapply(lis, cbind.data.frame)
+
+ if(!any(is.na(x[[i]]))){
+ if(methodF!=3 & methodF!=4)
+ res <- lapply(lis, function(u) sqrt(dist.prop(u, method = methodF)))
+ else
+ res <- lapply(lis, function(u) dist.prop(u, method = methodF))
+ funfor0 <- function(x){
+ x[x < tol] <- 0
+ return(x)
+ }
+ thedis <- lapply(res, funfor0)
+ names(thedis) <- attributes(x[[i]])$Labels
+ }
+ else{
+ fun1.F <- function(mtflo){
+ res <- matrix(0, nlig, nlig)
+ positions <- apply(mtflo, 1, function(u) any(is.na(u)))
+ dfsansna <- mtflo[!positions, ]
+ if(methodF!=3 & methodF!=4)
+ resdis <- as.matrix(sqrt(dist.prop(dfsansna, method = methodF)))
+ else
+ resdis <- as.matrix(dist.prop(dfsansna, method = methodF))
+ res[!positions, !positions] <- as.vector(resdis)
+ res[positions, ] <- NA
+ res[, positions] <- NA
+ return(as.dist(res))
+ }
+ listdis <- lapply(lis, fun1.F)
+ funfor0 <- function(x){
+ x[x < tol] <- 0
+ return(x)
+ }
+ thedis <- lapply(listdis, funfor0)
+ names(thedis) <- attributes(x[[i]])$Labels
+ }
+ }
+
+ #*****************************************************#
+ # Binary data #
+ #*****************************************************#
+
+ if(type[i] == "B"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ if(!all(unlist(lapply(x[[i]], is.numeric))))
+ stop("Incorrect definition of the binary variables")
+
+ if(is.null(attributes(x[[i]])$col.blocks))
+ stop("The binary data set must be prepared with the function prep.binary")
+
+ if(any(is.na(match(as.vector(as.matrix(x[[i]])), c(0, 1, NA)))))
+ stop("The binary data set must be prepared with the function prep.binary")
+
+ #*****************************************************#
+
+ blocs <- attributes(x[[i]])$col.blocks
+ fac <- as.factor(rep(1:length(blocs), blocs))
+ lis <- split(as.data.frame(t(x[[i]])), fac)
+ lis <- lapply(lis, t)
+ lis <- lapply(lis, cbind.data.frame)
+
+ if(!any(is.na(x[[i]]))){
+ res <- lapply(lis, function(u) dist.binary(u, method = methodB))
+ if(any(is.na(unlist(res))))
+ stop("Rows of zero for binary variables")
+ funfor0 <- function(x){
+ x[x < tol] <- 0
+ return(x)
+ }
+ thedis <- lapply(res, funfor0)
+ names(thedis) <- attributes(x[[i]])$Labels
+ }
+ else{
+ fun1.B <- function(mtbin){
+ res <- matrix(0, nlig, nlig)
+ positions <- apply(mtbin, 1, function(u) any(is.na(u)))
+ dfsansna <- mtbin[!positions, ]
+ resdis <- as.matrix(dist.binary(dfsansna, method = methodB))
+ res[!positions, !positions] <- as.vector(resdis)
+ res[positions, ] <- NA
+ res[, positions] <- NA
+ return(as.dist(res))
+ }
+ listdis <- lapply(lis, fun1.B)
+ funfor0 <- function(x){
+ x[x < tol] <- 0
+ return(x)
+ }
+ thedis <- lapply(res, funfor0)
+ names(thedis) <- attributes(x[[i]])$Labels
+ }
+ }
+
+ #*****************************************************#
+ # Circular data #
+ #*****************************************************#
+
+ if(type[i] == "C"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ df <- x[[i]]
+ df2 <- cbind.data.frame(df[, apply(df, 2,
+ function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("the circular data frames ", i, " is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the circular data sets")
+ df <- as.data.frame(df2)
+ }
+
+ if(is.null(attributes(df)$max))
+ stop("The circular data sets must be prepared with the function prep.circular")
+
+ verif <- function(u){
+ if(any(u[!is.na(u)] < 0)) stop("negative values in circular variables")
+ }
+ lapply(df, verif)
+
+ #*****************************************************#
+
+ d.names <- row.names(x[[i]])
+ nlig <- nrow(x[[i]])
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)],
+ row(mat)[col(mat) < row(mat)])
+ odd <- function(u){
+ ifelse(abs(u/2 - floor(u/2)) < 1e-08, FALSE, TRUE)
+ }
+ if(!any(is.na(df))){
+ fun1.C <- function(nucol){
+ vect <- x[[i]][, nucol]
+ maxi <- attributes(df)$max[nucol]
+ vect <- vect / maxi
+ fun2.C <- function(u) {
+ if(odd(maxi))
+ return(sqrt((2 * maxi /(maxi - 1)) *
+ min(c(abs(vect[u[1]] - vect[u[2]]),
+ (1 - abs(vect[u[1]] - vect[u[2]]))),
+ na.rm = TRUE)))
+ else
+ return(sqrt(2 * min(c(abs(vect[u[1]] - vect[u[2]]),
+ (1 - abs(vect[u[1]] - vect[u[2]]))),
+ na.rm = TRUE)))
+ }
+ d <- unlist(apply(index, 1, fun2.C))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "circular"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ lis <- as.list(1:ncol(df))
+ res <- lapply(lis, fun1.C)
+ funfor0 <- function(x){
+ x[x < tol] <- 0
+ return(x)
+ }
+ thedis <- lapply(res, funfor0)
+ names(thedis) <- names(x[[i]])
+ }
+ else{
+ fun1.CNA <- function(nucol){
+ vect <- x[[i]][, nucol]
+ maxi <- attributes(df)$max[nucol]
+ vect <- vect / maxi
+ fun2.CNA <- function(u){
+ if(any(is.na(c(vect[u[1]], vect[u[2]])))) return(NA)
+ else{
+ if(odd(maxi))
+ return(sqrt((2 * maxi /(maxi - 1)) *
+ min(c(abs(vect[u[1]] - vect[u[2]]),
+ (1 - abs(vect[u[1]] - vect[u[2]]))),
+ na.rm = TRUE)))
+ else
+ return(sqrt(2 * min(c(abs(vect[u[1]] - vect[u[2]]),
+ (1 - abs(vect[u[1]] - vect[u[2]]))),
+ na.rm = TRUE)))
+ }
+ }
+ d <- unlist(apply(index, 1, fun2.CNA))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "circular"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ lis <- as.list(1:ncol(df))
+ listdis <- lapply(lis, fun1.CNA)
+ funfor0 <- function(x){
+ x[x < tol] <- 0
+ return(x)
+ }
+ thedis <- lapply(res, funfor0)
+ names(thedis) <- names(x[[i]])
+ }
+ }
+ return(thedis)
+ }
+
+ # Last calculations
+
+ interm <- as.list(1:length(x$blo))
+ names(interm) <- paste("iteration", 1:length(x$blo), sep="")
+ dispervar <- lapply(interm, treatment)
+ namesv <- unlist(lapply(dispervar, names))
+ dispervar <- do.call("c", dispervar)
+ names(dispervar) <- namesv
+ return(dispervar)
+ }
+
+ dist.ktab2 <-
+ function(x, type, option = c("scaledBYrange", "scaledBYsd", "noscale"), tol = 1e-8) {
+
+ treatment <- function(i)
+ {
+
+ #*****************************************************#
+ # Ordinal data #
+ #*****************************************************#
+
+ if(type[i] == "O"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ transrank <- function(u){
+ return(rank(u, na.last = "keep"))
+ }
+ df <- apply(x[[i]], 2, transrank)
+
+ #*****************************************************#
+
+ if(methodO == 1){
+ if(!any(is.na(df))){
+ cmax <- apply(df, 2, max, na.rm = TRUE)
+ cmin <- apply(df, 2, min, na.rm = TRUE)
+ df <- as.data.frame(scale(df, center = cmin, scale = (cmax - cmin)))
+ if(methodQ == 1){
+ thedis <- dist.quant(df, method = 1)
+ }
+ else{
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+ fun1.O <- function(tab){
+ fun2.O <- function(u) {
+ # start
+ return(sqrt(sum(abs(tab[u[1], ] - tab[u[2], ]))))
+ # end
+ }
+ d <- unlist(apply(index, 1, fun2.O))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "quantitative"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ thedis <- fun1.O(df)
+ }
+ thedis[thedis < tol] <- 0
+ nbvar <- ncol(x[[i]])
+ if(napres){
+ ntvar <- matrix(ncol(df), nrow(df), nrow(df))
+ }
+ }
+ else{
+ cmax <- apply(df, 2, max, na.rm = TRUE)
+ cmin <- apply(df, 2, min, na.rm = TRUE)
+ df <- as.data.frame(scale(df, center = cmin, scale = ifelse((cmax - cmin)<tol,
+ 1, cmax - cmin)))
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+
+ fun1.ONA <- function(vect){
+ fun2.ONA <- function(u) {
+ if(methodQ ==1)
+ return((vect[u[1]] - vect[u[2]])^2)
+
+ else
+ return(abs(vect[u[1]] - vect[u[2]]))
+ }
+ d <- unlist(apply(index, 1, fun2.ONA))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "quantitative"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ if(ncol(df) == 1)
+ lis <- list(df[, 1])
+ else
+ lis <- as.list(df)
+ listdis <- lapply(lis, fun1.ONA)
+
+ listmat <- lapply(listdis, as.matrix)
+ funfin1.ONA <- function(u){
+ u[!is.na(u)] <- 1
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ interm <- lapply(listmat, funfin1.ONA)
+ mat <- interm[[1]]
+ if(length(interm) > 1){
+ for (k in 2:length(interm)){
+ mat <- interm[[k]] + mat
+ }
+ }
+ ntvar <- mat
+ # calculation of the sum of distances
+ funfin2.ONA <- function(u){
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ res <- lapply(listdis, funfin2.ONA)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ }
+ }
+ else{
+ #####################################################
+ # Podani's distance #
+ #####################################################
+
+ df2 <- cbind.data.frame(df[, apply(df, 2, function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("one of the quantitative data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the quantitative or ordinal data set ", i)
+ df <- as.data.frame(df2)
+ }
+ if(!all(unlist(lapply(df, is.numeric))))
+ stop("Incorrect definition of the quantitative variables")
+
+ #*****************************************************#
+ cmax <- apply(df, 2, max, na.rm = TRUE)
+ cmin <- apply(df, 2, min, na.rm = TRUE)
+ if(ncol(df)>1)
+ granks <- apply(df, 2, table)
+ else
+ granks <- list(as.vector(apply(df, 2, table)))
+ grankmax <- as.vector(unlist(lapply(granks, function(u) u[length(u)])))
+ grankmin <- as.vector(unlist(lapply(granks, function(u) u[1])))
+ if(ncol(df)>1)
+ uranks <- apply(df, 2, function(u) sort(unique(u)))
+ else
+ uranks <- list(as.vector(apply(df, 2, function(u) sort(unique(u)))))
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+ fun1.OP <- function(k){
+ r <- df
+ fun2.OP <- function(u){
+ if(any(is.na(c(r[u[1], k], r[u[2], k])))){
+ return(NA)}
+ else{
+ if(r[u[1], k] == r[u[2], k]){
+ return(0)}
+ else{
+ val <- (abs(r[u[1], k] - r[u[2], k]) - (granks[[k]][uranks[[k]]==r[u[1], k]] - 1)/2 -
+ (granks[[k]][uranks[[k]]==r[u[2], k]]-1)/2) / ((cmax[k]-cmin[k]) -
+ (grankmax[k] - 1)/2 - (grankmin[k] - 1)/2)
+ return(val)
+ }
+ }
+ }
+ d <- unlist(apply(index, 1, fun2.OP))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "quantitative"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ lis <- as.list(1:ncol(df))
+ listdis <- lapply(lis, fun1.OP)
+ if(napres){
+ listmat <- lapply(listdis, as.matrix)
+ funfin1.OP <- function(u){
+ u[!is.na(u)] <- 1
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ interm <- lapply(listmat, funfin1.OP)
+ mat <- interm[[1]]
+ if(length(interm) > 1){
+ for (k in 2:length(interm)){
+ mat <- interm[[k]] + mat
+ }
+ }
+ ntvar <- mat
+ }
+ else
+ nbvar <- ncol(x[[i]])
+ # calculation of the sum of distances
+ funfin2.OP <- function(u){
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ res <- lapply(listdis, funfin2.OP)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ }
+ }
+
+ #*****************************************************#
+ # Quantitative data #
+ #*****************************************************#
+
+ if(type[i] == "Q"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ df <- x[[i]]
+ df2 <- cbind.data.frame(df[, apply(df, 2, function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("one of the quantitative data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the quantitative or ordinal data set ", i)
+ df <- as.data.frame(df2)
+ }
+ if(!all(unlist(lapply(df, is.numeric))))
+ stop("Incorrect definition of the quantitative variables")
+
+ #*****************************************************#
+
+ if(option[1] == "scaledBYsd")
+ df <- as.data.frame(scale(df))
+ if(option[1] == "scaledBYrange")
+ {
+ cmax <- apply(df, 2, max, na.rm = TRUE)
+ cmin <- apply(df, 2, min, na.rm = TRUE)
+ df <- as.data.frame(scale(df, center = cmin, scale = ifelse((cmax - cmin)<tol,
+ 1, cmax - cmin)))
+ }
+
+ if(!any(is.na(df))){
+ if(methodQ == 1){
+ thedis <- dist.quant(df, method = methodQ)
+ }
+ else{
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+ fun1.Q <- function(tab){
+ fun2.Q <- function(u) {
+ # start
+ return(sqrt(sum(abs(tab[u[1], ] - tab[u[2], ]))))
+ # end
+ }
+ d <- unlist(apply(index, 1, fun2.Q))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "quantitative"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ thedis <- fun1.Q(df)
+ }
+ thedis[thedis < tol] <- 0
+ nbvar <- ncol(x[[i]])
+ if(napres){
+ ntvar <- matrix(ncol(df), nrow(df), nrow(df))
+ }
+ }
+ else{
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+
+ fun1.QNA <- function(vect){
+ fun2.QNA <- function(u) {
+ if(methodQ == 1)
+ return((vect[u[1]] - vect[u[2]])^2)
+ else
+ return(abs(vect[u[1]] - vect[u[2]]))
+ }
+ d <- unlist(apply(index, 1, fun2.QNA))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "quantitative"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ if(ncol(df) == 1)
+ lis <- list(df[, 1])
+ else
+ lis <- as.list(df)
+ listdis <- lapply(lis, fun1.QNA)
+
+ listmat <- lapply(listdis, as.matrix)
+ funfin1.QNA <- function(u){
+ u[!is.na(u)] <- 1
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ interm <- lapply(listmat, funfin1.QNA)
+ mat <- interm[[1]]
+ if(length(interm) > 1){
+ for (k in 2:length(interm)){
+ mat <- interm[[k]] + mat
+ }
+ }
+ ntvar <- mat
+ # calculation of the sum of distances
+ funfin2.QNA <- function(u){
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ res <- lapply(listdis, funfin2.QNA)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ }
+ }
+
+ #*****************************************************#
+ # Nominal data #
+ #*****************************************************#
+
+ if(type[i] == "N"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ df <- x[[i]]
+ df2 <- cbind.data.frame(df[, apply(df, 2, function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("one of the nominal data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the nominal data sets")
+ df <- as.data.frame(df2)
+ }
+
+ verif <- function(u){
+ if(!is.factor(u)){
+ if(!is.character(u))
+ stop("Incorrect definition of the nominal variables")
+ }
+ }
+
+ lapply(df, verif)
+
+ #*****************************************************#
+
+ if(!any(is.na(df))){
+ FUN <- function(u){
+ m <- model.matrix(~-1 + as.factor(u))
+ return(dist(m) / sqrt(2))
+ }
+ lis <- as.list(df)
+ res <- lapply(lis, FUN)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ nbvar <- ncol(df)
+ if(napres){
+ ntvar <- matrix(ncol(df), nrow(df), nrow(df))
+ }
+ }
+ else{
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+ fun1.NNA <- function(vect){
+ fun2.NNA <- function(u) {
+ if(any(is.na(c(vect[u[1]], vect[u[2]])))) return(NA)
+ else{
+ if(vect[u[1]] == vect[u[2]]){
+ return(0)
+ }
+ else return(1)
+ }
+ }
+ d <- unlist(apply(index, 1, fun2.NNA))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "nominal"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ if(ncol(df) == 1)
+ lis <- list(df[, 1])
+ else
+ lis <- as.list(df)
+ listdis <- lapply(lis, fun1.NNA)
+
+ listmat <- lapply(listdis, as.matrix)
+ funfin1.NNA <- function(u){
+ u[!is.na(u)] <- 1
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ interm <- lapply(listmat, funfin1.NNA)
+ mat <- interm[[1]]
+ if(length(interm) > 1){
+ for (k in 2:length(interm)){
+ mat <- interm[[k]] + mat
+ }
+ }
+ ntvar <- mat
+ # calculation of the sum of distances
+ funfin2.NNA <- function(u){
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ res <- lapply(listdis, funfin2.NNA)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ }
+ }
+
+ #*****************************************************#
+ # Dichotomous data #
+ #*****************************************************#
+
+ if(type[i] == "D"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ df <- x[[i]]
+ df2 <- cbind.data.frame(df[, apply(df, 2, function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("one of the nominal data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the dichotomous data sets")
+ df <- as.data.frame(df2)
+ }
+
+ verif <- function(u){
+ if(any(is.na(match(u, c(0,1)))))
+ stop("Dichotomous variables should have only 0, and 1")
+ }
+
+ lapply(df, verif)
+
+ #*****************************************************#
+
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)], row(mat)[col(mat) < row(mat)])
+ fun1.D <- function(vect){
+ fun2.D <- function(u) {
+ if(any(is.na(c(vect[u[1]], vect[u[2]])))) return(NA)
+ else{
+ if(vect[u[1]] == vect[u[2]]){
+ if(vect[u[1]] == 1)
+ return(0)
+ else return(NA)
+ }
+ else
+ return(1)
+ }
+ }
+ d <- unlist(apply(index, 1, fun2.D))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "nominal"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ if(ncol(df) == 1)
+ lis <- list(df[, 1])
+ else
+ lis <- as.list(df)
+ listdis <- lapply(lis, fun1.D)
+
+ listmat <- lapply(listdis, as.matrix)
+ funfin1.D <- function(u){
+ u[!is.na(u)] <- 1
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ interm <- lapply(listmat, funfin1.D)
+ mat <- interm[[1]]
+ if(length(interm) > 1){
+ for (k in 2:length(interm)){
+ mat <- interm[[k]] + mat
+ }
+ }
+ ntvar <- mat
+ # calculation of the sum of distances
+ funfin2.D <- function(u){
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ res <- lapply(listdis, funfin2.D)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ }
+
+ #*****************************************************#
+ # Fuzzy data #
+ #*****************************************************#
+
+ if(type[i] == "F"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+ df <- x[[i]]
+ df2 <- df[, apply(df, 2, function(u) !all(is.na(u)))]
+ if(ncol(df2) == 0) stop("one of the fuzzy data frames is full of NA")
+ if(ncol(df) != ncol(df2)){
+ stop("a column full of NA in the fuzzy data sets")
+ }
+
+ if(!all(unlist(lapply(df, is.numeric))))
+ stop("Incorrect definition of the fuzzy variables")
+
+ if(is.null(attributes(df)$col.blocks))
+ stop("The fuzzy data set must be prepared with the function prep.fuzzy")
+
+
+ #*****************************************************#
+
+ blocs <- attributes(x[[i]])$col.blocks
+ fac <- as.factor(rep(1:length(blocs), blocs))
+ lis <- split(as.data.frame(t(x[[i]])), fac)
+ lis <- lapply(lis, t)
+ lis <- lapply(lis, cbind.data.frame)
+
+ if(!any(is.na(x[[i]]))){
+ if(methodF!=3 & methodF!=4)
+ res <- lapply(lis, function(u) dist.prop(u, method = methodF))
+ else
+ res <- lapply(lis, function(u) dist.prop(u, method = methodF)^2)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ nbvar <- length(blocs)
+ if(napres){
+ ntvar <- matrix(length(blocs), nrow(df), nrow(df))
+ }
+ }
+ else{
+ fun1.F <- function(mtflo){
+ res <- matrix(0, nlig, nlig)
+ positions <- apply(mtflo, 1, function(u) any(is.na(u)))
+ dfsansna <- mtflo[!positions, ]
+ if(methodF!=3 & methodF!=4)
+ resdis <- as.matrix(dist.prop(dfsansna, method = methodF))
+ else
+ resdis <- as.matrix(dist.prop(dfsansna, method = methodF)^2)
+ res[!positions, !positions] <- as.vector(resdis)
+ res[positions, ] <- NA
+ res[, positions] <- NA
+ return(as.dist(res))
+ }
+ listdis <- lapply(lis, fun1.F)
+
+ listmat <- lapply(listdis, as.matrix)
+ funfin1.F <- function(u){
+ u[!is.na(u)] <- 1
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ interm <- lapply(listmat, funfin1.F)
+ mat <- interm[[1]]
+ if(length(interm) > 1){
+ for (k in 2:length(interm)){
+ mat <- interm[[k]] + mat
+ }
+ }
+ ntvar <- mat
+ # calculation of the sum of distances
+ funfin2.F <- function(u){
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ res <- lapply(listdis, funfin2.F)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ }
+ }
+
+ #*****************************************************#
+ # Binary data #
+ #*****************************************************#
+
+ if(type[i] == "B"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ if(!all(unlist(lapply(x[[i]], is.numeric))))
+ stop("Incorrect definition of the binary variables")
+
+ if(is.null(attributes(x[[i]])$col.blocks))
+ stop("The binary data set must be prepared with the function prep.binary")
+
+ if(any(is.na(match(as.vector(as.matrix(x[[i]])), c(0, 1, NA)))))
+ stop("The binary data set must be prepared with the function prep.binary")
+
+ #*****************************************************#
+
+ blocs <- attributes(x[[i]])$col.blocks
+ fac <- as.factor(rep(1:length(blocs), blocs))
+ lis <- split(as.data.frame(t(x[[i]])), fac)
+ lis <- lapply(lis, t)
+ lis <- lapply(lis, cbind.data.frame)
+
+ if(!any(is.na(x[[i]]))){
+ res <- lapply(lis, function(u) dist.binary(u, method = methodB)^2)
+ if(any(is.na(unlist(res))))
+ stop("Rows of zero for binary variables")
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ nbvar <- length(blocs)
+ if(napres){
+ ntvar <- matrix(length(blocs), nlig, nlig)
+ }
+ }
+ else{
+ fun1.BNA <- function(mtbin){
+ res <- matrix(0, nlig, nlig)
+ positions <- apply(mtbin, 1, function(u) any(is.na(u)))
+ dfsansna <- mtbin[!positions, ]
+ resdis <- as.matrix(dist.binary(dfsansna, method = methodB)^2)
+ res[!positions, !positions] <- as.vector(resdis)
+ res[positions, ] <- NA
+ res[, positions] <- NA
+ return(as.dist(res))
+ }
+ listdis <- lapply(lis, fun1.BNA)
+
+ listmat <- lapply(listdis, as.matrix)
+ funfin1.BNA <- function(u){
+ u[!is.na(u)] <- 1
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ interm <- lapply(listmat, funfin1.BNA)
+ mat <- interm[[1]]
+ if(length(interm) > 1){
+ for (k in 2:length(interm)){
+ mat <- interm[[k]] + mat
+ }
+ }
+ ntvar <- mat
+ # calculation of the sum of distances
+ funfin2.BNA <- function(u){
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ res <- lapply(listdis, funfin2.BNA)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ }
+ }
+
+ #*****************************************************#
+ # Circular data #
+ #*****************************************************#
+
+ if(type[i] == "C"){
+
+ #*****************************************************#
+ # Data are checked #
+ #*****************************************************#
+
+ df <- x[[i]]
+ df2 <- cbind.data.frame(df[, apply(df, 2,
+ function(u) !all(is.na(u)))])
+ if(ncol(df2) == 0) stop("the circular data frames ", i, " is full of NA")
+ if(ncol(df) != ncol(df2)){
+ warning("a column full of NA in the circular data sets")
+ df <- as.data.frame(df2)
+ }
+
+ if(is.null(attributes(df)$max))
+ stop("The circular data sets must be prepared with the function prep.circular")
+
+ verif <- function(u){
+ if(any(u[!is.na(u)] < 0)) stop("negative values in circular variables")
+ }
+ lapply(df, verif)
+
+ #*****************************************************#
+
+ d.names <- row.names(x[[i]])
+ nlig <- nrow(x[[i]])
+ mat <- matrix(0, nlig, nlig)
+ index <- cbind(col(mat)[col(mat) < row(mat)],
+ row(mat)[col(mat) < row(mat)])
+ odd <- function(u){
+ ifelse(abs(u/2 - floor(u/2)) < 1e-08, FALSE, TRUE)
+ }
+ if(!any(is.na(df))){
+ fun1.C <- function(nucol){
+ vect <- x[[i]][, nucol]
+ maxi <- attributes(df)$max[nucol]
+ vect <- vect / maxi
+ fun2.C <- function(u) {
+ if(odd(maxi))
+ return((2 * maxi /(maxi - 1)) *
+ min(c(abs(vect[u[1]] - vect[u[2]]),
+ (1 - abs(vect[u[1]] - vect[u[2]]))),
+ na.rm = TRUE))
+ else
+ return(2 * min(c(abs(vect[u[1]] - vect[u[2]]),
+ (1 - abs(vect[u[1]] - vect[u[2]]))),
+ na.rm = TRUE))
+ }
+ d <- unlist(apply(index, 1, fun2.C))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "circular"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ lis <- as.list(1:ncol(df))
+ res <- lapply(lis, fun1.C)
+
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ nbvar <- ncol(x[[i]])
+ if(napres){
+ ntvar <- matrix(ncol(x[[i]]), nrow(df), nrow(df))
+ }
+ }
+ else{
+ fun1.CNA <- function(nucol){
+ vect <- x[[i]][, nucol]
+ maxi <- attributes(df)$max[nucol]
+ vect <- vect / maxi
+ fun2.CNA <- function(u){
+ if(any(is.na(c(vect[u[1]], vect[u[2]])))) return(NA)
+ else{
+ if(odd(maxi))
+ return((2 * maxi /(maxi - 1)) *
+ min(c(abs(vect[u[1]] - vect[u[2]]),
+ (1 - abs(vect[u[1]] - vect[u[2]]))),
+ na.rm = TRUE))
+ else
+ return(2 * min(c(abs(vect[u[1]] - vect[u[2]]),
+ (1 - abs(vect[u[1]] - vect[u[2]]))),
+ na.rm = TRUE))
+ }
+ }
+ d <- unlist(apply(index, 1, fun2.CNA))
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "method") <- "circular"
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+ }
+ lis <- as.list(1:ncol(df))
+ listdis <- lapply(lis, fun1.CNA)
+
+ listmat <- lapply(listdis, as.matrix)
+ funfin1.CNA <- function(u){
+ u[!is.na(u)] <- 1
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ interm <- lapply(listmat, funfin1.CNA)
+ mat <- interm[[1]]
+ if(length(interm) > 1){
+ for (k in 2:length(interm)){
+ mat <- interm[[k]] + mat
+ }
+ }
+ ntvar <- mat
+ # calculation of the sum of distances
+ funfin2.CNA <- function(u){
+ u[is.na(u)] <- 0
+ return(u)
+ }
+ res <- lapply(listdis, funfin2.CNA)
+ mat <- res[[1]]
+ if(length(res) > 1){
+ for (k in 2:length(res)){
+ mat <- res[[k]] + mat
+ }
+ }
+ thedis <- mat
+ thedis[thedis < tol] <- 0
+ thedis <- sqrt(thedis)
+ }
+ }
+
+ if(!napres)
+ return(list(nbvar, thedis))
+ else
+ return(list(ntvar, thedis))
+ }
+
+ # Last calculations
+
+ interm <- as.list(1:length(x$blo))
+ names(interm) <- paste("iteration", 1:length(x$blo), sep="")
+ res <- lapply(interm, treatment)
+ if(!napres)
+ nbvar <- sum(unlist(lapply(res, function(u) u[[1]])))
+ else{
+ listntvar <- lapply(res, function(u) u[[1]])
+ mat <- listntvar[[1]]
+ if(length(listntvar) > 1){
+ for (k in 2:length(listntvar)){
+ mat <- listntvar[[k]] + mat
+ }
+ }
+ ntvar <- mat + diag(rep(1, nlig))
+ }
+ dis <- lapply(res, function(u) u[[2]])
+ mat <- dis[[1]]^2
+ if(length(dis) > 1){
+ for (k in 2:length(dis)){
+ mat <- dis[[k]]^2 + mat
+ }
+ }
+ if(!napres){
+ disglobal <- sqrt(mat / nbvar)
+ }
+ else{
+ disglobal <- as.dist(sqrt(as.matrix(mat) / ntvar))
+ }
+
+ attributes(disglobal)$Labels <- d.names
+
+ return(disglobal)
+ }
+
+ ldis <- ldist.ktab2(x, type, option, tol = 1e-8)
+ disglob <- dist.ktab2(x, type, option, tol = 1e-8)
+ tabvec <- cbind.data.frame(lapply(ldis, as.vector))
+ vecglo <- as.vector(disglob)
+ if(squared){
+ paircov <- cov(tabvec^2, use = "pairwise.complete.obs")
+ paircor <- cor(tabvec^2, use = "pairwise.complete.obs")
+ glocor <- cor(tabvec^2, vecglo^2, use = "pairwise.complete.obs")
+ colnames(glocor) <- "global distance"
+ }
+ else{
+ paircov <- cov(tabvec, use = "pairwise.complete.obs")
+ paircor <- cor(tabvec, use = "pairwise.complete.obs")
+ glocor <- cor(tabvec, vecglo, use = "pairwise.complete.obs")
+ colnames(glocor) <- "global distance"
+ }
+ return(list(paircov = paircov, paircor = paircor, glocor = glocor))
+
+}
+
diff --git a/R/dist.neig.R b/R/dist.neig.R
new file mode 100644
index 0000000..eeee413
--- /dev/null
+++ b/R/dist.neig.R
@@ -0,0 +1,18 @@
+"dist.neig" <- function (neig) {
+ if (!inherits(neig, "neig"))
+ stop("Object of class 'neig' expected")
+ res <- neig.util.LtoG(neig)
+ n <- nrow(res)
+ auxi1 <- res
+ auxi2 <- res
+ for (itour in 2:n) {
+ auxi2 <- auxi2 %*% auxi1
+ auxi2[res != 0] <- 0
+ diag(auxi2) <- 0
+ auxi2 <- (auxi2 > 0) * itour
+ if (sum(auxi2) == 0)
+ break
+ res <- res + auxi2
+ }
+ return(as.dist(res))
+}
diff --git a/R/dist.prop.R b/R/dist.prop.R
new file mode 100644
index 0000000..db54fec
--- /dev/null
+++ b/R/dist.prop.R
@@ -0,0 +1,83 @@
+"dist.prop" <- function (df, method = NULL, diag = FALSE, upper = FALSE) {
+ METHODS <- c("d1 Manly", "Overlap index Manly", "Rogers 1972",
+ "Nei 1972", "Edwards 1971")
+ if (!inherits(df, "data.frame"))
+ stop("df is not a data.frame")
+ if (any(df < 0))
+ stop("non negative value expected in df")
+ dfs <- apply(df, 1, sum)
+ if (any(dfs == 0))
+ stop("row with all zero value")
+ df <- df/dfs
+ if (is.null(method)) {
+ cat("1 = d1 Manly\n")
+ cat("d1 = Sum|p(i)-q(i)|/2\n")
+ cat("2 = Overlap index Manly\n")
+ cat("d2=1-Sum(p(i)q(i))/sqrt(Sum(p(i)^2)/sqrt(Sum(q(i)^2)\n")
+ cat("3 = Rogers 1972 (one locus)\n")
+ cat("d3=sqrt(0.5*Sum(p(i)-q(i)^2))\n")
+ cat("4 = Nei 1972 (one locus)\n")
+ cat("d4=-ln(Sum(p(i)q(i)/sqrt(Sum(p(i)^2)/sqrt(Sum(q(i)^2))\n")
+ cat("5 = Edwards 1971 (one locus)\n")
+ cat("d5= sqrt (1 - (Sum(sqrt(p(i)q(i))))\n")
+ cat("Selec an integer (1-5): ")
+ method <- as.integer(readLines(n = 1))
+ }
+ nlig <- nrow(df)
+ d <- matrix(0, nlig, nlig)
+ d.names <- row.names(df)
+ df <- as.matrix(df)
+ fun1 <- function(x) {
+ p <- df[x[1], ]
+ q <- df[x[2], ]
+ w <- sum(abs(p - q))/2
+ return(w)
+ }
+ fun2 <- function(x) {
+ p <- df[x[1], ]
+ q <- df[x[2], ]
+ w <- 1 - sum(p * q)/sqrt(sum(p * p))/sqrt(sum(q * q))
+ return(w)
+ }
+ fun3 <- function(x) {
+ p <- df[x[1], ]
+ q <- df[x[2], ]
+ w <- sqrt(0.5 * sum((p - q)^2))
+ return(w)
+ }
+ fun4 <- function(x) {
+ p <- df[x[1], ]
+ q <- df[x[2], ]
+ if (sum(p * q) == 0)
+ stop("sum(p*q)==0 -> non convenient data")
+ w <- -log(sum(p * q)/sqrt(sum(p * p))/sqrt(sum(q * q)))
+ return(w)
+ }
+ fun5 <- function(x) {
+ p <- df[x[1], ]
+ q <- df[x[2], ]
+ w <- sqrt(1 - sum(sqrt(p * q)))
+ return(w)
+ }
+ index <- cbind(col(d)[col(d) < row(d)], row(d)[col(d) < row(d)])
+ method <- method[1]
+ if (method == 1)
+ d <- unlist(apply(index, 1, fun1))
+ else if (method == 2)
+ d <- unlist(apply(index, 1, fun2))
+ else if (method == 3)
+ d <- unlist(apply(index, 1, fun3))
+ else if (method == 4)
+ d <- unlist(apply(index, 1, fun4))
+ else if (method == 5)
+ d <- unlist(apply(index, 1, fun5))
+ else stop("Non convenient method")
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- diag
+ attr(d, "Upper") <- upper
+ attr(d, "method") <- METHODS[method]
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+}
diff --git a/R/dist.quant.R b/R/dist.quant.R
new file mode 100644
index 0000000..8b28b27
--- /dev/null
+++ b/R/dist.quant.R
@@ -0,0 +1,55 @@
+"dist.quant" <- function (df, method = NULL, diag = FALSE, upper = FALSE, tol = 1e-07) {
+ METHODS <- c("Canonical", "Joreskog", "Mahalanobis")
+ df <- data.frame(df)
+ if (!inherits(df, "data.frame"))
+ stop("df is not a data.frame")
+ if (is.null(method)) {
+ cat("1 = Canonical\n")
+ cat("d1 = ||x-y|| A=Identity\n")
+ cat("2 = Joreskog\n")
+ cat("d2=d2 = ||x-y|| A=1/diag(cov)\n")
+ cat("3 = Mahalanobis\n")
+ cat("d3 = ||x-y|| A=inv(cov)\n")
+ cat("Selec an integer (1-3): ")
+ method <- as.integer(readLines(n = 1))
+ }
+ nlig <- nrow(df)
+ d <- matrix(0, nlig, nlig)
+ d.names <- row.names(df)
+ fun1 <- function(x) {
+ sqrt(sum((df[x[1], ] - df[x[2], ])^2))
+ }
+ df <- as.matrix(df)
+ index <- cbind(col(d)[col(d) < row(d)], row(d)[col(d) < row(d)])
+ method <- method[1]
+ if (method == 1) {
+ d <- unlist(apply(index, 1, fun1))
+ }
+ else if (method == 2) {
+ dfcov <- cov(df) * (nlig - 1)/nlig
+ jor <- diag(dfcov)
+ jor[jor == 0] <- 1
+ jor <- 1/sqrt(jor)
+ df <- t(t(df) * jor)
+ d <- unlist(apply(index, 1, fun1))
+ }
+ else if (method == 3) {
+ dfcov <- cov(df) * (nlig - 1)/nlig
+ maha <- eigen(dfcov, symmetric = TRUE)
+ maha.r <- sum(maha$values > (maha$values[1] * tol))
+ maha.e <- 1/sqrt(maha$values[1:maha.r])
+ maha.v <- maha$vectors[, 1:maha.r]
+ maha.v <- t(t(maha.v) * maha.e)
+ df <- df %*% maha.v
+ d <- unlist(apply(index, 1, fun1))
+ }
+ else stop("Non convenient method")
+ attr(d, "Size") <- nlig
+ attr(d, "Labels") <- d.names
+ attr(d, "Diag") <- diag
+ attr(d, "Upper") <- upper
+ attr(d, "method") <- METHODS[method]
+ attr(d, "call") <- match.call()
+ class(d) <- "dist"
+ return(d)
+}
diff --git a/R/divc.R b/R/divc.R
new file mode 100644
index 0000000..80bed99
--- /dev/null
+++ b/R/divc.R
@@ -0,0 +1,26 @@
+divc <- function(df, dis = NULL, scale = FALSE){
+ # checking of user's data and initialization.
+ if (!inherits(df, "data.frame")) stop("Non convenient df")
+ if (any(df < 0)) stop("Negative value in df")
+ if (!is.null(dis)) {
+ if (!inherits(dis, "dist")) stop("Object of class 'dist' expected for distance")
+ if (!is.euclid(dis)) warning("Euclidean property is expected for distance")
+ dis <- as.matrix(dis)
+ if (nrow(df)!= nrow(dis)) stop("Non convenient df")
+ dis <- as.dist(dis)
+ }
+ if (is.null(dis)) dis <- as.dist((matrix(1, nrow(df), nrow(df))
+ - diag(rep(1, nrow(df)))) * sqrt(2))
+ div <- as.data.frame(rep(0, ncol(df)))
+ names(div) <- "diversity"
+ rownames(div) <- names(df)
+ for (i in 1:ncol(df)) {
+ if(sum(df[, i]) < 1e-16) div[i, ] <- 0
+ else div[i, ] <- (t(df[, i]) %*% (as.matrix(dis)^2) %*% df[, i]) / 2 / (sum(df[, i])^2)
+ }
+ if(scale == TRUE){
+ divmax <- divcmax(dis)$value
+ div <- div / divmax
+ }
+ return(div)
+}
diff --git a/R/divcmax.R b/R/divcmax.R
new file mode 100644
index 0000000..291509a
--- /dev/null
+++ b/R/divcmax.R
@@ -0,0 +1,101 @@
+divcmax <- function(dis, epsilon = 1e-008, comment = FALSE)
+{
+# inititalisation
+ if(!inherits(dis, "dist")) stop("Distance matrix expected")
+ if(epsilon <= 0) stop("epsilon must be positive")
+ if(!is.euclid(dis)) stop("Euclidean property is expected for dis")
+ D2 <- as.matrix(dis)^2 / 2
+ n <- dim(D2)[1]
+ result <- data.frame(matrix(0, n, 4))
+ names(result) <- c("sim", "pro", "met", "num")
+ relax <- 0 # determination de la valeur initiale x0
+ x0 <- apply(D2, 1, sum) / sum(D2)
+ result$sim <- x0 # ponderation simple
+ objective0 <- t(x0) %*% D2 %*% x0
+ if (comment == TRUE)
+ print("evolution of the objective function:")
+ xk <- x0 # grande boucle de test des conditions de Kuhn-Tucker
+ repeat {
+ # boucle de test de nullite du gradient projete
+ repeat {
+ maxi.temp <- t(xk) %*% D2 %*% xk
+ if(comment == TRUE) print(as.character(maxi.temp))
+ #calcul du gradient
+ deltaf <- (-2 * D2 %*% xk)
+ # determination des contraintes saturees
+ sature <- (abs(xk) < epsilon)
+ if(relax != 0) {
+ sature[relax] <- FALSE
+ relax <- 0
+ }
+ # construction du gradient projete
+ yk <- ( - deltaf)
+ yk[sature] <- 0
+ yk[!(sature)] <- yk[!(sature)] - mean(yk[!(
+ sature)])
+ # test de la nullite du gradient projete
+ if (max(abs(yk)) < epsilon) {
+ break
+ }
+ # determination du pas le plus grand compatible avec les contraintes
+ alpha.max <- as.vector(min( - xk[yk < 0] / yk[yk <
+ 0]))
+ alpha.opt <- as.vector( - (t(xk) %*% D2 %*% yk) / (
+ t(yk) %*% D2 %*% yk))
+ if ((alpha.opt > alpha.max) | (alpha.opt < 0)) {
+ alpha <- alpha.max
+ }
+ else {
+ alpha <- alpha.opt
+ }
+ if (abs(maxi.temp - t(xk + alpha * yk) %*% D2 %*% (
+ xk + alpha * yk)) < epsilon) {
+ break
+ }
+ xk <- xk + alpha * yk
+ }
+ # verification des conditions de KT
+ if (prod(!sature) == 1) {
+ if (comment == TRUE)
+ print("KT")
+ break
+ }
+ vectD2 <- D2 %*% xk
+ u <- 2 * (mean(vectD2[!sature]) - vectD2[sature])
+ if (min(u) >= 0) {
+ if (comment == TRUE)
+ print("KT")
+ break
+ }
+ else {
+ if (comment == TRUE)
+ print("relaxation")
+ satu <- (1:n)[sature]
+ relax <- satu[u == min(u)]
+ relax <-relax[1]
+ }
+ }
+ if (comment == TRUE)
+ print(list(objective.init = objective0, objective.final
+ = maxi.temp))
+ result$num <- as.vector(xk, mode = "numeric")
+ result$num[result$num < epsilon] <- 0
+ # ponderation numerique
+ xk <- x0 / sqrt(sum(x0 * x0))
+ repeat {
+ yk <- D2 %*% xk
+ yk <- yk / sqrt(sum(yk * yk))
+ if (max(xk - yk) > epsilon) {
+ xk <- yk
+ }
+ else break
+ }
+ x0 <- as.vector(yk, mode = "numeric")
+ result$pro <- x0 / sum(x0) # ponderation propre
+ result$met <- x0 * x0 # ponderation propre
+ restot <- list()
+ restot$value <- divc(cbind.data.frame(result$num), dis)[,1]
+ restot$vectors <- result
+ return(restot)
+}
+
diff --git a/R/dotchart.phylog.R b/R/dotchart.phylog.R
new file mode 100644
index 0000000..7bea01e
--- /dev/null
+++ b/R/dotchart.phylog.R
@@ -0,0 +1,102 @@
+"dotchart.phylog" <- function(phylog, values, y = NULL, scaling = TRUE, ranging = TRUE, yranging = NULL,
+ joining = TRUE, yjoining = NULL, ceti = 1, cdot = 1, csub = 1, f.phylog = 1/(1 + ncol(values)), ...)
+{
+
+# l'argument scaling décide si l'on normalise les données ou non
+# l'argument ranging décide si l'on adopte une échelle commune pour toutes les séries ou non
+# l'argument yranging permet de fixer l'échelle commune à toutes les séries lorsque ranging = TRUE. Par défaut, l'échelle
+# commune est choisit en prenant les valeurs extrêmes de l'ensemble des valeurs
+# l'argument joining décide si'lon rajoute ou non des traits verticaux qui relie chaque point à un axe horizontal
+# l'argument yjoining définit le niveau de l'axe horizontal. Par défaut, il s'agit de la moyenne de chaque série.
+# les autres arguments sont des arguments graphiques:
+# ceti pour la taille des absisses
+# cdot pour la taille des carrés
+# csub pour la taille du titre de chaque série
+# f.phylog pour la taille relative de la phylogénie
+
+ if (!inherits(phylog, "phylog"))
+ stop("Non convenient data")
+
+ if (is.vector(values))
+ values <- as.data.frame(values)
+
+ if (!is.data.frame(values))
+ stop("'values' is not a data frame")
+
+ if (!is.numeric(as.matrix(values)))
+ stop("'values' is not numeric")
+
+ n <- nrow(values)
+ nvar <- ncol(values)
+ names.var <- names(values)
+
+ if (length(phylog$leaves) != n)
+ stop("Non convenient length")
+
+ if (scaling == TRUE){
+ values <- scalewt(values)
+ values <- as.data.frame(values)
+ names(values) <- names.var
+ }
+
+ w <- plot.phylog(x = phylog, y = y, clabel.leaves = 0, f.phylog = f.phylog, ...)
+ mar.old <- par("mar")
+ on.exit(par(mar = mar.old))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ par(usr = c(0, 1, -0.05, 1))
+
+ x1 <- w$xbase
+ space <- (1 - w$xbase - (w$xbase - max(w$xy$x))/2*nvar)/nvar
+ x2 <- x1 + space
+ fun1 <- function(x) {x1 + (x2 - x1) * (x - x1.use)/(x2.use - x1.use)}
+
+ ret <- cbind.data.frame(values,w$xy[,"y"])
+ for(i in 1:nvar){
+
+ if (ranging == TRUE){
+ if (is.null(yranging))
+ val.ref <- pretty(range(values), 4)
+ else
+ val.ref <- pretty(yranging, 4)
+ }
+ else
+ val.ref <- pretty(values[,i], 4)
+
+ x1.use <- min(val.ref)
+ x2.use <- max(val.ref)
+ xleg <- fun1(val.ref)
+ miny <- 0
+ maxy <- max(w$xy$y)
+ nleg <- length(xleg)
+
+ segments(xleg, rep(miny, nleg), xleg, rep(maxy, nleg), col = grey(0.85))
+ segments(w$xy$x, w$xy$y, rep(max(w$xy$x), n), w$xy$y, col = grey(0.85))
+ segments(rep(xleg[1], n), w$xy$y, rep(max(xleg), n), w$xy$y, col = grey(0.85))
+
+ if (cdot > 0)
+ points(fun1(values[,i]), w$xy$y, pch = 15, cex = cdot, bg = 1)
+
+ if (ceti > 0){
+ if (trunc(i/2) < (i/2))
+ text(xleg, rep((miny - 0.05)*2/3, nleg), as.character(val.ref), cex = par("cex") * ceti)
+ else
+ text(xleg, rep((miny - 0.05)*1/3, nleg), as.character(val.ref), cex = par("cex") * ceti)
+ }
+
+ if (joining == TRUE){
+ if (is.null(yjoining)) origin <- mean(values[,i])
+ else origin <- 0
+ segments(fun1(origin), miny, fun1(origin), maxy, lty = 2, col = grey(0.50))
+ segments(fun1(values[,i]), w$xy$y, fun1(origin), w$xy$y, col = grey(0.50))
+ }
+
+ if (csub > 0)
+ text(xleg[3], 1 - (1-max(w$xy$y))/3, names(values)[i], cex = par("cex") * csub)
+
+ ret[,i] <- fun1(values[,i])
+
+ x1 <- x1 + space + (w$xbase - max(w$xy$x))/2
+ x2 <- x2 + space + (w$xbase - max(w$xy$x))/2
+ }
+ return(invisible(ret))
+}
diff --git a/R/dotcircle.R b/R/dotcircle.R
new file mode 100644
index 0000000..5c33d8b
--- /dev/null
+++ b/R/dotcircle.R
@@ -0,0 +1,44 @@
+"dotcircle" <- function (z,alpha0=pi/2,xlim=range(pretty(z)),labels=names(z),clabel=1,cleg=1) {
+ if (!is.numeric(z)) stop("z is not numeric")
+ n <- length(z)
+ if (n<=2) stop ("length(z)<3")
+ if (is.null (labels)) clabel <- 0
+ if (length(labels)!=length(z)) clabel <- 0
+ alpha <- alpha0-(1:n)*2*pi/n
+ leg <- xlim
+ leg0 <- (leg-min(leg))/(max(leg)-min(leg))*0.8+0.2
+ z0 <- (z-min(leg))/(max(leg)-min(leg))*0.8+0.2
+ opar <- par(mar = par("mar"),srt=par("srt"))
+ on.exit(par(opar))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ x <- z0*cos(alpha)
+ y <- z0*sin(alpha)
+
+ plot( c(0,0), type = "n", ylab = "", asp = 1, xaxt = "n",
+ yaxt = "n", frame.plot = FALSE, xlim=c(-1.2,1.2), ylim=c(-1.2,1.2))
+ # if (clabel > 0) scatter.util.eti.circ(x, y, label, clabel)
+ # if (csub > 0) scatter.util.sub(sub, csub, possub)
+ # if (box) box()
+
+ symbols(0, 0, circles=0.2,inches=FALSE,add=TRUE)
+ for (i in 1:2) {
+ symbols(0, 0, circles=leg0[i],inches=FALSE,add=TRUE,fg=grey(0.5))
+ }
+ points(x,y,type="o",pch=20,cex=2)
+ segments(x[n],y[n],x[1],y[1])
+ segments(0.2*cos(alpha),0.2*sin(alpha),x,y)
+ if (clabel>0) {
+ for (i in 1:n) {
+ par(srt=alpha[i]*360/2/pi)
+ text(1.1*cos(alpha[i]),1.1*sin(alpha[i]),labels[i],adj=0,cex=par("cex")*clabel)
+ segments(cos(alpha[i]),sin(alpha[i]),1.1*cos(alpha[i]),1.1*sin(alpha[i]),col=grey(0.5))
+ }
+ }
+ par(srt=0)
+ if (cleg>0) {
+ s.label(cbind.data.frame(c(0.2,0,-0.2,0),c(0,-0.2,0,0.2)),
+ label=as.character(rep(leg[1],4)),add.plot=TRUE,clabel=cleg)
+ s.label(cbind.data.frame(c(1,0,-1,0),c(0,-1,0,1)),
+ label=as.character(rep(leg[2],4)),clabel=cleg, add.plot=TRUE)
+ }
+}
diff --git a/R/dpcoa.R b/R/dpcoa.R
new file mode 100644
index 0000000..71d0816
--- /dev/null
+++ b/R/dpcoa.R
@@ -0,0 +1,160 @@
+dpcoa <- function (df, dis = NULL, scannf = TRUE, nf = 2, full = FALSE, tol = 1e-07, RaoDecomp = TRUE)
+{
+ if (!inherits(df, "data.frame"))
+ stop("df is not a data.frame")
+ if (any(df < 0))
+ stop("Negative value in df")
+ if (any(rowSums(df) < tol))
+ stop("Remove empty samples")
+ nesp <- ncol(df)
+ nrel <- nrow(df)
+ if (!is.null(dis)) {
+ if (!inherits(dis, "dist"))
+ stop("dis is not an object 'dist'")
+ n1 <- attr(dis, "Size")
+ if (nesp != n1)
+ stop("Non convenient dimensions")
+ if (!is.euclid(dis))
+ stop("an Euclidean matrix is needed")
+ }
+ if (is.null(dis)) {
+ dis <- (matrix(1, nesp, nesp) - diag(rep(1, nesp))) * sqrt(2)
+ rownames(dis) <- colnames(dis) <- names(df)
+ dis <- as.dist(dis)
+ }
+ if (is.null(attr(dis, "Labels")))
+ attr(dis, "Labels") <- names(df)
+
+ d <- as.matrix(dis)
+ d <- (d^2) / 2
+
+ w.samples <- rowSums(df)/sum(df)
+ w.esp <- colSums(df)/sum(df)
+ dfp <- as.matrix(sweep(df, 1, rowSums(df), "/"))
+
+ ## Eigenanalysis
+ pco1 <- dudi.pco(dis, row.w = w.esp, full = TRUE)
+ wrel <- data.frame(dfp %*% as.matrix(pco1$li))
+ row.names(wrel) <- rownames(df)
+ res <- as.dudi(wrel, rep(1, ncol(wrel)), w.samples, scannf = scannf, nf = nf, call = match.call(), type = "dpcoa", tol = tol, full = full)
+ ## lw was w2
+ ## li was l2
+ w <- as.matrix(pco1$li) %*% as.matrix(res$c1)
+ w <- data.frame(w)
+ row.names(w) <- names(df)
+ res$dls <- w ## was l1
+ res$dw <- w.esp ## was w1
+ res$co <- res$l1 <- NULL
+
+ ## Returns some infomation related to Rao Entropy
+ if(RaoDecomp){
+ res$RaoDiv <- apply(dfp, 1, function(x) sum(d * outer(x, x)))
+
+ fun1 <- function(x) {
+ w <- -sum(d * outer (x, x))
+ return(sqrt(w))
+ }
+ dnew <- matrix(0, nrel, nrel)
+ idx <- dfp[col(dnew)[col(dnew) < row(dnew)], ] - dfp[row(dnew)[col(dnew) < row(dnew)], ]
+ dnew <- apply(idx, 1, fun1)
+ attr(dnew, "Size") <- nrel
+ attr(dnew, "Labels") <- rownames(df)
+ attr(dnew, "Diag") <- TRUE
+ attr(dnew, "Upper") <- FALSE
+ attr(dnew, "method") <- "dis"
+ attr(dnew, "call") <- match.call()
+ class(dnew) <- "dist"
+ res$RaoDis <- dnew
+
+ Bdiv <- crossprod(w.samples, (as.matrix(dnew)^2)/2) %*% w.samples
+ Tdiv <- crossprod(w.esp, d) %*% (w.esp)
+ Wdiv <- Tdiv - Bdiv
+ divdec <- data.frame(c(Bdiv, Wdiv, Tdiv))
+ names(divdec) <- "Diversity"
+ rownames(divdec) <- c("Between-samples diversity", "Within-samples diversity", "Total diversity")
+ res$RaoDecodiv <- divdec
+ }
+
+ class(res) <- "dpcoa"
+ return(res)
+}
+
+
+
+plot.dpcoa <- function(x, xax = 1, yax = 2, ...) {
+ if (!inherits(x, "dpcoa"))
+ stop("Object of type 'dpcoa' expected")
+ nf <- x$nf
+ if (xax > nf)
+ stop("Non convenient xax")
+ if (yax > nf)
+ stop("Non convenient yax")
+ opar <- par(no.readonly = TRUE)
+ on.exit (par(opar))
+ par(mfrow = c(2,2))
+ s.corcircle(x$c1[, c(xax, yax)], cgrid = 0,
+ sub = "Principal axes", csub = 1.5, possub = "topleft", fullcircle = TRUE)
+ add.scatter.eig(x$eig, length(x$eig), xax, yax, posi = "bottomleft", ratio = 1/4)
+ X <- as.list(x$call)[[2]]
+ X <- eval.parent(X)
+ s.distri(x$dls[, c(xax, yax)], t(X), cellipse = 1, cstar = 0,
+ sub = "Categories & Collections", possub = "bottomleft", csub = 1.5)
+ s.label(x$dls[, c(xax, yax)], sub = "Categories", possub = "bottomleft", csub = 1.5)
+ if(!is.null(x$RaoDiv))
+ s.value(x$li[, c(xax, yax)], x$RaoDiv, sub = "Rao Divcs")
+ else
+ s.label(x$li[, c(xax, yax)], sub = "Collections", possub = "bottomleft", csub = 1.5)
+
+}
+
+summary.dpcoa <- function(object, ...){
+ summary.dudi(dpcoa, ...)
+}
+
+
+print.dpcoa <- function (x, ...)
+{
+ if (!inherits(x, "dpcoa"))
+ stop("to be used with 'dpcoa' object")
+ cat("Double principal coordinate analysis\n")
+ cat("call: ")
+ print(x$call)
+ cat("class: ")
+ cat(class(x), "\n")
+ cat("\n$nf (axis saved) :", x$nf)
+ cat("\n$rank: ", x$rank)
+ cat("\n\neigen values: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n\n")
+ else cat("\n\n")
+
+ nr <- ifelse(!is.null(x$RaoDecomp), 4, 3)
+ sumry <- array("", c(nr, 4), list(1:nr, c("vector", "length",
+ "mode", "content")))
+ sumry[1, ] <- c("$dw", length(x$dw), mode(x$dw), "category weights")
+ sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "collection weights")
+ sumry[3, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
+ if(nr == 4)
+ sumry[4, ] <- c("$RaoDiv", length(x$RaoDiv), mode(x$RaoDiv),
+ "diversity coefficients within collections")
+ print(sumry, quote = FALSE)
+ cat("\n")
+
+ if(!is.null(x$RaoDecomp)){
+ sumry <- array("", c(1, 3), list(1:1, c("dist", "Size", "content")))
+ sumry[1, ] <- c("$RaoDis", attributes(x$RaoDis)$Size, "distances among collections")
+ print(sumry, quote = FALSE)
+ cat("\n")
+ }
+
+ sumry <- array("", c(nr, 4), list(1:nr, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$dls", nrow(x$dls), ncol(x$dls), "coordinates of the categories")
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "coordinates of the collections")
+ sumry[3, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "scores of the principal axes of the categories")
+ if(nr == 4)
+ sumry[4, ] <- c("$RaoDecodiv", 3, 1, "decomposition of diversity")
+ print(sumry, quote = FALSE)
+}
diff --git a/R/dudi.R b/R/dudi.R
new file mode 100644
index 0000000..cfe2ab0
--- /dev/null
+++ b/R/dudi.R
@@ -0,0 +1,269 @@
+"as.dudi" <- function (df, col.w, row.w, scannf, nf, call, type, tol = 1e-07,
+ full = FALSE)
+{
+ if (!is.data.frame(df))
+ stop("data.frame expected")
+ lig <- nrow(df)
+ col <- ncol(df)
+ if (length(col.w) != col)
+ stop("Non convenient col weights")
+ if (length(row.w) != lig)
+ stop("Non convenient row weights")
+ if (any(col.w < 0))
+ stop("col weight < 0")
+ if (any(row.w < 0))
+ stop("row weight < 0")
+ if (full)
+ scannf <- FALSE
+ transpose <- FALSE
+ if(lig<col)
+ transpose <- TRUE
+ res <- list(tab = df, cw = col.w, lw = row.w)
+ df <- as.matrix(df)
+ df.ori <- df
+ df <- df * sqrt(row.w)
+ df <- sweep(df, 2, sqrt(col.w), "*")
+ if(!transpose){
+ df <- crossprod(df,df)
+ }
+ else{
+ df <- tcrossprod(df,df)
+ }
+ eig1 <- eigen(df,symmetric=TRUE)
+ eig <- eig1$values
+ rank <- sum((eig/eig[1]) > tol)
+ if (scannf) {
+ if (exists("ade4TkGUIFlag")) {
+ nf <- ade4TkGUI::chooseaxes(eig, rank)
+ }
+ else {
+ barplot(eig[1:rank])
+ cat("Select the number of axes: ")
+ nf <- as.integer(readLines(n = 1))
+ }
+ }
+ if (nf <= 0)
+ nf <- 2
+ if (nf > rank)
+ nf <- rank
+ if (full)
+ nf <- rank
+ res$eig <- eig[1:rank]
+ res$rank <- rank
+ res$nf <- nf
+ col.w[which(col.w == 0)] <- 1
+ row.w[which(row.w == 0)] <- 1
+ dval <- sqrt(res$eig)[1:nf]
+ if(!transpose){
+ col.w <- 1/sqrt(col.w)
+ auxi <- eig1$vectors[, 1:nf] * col.w
+ auxi2 <- sweep(df.ori, 2, res$cw, "*")
+ auxi2 <- data.frame(auxi2%*%auxi)
+ auxi <- data.frame(auxi)
+
+ names(auxi) <- paste("CS", (1:nf), sep = "")
+ row.names(auxi) <- make.unique(names(res$tab))
+ res$c1 <- auxi
+
+ names(auxi2) <- paste("Axis", (1:nf), sep = "")
+ row.names(auxi2) <- row.names(res$tab)
+ res$li <- auxi2
+
+ res$co <- sweep(res$c1,2,dval,"*")
+ names(res$co) <- paste("Comp", (1:nf), sep = "")
+
+ res$l1 <- sweep(res$li,2,dval,"/")
+ names(res$l1) <- paste("RS", (1:nf), sep = "")
+
+
+ } else {
+ row.w <- 1/sqrt(row.w)
+ auxi <- eig1$vectors[, 1:nf] * row.w
+ auxi2 <- t(sweep(df.ori,1,res$lw,"*"))
+ auxi2 <- data.frame(auxi2%*%auxi)
+ auxi <- data.frame(auxi)
+
+ names(auxi) <- paste("RS", (1:nf), sep = "")
+ row.names(auxi) <- row.names(res$tab)
+ res$l1 <- auxi
+
+ names(auxi2) <- paste("Comp", (1:nf), sep = "")
+ row.names(auxi2) <- make.unique(names(res$tab))
+ res$co <- auxi2
+
+ res$li <- sweep(res$l1,2,dval,"*")
+ names(res$li) <- paste("Axis", (1:nf), sep = "")
+
+ res$c1 <- sweep(res$co,2,dval,"/")
+ names(res$c1) <- paste("CS", (1:nf), sep = "")
+
+ }
+
+ res$call <- call
+ class(res) <- c(type, "dudi")
+ return(res)
+}
+
+
+"is.dudi" <- function (x) {
+ inherits(x, "dudi")
+}
+
+"print.dudi" <- function (x, ...) {
+ cat("Duality diagramm\n")
+ cat("class: ")
+ cat(class(x))
+ cat("\n$call: ")
+ print(x$call)
+ cat("\n$nf:", x$nf, "axis-components saved")
+ cat("\n$rank: ")
+ cat(x$rank)
+ cat("\neigen values: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n")
+ else cat("\n")
+ sumry <- array("", c(3, 4), list(1:3, c("vector", "length",
+ "mode", "content")))
+ sumry[1, ] <- c("$cw", length(x$cw), mode(x$cw), "column weights")
+ sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weights")
+ sumry[3, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(5, 4), list(1:5, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "modified array")
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates")
+ sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "row normed scores")
+ sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates")
+ sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores")
+
+ print(sumry, quote = FALSE)
+ cat("other elements: ")
+ if (length(names(x)) > 11)
+ cat(names(x)[12:(length(x))], "\n")
+ else cat("NULL\n")
+}
+
+"t.dudi" <- function (x) {
+ if (!inherits(x, "dudi"))
+ stop("Object of class 'dudi' expected")
+ res <- list()
+ res$tab <- data.frame(t(x$tab))
+ res$cw <- x$lw
+ res$lw <- x$cw
+ res$eig <- x$eig
+ res$rank <- x$rank
+ res$nf <- x$nf
+ res$c1 <- x$l1
+ res$l1 <- x$c1
+ res$co <- x$li
+ res$li <- x$co
+ res$call <- match.call()
+ class(res) <- c("transpo", "dudi")
+ return(res)
+}
+
+"redo.dudi" <- function (dudi, newnf = 2) {
+ if (!inherits(dudi, "dudi"))
+ stop("Object of class 'dudi' expected")
+ appel <- as.list(dudi$call)
+ if (appel[[1]] == "t.dudi") {
+ dudiold <- eval.parent(appel[[2]])
+ appel <- as.list(dudiold$call)
+ appel$nf <- newnf
+ appel$scannf <- FALSE
+ dudinew <- eval.parent(as.call(appel))
+ return(t.dudi(dudinew))
+ }
+ appel$nf <- newnf
+ appel$scannf <- FALSE
+ eval.parent(as.call(appel))
+}
+
+
+
+screeplot.dudi <- function (x, npcs = length(x$eig), type = c("barplot","lines"), main = deparse(substitute(x)), col = c(rep("black",x$nf),rep("grey",npcs-x$nf)), ...){
+ type <- match.arg(type)
+ pcs <- x$eig
+ xp <- seq_len(npcs)
+ if (type == "barplot")
+ barplot(pcs[xp], names.arg = 1:npcs, main = main, ylab = "Inertia", xlab = "Axis", col = col, ...)
+ else {
+ plot(xp, pcs[xp], type = "b", axes = FALSE, main = main, xlab = "Axis", ylab = "Inertia", col = col, ...)
+ axis(2)
+ axis(1, at = xp, labels = 1:npcs)
+ }
+ invisible()
+
+}
+
+biplot.dudi <- function (x, ...){
+ scatter(x, ...)
+
+}
+
+summary.dudi <- function(object, ...){
+ cat("Class: ")
+ cat(class(object))
+ cat("\nCall: ")
+ print(object$call)
+ cat("\nTotal inertia: ")
+ cat(signif(sum(object$eig), 4))
+ cat("\n")
+ l0 <- length(object$eig)
+
+ cat("\nEigenvalues:\n")
+ vec <- object$eig[1:(min(5, l0))]
+ names(vec) <- paste("Ax",1:length(vec), sep = "")
+ print(format(vec, digits = 4, trim = TRUE, width = 7), quote = FALSE)
+
+ cat("\nProjected inertia (%):\n")
+ vec <- (object$eig / sum(object$eig) * 100)[1:(min(5, l0))]
+ names(vec) <- paste("Ax",1:length(vec), sep = "")
+ print(format(vec, digits = 4, trim = TRUE, width = 7), quote = FALSE)
+
+ cat("\nCumulative projected inertia (%):\n")
+ vec <- (cumsum(object$eig) / sum(object$eig) * 100)[1:(min(5, l0))]
+ names(vec)[1] <- "Ax1"
+
+ if(l0>1)
+ names(vec)[2:length(vec)] <- paste("Ax1:",2:length(vec),sep="")
+ print(format(vec, digits = 4, trim = TRUE, width = 7), quote = FALSE)
+
+
+ if (l0 > 5) {
+ cat("\n")
+ cat(paste("(Only 5 dimensions (out of ",l0, ") are shown)\n", sep="",collapse=""))
+ }
+ cat("\n")
+}
+
+
+########### [.dudi ###########
+
+"[.dudi" <- function (x, i, j) {
+
+ ## i: index of rows
+ ## j: index of columns
+ res <- unclass(x)
+ if(!missing(i)){
+ res$tab <- res$tab[i, , drop = FALSE]
+ res$li <- res$li[i, , drop = FALSE]
+ res$l1 <- res$l1[i, , drop = FALSE]
+ res$lw <- res$lw[i, drop = FALSE]
+ res$lw <- res$lw / sum(res$lw)
+
+ }
+ if(!missing(j)){
+ res$tab <- res$tab[, j, drop = FALSE]
+ res$co <- res$co[j, , drop = FALSE]
+ res$c1 <- res$c1[j, , drop = FALSE]
+ res$cw <- res$lw[j, drop = FALSE]
+ }
+ class(res) <- class(x)
+ res$call <- match.call()
+ return(res)
+}
diff --git a/R/dudi.acm.R b/R/dudi.acm.R
new file mode 100644
index 0000000..2884fdc
--- /dev/null
+++ b/R/dudi.acm.R
@@ -0,0 +1,116 @@
+"dudi.acm" <- function (df, row.w = rep(1, nrow(df)), scannf = TRUE, nf = 2) {
+ if (!all(unlist(lapply(df, is.factor))))
+ stop("All variables must be factors")
+ df <- as.data.frame(df)
+ X <- acm.disjonctif(df)
+ lig <- nrow(X)
+ col <- ncol(X)
+ var <- ncol(df)
+ if (length(row.w) != lig)
+ stop("Non convenient row weights")
+ if (any(row.w < 0))
+ stop("row weight < 0")
+ row.w <- row.w/sum(row.w)
+ col.w <- apply(X, 2, function(x) sum(x*row.w))
+ if (any(col.w == 0))
+ stop("One category with null weight")
+ X <- t(t(X)/col.w) - 1
+ col.w <- col.w/var
+ X <- as.dudi(data.frame(X), col.w, row.w, scannf = scannf,
+ nf = nf, call = match.call(), type = "acm")
+ rcor <- matrix(0, ncol(df), X$nf)
+ rcor <- row(rcor) + 0 + (0+1i) * col(rcor)
+ floc <- function(x) {
+ i <- Re(x)
+ j <- Im(x)
+ x <- X$l1[, j] * X$lw
+ qual <- df[, i]
+ poicla <- unlist(tapply(X$lw, qual, sum))
+ z <- unlist(tapply(x, qual, sum))/poicla
+ return(sum(poicla * z * z))
+ }
+ rcor <- apply(rcor, c(1, 2), floc)
+ rcor <- data.frame(rcor)
+ row.names(rcor) <- names(df)
+ names(rcor) <- names(X$l1)
+ X$cr <- rcor
+ return(X)
+}
+
+"boxplot.acm" <- function (x, xax = 1, ...) {
+ # correction d'un bug par P. Cornillon 29/10/2004
+ if (!inherits(x, "acm"))
+ stop("Object of class 'acm' expected")
+ if ((xax < 1) || (xax > x$nf))
+ stop("non convenient axe number")
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ oritab <- eval.parent(as.list(x$call)[[2]])
+ nvar <- ncol(oritab)
+ if (nvar <= 7)
+ sco.boxplot(x$l1[, xax], oritab[, 1:nvar], clabel = 1)
+ else if (nvar <= 14) {
+ par(mfrow = c(1, 2))
+ sco.boxplot(x$l1[, xax], oritab[, 1:(nvar%/%2)], clabel = 1.3)
+ sco.boxplot(x$l1[, xax], oritab[, (nvar%/%2 + 1):nvar],
+ clabel = 1.3)
+ }
+ else {
+ par(mfrow = c(1, 3))
+ if ((a0 <- nvar%/%3) < nvar/3)
+ a0 <- a0 + 1
+ sco.boxplot(x$l1[, xax], oritab[, 1:a0], clabel = 1.6)
+ sco.boxplot(x$l1[, xax], oritab[, (a0 + 1):(2 * a0)],
+ clabel = 1.6)
+ sco.boxplot(x$l1[, xax], oritab[, (2 * a0 + 1):nvar],
+ clabel = 1.6)
+ }
+}
+
+"acm.burt" <- function (df1, df2, counts = rep(1, nrow(df1))) {
+ if (!all(unlist(lapply(df1, is.factor))))
+ stop("All variables must be factors")
+ if (!all(unlist(lapply(df2, is.factor))))
+ stop("All variables must be factors")
+ if (nrow(df1) != nrow(df2))
+ stop("non convenient row numbers")
+ if (length(counts) != nrow(df2))
+ stop("non convenient row numbers")
+ g1 <- acm.disjonctif(df1)
+ g1 <- g1 * counts
+ g2 <- acm.disjonctif(df2)
+ burt <- as.matrix(t(g1)) %*% as.matrix(g2)
+ burt <- data.frame(burt)
+ names(burt) <- names(g2)
+ row.names(burt) <- names(g1)
+ return(burt)
+}
+
+"acm.disjonctif" <- function (df) {
+ acm.util.df <- function(i) {
+ cl <- df[,i]
+ cha <- names(df)[i]
+ n <- length(cl)
+ cl <- as.factor(cl)
+ x <- matrix(0, n, length(levels(cl)))
+ x[(1:n) + n * (unclass(cl) - 1)] <- 1
+ dimnames(x) <- list(row.names(df), paste(cha,levels(cl),sep="."))
+ return(x)
+ }
+ G <- lapply(1:ncol(df), acm.util.df)
+ G <- data.frame (G, check.names = FALSE)
+ return(G)
+}
+
+
+fac2disj<- function(fac, drop = FALSE) {
+ ## Returns the disjunctive table corrseponding to a factor
+ n <- length(fac)
+ fac <- as.factor(fac)
+ if(drop)
+ fac <- factor(fac)
+ x <- matrix(0, n, nlevels(fac))
+ x[(1:n) + n * (unclass(fac) - 1)] <- 1
+ dimnames(x) <- list(names(fac), as.character(levels(fac)))
+ return(data.frame(x, check.names = FALSE))
+}
diff --git a/R/dudi.coa.R b/R/dudi.coa.R
new file mode 100644
index 0000000..0598081
--- /dev/null
+++ b/R/dudi.coa.R
@@ -0,0 +1,27 @@
+"dudi.coa" <- function (df, scannf = TRUE, nf = 2) {
+ df <- as.data.frame(df)
+ if (!is.data.frame(df))
+ stop("data.frame expected")
+ if (any(df < 0))
+ stop("negative entries in table")
+ if ((N <- sum(df)) == 0)
+ stop("all frequencies are zero")
+ df <- df/N
+ row.w <- apply(df, 1, sum)
+ col.w <- apply(df, 2, sum)
+ df <- df/row.w
+ df <- sweep(df, 2, col.w, "/") - 1
+ if (any(is.na(df))) {
+ fun1 <- function(x) {
+ if (is.na(x))
+ return(0)
+ else return(x)
+ }
+ df <- apply(df, c(1, 2), fun1)
+ df <- data.frame(df)
+ }
+ X <- as.dudi(df, col.w, row.w, scannf = scannf, nf = nf,
+ call = match.call(), type = "coa")
+ X$N <- N
+ return(X)
+}
diff --git a/R/dudi.dec.R b/R/dudi.dec.R
new file mode 100644
index 0000000..6eba67d
--- /dev/null
+++ b/R/dudi.dec.R
@@ -0,0 +1,33 @@
+"dudi.dec" <- function (df, eff, scannf = TRUE, nf = 2) {
+ df <- as.data.frame(df)
+ if (!is.data.frame(df))
+ stop("data.frame expected")
+ lig <- nrow(df)
+ if (any(df < 0))
+ stop("negative entries in table")
+ if ((sum(df)) == 0)
+ stop("all frequencies are zero")
+ if (length(eff) != lig)
+ stop("non convenient dimension")
+ if (any(eff) <= 0)
+ stop("non convenient vector eff")
+ rtot <- sum(eff)
+ row.w <- eff/rtot
+ col.w <- apply(df, 2, sum)
+ col.w <- col.w/rtot
+ df <- sweep(df, 1, eff, "/")
+ df <- sweep(df, 2, col.w, "/") - 1
+ if (any(is.na(df))) {
+ fun1 <- function(x) {
+ if (is.na(x))
+ return(0)
+ else return(x)
+ }
+ df <- apply(df, c(1, 2), fun1)
+ df <- data.frame(df)
+ }
+ X <- as.dudi(df, col.w, row.w, scannf = scannf, nf = nf,
+ call = match.call(), type = "dec")
+ X$R <- rtot
+ return(X)
+}
diff --git a/R/dudi.fca.R b/R/dudi.fca.R
new file mode 100644
index 0000000..a5e2b86
--- /dev/null
+++ b/R/dudi.fca.R
@@ -0,0 +1,133 @@
+"dudi.fca" <- function (df, scannf = TRUE, nf = 2) {
+ df <- as.data.frame(df)
+ if (!is.data.frame(df))
+ stop("data.frame expected")
+ if (is.null(attr(df, "col.blocks")))
+ stop("attribute 'col.blocks' expected for df")
+ if (is.null(attr(df, "row.w")))
+ stop("attribute 'row.w' expected for df")
+ bloc <- attr(df, "col.blocks")
+ row.w <- attr(df, "row.w")
+ indica <- attr(df, "col.num")
+ nvar <- length(bloc)
+ col.w <- apply(df * row.w, 2, sum)
+ df <- sweep(df, 2, col.w, "/") - 1
+ col.w <- col.w/length(bloc)
+ X <- as.dudi(df, col.w, row.w, scannf = scannf, nf = nf,
+ call = match.call(), type = "fca")
+ rcor <- matrix(0, nvar, X$nf)
+ rcor <- row(rcor) + 0 + (0+1i) * col(rcor)
+ floc <- function(x) {
+ i <- Re(x)
+ j <- Im(x)
+ if (i == 1)
+ k1 <- 0
+ else k1 <- cumsum(bloc)[i - 1]
+ k2 <- k1 + bloc[i]
+ k1 <- k1 + 1
+ z <- X$co[k1:k2, j]
+ poicla <- X$cw[k1:k2] * nvar
+ return(sum(poicla * z * z))
+ }
+ rcor <- apply(rcor, c(1, 2), floc)
+ rcor <- data.frame(rcor)
+ row.names(rcor) <- names(bloc)
+ names(rcor) <- names(X$l1)
+ X$cr <- rcor
+ X$blo <- bloc
+ X$indica <- indica
+ return(X)
+}
+
+"prep.fuzzy.var" <- function (df, col.blocks, row.w = rep(1, nrow(df))) {
+ if (!is.data.frame(df))
+ stop("data.frame expected")
+ if (!is.null(row.w)) {
+ if (length(row.w) != nrow(df))
+ stop("non convenient dimension")
+ }
+ if (sum(col.blocks) != ncol(df)) {
+ stop("non convenient data in col.blocks")
+ }
+ if (is.null(row.w))
+ row.w <- rep(1, nrow(df))/nrow(df)
+ row.w <- row.w/sum(row.w)
+ if (is.null(names(col.blocks))) {
+ names(col.blocks) <- paste("FV", as.character(1:length(col.blocks)),
+ sep = "")
+ }
+ f1 <- function(x) {
+ a <- sum(x)
+ if (is.na(a))
+ return(rep(0, length(x)))
+ if (a == 0)
+ return(rep(0, length(x)))
+ return(x/a)
+ }
+ k2 <- 0
+ col.w <- rep(1, ncol(df))
+ for (k in 1:(length(col.blocks))) {
+ k1 <- k2 + 1
+ k2 <- k2 + col.blocks[k]
+ X <- df[, k1:k2]
+ X <- t(apply(X, 1, f1))
+ X.marge <- apply(X, 1, sum)
+ X.marge <- X.marge * row.w
+ X.marge <- X.marge/sum(X.marge)
+ X.mean <- apply(X * X.marge, 2, sum)
+ nr <- sum(X.marge == 0)
+ if (nr > 0) {
+ nc <- col.blocks[k]
+ X[X.marge == 0, ] <- rep(X.mean, rep(nr, nc))
+ cat(nr, "missing data found in block", k, "\n")
+ }
+ df[, k1:k2] <- X
+ col.w[k1:k2] <- X.mean
+ }
+ attr(df, "col.blocks") <- col.blocks
+ attr(df, "row.w") <- row.w
+ attr(df, "col.freq") <- col.w
+ col.num <- factor(rep((1:length(col.blocks)), col.blocks))
+ attr(df, "col.num") <- col.num
+ return(df)
+}
+
+"dudi.fpca" <- function (df, scannf = TRUE, nf = 2) {
+ if (!is.data.frame(df))
+ stop("data.frame expected")
+ if (is.null(attr(df, "col.blocks")))
+ stop("attribute 'col.blocks' expected for df")
+ if (is.null(attr(df, "row.w")))
+ stop("attribute 'row.w' expected for df")
+ bloc <- attr(df, "col.blocks")
+ row.w <- attr(df, "row.w")
+ indica <- attr(df, "col.num")
+ nvar <- length(bloc)
+ col.w <- unlist(lapply(bloc, function(k) rep(1/k,k)))
+ X <- dudi.pca (df, row.w = row.w, col.w = col.w, center = TRUE,
+ scale = FALSE, scannf = scannf, nf = nf)
+ X$call <- match.call()
+ X$blo <- bloc
+ X$indica <- indica
+ w1 <- unlist(lapply(X$tab,function(x) sum(x*x*row.w)))
+ w1 <- unlist(tapply(w1*col.w,indica,sum))
+ w2 <- tapply(X$cent,indica,function(x) 1-sum(x*x))
+ ratio <- w1/sum(w1)
+ w1 <- cbind.data.frame(inertia=w1,max=w2,FST=w1/w2)
+ row.names(w1) <- names(bloc)
+ X$FST <- w1
+ row.names(w1) <- names(bloc)
+ floc1 <- function(ifac)
+ tapply(col.w*X$co[,ifac]*X$co[,ifac],indica,sum)
+ w2 <- unlist(lapply(1:X$nf,floc1))
+ w2 <- matrix(w2,nvar,X$nf)
+ w3 <- X$eig[1:X$nf]
+ w2 <- t(apply(w2,1,function(x) x/w3))
+ w2 <- as.data.frame(w2)
+ names(w2)=paste("Ax",1:X$nf,sep="")
+ row.names(w2) <- names(bloc)
+ w2 <- cbind.data.frame(w2,total=ratio)
+ w2 <- round(1000*w2,0)
+ X$inertia <- w2
+ return(X)
+}
diff --git a/R/dudi.hillsmith.R b/R/dudi.hillsmith.R
new file mode 100644
index 0000000..237228a
--- /dev/null
+++ b/R/dudi.hillsmith.R
@@ -0,0 +1,100 @@
+"dudi.hillsmith" <- function (df, row.w=rep(1, nrow(df))/nrow(df), scannf = TRUE, nf = 2)
+{
+ df <- as.data.frame(df)
+ if (!is.data.frame(df))
+ stop("data.frame expected")
+
+ df <- data.frame(df)
+ nc <- ncol(df)
+ nl <- nrow(df)
+ row.w <- row.w/sum(row.w)
+ if (any(is.na(df)))
+ stop("na entries in table")
+ index <- rep("", nc)
+ for (j in 1:nc) {
+ w1 <- "q"
+ if (is.factor(df[, j]))
+ w1 <- "f"
+ if (is.ordered(df[, j]))
+ stop("use dudi.mix for ordered data")
+ index[j] <- w1
+ }
+ res <- matrix(0, nl, 1)
+ provinames <- "0"
+ col.w <- NULL
+ col.assign <- NULL
+ k <- 0
+ center <- vector(mode = "numeric", length = 0)
+ norm <- vector(mode = "numeric", length = 0)
+ for (j in 1:nc) {
+ if (index[j] == "q") {
+ var.tmp <- scalewt(df[, j], wt = row.w)
+ center <- c(center, attr(var.tmp, "scaled:center"))
+ norm <- c(norm, attr(var.tmp, "scaled:scale"))
+ res <- cbind(res, var.tmp)
+ provinames <- c(provinames, names(df)[j])
+ col.w <- c(col.w, 1)
+ k <- k + 1
+ col.assign <- c(col.assign, k)
+
+ }
+ else if (index[j] == "f") {
+ w <- fac2disj(df[, j], drop = TRUE)
+ center <- c(center, NA)
+ norm <- c(norm, NA)
+ cha <- paste(substr(names(df)[j], 1, 5), ".", names(w),
+ sep = "")
+ col.w.provi <- drop(row.w %*% as.matrix(w))
+ w <- t(t(w)/col.w.provi) - 1
+ col.w <- c(col.w, col.w.provi)
+ res <- cbind(res, w)
+ provinames <- c(provinames, cha)
+ k <- k + 1
+ col.assign <- c(col.assign, rep(k, length(cha)))
+ }
+ }
+ res <- data.frame(res)
+ names(res) <- make.names(provinames, unique = TRUE)
+ row.names(res) <- row.names(df)
+ res <- res[, -1]
+ names(col.w) <- provinames[-1]
+ X <- as.dudi(res, col.w, row.w, scannf = scannf, nf = nf,
+ call = match.call(), type = "mix")
+ X$assign <- factor(col.assign)
+ X$index <- factor(index)
+ rcor <- matrix(0, nc, X$nf)
+ rcor <- row(rcor) + 0 + (0 + (0+1i)) * col(rcor)
+ floc <- function(x) {
+ i <- Re(x)
+ j <- Im(x)
+ if (index[i] == "q") {
+ if (sum(col.assign == i)) {
+ w <- X$l1[, j] * X$lw * X$tab[, col.assign ==
+ i]
+ return(sum(w)^2)
+ }
+ else {
+ w <- X$lw * X$l1[, j]
+ w <- X$tab[, col.assign == i] * w
+ w <- apply(w, 2, sum)
+ return(sum(w^2))
+ }
+ }
+ else if (index[i] == "f") {
+ x <- X$l1[, j] * X$lw
+ qual <- df[, i]
+ poicla <- unlist(tapply(X$lw, qual, sum))
+ z <- unlist(tapply(x, qual, sum))/poicla
+ return(sum(poicla * z * z))
+ }
+ else return(NA)
+ }
+ rcor <- apply(rcor, c(1, 2), floc)
+ rcor <- data.frame(rcor)
+ row.names(rcor) <- names(df)
+ names(rcor) <- names(X$l1)
+ X$cr <- rcor
+ X$center <- center
+ X$norm <- norm
+ return(X)
+}
diff --git a/R/dudi.mix.R b/R/dudi.mix.R
new file mode 100644
index 0000000..f632b69
--- /dev/null
+++ b/R/dudi.mix.R
@@ -0,0 +1,126 @@
+"dudi.mix" <- function (df, add.square = FALSE, scannf = TRUE, nf = 2) {
+ df <- as.data.frame(df)
+ if (!is.data.frame(df))
+ stop("data.frame expected")
+ row.w <- rep(1, nrow(df))/nrow(df)
+
+ f1 <- function(v) {
+ moy <- sum(v)/length(v)
+ v <- v - moy
+ et <- sqrt(sum(v * v)/length(v))
+ return(v/et)
+ }
+ df <- data.frame(df)
+ nc <- ncol(df)
+ nl <- nrow(df)
+ if (any(is.na(df)))
+ stop("na entries in table")
+ index <- rep("", nc)
+ for (j in 1:nc) {
+ w1 <- "q"
+ if (is.factor(df[, j]))
+ w1 <- "f"
+ if (is.ordered(df[, j]))
+ w1 <- "o"
+ index[j] <- w1
+ }
+ res <- matrix(0, nl, 1)
+ provinames <- "0"
+ col.w <- NULL
+ col.assign <- NULL
+ k <- 0
+ for (j in 1:nc) {
+ if (index[j] == "q") {
+ if (!add.square) {
+ res <- cbind(res, f1(df[, j]))
+ provinames <- c(provinames, names(df)[j])
+ col.w <- c(col.w, 1)
+ k <- k + 1
+ col.assign <- c(col.assign, k)
+ }
+ else {
+ w <- df[, j]
+ deg.poly <- 2
+ w <- sqrt(nl - 1) * poly(w, deg.poly)
+ cha <- paste(names(df)[j], c(".L", ".Q"), sep = "")
+ res <- cbind(res, as.matrix(w))
+ provinames <- c(provinames, cha)
+ col.w <- c(col.w, rep(1, deg.poly))
+ k <- k + 1
+ col.assign <- c(col.assign, rep(k, deg.poly))
+ }
+ }
+ else if (index[j] == "o") {
+ w <- as.numeric(df[, j])
+ deg.poly <- min(nlevels(df[, j]) - 1, 2)
+ w <- sqrt(nl - 1) * poly(w, deg.poly)
+ if (deg.poly == 1)
+ cha <- names(df)[j]
+ else cha <- paste(names(df)[j], c(".L", ".Q"), sep = "")
+ res <- cbind(res, as.matrix(w))
+ provinames <- c(provinames, cha)
+ col.w <- c(col.w, rep(1, deg.poly))
+ k <- k + 1
+ col.assign <- c(col.assign, rep(k, deg.poly))
+ }
+ else if (index[j] == "f") {
+ w <- fac2disj(df[, j], drop = TRUE)
+ cha <- paste(substr(names(df)[j], 1, 5), ".", names(w),
+ sep = "")
+ col.w.provi <- apply(w, 2, function(x) sum(x*row.w))
+ w <- t(t(w)/col.w.provi) - 1
+ col.w <- c(col.w, col.w.provi)
+ res <- cbind(res, w)
+ provinames <- c(provinames, cha)
+ k <- k + 1
+ col.assign <- c(col.assign, rep(k, length(cha)))
+ }
+ }
+ res <- data.frame(res)
+ names(res) <- make.names(provinames, unique = TRUE)
+ res <- res[, -1]
+ names(col.w) <- provinames[-1]
+ X <- as.dudi(res, col.w, row.w, scannf = scannf, nf = nf,
+ call = match.call(), type = "mix")
+ X$assign <- factor(col.assign)
+ X$index <- factor(index)
+ rcor <- matrix(0, nc, X$nf)
+ rcor <- row(rcor) + 0 + (0+1i) * col(rcor)
+ floc <- function(x) {
+ i <- Re(x)
+ j <- Im(x)
+ if (index[i] == "q") {
+ if (sum(col.assign == i)) {
+ w <- X$l1[, j] * X$lw * X$tab[, col.assign ==
+ i]
+ return(sum(w)^2)
+ }
+ else {
+ w <- X$lw * X$l1[, j]
+ w <- X$tab[, col.assign == i] * w
+ w <- apply(w, 2, sum)
+ return(sum(w^2))
+ }
+ }
+ else if (index[i] == "o") {
+ w <- X$lw * X$l1[, j]
+ w <- X$tab[, col.assign == i] * w
+ w <- apply(w, 2, sum)
+ return(sum(w^2))
+ }
+ else if (index[i] == "f") {
+ x <- X$l1[, j] * X$lw
+ qual <- df[, i]
+ poicla <- unlist(tapply(X$lw, qual, sum))
+ z <- unlist(tapply(x, qual, sum))/poicla
+ return(sum(poicla * z * z))
+ }
+ else return(NA)
+ }
+ rcor <- apply(rcor, c(1, 2), floc)
+ rcor <- data.frame(rcor)
+ row.names(rcor) <- names(df)
+ names(rcor) <- names(X$l1)
+ X$cr <- rcor
+ X
+}
diff --git a/R/dudi.nsc.R b/R/dudi.nsc.R
new file mode 100644
index 0000000..e74783d
--- /dev/null
+++ b/R/dudi.nsc.R
@@ -0,0 +1,19 @@
+"dudi.nsc" <- function (df, scannf = TRUE, nf = 2) {
+ df <- as.data.frame(df)
+ col <- ncol(df)
+ if (any(df < 0))
+ stop("negative entries in table")
+ if ((N <- sum(df)) == 0)
+ stop("all frequencies are zero")
+ row.w <- apply(df, 1, sum)/N
+ col.w <- apply(df, 2, sum)/N
+ df <- t(apply(df, 1, function(x) if (sum(x) == 0)
+ col.w
+ else x/sum(x)))
+ df <- sweep(df, 2, col.w)
+ df <- data.frame(col * df)
+ X <- as.dudi(df, rep(1, col)/col, row.w, scannf = scannf,
+ nf = nf, call = match.call(), type = "nsc")
+ X$N <- N
+ return(X)
+}
diff --git a/R/dudi.pca.R b/R/dudi.pca.R
new file mode 100644
index 0000000..02fd247
--- /dev/null
+++ b/R/dudi.pca.R
@@ -0,0 +1,32 @@
+"dudi.pca" <- function (df, row.w = rep(1, nrow(df))/nrow(df), col.w = rep(1,
+ ncol(df)), center = TRUE, scale = TRUE, scannf = TRUE, nf = 2)
+{
+ df <- as.data.frame(df)
+ nc <- ncol(df)
+ if (any(is.na(df)))
+ stop("na entries in table")
+ f1 <- function(v) sum(v * row.w)/sum(row.w)
+ f2 <- function(v) sqrt(sum(v * v * row.w)/sum(row.w))
+ if (is.logical(center)) {
+ if (center) {
+ center <- apply(df, 2, f1)
+ df <- sweep(df, 2, center)
+ }
+ else center <- rep(0, nc)
+ }
+ else if (is.numeric(center) && (length(center) == nc))
+ df <- sweep(df, 2, center)
+ else stop("Non convenient selection for center")
+ if (scale) {
+ norm <- apply(df, 2, f2)
+ norm[norm < 1e-08] <- 1
+ df <- sweep(df, 2, norm, "/")
+ }
+ else norm <- rep(1, nc)
+ X <- as.dudi(df, col.w, row.w, scannf = scannf, nf = nf,
+ call = match.call(), type = "pca")
+ X$cent <- center
+ X$norm <- norm
+ X
+}
+
diff --git a/R/dudi.pco.R b/R/dudi.pco.R
new file mode 100644
index 0000000..e5186f8
--- /dev/null
+++ b/R/dudi.pco.R
@@ -0,0 +1,112 @@
+"dudi.pco" <- function (d, row.w = "uniform", scannf = TRUE, nf = 2, full = FALSE,
+ tol = 1e-07)
+{
+ if (!inherits(d, "dist"))
+ stop("Distance matrix expected")
+ if (full)
+ scannf <- FALSE
+ distmat <- as.matrix(d)
+ n <- ncol(distmat)
+ rownames <- attr(d, "Labels")
+ if (any(is.na(d)))
+ stop("missing value in d")
+ if (is.null(rownames))
+ rownames <- as.character(1:n)
+ if (any(row.w == "uniform")) {
+ row.w <- rep(1, n)
+ }
+ else {
+ if (length(row.w) != n)
+ stop("Non convenient length(row.w)")
+ if (any(row.w < 0))
+ stop("Non convenient row.w (p<0)")
+ if (any(row.w == 0))
+ stop("Non convenient row.w (p=0)")
+ }
+ row.w <- row.w/sum(row.w)
+ delta <- -0.5 * bicenter.wt(distmat * distmat, row.wt = row.w,
+ col.wt = row.w)
+ wsqrt <- sqrt(row.w)
+ delta <- delta * wsqrt
+ delta <- t(t(delta) * wsqrt)
+ eig <- eigen(delta, symmetric = TRUE)
+ lambda <- eig$values
+ w0 <- lambda[n]/lambda[1]
+ if (w0 < -tol)
+ warning("Non euclidean distance")
+ r <- sum(lambda > (lambda[1] * tol))
+ if (scannf) {
+ if (exists("ade4TkGUIFlag")) {
+ nf <- ade4TkGUI::chooseaxes(lambda, length(lambda))
+ } else {
+ barplot(lambda)
+ cat("Select the number of axes: ")
+ nf <- as.integer(readLines(n = 1))
+ }
+ }
+ if (nf <= 0)
+ nf <- 2
+ if (nf > r)
+ nf <- r
+ if (full)
+ nf <- r
+ res <- list()
+ res$eig <- lambda[1:r]
+# valeurs propres variances des coordonnees
+ res$rank <- r
+# rang de la representation euclidienne
+ res$nf <- nf
+# nombre de facteurs conserves
+ res$cw <- rep(1, r)
+# poids des colonnes unitaires
+ w <- t(t(eig$vectors[, 1:r]) * sqrt(lambda[1:r]))/wsqrt
+ w <- data.frame(w)
+ names(w) <- paste("A", 1:r, sep = "")
+ row.names(w) <- rownames
+ res$tab <- w
+# res$tab contient la representation euclidienne globale
+# tous les scores de variance lambda superieure a tol*(la plus grande)
+ res$li <- data.frame(w[, 1:nf])
+ names(res$li) <- names(res$tab)[1:nf]
+# res$li contient la representation euclidienne
+# les nf premiers scores conserves
+# cas particulier d'un tableau de coordonnees dont on fait l'ACP
+ w <- eig$vectors[, 1:nf]/wsqrt
+ w <- data.frame(w)
+ names(w) <- paste("RS", 1:nf, sep = "")
+ row.names(w) <- rownames
+ res$l1 <- w
+# res$l1 contient les scores normes
+# pour la ponderation des individus
+# Cette pco admet une ponderation de centrage arbitraire
+# plus generale que cmdscale
+ w <- data.frame(diag(1, r))
+ row.names(w) <- names(res$tab)
+ res$c1 <- data.frame(w[, 1:nf])
+ names(res$c1) <- paste("CS", (1:nf), sep = "")
+# res$c1 contient le debut de la base canonique
+# cas particulier d'un tableau de coordonnees dont on fait l'ACP
+ w <- data.frame(matrix(0, r, nf))
+ w[1:nf, 1:nf] <- diag(sqrt(lambda[1:nf]),nrow=nf)
+ names(w) <- paste("Comp", (1:nf), sep = "")
+ row.names(w) <- names(res$tab)
+ res$co <- w
+# res$co indique que la variable est le composante * la norme
+ res$lw <- row.w
+# re$lw est le poids des lignes introduits si non uniforme
+ res$call <- match.call()
+ class(res) <- c("pco", "dudi")
+ return(res)
+}
+
+"scatter.pco" <- function (x, xax = 1, yax = 2, clab.row = 1, posieig = "top",
+ sub = NULL, csub = 2, ...)
+{
+ if (!inherits(x, "pco"))
+ stop("Object of class 'pco' expected")
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ coolig <- x$li[, c(xax, yax)]
+ s.label(coolig, clabel = clab.row, sub=sub, csub=csub)
+ add.scatter.eig(x$eig, x$nf, xax, yax, posi = posieig, ratio = 1/4)
+}
diff --git a/R/foucart.R b/R/foucart.R
new file mode 100644
index 0000000..38691ef
--- /dev/null
+++ b/R/foucart.R
@@ -0,0 +1,179 @@
+"foucart" <- function (X, scannf = TRUE, nf = 2) {
+ if (!is.list(X))
+ stop("X is not a list")
+ nblo <- length(X)
+ if (!all(unlist(lapply(X, is.data.frame))))
+ stop("a component of X is not a data.frame")
+ # vérification que chaque tableau de la liste a les
+ # mêmes dimensions
+ blocks <- unlist(lapply(X, ncol))
+ if (length(unique(blocks)) != 1)
+ stop("non equal col numbers among array")
+ blocks <- unlist(lapply(X, nrow))
+ if (length(unique(blocks)) != 1)
+ stop("non equal row numbers among array")
+ r.n <- row.names(X[[1]])
+ for (i in 1:nblo) {
+ r.new <- row.names(X[[i]])
+ if (any(r.new != r.n))
+ stop("non equal row.names among array")
+ }
+ # vérification que chaque tableau de la liste a les
+ # mêmes noms
+ unique.col.names <- names(X[[1]])
+ for (i in 1:nblo) {
+ c.new <- names(X[[i]])
+ if (any(c.new != unique.col.names))
+ stop
+ ("non equal col.names among array")
+ }
+ # vérification que chaque tableau de la liste supporte
+ # une analyse des correspondances
+ for (i in 1:nblo) {
+ if (any(X[[i]] < 0))
+ stop(paste("negative entries in data.frame", i))
+ if (sum(X[[i]]) <= 0)
+ stop(paste("Non convenient sum in data.frame", i))
+ }
+ X <- ktab.list.df(X)
+ auxinames <- ktab.util.names(X)
+ blocks <- X$blo
+ nblo <- length(blocks)
+ tnames <- tab.names(X)
+ tabm <- X[[1]]/sum(X[[1]])
+ for (k in 2:nblo) tabm <- tabm + X[[k]]/sum(X[[k]])
+ tabm <- tabm/nblo
+ row.names(tabm) <- row.names(X)
+ names(tabm) <- unique.col.names
+ fouc <- dudi.coa(tabm, scannf = scannf, nf = nf)
+ fouc$call <- match.call()
+ class(fouc) <- c("foucart", "coa", "dudi")
+ cooli <- suprow(fouc, X[[1]])$lisup
+ for (k in 2:nblo) {
+ cooli <- rbind(cooli, suprow(fouc, X[[k]])$lisup)
+ }
+ row.names(cooli) <- auxinames$row
+ fouc$Tli <- cooli
+ cooco <- supcol(fouc, X[[1]])$cosup
+ for (k in 2:nblo) {
+ cooco <- rbind(cooco, supcol(fouc, X[[k]])$cosup)
+ }
+ row.names(cooco) <- auxinames$col
+ fouc$Tco <- cooco
+ fouc$TL <- X$TL
+ fouc$TC <- X$TC
+ fouc$blocks <- blocks
+ fouc$tab.names <- tnames
+ fouc$call <- match.call()
+ return(fouc)
+}
+
+"kplot.foucart" <- function (object, xax = 1, yax = 2, mfrow = NULL, which.tab = 1:length(object$blo),
+ clab.r = 1, clab.c = 1.25, csub = 2, possub = "bottomright", ...)
+{
+ if (!inherits(object, "foucart"))
+ stop("Object of type 'foucart' expected")
+ opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
+ on.exit(par(opar))
+ if (is.null(mfrow))
+ mfrow <- n2mfrow(length(which.tab))
+ par(mfrow = mfrow)
+ nblo <- length(object$blo)
+ if (length(which.tab) > prod(mfrow))
+ par(ask = TRUE)
+ rank.fac <- factor(rep(1:nblo, object$rank))
+ nf <- ncol(object$li)
+ coolig <- object$Tli[, c(xax, yax)]
+ coocol <- object$Tco[, c(xax, yax)]
+ names(coocol) <- names(coolig)
+ cootot <- rbind.data.frame(coocol, coolig)
+ if (clab.r > 0)
+ cpoi <- 0
+ else cpoi <- 2
+ for (ianal in which.tab) {
+ coolig <- object$Tli[object$TL[, 1] == levels(object$TL[,1])[ianal], c(xax, yax)]
+ coocol <- object$Tco[object$TC[, 1] == levels(object$TC[,1])[ianal], c(xax, yax)]
+ s.label(cootot, clab = 0, cpoi = 0, sub = object$tab.names[ianal],
+ csub = csub, possub = possub)
+ s.label(coolig, clab = clab.r, cpoi = cpoi, add.p = TRUE)
+ s.label(coocol, clab = clab.c, add.p = TRUE)
+ }
+}
+
+"plot.foucart" <- function (x, xax = 1, yax = 2, clab = 1, csub = 2, possub = "bottomright", ...) {
+ if (!inherits(x, "foucart"))
+ stop("Object of type 'foucart' expected")
+ opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
+ on.exit(par(opar))
+ par(mfrow = c(2, 2))
+ cootot <- x$li[, c(xax, yax)]
+ auxi <- x$li[, c(xax, yax)]
+ names(auxi) <- names(cootot)
+ cootot <- rbind.data.frame(cootot, auxi)
+ auxi <- x$Tli[, c(xax, yax)]
+ names(auxi) <- names(cootot)
+ cootot <- rbind.data.frame(cootot, auxi)
+ auxi <- x$Tco[, c(xax, yax)]
+ names(auxi) <- names(cootot)
+ cootot <- rbind.data.frame(cootot, auxi)
+ s.label(cootot, clabel = 0, cpoint = 0, sub = "Rows (Base)",
+ csub = csub, possub = possub)
+ s.label(x$li, xax, yax, clabel = clab, add.plot = TRUE)
+ s.label(cootot, clabel = 0, cpoint = 0, sub = "Columns (Base)",
+ csub = csub, possub = possub)
+ s.label(x$co, xax, yax, clabel = clab, add.plot = TRUE)
+ s.label(cootot, clabel = 0, cpoint = 0, sub = "Rows", csub = csub,
+ possub = possub)
+ s.class(x$Tli, x$TL[, 2], xax = xax, yax = yax,
+ axesell = FALSE, clabel = clab, add.plot = TRUE)
+ s.label(cootot, clabel = 0, cpoint = 0, sub = "Columns",
+ csub = csub, possub = possub)
+ s.class(x$Tco, x$TC[, 2], xax = xax, yax = yax,
+ axesell = FALSE, clabel = clab, add.plot = TRUE)
+}
+
+"print.foucart" <- function (x, ...) {
+ cat("Foucart's COA\n")
+ cat("class: ")
+ cat(class(x))
+ cat("\n$call: ")
+ print(x$call)
+ cat("table number:", length(x$blo), "\n")
+ cat("\n$nf:", x$nf, "axis-components saved")
+ cat("\n$rank: ")
+ cat(x$rank)
+ cat("\neigen values: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n")
+ else cat("\n")
+ cat("blo vector ", length(x$blo), " blocks\n")
+ sumry <- array("", c(3, 4), list(rep("", 3), c("vector",
+ "length", "mode", "content")))
+ sumry[1, ] <- c("$cw", length(x$cw), mode(x$cw), "column weights")
+ sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weights")
+ sumry[3, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(5, 4), list(rep("", 5), c("data.frame",
+ "nrow", "ncol", "content")))
+ sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "modified array")
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates")
+ sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "row normed scores")
+ sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates")
+ sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores")
+
+ print(sumry, quote = FALSE)
+ cat("\n **** Intrastructure ****\n\n")
+ sumry <- array("", c(4, 4), list(rep("", 4), c("data.frame",
+ "nrow", "ncol", "content")))
+ sumry[1, ] <- c("$Tli", nrow(x$Tli), ncol(x$Tli), "row coordinates (each table)")
+ sumry[2, ] <- c("$Tco", nrow(x$Tco), ncol(x$Tco), "col coordinates (each table)")
+ sumry[3, ] <- c("$TL", nrow(x$TL), ncol(x$TL), "factors for Tli")
+ sumry[4, ] <- c("$TC", nrow(x$TC), ncol(x$TC), "factors for Tco")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+}
diff --git a/R/fourthcorner.R b/R/fourthcorner.R
new file mode 100644
index 0000000..c3db043
--- /dev/null
+++ b/R/fourthcorner.R
@@ -0,0 +1,291 @@
+"fourthcorner" <- function(tabR, tabL, tabQ, modeltype = 6,nrepet = 999, tr01 = FALSE, p.adjust.method.G = p.adjust.methods, p.adjust.method.D = p.adjust.methods, p.adjust.D = c("global","levels"), ...) {
+
+ ## tabR ,tabL, tabQ are 3 data frames containing the data
+ ## permut.model is the permutational model and can take 6 values (1:6) 6 corresponds to the combination of 2 and 4
+
+
+
+ ## -------------------------------
+ ## Test of the different arguments
+ ## -------------------------------
+
+ if (!is.data.frame(tabR))
+ stop("data.frame expected")
+
+ if (!is.data.frame(tabL))
+ stop("data.frame expected")
+
+ if (!is.data.frame(tabQ))
+ stop("data.frame expected")
+
+ if (any(is.na(tabR)))
+ stop("na entries in table")
+
+ if (any(is.na(tabL)))
+ stop("na entries in table")
+
+ if (any(tabL<0))
+ stop("negative values in table L")
+
+ if (any(is.na(tabQ)))
+ stop("na entries in table")
+
+ p.adjust.D <- match.arg(p.adjust.D)
+ p.adjust.method.D <- match.arg(p.adjust.method.D)
+ p.adjust.method.G <- match.arg(p.adjust.method.G)
+
+ if (sum(modeltype==(1:6))!=1)
+ stop("modeltype should be 1, 2, 3, 4, 5 or 6")
+
+ if(modeltype == 6){
+ test1 <- fourthcorner(tabR, tabL, tabQ, modeltype = 2,nrepet = nrepet, tr01 = tr01, p.adjust.method.G = p.adjust.method.G, p.adjust.method.D = p.adjust.method.D, p.adjust.D = p.adjust.D, ...)
+ test2 <- fourthcorner(tabR, tabL, tabQ, modeltype = 4,nrepet = nrepet, tr01 = tr01, p.adjust.method.G = p.adjust.method.G, p.adjust.method.D = p.adjust.method.D, p.adjust.D = p.adjust.D, ...)
+ res <- combine.4thcorner(test1,test2)
+ res$call <- res$tabD2$call <- res$tabD$call <- res$tabG$call <- match.call()
+ return(res)
+ }
+
+ nrowL <- nrow(tabL)
+ ncolL <- ncol(tabL)
+ nrowR <- nrow(tabR)
+ nrowQ <- nrow(tabQ)
+
+ nvarQ <- ncol(tabQ)
+ nvarR <- ncol(tabR)
+
+ if (nrowR != nrowL)
+ stop("Non equal row numbers")
+ if (nrowQ != ncolL)
+ stop("Non equal row numbers")
+
+ ## transform the data into presence-absence if trO1 = TRUE
+ if (tr01)
+ {
+ cat("Values in table L are 0-1 transformed\n")
+ tabL <- ifelse(tabL==0,0,1)
+
+ }
+
+ ## ------------------------------------------
+ ## Create the data matrices for R and Q
+ ## Transform factors into disjunctive tables
+ ## tabR becomes matR and tabQ becomes matQ
+ ## ------------------------------------------
+
+ ## For tabR
+ matR <- matrix(0, nrowR, 1)
+ provinames <- "tmp"
+ assignR <- NULL
+ k <- 0
+ indexR <- rep(0, nvarR)
+
+ for (j in 1:nvarR) {
+ ## Get the type of data
+ ## The type is store in the index vector (1 for numeric / 2 for factor)
+ if (is.numeric(tabR[, j])) {
+ indexR[j] <- 1
+ matR <- cbind(matR, tabR[, j])
+ provinames <- c(provinames, names(tabR)[j])
+ k <- k + 1
+ assignR <- c(assignR, k)
+ }
+ else if (is.factor(tabR[, j])) {
+ indexR[j] <- 2
+ if (is.ordered(tabR[, j]))
+ warning("ordered variables will be considered as factor")
+ w <- fac2disj(tabR[, j], drop = TRUE)
+ cha <- paste(substr(names(tabR)[j], 1, 5), ".", names(w), sep = "")
+ matR <- cbind(matR, w)
+ provinames <- c(provinames, cha)
+ k <- k + 1
+ assignR <- c(assignR, rep(k, length(cha)))
+ } else stop("Not yet available")
+ }
+ matR <- data.frame(matR[, -1])
+ names(matR) <- provinames[-1]
+ ncolR <- ncol(matR)
+ ## ----------
+
+ ## For tabQ
+ matQ <- matrix(0, nrowQ, 1)
+ provinames <- "tmp"
+ assignQ <- NULL
+ k <- 0
+ indexQ <- rep(0, nvarQ)
+
+ for (j in 1:nvarQ) {
+ ## Get the type of data
+ ## The type is stored in the index vector (1 for numeric / 2 for factor)
+ if (is.numeric(tabQ[, j])) {
+ indexQ[j] <- 1
+ matQ <- cbind(matQ, tabQ[, j])
+ provinames <- c(provinames, names(tabQ)[j])
+ k <- k + 1
+ assignQ <- c(assignQ, k)
+ }
+ else if (is.factor(tabQ[, j])) {
+ indexQ[j] <- 2
+ if (is.ordered(tabQ[, j]))
+ warning("ordered variables will be considered as factor")
+ w <- fac2disj(tabQ[, j], drop = TRUE)
+ cha <- paste(substr(names(tabQ)[j], 1, 5), ".", names(w), sep = "")
+ matQ <- cbind(matQ, w)
+ provinames <- c(provinames, cha)
+ k <- k + 1
+ assignQ <- c(assignQ, rep(k, length(cha)))
+ }
+ }
+ matQ <- data.frame(matQ[, -1])
+ names(matQ) <- provinames[-1]
+ ncolQ <- ncol(matQ)
+ ## ----------
+
+ ##----- create objects to store results -------#
+ tabD <- matrix(0,nrepet + 1, ncolR * ncolQ)
+ tabD2 <- matrix(0,nrepet + 1, ncolR * ncolQ)
+ tabG <- matrix(0,nrepet + 1, nvarR * nvarQ)
+ res <- list()
+
+ ##------------------
+ ## Call the C code
+ ##------------------
+ res <- .C("quatriemecoin",
+ as.double(t(matR)),
+ as.double(t(tabL)),
+ as.double(t(matQ)),
+ as.integer(ncolR),
+ as.integer(nvarR),
+ as.integer(nrowL),
+ as.integer(ncolL),
+ as.integer(ncolQ),
+ as.integer(nvarQ),
+ as.integer(nrepet),
+ modeltype = as.integer(modeltype),
+ tabD = as.double(tabD),
+ tabD2 = as.double(tabD2),
+ tabG = as.double(tabG),
+ as.integer(indexR),
+ as.integer(indexQ),
+ as.integer(assignR),
+ as.integer(assignQ),
+ PACKAGE="ade4")[c("tabD","tabD2","tabG")]
+
+ ##-------------------------------------------------------------------#
+ ## Outputs #
+ ##-------------------------------------------------------------------#
+
+ res$varnames.R <- names(tabR)
+ res$colnames.R <- names(matR)
+ res$varnames.Q <- names(tabQ)
+ res$colnames.Q <- names(matQ)
+ res$indexQ <- indexQ
+ res$assignQ <- assignQ
+ res$assignR <- assignR
+ res$indexR <- indexR
+
+ ## set invalid permutation to NA (in the case of levels of a factor with no observation)
+ res$tabD <- ifelse(res$tabD < (-998), NA, res$tabD)
+ res$tabG <- ifelse(res$tabG < (-998), NA, res$tabG)
+
+ ## Reshape the tables
+ res$tabD <- matrix(res$tabD, nrepet + 1, ncolR * ncolQ, byrow=TRUE)
+ res$tabD2 <- matrix(res$tabD2, nrepet + 1, ncolR * ncolQ, byrow=TRUE)
+ res$tabG <- matrix(res$tabG, nrepet + 1, nvarR * nvarQ, byrow=TRUE)
+
+ ## Create vectors to store type of statistics and alternative hypotheses
+ names.stat.D <- vector(mode="character")
+ names.stat.D2 <- vector(mode="character")
+ names.stat.G <- vector(mode="character")
+ alter.G <- vector(mode="character")
+ alter.D <- vector(mode="character")
+ alter.D2 <- vector(mode="character")
+
+ for (i in 1:nvarQ){
+ for (j in 1:nvarR){
+ ## Type of statistics for G and alternative hypotheses
+ if ((res$indexR[j]==1)&(res$indexQ[i]==1)){
+ names.stat.G <- c(names.stat.G, "r")
+ alter.G <- c(alter.G, "two-sided")
+ }
+ if ((res$indexR[j]==1)&(res$indexQ[i]==2)){
+ names.stat.G <- c(names.stat.G, "F")
+ alter.G <- c(alter.G, "greater")
+ }
+ if ((res$indexR[j]==2)&(res$indexQ[i]==1)){
+ names.stat.G <- c(names.stat.G, "F")
+ alter.G <- c(alter.G, "greater")
+ }
+ if ((res$indexR[j]==2)&(res$indexQ[i]==2)){
+ names.stat.G <- c(names.stat.G, "Chi2")
+ alter.G <- c(alter.G, "greater")
+ }
+ }
+ }
+
+ for (i in 1:ncolQ){
+ for (j in 1:ncolR){
+ ## Type of statistics for D and alternative hypotheses
+ idx.vars <- ncolR * (i-1) + j
+ if ((res$indexR[res$assignR[j]]==1)&(res$indexQ[res$assignQ[i]]==1)){
+ names.stat.D <- c(names.stat.D, "r")
+ names.stat.D2 <- c(names.stat.D2, "r")
+ alter.D <- c(alter.D, "two-sided")
+ alter.D2 <- c(alter.D2, "two-sided")
+ }
+ if ((res$indexR[res$assignR[j]]==1)&(res$indexQ[res$assignQ[i]]==2)){
+ names.stat.D <- c(names.stat.D, "Homog.")
+ names.stat.D2 <- c(names.stat.D2, "r")
+ alter.D <- c(alter.D, "less")
+ alter.D2 <- c(alter.D2, "two-sided")
+ }
+ if ((res$indexR[res$assignR[j]]==2)&(res$indexQ[res$assignQ[i]]==1)){
+ names.stat.D <- c(names.stat.D, "Homog.")
+ names.stat.D2 <- c(names.stat.D2, "r")
+ alter.D <- c(alter.D, "less")
+ alter.D2 <- c(alter.D2, "two-sided")
+ }
+ if ((res$indexR[res$assignR[j]]==2)&(res$indexQ[res$assignQ[i]]==2)){
+ names.stat.D <- c(names.stat.D, "N")
+ names.stat.D2 <- c(names.stat.D2, "N")
+ alter.D <- c(alter.D, "two-sided")
+ alter.D2 <- c(alter.D2, "two-sided")
+ }
+ }
+ }
+
+ provinames <- apply(expand.grid(res$colnames.R, res$colnames.Q), 1, paste, collapse=" / ")
+ res$tabD <- as.krandtest(obs = res$tabD[1, ], sim = res$tabD[-1, , drop = FALSE], names = provinames, alter = alter.D, call = match.call(), p.adjust.method = p.adjust.method.D, ...)
+ res$tabD2 <- as.krandtest(obs = res$tabD2[1, ], sim = res$tabD2[-1, , drop = FALSE], names = provinames, alter = alter.D2, call = match.call(), p.adjust.method = p.adjust.method.D, ...)
+
+
+ if(p.adjust.D == "levels"){
+ ## adjustment only between levels of a factor (corresponds to the original paper of Legendre et al. 1997)
+ for (i in 1:nvarQ){
+ for (j in 1:nvarR){
+ idx.varR <- which(res$assignR == j)
+ idx.varQ <- which(res$assignQ == i)
+ idx.vars <- nvarR * (idx.varQ - 1) + idx.varR
+ res$tabD$adj.pvalue[idx.vars] <- p.adjust(res$tabD$pvalue[idx.vars], method = p.adjust.method.D)
+ res$tabD2$adj.pvalue[idx.vars] <- p.adjust(res$tabD2$pvalue[idx.vars], method = p.adjust.method.D)
+ }
+ }
+ res$tabD$adj.method <- res$tabD2$adj.method <- paste(p.adjust.method.D, "by levels")
+ }
+
+
+
+ provinames <- apply(expand.grid(res$varnames.R, res$varnames.Q), 1, paste, collapse=" / ")
+ res$tabG <- as.krandtest(obs = res$tabG[1, ], sim = res$tabG[-1, ,drop = FALSE], names = provinames, alter = alter.G, call = match.call(), p.adjust.method = p.adjust.method.G, ...)
+
+ res$tabD$statnames <- names.stat.D
+ res$tabD2$statnames <- names.stat.D2
+ res$tabG$statnames <- names.stat.G
+
+ res$call <- match.call()
+ res$model <- modeltype
+ res$npermut <- nrepet
+
+ class(res) <- "4thcorner"
+
+ return(res)
+}
diff --git a/R/fourthcorner.rlq.R b/R/fourthcorner.rlq.R
new file mode 100644
index 0000000..f711dfb
--- /dev/null
+++ b/R/fourthcorner.rlq.R
@@ -0,0 +1,310 @@
+fourthcorner.rlq <- function(xtest, nrepet = 999, modeltype = 6, typetest = c("axes","Q.axes","R.axes"), p.adjust.method.G = p.adjust.methods, p.adjust.method.D = p.adjust.methods, p.adjust.D = c("global","levels"), ...)
+{
+ ## test RLQ axes
+
+ if (!inherits(xtest, "dudi"))
+ stop("Object of class dudi expected")
+ if (!inherits(xtest, "rlq"))
+ stop("Object of class 'rlq' expected")
+ if (!(modeltype %in% c(2, 4, 5, 6)))
+ stop("modeltype should be 2, 4, 5 or 6")
+
+ if(modeltype == 6){
+ test1 <- fourthcorner.rlq(xtest, modeltype = 2,nrepet = nrepet, typetest = typetest, p.adjust.method.G = p.adjust.method.G, p.adjust.method.D = p.adjust.method.D, p.adjust.D = p.adjust.D, ...)
+ test2 <- fourthcorner.rlq(xtest, modeltype = 4,nrepet = nrepet, typetest = typetest, p.adjust.method.G = p.adjust.method.G, p.adjust.method.D = p.adjust.method.D, p.adjust.D = p.adjust.D, ...)
+ res <- combine.4thcorner(test1, test2)
+ res$call <- res$tabD2$call <- res$tabD$call <- res$tabG$call <- match.call()
+ return(res)
+ }
+
+ p.adjust.D <- match.arg(p.adjust.D)
+ p.adjust.method.D <- match.arg(p.adjust.method.D)
+ p.adjust.method.G <- match.arg(p.adjust.method.G)
+ typetest <- match.arg(typetest)
+
+ appel <- as.list(xtest$call)
+ dudiR <- eval.parent(appel$dudiR)
+ dudiQ <- eval.parent(appel$dudiQ)
+ dudiL <- eval.parent(appel$dudiL)
+
+ tabR.cw <- dudiR$cw
+ appelR <- as.list(dudiR$call)
+ tabR <- Rinit <- eval.parent(appelR$df)
+
+ ## Test the different cases
+ ## typ=1 no modification (PCA on original variable)
+ ## typ=2 ACM
+ ## typ=3 normed and centred PCA
+ ## typ=4 centred PCA
+ ## typ=5 normed and non-centred PCA
+ ## typ=6 COA
+ ## typ=7 FCA
+ ## typ=8 Hill-smith
+
+
+ typR <- dudi.type(dudiR$call)
+ ##------- index can takes 2 values (1 for quantitative / 2 for factor) --------#
+ if (typR %in% c(1, 3, 4, 5, 6, 7)) {
+ indexR <- rep(1, ncol(Rinit))
+ assignR <- 1:ncol(Rinit)
+ } else if (typR == 2) {
+ indexR <- rep(2, ncol(Rinit))
+ assignR <- rep(1:ncol(Rinit), apply(Rinit, 2, function(x) nlevels(as.factor(x))))
+ Rinit <- acm.disjonctif(Rinit)
+ } else if (typR == 8) {
+ provinames <- "tmp"
+ indexR <- ifelse(dudiR$index == "q", 1, 2)
+ assignR <- as.numeric(dudiR$assign)
+
+ res <- matrix(0, nrow(Rinit), 1)
+
+ for (j in 1:(ncol(Rinit))) {
+ if (indexR[j] == 1) {
+ res <- cbind(res, Rinit[, j])
+ provinames <- c(provinames,names(Rinit)[j])
+ }
+ else if (indexR[j] == 2) {
+ w <- fac2disj(Rinit[, j], drop = TRUE)
+ res <- cbind(res, w)
+ provinames <- c(provinames, paste(substr(names(Rinit)[j], 1, 5), ".", names(w), sep = ""))
+ }
+ }
+ Rinit <- res[,-1]
+ colnames(Rinit) <- provinames[-1]
+ } else stop ("Not yet available")
+
+
+ tabQ.cw <- dudiQ$cw
+ appelQ <- as.list(dudiQ$call)
+ tabQ <- Qinit <- eval.parent(appelQ$df)
+
+ typQ <- dudi.type(dudiQ$call)
+
+ if (typQ %in% c(1, 3, 4, 5, 6, 7)) {
+ indexQ <- rep(1,ncol(Qinit))
+ assignQ <- 1:ncol(Qinit)
+} else if (typQ == 2) {
+ indexQ <- rep(2, ncol(Qinit))
+ assignQ <- rep(1:ncol(Qinit),apply(Qinit, 2, function(x) nlevels(as.factor(x))))
+ Qinit <- acm.disjonctif(Qinit)
+} else if (typQ == 8) {
+ provinames <- "tmp"
+ indexQ <- ifelse(dudiQ$index=="q",1,2)
+ assignQ <- as.numeric(dudiQ$assign)
+
+ res <- matrix(0, nrow(Qinit), 1)
+
+ for (j in 1:(ncol(Qinit))) {
+ if (indexQ[j] == 1) {
+ res <- cbind(res, Qinit[, j])
+ provinames <- c(provinames,names(Qinit)[j])
+ }
+ else if (indexQ[j] == 2) {
+ w <- fac2disj(Qinit[, j])
+ res <- cbind(res, w)
+ provinames <- c(provinames, paste(substr(names(Qinit)[j], 1, 5), ".", names(w), sep = ""))
+ }
+ }
+ Qinit <- res[,-1]
+ colnames(Qinit) <- provinames[-1]
+} else stop ("Not yet available")
+
+
+appelL <- as.list(dudiL$call)
+tabL <- eval.parent(appelL$df)
+tabL.cw <- dudiL$cw
+tabL.lw <- dudiL$lw
+
+ncolQ <- ncol(Qinit)
+ncolR <- ncol(Rinit)
+nvarR <- ncol(tabR)
+nvarQ <- ncol(tabQ)
+
+## Dimensions for D ang G matrices
+naxes <- xtest$nf
+
+
+if(typetest=="axes"){
+ ncolD <- ncolG <- naxes
+ nrowD <- nrowG <- naxes
+ typeTestN <- 1
+} else if (typetest=="Q.axes"){
+ ncolD <- ncolG <- naxes
+ nrowD <- ncolQ
+ nrowG <- nvarQ
+ typeTestN <- 3
+} else if(typetest=="R.axes"){
+ ncolD <- ncolR
+ ncolG <- nvarR
+ nrowD <- nrowG <- naxes
+ typeTestN <- 2
+}
+
+
+
+
+##----- create objects to store results -------#
+
+tabD <- matrix(0, nrepet + 1, nrowD * ncolD)
+tabD2 <- matrix(0, nrepet + 1, nrowD * ncolD)
+tabG <- matrix(0, nrepet + 1, nrowG * ncolG)
+res <- list()
+
+##------------------
+## Call the C code
+##------------------
+res <- .C("quatriemecoinRLQ",
+ as.double(t(Rinit)),
+ as.double(t(tabL)),
+ as.double(t(Qinit)),
+ as.integer(ncolR),
+ as.integer(nvarR),
+ as.integer(nrow(tabL)),
+ as.integer(ncol(tabL)),
+ as.integer(ncolQ),
+ as.integer(nvarQ),
+ as.integer(nrepet),
+ modeltype = as.integer(modeltype),
+ tabD = as.double(tabD),
+ tabD2 = as.double(tabD2),
+ tabG = as.double(tabG),
+ as.integer(nrowD),
+ as.integer(ncolD),
+ as.integer(nrowG),
+ as.integer(ncolG),
+ as.integer(indexR),
+ as.integer(indexQ),
+ as.integer(assignR),
+ as.integer(assignQ),
+ as.double(t(xtest$c1)),
+ as.double(t(xtest$l1)),
+ as.integer(typeTestN),
+ as.integer(naxes),
+ as.integer(typR),
+ as.integer(typQ),
+ as.double(tabR.cw),
+ as.double(tabQ.cw),
+ PACKAGE="ade4")[c("tabD","tabD2","tabG")]
+
+##-------------------------------------------------------------------#
+## Outputs #
+##-------------------------------------------------------------------#
+
+if(typetest == "axes"){
+ res$varnames.Q <- res$colnames.Q <- names(xtest$lQ)
+ res$varnames.R <- res$colnames.R <- names(xtest$lR)
+ res$assignR <- res$assignQ <- 1:naxes
+ res$indexR <- res$indexQ <- rep(1,naxes)
+} else if (typetest == "Q.axes"){
+ res$varnames.Q <- names(tabQ)
+ res$colnames.Q <- colnames(Qinit)
+ res$varnames.R <- res$colnames.R <- names(xtest$lR)
+ res$indexQ <- indexQ
+ res$assignQ <- assignQ
+ res$assignR <- 1:naxes
+ res$indexR <- rep(1,naxes)
+} else if(typetest == "R.axes"){
+ res$varnames.Q <- res$colnames.Q <- names(xtest$lQ)
+ res$varnames.R <- names(tabR)
+ res$colnames.R <- colnames(Rinit)
+ res$indexR <- indexR
+ res$assignR <- assignR
+ res$assignQ <- 1:naxes
+ res$indexQ <- rep(1,naxes)
+}
+
+## set invalid permutation to NA (in the case of levels of a factor with no observation)
+res$tabD <- ifelse(res$tabD < (-998), NA, res$tabD)
+res$tabG <- ifelse(res$tabG < (-998), NA, res$tabG)
+
+## Reshape the tables
+res$tabD <- matrix(res$tabD, nrepet + 1, nrowD * ncolD, byrow = TRUE)
+res$tabD2 <- matrix(res$tabD2, nrepet + 1, nrowD * ncolD, byrow = TRUE)
+res$tabG <- matrix(res$tabG, nrepet + 1, nrowG * ncolG, byrow = TRUE)
+
+## Create vectors to store type of statistics and alternative hypotheses
+names.stat.D <- vector(mode="character")
+names.stat.D2 <- vector(mode="character")
+names.stat.G <- vector(mode="character")
+alter.G <- vector(mode="character")
+alter.D <- vector(mode="character")
+alter.D2 <- vector(mode="character")
+
+for (i in 1:nrowG){
+ for (j in 1:ncolG){
+ ## Type of statistics for G and alternative hypotheses
+ if ((res$indexR[j]==1)&(res$indexQ[i]==1)){
+ names.stat.G <- c(names.stat.G, "r")
+ alter.G <- c(alter.G, "two-sided")
+ }
+ if ((res$indexR[j]==1)&(res$indexQ[i]==2)){
+ names.stat.G <- c(names.stat.G, "F")
+ alter.G <- c(alter.G, "greater")
+ }
+ if ((res$indexR[j]==2)&(res$indexQ[i]==1)){
+ names.stat.G <- c(names.stat.G, "F")
+ alter.G <- c(alter.G, "greater")
+ }
+ }
+}
+
+for (i in 1:nrowD){
+ for (j in 1:ncolD){
+ ## Type of statistics for D and alternative hypotheses
+ if ((res$indexR[res$assignR[j]]==1)&(res$indexQ[res$assignQ[i]]==1)){
+ names.stat.D <- c(names.stat.D, "r")
+ names.stat.D2 <- c(names.stat.D2, "r")
+ alter.D <- c(alter.D, "two-sided")
+ alter.D2 <- c(alter.D2, "two-sided")
+ }
+ if ((res$indexR[res$assignR[j]]==1)&(res$indexQ[res$assignQ[i]]==2)){
+ names.stat.D <- c(names.stat.D, "Homog.")
+ names.stat.D2 <- c(names.stat.D2, "r")
+ alter.D <- c(alter.D, "less")
+ alter.D2 <- c(alter.D2, "two-sided")
+ }
+ if ((res$indexR[res$assignR[j]]==2)&(res$indexQ[res$assignQ[i]]==1)){
+ names.stat.D <- c(names.stat.D, "Homog.")
+ names.stat.D2 <- c(names.stat.D2, "r")
+ alter.D <- c(alter.D, "less")
+ alter.D2 <- c(alter.D2, "two-sided")
+ }
+ }
+}
+
+provinames <- apply(expand.grid(res$colnames.R, res$colnames.Q), 1, paste, collapse=" / ")
+res$tabD <- as.krandtest(obs = res$tabD[1, ], sim = res$tabD[-1, , drop = FALSE], names = provinames, alter = alter.D, call = match.call(), p.adjust.method = p.adjust.method.D, ...)
+res$tabD2 <- as.krandtest(obs = res$tabD2[1, ], sim = res$tabD2[-1, , drop = FALSE], names = provinames, alter = alter.D2, call = match.call(), p.adjust.method = p.adjust.method.D, ...)
+
+
+if(p.adjust.D == "levels"){
+ ## adjustment only between levels of a factor (corresponds to the original paper of Legendre et al. 1997)
+ for (i in 1:nrowG){
+ for (j in 1:ncolG){
+ idx.varR <- which(res$assignR == j)
+ idx.varQ <- which(res$assignQ == i)
+ idx.vars <- ncolG * (idx.varQ - 1) + idx.varR
+ res$tabD$adj.pvalue[idx.vars] <- p.adjust(res$tabD$pvalue[idx.vars], method = p.adjust.method.D)
+ res$tabD2$adj.pvalue[idx.vars] <- p.adjust(res$tabD2$pvalue[idx.vars], method = p.adjust.method.D)
+ }
+ }
+ res$tabD$adj.method <- res$tabD2$adj.method <- paste(p.adjust.method.D, "by levels")
+}
+
+provinames <- apply(expand.grid(res$varnames.R, res$varnames.Q), 1, paste, collapse=" / ")
+res$tabG <- as.krandtest(obs = res$tabG[1, ], sim = res$tabG[-1, , drop = FALSE], names = provinames, alter = alter.G, call = match.call(), p.adjust.method = p.adjust.method.G, ...)
+
+res$tabD$statnames <- names.stat.D
+res$tabD2$statnames <- names.stat.D2
+res$tabG$statnames <- names.stat.G
+
+res$call <- match.call()
+res$model <- modeltype
+res$npermut <- nrepet
+
+class(res) <- "4thcorner"
+
+return(res)
+
+
+}
diff --git a/R/fourthcorner2.R b/R/fourthcorner2.R
new file mode 100644
index 0000000..ab9ccbf
--- /dev/null
+++ b/R/fourthcorner2.R
@@ -0,0 +1,218 @@
+"fourthcorner2" <- function(tabR, tabL, tabQ, modeltype = 6,nrepet = 999, tr01 = FALSE, p.adjust.method.G = p.adjust.methods, ...) {
+
+ ## tabR ,tabL, tabQ are 3 data frames containing the data
+ ## permut.model is the permutational model and can take 6 values (1:6). 6 corresponds to the combined approach
+
+
+
+ ## -------------------------------
+ ## Test of the different arguments
+ ## -------------------------------
+
+ if (!is.data.frame(tabR))
+ stop("data.frame expected")
+
+ if (!is.data.frame(tabL))
+ stop("data.frame expected")
+
+ if (!is.data.frame(tabQ))
+ stop("data.frame expected")
+
+ if (any(is.na(tabR)))
+ stop("na entries in table")
+
+ if (any(is.na(tabL)))
+ stop("na entries in table")
+
+ if (any(tabL<0))
+ stop("negative values in table L")
+
+ if (any(is.na(tabQ)))
+ stop("na entries in table")
+
+ p.adjust.method.G <- match.arg(p.adjust.method.G)
+
+ if (sum(modeltype==(1:6))!=1)
+ stop("modeltype should be 1, 2, 3, 4, 5 or 6")
+
+ if(modeltype == 6){
+ test1 <- fourthcorner2(tabR, tabL, tabQ, modeltype = 2,nrepet = nrepet, tr01 = tr01, p.adjust.method.G = p.adjust.method.G, ...)
+ test2 <- fourthcorner2(tabR, tabL, tabQ, modeltype = 4,nrepet = nrepet, tr01 = tr01, p.adjust.method.G = p.adjust.method.G, ...)
+ res <- combine.4thcorner(test1,test2)
+ res$call <- res$tabG$call <- res$trRLQ$call <- match.call()
+ return(res)
+ }
+
+ nrowL <- nrow(tabL)
+ ncolL <- ncol(tabL)
+ nrowR <- nrow(tabR)
+ nrowQ <- nrow(tabQ)
+
+ nvarQ <- ncol(tabQ)
+ nvarR <- ncol(tabR)
+
+ if (nrowR != nrowL)
+ stop("Non equal row numbers")
+ if (nrowQ != ncolL)
+ stop("Non equal row numbers")
+
+ ## transform the data into prsence-absence if trO1 = TRUE
+ if (tr01)
+ {
+ cat("Values in table L are 0-1 transformed\n")
+ tabL <- ifelse(tabL==0,0,1)
+
+ }
+
+ ## ------------------------------------------
+ ## Create the data matrices for R and Q
+ ## Transform factors into dsjunctive tables
+ ## tabR becomes matR and tabQ becomes matQ
+ ## ------------------------------------------
+
+ ## For tabR
+ matR <- matrix(0, nrowR, 1)
+ provinames <- "tmp"
+ assignR <- NULL
+ k <- 0
+ indexR <- rep(0, nvarR)
+
+ for (j in 1:nvarR) {
+ ## Get the type of data
+ ## The type is store in the index vector (1 for numeric / 2 for factor)
+ if (is.numeric(tabR[, j])) {
+ indexR[j] <- 1
+ matR <- cbind(matR, tabR[, j])
+ provinames <- c(provinames, names(tabR)[j])
+ k <- k + 1
+ assignR <- c(assignR, k)
+ }
+ else if (is.factor(tabR[, j])) {
+ indexR[j] <- 2
+ if (is.ordered(tabR[, j]))
+ warning("ordered variables will be considered as factor")
+ w <- fac2disj(tabR[, j], drop = TRUE)
+ cha <- paste(substr(names(tabR)[j], 1, 5), ".", names(w), sep = "")
+ matR <- cbind(matR, w)
+ provinames <- c(provinames, cha)
+ k <- k + 1
+ assignR <- c(assignR, rep(k, length(cha)))
+ } else stop("Not yet available")
+ }
+ matR <- data.frame(matR[, -1])
+ names(matR) <- provinames[-1]
+ ncolR <- ncol(matR)
+ ## ----------
+
+ ## For tabQ
+ matQ <- matrix(0, nrowQ, 1)
+ provinames <- "tmp"
+ assignQ <- NULL
+ k <- 0
+ indexQ <- rep(0, nvarQ)
+
+ for (j in 1:nvarQ) {
+ ## Get the type of data
+ ## The type is store in the index vector (1 for numeric / 2 for factor)
+ if (is.numeric(tabQ[, j])) {
+ indexQ[j] <- 1
+ matQ <- cbind(matQ, tabQ[, j])
+ provinames <- c(provinames, names(tabQ)[j])
+ k <- k + 1
+ assignQ <- c(assignQ, k)
+ }
+ else if (is.factor(tabQ[, j])) {
+ indexQ[j] <- 2
+ if (is.ordered(tabQ[, j]))
+ warning("ordered variables will be considered as factor")
+ w <- fac2disj(tabQ[, j], drop = TRUE)
+ cha <- paste(substr(names(tabQ)[j], 1, 5), ".", names(w), sep = "")
+ matQ <- cbind(matQ, w)
+ provinames <- c(provinames, cha)
+ k <- k + 1
+ assignQ <- c(assignQ, rep(k, length(cha)))
+ }
+ }
+ matQ <- data.frame(matQ[, -1])
+ names(matQ) <- provinames[-1]
+ ncolQ <- ncol(matQ)
+ ## ----------
+
+ ##----- create objects to store results -------#
+ tabG <- matrix(0,nrepet + 1, nvarR * nvarQ)
+ trRLQ <- rep(0, nrepet + 1)
+ res <- list()
+
+ ##------------------
+ ## Call the C code
+ ##------------------
+ res <- .C("quatriemecoin2",
+ as.double(t(matR)),
+ as.double(t(tabL)),
+ as.double(t(matQ)),
+ as.integer(ncolR),
+ as.integer(nvarR),
+ as.integer(nrowL),
+ as.integer(ncolL),
+ as.integer(ncolQ),
+ as.integer(nvarQ),
+ as.integer(nrepet),
+ modeltype = as.integer(modeltype),
+ tabG = as.double(tabG),
+ trRLQ = as.double(trRLQ),
+ as.integer(indexR),
+ as.integer(indexQ),
+ as.integer(assignR),
+ as.integer(assignQ),
+ PACKAGE="ade4")[c("tabG", "trRLQ")]
+
+ ##-------------------------------------------------------------------#
+ ## Outputs #
+ ##-------------------------------------------------------------------#
+
+ res$varnames.R <- names(tabR)
+ res$colnames.R <- names(matR)
+ res$varnames.Q <- names(tabQ)
+ res$colnames.Q <- names(matQ)
+ res$indexQ <- indexQ
+ res$assignQ <- assignQ
+ res$assignR <- assignR
+ res$indexR <- indexR
+
+ ## set invalid permutation to NA (in the case of levels of a factor with no observation)
+ res$tabG <- ifelse(res$tabG < (-998), NA, res$tabG)
+
+ ## Reshape the tables
+ res$tabG <- matrix(res$tabG, nrepet + 1, nvarR * nvarQ, byrow=TRUE)
+
+ ## Create vectors to store type of statistics and alternative hypotheses
+ names.stat.G <- vector(mode="character")
+ alter.G <- rep("greater", nvarQ * nvarR)
+
+ for (i in 1:nvarQ){
+ for (j in 1:nvarR){
+ ## Type of statistics for G
+ if ((res$indexR[j]==1)&(res$indexQ[i]==1))
+ names.stat.G <- c(names.stat.G, "r^2")
+ if ((res$indexR[j]==1)&(res$indexQ[i]==2))
+ names.stat.G <- c(names.stat.G, "Eta^2")
+ if ((res$indexR[j]==2)&(res$indexQ[i]==1))
+ names.stat.G <- c(names.stat.G, "Eta^2")
+ if ((res$indexR[j]==2)&(res$indexQ[i]==2))
+ names.stat.G <- c(names.stat.G, "Chi2/sum(L)")
+ }
+ }
+
+ provinames <- apply(expand.grid(res$varnames.R, res$varnames.Q), 1, paste, collapse=" / ")
+ res$tabG <- as.krandtest(obs = res$tabG[1, ], sim = res$tabG[-1, ,drop = FALSE], names = provinames, alter = alter.G, call = match.call(), p.adjust.method = p.adjust.method.G, ...)
+ res$trRLQ <- as.randtest(obs = res$trRLQ[1], sim = res$trRLQ[-1], alter = "greater", call = match.call(), ...)
+ res$tabG$statnames <- names.stat.G
+
+ res$call <- match.call()
+ res$model <- modeltype
+ res$npermut <- nrepet
+
+ class(res) <- c("4thcorner", "4thcorner.rlq")
+
+ return(res)
+}
diff --git a/R/fuzzygenet.R b/R/fuzzygenet.R
new file mode 100644
index 0000000..88c427f
--- /dev/null
+++ b/R/fuzzygenet.R
@@ -0,0 +1,143 @@
+"fuzzygenet" <- function(X) {
+ if (!inherits(X, "data.frame")) stop ("X is not a data.frame")
+ nind <- nrow(X)
+ ####################################################################################
+ "codred" <- function(base, n) {
+ # fonction qui fait des codes de noms ordonnés par ordre
+ # alphabétique de longueur constante le plus simples possibles
+ # base est une chaîne de charactères, n le nombre qu'on veut
+ w <- as.character(1:n)
+ max0 <- max(nchar(w))
+ "fun1" <- function(x) while ( nchar(w[x]) < max0) w[x] <<- paste("0",w[x],sep="")
+ lapply(1:n, fun1)
+ return(paste(base,w,sep=""))
+ }
+ ###################################################################################
+ # ce qui touche au loci
+ loc.names <- names(X)
+ nloc <- ncol(X)
+ loc.codes <- codred("L",nloc)
+ names(loc.names) <- loc.codes
+ names(X) <- loc.codes
+ "cha6car" <- function(cha) {
+ # pour compléter les chaînes de caratères par des zéros devant
+ n0 <- nchar(cha)
+ if (n0 == 6) return (cha)
+ if (n0 >6) stop ("More than 6 characters")
+ cha = paste("0",cha,sep="")
+ cha = cha6car(cha)
+ }
+ X <- apply(X,c(1,2),cha6car)
+
+ # Toutes les chaînes sont de 6 charactères suppose que le codage est complet
+ # ou qu'il ne manque des zéros qu'au début
+ "enumallel" <- function (x) {
+ w <- as.character(x)
+ w1 <- substr(w,1,3)
+ w2 <- substr(w,4,6)
+ w3 <- sort(unique (c(w1,w2)))
+ return(w3)
+ }
+ all.util <- apply(X,2,enumallel)
+ # all.util est une liste dont les composantes sont les noms des allèles ordonnés
+ # peut comprendre 000 pour un non typé
+ # on conserve le nombre d'individus typés par locus dans vec1
+ "compter" <- function(x) {
+ # compte le nombre d'individus typés par locus
+ num0 <- x!="000000"
+ num0 <- sum(num0)
+ return(num0)
+ }
+ vec1 <- unlist(apply(X,2, compter))
+ names(vec1) <- loc.codes
+ # vec1 est le vecteur des effectifs d'individus typés par locus
+ "polymor" <- function(x) {
+ if (any(x=="000")) return(x[x!="000"])
+ return(x)
+ }
+ "nallel" <- function(x) {
+ l0 <- length(x)
+ if (any(x=="000")) return(l0-1)
+ return(l0)
+ }
+ vec2 <- unlist(lapply(all.util, nallel))
+ names(vec2) <- names(all.util)
+ # vec2 est le vecteur du nombre d'allèles observés par locus
+
+ all.names <- unlist(lapply(all.util, polymor))
+ # all.names contient les nomds des alleles sans "000"
+ loc.blocks <- unlist(lapply(all.util, nallel))
+ names(loc.blocks) <- names(all.util)
+ all.names <- unlist(lapply(all.util, polymor))
+ w1 <- rep(loc.codes,loc.blocks)
+ w2 <- unlist(lapply(loc.blocks, function(n) codred(".",n)))
+ all.codes <- paste(w1,w2,sep="")
+ all.names <- paste(rep(loc.names, loc.blocks),all.names,sep=".")
+ names(all.names) <- all.codes
+ # all.names est le nouveau nom des allèles
+ w1 <- as.factor(w1)
+ names(w1) <- all.codes
+ loc.fac <- w1
+ "manq"<- function(x) {
+ if (any(x=="000")) return(TRUE)
+ return(FALSE)
+ }
+ missingdata <- unlist(lapply(all.util, manq))
+ "enumindiv" <- function (x) {
+ x <- as.character(x)
+ n <- length(x)
+ w1 <- substr(x, 1, 3)
+ w2 <- substr(x, 4, 6)
+ "funloc1" <- function (k) {
+ w0 <- rep(0,length(all.util[[k]]))
+ names(w0) <- all.util[[k]]
+ w0[w1[k]] <- w0[w1[k]]+1
+ w0[w2[k]] <- w0[w2[k]]+1
+ # ce locus n'a pas de données manquantes
+ if (!missingdata[k]) return(w0)
+ # ce locus a des données manquantes mais pas cet individu
+ if (w0["000"]==0) return(w0[names(w0)!="000"])
+ #cet individus a deux données manquantes
+ if (w0["000"]==2) {
+ w0 <- rep(NA, length(w0)-1)
+ return(w0)
+ }
+ # il doit y avoir une seule donnée manquante
+ stop( paste("a1 =",w1[k],"a2 =",w2[k], "Non implemented case"))
+ }
+ w <- as.numeric(unlist(lapply(1:n, funloc1)))
+ return(w)
+ }
+ ind.all <- apply(X,1,enumindiv)
+ ind.all <- data.frame(t(ind.all))
+ names(ind.all) <- all.names
+ nind <- nrow(ind.all)
+ # ind.all contient un tableau individus - alleles codé
+ # ******* pour NA pour les manquants
+ # 010010 pour les hétérozygotes
+ # 000200 pour les homozygotes
+ all.som <- apply(ind.all,2,function(x) sum(na.omit(x)))
+ #all.som contient le nombre d'allèles présents par forme allélique
+ names(all.som) = all.names
+
+ center <- split(all.som, loc.fac)
+ center <- lapply(center, function(x) 2*x/sum(x))
+ center <- unlist(center)
+ names(center) <- all.codes
+ "modifier" <- function (x) {
+ x[is.na(x)]=center[is.na(x)]
+ return(x/2)
+ }
+ ind.all <- t(apply(ind.all, 1, modifier))
+ ind.all <- as.data.frame(ind.all)
+ names(ind.all) <- all.codes
+ attr(ind.all,"col.blocks") <- vec2
+ attr(ind.all,"all.names") <- all.names
+ attr(ind.all,"loc.names") <- loc.names
+ attr(ind.all,"row.w") <- rep(1/nind, nind)
+ attr(ind.all,"col.freq") <- center/2
+ attr(ind.all,"col.num") <- as.factor(rep(loc.names,vec2))
+ return(ind.all)
+}
+
+
diff --git a/R/gearymoran.R b/R/gearymoran.R
new file mode 100644
index 0000000..82d84c1
--- /dev/null
+++ b/R/gearymoran.R
@@ -0,0 +1,28 @@
+"gearymoran" <- function (bilis, X, nrepet = 999,alter = c("greater", "less", "two-sided")) {
+ alter <- match.arg(alter)
+ ## bilis doit être une matrice
+ bilis <- as.matrix(bilis)
+ nobs <- ncol(bilis)
+ # bilis doit être carrée
+ if (nrow(bilis) != nobs) stop ("'bilis' is not squared")
+ # bilis doit être symétrique
+ bilis <- (bilis + t(bilis))/2
+ # bilis doit être à termes positifs (voisinages)
+ if (any(bilis<0)) stop ("term <0 found in 'bilis'")
+ test.names <- names(X)
+ X <- data.matrix(X)
+ if (nrow(X) != nobs) stop ("non convenient dimension")
+ nvar <- ncol(X)
+ res <- .C("gearymoran",
+ param = as.integer(c(nobs,nvar,nrepet)),
+ data = as.double(X),
+ bilis = as.double(bilis),
+ obs = double(nvar),
+ result = double (nrepet*nvar),
+ obstot = double(1),
+ restot = double (nrepet),
+ PACKAGE="ade4"
+ )
+ res <- as.krandtest(obs = res$obs, sim = matrix(res$result, ncol = nvar, byrow = TRUE), names = test.names, alter = alter)
+ return(res)
+}
diff --git a/R/genet.R b/R/genet.R
new file mode 100644
index 0000000..0944769
--- /dev/null
+++ b/R/genet.R
@@ -0,0 +1,375 @@
+"char2genet" <- function(X,pop,complete=FALSE) {
+ if (!inherits(X, "data.frame")) stop ("X is not a data.frame")
+ if (!is.factor(pop)) stop("pop is not a factor")
+ nind <- length(pop)
+ if (nrow(X) != nind) stop ("pop & X have non convenient dimension")
+ # tri des lignes par ordre alphabétique des noms de population
+ # tri par ordre alphabétique des noms de loci
+ X <- X[order(pop),]
+ X <- X[,sort(names(X))]
+ pop <- sort(pop) # comme pop[order(pop)]
+ ####################################################################################
+ "codred" <- function(base, n) {
+ # fonction qui fait des codes de noms ordonnés par ordre
+ # alphabétique de longueur constante le plus simples possibles
+ # base est une chaîne de charactères, n le nombre qu'on veut
+ w <- as.character(1:n)
+ max0 <- max(nchar(w))
+ "fun1" <- function(x) while ( nchar(w[x]) < max0) w[x] <<- paste("0",w[x],sep="")
+ lapply(1:n, fun1)
+ return(paste(base,w,sep=""))
+ }
+ ####################################################################################
+ # Ce qui touche aux populations
+ npop <- nlevels(pop)
+ pop.names <- as.character(levels(pop))
+ pop.codes <- codred("P", npop)
+ names(pop.names) <- pop.codes
+ levels(pop) <- pop.codes
+ ####################################################################################
+ # Ce qui touche aux individus
+ nind <- nrow(X)
+ ind.names <- row.names(X)
+ ind.codes <- codred("", nind)
+ names(ind.names) <- ind.codes
+ ###################################################################################
+ # ce qui touche au loci
+ loc.names <- names(X)
+ nloc <- ncol(X)
+ loc.codes <- codred("L",nloc)
+ names(loc.names) <- loc.codes
+ names(X) <- loc.codes
+ "cha6car" <- function(cha) {
+ # pour compléter les chaînes de caratères par des zéros devant
+ n0 <- nchar(cha)
+ if (n0 == 6) return (cha)
+ if (n0 >6) stop ("More than 6 characters")
+ cha = paste("0",cha,sep="")
+ cha = cha6car(cha)
+ }
+ X <- as.data.frame(apply(X,c(1,2),cha6car))
+
+ # Toutes les chaînes sont de 6 charactères suppose que le codage est complet
+ # ou qu'il ne manque des zéros qu'au début
+ "enumallel" <- function (x) {
+ w <- as.character(x)
+ w1 <- substr(w,1,3)
+ w2 <- substr(w,4,6)
+ w3 <- sort(unique (c(w1,w2)))
+ return(w3)
+ }
+ all.util <- lapply(X,enumallel)
+ # all.util est une liste dont les composantes sont les noms des allèles ordonnés
+ # Correction d'un bug mis en evidence par Amalia
+ # amalia at mail.imsdd.meb.uni-bonn.de
+ # La liste etait automatiquement une matrice quand le nombre d'allele par locus est constant
+ # peut comprendre 000 pour un non typé
+ # on conserve le nombre d'individus typés par locus et par populations
+ "compter" <- function(x) {
+ num0 <- x!="000000"
+ num0 <- split(num0,pop)
+ num0 <- as.numeric(unlist(lapply(num0,sum)))
+ return(num0)
+ }
+ Z <- unlist(apply(X,2, compter))
+ Z <- data.frame(matrix(Z,ncol=nloc))
+ names(Z) <- loc.codes
+ row.names(Z) <- pop.codes
+ # Z est un data.frame populations-locus des effectifs d'individus
+ ind.full <- apply(X,1,function (x) !any(x == "000000"))
+ "polymor" <- function(x) {
+ if (any(x=="000")) return(x[x!="000"])
+ return(x)
+ }
+ "nallel" <- function(x) {
+ l0 <- length(x)
+ if (any(x=="000")) return(l0-1)
+ return(l0)
+ }
+ loc.blocks <- unlist(lapply(all.util, nallel))
+ names(loc.blocks) <- names(all.util)
+ all.names <- unlist(lapply(all.util, polymor))
+ w1 <- rep(loc.codes,loc.blocks)
+ w2 <- unlist(lapply(loc.blocks, function(n) codred(".",n)))
+ all.codes <- paste(w1,w2,sep="")
+ all.names <- paste(rep(loc.names, loc.blocks),all.names,sep=".")
+ names(all.names) <- all.codes
+ w1 <- as.factor(w1)
+ names(w1) <- all.codes
+ loc.fac <- w1
+ "manq"<- function(x) {
+ if (any(x=="000")) return(TRUE)
+ return(FALSE)
+ }
+ missingdata <- unlist(lapply(all.util, manq))
+ "enumindiv" <- function (x) {
+ x <- as.character(x)
+ n <- length(x)
+ w1 <- substr(x, 1, 3)
+ w2 <- substr(x, 4, 6)
+ "funloc1" <- function (k) {
+ w0 <- rep(0,length(all.util[[k]]))
+ names(w0) <- all.util[[k]]
+ w0[w1[k]] <- w0[w1[k]]+1
+ w0[w2[k]] <- w0[w2[k]]+1
+ # ce locus n'a pas de données manquantes
+ if (!missingdata[k]) return(w0)
+ # ce locus a des données manquantes mais pas cet individu
+ if (w0["000"]==0) return(w0[names(w0)!="000"])
+ #cet individus a deux données manquantes
+ if (w0["000"]==2) {
+ w0 <- rep(NA, length(w0)-1)
+ return(w0)
+ }
+ # il doit y avoir une seule donnée manquante
+ stop( paste("a1 =",w1[k],"a2 =",w2[k], "Non implemented case"))
+ }
+ w <- as.numeric(unlist(lapply(1:n, funloc1)))
+ return(w)
+ }
+ ind.all <- apply(X,1,enumindiv)
+ ind.all <- data.frame(t(ind.all))
+ names(ind.all) <- all.codes
+ nallels <- length(all.codes)
+
+ # ind.all contient un tableau individus - alleles codé
+ # ******* pour NA pour les manquants
+ # 010010 pour les hétérozygotes
+ # 000200 pour les homozygotes
+ ind.all <- split(ind.all, pop)
+ "remplacer" <- function (a,b) {
+ if (all(!is.na(a))) return(a)
+ if (all(is.na(a))) return(b)
+ a[is.na(a)] <- b[is.na(a)]
+ return(a)
+ }
+
+ "sommer"<- function (x){
+ apply(x,2,function(x) sum(na.omit(x)))
+ }
+ all.pop <- matrix(unlist(lapply(ind.all,sommer)),nrow = nallels)
+ all.pop = as.data.frame(all.pop)
+ names(all.pop) <- pop.codes
+ row.names(all.pop) <- all.codes
+
+ center <- apply(all.pop,1,sum)
+ center <- split(center, loc.fac)
+ center <- unlist(lapply(center, function(x) x/sum(x)))
+ names(center) <- all.codes
+ "completer" <- function (x) {
+ moy0 <- apply(x,2,mean, na.rm=TRUE)
+ y <- apply(x, 1, function(a) remplacer(a,moy0))
+ return(y/2)
+ }
+ ind.all <- lapply(ind.all, completer)
+ res <- list()
+ pop.all <- unlist(lapply(ind.all,function(x) apply(x,1,mean)))
+ pop.all <- matrix(pop.all, ncol=nallels, byrow=TRUE)
+ pop.all <- data.frame(pop.all)
+ names(pop.all) <- all.codes
+ row.names(pop.all) <- pop.codes
+ # 1) tableau de fréquences alléliques popualations-lignes
+ # allèles-colonnes indispensable pour la classe genet
+ res$tab <- pop.all
+ # 2) marge du précédent calculé sur l'ensemble des individus typés par locus
+ res$center <- center
+ # 3) noms des populations renumérotées P001 ... P999
+ # le vecteur contient les noms d'origine
+ res$pop.names <- pop.names
+ # 4) noms des allèles recodé L01.1, L01.2, ...
+ # le vecteurs contient les noms d'origine.
+ res$all.names <- all.names
+ # 5) le vecteur du nombre d'allèles par loci
+ res$loc.blocks <- loc.blocks
+ # 6) le facteur répartissant les allèles par loci
+ res$loc.fac <- loc.fac
+ # 7) noms des loci renumérotées L01 ... L99
+ # le vecteur contient les noms d'origine
+ res$loc.names <- loc.names
+ # 8) le nombre de gènes qui ont permis les calculs de fréquences
+ res$pop.loc <- Z
+ # 9) le nombre d'occurences de chaque forme allélique dans chaque population
+ # allèles eln lignes, populations en colonnes
+ res$all.pop <- all.pop
+ #######################################################
+ if (complete) {
+ n0 <- length(all.codes) # nrow(ind.all[[1]])
+ ind.all <- unlist(ind.all)
+ ind.all <- matrix(ind.all, ncol=n0, byrow=TRUE)
+ ind.all <- data.frame(ind.all)
+ ind.all <- ind.all[ind.full,]
+ pop.red <- pop[ind.full]
+ names(ind.all) <- all.codes
+ row.names(ind.all) <- ind.codes[ind.full]
+ ind.all <- 2*ind.all
+ # ind.all <- split(ind.all,pop.red)
+ # ind.all <- lapply(ind.all,t)
+ # 10) les typages d'individus complets
+ # ind.all est une liste de matrices allèles-individus
+ # ne contenant que les individus complètement typés
+ # avec le codage 02000 ou 01001
+
+ res$comp <- ind.all
+ res$comp.pop <- pop.red
+ }
+ class(res) <- c("genet", "list")
+ return(res)
+}
+
+
+"count2genet" <- function (PopAllCount) {
+ # PopAllCount est un data.frame qui contient des dénombrements
+ ####################################################################################
+ "codred" <- function(base, n) {
+ # fonction qui fait des codes de noms ordonnés par ordre
+ # alphabétique de longueur constante le plus simples possibles
+ # base est une chaîne de charactères, n le nombre qu'on veut
+ w <- as.character(1:n)
+ max0 <- max(nchar(w))
+ "fun1" <- function(x) while ( nchar(w[x]) < max0) w[x] <<- paste("0",x,sep="")
+ lapply(1:n, fun1)
+ return(paste(base,w,sep=""))
+ }
+
+ if (!inherits(PopAllCount,"data.frame")) stop ("data frame expected")
+ if (!all(apply(PopAllCount,2,function(x) all(x==as.integer(x)))))
+ stop("For integer values only")
+ PopAllCount <- PopAllCount[sort(row.names(PopAllCount)),]
+ PopAllCount <- PopAllCount[,sort(names(PopAllCount))]
+ npop <- nrow(PopAllCount)
+ w1 <- strsplit(names(PopAllCount),"[.]")
+ loc.fac <- as.factor(unlist(lapply(w1, function(x) x[1])))
+ loc.blocks <- as.numeric(table(loc.fac))
+ nloc <- nlevels(loc.fac)
+ loc.names <- as.character(levels(loc.fac))
+ pop.codes <- codred("P", npop)
+ loc.codes <- codred("L",nloc)
+ names(loc.blocks) <- loc.codes
+ pop.names <- row.names(PopAllCount)
+ names(pop.names) <- pop.codes
+
+ w1 <- rep(loc.codes,loc.blocks)
+ w2 <- unlist(lapply(loc.blocks, function(n) codred(".",n)))
+ all.codes <- paste(w1,w2,sep="")
+ all.names <- names(PopAllCount)
+ names(all.names) <- all.codes
+ names(loc.names) <- loc.codes
+ all.pop <- as.data.frame(t(PopAllCount))
+ names(all.pop) <- pop.codes
+ row.names(all.pop) <- all.codes
+
+ center <- apply(all.pop,1,sum)
+ center <- split(center,loc.fac)
+ center <- unlist(lapply(center, function(x) x/sum(x)))
+ names(center) <- all.codes
+
+ PopAllCount <- split(all.pop,loc.fac)
+ "pourcent" <- function(x) {
+ x <- t(x)
+ w <- apply(x,1,sum)
+ w[w==0] <- 1
+ x <- x/w
+ return(x)
+ # retourne un tableau populations-allèles
+ }
+ PopAllCount <- lapply(PopAllCount,pourcent)
+ tab <- data.frame(provi=rep(1,npop))
+ lapply(PopAllCount, function(x) tab <<- cbind.data.frame(tab,x))
+ tab <- tab[,-1]
+ names(tab) <- all.codes
+ row.names(tab) <- pop.codes
+ res <- list()
+ res$tab <- tab
+ res$center <- center
+ res$pop.names <- pop.names
+ res$all.names <- all.names
+ res$loc.blocks <- loc.blocks
+ res$loc.fac <- loc.fac
+ res$loc.names <- loc.names
+ res$pop.loc <- NULL
+ res$all.pop <- all.pop
+ res$complet <- NULL
+ class(res) <- c("genet","list")
+ return(res)
+}
+
+"freq2genet" <- function (PopAllFreq) {
+ # PopAllFreq est un data.frame qui contient des fréquences alléliques
+ ####################################################################################
+ "codred" <- function(base, n) {
+ # fonction qui fait des codes de noms ordonnés par ordre
+ # alphabétique de longueur constante le plus simples possibles
+ # base est une chaîne de charactères, n le nombre qu'on veut
+ w <- as.character(1:n)
+ max0 <- max(nchar(w))
+ nformat <- paste("%0",max0,"i",sep="")
+ "fun1" <- function(x) w[x] <<- sprintf(nformat,x)
+ # "fun1" <- function(x) while ( nchar(w[x]) < max0) w[x] <<- paste("0",x,sep="")
+ lapply(1:n, fun1)
+ return(paste(base,w,sep=""))
+ }
+
+ if (!inherits(PopAllFreq,"data.frame")) stop ("data frame expected")
+ if (!all(apply(PopAllFreq,2,function(x) all(x>=0))))
+ stop("Data >= 0 expected")
+ if (!all(apply(PopAllFreq,2,function(x) all(x<=1))))
+ stop("Data <= 1 expected")
+ PopAllFreq <- PopAllFreq[sort(row.names(PopAllFreq)),]
+ PopAllFreq <- PopAllFreq[,sort(names(PopAllFreq))]
+ npop <- nrow(PopAllFreq)
+ w1 <- strsplit(names(PopAllFreq),"[.]")
+ loc.fac <- as.factor(unlist(lapply(w1, function(x) x[1])))
+ loc.blocks <- as.numeric(table(loc.fac))
+ nloc <- nlevels(loc.fac)
+ loc.names <- as.character(levels(loc.fac))
+ pop.codes <- codred("P", npop)
+ loc.codes <- codred("L",nloc)
+ names(loc.blocks) <- loc.codes
+ pop.names <- row.names(PopAllFreq)
+ names(pop.names) <- pop.codes
+
+ w1 <- rep(loc.codes,loc.blocks)
+ w2 <- unlist(lapply(loc.blocks, function(n) codred(".",n)))
+ all.codes <- paste(w1,w2,sep="")
+ all.names <- names(PopAllFreq)
+ names(all.names) <- all.codes
+ names(loc.names) <- loc.codes
+ all.pop <- as.data.frame(t(PopAllFreq))
+ names(all.pop) <- pop.codes
+ row.names(all.pop) <- all.codes
+
+ center <- apply(all.pop,1,mean)
+ center <- split(center,loc.fac)
+ center <- unlist(lapply(center, function(x) x/sum(x)))
+ names(center) <- all.codes
+
+ PopAllFreq <- split(all.pop,loc.fac)
+ "pourcent" <- function(x) {
+ x <- t(x)
+ w <- apply(x,1,sum)
+ w[w==0] <- 1
+ x <- x/w
+ return(x)
+ # retourne un tableau populations-allèles
+ }
+ PopAllFreq <- lapply(PopAllFreq,pourcent)
+ tab <- data.frame(provi=rep(1,npop))
+ lapply(PopAllFreq, function(x) tab <<- cbind.data.frame(tab,x))
+ tab <- tab[,-1]
+ names(tab) <- all.codes
+ row.names(tab) <- pop.codes
+ res <- list()
+ res$tab <- tab
+ res$center <- center
+ res$pop.names <- pop.names
+ res$all.names <- all.names
+ res$loc.blocks <- loc.blocks
+ res$loc.fac <- loc.fac
+ res$loc.names <- loc.names
+ res$pop.loc <- NULL
+ res$all.pop <- all.pop
+ res$complet <- NULL
+ class(res) <- c("genet","list")
+ return(res)
+}
+
diff --git a/R/gridrowcol.R b/R/gridrowcol.R
new file mode 100644
index 0000000..c16360d
--- /dev/null
+++ b/R/gridrowcol.R
@@ -0,0 +1,107 @@
+"gridrowcol" <- function (nrow,ncol, cell.names=NULL) {
+ # Résultats utilisés dans le thèse de Cornillon p. 15
+ # corrections de 2 coquilles bas de p. 15
+ nrow <- as.integer(nrow)
+ if (nrow < 1) stop("nrow nonpositive")
+ ncol <- as.integer(ncol)
+ if (ncol < 1) stop("ncol nonpositive")
+ ncell <- nrow*ncol
+ xy<-matrix(0,nrow,ncol)
+ xy <- cbind(as.numeric(t(col(xy))),as.numeric(t(row(xy))))
+ if (!is.null(cell.names)) {
+ if (length(cell.names)!=nrow*ncol) cell.names <- NULL
+ }
+ if (is.null (cell.names)) {
+ cell.names <- paste("R",xy[,2],"C",xy[,1],sep="")
+ }
+
+ xy <- data.frame(xy)
+ names(xy)=c("x","y")
+ row.names(xy) = cell.names
+ xy$"y" <- nrow+1-xy$"y"
+ res<- list(xy=xy)
+ area <- rep(row.names(xy),rep(4,ncell))
+ area <- as.factor(area)
+ w <- cbind(xy$"x"-0.5,xy$"x"-0.5,xy$"x"+0.5,xy$"x"+0.5)
+ w <- as.numeric(t(w))
+ area <- cbind.data.frame(area,w)
+ w <- cbind(xy$"y"-0.5,xy$"y"+0.5,xy$"y"+0.5,xy$"y"-0.5)
+ w <- as.numeric(t(w))
+ area <- cbind.data.frame(area,w)
+ names(area) <- c("cell","x","y")
+ res$area <- area
+ d0 <- as.matrix(dist.quant(xy,1))
+ d0 <- 1*(d0<1.2)
+ diag(d0) <-0
+ pvoisi <- unlist(apply(d0,1,sum))
+ naret <- sum(pvoisi)
+ pvoisi <- pvoisi/naret
+ d0 <- neig(mat01=d0)
+ res$neig <- d0
+
+ xy$"y" <- nrow+1-xy$"y"
+ # numero de colonne en x et numero de ligne en y
+ "glin" <- function (n) {
+ n<-n
+ "vecpro" <- function(k) {
+ x <- cos(k*pi*((1:n)-0.5)/n)
+ x <- x/sqrt(sum(x*x))
+ # print(x)
+ }
+ w <- unlist(lapply(0:(n-1),vecpro))
+ w <- matrix(w,n)
+ }
+
+ orthobasis <- glin(nrow)%x%glin(ncol)
+
+ # ce paragrahe calcule les valeurs de xtEx pour les vecteurs de orthobasis
+ # et permet de vérifier qu'il s'agit bien des vecteurs propres
+ # et que les valeurs propres sont bien celles qui sont calculées
+ # d0=neig2mat(d0)
+ # d1=apply(d0,1,sum)
+ # d0=diag(d1)-d0
+ # fun2 <- function(x) {
+ # w=d0*x
+ # return(sum(t(w)*x))
+ # }
+ # lambda <- unlist(apply(orthobasis,2,fun2))
+ # print(lambda)
+ # res$lambda <- lambda
+
+ pirow <- pi/nrow
+ picol<- pi/ncol
+ salpha <- (sin((0:(nrow-1))*pirow/2))^2
+ sbeta <- (sin((0:(ncol-1))*picol/2))^2
+ z <- rep(sbeta,nrow)+rep(salpha,rep(ncol,nrow))
+ z <- 4*z/nrow/ncol
+ w <- order(z)[-1]
+ z <- z[w]
+ orthobasis <- sqrt(ncell)*orthobasis[,w]
+ orthobasis <- data.frame(orthobasis)
+ val <- unlist(lapply(orthobasis,function(x) sum(x*x*pvoisi)))
+ val <- val - z*ncell*ncell/naret
+ ord <- rev(order(val))
+ orthobasis <- orthobasis[,ord]
+ val <- val[ord]
+ names(orthobasis) = paste("S",1:(ncell-1),sep="")
+ row.names(orthobasis) = row.names(res$xy)
+ # Les valeurs sont calculées à partir des valeurs propres de l'opérateur de lissage
+ # Ce sont des valeurs de l'indice de Moran xtFx/v(x) v en 1/n
+ # print(unlist(lapply(orthobasis,function(x) sum(x*x*pvoisi))))
+ attr(orthobasis,"values") <- val
+ attr(orthobasis,"weights") <- rep(1/ncell,ncell)
+ attr(orthobasis,"call") <- match.call()
+ attr(orthobasis,"class") <- c("orthobasis","data.frame")
+ res$orthobasis <- orthobasis
+ # ces ordres vérifient qu'on a bien trouvé les indices de Moran
+ # d0 = neig2mat(d0)
+ # d0 = d0/sum(d0) # Moran type W
+ # moran <- unlist(lapply(orthobasis,function(x) sum(t(d0*x)*x)))
+ # print(moran)
+ # plot(moran,attr(orthobasis,"values"))
+ # abline(lm(attr(orthobasis,"values")~moran))
+ # print(summary(lm(attr(orthobasis,"values")~moran)))
+ return(res)
+}
+
+
diff --git a/R/inertia.dudi.R b/R/inertia.dudi.R
new file mode 100644
index 0000000..c79010f
--- /dev/null
+++ b/R/inertia.dudi.R
@@ -0,0 +1,161 @@
+"inertia" <- function (x, ...) UseMethod("inertia")
+
+"inertia.dudi" <- function (x, row.inertia = FALSE, col.inertia = FALSE, ...) {
+ if (!inherits(x, "dudi"))
+ stop("Object of class 'dudi' expected")
+
+ nf <- x$nf
+ inertia <- x$eig
+ cum <- cumsum(inertia)
+ ratio <- cum/sum(inertia) * 100
+ TOT <- cbind.data.frame(inertia, cum, ratio)
+ rownames(TOT) <- paste0("Ax", 1:length(ratio))
+ names(TOT)[3] <- "cum(%)"
+ listing <- list(TOT = TOT)
+ if (row.inertia) {
+ w <- x$tab * sqrt(x$lw)
+ w <- sweep(w, 2, sqrt(x$cw), "*")
+ w <- w * w
+ listing$row.contrib <- apply(w, 1, sum)/sum(w) * 100
+ w <- x$li * x$li * x$lw
+ listing$row.abs <- sweep(w, 2, x$eig[1:nf], "/") * 100
+ names(listing$row.abs) <- paste0(names(listing$row.abs), "(%)")
+
+ w <- x$tab
+ w <- sweep(w, 2, sqrt(x$cw), "*")
+ d2 <- apply(w * w, 1, sum)
+ w <- x$li * x$li
+ w <- sweep(w, 1, d2, "/")
+ w <- w * sign(x$li)
+ names(w) <- names(x$li)
+ listing$row.rel <- data.frame(w) * 100
+
+ w <- x$li * x$li
+ w <- sweep(w, 1, d2, "/")
+ w <- data.frame(t(apply(w, 1, cumsum)))
+ names(w) <- names(x$li)
+ remain <- 1 - w[, ncol(w)]
+ listing$row.cum <- cbind.data.frame(w, remain) * 100
+ names(listing$row.cum) <- paste0("Axis", c(1, if(nf > 1) paste(1,2:nf, sep =":") else NULL, paste0(nf+ 1, ":", length(ratio))))
+ }
+ if (col.inertia) {
+ w <- x$tab * sqrt(x$lw)
+ w <- sweep(w, 2, sqrt(x$cw), "*")
+ w <- w * w
+ listing$col.contrib <- apply(w, 2, sum)/sum(w) * 100
+ w <- x$co * x$co * x$cw
+ listing$col.abs <- sweep(w, 2, x$eig[1:nf], "/") * 100
+ names(listing$col.abs) <- paste0("Axis", 1:nf,"(%)")
+
+ w <- x$tab
+ w <- sweep(w, 1, sqrt(x$lw), "*")
+ d2 <- apply(w * w, 2, sum)
+ w <- x$co * x$co
+ w <- sweep(w, 1, d2, "/")
+ w <- w * sign(x$co)
+ names(w) <- paste0("Axis", 1:ncol(w))
+ listing$col.rel <- data.frame(w) * 100
+
+
+ w <- x$co * x$co
+ w <- sweep(w, 1, d2, "/")
+ w <- data.frame(t(apply(w, 1, cumsum)))
+ names(w) <- names(x$co)
+ remain <- 1 - w[, ncol(w)]
+ listing$col.cum <- cbind.data.frame(w, remain) * 100
+ names(listing$col.cum) <- paste0("Axis", c(1, if(nf > 1) paste(1,2:nf, sep =":") else NULL, paste0(nf+ 1, ":", length(ratio))))
+ }
+
+ listing$call <- match.call()
+ class(listing) <- c("inertia", class(listing))
+ return(listing)
+}
+
+print.inertia <- function(x, ...){
+ cat("Inertia information:")
+ cat("\nCall: ")
+ print(x$call)
+ cat("\nDecomposition of total inertia:\n")
+ print(format(x$TOT, digits = 4, trim = TRUE, width = 7), quote = FALSE)
+
+ if(!is.null(x$row.abs)){
+ cat("\nRow contributions (%):\n")
+ print(format(x$row.contrib, digits = 4, trim = TRUE, width = 7), quote = FALSE)
+
+ cat("\nRow absolute contributions (%):\n")
+ print(format(x$row.abs, digits = 4, trim = TRUE, width = 7), quote = FALSE)
+
+ cat("\nSigned row relative contributions:\n")
+ print(format(x$row.rel, digits = 4, trim = TRUE, width = 7), quote = FALSE)
+
+ cat("\nCumulative sum of row relative contributions (%):\n")
+ print(format(x$row.cum, digits = 4, trim = TRUE, width = 7), quote = FALSE)
+
+ }
+
+ if(!is.null(x$col.abs)){
+ cat("\nColumn contributions (%):\n")
+ print(format(x$col.contrib, digits = 4, trim = TRUE, width = 7), quote = FALSE)
+
+ cat("\nColumn absolute contributions (%):\n")
+ print(format(x$col.abs, digits = 4, trim = TRUE, width = 7), quote = FALSE)
+
+ cat("\nSigned column relative contributions:\n")
+ print(format(x$col.rel, digits = 4, trim = TRUE, width = 7), quote = FALSE)
+
+ cat("\nCumulative sum of column relative contributions (%):\n")
+ print(format(x$col.cum, digits = 4, trim = TRUE, width = 7), quote = FALSE)
+
+ }
+}
+
+
+summary.inertia <- function(object, subset = 5, ...){
+ cat("\nTotal inertia: ")
+ cat(signif(sum(object$TOT$inertia), 4))
+ cat("\n")
+ l0 <- nrow(object$TOT)
+
+ cat("\nProjected inertia (%):\n")
+ vec <- (object$TOT$inertia / sum(object$TOT$inertia) * 100)[1:(min(subset, l0))]
+ names(vec) <- paste("Ax",1:length(vec), sep = "")
+ print(format(vec, digits = 4, trim = TRUE, width = 7), quote = FALSE)
+
+ if (l0 > 5) {
+ cat("\n")
+ cat(paste("(Only ", subset, " dimensions (out of ",l0, ") are shown)\n", sep="",collapse=""))
+ }
+ cat("\n")
+
+ if(!is.null(object$row.abs)){
+ nsub <- min(subset, length(object$row.contrib))
+
+ cat("\nRow contributions (%):\n")
+ vec <- sort(object$row.contrib, decreasing = TRUE)[1:nsub]
+
+ print(format(vec, digits = 4, trim = TRUE, width = 7), quote = FALSE)
+
+ cat("\nRow absolute contributions (%):\n")
+ idx <- apply(object$row.abs, 2, order, decreasing = TRUE)
+ idx <- unique(as.vector(idx[1:nsub,]))
+ print(format(object$row.abs[idx,], digits = 4, trim = TRUE, width = 7), quote = FALSE)
+ cat("\n")
+ }
+
+ if(!is.null(object$col.abs)){
+ nsub <- min(subset, length(object$col.contrib))
+
+ cat("\nColumn contributions (%):\n")
+ vec <- sort(object$col.contrib, decreasing = TRUE)[1:nsub]
+
+ print(format(vec, digits = 4, trim = TRUE, width = 7), quote = FALSE)
+
+ cat("\nColumn absolute contributions (%):\n")
+ idx <- apply(object$col.abs, 2, order, decreasing = TRUE)
+ idx <- unique(as.vector(idx[1:nsub,]))
+ print(format(object$col.abs[idx,], digits = 4, trim = TRUE, width = 7), quote = FALSE)
+
+ }
+
+
+}
\ No newline at end of file
diff --git a/R/is.euclid.R b/R/is.euclid.R
new file mode 100644
index 0000000..0f805c6
--- /dev/null
+++ b/R/is.euclid.R
@@ -0,0 +1,31 @@
+"is.euclid" <- function (distmat, plot = FALSE, print = FALSE, tol = 1e-07) {
+ if (!inherits(distmat, "dist"))
+ stop("Object of class 'dist' expected")
+ if(any(distmat<tol))
+ warning("Zero distance(s)")
+ distmat <- as.matrix(distmat)
+ n <- ncol(distmat)
+ delta <- -0.5 * bicenter.wt(distmat * distmat)
+ lambda <- eigen(delta, symmetric = TRUE, only.values = TRUE)$values
+ w0 <- lambda[n]/lambda[1]
+ if (plot)
+ barplot(lambda)
+ if (print)
+ print(lambda)
+ return((w0 > -tol))
+}
+
+"summary.dist" <- function (object, ...) {
+ if (!inherits(object, "dist"))
+ stop("For use on the class 'dist'")
+ cat("Class: ")
+ cat(class(object), "\n")
+ cat("Distance matrix by lower triangle : d21, d22, ..., d2n, d32, ...\n")
+ cat("Size:", attr(object, "Size"), "\n")
+ cat("Labels:", attr(object, "Labels"), "\n")
+ cat("call: ")
+ print(attr(object, "call"))
+ cat("method:", attr(object, "method"), "\n")
+ cat("Euclidean matrix (Gower 1966):", is.euclid(object), "\n")
+}
+
diff --git a/R/kdist.R b/R/kdist.R
new file mode 100644
index 0000000..98bb714
--- /dev/null
+++ b/R/kdist.R
@@ -0,0 +1,269 @@
+# kdist # création jeudi, avril 3, 2003 at 13:57
+# as.data.frame.kdist # création jeudi, avril 3, 2003 at 13:57
+# print.kdist # création jeudi, avril 3, 2003 at 13:57
+# [.kdist # création jeudi, avril 3, 2003 at 13:57
+# c.kdist # création jeudi, avril 3, 2003 at 13:57
+#################### kdist #################################
+"kdist" <- function (..., epsi = 1e-07, upper=FALSE) {
+ is.dist <- function(x) {
+ if (!inherits(x,"dist")) return (FALSE)
+ else return (TRUE)
+ }
+ is.matrix.dist <- function(m) {
+ m <- as.matrix(m)
+ n <- ncol(m) ; p <- nrow(m)
+ if (any(is.na(m))) return ("NA values not allowed in m")
+ if (n != p) return ("Square matrix expected")
+ if (sum(diag(m)^2) != 0) return ("0 in diagonal expected")
+ if (min(m) < 0) return ("non negative value expected")
+ if (sum((t(m) - m)^2) != 0) return ("Symetric matrice expected")
+ return (NULL)
+ }
+
+ triinftodist <- function(x) {
+ n0 <- length(x)
+ n <- sqrt(1 + 8 * n0)
+ n <- (1 + n)/2
+ a <- matrix(0, ncol = n, nrow = n)
+ a[row(a) > col(a)] <- x
+ a <- a+t(a)
+ return(a)
+ }
+ trisuptodist <- function(x) {
+ n0 <- length(x)
+ n <- sqrt(1 + 8 * n0)
+ n <- (1 + n)/2
+ a <- matrix(0, ncol = n, nrow = n)
+ a[row(a) < col(a)] <- x
+ a <- a+t(a)
+ return(a)
+ }
+ vecttovect <- function(x,upper) {
+ attributes(x) <- NULL
+ if (upper) {
+ m <- trisuptodist(x)
+ return(m[row(m) > col(m)])
+ } else {
+ return (x)
+ }
+ }
+
+ as.kdist.dist <- function(list.obj) {
+ # une liste d'objets de la classe dist
+ f1 <- function(x) {
+ attributes(x) <- NULL
+ return(as.vector(x))
+ }
+ n <- length(list.obj)
+ res <- lapply(list.obj,is.dist)
+ size <- unlist(lapply(list.obj,function(x) attr(x,"Size")))
+ if (any(size!=size[1])) stop ("Non equal dimension")
+ size <- unique(size)
+ retval <- lapply(list.obj, f1)
+ res <- unlist(lapply(list.obj,is.euclid ,tol=epsi))
+ if (is.null(names(retval))) {
+ names(retval) <- as.character(1:n)
+ }
+ attr(retval, "size") <- size
+ attr(retval, "labels") <- attr(list.obj[[1]],"Labels")
+ if(is.null(attr(retval, "labels"))) attr(retval, "labels") <- as.character(1:size)
+ attr(retval, "euclid") <- res
+ return(retval)
+ }
+
+ as.kdist.matrix <- function(list.obj) {
+ # une liste d'objets de la classe matrix
+ n <- length(list.obj)
+ res <- lapply(list.obj,is.matrix.dist)
+ for (i in 1:n) {
+ if (!is.null(res[[i]]))
+ stop (paste ("object",i,"(",res[[i]],")"))
+ }
+ size <- unlist(lapply(list.obj,ncol))
+ if (any(size!=size[1])) stop ("Non equal dimension")
+ list.obj =lapply(list.obj,as.dist)
+ return (as.kdist.dist(list.obj))
+ }
+
+ as.kdist.vector <- function(list.obj,upper=upper) {
+ n <- length(list.obj)
+ w <- unlist(lapply(list.obj,length))
+ if (any(w!=w[1])) stop ("Non equal length")
+ w <- unique(w)
+ size <- 0.5*(1+sqrt(1+8*w))
+ if (size!=as.integer(size)) stop ("Non convenient dimension")
+ retval <- lapply(list.obj, vecttovect, upper=upper)
+ attr(retval, "size") <- size
+ attr(retval, "labels") <- as.character(1:size)
+ euclid <- logical(n)
+ for (i in 1:n) {
+ euclid[i] <- is.euclid(as.dist(triinftodist(retval[[i]])),tol = epsi)
+ }
+ if (is.null(names(retval))) {
+ names(retval) <- as.character(1:length(list.obj))
+ }
+ attr(retval, "euclid") <- euclid
+ return(retval)
+ }
+
+ list.obj <- list(...)
+ compo.names <- as.character(substitute(list(...)))[-1]
+ for (j in 1:length(list.obj)) {
+ X <- list.obj[[j]]
+ if (is.data.frame(X)) {
+ init.names <- names(X)
+ X <- as.matrix(X)
+ X <- split(X,col(X))
+ } else if (is.list(X)) {
+ init.names <- names(X)
+ } else {
+ X <- list(X)
+ init.names <- compo.names[j]
+ }
+ if (all(unlist(lapply(X, is.dist))))
+ list.obj[[j]] <- as.kdist.dist(X)
+ else if (all(unlist(lapply(X, is.matrix))))
+ list.obj[[j]] <- as.kdist.matrix(X)
+ else if (all(unlist(lapply(X, is.vector))))
+ list.obj[[j]] <- as.kdist.vector(X,upper=upper)
+ else stop("Non convenient data")
+ if (length(list.obj[[j]])==length(init.names) )
+ names(list.obj[[j]]) <- init.names
+ names(list.obj[[j]]) <- make.names(names(list.obj[[j]]))
+ }
+ n <- length(list.obj)
+ size <- attr(list.obj[[1]],"size")
+ compo.eff <- unlist(lapply(list.obj,length))
+ dist.names <- unlist(lapply(list.obj,names))
+ if (any(unlist(lapply(list.obj,function(x) attr(x,"size")))!=size))
+ stop ("arguments imply differing size")
+ euclid <- unlist(lapply(list.obj,function(x) attr(x,"euclid")))
+ labels <- attr(list.obj[[1]],"labels")
+ retval <- list(NULL)
+ k <- 0
+ for (i in 1:n) {
+ lab <- attr(list.obj[[i]],"labels")
+ if( any(lab!=labels) ) stop ("arguments imply differing labels")
+ w <- list.obj[[i]]
+ attributes(w) <- NULL
+ for (j in 1:compo.eff[[i]]) {
+ k <- k+1
+ retval[[k]] <- w[[j]]
+ }
+ }
+ names(retval) <- dist.names
+ attr(retval,"size") <- size
+ attr(retval, "labels") <- labels
+ attr(retval, "euclid") <- euclid
+ attr(retval, "call") <- match.call()
+ class(retval) <- "kdist"
+ return(retval)
+}
+
+############# as.data.frame.kdist ######################
+"as.data.frame.kdist" <- function(x, row.names=NULL, optional=FALSE,...) {
+ if (!inherits (x, "kdist")) stop ("object 'kdist' expected")
+ res <- as.data.frame(unclass(x))
+ nind <- attr(x,"size")
+ w <- matrix(0,nind,nind)
+ numrow <- row(w)[row(w)>col(w)]
+ numcol <- col(w)[row(w)>col(w)]
+ numrow <- attr(x, "labels")[numrow]
+ numcol <- attr(x, "labels")[numcol]
+ cha <- paste(numrow,numcol,sep="-")
+ row.names(res) <- cha
+ return(res)
+}
+
+########## print.kdist #################################
+"print.kdist" <- function(x,print.matrix.dist=FALSE,...)
+{
+ cat("List of distances matrices\n")
+ cat("call: ")
+ print(attr(x,"call"))
+ cat(paste("class:",class(x)))
+ n <- length(x)
+ cat(paste("\nnumber of distances:",n))
+ npoints <- attr(x,"size")
+ cat(paste("\nsize:", npoints))
+ cat("\nlabels:\n")
+ labels <- attr(x,"labels")
+ print(labels)
+ euclid <- attr(x,"euclid")
+ print1 <- function (x,size,labels,...)
+ # modif error sur CRAN DAILY 18/11:2004
+ # from print.dist de stats
+ {
+ df <- matrix(0, size, size)
+ df[row(df) > col(df)] <- x
+ df <- format(df)
+ df[row(df) <= col(df)] <- ""
+ dimnames(df) <- list(labels, labels)
+ print(df, quote = FALSE, ...)
+ }
+ for (i in 1:n) {
+ w <- x[[i]]
+ cat(names(x)[i])
+ if (euclid[i]) cat(": euclidean distance\n")
+ else cat(": non euclidean distance\n")
+ if (print.matrix.dist) {
+ print1(w,npoints,labels,...)
+ cat("\n")
+ }
+ }
+}
+
+######################## [.kdist #######################
+"[.kdist" <- function(object,selection) {
+ retval <- unclass(object)[selection]
+ n <- attr(object,"size")
+ labels <- attr(object,"labels")
+ euclid <- attr(object,"euclid")
+ euclid <- euclid[selection]
+ attr(retval, "size") <- n
+ attr(retval, "labels") <- labels
+ attr(retval, "euclid") <- euclid
+ attr(retval, "call") <- match.call()
+ class(retval) <- "kdist"
+ return(retval)
+}
+######################## c.kdist ###########################
+c.kdist <- function(...) {
+ x <- list(...)
+ n <- length(x)
+ compo.names <- as.character(substitute(list(...)))[-1]
+ compo.eff <- unlist(lapply(x,length))
+ dist.names <- unlist(lapply(x,names))
+ rep.names <- paste(rep(compo.names,compo.eff),dist.names,sep=".")
+
+ if (any(lapply(x,class)!="kdist"))
+ stop ("arguments imply object without 'kdist' class")
+ size <- attr(x[[1]],"size")
+ if (any(unlist(lapply(x,function(x) attr(x,"size")))!=size))
+ stop ("arguments imply differing size")
+ euclid <- unlist(lapply(x,function(x) attr(x,"euclid")))
+ labels <- attr(x[[1]],"labels")
+ if (length(unique(dist.names))!=length(dist.names))
+ dist.names <- rep.names
+ names(euclid) <- dist.names
+ retval <- list(NULL)
+ k <- 0
+ for (i in 1:n) {
+ lab <- attr(x[[i]],"labels")
+ if( any(lab!=labels) ) stop ("arguments imply differing labels")
+ w <- x[[i]]
+ attributes(w) <- NULL
+ for (j in 1:compo.eff[[i]]) {
+ k <- k+1
+ retval[[k]] <- w[[j]]
+ }
+ }
+ attr(retval,"names") <- dist.names
+ attr(retval,"size") <- size
+ attr(retval, "labels") <- labels
+ attr(retval, "euclid") <- euclid
+ attr(retval, "call") <- match.call()
+ class(retval) <- "kdist"
+ return(retval)
+}
+
diff --git a/R/kdist2ktab.R b/R/kdist2ktab.R
new file mode 100644
index 0000000..7b283c8
--- /dev/null
+++ b/R/kdist2ktab.R
@@ -0,0 +1,47 @@
+"kdist2ktab" <- function (kd, scale = TRUE, tol=1e-07) {
+ if (!inherits(kd,"kdist")) stop ("objet 'kdist' expected")
+ if (!all(attr(kd,"euclid"))) stop ("Euclidean distances expected")
+ ndist <- length(kd)
+ nind <- attributes(kd)$size
+ distnames <- attributes(kd)$names
+ if(is.null(distnames)) distnames <- paste("D", 1:ndist, sep = "")
+ rnames <-attributes(kd)$label
+ if(is.null(rnames)) rnames <- as.character(1:nind)
+
+ "representationeuclidienne" <- function (x) {
+ # x est un vecteur demi-matrice du kdist
+ d <- matrix(0,nind,nind)
+ d[col(d)<row(d)] <- x
+ d <- d+t(d)
+ d <- (-0.5)*bicenter.wt(d*d)
+ # d est une matrice de produits scalaires
+ eig <- eigen(d, symmetric = TRUE)
+ ncomp <- sum(eig$values > (eig$values[1] * tol))
+ d <- eig$vectors[, 1:ncomp]
+ variances <- eig$values[1:ncomp]
+ d <- t(apply(d, 1, "*", sqrt(variances)))
+ # d est une représentation euclidienne
+ if (scale) {
+ inertot <- sum(variances)
+ d <- d/sqrt(inertot)
+ d = d*sqrt(nrow(d))
+ }
+ d <- data.frame(d)
+ row.names(d) <- rnames
+ names(d) <- paste("C", 1:ncomp, sep = "")
+ return(d)
+ }
+ res <- lapply(kd, representationeuclidienne)
+ names (res) <- distnames
+ for (k in 1:ndist) {
+ cha <- distnames[k]
+ ncomp <- ncol(res[[k]])
+ names(res[[k]]) <- paste(substring (cha,1,4), 1:ncomp,sep="")
+ }
+ w.row <- rep(1,nind)/nind
+ w.col <- lapply(res, function(x) rep(1, ncol(x)))
+ res <- ktab.list.df (res, w.row=w.row,w.col=w.col )
+ return(res)
+
+}
+
diff --git a/R/kdisteuclid.R b/R/kdisteuclid.R
new file mode 100644
index 0000000..2fc340e
--- /dev/null
+++ b/R/kdisteuclid.R
@@ -0,0 +1,64 @@
+kdisteuclid <- function(obj,method=c("lingoes","cailliez","quasi")) {
+
+ if (is.null(class(obj))) stop ("Object of class 'kdist' expected")
+ if (class(obj)!="kdist") stop ("Object of class 'kdist' expected")
+
+ choice <- match.arg(method)
+
+ lingo.1 <- function(x,size) {
+ mat <- matrix(0, size, size)
+ mat[row(mat) > col(mat)] <- x
+ mat <- mat + t(mat)
+ delta <- -0.5 * bicenter.wt(mat*mat)
+ lambda <- eigen(delta, symmetric = TRUE, only.values = TRUE)$values
+ lder <- lambda[ncol(mat)]
+ mat <- sqrt(mat * mat + 2 * abs(lder))
+ mat <- unclass(mat[row(mat) > col(mat)])
+ print(paste("Lingoes constant =", abs(lder)))
+ return(mat)
+ }
+
+ quasi.1 <- function(x,size) {
+ mat <- matrix(0, size, size)
+ mat[row(mat) > col(mat)] <- x
+ mat <- mat + t(mat)
+ delta <- -0.5 * bicenter.wt(mat*mat)
+ eig <- eigen(delta, symmetric = TRUE)
+ ncompo <- sum(eig$value>0)
+ tabnew <- t( t(eig$vectors[,1:ncompo])*sqrt(eig$values[1:ncompo]) )
+ mat <- unclass(dist.quant(tabnew,1))
+ print(paste("First ev =", eig$value[1], "Last ev =", eig$value[size]))
+ return(mat)
+ }
+
+ cailliez.1 <- function(x,size) {
+ mat <- matrix(0, size, size)
+ mat[row(mat) > col(mat)] <- x
+ mat <- mat + t(mat)
+ m1 <- matrix(0,size,size)
+ m1 <- rbind(m1,-diag(size))
+ m2 <- -bicenter.wt(mat*mat)
+ m2 <- rbind(m2, 2*bicenter.wt(mat))
+ m1 <- cbind(m1,m2)
+ lambda <- eigen(m1,only.values = TRUE)$values
+ c <- max(Re(lambda)[Im(lambda)<1e-08])
+ print(paste("Cailliez constant =", c))
+ return(x+c)
+ }
+
+ n <- attr(obj,"size")
+ ndist <- length(obj)
+ euclid <- attr(obj,"euclid")
+ for (i in 1:ndist) {
+ if (!euclid[i]) {
+ if (choice=="lingoes") obj[[i]] <- lingo.1(obj[[i]],n)
+ else if (choice=="cailliez") obj[[i]] <- cailliez.1(obj[[i]],n)
+ else if (choice=="quasi") obj[[i]] <- quasi.1(obj[[i]],n)
+ else (stop ("unknown method"))
+ }
+ }
+ attr(obj, "euclid") <- rep(TRUE, ndist)
+ attr(obj, "call") <- match.call()
+ return(obj)
+}
+
diff --git a/R/kplot.R b/R/kplot.R
new file mode 100644
index 0000000..8c1c129
--- /dev/null
+++ b/R/kplot.R
@@ -0,0 +1,3 @@
+"kplot" <- function (object, ...) {
+ UseMethod("kplot")
+}
diff --git a/R/kplot.foucart.R b/R/kplot.foucart.R
new file mode 100644
index 0000000..2eb863d
--- /dev/null
+++ b/R/kplot.foucart.R
@@ -0,0 +1,28 @@
+"kplot.foucart" <- function (object, xax = 1, yax = 2, mfrow = NULL, which.tab = 1:length(object$blo),
+ clab.r = 1, clab.c = 1.25, csub = 2, possub = "bottomright", ...)
+{
+ if (!inherits(object, "foucart"))
+ stop("Object of type 'foucart' expected")
+ opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
+ on.exit(par(opar))
+ if (is.null(mfrow))
+ mfrow <- n2mfrow(length(which.tab))
+ par(mfrow = mfrow)
+ if (length(which.tab) > prod(mfrow))
+ par(ask = TRUE)
+ coolig <- object$Tli[, c(xax, yax)]
+ coocol <- object$Tco[, c(xax, yax)]
+ names(coocol) <- names(coolig)
+ cootot <- rbind.data.frame(coocol, coolig)
+ if (clab.r > 0)
+ cpoi <- 0
+ else cpoi <- 2
+ for (ianal in which.tab) {
+ coolig <- object$Tli[object$TL[, 1] == levels(object$TL[,1])[ianal], c(xax, yax)]
+ coocol <- object$Tco[object$TC[, 1] == levels(object$TC[,1])[ianal], c(xax, yax)]
+ s.label(cootot, clabel = 0, cpoint = 0, sub = object$tab.names[ianal],
+ csub = csub, possub = possub)
+ s.label(coolig, clabel = clab.r, cpoint = cpoi, add.plot = TRUE)
+ s.label(coocol, clabel = clab.c, add.plot = TRUE)
+ }
+}
diff --git a/R/kplot.mcoa.R b/R/kplot.mcoa.R
new file mode 100644
index 0000000..0a103c2
--- /dev/null
+++ b/R/kplot.mcoa.R
@@ -0,0 +1,61 @@
+"kplot.mcoa" <- function (object, xax = 1, yax = 2, which.tab = 1:nrow(object$cov2),
+ mfrow = NULL, option = c("points", "axis", "columns"), clab = 1,
+ cpoint = 2, csub = 2, possub = "bottomright", ...)
+{
+ if (!inherits(object, "mcoa"))
+ stop("Object of type 'mcoa' expected")
+ opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
+ on.exit(par(opar))
+ option <- option[1]
+ if (option == "points") {
+ if (is.null(mfrow))
+ mfrow <- n2mfrow(length(which.tab) + 1)
+ par(mfrow = mfrow)
+ if (length(which.tab) > prod(mfrow) - 1)
+ par(ask = TRUE)
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ coo1 <- object$SynVar[, c(xax, yax)]
+ cootot <- object$Tl1[, c(xax, yax)]
+ names(cootot) <- names(coo1)
+ coofull <- coo1
+ for (i in which.tab) coofull <- rbind.data.frame(coofull,
+ cootot[object$TL[, 1] == levels(object$TL[,1])[i], ])
+ s.label(coo1, clabel = clab, sub = "Reference", possub = "bottomright",
+ csub = csub)
+ for (ianal in which.tab) {
+ scatterutil.base(coofull, 1, 2, xlim = NULL, ylim = NULL,
+ grid = TRUE, addaxes = TRUE, cgrid = 1, include.origin = TRUE,
+ origin = c(0, 0), sub = row.names(object$cov2)[ianal],
+ csub = csub, possub = possub, pixmap = NULL,
+ contour = NULL, area = NULL, add.plot = FALSE)
+ coo2 <- cootot[object$TL[, 1] == levels(object$TL[,1])[ianal], 1:2]
+ s.match(coo1, coo2, clabel = 0, add.plot = TRUE)
+ s.label(coo1, clabel = 0, cpoint = cpoint, add.plot = TRUE)
+ }
+ return(invisible())
+ }
+ if (is.null(mfrow))
+ mfrow <- n2mfrow(length(which.tab))
+ par(mfrow = mfrow)
+ if (option == "axis") {
+ if (length(which.tab) > prod(mfrow))
+ par(ask = TRUE)
+ for (ianal in which.tab) {
+ coo2 <- object$Tax[object$T4[, 1] == levels(object$T4[,1])[ianal], c(xax, yax)]
+ row.names(coo2) <- as.character(1:4)
+ s.corcircle(coo2, clabel = clab, sub = row.names(object$cov2)[ianal],
+ csub = csub, possub = possub)
+ }
+ return(invisible())
+ }
+ if (option == "columns") {
+ if (length(which.tab) > prod(mfrow))
+ par(ask = TRUE)
+ for (ianal in which.tab) {
+ coo2 <- object$Tco[object$TC[, 1] == levels(object$TC[,1])[ianal], c(xax, yax)]
+ s.arrow(coo2, clabel = clab, sub = row.names(object$cov2)[ianal],
+ csub = csub, possub = possub)
+ }
+ return(invisible())
+ }
+}
diff --git a/R/kplot.mfa.R b/R/kplot.mfa.R
new file mode 100644
index 0000000..8bbd27e
--- /dev/null
+++ b/R/kplot.mfa.R
@@ -0,0 +1,39 @@
+"kplot.mfa" <- function (object, xax = 1, yax = 2, mfrow = NULL, which.tab = 1:length(object$blo),
+ row.names = FALSE, col.names = TRUE, traject = FALSE, permute.row.col = FALSE,
+ clab = 1, csub = 2, possub = "bottomright", ...)
+{
+ if (!inherits(object, "mfa"))
+ stop("Object of type 'mfa' expected")
+ opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
+ on.exit(par(opar))
+ if (is.null(mfrow))
+ mfrow <- n2mfrow(length(which.tab))
+ par(mfrow = mfrow)
+ if (length(which.tab) > prod(mfrow))
+ par(ask = TRUE)
+ for (ianal in which.tab) {
+ coolig <- object$lisup[object$TL[, 1] == levels(object$TL[,1])[ianal], c(xax, yax)]
+ coocol <- object$co[object$TC[, 1] == levels(object$TC[,1])[ianal], c(xax, yax)]
+ if (permute.row.col) {
+ auxi <- coolig
+ coolig <- coocol
+ coocol <- auxi
+ }
+ cl <- clab * row.names
+ if (cl > 0)
+ cpoi <- 0
+ else cpoi <- 2
+ s.label(coolig, clabel = cl, cpoint = cpoi)
+ if (traject)
+ s.traject(coolig, clabel = 0, add.plot = TRUE)
+ born <- par("usr")
+ k1 <- min(coocol[, 1])/born[1]
+ k2 <- max(coocol[, 1])/born[2]
+ k3 <- min(coocol[, 2])/born[3]
+ k4 <- max(coocol[, 2])/born[4]
+ k <- c(k1, k2, k3, k4)
+ coocol <- 0.7 * coocol/max(k)
+ s.arrow(coocol, clabel = clab * col.names, add.plot = TRUE,
+ sub = object$tab.names[ianal], possub = possub, csub = csub)
+ }
+}
diff --git a/R/kplot.pta.R b/R/kplot.pta.R
new file mode 100644
index 0000000..9f7475b
--- /dev/null
+++ b/R/kplot.pta.R
@@ -0,0 +1,72 @@
+"kplot.pta" <- function (object, xax = 1, yax = 2, which.tab = 1:nrow(object$RV),
+ mfrow = NULL, which.graph = 1:4, clab = 1, cpoint = 2, csub = 2,
+ possub = "bottomright", ask = par("ask"), ...)
+{
+ if (!inherits(object, "pta"))
+ stop("Object of type 'pta' expected")
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ show <- rep(FALSE, 4)
+ if (!is.numeric(which.graph) || any(which.graph < 1) || any(which.graph >
+ 4))
+ stop("`which' must be in 1:4")
+ show[which.graph] <- TRUE
+ if (is.null(mfrow)) {
+ mfcol <- c(length(which.tab), length(which.graph))
+ par(mfcol = mfcol)
+ }
+ else par(mfrow = mfrow)
+ par(ask = ask)
+ if (show[1]) {
+ for (ianal in which.tab) {
+ coo2 <- object$Tax[object$T4[, 1] == levels(object$T4[,1])[ianal], c(xax, yax)]
+ row.names(coo2) <- as.character(1:4)
+ s.corcircle(coo2, clabel = clab, cgrid = 0, sub = row.names(object$RV)[ianal],
+ csub = csub, possub = possub)
+ }
+ }
+ if (show[2]) {
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ coo1 <- object$li[, c(xax, yax)]
+ cootot <- object$Tli[, c(xax, yax)]
+ names(cootot) <- names(coo1)
+ coofull <- coo1
+ for (i in which.tab) coofull <- rbind.data.frame(coofull, cootot[object$TL[, 1] == levels(object$TL[,1])[i], ])
+ for (ianal in which.tab) {
+ scatterutil.base(coofull, 1, 2, xlim = NULL, ylim = NULL,
+ grid = TRUE, addaxes = TRUE, cgrid = 1, include.origin = TRUE,
+ origin = c(0, 0), sub = row.names(object$RV)[ianal],
+ csub = csub, possub = possub, pixmap = NULL,
+ contour = NULL, area = NULL, add.plot = FALSE)
+ coo2 <- cootot[object$TL[, 1] == levels(object$TL[,1])[ianal], 1:2]
+ s.label(coo2, add.plot = TRUE, clabel = clab, label = row.names(object$Tli)[object$TL[, 1] == levels(object$TL[,1])[ianal]])
+ }
+ }
+ if (show[3]) {
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ coo1 <- object$co[, c(xax, yax)]
+ cootot <- object$Tco[, c(xax, yax)]
+ names(cootot) <- names(coo1)
+ coofull <- coo1
+ for (i in which.tab) coofull <- rbind.data.frame(coofull,
+ cootot[object$TC[, 1] == levels(object$TC[,1])[i], ])
+ for (ianal in which.tab) {
+ scatterutil.base(coofull, 1, 2, xlim = NULL, ylim = NULL,
+ grid = TRUE, addaxes = TRUE, cgrid = 1, include.origin = TRUE,
+ origin = c(0, 0), sub = row.names(object$RV)[ianal],
+ csub = csub, possub = possub, pixmap = NULL,
+ contour = NULL, area = NULL, add.plot = FALSE)
+ coo2 <- object$Tco[object$TC[, 1] == levels(object$TC[,1])[ianal], c(xax, yax)]
+ s.arrow(coo2, add.plot = TRUE, clabel = clab, sub = row.names(object$RV)[ianal],
+ csub = csub, possub = possub)
+ }
+ }
+ if (show[4]) {
+ for (ianal in which.tab) {
+ coo2 <- object$Tcomp[object$T4[, 1] == levels(object$T4[,1])[ianal], c(xax, yax)]
+ row.names(coo2) <- as.character(1:4)
+ s.corcircle(coo2, clabel = clab, cgrid = 0, sub = row.names(object$RV)[ianal],
+ csub = csub, possub = possub)
+ }
+ }
+}
diff --git a/R/kplot.sepan.R b/R/kplot.sepan.R
new file mode 100644
index 0000000..fec80fd
--- /dev/null
+++ b/R/kplot.sepan.R
@@ -0,0 +1,104 @@
+"kplot.sepan" <- function (object, xax = 1, yax = 2, which.tab = 1:length(object$blo),
+ mfrow = NULL, permute.row.col = FALSE, clab.row = 1, clab.col = 1.25,
+ traject.row = FALSE, csub = 2, possub = "bottomright", show.eigen.value = TRUE, ...)
+{
+ if (!inherits(object, "sepan"))
+ stop("Object of type 'sepan' expected")
+ opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
+ on.exit(par(opar))
+ nbloc <- length(object$blo)
+ if (is.null(mfrow))
+ mfrow <- n2mfrow(length(which.tab))
+ par(mfrow = mfrow)
+ if (length(which.tab) > prod(mfrow))
+ par(ask = TRUE)
+ rank.fac <- factor(rep(1:nbloc, object$rank))
+ nf <- ncol(object$Li)
+ neig <- max(object$rank)
+ appel <- as.list(object$call)
+ X <- eval.parent(appel$X)
+ names.li <- row.names(X[[1]])
+ for (ianal in which.tab) {
+ coolig <- object$Li[object$TL[, 1] == levels(object$TL[,1])[ianal], c(xax, yax)]
+ row.names(coolig) <- names.li
+ coocol <- object$Co[object$TC[, 1] == levels(object$TC[,1])[ianal], c(xax, yax)]
+ row.names(coocol) <- names(X[[ianal]])
+ if (permute.row.col) {
+ auxi <- coolig
+ coolig <- coocol
+ coocol <- auxi
+ }
+ if (clab.row > 0)
+ cpoi <- 0
+ else cpoi <- 2
+ if (!traject.row)
+ s.label(coolig, clabel = clab.row, cpoint = cpoi)
+ else s.traject(coolig, clabel = 0, cpoint = 2)
+ born <- par("usr")
+ k1 <- min(coocol[, 1])/born[1]
+ k2 <- max(coocol[, 1])/born[2]
+ k3 <- min(coocol[, 2])/born[3]
+ k4 <- max(coocol[, 2])/born[4]
+ k <- c(k1, k2, k3, k4)
+ coocol <- 0.7 * coocol/max(k)
+ s.arrow(coocol, clabel = clab.col, add.plot = TRUE, sub = object$tab.names[ianal],
+ csub = csub, possub = possub)
+ w <- object$Eig[rank.fac == ianal]
+ if (length(w) < neig)
+ w <- c(w, rep(0, neig - length(w)))
+ if (show.eigen.value)
+ add.scatter.eig(w, nf, xax, yax, posi = c("bottom","top"), ratio = 1/4)
+ }
+}
+
+
+"kplotsepan.coa" <- function (object, xax = 1, yax = 2, which.tab = 1:length(object$blo),
+ mfrow = NULL, permute.row.col = FALSE, clab.row = 1, clab.col = 1.25,
+ csub = 2, possub = "bottomright", show.eigen.value = TRUE,
+ poseig = c("bottom", "top"), ...)
+{
+ if (!inherits(object, "sepan"))
+ stop("Object of type 'sepan' expected")
+ opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
+ on.exit(par(opar))
+ nbloc <- length(object$blo)
+ if (is.null(mfrow))
+ mfrow <- n2mfrow(length(which.tab))
+ par(mfrow = mfrow)
+ if (length(which.tab) > prod(mfrow))
+ par(ask = TRUE)
+ rank.fac <- factor(rep(1:nbloc, object$rank))
+ nf <- ncol(object$Li)
+ neig <- max(object$rank)
+ appel <- as.list(object$call)
+ X <- eval.parent(appel$X)
+ names.li <- row.names(X[[1]])
+ for (ianal in which.tab) {
+ coocol <- object$C1[object$TC[, 1] == levels(object$TC[,1])[ianal], c(xax, yax)]
+ row.names(coocol) <- names(X[[ianal]])
+ coolig <- object$Li[object$TL[, 1] == levels(object$TL[,1])[ianal], c(xax, yax)]
+ row.names(coolig) <- names.li
+ if (permute.row.col) {
+ auxi <- coolig
+ coolig <- coocol
+ coocol <- auxi
+ }
+ if (clab.col > 0)
+ cpoi <- 0
+ else cpoi <- 3
+ s.label(coocol, clabel = 0, cpoint = 0, sub = object$tab.names[ianal],
+ csub = csub, possub = possub)
+ s.label(coocol, clabel = clab.col, cpoint = cpoi, add.plot = TRUE)
+ s.label(coolig, clabel = clab.row, add.plot = TRUE)
+ if (permute.row.col) {
+ auxi <- coolig
+ coolig <- coocol
+ coocol <- auxi
+ }
+ w <- object$Eig[rank.fac == ianal]
+ if (length(w) < neig)
+ w <- c(w, rep(0, neig - length(w)))
+ if (show.eigen.value)
+ add.scatter.eig(w, nf, xax, yax, posi = poseig, ratio = 1/4)
+ }
+}
diff --git a/R/kplot.statis.R b/R/kplot.statis.R
new file mode 100644
index 0000000..59aeee5
--- /dev/null
+++ b/R/kplot.statis.R
@@ -0,0 +1,48 @@
+"kplot.statis" <- function (object, xax = 1, yax = 2, mfrow = NULL, which.tab = 1:length(object$tab.names),
+ clab = 1.5, cpoi = 2, traject = FALSE, arrow = TRUE, class = NULL,
+ unique.scale = FALSE, csub = 2, possub = "bottomright", ...)
+{
+ if (!inherits(object, "statis"))
+ stop("Object of type 'statis' expected")
+ opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
+ on.exit(par(opar))
+ if (is.null(mfrow))
+ mfrow <- n2mfrow(length(which.tab))
+ par(mfrow = mfrow)
+ if (length(which.tab) > prod(mfrow))
+ par(ask = TRUE)
+ nf <- ncol(object$C.Co)
+ if (xax > nf)
+ stop("Non convenient xax")
+ if (yax > nf)
+ stop("Non convenient yax")
+ cootot <- object$C.Co[, c(xax, yax)]
+ label <- TRUE
+ if (!is.null(class)) {
+ class <- factor(class)
+ if (length(class) != length(object$TC[, 1]))
+ class <- NULL
+ else label <- FALSE
+ }
+ for (ianal in which.tab) {
+ coocol <- cootot[object$TC[, 1] == levels(object$TC[,1])[ianal], ]
+ if (unique.scale)
+ s.label(cootot, clabel = 0, cpoint = 0, sub = object$tab.names[ianal],
+ possub = possub, csub = csub)
+ else s.label(coocol, clabel = 0, cpoint = 0, sub = object$tab.names[ianal],
+ possub = possub, csub = csub)
+ if (arrow) {
+ s.arrow(coocol, clabel = clab, add.plot = TRUE)
+ label <- FALSE
+ }
+ if (label)
+ s.label(coocol, clabel = clab, cpoint = cpoi, add.plot = TRUE)
+ if (traject)
+ s.traject(coocol, clabel = 0, add.plot = TRUE)
+ if (!is.null(class)) {
+ f1 <- as.factor(class[object$TC[, 1] == levels(object$TC[,1])[ianal]])
+ s.class(coocol, f1, clabel = clab, cpoint = 2,
+ pch = 20, axesell = FALSE, cellipse = 0, add.plot = TRUE)
+ }
+ }
+}
diff --git a/R/krandboot.R b/R/krandboot.R
new file mode 100644
index 0000000..df4eb3e
--- /dev/null
+++ b/R/krandboot.R
@@ -0,0 +1,32 @@
+as.krandboot <- function(obs, boot, quantiles = c(0.025, 0.975), names = colnames(boot), call = match.call()){
+ ## obs: a vector (length p) with observed value of the statistic
+ ## boot: a matrix (n p) with bootstrapped values
+ ## n: number of repetitions, p number of statistics
+ if(ncol(boot) != length(obs))
+ stop("Wrong number of statistics")
+
+ res <- list(obs = obs, boot = boot)
+ res$rep <- apply(boot, 2, function(x) length(na.omit(x)))
+
+ res$stats <- t(sapply(1:length(obs), function(i) obs[i] - quantile(boot[,i] - obs[i], probs = rev(quantiles), na.rm = TRUE)))
+ colnames(res$stats) <- rev(colnames(res$stats))
+ if(is.null(names))
+ names <- 1: nrow(res$stats)
+ rownames(res$stats) <- names
+ res$call <- call
+ class(res) <- "krandboot"
+ return(res)
+}
+
+
+print.krandboot <- function(x, ...){
+ if (!inherits(x, "krandboot"))
+ stop("Non convenient data")
+ cat("Multiple bootstrap\n")
+ cat("Call: ")
+ print(x$call)
+ cat("\nNumber of statistics: ", length(x$obs), "\n")
+ cat("\nConfidence Interval:\n")
+ print(cbind.data.frame(N.rep = x$rep, Obs = x$obs, x$stats))
+
+}
diff --git a/R/krandtest.R b/R/krandtest.R
new file mode 100644
index 0000000..f0cbb93
--- /dev/null
+++ b/R/krandtest.R
@@ -0,0 +1,120 @@
+"as.krandtest" <- function (sim, obs, alter="greater", call = match.call(), names = colnames(sim), p.adjust.method = "none", output = c("light", "full")) {
+ output <- match.arg(output)
+ if(output == "full")
+ res <- list(sim = sim, obs = obs)
+ else
+ res <- list(obs = obs)
+
+ if(length(obs)!=length(alter))
+ alter <- rep(alter, length = length(obs))
+ res$alter <- alter
+ ## Invalid permutations are stored as NA
+ res$rep <- apply(sim, 2, function(x) length(na.omit(x)))
+ res$ntest <- length(obs)
+ res$expvar <- data.frame(matrix(0, res$ntest, 3))
+ if(!is.null(names)){
+ res$names <- names
+ } else {
+ res$names <- paste("test", 1:res$ntest, sep="")
+ }
+
+ names(res$expvar) <- c("Std.Obs","Expectation","Variance")
+ res$pvalue <- rep(0,length(obs))
+ for(i in 1:length(obs)){
+
+ vec.sim <- na.omit(sim[,i])
+ if(length(vec.sim > 0)){
+ ## compute histogram (mainly used for 'light' randtest)
+ r0 <- c(vec.sim, obs[i])
+ l0 <- max(vec.sim) - min(vec.sim)
+ w0 <- l0/(log(length(vec.sim), base = 2) + 1)
+ xlim0 <- range(r0) + c(-w0, w0)
+ h0 <- hist(vec.sim, plot = FALSE, nclass = 10)
+ res$plot[[i]] <- list(hist = h0, xlim = xlim0)
+ }
+
+ res$alter[i] <- match.arg(res$alter[i], c("greater", "less", "two-sided"))
+ res$expvar[i,1] <- (obs[i] - mean(vec.sim)) / sd(vec.sim)
+ res$expvar[i,2] <- mean(vec.sim)
+ res$expvar[i,3] <- sd(vec.sim)
+
+ if(res$alter[i]=="greater"){
+ res$pvalue[i] <- (sum(vec.sim >= obs[i]) + 1)/(res$rep[i] + 1)
+ }
+ else if(res$alter[i]=="less"){
+ res$pvalue[i] <- (sum(vec.sim <= obs[i]) + 1)/(res$rep[i] + 1)
+ }
+ else if(res$alter[i]=="two-sided") {
+ sim0 <- abs(vec.sim - mean(vec.sim))
+ obs0 <- abs(obs[i] - mean(vec.sim))
+ res$pvalue[i] <- (sum(sim0 >= obs0) + 1) / (res$rep[i] +1)
+ }
+ }
+
+ p.adjust.method <- match.arg(p.adjust.method, p.adjust.methods)
+ res$adj.pvalue <- p.adjust(res$pvalue, method = p.adjust.method)
+ res$adj.method <- p.adjust.method
+ res$call <- call
+ class(res) <- "krandtest"
+ if(output == "light")
+ class(res) <- c(class(res), "lightkrandtest")
+
+ return(res)
+}
+
+
+"plot.krandtest" <- function (x, mfrow = NULL, nclass = 10, main.title = x$names, ...) {
+ if (!inherits(x, "krandtest"))
+ stop("to be used with 'krandtest' object")
+ if (is.null(mfrow))
+ mfrow = n2mfrow(x$ntest)
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ par(mfrow = mfrow)
+ par(mar = c(3.1, 2.5, 2.1, 2.1))
+ if (length(main.title)!=length(x$names))
+ main.title <- x$names
+ if(inherits(x, "lightkrandtest")) {
+ for (k in 1:x$ntest) {
+ y0 <- max(x$plot[[k]]$hist$counts)
+ plot(x$plot[[k]]$hist, xlim = x$plot[[k]]$xlim, col = grey(0.8), main = main.title[k], ...)
+ lines(c(x$obs[k], x$obs[k]), c(y0/2, 0))
+ points(x$obs[k], y0/2, pch = 18, cex = 2)
+ }
+ } else {
+
+ for (k in 1:x$ntest) {
+ plot.randtest(as.randtest(x$sim[,k], x$obs[k], call = match.call()), main = main.title[k], nclass = nclass)
+ }
+}
+}
+
+"print.krandtest" <- function (x, ...) {
+ if (!inherits(x, "krandtest"))
+ stop("to be used with 'krandtest' object")
+ cat("class:", class(x), "\n")
+ ## dig0 <- ceiling (log(x$rep)/log(10))
+ cat("Monte-Carlo tests\n")
+ cat("Call: ")
+ print(x$call)
+ cat("\nNumber of tests: ", x$ntest, "\n")
+ cat("\nAdjustment method for multiple comparisons: ", x$adj.method, "\n")
+
+ sumry <- list(Test = x$names, Obs = x$obs, Std.Obs = x$expvar[,1], Alter = x$alter)
+ sumry <- as.data.frame(sumry)
+ row.names(sumry) <- 1:x$ntest
+
+ if(any(x$rep[1] != x$rep)){
+ sumry <- cbind(sumry[,1:4], N.perm = x$rep)
+ } else {
+ cat("Permutation number: ", x$rep[1], "\n")
+ }
+ sumry <- cbind(sumry, Pvalue = x$pvalue)
+ if(x$adj.method != "none")
+ sumry <- cbind(sumry, Pvalue.adj = x$adj.pvalue)
+
+ print(sumry)
+ cat("\n")
+
+}
+
diff --git a/R/krandxval.R b/R/krandxval.R
new file mode 100644
index 0000000..391bbd3
--- /dev/null
+++ b/R/krandxval.R
@@ -0,0 +1,40 @@
+as.krandxval <- function(RMSEc, RMSEv, quantiles = c(0.25, 0.75), names = colnames(RMSEc), call = match.call()){
+ ## RMSEc: n x p matrix with residual mean square error of calibration
+ ## RMSEv: n x p matrix with residual mean square error of validation
+ ## n: number of repetitions, p: number of statistics
+ if(nrow(RMSEc) != nrow(RMSEv))
+ stop("Both RMSE should be computed on the same number of repetitions")
+
+ if(ncol(RMSEc) != ncol(RMSEv))
+ stop("Both RMSE should be computed on the same number of statistics")
+
+ res <- list(RMSEc = RMSEc, RMSEv = RMSEv, rep = nrow(RMSEc))
+
+ ## compute stats for RMSEc
+ res$repRMSEc <- colSums(!is.na(res$RMSEc))
+ res$statsRMSEc <- cbind.data.frame(Mean = colMeans(res$RMSEc, na.rm = TRUE), t(apply(res$RMSEc,2, quantile, probs = quantiles, na.rm = TRUE)))
+ rownames(res$statsRMSEc) <- names
+
+ ## compute stats for RMSEv
+ res$repRMSEv <- colSums(!is.na(res$RMSEc))
+ res$statsRMSEv <- cbind.data.frame(Mean = colMeans(res$RMSEv, na.rm = TRUE), t(apply(res$RMSEv,2, quantile, probs = quantiles, na.rm = TRUE)))
+ rownames(res$statsRMSEv) <- names
+
+ res$call <- call
+ class(res) <- "krandxval"
+ return(res)
+}
+
+
+print.krandxval <- function(x, ...){
+ if (!inherits(x, "krandxval"))
+ stop("Non convenient data")
+ cat("Two-fold cross-validation\n")
+ cat("Call: ")
+ print(x$call)
+ cat("\nResults for", ncol(x$RMSEc), "statistics\n\n")
+ cat("Root mean square error of calibration:\n")
+ print(cbind.data.frame(N.rep = x$repRMSEc, x$statsRMSEc))
+ cat("\nRoot mean square error of validation:\n")
+ print(cbind.data.frame(N.rep = x$repRMSEv, x$statsRMSEv))
+}
diff --git a/R/ktab.R b/R/ktab.R
new file mode 100644
index 0000000..f958435
--- /dev/null
+++ b/R/ktab.R
@@ -0,0 +1,332 @@
+########### is.ktab ###########
+"is.ktab" <- function (x)
+ inherits(x, "ktab")
+
+########### [.ktab ###########
+"[.ktab" <- function (x, i, j, k) {
+ ## i: index of blocks
+ ## j: index of rows
+ ## k: index of columns
+
+ ## select blocks
+ blocks <- x$blo
+ nblo <- length(blocks)
+ if(missing(i))
+ i <- 1:nblo
+ if (is.logical(i))
+ i <- which(i)
+ if (any(i > nblo))
+ stop("Non convenient selection")
+ indica <- as.factor(rep(1:nblo, blocks))
+ res <- unclass(x)[i]
+
+ tabw <- x$tabw[i]
+ cw <- x$cw
+ cw <- split(cw, indica)
+ cw <- cw[i]
+
+ ## select columns
+ if(!missing(k)){
+ res <- lapply(res, function(z) z[, k, drop = FALSE])
+ cw <- lapply(cw, function(z) z[k, drop = FALSE])
+ }
+ cw <- unlist(cw)
+ blocks <- unlist(lapply(res, function(z) ncol(z)))
+
+ ## select rows
+ lw <- x$lw
+ if(!missing(j)){
+ res <- lapply(res, function(z) z[j,, drop = FALSE])
+ lw <- lw[j, drop = FALSE]
+ }
+ res$lw <- lw / sum(lw)
+ res$cw <- cw
+ res$tabw <- tabw
+
+ nblo <- length(blocks)
+ res$blo <- blocks
+ class(res) <- "ktab"
+ res <- ktab.util.addfactor(res)
+ res$call <- match.call()
+
+ return(res)
+}
+
+########### print.ktab ###########
+"print.ktab" <- function (x, ...) {
+ if (!inherits(x, "ktab"))
+ stop("to be used with 'ktab' object")
+ cat("class:", class(x), "\n")
+ ntab <- length(x$blo)
+ cat("\ntab number: ", ntab, "\n")
+ sumry <- array("", c(ntab, 3), list(1:ntab, c("data.frame",
+ "nrow", "ncol")))
+ for (i in 1:ntab) {
+ sumry[i, ] <- c(names(x)[i], nrow(x[[i]]), ncol(x[[i]]))
+ }
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(4, 4), list((ntab + 1):(ntab + 4), c("vector",
+ "length", "mode", "content")))
+ sumry[1, ] <- c("$lw", length(x$lw), mode(x$lw), "row weigths")
+ sumry[2, ] <- c("$cw", length(x$cw), mode(x$cw), "column weights")
+ sumry[3, ] <- c("$blo", length(x$blo), mode(x$blo), "column numbers")
+ sumry[4, ] <- c("$tabw", length(x$tabw), mode(x$tabw), "array weights")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(3, 4), list((ntab + 5):(ntab + 7), c("data.frame",
+ "nrow", "ncol", "content")))
+ sumry[1, ] <- c("$TL", nrow(x$TL), ncol(x$TL), "Factors Table number Line number")
+ sumry[2, ] <- c("$TC", nrow(x$TC), ncol(x$TC), "Factors Table number Col number")
+ sumry[3, ] <- c("$T4", nrow(x$T4), ncol(x$T4), "Factors Table number 1234")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ cat((ntab + 8), "$call: ")
+ print(x$call)
+ cat("\n")
+ cat("names :\n")
+ for (i in 1:ntab) {
+ cat(names(x)[i], ":", names(x[[i]]), "\n")
+ }
+ cat("\n")
+ indica <- as.factor(rep(1:ntab, x$blo))
+ w <- split(x$cw, indica)
+ cat("Col weigths :\n")
+ for (i in 1:ntab) {
+ cat(names(x)[i], ":", w[[i]], "\n")
+ }
+ cat("\n")
+ cat("Row weigths :\n")
+ cat(x$lw)
+ cat("\n")
+}
+########### c.ktab" ###########
+"c.ktab" <- function (...) {
+ x <- list(...)
+ n <- length(x)
+ if (any(lapply(x, class) != "ktab"))
+ stop("arguments imply object without 'ktab' class")
+ nr <- unlist(lapply(x, function(x) nrow(x[[1]])))
+ if (length(unique(nr)) != 1)
+ stop("arguments imply object with non constant row numbers")
+ lw <- x[[1]]$lw
+ nr <- length(lw)
+ noms <- row.names(x[[1]][[1]])
+ res <- NULL
+ cw <- NULL
+ blocks <- NULL
+ for (i in 1:n) {
+ if (any(x[[i]]$lw != lw))
+ stop("arguments imply object with non constant row weights")
+ if (any(row.names(x[[i]][[1]]) != noms))
+ stop("arguments imply object with non constant row.names")
+ blo.i <- x[[i]]$blo
+ nblo.i <- length(blo.i)
+ res <- c(res, unclass(x[[i]])[1:nblo.i])
+ cw <- c(cw, x[[i]]$cw)
+ blocks <- c(blocks, blo.i)
+ }
+ names(res) <- make.names(names(res), TRUE)
+ res$lw <- lw
+ res$cw <- cw
+ res$blo <- blocks
+ class(res) <- "ktab"
+ res <- ktab.util.addfactor(res)
+ res$call <- match.call()
+ return(res)
+}
+
+########### t.ktab" ###########
+"t.ktab" <- function (x) {
+ if (!inherits(x, "ktab"))
+ stop("object 'ktab' expected")
+ blocks <- x$blo
+ nblo <- length(blocks)
+ res <- x
+ r.n <- row.names(x[[1]])
+ for (i in 1:nblo) {
+ r.new <- row.names(x[[i]])
+ if (any(r.new != r.n))
+ stop("non equal row.names among array")
+ }
+ if (length(unique(blocks)) != 1)
+ stop("non equal col numbers among array")
+ c.n <- names(x[[1]])
+ for (i in 1:nblo) {
+ c.new <- names(x[[i]])
+ if (any(c.new != c.n))
+ stop("non equal col.names among array")
+ }
+ new.row.names <- names(x[[1]])
+ indica <- as.factor(rep(1:nblo, blocks))
+ w <- split(x$cw, indica)
+ col.w <- w[[1]]
+ for (i in 1:nblo) {
+ col.w.new <- w[[i]]
+ if (any(col.w != col.w.new))
+ stop("non equal column weights among array")
+ }
+ for (j in 1:nblo) {
+ w <- x[[j]]
+ w <- data.frame(t(w))
+ row.names(w) <- new.row.names
+ res[[j]] <- w
+ blocks[j] <- ncol(w)
+ }
+ res$lw <- col.w
+ res$cw <- rep(x$lw, nblo)
+ res$blo <- blocks
+ class(res) <- "ktab"
+ res <- ktab.util.addfactor(res)
+ res$call <- match.call()
+ return(res)
+}
+
+########### row.names.ktab ###########
+"row.names.ktab" <- function (x) {
+ if (!inherits(x, "ktab"))
+ stop("to be used with 'ktab' object")
+ ntab <- length(x$blo)
+ cha <- attr(x[[1]], "row.names")
+ for (i in 1:ntab) {
+ if (any(attr(x[[i]], "row.names") != cha))
+ warnings(paste("array", i, "and array 1 have different row.names"))
+ }
+ return(cha)
+}
+########### row.names<-.ktab ###########
+"row.names<-.ktab" <- function (x, value) {
+ if (!inherits(x, "ktab"))
+ stop("to be used with 'ktab' object")
+ ntab <- length(x$blo)
+ old <- attr(x[[1]], "row.names")
+ if (!is.null(old) && length(value) != length(old))
+ stop("invalid row.names length")
+ value <- as.character(value)
+ if (any(duplicated(value)))
+ stop("duplicate row.names are not allowed")
+ for (i in 1:ntab) {
+ attr(x[[i]], "row.names") <- value
+ }
+ x
+}
+########### col.names ###########
+"col.names" <- function (x) UseMethod("col.names")
+
+########### col.names<- ###########
+"col.names<-" <- function (x, value) UseMethod("col.names<-")
+
+########### col.names.ktab ###########
+"col.names.ktab" <- function (x) {
+ if (!inherits(x, "ktab"))
+ stop("to be used with 'ktab' object")
+ ntab <- length(x$blo)
+ cha <- unlist(lapply(1:ntab, function(y) attr(x[[y]], "names")))
+ return(cha)
+}
+########### col.names<-.ktab ###########
+"col.names<-.ktab" <- function (x, value) {
+ if (!inherits(x, "ktab"))
+ stop("to be used with 'ktab' object")
+ ntab <- length(x$blo)
+ old <- unlist(lapply(1:ntab, function(y) attr(x[[y]], "names")))
+ if (!is.null(old) && length(value) != length(old))
+ stop("invalid col.names length")
+ value <- as.character(value)
+ indica <- as.factor(rep(1:ntab, x$blo))
+ for (i in 1:ntab) {
+ if (any(duplicated(value[indica == i])))
+ stop("duplicate col.names are not allowed in the same array")
+ attr(x[[i]], "names") <- value[indica == i]
+ }
+ x
+}
+
+
+########### tab.names ###########
+# fonction générique
+"tab.names" <- function (x) UseMethod("tab.names")
+########### tab.names.ktab ###########
+# méthode pour ktab
+"tab.names.ktab" <- function (x) {
+ if (!inherits(x, "ktab"))
+ stop("to be used with 'ktab' object")
+ ntab <- length(x$blo)
+ cha <- names(x)[1:ntab]
+ return(cha)
+}
+########### tab.names<- ###########
+# fonction générique
+"tab.names<-" <- function (x, value) UseMethod("tab.names<-")
+########### tab.names<-.ktab ###########
+# méthode pour ktab
+# les tab.names d'un ktab est le vecteur des noms des k premières composantes
+# ce nombre de tableaux est la longueur de la composante blo
+"tab.names<-.ktab" <- function (x, value) {
+ if (!inherits(x, "ktab"))
+ stop("to be used with 'ktab' object")
+ ntab <- length(x$blo)
+ old <- tab.names(x)[1:ntab]
+ if (!is.null(old) && length(value) != length(old))
+ stop("invalid tab.names length")
+ value <- as.character(value)
+ if (any(duplicated(value)))
+ stop("duplicate tab.names are not allowed")
+ names(x)[1:ntab] <- value
+ x
+}
+########### ktab.util.names ###########
+# utilitaire qui récupère dans un ktab
+# une liste de 3 éléments
+# les noms des lignes "." les noms des tableaux
+# les noms des colonnes sans duplicats
+# les noms des tableaux "." 1234
+# pour donner des étiquettes aux TL, TC et T4 dans les graphiques
+"ktab.util.names" <- function (x) {
+ w <- row.names(x)
+ w1 <- paste(w, as.character(x$TL[, 1]), sep = ".")
+ w <- col.names(x)
+ if (any(duplicated(w)))
+ w <- paste(w, as.character(x$TC[, 1]), sep = ".")
+ w2 <- w
+ w <- tab.names(x)
+ l0 <- length(w)
+ w3 <- paste(rep(w, rep(4, l0)), as.character(1:4), sep = ".")
+ # Cas d'un ktab de type kcoinertie
+ if (!inherits (x,"kcoinertia")) return(list(row = w1, col = w2, tab = w3))
+# w4 <- paste(rep(tab.names(x), each=nrow(x$supX)/length(tab.names(x))), row.names(x$supX), sep=".")
+# Admettre des ktabs ayant des nombres de lignes (colonnes) différents
+ w4 <- paste(rep(tab.names(x), x$supblo), row.names(x$supX), sep=".")
+ return(list(row = w1, col = w2, tab = w3, Trow=w4))
+}
+
+########### ktab.util.addfactor<- ###########
+## utility used for ktab objects
+## add the componenst TL TC and T4
+## x is an object of class ktab not yet finished (should contains tables, lw and blo)
+# we obtain the col number (unique for each table) and the number of row (common to all tables)
+"ktab.util.addfactor" <- function (x) {
+ blocks <- x$blo
+ nlig <- length(x$lw)
+ nblo <- length(x$blo)
+ rowname <- row.names(x)
+ colname <- col.names(x)
+ blocname <- tab.names(x)
+
+ w <- cbind.data.frame(gl(nblo, nlig, labels = blocname), factor(rep(1:nlig,
+ nblo), labels = rowname))
+ names(w) <- c("T", "L")
+ x$TL <- w
+ w <- NULL
+ for (i in 1:nblo) w <- c(w, 1:blocks[i])
+ w <- cbind.data.frame(factor(rep(1:nblo, blocks), labels = blocname), factor(colname))
+ names(w) <- c("T", "C")
+ x$TC <- w
+ w <- cbind.data.frame(gl(nblo, 4, labels = blocname), factor(rep(1:4, nblo)))
+ names(w) <- c("T", "4")
+ x$T4 <- w
+ x
+}
diff --git a/R/ktab.data.frame.R b/R/ktab.data.frame.R
new file mode 100644
index 0000000..ff24d98
--- /dev/null
+++ b/R/ktab.data.frame.R
@@ -0,0 +1,43 @@
+"ktab.data.frame" <- function (df, blocks, rownames = NULL, colnames = NULL, tabnames = NULL,
+ w.row = rep(1, nrow(df))/nrow(df), w.col = rep(1, ncol(df)))
+{
+ if (!inherits(df, "data.frame"))
+ stop("object 'data.frame' expected")
+ nblo <- length(blocks)
+ if (sum(blocks) != ncol(df))
+ stop("Non convenient 'blocks' parameter")
+ if (is.null(rownames))
+ rownames <- row.names(df)
+ else if (length(rownames) != length(row.names(df)))
+ stop("Non convenient rownames length")
+ if (is.null(colnames))
+ colnames <- names(df)
+ else if (length(colnames) != length(names(df)))
+ stop("Non convenient colnames length")
+ if (is.null(names(blocks)))
+ tn <- paste("Ana", 1:nblo, sep = "")
+ else tn <- names(blocks)
+ if (is.null(tabnames))
+ tabnames <- tn
+ else if (length(tabnames) != length(tn))
+ stop("Non convenient tabnames length")
+ for (x in c("lw", "cw", "blo", "TL", "TC", "T4")) tabnames[tabnames ==
+ x] <- paste(x, "*", sep = "")
+ indica <- as.factor(rep(1:nblo, blocks))
+ res <- list()
+ for (i in 1:nblo) {
+ res[[i]] <- df[, indica == i]
+ }
+ names(blocks) <- tabnames
+ res$lw <- w.row
+ res$cw <- w.col
+ res$blo <- blocks
+ class(res) <- "ktab"
+ row.names(res) <- rownames
+ col.names(res) <- colnames
+ tab.names(res) <- tabnames
+ res <- ktab.util.addfactor(res)
+ res$call <- match.call()
+
+ return(res)
+}
diff --git a/R/ktab.list.df.R b/R/ktab.list.df.R
new file mode 100644
index 0000000..957fe83
--- /dev/null
+++ b/R/ktab.list.df.R
@@ -0,0 +1,51 @@
+"ktab.list.df" <- function (obj, rownames = NULL, colnames = NULL, tabnames = NULL,
+ w.row = rep(1, nrow(obj[[1]])), w.col = lapply(obj, function(x) rep(1/ncol(x),
+ ncol(x))))
+{
+ obj <- as.list(obj)
+ if (any(unlist(lapply(obj, function(x) !inherits(x, "data.frame")))))
+ stop("list of 'data.frame' object expected")
+ nblo <- length(obj)
+ res <- list()
+ nlig <- nrow(obj[[1]])
+ blocks <- unlist(lapply(obj, function(x) ncol(x)))
+ cn <- unlist(lapply(obj, names))
+ if (is.null(rownames))
+ rownames <- row.names(obj[[1]])
+ else if (length(rownames) != length(row.names(obj[[1]])))
+ stop("Non convenient rownames length")
+ if (is.null(colnames))
+ colnames <- cn
+ else if (length(colnames) != length(cn))
+ stop("Non convenient colnames length")
+ if (is.null(names(obj)))
+ tn <- paste("Ana", 1:nblo, sep = "")
+ else tn <- names(obj)
+ if (is.null(tabnames))
+ tabnames <- tn
+ else if (length(tabnames) != length(tn))
+ stop("Non convenient tabnames length")
+ if (nlig != length(w.row))
+ stop("Non convenient length for w.row")
+ n1 <- unlist(lapply(w.col, length))
+ n2 <- unlist(lapply(obj, ncol))
+ if (any(n1 != n2))
+ stop("Non convenient length in w.col")
+ for (i in 1:nblo) {
+ res[[i]] <- obj[[i]]
+ }
+ lw <- w.row
+ cw <- unlist(w.col)
+ names(cw) <- NULL
+ names(blocks) <- tabnames
+ res$blo <- blocks
+ res$lw <- lw
+ res$cw <- cw
+ class(res) <- "ktab"
+ row.names(res) <- rownames
+ col.names(res) <- colnames
+ tab.names(res) <- tabnames
+ res <- ktab.util.addfactor(res)
+ res$call <- match.call()
+ return(res)
+}
diff --git a/R/ktab.list.dudi.R b/R/ktab.list.dudi.R
new file mode 100644
index 0000000..19032b0
--- /dev/null
+++ b/R/ktab.list.dudi.R
@@ -0,0 +1,44 @@
+"ktab.list.dudi" <- function (obj, rownames = NULL, colnames = NULL, tabnames = NULL) {
+ obj <- as.list(obj)
+ if (any(unlist(lapply(obj, function(x) !inherits(x, "dudi")))))
+ stop("list of object 'dudi' expected")
+ nblo <- length(obj)
+ res <- list()
+ lw <- obj[[1]]$lw
+ cw <- NULL
+ blocks <- unlist(lapply(obj, function(x) ncol(x$tab)))
+ for (i in 1:nblo) {
+ if (any(obj[[i]]$lw != lw))
+ stop("Non equal row weights among arrays")
+ res[[i]] <- obj[[i]]$tab
+ cw <- c(cw, obj[[i]]$cw)
+ }
+ cn <- unlist(lapply(obj, function(x) names(x$tab)))
+ if (is.null(rownames))
+ rownames <- row.names(obj[[1]]$tab)
+ else if (length(rownames) != length(row.names(obj[[1]]$tab)))
+ stop("Non convenient rownames length")
+ if (is.null(colnames))
+ colnames <- cn
+ else if (length(colnames) != length(cn))
+ stop("Non convenient colnames length")
+ if (is.null(names(obj)))
+ tn <- paste("Ana", 1:nblo, sep = "")
+ else tn <- names(obj)
+ if (is.null(tabnames))
+ tabnames <- tn
+ else if (length(tabnames) != length(tn))
+ stop("Non convenient tabnames length")
+ names(blocks) <- tabnames
+ res$blo <- blocks
+ res$lw <- lw
+ res$cw <- cw
+ class(res) <- "ktab"
+ row.names(res) <- rownames
+ col.names(res) <- colnames
+ tab.names(res) <- tabnames
+ res <- ktab.util.addfactor(res)
+ res$call <- match.call()
+
+ return(res)
+}
diff --git a/R/ktab.match2ktabs.R b/R/ktab.match2ktabs.R
new file mode 100644
index 0000000..edb7f96
--- /dev/null
+++ b/R/ktab.match2ktabs.R
@@ -0,0 +1,58 @@
+"ktab.match2ktabs" <- function (KTX, KTY) {
+ if (!inherits(KTX, "ktab")) stop("The first argument must be a 'ktab'")
+ if (!inherits(KTY, "ktab")) stop("The second argument must be a 'ktab'")
+#### crossed ktab
+ res <- list()
+#### Parameters of first ktab
+ lwX <- KTX$lw
+ cwX <- KTX$cw
+ ncolX <- length(cwX)
+ bloX <- KTX$blo
+ ntabX <- length(KTX$blo)
+#### Parameters of second ktab
+ lwY <- KTY$lw
+ nligY <- length(lwY)
+ cwY <- KTY$cw
+ ncolY <- length(cwY)
+ bloY <- KTY$blo
+ ntabY <- length(KTY$blo)
+#### Tests of coherence of the two ktabs
+ if (ncolX != ncolY) stop("The two ktabs must have the same column numbers")
+ if (any(cwX != cwY)) stop("The two ktabs must have the same column weights")
+ if (ntabX != ntabY) stop("The two ktabs must have the same number of tables")
+ if (!all(bloX == bloY)) stop("The two tables of one pair must have the same number of columns")
+ ntab <- ntabX
+ indica <- as.factor(rep(1:ntab, KTX$blo))
+ lw <- split(cwX, indica)
+#### Compute crossed ktab
+ for (i in 1:ntab) {
+ tx <- as.matrix(KTX[[i]])
+ ty <- as.matrix(KTY[[i]])
+ res[[i]] <- as.data.frame(tx %*% (t(ty) * lw[[i]]))
+ }
+#### Complete crossed ktab structure
+ res$lw <- lwX
+ res$cw <- rep(lwY,ntab)
+ blo <- rep(nligY,ntab)
+ res$blo <- blo
+
+#### Enregistrement des tableaux de départ
+ res$supX <- KTX[[1]]
+ res$supY <- KTY[[1]]
+ for (i in 2:ntab) {
+ res$supX <- cbind(res$supX, KTX[[i]])
+ res$supY <- cbind(res$supY, KTY[[i]])
+ }
+ res$supX=t(res$supX)
+ res$supY=t(res$supY)
+ res$supblo <- KTX$blo
+ res$suplw <- cwX
+ res$call <- match.call()
+ class(res) <- c("ktab", "kcoinertia")
+ col.names(res) <- rep(row.names(KTY),ntab)
+ row.names(res) <- row.names(KTX)
+ tab.names(res) <- tab.names(KTX)
+ res <- ktab.util.addfactor(res)
+
+ return(res)
+}
diff --git a/R/ktab.within.R b/R/ktab.within.R
new file mode 100644
index 0000000..bb22f98
--- /dev/null
+++ b/R/ktab.within.R
@@ -0,0 +1,41 @@
+"ktab.within" <- function (dudiwit, rownames = NULL, colnames = NULL, tabnames = NULL) {
+ if (!inherits(dudiwit, "within"))
+ stop("Result from within expected for dudiwit")
+ fac <- dudiwit$fac
+ nblo <- nlevels(fac)
+ res <- list()
+ blocks <- rep(0, nblo)
+ if (is.null(rownames))
+ rownames <- names(dudiwit$tab)
+ else if (length(rownames) != length(names(dudiwit$tab)))
+ stop("Non convenient rownames length")
+ if (is.null(colnames))
+ colnames <- unlist(split(row.names(dudiwit$tab), fac))
+ else if (length(colnames) != length(row.names(dudiwit$tab)))
+ stop("Non convenient colnames length")
+ if (is.null(tabnames))
+ tabnames <- levels(fac)
+ else if (length(tabnames) != nblo)
+ stop("Non convenient tabnames length")
+ cw <- NULL
+ for (i in 1:nblo) {
+ k <- levels(fac)[i]
+ w1 <- dudiwit$lw[fac == k]
+ w1 <- w1/sum(w1)
+ cw <- c(cw, w1)
+ res[[i]] <- data.frame(t(dudiwit$tab[fac == k, ]))
+ blocks[i] <- ncol(res[[i]])
+ }
+ names(blocks) <- tabnames
+ res$lw <- dudiwit$cw
+ res$cw <- cw
+ res$blo <- blocks
+ class(res) <- "ktab"
+ row.names(res) <- rownames
+ col.names(res) <- colnames
+ tab.names(res) <- tabnames
+ res <- ktab.util.addfactor(res)
+ res$call <- match.call()
+ res$tabw <- dudiwit$tabw
+ return(res)
+}
diff --git a/R/lingoes.R b/R/lingoes.R
new file mode 100644
index 0000000..f0e4c76
--- /dev/null
+++ b/R/lingoes.R
@@ -0,0 +1,24 @@
+"lingoes" <- function (distmat, print = FALSE, tol = 1e-07, cor.zero = TRUE) {
+ if (is.euclid(distmat)) {
+ warning("Euclidean distance found : no correction need")
+ return(distmat)
+ }
+ distmat <- as.matrix(distmat)
+ delta <- -0.5 * bicenter.wt(distmat * distmat)
+ lambda <- eigen(delta, symmetric = TRUE, only.values = TRUE)$values
+ lder <- lambda[ncol(distmat)]
+ if(cor.zero){
+ distmat <- distmat * distmat
+ distmat[distmat > tol] <- sqrt(distmat[distmat > tol] + 2 * abs(lder))
+ } else {
+ distmat <- sqrt(distmat * distmat + 2 * abs(lder))
+ }
+
+ if (print)
+ cat("Lingoes constant =", round(abs(lder), digits = 6),
+ "\n")
+ distmat <- as.dist(distmat)
+ attr(distmat, "call") <- match.call()
+ attr(distmat, "method") <- "Lingoes"
+ return(distmat)
+}
diff --git a/R/mantel.randtest.R b/R/mantel.randtest.R
new file mode 100644
index 0000000..930a58f
--- /dev/null
+++ b/R/mantel.randtest.R
@@ -0,0 +1,15 @@
+"mantel.randtest" <- function(m1, m2, nrepet = 999, ...) {
+ if (!inherits(m1, "dist"))
+ stop("Object of class 'dist' expected")
+ if (!inherits(m2, "dist"))
+ stop("Object of class 'dist' expected")
+ n <- attr(m1, "Size")
+ if (n != attr(m2, "Size"))
+ stop("Non convenient dimension")
+ m1 <- as.matrix(m1)
+ m2 <- as.matrix(m2)
+ col <- ncol(m1)
+ isim<-testmantel(nrepet, col, as.matrix(m1), as.matrix(m2))
+ obs<-isim[1]
+ return(as.randtest(sim = isim[-1], obs = obs, call = match.call(), ...))
+}
diff --git a/R/mantel.rtest.R b/R/mantel.rtest.R
new file mode 100644
index 0000000..e975d39
--- /dev/null
+++ b/R/mantel.rtest.R
@@ -0,0 +1,38 @@
+"mantel.rtest" <- function (m1, m2, nrepet = 99, ...) {
+ if (!inherits(m1, "dist"))
+ stop("Object of class 'dist' expected")
+ if (!inherits(m2, "dist"))
+ stop("Object of class 'dist' expected")
+ n <- attr(m1, "Size")
+ if (n != attr(m2, "Size"))
+ stop("Non convenient dimension")
+
+ permutedist <- function(m) {
+ w0 <- sample.int(attr(m, "Size"))
+ m <- as.matrix(m)
+ return(as.dist(m[w0, w0]))
+ }
+
+ mantelnoneuclid <- function(m1, m2, nrepet) {
+ obs <- cor(unclass(m1), unclass(m2))
+ if (nrepet == 0)
+ return(obs)
+ perm <- matrix(0, nrow = nrepet, ncol = 1)
+ perm <- apply(perm, 1, function(x) cor(unclass(m1), unclass(permutedist(m2))))
+ w <- as.randtest(obs = obs, sim = perm, call = match.call(), ...)
+ return(w)
+ }
+ if (is.euclid(m1) & is.euclid(m2)) {
+ tab1 <- pcoscaled(m1)
+ obs <- cor(dist.quant(tab1, 1), m2)
+ if (nrepet == 0)
+ return(obs)
+ perm <- rep(0, nrepet)
+ perm <- unlist(lapply(perm, function(x) cor(dist(tab1[sample(n),
+ ]), m2)))
+ w <- as.randtest(obs = obs, sim = perm, call = match.call(), ...)
+ return(w)
+ }
+ w <- mantelnoneuclid(m1, m2, nrepet = nrepet)
+ return(w)
+}
diff --git a/R/mbpcaiv.R b/R/mbpcaiv.R
new file mode 100644
index 0000000..d2c6da1
--- /dev/null
+++ b/R/mbpcaiv.R
@@ -0,0 +1,248 @@
+mbpcaiv <- function(dudiY, ktabX, scale = TRUE, option = c("uniform", "none"), scannf = TRUE, nf = 2) {
+
+ ## -------------------------------------------------------------------------------
+ ## Some tests
+ ##--------------------------------------------------------------------------------
+
+ if (!inherits(dudiY, "dudi"))
+ stop("object 'dudi' expected")
+ if (!inherits(ktabX, "ktab"))
+ stop("object 'ktab' expected")
+ if (any(row.names(ktabX) != row.names(dudiY$tab)))
+ stop("ktabX and dudiY must have the same rows")
+ if (!(all.equal(ktabX$lw/sum(ktabX$lw), dudiY$lw/sum(dudiY$lw))))
+ stop("ktabX and dudiY must have the same row weights")
+ if (nrow(dudiY$tab) < 6)
+ stop("Minimum six rows are required")
+ if (any(ktabX$blo < 2))
+ stop("Minimum two variables per explanatory block are required")
+ if (!(is.logical(scale)))
+ stop("Non convenient selection for scaling")
+ if (!(is.logical(scannf)))
+ stop("Non convenient selection for scannf")
+ if (nf < 0)
+ nf <- 2
+
+ ## Only works with centred pca (dudi.pca with center=TRUE) with uniform row weights
+ # if (!any(dudi.type(dudiY$call) == c(3,4)))
+ # stop("Only implemented for centred pca")
+
+ # Vérifier la formule / arrondi
+ #if (any(dudiY$lw != 1/nrow(dudiY$tab)))
+ # stop("Only implemented for uniform row weights")
+
+ option <- match.arg(option)
+
+ ## -------------------------------------------------------------------------------
+ ## Arguments and data transformation
+ ## -------------------------------------------------------------------------------
+
+ ## Preparation of the data frames
+ Y <- scalewt(as.matrix(dudiY$tab), wt = dudiY$lw, center = TRUE, scale = scale)
+ nblo <- length(ktabX$blo)
+ Xk <- lapply(unclass(ktabX)[1 : nblo], scalewt, wt = ktabX$lw, center = TRUE, scale = scale)
+
+ nr <- nrow(Y)
+ ncolY <- ncol(Y)
+
+ ## Block weighting
+ if (option[1] == "uniform"){
+ Y <- Y / sqrt(sum(dudiY$eig)) ## Here we use biased variance. We should use Y <- Y / sqrt(nr/(nr-1)*sum(dudiY$eig)) for unbiased estimators
+ for (k in 1 : nblo){
+ Xk[[k]] <- Xk[[k]] / sqrt((nblo/nr) * sum(diag(crossprod(Xk[[k]])))) ## same : Xk[[k]] <- Xk[[k]] / sqrt((nblo/(nr-1)) * sum(diag(crossprod(Xk[[k]])))) for unbiased estimators
+ }
+ }
+
+ X <- cbind.data.frame(Xk)
+ colnames(X) <- col.names(ktabX)
+ ncolX <- ncol(X)
+ maxdim <- qr(X)$rank
+
+
+ ##-----------------------------------------------------------------------
+ ## Prepare the outputs
+ ##-----------------------------------------------------------------------
+
+
+ ## Yc1 (V in Bougeard et al): was c1
+ ## lY (U): was ls
+ ## Ajout: de Yco (cov(Y, lX)) -> norme total = eig
+
+ ## lX (T): was li
+ ## faX (W*): was Wstar
+
+ ## Tl1 (Tk): was Tk
+ ## Ajout: Tli (Tk non normé = Tk2) norme total = eig
+ ## Tfa (Wk): was Wk
+ ## Ajout: cov2 (cov^2(lY, Tl1))
+ ## XYcoef: (Beta) was beta
+
+ ## bip, bipc
+ ## vip, vipc
+
+ ## Suppression: W
+ ## Suppression: l1
+ ## Suppression de C (remplacé par Yco)
+ ## Suppression de Ak (remplacé par cov2)
+
+ dimlab <- paste("Ax", 1:maxdim, sep = "")
+ res <- list(tabX = X, tabY = as.data.frame(Y), nf = nf, lw = ktabX$lw, X.cw = ktabX$cw, blo = ktabX$blo, rank = maxdim, eig = rep(0, maxdim), TL = ktabX$TL, TC = ktabX$TC)
+
+ res$Yc1 <- matrix(0, nrow = ncolY, ncol = maxdim, dimnames = list(colnames(dudiY$tab), dimlab))
+ res$lX <- res$lY <- matrix(0, nrow = nr, ncol = maxdim, dimnames = list(row.names(dudiY$tab), dimlab))
+ res$cov2 <- Ak <- matrix(0, nrow = nblo, ncol = maxdim, dimnames = list(names(ktabX$blo), dimlab))
+ res$Tfa <- lapply(1:nblo, function(k) matrix(0, nrow = ncol(Xk[[k]]), ncol = maxdim, dimnames = list(colnames(Xk[[k]]), dimlab)))
+ res$Tli <- res$Tl1 <- rep(list(matrix(0, nrow = nr, ncol = maxdim, dimnames = list(row.names(dudiY$tab), dimlab))), nblo)
+ res$faX <- matrix(0, nrow = ncolX, ncol = maxdim, dimnames = list(col.names(ktabX), dimlab))
+ lX1 <- res$lX
+ W <- res$faX
+
+ ##-----------------------------------------------------------------------
+ ## Compute components and loadings by an iterative algorithm
+ ##-----------------------------------------------------------------------
+
+ Y <- as.matrix(Y)
+ X <- as.matrix(X)
+
+ f1 <- function(x) lm.wfit(x = x, y = Y, w = res$lw)$fitted.values
+
+ for(h in 1 : maxdim) {
+
+ ## iterative algorithm
+
+ ## Compute the matrix M for the eigenanalysis
+ M <- lapply(lapply(Xk, f1), function (x) crossprod(x * sqrt(res$lw)))
+ M <- Reduce("+", M)
+
+ ## Compute the loadings V and the components U (Y dataset)
+ eig.M <- eigen(M)
+
+ if (eig.M$values[1] < sqrt(.Machine$double.eps)) {
+ res$rank <- h-1 ## update the rank
+ break
+ }
+
+ res$eig[h] <- eig.M$values[1]
+ res$Yc1[, h] <- eig.M$vectors[, 1, drop = FALSE]
+ res$lY[, h] <- Y %*% res$Yc1[, h]
+
+ ## Compute the loadings Wk and the components Tk (Xk datasets)
+
+ covutcarre <- 0
+ covutk <- rep(0, nblo)
+ for (k in 1 : nblo) {
+ lm1 <- lm.wfit(x = Xk[[k]], y = res$lY[, h], w = res$lw)
+ res$Tfa[[k]][, h] <- lm1$coefficients / sqrt(sum(res$lw * lm1$fitted.values^2))
+ res$Tl1[[k]][, h] <- scalewt(lm1$fitted.values, wt = res$lw)
+ res$Tli[[k]][, h] <- lm1$fitted.values
+
+ covutk[k] <- crossprod(res$lY[, h] * res$lw, res$Tl1[[k]][, h])
+ res$cov2[k, h] <- covutk[k]^2
+ covutcarre <- covutcarre + res$cov2[k, h]
+ }
+
+ for(k in 1 : nblo) {
+ Ak[k, h] <- covutk[k] / sqrt(sum(res$cov2[,h]))
+ res$lX[, h] <- res$lX[, h] + Ak[k, h] * res$Tl1[[k]][, h]
+ }
+
+ lX1[, h] <- res$lX[, h] / sqrt(sum(res$lX[, h]^2))
+
+ ## use ginv to avoid NA in coefficients (collinear system)
+ W[, h] <- tcrossprod(MASS::ginv(crossprod(X)), X) %*% res$lX[, h]
+
+ ## Deflation of the Xk datasets on the global components T
+ Xk <- lapply(Xk, function(y) lm.wfit(x = as.matrix(res$lX[, h]), y = y, w = res$lw)$residuals)
+ X <- as.matrix(cbind.data.frame(Xk))
+ }
+
+ ##-----------------------------------------------------------------------
+ ## Compute regressions coefficients
+ ##-----------------------------------------------------------------------
+
+ ## Use of the original (and not the deflated) datasets X and Y
+ X <- as.matrix(res$tabX)
+ Y <- as.matrix(res$tabY)
+
+ ## Computing the regression coefficients of X onto the global components T (Wstar)
+ ## res$faX <- lm.wfit(x = X, y = res$lX, w = res$lw)$coefficients ## lm is not used to avoid NA coefficients in the case of not full rank matrices
+ res$faX[, 1] <- W[, 1, drop = FALSE]
+ A <- diag(ncolX)
+ if(maxdim >= 2){
+ for(h in 2:maxdim){
+ a <- crossprod(lX1[, h-1], X) / sqrt(sum(res$lX[, h-1]^2))
+ A <- A %*% (diag(ncolX) - W[, h-1] %*% a)
+ res$faX[, h] <- A %*% W[, h]
+ X <- X - tcrossprod(lX1[, h-1]) %*% X
+ }
+ }
+
+ ## Computing the regression coefficients of X onto Y (Beta)
+ res$Yco <- t(Y) %*% diag(res$lw) %*% res$lX
+ norm.li <- diag(crossprod(res$lX * sqrt(res$lw)))
+ ##res$C <- t(lm.wfit(x = res$lX, y = Y, w = res$lw)$coefficients)
+ ##res$XYcoef <- lapply(1:ncolY, function(x) t(apply(sweep(res$faX, 2 , res$C[x,], "*"), 1, cumsum)))
+ res$XYcoef <- lapply(1:ncolY, function(x) t(apply(sweep(res$faX, 2 , res$Yco[x,] / norm.li, "*"), 1, cumsum)))
+ names(res$XYcoef) <- colnames(dudiY$tab)
+
+ ## Computing the intercept
+ X <- cbind.data.frame(lapply(unclass(ktabX)[1 : nblo], scalewt, wt = dudiY$lw, center = FALSE, scale = scale))
+ if (any(apply(X, 2, weighted.mean, w = dudiY$lw) < sqrt(.Machine$double.eps)) == FALSE & scale == TRUE) {
+ ## i.e. center=F, scale=T
+ meanY <- apply(sweep(as.matrix(dudiY$tab), 2, sqrt(apply(dudiY$tab, 2, varwt, wt = dudiY$lw)), "/"), 2, weighted.mean, w = dudiY$lw)
+ meanX <- apply(sweep(as.matrix(X), 2, sqrt(apply(X, 2, varwt, wt = dudiY$lw)), "/"), 2, weighted.mean, w = dudiY$lw)
+ } else {
+ meanY <- apply(as.matrix(dudiY$tab), 2, weighted.mean, w = dudiY$lw)
+ meanX <- apply(as.matrix(X), 2, weighted.mean, w = dudiY$lw)
+ }
+ res$intercept <- lapply(1:ncolY, function(x) (meanY[x] - meanX %*% res$XYcoef[[x]]))
+ names(res$intercept) <- colnames(dudiY$tab)
+
+ ##-----------------------------------------------------------------------
+ ## Variable and block importances
+ ##-----------------------------------------------------------------------
+
+ ## Block importances
+ res$bip <- Ak^2
+
+ if (nblo == 1 | res$rank ==1)
+ res$bipc <- res$bip
+ else
+ res$bipc <- t(sweep(apply(sweep(res$bip, 2, res$eig, "*") , 1, cumsum), 1, cumsum(res$eig), "/"))
+
+ ## Variable importances
+ WcarreAk <- res$faX^2 * res$bip[rep(1:nblo, ktabX$blo),]
+ res$vip <- sweep(WcarreAk, 2, colSums(WcarreAk), "/")
+ if (nblo == 1 | res$rank ==1)
+ res$vipc <- res$vip
+ else
+ res$vipc <- t(sweep(apply(sweep(res$vip, 2, res$eig, "*") , 1, cumsum), 1, cumsum(res$eig), "/"))
+
+ ##-----------------------------------------------------------------------
+ ## Modify the outputs
+ ##-----------------------------------------------------------------------
+
+ if (scannf == TRUE){
+ barplot(res$eig[1:res$rank])
+ cat("Select the number of global components: ")
+ res$nf <- as.integer(readLines(n = 1))
+ }
+
+ if(res$nf > res$rank)
+ res$nf <- res$rank
+
+ ## keep results for the nf dimensions (except eigenvalues and lX)
+ res$eig <- res$eig[1:res$rank]
+ res$lX <- res$lX[, 1:res$rank]
+ res$Tfa <- do.call("rbind", res$Tfa)
+ res$Tl1 <- do.call("rbind", res$Tl1)
+ res$Tli <- do.call("rbind", res$Tli)
+ res <- modifyList(res, lapply(res[c("Yc1", "Yco", "lY", "Tfa", "Tl1", "Tli", "cov2", "faX", "vip", "vipc", "bip", "bipc")], function(x) x[, 1:res$nf, drop = FALSE]))
+ res$XYcoef <- lapply(res$XYcoef, function(x) x[, 1:res$nf, drop = FALSE])
+ res$intercept <- lapply(res$intercept, function(x) x[, 1:res$nf, drop = FALSE])
+ res$call <- match.call()
+ class(res) <- c("multiblock", "mbpcaiv")
+ return(res)
+}
+
+
diff --git a/R/mbpls.R b/R/mbpls.R
new file mode 100644
index 0000000..f1f2a16
--- /dev/null
+++ b/R/mbpls.R
@@ -0,0 +1,239 @@
+mbpls <- function(dudiY, ktabX, scale = TRUE, option = c("uniform", "none"), scannf = TRUE, nf = 2) {
+
+ ## -------------------------------------------------------------------------------
+ ## Some tests
+ ##--------------------------------------------------------------------------------
+
+ if (!inherits(dudiY, "dudi"))
+ stop("object 'dudi' expected")
+ if (!inherits(ktabX, "ktab"))
+ stop("object 'ktab' expected")
+ if (any(row.names(ktabX) != row.names(dudiY$tab)))
+ stop("ktabX and dudiY must have the same rows")
+ if (!(all.equal(ktabX$lw/sum(ktabX$lw), dudiY$lw/sum(dudiY$lw))))
+ stop("ktabX and dudiY must have the same row weights")
+ if (nrow(dudiY$tab) < 6)
+ stop("Minimum six rows are required")
+ if (any(ktabX$blo < 2))
+ stop("Minimum two variables per explanatory block are required")
+ if (!(is.logical(scale)))
+ stop("Non convenient selection for scaling")
+ if (!(is.logical(scannf)))
+ stop("Non convenient selection for scannf")
+ if (nf < 0)
+ nf <- 2
+
+ ## Only works with centred pca (dudi.pca with center=TRUE) with uniform row weights
+ #if (!any(dudi.type(dudiY$call) == c(3,4)))
+ # stop("Only implemented for centred pca")
+
+ # Vérifier la formule / arrondi
+ #if (any(dudiY$lw != 1/nrow(dudiY$tab)))
+ # stop("Only implemented for uniform row weights")
+
+ option <- match.arg(option)
+
+ ## -------------------------------------------------------------------------------
+ ## Arguments and data transformation
+ ## -------------------------------------------------------------------------------
+
+ ## Preparation of the data frames
+ Y <- scalewt(as.matrix(dudiY$tab), wt = dudiY$lw, center = TRUE, scale = scale)
+ nblo <- length(ktabX$blo)
+ Xk <- lapply(unclass(ktabX)[1 : nblo], scalewt, wt = ktabX$lw, center = TRUE, scale = scale)
+
+ nr <- nrow(Y)
+ ncolY <- ncol(Y)
+
+ ## Block weighting
+ if (option[1] == "uniform"){
+ Y <- Y / sqrt(sum(dudiY$eig)) ## Here we use biased variance. We should use Y <- Y / sqrt(nr/(nr-1)*sum(dudiY$eig)) for unbiased estimators
+ for (k in 1 : nblo){
+ Xk[[k]] <- Xk[[k]] / sqrt((nblo/nr) * sum(diag(crossprod(Xk[[k]])))) ## same : Xk[[k]] <- Xk[[k]] / sqrt((nblo/(nr-1)) * sum(diag(crossprod(Xk[[k]])))) for unbiased estimators
+ }
+ }
+
+ X <- cbind.data.frame(Xk)
+ colnames(X) <- col.names(ktabX)
+ ncolX <- ncol(X)
+
+ maxdim <- qr(X)$rank
+
+ ##-----------------------------------------------------------------------
+ ## Prepare the outputs
+ ##-----------------------------------------------------------------------
+
+ ## Yc1 (V in Bougeard et al): was c1
+ ## lY (U): was ls
+ ## Ajout: de Yco (cov(Y, lX)) -> norme total = eig
+
+ ## lX (T): was li
+ ## faX (W*): was Wstar
+
+ ## TlX (Tk): was Tk
+ ## Tfa (Wk): was Wk Tc1 !!!!!!!!!
+ ## Ajout: cov2 (cov^2(lY, Tl1))
+ ## XYcoef: (Beta) was beta
+
+ ## bip, bipc
+ ## vip, vipc
+
+ ## Suppression: W
+ ## Suppression: l1
+ ## Suppression de C (remplacé par Yco)
+ ## Suppression de Ak (remplacé par cov2)
+
+ dimlab <- paste("Ax", 1:maxdim, sep = "")
+ res <- list(tabX = X, tabY = as.data.frame(Y), nf = nf, lw = ktabX$lw, X.cw = ktabX$cw, blo = ktabX$blo, rank = maxdim, eig = rep(0, maxdim), TL = ktabX$TL, TC = ktabX$TC)
+
+ res$Yc1 <- matrix(0, nrow = ncolY, ncol = maxdim, dimnames = list(colnames(dudiY$tab), dimlab))
+ res$lX <- res$lY <- matrix(0, nrow = nr, ncol = maxdim, dimnames = list(row.names(dudiY$tab), dimlab))
+ res$cov2 <- Ak <- matrix(0, nrow = nblo, ncol = maxdim, dimnames = list(names(ktabX$blo), dimlab))
+ res$Tc1 <- lapply(1:nblo, function(k) matrix(0, nrow = ncol(Xk[[k]]), ncol = maxdim, dimnames = list(colnames(Xk[[k]]), dimlab)))
+ res$TlX <- rep(list(matrix(0, nrow = nr, ncol = maxdim, dimnames = list(row.names(dudiY$tab), dimlab))), nblo)
+ res$faX <- matrix(0, nrow = ncolX, ncol = maxdim, dimnames = list(col.names(ktabX), dimlab))
+ lX1 <- res$lX
+ W <- res$faX
+ ##-----------------------------------------------------------------------
+ ## Compute components and loadings by an iterative algorithm
+ ##-----------------------------------------------------------------------
+
+ Y <- as.matrix(Y)
+ X <- as.matrix(X)
+
+ f1 <- function(x) crossprod(x * res$lw, Y)
+
+ for(h in 1 : maxdim) {
+
+ ## iterative algorithm
+
+ ## Compute the matrix M for the eigenanalysis
+ M <- lapply(lapply(Xk, f1), crossprod)
+ M <- Reduce("+", M)
+
+ ## Compute the loadings V and the components U (Y dataset)
+ eig.M <- eigen(M)
+
+ if (eig.M$values[1] < sqrt(.Machine$double.eps)) {
+ res$rank <- h-1 ## update the rank
+ break
+ }
+
+ res$eig[h] <- eig.M$values[1]
+ res$Yc1[, h] <- eig.M$vectors[, 1, drop = FALSE]
+ res$lY[, h] <- Y %*% res$Yc1[, h]
+
+ ## Compute the loadings Wk and the components Tk (Xk datasets)
+
+ covutk <- rep(0, nblo)
+ for (k in 1 : nblo) {
+ res$Tc1[[k]][, h] <- crossprod(Xk[[k]] * res$lw, res$lY[, h])
+ res$Tc1[[k]][, h] <- res$Tc1[[k]][, h] / sqrt(sum(res$Tc1[[k]][, h]^2))
+ res$TlX[[k]][, h] <- Xk[[k]] %*% res$Tc1[[k]][, h]
+
+ covutk[k] <- crossprod(res$lY[, h] * res$lw, res$TlX[[k]][, h])
+ res$cov2[k, h] <- covutk[k]^2
+ }
+
+ for(k in 1 : nblo) {
+ Ak[k, h] <- covutk[k] / sqrt(sum(res$cov2[,h]))
+ res$lX[, h] <- res$lX[, h] + Ak[k, h] * res$TlX[[k]][, h]
+ }
+
+ lX1[, h] <- res$lX[, h] / sqrt(sum(res$lX[, h]^2))
+ ## use ginv to avoid NA in coefficients (collinear system)
+ W[, h] <- tcrossprod(MASS::ginv(crossprod(X)), X) %*% res$lX[, h]
+
+ ## Deflation of the Xk datasets on the global components T
+ Xk <- lapply(Xk, function(y) lm.wfit(x = as.matrix(res$lX[, h]), y = y, w = res$lw)$residuals)
+ X <- as.matrix(cbind.data.frame(Xk))
+ }
+
+ ##-----------------------------------------------------------------------
+ ## Compute regressions coefficients
+ ##-----------------------------------------------------------------------
+
+ ## Use of the original (and not the deflated) datasets X and Y
+ X <- as.matrix(res$tabX)
+ Y <- as.matrix(res$tabY)
+
+ ## Computing the regression coefficients of X onto the global components T (Wstar)
+ ## res$faX <- lm.wfit(x = X, y = res$lX, w = res$lw)$coefficients ## lm is not used to avoid NA coefficients in the case of not full rank matrices
+ res$faX[, 1] <- W[, 1, drop = FALSE]
+ A <- diag(ncolX)
+ if(maxdim >= 2){
+ for(h in 2:maxdim){
+ a <- crossprod(lX1[, h-1], X) / sqrt(sum(res$lX[, h-1]^2))
+ A <- A %*% (diag(ncolX) - W[, h-1] %*% a)
+ res$faX[, h] <- A %*% W[, h]
+ X <- X - tcrossprod(lX1[, h-1]) %*% X
+ }
+ }
+ ## Computing the regression coefficients of X onto Y (Beta)
+ res$Yco <- t(Y) %*% diag(res$lw) %*% res$lX
+ norm.li <- diag(crossprod(res$lX * sqrt(res$lw)))
+ ##res$C <- t(lm.wfit(x = res$lX, y = Y, w = res$lw)$coefficients)
+ ##res$XYcoef <- lapply(1:ncolY, function(x) t(apply(sweep(res$faX, 2 , res$C[x,], "*"), 1, cumsum)))
+ res$XYcoef <- lapply(1:ncolY, function(x) t(apply(sweep(res$faX, 2 , res$Yco[x,] / norm.li, "*"), 1, cumsum)))
+ names(res$XYcoef) <- colnames(dudiY$tab)
+
+ ## Computing the intercept
+ X <- cbind.data.frame(lapply(unclass(ktabX)[1 : nblo], scalewt, wt = dudiY$lw, center = FALSE, scale = scale))
+ if (any(apply(X, 2, weighted.mean, w = dudiY$lw) < sqrt(.Machine$double.eps)) == FALSE & scale == TRUE) {
+ ## i.e. center=F, scale=T
+ meanY <- apply(sweep(as.matrix(dudiY$tab), 2, sqrt(apply(dudiY$tab, 2, varwt, wt = dudiY$lw)), "/"), 2, weighted.mean, w = dudiY$lw)
+ meanX <- apply(sweep(as.matrix(X), 2, sqrt(apply(X, 2, varwt, wt = dudiY$lw)), "/"), 2, weighted.mean, w = dudiY$lw)
+ } else {
+ meanY <- apply(as.matrix(dudiY$tab), 2, weighted.mean, w = dudiY$lw)
+ meanX <- apply(as.matrix(X), 2, weighted.mean, w = dudiY$lw)
+ }
+ res$intercept <- lapply(1:ncolY, function(x) (meanY[x] - meanX %*% res$XYcoef[[x]]))
+ names(res$intercept) <- colnames(dudiY$tab)
+
+ ##-----------------------------------------------------------------------
+ ## Variable and block importances
+ ##-----------------------------------------------------------------------
+
+ ## Block importances
+ res$bip <- Ak^2
+
+ if (nblo == 1 | res$rank ==1)
+ res$bipc <- res$bip
+ else
+ res$bipc <- t(sweep(apply(sweep(res$bip, 2, res$eig, "*") , 1, cumsum), 1, cumsum(res$eig), "/"))
+
+ ## Variable importances
+ WcarreAk <- res$faX^2 * res$bip[rep(1:nblo, ktabX$blo),]
+ res$vip <- sweep(WcarreAk, 2, colSums(WcarreAk), "/")
+ if (nblo == 1 | res$rank ==1)
+ res$vipc <- res$vip
+ else
+ res$vipc <- t(sweep(apply(sweep(res$vip, 2, res$eig, "*") , 1, cumsum), 1, cumsum(res$eig), "/"))
+
+ ##-----------------------------------------------------------------------
+ ## Modify the outputs
+ ##-----------------------------------------------------------------------
+
+ if (scannf == TRUE){
+ barplot(res$eig[1:res$rank])
+ cat("Select the number of global components: ")
+ res$nf <- as.integer(readLines(n = 1))
+ }
+
+ if(res$nf > res$rank)
+ res$nf <- res$rank
+
+ ## keep results for the nf dimensions (except eigenvalues and lX)
+ res$eig <- res$eig[1:res$rank]
+ res$lX <- res$lX[, 1:res$rank]
+ res$Tc1 <- do.call("rbind", res$Tc1)
+ res$TlX <- do.call("rbind", res$TlX)
+
+ res <- modifyList(res, lapply(res[c("Yc1", "Yco", "lY", "Tc1", "TlX", "cov2", "faX", "vip", "vipc", "bip", "bipc")], function(x) x[, 1:res$nf, drop = FALSE]))
+ res$XYcoef <- lapply(res$XYcoef, function(x) x[, 1:res$nf, drop = FALSE])
+ res$intercept <- lapply(res$intercept, function(x) x[, 1:res$nf, drop = FALSE])
+ res$call <- match.call()
+ class(res) <- c("multiblock", "mbpls")
+ return(res)
+}
+
diff --git a/R/mcoa.R b/R/mcoa.R
new file mode 100644
index 0000000..db891d6
--- /dev/null
+++ b/R/mcoa.R
@@ -0,0 +1,331 @@
+"mcoa" <- function (X, option = c("inertia", "lambda1", "uniform", "internal"),
+ scannf = TRUE, nf = 3, tol = 1e-07)
+{
+ if (!inherits(X, "ktab"))
+ stop("object 'ktab' expected")
+ option <- option[1]
+ if (option == "internal") {
+ if (is.null(X$tabw)) {
+ warning("Internal weights not found: uniform weigths are used")
+ option <- "uniform"
+ }
+ }
+ lw <- X$lw
+ nlig <- length(lw)
+ cw <- X$cw
+ ncol <- length(cw)
+ nbloc <- length(X$blo)
+ indicablo <- X$TC[, 1]
+ veclev <- levels(X$TC[,1])
+ Xsepan <- sepan(X, nf = 4)
+ rank.fac <- factor(rep(1:nbloc, Xsepan$rank))
+ tabw <- NULL
+ auxinames <- ktab.util.names(X)
+ if (option == "lambda1") {
+ for (i in 1:nbloc) tabw <- c(tabw, 1/Xsepan$Eig[rank.fac == i][1])
+ }
+ else if (option == "inertia") {
+ for (i in 1:nbloc) tabw <- c(tabw, 1/sum(Xsepan$Eig[rank.fac == i]))
+ }
+ else if (option == "uniform") {
+ tabw <- rep(1, nbloc)
+ }
+ else if (option == "internal")
+ tabw <- X$tabw
+ else stop("Unknown option")
+ for (i in 1:nbloc) X[[i]] <- X[[i]] * sqrt(tabw[i])
+ Xsepan <- sepan(X, nf = 4)
+ normaliserparbloc <- function(scorcol) {
+ for (i in 1:nbloc) {
+ w1 <- scorcol[indicablo == veclev[i]]
+ w2 <- sqrt(sum(w1 * w1))
+ if (w2 > tol)
+ w1 <- w1/w2
+ scorcol[indicablo == veclev[i]] <- w1
+ }
+ return(scorcol)
+ }
+ recalculer <- function(tab, scorcol) {
+ for (k in 1:nbloc) {
+ soustabk <- tab[, indicablo == veclev[k]]
+ uk <- scorcol[indicablo == veclev[k]]
+ soustabk.hat <- t(apply(soustabk, 1, function(x) sum(x *
+ uk) * uk))
+ soustabk <- soustabk - soustabk.hat
+ tab[, indicablo == veclev[k]] <- soustabk
+ }
+ return(tab)
+ }
+ tab <- as.matrix(X[[1]])
+ for (i in 2:nbloc) {
+ tab <- cbind(tab, X[[i]])
+ }
+ names(tab) <- auxinames$col
+ tab <- tab * sqrt(lw)
+ tab <- t(t(tab) * sqrt(cw))
+ compogene <- list()
+ uknorme <- list()
+ valsing <- NULL
+ nfprovi <- min(c(20, nlig, ncol))
+ for (i in 1:nfprovi) {
+ af <- svd(tab)
+ w <- af$u[, 1]
+ w <- w/sqrt(lw)
+ compogene[[i]] <- w
+ w <- af$v[, 1]
+ w <- normaliserparbloc(w)
+ tab <- recalculer(tab, w)
+ w <- w/sqrt(cw)
+ uknorme[[i]] <- w
+ w <- af$d[1]
+ valsing <- c(valsing, w)
+ }
+ pseudoeig <- valsing^2
+ if (scannf) {
+ barplot(pseudoeig)
+ cat("Select the number of axes: ")
+ nf <- as.integer(readLines(n = 1))
+ }
+ if (nf <= 0)
+ nf <- 2
+ acom <- list()
+ acom$pseudoeig <- pseudoeig
+ w <- matrix(0, nbloc, nf)
+ for (i in 1:nbloc) {
+ w1 <- Xsepan$Eig[rank.fac == i]
+ r0 <- Xsepan$rank[i]
+ if (r0 > nf)
+ r0 <- nf
+ w[i, 1:r0] <- w1[1:r0]
+ }
+ w <- data.frame(w)
+ row.names(w) <- Xsepan$tab.names
+ names(w) <- paste("lam", 1:nf, sep = "")
+ acom$lambda <- w
+ w <- matrix(0, nlig, nf)
+ for (j in 1:nf) w[, j] <- compogene[[j]]
+ w <- data.frame(w)
+ names(w) <- paste("SynVar", 1:nf, sep = "")
+ row.names(w) <- row.names(X)
+ acom$SynVar <- w
+ w <- matrix(0, ncol, nf)
+ for (j in 1:nf) w[, j] <- uknorme[[j]]
+ w <- data.frame(w)
+ names(w) <- paste("Axis", 1:nf, sep = "")
+ row.names(w) <- auxinames$col
+ acom$axis <- w
+ w <- matrix(0, nlig * nbloc, nf)
+ covar <- matrix(0, nbloc, nf)
+ i1 <- 0
+ i2 <- 0
+ for (k in 1:nbloc) {
+ i1 <- i2 + 1
+ i2 <- i2 + nlig
+ urk <- as.matrix(acom$axis[indicablo == veclev[k], ])
+ tab <- as.matrix(X[[k]])
+ urk <- urk * cw[indicablo == veclev[k]]
+ urk <- tab %*% urk
+ w[i1:i2, ] <- urk
+ urk <- urk * acom$SynVar * lw
+ covar[k, ] <- apply(urk, 2, sum)
+ }
+ w <- data.frame(w, row.names = auxinames$row)
+ names(w) <- paste("Axis", 1:nf, sep = "")
+ acom$Tli <- w
+ covar <- data.frame(covar)
+ row.names(covar) <- tab.names(X)
+ names(covar) <- paste("cov2", 1:nf, sep = "")
+ acom$cov2 <- covar^2
+ w <- matrix(0, nlig * nbloc, nf)
+ i1 <- 0
+ i2 <- 0
+ for (k in 1:nbloc) {
+ i1 <- i2 + 1
+ i2 <- i2 + nlig
+ tab <- acom$Tli[i1:i2, ]
+ tab <- as.matrix(sweep(tab, 2, sqrt(colSums((tab*sqrt(lw))^2)), "/"))
+ w[i1:i2, ] <- tab
+ }
+ w <- data.frame(w, row.names = auxinames$row)
+ names(w) <- paste("Axis", 1:nf, sep = "")
+ acom$Tl1 <- w
+ w <- matrix(0, ncol, nf)
+ i1 <- 0
+ i2 <- 0
+ for (k in 1:nbloc) {
+ i1 <- i2 + 1
+ i2 <- i2 + ncol(X[[k]])
+ urk <- as.matrix(acom$SynVar)
+ tab <- as.matrix(X[[k]])
+ urk <- urk * lw
+ w[i1:i2, ] <- t(tab) %*% urk
+ }
+ w <- data.frame(w, row.names = auxinames$col)
+ names(w) <- paste("SV", 1:nf, sep = "")
+ acom$Tco <- w
+ var.names <- NULL
+ w <- matrix(0, nbloc * 4, nf)
+ i1 <- 0
+ i2 <- 0
+ for (k in 1:nbloc) {
+ i1 <- i2 + 1
+ i2 <- i2 + 4
+ urk <- as.matrix(acom$axis[indicablo == veclev[k], ])
+ tab <- as.matrix(Xsepan$C1[indicablo == veclev[k], ])
+ urk <- urk * cw[indicablo == veclev[k]]
+ tab <- t(tab) %*% urk
+ for (i in 1:min(nf, 4)) {
+ if (tab[i, i] < 0) {
+ for (j in 1:nf) tab[i, j] <- -tab[i, j]
+ }
+ }
+ w[i1:i2, ] <- tab
+ var.names <- c(var.names, paste(Xsepan$tab.names[k],
+ ".a", 1:4, sep = ""))
+ }
+ w <- data.frame(w, row.names = auxinames$tab)
+ names(w) <- paste("Axis", 1:nf, sep = "")
+ acom$Tax <- w
+ acom$nf <- nf
+ acom$TL <- X$TL
+ acom$TC <- X$TC
+ acom$T4 <- X$T4
+ class(acom) <- "mcoa"
+ acom$call <- match.call()
+ return(acom)
+}
+
+"plot.mcoa" <- function (x, xax = 1, yax = 2, eig.bottom = TRUE, ...) {
+ if (!inherits(x, "mcoa"))
+ stop("Object of type 'mcoa' expected")
+ nf <- x$nf
+ if (xax > nf)
+ stop("Non convenient xax")
+ if (yax > nf)
+ stop("Non convenient yax")
+ opar <- par(mar = par("mar"), mfrow = par("mfrow"), xpd = par("xpd"))
+ on.exit(par(opar))
+ par(mfrow = c(2, 2))
+ coolig <- x$SynVar[, c(xax, yax)]
+ for (k in 2:nrow(x$cov2)) {
+ coolig <- rbind.data.frame(coolig, x$SynVar[, c(xax,
+ yax)])
+ }
+ names(coolig) <- names(x$Tl1)[c(xax, yax)]
+ row.names(coolig) <- row.names(x$Tl1)
+ s.match(x$Tl1[, c(xax, yax)], coolig, clabel = 0,
+ sub = "Row projection", csub = 1.5, edge = FALSE)
+ s.label(x$SynVar[, c(xax, yax)], add.plot = TRUE)
+ coocol <- x$Tco[, c(xax, yax)]
+ s.arrow(coocol, sub = "Col projection", csub = 1.5)
+ valpr <- function(x) {
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ born <- par("usr")
+ w <- x$pseudoeig
+ col <- rep(grey(1), length(w))
+ col[1:nf] <- grey(0.8)
+ col[c(xax, yax)] <- grey(0)
+ l0 <- length(w)
+ xx <- seq(born[1], born[1] + (born[2] - born[1]) * l0/60,
+ le = l0 + 1)
+ w <- w/max(w)
+ w <- w * (born[4] - born[3])/4
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ if (eig.bottom)
+ m3 <- born[3]
+ else m3 <- born[4] - w[1]
+ w <- m3 + w
+ rect(xx[1], m3, xx[l0 + 1], w[1], col = grey(1))
+ for (i in 1:l0) rect(xx[i], m3, xx[i + 1], w[i], col = col[i])
+ }
+ s.corcircle(x$Tax[x$T4[, 2] == 1, ], fullcircle = FALSE,
+ sub = "First axis projection", possub = "topright", csub = 1.5)
+ valpr(x)
+ plot(x$cov2[, c(xax, yax)])
+ scatterutil.grid(0)
+ title(main = "Pseudo-eigen values")
+ par(xpd = TRUE)
+ scatterutil.eti(x$cov2[, xax], x$cov2[, yax], label = row.names(x$cov2),
+ clabel = 1)
+}
+
+"print.mcoa" <- function (x, ...) {
+ if (!inherits(x, "mcoa"))
+ stop("non convenient data")
+ cat("Multiple Co-inertia Analysis\n")
+ cat(paste("list of class", class(x)))
+ l0 <- length(x$pseudoeig)
+ cat("\n\n$pseudoeig:", l0, "pseudo eigen values\n")
+ cat(signif(x$pseudoeig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n")
+ else cat("\n")
+ cat("\n$call: ")
+ print(x$call)
+ cat("\n$nf:", x$nf, "axis saved\n\n")
+ sumry <- array("", c(11, 4), list(1:11, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$SynVar", nrow(x$SynVar), ncol(x$SynVar),
+ "synthetic scores")
+ sumry[2, ] <- c("$axis", nrow(x$axis), ncol(x$axis),
+ "co-inertia axis")
+ sumry[3, ] <- c("$Tli", nrow(x$Tli), ncol(x$Tli), "co-inertia coordinates")
+ sumry[4, ] <- c("$Tl1", nrow(x$Tl1), ncol(x$Tl1), "co-inertia normed scores")
+ sumry[5, ] <- c("$Tax", nrow(x$Tax), ncol(x$Tax), "inertia axes onto co-inertia axis")
+ sumry[6, ] <- c("$Tco", nrow(x$Tco), ncol(x$Tco), "columns onto synthetic scores")
+ sumry[7, ] <- c("$TL", nrow(x$TL), ncol(x$TL), "factors for Tli Tl1")
+ sumry[8, ] <- c("$TC", nrow(x$TC), ncol(x$TC), "factors for Tco")
+ sumry[9, ] <- c("$T4", nrow(x$T4), ncol(x$T4), "factors for Tax")
+ sumry[10, ] <- c("$lambda", nrow(x$lambda), ncol(x$lambda),
+ "eigen values (separate analysis)")
+ sumry[11, ] <- c("$cov2", nrow(x$cov2), ncol(x$cov2),
+ "pseudo eigen values (synthetic analysis)")
+
+ print(sumry, quote = FALSE)
+ cat("other elements: ")
+ if (length(names(x)) > 14)
+ cat(names(x)[15:(length(x))], "\n")
+ else cat("NULL\n")
+}
+
+"summary.mcoa" <- function (object, ...) {
+ if (!inherits(object, "mcoa"))
+ stop("non convenient data")
+ cat("Multiple Co-inertia Analysis\n")
+ appel <- as.list(object$call)
+ X <- eval.parent(appel$X)
+ lw <- sqrt(X$lw)
+ cw <- X$cw
+ ncol <- length(cw)
+ nbloc <- length(X$blo)
+ nf <- object$nf
+ for (i in 1:nbloc) {
+ cat("Array number", i, names(X)[[i]], "Rows", nrow(X[[i]]),
+ "Cols", ncol(X[[i]]), "\n")
+ eigval <- unlist(object$lambda[i, ])
+ eigval <- zapsmall(eigval)
+ eigvalplus <- zapsmall(cumsum(eigval))
+ w <- object$Tli[object$TL[, 1] == levels(object$TL[,1])[i], ]
+ w <- w * lw
+ varproj <- zapsmall(apply(w * w, 2, sum))
+ varprojplus <- zapsmall(cumsum(varproj))
+ w1 <- object$SynVar
+ w1 <- w1 * lw
+ cos2 <- apply(w * w1, 2, sum)
+ cos2 <- cos2^2/varproj
+ cos2[is.infinite(cos2)] <- NA
+ cos2 <- zapsmall(cos2)
+ sumry <- array("", c(nf, 6), list(1:nf, c("Iner", "Iner+",
+ "Var", "Var+", "cos2", "cov2")))
+ sumry[, 1] <- round(eigval, digits = 3)
+ sumry[, 2] <- round(eigvalplus, digits = 3)
+ sumry[, 3] <- round(varproj, digits = 3)
+ sumry[, 4] <- round(varprojplus, digits = 3)
+ sumry[, 5] <- round(cos2, digits = 3)
+ sumry[, 6] <- round(object$cov2[i, ], digits = 3)
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ }
+}
diff --git a/R/mdpcoa.R b/R/mdpcoa.R
new file mode 100644
index 0000000..b7b04ef
--- /dev/null
+++ b/R/mdpcoa.R
@@ -0,0 +1,226 @@
+mdpcoa <- function(msamples, mdistances = NULL, method = c("mcoa", "statis", "mfa"), option = c("inertia", "lambda1", "uniform", "internal"), scannf = TRUE, nf = 3, full = TRUE, nfsep = NULL, tol = 1e-07)
+{
+ if(!is.null(mdistances)){
+ if(length(msamples) != length(mdistances)) stop("uncorrect data")
+ }
+ method <- method[1]
+ nbloci <- length(msamples)
+ npop <- ncol(msamples[[1]])
+ if(nbloci == 1) stop("multiloci data are needed")
+ if(any(nfsep < 2)) stop("The number of axes kept for the separated analyses should be higher than 1")
+ YesY <- list()
+ YesX <- list()
+ option <- option[1]
+ valoption <- rep(0, nbloci)
+ if (option == "internal") {
+ if (is.null(msamples$tabw) && is.null(mdistances$tabw)) {
+ warning("Internal weights not found: uniform weigths are used")
+ option <- "uniform"
+ }
+ else{
+ if (is.null(msamples$tabw) || is.null(mdistances$tabw))
+ valinternal <- c(msamples$tabw, mdistances$tabw)
+ else{
+ valinternal <- msamples$tabw
+ }
+ }
+
+ }
+ if(full == TRUE || !is.null(nfsep))
+ scansep <- FALSE
+ else
+ scansep <- TRUE
+ for(i in 1:nbloci)
+ {
+ if(!is.null(nfsep[i])){
+ nf1 <- nfsep[i]
+ }
+ else
+ nf1 <- 2
+ dpcoasep <- dpcoa(data.frame(t(msamples[[i]])), mdistances[[i]], scannf = scansep, full = full, nf = nf1, tol = tol)
+ YesY[[i]] <- dpcoasep$li
+ YesX[[i]] <- dpcoasep$dls
+
+ if (option == "lambda1")
+ valoption[i] <- 1/(dpcoasep$eig[1])
+
+ else if (option == "inertia") {
+ valoption[i] <- 1/sum(dpcoasep$eig)
+ }
+ else if (option == "uniform") {
+ valoption[i] <- 1
+ }
+ else if (option == "internal")
+ valoption[i] <- valinternal[i]
+ }
+ names(YesY) <- names(msamples)
+ names(YesX) <- names(msamples)
+
+ weig1 <- as.vector(apply(msamples[[1]], 2, sum))
+ sum1 <- sum(msamples[[1]])
+
+ for(i in 2:nbloci)
+ {
+ weig1 <- weig1 + as.vector(apply(msamples[[i]], 2, sum))
+ sum1 <- sum1 + sum(msamples[[i]])
+
+ }
+ weig1 <- weig1/sum1
+
+ YesY <- ktab.list.df(YesY, w.row = weig1, w.col = lapply(YesY, function(x) rep(1, ncol(x))))
+
+ coord <- list()
+
+ if(method == "mcoa")
+ {
+ mdpcoa1 <- mcoa(YesY, option[1], scannf = scannf, nf = nf)
+ nf <- mdpcoa1$nf
+ increm <- lapply(YesY, ncol)
+ increm <- c(0, cumsum(as.vector(unlist(increm))))
+
+ for(i in 1:nbloci)
+ {
+ X <- mdpcoa1$Tli[(1:npop) + npop * (i - 1), ]
+ norm <- apply(X * X * YesY$lw, 2, sum)
+ norm[norm <= tol * max(norm)] <- 1
+ coord[[i]] <- sqrt(valoption[i]) * (as.matrix(YesX[[i]]) %*% as.matrix(mdpcoa1$axis[(increm[i]+1):increm[i+1], ])) %*% diag(1/sqrt(norm))
+ }
+ coordX <- t(cbind.data.frame(lapply(coord,t)))
+ mdpcoa1$cosupX <- coordX
+ mdpcoa1$nX <- as.vector(unlist(lapply(YesX, nrow)))
+ class(mdpcoa1) <- c("mdpcoa", "mcoa")
+ }
+
+ if(method == "statis")
+ {
+ mdpcoa1 <- statis(YesY, scannf = scannf, nf = nf)
+ nf <- mdpcoa1$C.nf
+ coY <- list()
+ coX <- list()
+ norm <- apply(mdpcoa1$C.li * mdpcoa1$C.li * YesY$lw, 2, sum)
+ norm[norm <= tol * max(norm)] <- 1
+ for(i in 1:nbloci)
+ {
+ coY[[i]] <- as.matrix(YesY[[i]])%*%t(YesY[[i]])%*%diag(YesY$lw)%*%as.matrix(mdpcoa1$C.li[, 1:nf])%*%diag(1/norm)
+ coX[[i]] <- as.matrix(YesX[[i]])%*%t(YesY[[i]])%*%diag(YesY$lw)%*%as.matrix(mdpcoa1$C.li[, 1:nf])%*%diag(1/norm)
+ }
+ coordY <- t(cbind.data.frame(lapply(coY,t)))
+ coordX <- t(cbind.data.frame(lapply(coX,t)))
+ mdpcoa1$cosupY <- coordY
+ mdpcoa1$cosupX <- coordX
+ mdpcoa1$nX <- as.vector(unlist(lapply(YesX, nrow)))
+ class(mdpcoa1) <- c("mdpcoa", "statis")
+ }
+
+ if(method == "mfa")
+ {
+ mdpcoa1 <- mfa(YesY, option[1], scannf = scannf, nf = nf)
+ nf <- mdpcoa1$nf
+ for(i in 1:nbloci)
+ {
+ interm <- (valoption[i]* t(YesY[[i]]))
+ interm2 <- as.matrix(mdpcoa1$l1) * mdpcoa1$lw
+ coord[[i]] <- (as.matrix(YesX[[i]])%*% interm)%*% interm2
+ }
+ coordX <- t(cbind.data.frame(lapply(coord,t)))
+ mdpcoa1$nX <- as.vector(unlist(lapply(YesX, nrow)))
+ mdpcoa1$cosupX <- coordX
+ class(mdpcoa1) <- c("mdpcoa", "mfa")
+ }
+
+ return(mdpcoa1)
+
+}
+
+
+kplotX.mdpcoa <- function(object, xax = 1, yax = 2, mfrow = NULL,
+ which.tab = 1:length(object$nX), includepop = FALSE, clab = 0.7, cpoi = 0.7,
+ unique.scale = FALSE, csub = 2, possub = "bottomright")
+{
+
+
+ if (!inherits(object, "mdpcoa"))
+ stop("Object of type 'mdpcoa' expected")
+
+ opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
+
+ on.exit(par(opar))
+ if (is.null(mfrow))
+ mfrow <- n2mfrow(length(which.tab))
+ par(mfrow = mfrow)
+ if (length(which.tab) > prod(mfrow))
+ par(ask = TRUE)
+ nbloc <- length(object$nX)
+
+ increm <- rep(1:nbloc, object$nX)
+
+ nf <- ncol(object$cosupX)
+ if (xax > nf)
+ stop("Non convenient xax")
+ if (yax > nf)
+ stop("Non convenient yax")
+ cootot <- object$cosupX[, c(xax, yax)]
+ label <- TRUE
+ if(inherits(object, "mcoa"))
+ namloci <- rownames(object$cov2)
+ else
+ namloci <- object$tab.names
+ for (ianal in which.tab) {
+ coocol <- cootot[increm == ianal, ]
+ if (unique.scale)
+ s.label(cootot, clabel = 0, cpoint = 0, sub = namloci[ianal],
+ possub = possub, csub = csub)
+ else s.label(coocol, clabel = 0, cpoint = 0, sub = namloci[ianal],
+ possub = possub, csub = csub)
+ if (label)
+ s.label(coocol, clabel = ifelse(includepop, 0, clab), cpoint = cpoi, add.plot = TRUE)
+ if (includepop)
+ {
+ if(inherits(object, "mcoa"))
+ s.label(object$Tl1[object$TL[, 1] == levels(object$TL[,1])[ianal], c(xax, yax)], clabel = clab, cpoint = 0, add.plot = TRUE)
+ else if (inherits(object, "statis")){
+ npop <- nrow(object$C.li)
+ s.label(object$cosupY[(1:npop) + npop * (ianal - 1), c(xax, yax)], clabel = clab, cpoint = 0, add.plot = TRUE)
+ }
+ else if (inherits(object, "mfa")){
+ npop <- nrow(object$li)
+ s.label(object$lisup[(1:npop) + npop * (ianal - 1), c(xax, yax)], clabel = clab, cpoint = 0, add.plot = TRUE)
+ }
+ }
+ }
+
+}
+
+prep.mdpcoa <- function(dnaobj, pop, model, ...)
+{
+
+ if(!is.factor(pop)) stop("pop should be a factor")
+
+ fun1 <- function(x){
+ sam1 <- model.matrix(~ -1 + pop)
+ colnames(sam1) <- levels(pop)
+ sam1 <- as.data.frame(sam1)
+ dis1 <- ape::dist.dna(dnaobj[[x]], model[x], ...)
+ prep <- lapply(dnaobj[[x]], paste, collapse= "")
+ prep <- unlist(prep)
+ lprep <- length(prep)
+ prepind <- (1:lprep)[!duplicated(prep)]
+ fprep <- factor(prep, levels = unique(prep))
+ sam1 <- apply(sam1, 2, function(x) tapply(x, fprep, sum))
+ sam1 <- as.data.frame(sam1)
+ rownames(sam1) <- paste("a", 1:nrow(sam1), sep="")
+ dis1 <- as.dist(as.matrix(dis1)[prepind, prepind])
+ attributes(dis1)$Labels <- rownames(sam1)
+ alleleseq <- dnaobj[[x]][!duplicated(prep)]
+ names(alleleseq) <- rownames(sam1)
+ res <- list(pop = sam1, dis = dis1, alleleseq = alleleseq)
+ return(res)
+ }
+
+ sauv <- lapply(1:length(dnaobj), fun1)
+ sam <- lapply(sauv, function(x) x[[1]])
+ dis <- lapply(sauv, function(x) x[[2]])
+ alleleseq <- lapply(sauv, function(x) x[[3]])
+ names(dis) <- names(alleleseq) <- names(sam) <- names(dnaobj)
+ return(list(sam = sam, dis = dis, alleleseq = alleleseq))
+}
diff --git a/R/mfa.R b/R/mfa.R
new file mode 100644
index 0000000..70a7804
--- /dev/null
+++ b/R/mfa.R
@@ -0,0 +1,231 @@
+"mfa" <- function (X, option = c("lambda1", "inertia", "uniform", "internal"),
+ scannf = TRUE, nf = 3)
+{
+ if (!inherits(X, "ktab"))
+ stop("object 'ktab' expected")
+ if (option[1] == "internal") {
+ if (is.null(X$tabw)) {
+ warning("Internal weights not found: uniform weigths are used")
+ option <- "uniform"
+ }
+ }
+ lw <- X$lw
+ cw <- X$cw
+ sepan <- sepan(X, nf = 4)
+ nbloc <- length(sepan$blo)
+ indicablo <- factor(rep(1:nbloc, sepan$blo))
+ rank.fac <- factor(rep(1:nbloc, sepan$rank))
+ ncw <- NULL
+ tab.names <- names(X)[1:nbloc]
+ auxinames <- ktab.util.names(X)
+ option <- match.arg(option)
+ if (option == "lambda1") {
+ for (i in 1:nbloc) {
+ ncw <- c(ncw, rep(1/sepan$Eig[rank.fac == i][1],
+ sepan$blo[i]))
+ }
+ }
+ else if (option == "inertia") {
+ for (i in 1:nbloc) {
+ ncw <- c(ncw, rep(1/sum(sepan$Eig[rank.fac == i]),
+ sepan$blo[i]))
+ }
+ }
+ else if (option == "uniform")
+ ncw <- rep(1, sum(sepan$blo))
+ else if (option == "internal")
+ ncw <- rep(X$tabw, sepan$blo)
+
+ ncw <- cw * ncw
+ tab <- X[[1]]
+ for (i in 2:nbloc) {
+ tab <- cbind.data.frame(tab, X[[i]])
+ }
+ names(tab) <- auxinames$col
+ anaco <- as.dudi(tab, col.w = ncw, row.w = lw, nf = nf, scannf = scannf,
+ call = match.call(), type = "mfa")
+ nf <- anaco$nf
+ afm <- list()
+ afm$tab.names <- names(X)[1:nbloc]
+ afm$blo <- X$blo
+ afm$TL <- X$TL
+ afm$TC <- X$TC
+ afm$T4 <- X$T4
+ afm$tab <- anaco$tab
+ afm$eig <- anaco$eig
+ afm$rank <- anaco$rank
+ afm$li <- anaco$li
+ afm$l1 <- anaco$l1
+ afm$nf <- anaco$nf
+ afm$lw <- anaco$lw
+ afm$cw <- anaco$cw
+ afm$co <- anaco$co
+ afm$c1 <- anaco$c1
+ projiner <- function(xk, qk, d, z) {
+ w7 <- t(as.matrix(xk) * d) %*% as.matrix(z)
+ iner <- apply(w7 * w7 * qk, 2, sum)
+ return(iner)
+ }
+ link <- matrix(0, nbloc, nf)
+ for (k in 1:nbloc) {
+ xk <- X[[k]]
+ q <- ncw[indicablo == k]
+ link[k, ] <- projiner(xk, q, lw, anaco$l1)
+ }
+ link <- as.data.frame(link)
+ names(link) <- paste("Comp", 1:nf, sep = "")
+ row.names(link) <- tab.names
+ afm$link <- link
+ w <- matrix(0, nbloc * 4, nf)
+ i1 <- 0
+ i2 <- 0
+ matl1 <- as.matrix(afm$l1)
+ for (k in 1:nbloc) {
+ i1 <- i2 + 1
+ i2 <- i2 + 4
+ tab <- as.matrix(sepan$L1[sepan$TL[, 1] == levels(sepan$TL[,1])[k], ])
+ if (ncol(tab) > 4)
+ tab <- tab[, 1:4]
+ if (ncol(tab) < 4)
+ tab <- cbind(tab, matrix(0, nrow(tab), 4 - ncol(tab)))
+ tab <- t(tab * lw) %*% matl1
+ for (i in 1:min(nf, 4)) {
+ if (tab[i, i] < 0) {
+ for (j in 1:nf) tab[i, j] <- -tab[i, j]
+ }
+ }
+ w[i1:i2, ] <- tab
+ }
+ w <- data.frame(w)
+ names(w) <- paste("Comp", 1:nf, sep = "")
+ row.names(w) <- auxinames$tab
+ afm$T4comp <- w
+ w <- matrix(0, nrow(sepan$TL), ncol = nf)
+ i1 <- 0
+ i2 <- 0
+ for (k in 1:nbloc) {
+ i1 <- i2 + 1
+ i2 <- i2 + length(lw)
+ qk <- ncw[indicablo == k]
+ xk <- as.matrix(X[[k]])
+ w[i1:i2, ] <- (xk %*% (qk * t(xk))) %*% (matl1 * lw)
+ }
+ w <- data.frame(w)
+ row.names(w) <- auxinames$row
+ names(w) <- paste("Fac", 1:nf, sep = "")
+ afm$lisup <- w
+ afm$tabw <- X$tabw
+ afm$call <- match.call()
+ class(afm) <- c("mfa", "list")
+ return(afm)
+}
+
+
+"plot.mfa" <- function (x, xax = 1, yax = 2, option.plot = 1:4, ...) {
+ if (!inherits(x, "mfa"))
+ stop("Object of type 'mfa' expected")
+ nf <- x$nf
+ if (xax > nf)
+ stop("Non convenient xax")
+ if (yax > nf)
+ stop("Non convenient yax")
+ opar <- par(mar = par("mar"), mfrow = par("mfrow"), xpd = par("xpd"))
+ on.exit(par(opar))
+ mfrow <- n2mfrow(length(option.plot))
+ par(mfrow = mfrow)
+ for (j in option.plot) {
+ if (j == 1) {
+ coolig <- x$lisup[, c(xax, yax)]
+ s.class(coolig, fac = as.factor(x$TL[, 2]),
+ label = row.names(x$li), cellipse = 0, sub = "Row projection",
+ csub = 1.5)
+ add.scatter.eig(x$eig, x$nf, xax, yax, posi = "topleft",
+ ratio = 1/5)
+ }
+ if (j == 2) {
+ coocol <- x$co[, c(xax, yax)]
+ s.arrow(coocol, sub = "Col projection", csub = 1.5)
+ add.scatter.eig(x$eig, x$nf, xax, yax, posi = "topleft",
+ ratio = 1/5)
+ }
+ if (j == 3) {
+ s.corcircle(x$T4comp[x$T4[, 2] == levels(x$T4[,2])[1], ],
+ fullcircle = FALSE, sub = "Component projection", possub = "topright",
+ csub = 1.5)
+ add.scatter.eig(x$eig, x$nf, xax, yax, posi = "bottomleft",
+ ratio = 1/5)
+ }
+ if (j == 4) {
+ plot(x$link[, c(xax, yax)])
+ scatterutil.grid(0)
+ title(main = "Link")
+ par(xpd = TRUE)
+ scatterutil.eti(x$link[, xax], x$link[, yax],
+ label = row.names(x$link), clabel = 1)
+ }
+ if (j == 5) {
+ scatterutil.eigen(x$eig, wsel = 1:x$nf, sub = "Eigen values",
+ csub = 2, possub = "topright")
+ }
+ }
+}
+
+
+"print.mfa" <- function (x, ...) {
+ if (!inherits(x, "mfa"))
+ stop("non convenient data")
+ cat("Multiple Factorial Analysis\n")
+ cat(paste("list of class", class(x)))
+ cat("\n$call: ")
+ print(x$call)
+ cat("$nf:", x$nf, "axis-components saved\n\n")
+ sumry <- array("", c(6, 4), list(1:6, c("vector", "length",
+ "mode", "content")))
+ sumry[1, ] <- c("$tab.names", length(x$tab.names), mode(x$tab.names),
+ "tab names")
+ sumry[2, ] <- c("$blo", length(x$blo), mode(x$blo), "column number")
+ sumry[3, ] <- c("$rank", length(x$rank), mode(x$rank),
+ "tab rank")
+ sumry[4, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
+ sumry[5, ] <- c("$lw", length(x$lw), mode(x$lw), "row weights")
+ sumry[6, ] <- c("$tabw", length(x$tabw), mode(x$tabw),
+ "array weights")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(11, 4), list(1:11, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "modified array")
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates")
+ sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "row normed scores")
+ sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates")
+ sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores")
+ sumry[6, ] <- c("$lisup", nrow(x$lisup), ncol(x$lisup),
+ "row coordinates from each table")
+ sumry[7, ] <- c("$TL", nrow(x$TL), ncol(x$TL), "factors for li l1")
+ sumry[8, ] <- c("$TC", nrow(x$TC), ncol(x$TC), "factors for co c1")
+ sumry[9, ] <- c("$T4", nrow(x$T4), ncol(x$T4), "factors for T4comp")
+ sumry[10, ] <- c("$T4comp", nrow(x$T4comp), ncol(x$T4comp),
+ "component projection")
+ sumry[11, ] <- c("$link", nrow(x$link), ncol(x$link),
+ "link array-total")
+
+ print(sumry, quote = FALSE)
+ cat("other elements: ")
+ if (length(names(x)) > 19)
+ cat(names(x)[20:(length(mfa))], "\n")
+ else cat("NULL\n")
+}
+
+"summary.mfa" <- function (object, ...) {
+ if (!inherits(object, "mfa"))
+ stop("non convenient data")
+ cat("Multiple Factorial Analysis\n")
+ cat("rows:", nrow(object$tab), "columns:", ncol(object$tab))
+ l0 <- length(object$eig)
+ cat("\n\n$eig:", l0, "eigen values\n")
+ cat(signif(object$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n")
+ else cat("\n")
+}
diff --git a/R/mld.R b/R/mld.R
new file mode 100644
index 0000000..a77d429
--- /dev/null
+++ b/R/mld.R
@@ -0,0 +1,136 @@
+"mld"<- function (x, orthobas, level, na.action = c("fail", "mean"), plot=TRUE, dfxy = NULL, phylog = NULL, ...)
+{
+
+# on fait les vérifications sur x
+if (!is.numeric(x))
+ stop("x is not numeric")
+nobs <- length(x)
+if (any(is.na(x))) {
+ if (na.action == "fail")
+ stop(" missing values in 'x'")
+ else if (na.action == "mean")
+ x[is.na(x)] <- mean(na.omit(x))
+ else stop("unknown method for 'na.action'")
+ }
+
+# on fait les vérifications sur orthobas (class, dimension, orthogonalité, orthonormalité)
+if (!inherits(orthobas, "data.frame")) stop ("'orthobas' is not a data.frame")
+ if (nrow(orthobas) != nobs) stop ("non convenient dimensions")
+ if (ncol(orthobas) != (nobs-1)) stop (paste("'orthobas' has",ncol(orthobas),"columns, expected:",nobs-1))
+
+vecpro <- as.matrix(orthobas)
+
+w <- t(vecpro/nobs)%*%vecpro
+ if (any(abs(diag(w)-1)>1e-07)) {
+ stop("'orthobas' is not orthonormal for uniform weighting")
+ }
+
+diag(w) <- 0
+ if ( any( abs(as.numeric(w))>1e-07) ) stop("'orthobas' is not orthogonal for uniform weighting")
+
+# on calcule les différents vecteurs associés à la décomposition orthonormale de la variable
+
+ # si x n'est pas centrée, on la centre pour la pondération uniforme
+ if (mean(x)!=0)
+ x <- x-mean(x)
+
+ # on calcul les coefficients de corrélation entre la variable et les vecteurs de la base
+ coeff <- t(vecpro/nobs)%*%as.matrix(x)
+
+ # on calcul les vecteurs associés à la décomposition et au facteur level
+ if (!is.factor(level))
+ stop("'level' is not a factor")
+ if (length(level) != (nobs-1))
+ stop (paste("'level' has",length(level),"values, expected:",nobs-1))
+ res <- matrix(0, nrow = nobs, ncol = nlevels(level))
+ coeff <- split(coeff, level)
+ vecpro <- as.data.frame(t(vecpro))
+ vecpro <- split(vecpro, level)
+ for (i in 1:nlevels(level))
+ res[,i] <- t(vecpro[[i]])%*%as.matrix(coeff[[i]])
+ res <- as.data.frame(res)
+ names(res) <- paste("level", levels(level), sep=" ")
+
+
+# on fait les sorties graphiques si elles sont demandées: c'est pas parfait mais c'est pour donner une idée
+if (plot==TRUE){
+ # rajouter les données circulaires
+ if (is.ts(x)){
+ # pour les séries temporelles
+ u <- attributes(x)$tsp
+ tab <- ts(res, start = u[1], end = u[2], frequency = u[3])
+ tab <- ts.union(x, tab)
+ u <- range(tab)
+ opar <- par(mfrow = par("mfrow"), mar = par("mar"))
+ on.exit(par(opar))
+ mfrow <- n2mfrow(nlevels(level)+1)
+ par(mfrow = mfrow)
+ par(mar = c(2.5, 5, 1.5, 0.6))
+ plot.ts(x, ylim = u, ylab = "x", main = "multi-levels decomposition")
+ for (i in 1:nlevels(level))
+ plot(tab[,i+1], ylim = u, ylab = names(res)[i], main = "")
+ }
+
+ if (is.vector(x)){
+ if (!is.null(dfxy)){
+ # pour les données 2 D
+ opar <- par(mfrow = par("mfrow"), mar = par("mar"))
+ on.exit(par(opar))
+ mfrow <- n2mfrow(nlevels(level)+1)
+ par(mfrow = mfrow)
+ par(mar = c(0.6, 2.6, 0.6, 0.6))
+ s.value(dfxy, x, sub = "x", ...)
+ for (i in 1:nlevels(level))
+ if (max((1:(nobs-1))[level == levels(level)[i]])<(nobs/2)){
+ s.image(dfxy, res[,i])
+ s.value(dfxy, res[,i], sub = names(res)[i], add.plot=TRUE, ...)
+ }
+ else
+ s.value(dfxy, res[,i], sub = names(res)[i], ...)
+ }
+ else {
+ if (!is.null(phylog)){
+ # pour les données associées à une phylogénie
+ tab <- cbind.data.frame(x, res)
+ row.names(tab) <- names(phylog$leaves)
+ table.phylog(tab, phylog, ...)
+ }
+ else {
+ # pour les transects
+ par(mfrow = c(nlevels(level)+1,1))
+ par(mar = c(2, 5, 1.5, 0.6))
+ u <- range(cbind(x, res))
+ w <- trunc(u)
+ w <- c(w[1],0,w[2])
+ plot(x, type="h", ylim = u, axes = FALSE, ylab = "x", main = "multi-levels decomposition")
+ axis(side = 2, at = w, labels = as.character(w))
+ for (i in 1:nlevels(level)){
+ plot(res[,i], type="h", ylim = u, axes = FALSE, ylab = names(res)[i], main = "")
+ axis(side = 2, at = w, labels = as.character(w))
+ }
+ v <- seq(0, nobs, by = (nobs/10))
+ axis(side=1, at = v, labels = as.character(v))
+ }
+ }
+ }
+ }
+return(res)
+}
+
+#############################################################################
+haar2level <- function(x){
+# cette fonction calcul le facteur level pour lequel l'analyse mld correspond
+# à l'analyse mra de la library(waveslim)
+
+# on vérifie que x=2**a
+a <- log(length(x))/log(2)
+b <- floor(a)
+if ((a-b)^2>1e-10) stop ("Haar is not a power of 2")
+
+#on construit les J niveaux de décomposition
+u <- LETTERS[1:a]
+v <- rep(2,a)**(0:(a-1))
+level <- rep(u, v)
+level <- as.factor(level)
+return(level)
+}
diff --git a/R/mstree.R b/R/mstree.R
new file mode 100644
index 0000000..e29032e
--- /dev/null
+++ b/R/mstree.R
@@ -0,0 +1,17 @@
+mstree <- function(xdist, ngmax=1) {
+ if(!inherits (xdist,"dist")) stop ("Object of class 'dist' expected")
+ xdist <- as.matrix(xdist)
+ nlig=nrow(xdist)
+ xdist <- as.double(xdist)
+ if (ngmax<=1) ngmax=1
+ if (ngmax>=nlig) ngmax=1
+ ngmax=as.integer(ngmax)
+ voisi=as.double(matrix(0,nlig,nlig))
+ #MSTgraph (double *distances, int *nlig, int *ngmax, double *voisi)
+ mst = .C("MSTgraph", distances = xdist, nlig = nlig, ngmax = ngmax, voisi = voisi,PACKAGE="ade4")$voisi
+ mst = matrix(mst, nlig, nlig)
+ mst = neig (mat01=mst)
+ return(mst)
+}
+
+
diff --git a/R/multiblock.R b/R/multiblock.R
new file mode 100644
index 0000000..d3e34a8
--- /dev/null
+++ b/R/multiblock.R
@@ -0,0 +1,216 @@
+randboot.multiblock <- function(object, nrepet = 199, optdim, ...)
+
+{
+ if (!inherits(object, "multiblock"))
+ stop("Object of type 'mbpcaiv' or 'mbpls' expected")
+
+ if ((optdim < 0) | (optdim > object$rank))
+ stop("Wrong number for optimal dimension")
+
+ ## get some arguments
+ appel <- as.list(object$call)
+ method <- as.character(appel[[1]])
+ scale <- eval.parent(appel$scale)
+ option <- eval.parent(appel$option)
+ X <- eval.parent(appel$ktabX)
+ Y <- eval.parent(appel$dudiY)
+ nr <- nrow(Y$tab)
+ ncY <- ncol(Y$tab)
+ h <- object$rank
+
+ nblo <- length(object$blo) ## number of X tables
+ ncX <- sum(X$blo) ## total number of variables in X
+
+ ## prepare the outputs
+
+ res <- list()
+ res$XYcoef <- list()
+ res$XYcoef <- rep(list(matrix(0, ncol = ncX, nrow = nrepet, dimnames = list(NULL, colnames(object$tabX)))), ncY)
+
+ res$bipc <- matrix(0, ncol = nblo, nrow = nrepet)
+ colnames(res$bipc) <- names(X$blo)
+
+ res$vipc <- matrix(0, ncol = ncX, nrow = nrepet)
+ colnames(res$vipc) <- colnames(object$tabX)
+
+ ## bootstrap and outputs
+ for (i in 1 : nrepet){
+ s <- sample(x = nr, replace = TRUE)
+ Xboot <- X[, s, ]
+ Yboot <- Y[s, ]
+
+ resboot <- do.call(method, list(dudiY = Yboot, ktabX = Xboot, scale = scale, option = option, scannf = FALSE, nf = as.integer(optdim)))
+
+ for (k in 1:ncY)
+ res$XYcoef[[k]][i, ] <- resboot$XYcoef[[k]][, optdim]
+ res$bipc[i, ] <- resboot$bipc[, optdim]
+ res$vipc[i, ] <- resboot$vipc[, optdim]
+ }
+
+ thecall <- match.call()
+ res$XYcoef <- lapply(1:ncY, function(x) as.krandboot(obs = object$XYcoef[[x]][, optdim], boot = res$XYcoef[[x]], call = thecall))
+ names(res$XYcoef) <- colnames(object$tabY)
+ res$bipc <- as.krandboot(obs = object$bipc[, optdim], boot = res$bipc, call = thecall, ...)
+ res$vipc <- as.krandboot(obs = object$vipc[, optdim], boot = res$vipc, call = thecall, ...)
+
+ return(res)
+}
+
+
+
+
+testdim.multiblock <- function(object, nrepet = 100, quantiles = c(0.25, 0.75), ...){
+
+ if (!inherits(object, "multiblock"))
+ stop("Object of type 'mbpcaiv' or 'mbpls' expected")
+
+ ## get some arguments
+ appel <- as.list(object$call)
+ method <- as.character(appel[[1]])
+ scale <- eval.parent(appel$scale)
+ option <- eval.parent(appel$option)
+ X <- eval.parent(appel$ktabX)
+ Y <- eval.parent(appel$dudiY)
+ nr <- nrow(Y$tab)
+ q <- ncol(Y$tab)
+ h <- object$rank
+
+ ## prepare outputs
+ dimlab <- paste("Ax", (1 : h), sep = "")
+ RMSEV <- RMSEC <- matrix(NA, nrow = nrepet, ncol = h)
+ colnames(RMSEV) <- colnames(RMSEC) <- dimlab
+ rownames(RMSEV) <- rownames(RMSEC) <- 1:nrepet
+
+ ## Two-fold cross validation
+
+ Nc <- round(2 * nr / 3)
+ Nv <- nr - Nc
+
+ for(i in 1 : nrepet) {
+
+ ## Dividing X and Y into calibration (Xc, Yc) and validation (Xv, Yv) datasets
+ s <- sample(x = nr, size = Nc)
+ Xc <- X[, s, ]
+ Xv <- X[, -s, ]
+ Yc <- Y[s, ]
+ Yv <- Y[-s, ]
+
+ ## Applying the multiblock method to the calibration/validation datasets
+ rescal <- do.call(method, list(dudiY = Yc, ktabX = Xc, scale = scale, option = option, scannf = FALSE, nf = h))
+ resval <- do.call(method, list(dudiY = Yv, ktabX = Xv, scale = scale, option = option, scannf = FALSE, nf = h))
+
+ ## Compute Root Mean Square Errors of Calibration (RMSEC) and Validation (RMSEV)
+ nblo <- length(Xc$blo)
+ Xc.mat <- cbind.data.frame(unclass(Xc)[1:nblo])
+ Xv.mat <- cbind.data.frame(unclass(Xv)[1:nblo])
+ for(j in 1 : min(rescal$rank, resval$rank, h)){
+ XYcoef.cal <- sapply(rescal$XYcoef, function(x) x[, j])
+ intercept.cal <- sapply(rescal$intercept, function(x) x[, j])
+ residYc <- as.matrix(Yc$tab) - (matrix(rep(intercept.cal, each = Nc), ncol = q) + as.matrix(Xc.mat) %*% XYcoef.cal)
+ RMSEC[i, j] <- sqrt(sum(residYc^2) / (Nc * q))
+ residYv <- as.matrix(Yv$tab) - (matrix(rep(intercept.cal, each = Nv), ncol = q) + as.matrix(Xv.mat) %*% XYcoef.cal)
+ RMSEV[i, j] <- sqrt(sum(residYv^2) / (Nv * q))
+ }
+ }
+
+ res <- as.krandxval(RMSEC, RMSEV, call = match.call(), quantiles = quantiles)
+ return(res)
+}
+
+
+summary.multiblock <- function(object, ...) {
+
+ if (!inherits(object, "multiblock"))
+ stop("to be used with 'mbpcaiv' or 'mbpls' object")
+
+ thetitle <- ifelse(inherits(object, "mbpcaiv"), "Multiblock principal component analysis with instrumental variables",
+ "Multiblock partial least squares")
+ cat(thetitle)
+ cat("\n\n")
+ Xk <- ktab.data.frame(df = object$tabX, blocks = object$blo, tabnames = names(object$blo))
+ k <- length(object$blo)
+ h <- object$rank
+ appel <- as.list(object$call)
+
+ ## Summary for eigenvalues and inertia
+ summary.dudi(object)
+
+ ## Summary for the variances of Y and X explained by the global component (lX)
+ varT <- diag(crossprod(object$lX * object$lw, object$lX))
+
+ covarTY <- diag(tcrossprod(crossprod(object$lX * object$lw, as.matrix(object$tabY))))
+ varexplTY <- (covarTY/varT) / sum(covarTY/varT) * 100
+ varexplTYcum <- cumsum(varexplTY) / sum(varexplTY) * 100
+
+ covarTX <- diag(tcrossprod(crossprod(object$lX * object$lw, as.matrix(object$tabX))))
+ varexplTX <- (covarTX/varT) / sum(covarTX/varT) * 100
+ varexplTXcum <- cumsum(varexplTX) / sum(varexplTX) * 100
+
+ cat(paste("Inertia explained by the global latent, i.e.", deparse(substitute(object$lX)), "(in %): \n\n"))
+ sumry <- array(0, c(object$nf, 4), list(1:object$nf, c("varY", "varYcum", "varX", "varXcum")))
+ sumry[, 1] <- varexplTY[1 : object$nf]
+ sumry[, 2] <- varexplTYcum[1 : object$nf]
+ sumry[, 3] <- varexplTX[1 : object$nf]
+ sumry[, 4] <- varexplTXcum[1 : object$nf]
+ rownames(sumry) <- colnames(object$lX)[1:object$nf]
+ cat(paste(deparse(appel$dudiY), "$tab", " and ", deparse(appel$ktabX), ": \n", sep = ''))
+ print(sumry, digits = 3)
+
+ ## Summary for the variances of Xk explained by the global component (lX)
+ sumryk <- list()
+
+ for (j in 1:k) {
+ covarTXk <- diag(tcrossprod(crossprod(object$lX * object$lw, as.matrix(Xk[[j]]))))
+ varexplTXk <- (covarTXk/varT) / sum(covarTXk/varT) * 100
+ varexplTXkcum <- cumsum(varexplTXk) / sum(varexplTXk) * 100
+ sumryk[[j]] <- cbind.data.frame(varXk = varexplTXk[1 : object$nf], varXkcum = varexplTXkcum[1 : object$nf])
+ cat("\n")
+ cat(paste(names(object$blo[j])), ":\n", sep = '')
+ print(sumryk[[j]], digits = 3)
+ }
+
+ names(sumryk) <- names(object$blo)
+ res <- c(list(YandX = sumry), sumryk)
+ invisible(res)
+}
+
+
+print.multiblock <- function (x, ...)
+{
+ if (!inherits(x, "multiblock"))
+ stop("to be used with 'mbpcaiv' or 'mbpls' object")
+
+ thetitle <- ifelse(inherits(x, "mbpcaiv"), "Multiblock principal component analysis with instrumental variables",
+ "Multiblock partial least squares")
+ cat(thetitle)
+ cat(paste("\nlist of class", class(x)))
+ l0 <- length(x$eig)
+ cat("\n\n$eig:", l0, "eigen values\n")
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n")
+ else cat("\n")
+ cat("\n$call: ")
+ print(x$call)
+ cat("\n$nf:", x$nf, "axis saved\n\n")
+ showed.names <- c("nf", "call", "eig", "lX", "lY", "Tli", "Yco", "faX", "bip", "bipc", "vip", "vipc", "cov2")
+ sumry <- array("", c(10, 4), list(1:10, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$lX", nrow(x$lX), ncol(x$lX), "global components of the explanatory tables")
+ sumry[2, ] <- c("$lY", nrow(x$lY), ncol(x$lY), "components of the dependent data table")
+ sumry[3, ] <- c("$Tli", nrow(x$Tli), ncol(x$Tli), "partial components")
+ sumry[4, ] <- c("$Yco", nrow(x$Yco), ncol(x$Yco), "inertia axes onto co-inertia axis")
+ sumry[5, ] <- c("$faX", nrow(x$faX), ncol(x$faX), "loadings to build the global components")
+ sumry[6, ] <- c("$bip", nrow(x$bip), ncol(x$bip), "block importances")
+ sumry[7, ] <- c("$bipc", nrow(x$bipc), ncol(x$bipc), "cumulated block importances")
+ sumry[8, ] <- c("$vip", nrow(x$vip), ncol(x$vip), "variable importances")
+ sumry[9, ] <- c("$vipc", nrow(x$vipc), ncol(x$vipc), "cumulated variable importances")
+ sumry[10, ] <- c("$cov2", nrow(x$cov2), ncol(x$cov2), "squared covariance between components")
+ if(inherits(x, "mbpls"))
+ sumry <- sumry[-3,]
+ print(sumry, quote = FALSE)
+ cat("other elements: ")
+ cat(names(x)[!(names(x)%in%showed.names)], "\n")
+
+}
+
diff --git a/R/multispati.R b/R/multispati.R
new file mode 100644
index 0000000..bb84290
--- /dev/null
+++ b/R/multispati.R
@@ -0,0 +1,211 @@
+"multispati" <- function(dudi, listw, scannf=TRUE, nfposi=2, nfnega=0) {
+ if(!inherits(dudi,"dudi")) stop ("object of class 'dudi' expected")
+ if(!inherits(listw,"listw")) stop ("object of class 'listw' expected")
+ if(listw$style!="W") stop ("object of class 'listw' with style 'W' expected")
+ NEARZERO <- 1e-14
+
+ dudi$cw <- dudi$cw
+ fun <- function (x) spdep::lag.listw(listw,x,TRUE)
+ tablag <- apply(dudi$tab,2,fun)
+ covar <- t(tablag)%*%as.matrix((dudi$tab*dudi$lw))
+ covar <- (covar+t(covar))/2
+ covar <- covar * sqrt(dudi$cw)
+ covar <- t(t(covar) * sqrt(dudi$cw))
+ covar <- eigen(covar, symmetric = TRUE)
+ res <- list()
+ res$eig <- covar$values[abs(covar$values)>NEARZERO]
+ ndim <- length(res$eig)
+ covar$vectors <- covar$vectors[, abs(covar$values)>NEARZERO]
+
+ if (scannf) {
+ barplot(res$eig)
+ cat("Select the first number of axes (>=1): ")
+ nfposi <- as.integer(readLines(n = 1))
+
+ cat("Select the second number of axes (>=0): ")
+ nfnega <- as.integer(readLines(n = 1))
+ }
+ if (nfposi <= 0) nfposi <- 1
+ if (nfnega<=0) nfnega <- 0
+
+ if(nfposi > sum(res$eig > 0)){
+ nfposi <- sum(res$eig > 0)
+ warning(paste("There are only",sum(res$eig>0),"positive factors."))
+ }
+ if(nfnega > sum(res$eig < 0)){
+ nfnega <- sum(res$eig < 0)
+ warning(paste("There are only",sum(res$eig< 0),"negative factors."))
+ }
+ res$nfposi <- nfposi
+ res$nfnega <- nfnega
+ agarder <- c(1:nfposi,if (nfnega>0) (ndim-nfnega+1):ndim else NULL)
+ dudi$cw[which(dudi$cw == 0)] <- 1
+ auxi <- data.frame(covar$vectors[, agarder] /sqrt(dudi$cw))
+ names(auxi) <- paste("CS", agarder, sep = "")
+ row.names(auxi) <- names(dudi$tab)
+ res$c1 <- auxi
+ auxi <- as.matrix(auxi)*dudi$cw
+ auxi1 <- as.matrix(dudi$tab)%*%auxi
+ auxi1 <- data.frame(auxi1)
+ names(auxi1) <- names(res$c1)
+ row.names(auxi1) <- row.names(dudi$tab)
+ res$li <- auxi1
+ auxi1 <- as.matrix(tablag)%*%auxi
+ auxi1 <- data.frame(auxi1)
+ names(auxi1) <- names(res$c1)
+ row.names(auxi1) <- row.names(dudi$tab)
+ res$ls <- auxi1
+ auxi <- as.matrix(res$c1) * unlist(dudi$cw)
+ auxi <- data.frame(t(as.matrix(dudi$c1)) %*% auxi)
+ row.names(auxi) <- names(dudi$li)
+ names(auxi) <- names(res$li)
+ res$as <- auxi
+ res$call <- match.call()
+ class(res) <- "multispati"
+ return(res)
+}
+
+
+"summary.multispati" <- function (object, ...) {
+
+ norm.w <- function(X, w) {
+ f2 <- function(v) sum(v * v * w)/sum(w)
+ norm <- apply(X, 2, f2)
+ return(norm)
+ }
+
+ if (!inherits(object, "multispati")) stop("to be used with 'multispati' object")
+
+ cat("\nMultivariate Spatial Analysis\n")
+ cat("Call: ")
+ print(object$call)
+
+ appel <- as.list(object$call)
+ dudi <- eval.parent(appel$dudi)
+ listw <- eval.parent(appel$listw)
+
+ ## les scores de l'analyse de base
+ nf <- dudi$nf
+ eig <- dudi$eig[1:nf]
+ cum <- cumsum (dudi$eig) [1:nf]
+ ratio <- cum/sum(dudi$eig)
+ w <- apply(dudi$l1,2,spdep::lag.listw,x=listw)
+ moran <- apply(w*as.matrix(dudi$l1)*dudi$lw,2,sum)
+ res <- data.frame(var=eig,cum=cum,ratio=ratio, moran=moran)
+ cat("\nScores from the initial duality diagramm:\n")
+ print(res)
+
+ ## les scores de l'analyse spatiale
+ ## on recalcule l'objet en gardant tous les axes
+ eig <- object$eig
+ nfposi <- object$nfposi
+ nfnega <- object$nfnega
+ nfposimax <- sum(eig > 0)
+ nfnegamax <- sum(eig < 0)
+
+ ms <- multispati(dudi=dudi, listw=listw, scannf=FALSE,
+ nfposi=nfposimax, nfnega=nfnegamax)
+
+ ndim <- dudi$rank
+ nf <- nfposi + nfnega
+ agarder <- c(1:nfposi,if (nfnega>0) (ndim-nfnega+1):ndim else NULL)
+ varspa <- norm.w(ms$li,dudi$lw)
+ moran <- apply(as.matrix(ms$li)*as.matrix(ms$ls)*dudi$lw,2,sum)
+ res <- data.frame(eig=eig,var=varspa,moran=moran/varspa)
+
+ cat("\nMultispati eigenvalues decomposition:\n")
+ print(res[agarder,])
+ return(invisible(res))
+}
+
+
+
+print.multispati <- function(x, ...)
+{
+ cat("Multispati object \n")
+ cat("class: ")
+ cat(class(x))
+ cat("\n$call: ")
+ print(x$call)
+ cat("\n$nfposi:", x$nfposi, "axis-components saved")
+ cat("\n$nfnega:", x$nfnega, "axis-components saved")
+ #cat("\n$rank: ")
+ #cat(x$rank)
+ cat("\nPositive eigenvalues: ")
+ l0 <- sum(x$eig >= 0)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n")
+ else cat("\n")
+ cat("Negative eigenvalues: ")
+ l0 <- sum(x$eig <= 0)
+ cat(sort(signif(x$eig, 4))[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n")
+ else cat("\n")
+ cat('\n')
+ sumry <- array("", c(1, 4), list(1, c("vector", "length",
+ "mode", "content")))
+ sumry[1, ] <- c('$eig', length(x$eig), mode(x$eig), 'eigen values')
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(4, 4), list(1:4, c("data.frame", "nrow", "ncol", "content")))
+ sumry[1, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores")
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates")
+ sumry[3, ] <- c("$ls", nrow(x$ls), ncol(x$ls), 'lag vector coordinates')
+ sumry[4, ] <- c("$as", nrow(x$as), ncol(x$as), 'inertia axes onto multispati axes')
+
+
+ print(sumry, quote = FALSE)
+ cat("other elements: ")
+ if (length(names(x)) > 8)
+ cat(names(x)[9:(length(names(x)))], "\n")
+ else cat("NULL\n")
+}
+
+
+
+"plot.multispati" <- function (x, xax = 1, yax = 2, ...) {
+ if (!inherits(x, "multispati"))
+ stop("Use only with 'multispati' objects")
+
+ appel <- as.list(x$call)
+ dudi <- eval.parent(appel$dudi)
+ nf <- x$nfposi + x$nfnega
+ if ((nf == 1) || (xax == yax)) {
+ sco.quant(x$li[, 1], dudi$tab)
+ return(invisible())
+ }
+ if (xax > nf)
+ stop("Non convenient xax")
+ if (yax > nf)
+ stop("Non convenient yax")
+ f1 <- function ()
+ {
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ m <- length(x$eig)
+ par(mar = c(0.8, 2.8, 0.8, 0.8))
+ col.w <- rep(grey(1), m) # elles sont toutes blanches
+ col.w[1:x$nfposi] <- grey(0.8)
+ if (x$nfnega>0) col.w[m:(m-x$nfnega+1)] = grey(0.8)
+ j1 <- xax
+ if (j1>x$nfposi) j1 = j1-x$nfposi +m -x$nfnega
+ j2 <- yax
+ if (j2>x$nfposi) j2 = j2-x$nfposi +m -x$nfnega
+ col.w[c(j1,j2)] = grey(0)
+ barplot(x$eig, col = col.w)
+ scatterutil.sub(cha ="Eigen values", csub = 2, possub = "topright")
+ }
+
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ layout(matrix(c(3, 3, 1, 3, 3, 2), 3, 2))
+ par(mar = c(0.2, 0.2, 0.2, 0.2))
+ f1()
+ s.arrow(x$c1, xax = xax, yax = yax, sub = "Canonical weights",
+ csub = 2, clabel = 1.25)
+ s.match(x$li, x$ls, xax = xax, yax = yax, sub = "Scores and lag scores", csub = 2, clabel = 0.75)
+
+}
diff --git a/R/multispati.randtest.R b/R/multispati.randtest.R
new file mode 100644
index 0000000..13c8cba
--- /dev/null
+++ b/R/multispati.randtest.R
@@ -0,0 +1,35 @@
+"multispati.randtest" <- function (dudi, listw, nrepet = 999, ...) {
+ if(!inherits(dudi,"dudi")) stop ("object of class 'dudi' expected")
+ if(!inherits(listw,"listw")) stop ("object of class 'listw' expected")
+ if(listw$style!="W") stop ("object of class 'listw' with style 'W' expected")
+
+ "testmultispati"<- function(nrepet, nr, nc, tab, mat, lw, cw) {
+ .C("testmultispati",
+ as.integer(nrepet),
+ as.integer(nr),
+ as.integer(nc),
+ as.double(as.matrix(tab)),
+ as.double(mat),
+ as.double(lw),
+ as.double(cw),
+ inersim=double(nrepet+1),
+ PACKAGE="ade4")$inersim
+ }
+
+ tab<- dudi$tab
+ nr<-nrow(tab)
+ nc<-ncol(tab)
+ mat<-spdep::listw2mat(listw)
+ lw<- dudi$lw
+ cw<- dudi$cw
+ if (!(identical(all.equal(lw,rep(1/nrow(tab), nrow(tab))),TRUE))) {
+ stop ("Not implemented for non-uniform weights")
+ }
+ inersim<- testmultispati(nrepet, nr, nc, tab, mat, lw, cw)
+ inertot<- sum(dudi$eig)
+ inersim<- inersim/inertot
+ obs <- inersim[1]
+ w <- as.randtest(sim = inersim[-1], obs = obs, call = match.call(), ...)
+ return(w)
+}
+
diff --git a/R/multispati.rtest.R b/R/multispati.rtest.R
new file mode 100644
index 0000000..7ded93b
--- /dev/null
+++ b/R/multispati.rtest.R
@@ -0,0 +1,33 @@
+"multispati.rtest" <- function (dudi, listw, nrepet = 99, ...) {
+ if(!inherits(listw,"listw")) stop ("object of class 'listw' expected")
+ if(listw$style!="W") stop ("object of class 'listw' with style 'W' expected")
+ if (!(identical(all.equal(dudi$lw,rep(1/nrow(dudi$tab), nrow(dudi$tab))),TRUE))) {
+ stop ("Not implemented for non-uniform weights")
+ }
+ n <- length(listw$weights)
+ fun.lag <- function (x) spdep::lag.listw(listw,x,TRUE)
+ fun <- function (permuter = TRUE) {
+ if (permuter) {
+ permutation <- sample(n)
+ y <- dudi$tab[permutation,]
+ yw <- dudi$lw[permutation]
+ } else {
+ y <-dudi$tab
+ yw <- dudi$lw
+ }
+ y <- as.matrix(y)
+ ymoy <- apply(y, 2, fun.lag)
+ ymoy <- ymoy*yw
+ y <- y*ymoy
+ indexmoran <- sum(apply(y,2,sum)*dudi$cw)
+ return(indexmoran)
+ }
+ inertot <- sum(dudi$eig)
+ obs <- fun (permuter = FALSE)/inertot
+ if (nrepet == 0) return(obs)
+ perm <- unlist(lapply(1:nrepet, fun))/inertot
+ w <- as.randtest(obs = obs, sim = perm, call = match.call(), ...)
+ return(w)
+}
+
+
diff --git a/R/neig.R b/R/neig.R
new file mode 100644
index 0000000..b937972
--- /dev/null
+++ b/R/neig.R
@@ -0,0 +1,228 @@
+"neig" <- function (list = NULL, mat01 = NULL, edges = NULL, n.line = NULL,
+ n.circle = NULL, area = NULL)
+{
+ if (!is.null(list)) {
+ n <- length(list)
+ output <- matrix(0, n, n)
+ for (i in 1:n) {
+ w <- list[[i]]
+ if (length(w) > 0)
+ output[i, w] <- 1
+ }
+ output <- output + t(output)
+ output <- 1 * (output > 0)
+ w.output <- as.vector(apply(output, 1, sum))
+ names(w.output) <- as.character(1:n)
+ if (!is.null(attr(list, "region.id")))
+ names(w.output) <- attr(list, "region.id")
+ output <- neig.util.GtoL(output)
+ }
+ else if (!is.null(mat01)) {
+ output <- neig.util.GtoL(mat01)
+ w.output <- as.vector(apply(mat01, 1, sum))
+ if (!is.null(rownames(mat01)))
+ names(w.output) <- rownames(mat01)
+ else if (!is.null(colnames(mat01)))
+ names(w.output) <- colnames(mat01)
+ else names(w.output) <- as.character(1:(nrow(mat01)))
+ }
+ else if (!is.null(edges)) {
+ output <- edges
+ G <- neig.util.LtoG(edges)
+ w.output <- as.vector(apply(G, 1, sum))
+ names(w.output) <- as.character(1:length(w.output))
+ }
+ else if (!is.null(n.line)) {
+ output <- cbind(1:(n.line - 1), 2:n.line)
+ G <- neig.util.LtoG(output)
+ w.output <- as.vector(apply(G, 1, sum))
+ names(w.output) <- as.character(1:n.line)
+ }
+ else if (!is.null(n.circle)) {
+ output <- cbind(1:(n.circle - 1), 2:n.circle)
+ output <- rbind(output, c(n.circle, 1))
+ G <- neig.util.LtoG(output)
+ w.output <- as.vector(apply(G, 1, sum))
+ names(w.output) <- as.character(1:n.circle)
+ }
+ else if (!is.null(area)) {
+ fac <- area[, 1]
+ levpoly <- unique(fac)
+ npoly <- length(levpoly)
+ ng1 <- 0
+ ng2 <- 0
+ k <- 0
+ for (i in 1:(npoly - 1)) {
+ t1poly <- paste(area[fac == levpoly[i], 2], area[fac ==
+ levpoly[i], 3], sep = "000")
+ for (j in (i + 1):npoly) {
+ t2poly <- paste(area[fac == levpoly[j], 2], area[fac ==
+ levpoly[j], 3], sep = "000")
+ if (any(t1poly %in% t2poly)) {
+ k <- k + 1
+ ng1[k] <- i
+ ng2[k] <- j
+ }
+ }
+ }
+ output <- cbind(ng1, ng2)
+ G <- neig.util.LtoG(output)
+ w.output <- as.vector(apply(G, 1, sum))
+ names(w.output) <- as.character(levpoly)
+ }
+ attr(output, "degrees") <- w.output
+ attr(output, "call") <- match.call()
+ class(output) <- "neig"
+ output
+}
+
+"nb2neig" <- function (nb) {
+ if (!inherits(nb, "nb"))
+ stop("Non convenient data")
+ res <- neig(list = nb)
+ w <- attr(nb, "region.id")
+ if (is.null(w))
+ w <- as.character(1:length(nb))
+ names(attr(res, "degrees")) <- w
+ return(res)
+}
+
+"neig2nb" <- function (neig) {
+ if (!inherits(neig, "neig"))
+ stop("Non convenient data")
+ w1 <- attr(neig, "degrees")
+ n <- length(w1)
+ region.id <- names(w1)
+ if (is.null(region.id))
+ region.id <- as.character(1:n)
+ G <- neig.util.LtoG(neig)
+ res <- split(G, row(G))
+ res <- lapply(res, function(x) which(x > 0))
+ attr(res, "region.id") <- region.id
+ attr(res, "gal") <- FALSE
+ attr(res, "call") <- match.call()
+ class(res) <- "nb"
+ return(res)
+}
+
+"neig2mat" <- function (neig) {
+ # synonyme de neig.util.GtoL plus simple de mémorisation
+ # donne la matrice d'incidence sommet-sommet en 0-1
+ if (!inherits(neig,"neig")) stop ("Object 'neig' expected")
+ deg <- attr(neig, "degrees")
+ n <- length(deg)
+ labels <- names(deg)
+ neig <- unclass(neig)
+ G <- matrix(0, n, n)
+ for (i in 1:n) {
+ w <- neig[neig[, 1] == i, 2]
+ if (length(w) > 0) G[i, w] <- 1
+ }
+ G <- G + t(G)
+ G <- 1 * (G > 0)
+ if (is.null(labels)) labels <- paste("P",1:n,sep="")
+ dimnames(G) <- list(labels,labels)
+ return(G)
+}
+
+"neig.util.GtoL" <- function (G) {
+ G <- as.matrix(G)
+ n <- nrow(G)
+ if (ncol(G) != n)
+ stop("Square matrix expected")
+ # modif du any samedi, mai 31, 2003 at 16:19
+ if (any(t(G) != G))
+ stop("Symetric matrix expected")
+ if (sum(G == 0 | G == 1) != n * n)
+ stop("0-1 values expected")
+ if (sum(diag(G) != 0))
+ stop("Null diagonal expected")
+ G <- G * (row(G) < col(G))
+ G <- (row(G) + 0 + (0+1i) * col(G)) * G
+ G <- as.vector(G)
+ G <- G[G != 0]
+ G <- cbind(Re(G), Im(G))
+ return(G)
+}
+
+"neig.util.LtoG" <- function (L, n = max(L)) {
+ L <- unclass(L)
+ if (ncol(L) != 2)
+ stop("two col expected")
+ no.is.int <- function(x) x != as.integer(x)
+ if (any(apply(L, c(1, 2), no.is.int)))
+ stop("Non integer value found")
+ if (n < max(L))
+ stop("Non convenient 'n' parameter")
+ G <- matrix(0, n, n)
+ for (i in 1:n) {
+ w <- L[L[, 1] == i, 2]
+ if (length(w) > 0)
+ G[i, w] <- 1
+ }
+ G <- G + t(G)
+ G <- 1 * (G > 0)
+ return(G)
+}
+
+"print.neig" <- function (x, ...) {
+ deg <- attr(x, "degrees")
+ n <- length(deg)
+ labels <- names(deg)
+ df <- neig.util.LtoG(x)
+ for (i in 1:n) {
+ w <- c(".", "1")[df[i, 1:i] + 1]
+ cat(labels[i], " ", w, "\n", sep = "")
+ }
+ invisible(df)
+}
+
+ "summary.neig" <- function (object, ...) {
+ cat("Neigbourhood undirected graph\n")
+ deg <- attr(object, "degrees")
+ size <- length(deg)
+ cat("Vertices:", size, "\n")
+ cat("Degrees:", deg, "\n")
+ m <- sum(deg)/2
+ cat("Edges (pairs of vertices):", m, "\n")
+}
+
+"scores.neig" <- function (obj) {
+ tol <- 1e-07
+ if (!inherits(obj, "neig"))
+ stop("Object of class 'neig' expected")
+ b0 <- neig.util.LtoG(obj)
+ deg <- attr(obj, "degrees")
+ m <- sum(deg)
+ n <- length(deg)
+ b0 <- -b0/m + diag(deg)/m
+ # b0 est la matrice D-P
+ eig <- eigen (b0, symmetric = TRUE)
+ w0 <- abs(eig$values)/max(abs(eig$values))
+ w0 <- which(w0<tol)
+ if (length(w0)==0) stop ("abnormal output : no null eigenvalue")
+ if (length(w0)==1) w0 <- (1:n)[-w0]
+ else if (length(w0)>1) {
+ # on ajoute le vecteur dérivé de 1n
+ w <- cbind(rep(1,n),eig$vectors[,w0])
+ # on orthonormalise l'ensemble
+ w <- qr.Q(qr(w))
+ # on met les valeurs propres à 0
+ eig$values[w0] <- 0
+ # on remplace les vecteurs du noyau par une base orthonormée contenant
+ # en première position le parasite
+ eig$vectors[,w0] <- w[,-ncol(w)]
+ # on enlève la position du parasite
+ w0 <- (1:n)[-w0[1]]
+ }
+ w0=rev(w0)
+ rank <- length(w0)
+ values <- n-eig$values[w0]*n
+ eig <- eig$vectors[,w0]*sqrt(n)
+ eig <- data.frame(eig)
+ row.names(eig) <- names(deg)
+ names(eig) <- paste("V",1:rank,sep="")
+ attr(eig,"values")<-values
+ eig
+}
+
diff --git a/R/newick2phylog.R b/R/newick2phylog.R
new file mode 100644
index 0000000..6b5f279
--- /dev/null
+++ b/R/newick2phylog.R
@@ -0,0 +1,570 @@
+"newick2phylog" <- function (x.tre, add.tools = TRUE, call =match.call()) {
+ complete <- function(x.tre) {
+ # Si la chaîne est en plusieurs morceaux elle est rassemblée
+ if (length(x.tre) > 1) {
+ w <- ""
+ for (i in 1:length(x.tre)) w <- paste(w, x.tre[i],
+ sep = "")
+ x.tre <- w
+ }
+ # Si les parenthèses gauches et droites ont des effectifs différents -> out
+ ndroite <- nchar(gsub("[^)]","",x.tre))
+ ngauche <- nchar(gsub("[^(]","",x.tre))
+ if (ndroite !=ngauche) stop (paste (ngauche,"( versus",ndroite,")"))
+ # on doit trouver un ;
+ if (regexpr(";", x.tre) == -1)
+ stop("';' not found")
+ # Tous les commentaires entre [] sont supprimés
+ i <- 0
+ kint <- 0
+ kext <- 0
+ arret <- FALSE
+ if (regexpr("\\[", x.tre) != -1) {
+ x.tre <- gsub("\\[[^\\[]*\\]", "", x.tre)
+ }
+ x.tre <- gsub(" ", "", x.tre)
+ # On ne peut supprimer les . qui sont dans les distances !
+ # x.tre <- gsub("[.]","_", x.tre, ext = FALSE)
+ while (!arret) {
+ i <- i + 1
+
+ # examen de la chaîne par couple de charactères
+ if (substr(x.tre, i, i) == ";")
+ arret <- TRUE
+ # (, c'est une feuille sans label
+ if (substr(x.tre, i, i + 1) == "(,") {
+ kext <- kext + 1
+ add <- paste("Ext", kext, sep = "")
+ x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre,
+ i + 1), sep = "")
+ i <- i + 1
+ }
+ # ,, c'est une feuille sans label
+ else if (substr(x.tre, i, i + 1) == ",,") {
+ kext <- kext + 1
+ add <- paste("Ext", kext, sep = "")
+ x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre,
+ i + 1), sep = "")
+ i <- i + 1
+ }
+ # ,) c'est une feuille sans label
+ else if (substr(x.tre, i, i + 1) == ",)") {
+ kext <- kext + 1
+ add <- paste("Ext", kext, sep = "")
+ x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre,
+ i + 1), sep = "")
+ i <- i + 1
+ }
+ # (: c'est une feuille sans label avec distance
+ else if (substr(x.tre, i, i + 1) == "(:") {
+ kext <- kext + 1
+ add <- paste("Ext", kext, sep = "")
+ x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre,
+ i + 1), sep = "")
+ i <- i + 1
+ }
+ # ,: c'est une feuille sans label avec distance
+ else if (substr(x.tre, i, i + 1) == ",:") {
+ kext <- kext + 1
+ add <- paste("Ext", kext, sep = "")
+ x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre,
+ i + 1), sep = "")
+ i <- i + 1
+ }
+ # ), c'est un noeud sans label
+ else if (substr(x.tre, i, i + 1) == "),") {
+ kint <- kint + 1
+ add <- paste("I", kint, sep = "")
+ x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre,
+ i + 1), sep = "")
+ i <- i + 1
+ }
+ # )) c'est un noeud sans label
+ else if (substr(x.tre, i, i + 1) == "))") {
+ kint <- kint + 1
+ add <- paste("I", kint, sep = "")
+ x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre,
+ i + 1), sep = "")
+ i <- i + 1
+ }
+ # ): c'est un noeud sans label avec distance
+ else if (substr(x.tre, i, i + 1) == "):") {
+ kint <- kint + 1
+ add <- paste("I", kint, sep = "")
+ x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre,
+ i + 1), sep = "")
+ i <- i + 1
+ }
+ # ); c'est la racine sans label
+ else if (substr(x.tre, i, i + 1) == ");") {
+ add <- "Root"
+ x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre,
+ i + 1), sep = "")
+ i <- i + 1
+ }
+ }
+ # extraction de l'information non structurelle
+ lab.points <- strsplit(x.tre, "[(),;]")[[1]]
+ lab.points <- lab.points[lab.points != ""]
+ # recherche de la présence des longueurs
+ no.long <- (regexpr(":", lab.points) == -1)
+ # si il n'y avait aucune longueur
+ if (all(no.long)) {
+ lab.points <- paste(lab.points, ":", c(rep("1", length(no.long) -
+ 1), "0.0"), sep = "")
+ }
+ # si il y en vait partout sauf à la racine
+ else if (no.long[length(no.long)]) {
+ lab.points[length(lab.points)] <- paste(lab.points[length(lab.points)],
+ ":0.0", sep = "")
+ }
+ # si il y en a et il n'y en a pas -> out
+ else if (any(no.long)) {
+ print(x.tre)
+ stop("Non convenient data leaves or nodes with and without length")
+ }
+ w <- strsplit(x.tre, "[(),;]")[[1]]
+ w <- w[w != ""]
+ leurre <- make.names(w, unique = TRUE)
+ leurre <- gsub("[.]","_", leurre)
+ for (i in 1:length(w)) {
+ old <- paste(w[i])
+ x.tre <- sub(old, leurre[i], x.tre,fixed = TRUE)
+ }
+ # extraction des labels et des longueurs
+ w <- strsplit(lab.points, ":")
+ label <- function(x) {
+ # ici on peut travailler sur les labels
+ lab <- x[1]
+ lab <- gsub("[.]","_", lab)
+ return (lab)
+ }
+
+ longueur <- function(x) {
+ long <- x[2]
+ return (long)
+ }
+
+ labels <- unlist(lapply(w, label))
+ longueurs <- unlist(lapply(w, longueur))
+ # ici on peut travailler sur les labels
+ labels <- make.names(labels, TRUE)
+ labels <- gsub("[.]","_", labels)
+ w <- labels
+ for (i in 1:length(w)) {
+ new <- w[i]
+ x.tre <- sub(leurre[i], new, x.tre)
+ }
+ # on les a remis à leur place
+ cat <- rep("", length(w))
+ for (i in 1:length(w)) {
+ new <- w[i]
+ if (regexpr(paste("\\)", new, sep = ""), x.tre) !=
+ -1)
+ cat[i] <- "int"
+ else if (regexpr(paste(",", new, sep = ""), x.tre) != -1)
+ cat[i] <- "ext"
+ else if (regexpr(paste("\\(", new, sep = ""), x.tre) != -1)
+ cat[i] <- "ext"
+ else cat[i] <- "unknown"
+ }
+ return(list(tre = x.tre, noms = labels, poi = as.numeric(longueurs),
+ cat = cat))
+ }
+ res <- complete(x.tre)
+ poi <- res$poi
+ nam <- res$noms
+ names(poi) <- nam
+ cat <- res$cat
+ res <- list(tre = res$tre)
+ res$leaves <- poi[cat == "ext"]
+ names(res$leaves) <- nam[cat == "ext"]
+ res$nodes <- poi[cat == "int"]
+ names(res$nodes) <- nam[cat == "int"]
+ listclass <- list()
+ dnext <- c(names(res$leaves), names(res$nodes))
+ listpath <- as.list(dnext)
+ names(listpath) <- dnext
+ x.tre <- res$tre
+ while (regexpr("[(]", x.tre) != -1) {
+ a <- regexpr("\\([^\\(\\)]*\\)", x.tre)
+ n1 <- a[1] + 1
+ n2 <- n1 - 3 + attr(a, "match.length")
+ chasans <- substring(x.tre, n1, n2)
+ chaavec <- paste("\\(", chasans, "\\)", sep = "")
+ nam <- unlist(strsplit(chasans, ","))
+ w1 <- strsplit(x.tre, chaavec)[[1]][2]
+ parent <- unlist(strsplit(w1, "[,\\);]"))[1]
+ listclass[[parent]] <- nam
+ x.tre <- gsub(chaavec, "", x.tre)
+ w2 <- which(unlist(lapply(listpath, function(x) any(x[1] ==
+ nam))))
+ for (i in w2) {
+ listpath[[i]] <- c(parent, listpath[[i]])
+ }
+ }
+ res$parts <- listclass
+ res$paths <- listpath
+ dnext <- c(res$leaves, res$nodes)
+ names(dnext) <- c(names(res$leaves), names(res$nodes))
+ res$droot <- unlist(lapply(res$paths, function(x) sum(dnext[x])))
+ res$call <- call
+ class(res) <- "phylog"
+ if (!add.tools) return(res)
+ return(newick2phylog.addtools(res))
+}
+
+
+"hclust2phylog" <- function (hc, add.tools = TRUE) {
+ if (!inherits(hc, "hclust"))
+ stop("'hclust' object expected")
+ labels.leaves <- make.names(hc$labels, TRUE)
+ nnodes <- nrow(hc$merge)
+ labels.nodes <- paste("Int", 1:nnodes, sep = "")
+ l.bra <- matrix("$", nnodes, 2)
+ for (i in nnodes:1) {
+ for (j in 1:2) {
+ if (hc$merge[i, j] < 0)
+ l.bra[i, j] <- as.character(hc$height[i])
+ else l.bra[i, j] <- as.character(hc$height[i] - hc$height[hc$merge[i,
+ j]])
+ }
+ }
+ l.eti <- matrix("$", nnodes, 2)
+ for (i in nnodes:1) {
+ for (j in 1:2) {
+ if (hc$merge[i, j] > 0)
+ l.eti[i, j] <- labels.nodes[hc$merge[i, j]]
+ else l.eti[i, j] <- labels.leaves[-hc$merge[i, j]]
+ }
+ }
+ tre <- paste("(", l.eti[nnodes, 1], ":", l.bra[nnodes, 1],
+ ",", l.eti[nnodes, 2], ":", l.bra[nnodes, 2], ")Root:0.0;",
+ sep = "")
+ for (j in (nnodes - 1):1) {
+ w <- paste("(", l.eti[j, 1], ":", l.bra[j, 1], ",", l.eti[j,
+ 2], ":", l.bra[j, 2], ")", labels.nodes[j], ":",
+ sep = "")
+ tre <- gsub(paste(labels.nodes[j], ":", sep = ""), w,
+ tre)
+ }
+ res <- newick2phylog(tre, add.tools, call=match.call())
+ return(res)
+}
+
+
+taxo2phylog <- function (taxo, add.tools = FALSE, root = "Root", abbrev = TRUE)
+{
+ if (!inherits(taxo, "taxo"))
+ stop("Object 'taxo' expected")
+ nc <- ncol(taxo)
+ for (k in 1:nc) {
+ w <- as.character(k)
+ w <- paste("l", w, sep="")
+ w1 <- levels(taxo[,k])
+ if (abbrev) w1 <- abbreviate(w1)
+ levels(taxo[,k]) <- paste(w, w1,sep="")
+ }
+ leaves.names <- row.names(taxo)
+ res <- paste(root,";",sep="")
+ x <- taxo[, nc]
+ xred <- as.character(levels(x))
+ w <- "("
+ for (i in xred) w <- paste(w, i, ",", sep = "")
+ res <- paste(w, ")", res, sep = "")
+ res <- sub(",\\)", "\\)", res)
+ for (j in nc:1) {
+ x <- taxo[, j]
+ if (j>1) y <- taxo[, j - 1] else y <- as.factor(leaves.names)
+ for (k in 1:nlevels(x)) {
+ w <- "("
+ old <- as.character(levels(x)[k])
+ yred <- unique(y[x == levels(x)[k]])
+ yred <- as.character(yred)
+ for (i in yred) w <- paste(w, i, ",", sep = "")
+ w <- paste(w, ")", old, sep = "")
+ w <- sub(",\\)", "\\)", w)
+ res <- gsub(old, w, res)
+ }
+ }
+ return(newick2phylog(res, add.tools, call = match.call()))
+}
+
+
+"newick2phylog.addtools" <- function(res, tol =1e-07) {
+ nleaves <- length(res$leaves) # nombre de feuilles
+ nnodes <- length(res$nodes) # nombre de noeuds
+ node.names <- names(res$nodes) # noms des feuilles
+ leave.names <- names(res$leaves) # noms des noeuds
+ dimnodes<-unlist(lapply(res$parts,length)) # nombres de descendants immédiats de chaque noeud
+ effnodes <- dimnodes # recevra le nombre de descendants total de chaque noeud
+ wnodes <- lgamma(dimnodes+1)
+ # recevra le logarithme du nombre de permuations compatibles
+ # avec la sous-arborescence associée à chaque noeud
+
+
+
+ # les matrices de proximité #
+ a <- matrix(0, nleaves, nleaves)
+ ia <- as.numeric(col(a))
+ ja <- as.numeric(row(a))
+ a <- cbind(ia, ja)[ia < ja, ]
+ # a contient la liste des couples de feuilles
+ floc1 <- function(x) {
+ # x est un couple de numéros de deux feuilles i, avec i<j
+ # Cette fonction renvoie
+ # resw - la distance à la racine du premier ancêtre commun de deux feuilles
+ # resa - l'inverse des produits des nombres de descendants des noeuds
+ # rencontrés sur le plus court chemin entre les deux feuilles
+ c1 <- rev(res$paths[[x[1]]])
+ c2 <- rev(res$paths[[x[2]]])
+ commonnodes <- c1[c1 %in% c2]
+ resw <- res$droot[commonnodes[1]]
+ d1 <- c1[! (c1 %in% c2)][-1]
+ d2 <- c2[! (c2 %in% c1)][-1]
+ pathij <- c(d1,d2,commonnodes[1])
+ resa <- 1/prod(unlist(dimnodes[pathij]))
+ return(c(resw,resa))
+ }
+ b <- apply(a, 1, floc1)
+ names(b) <- NULL
+ w <- matrix(0, nleaves, nleaves)
+ w[col(w) < row(w)] <- b[1,]
+ w <- w + t(w)
+ diag(w) <- res$droot[leave.names]
+ dimnames(w) <- list(leave.names,1:nleaves)
+
+ res$Wmat <- w
+
+ #############################
+ # la composante Wmat contient la matrice W des distances racine-premier ancêtre commun
+ #############################
+
+ w <- diag(res$Wmat)
+ w <- matrix(w, nleaves, nleaves)
+ w <- w + t(w) - 2 * res$Wmat
+ w <- as.dist(sqrt(w))
+ attr(w, "Labels") <- leave.names
+
+ res$Wdist <- w
+ #############################
+ # la composante Wdist contient la matrice des racines des distances nodales
+ # qui forment une distance euclidienne
+ #############################
+ w <- res$Wmat
+ w <- w / sum(w)
+ w <- bicenter.wt(w)
+ w <- eigen(w,symmetric = TRUE)
+ res$Wvalues <- w$values[-nleaves]*nleaves
+ w <- as.data.frame(qr.Q(qr(scale(w$vectors, scale = FALSE)))[,-nleaves]*sqrt(nleaves))
+ row.names(w) <- leave.names
+ names(w) = paste("W",1:(nleaves-1),sep="")
+ res$Wscores <- w
+
+
+ w <- matrix(0, nleaves, nleaves)
+ w[col(w) < row(w)] <- b[2,]
+ w <- w + t(w)
+ # On rajoute la diagonale pour que A soit bistochastique
+ floc2 <- function(x) {
+ # cette fonction renvoie pour une feuille la fréquence des représentations
+ # compatibles qui placent cette feuille tout en haut ou tout en bas
+ c1 <- rev(res$paths[[x]])
+ c1 <- c1[-1] # premier ancetre, second ancetre, ..., racine
+ resw <- dimnodes[c1] # ordre des noeuds
+ resw <- 1/prod(unlist(resw))
+ return(resw)
+ }
+ diag(w) <- unlist(lapply(leave.names,floc2))
+ dimnames(w) <- list(leave.names,1:nleaves)
+ res$Amat <- w
+ #############################
+ # la composante Amat contient la matrice des probabilités
+ # pour une feuille d'être juste au dessus d'une autre
+ # dans l'ensemble des permutations compatibles
+ #############################
+ # double centrage
+ w <- bicenter.wt(w)
+ # diagonalisation
+ eig <- eigen (w, symmetric = TRUE)
+ w0 <- abs(eig$values)/max(abs(eig$values))
+ w0 <- which(w0<tol)
+ if (length(w0)==0) stop ("abnormal output : no null eigenvalue")
+ if (length(w0)==1) w0 <- (1:nleaves)[-w0]
+ else if (length(w0)>1) {
+ # on ajoute le vecteur dérivé de 1n
+ w <- cbind(rep(1,nleaves),eig$vectors[,w0])
+ # on orthonormalise l'ensemble
+ w <- qr.Q(qr(w))
+ # on met les valeurs propres à 0
+ eig$values[w0] <- 0
+ # on remplace les vecteurs du noyau par une base orthonormée contenant
+ # en première position le parasite
+ eig$vectors[,w0] <- w[,-ncol(w)]
+ # on enlève la position du parasite
+ w0 <- (1:nleaves)[-w0[1]]
+ }
+ rank <- length(w0)
+ res$Avalues <- eig$values[w0]*nleaves
+ #############################
+ # la composante Avalues contient les valeurs propres de QAQ
+ #############################
+ res$Adim <- sum(res$Avalues>tol)
+ #############################
+ # la composante Adim contient le nombre de valeurs propres positives
+ # associées à la composante positive de la variance
+ #############################
+ w <- eig$vectors[,w0]*sqrt(nleaves)
+ w <- data.frame(w)
+ row.names(w) <- leave.names
+ names(w) <- paste("A",1:rank,sep="")
+ res$Ascores <- w
+ #############################
+ # la composante Ascores contient une base orthobormée de l'orthogonal de n
+ # pour la pondération uniforme. Elle définit un phylogramme
+ #############################
+
+ # Complément : la valeur des noeuds #
+
+ floc3 <- function(k) {
+ # k est un numéro de noeud
+ # x est un vecteur comportant un nom de noeud et des noms de descendants
+ # de ce noeud.
+ # A la fin parts wnodes contient le logarithme
+ # du nombre de permutations compatibles de chaque sous-arbre
+ # et effnodes contient le nombre de descendants de chaque sous-arbre
+ y <- res$parts[[k]]
+ x <- y[y%in%names(res$nodes)]
+ n1 <- names(res$parts)[k]
+ if (length(x)<=0) return(NULL)
+ effnodes[n1] <<- effnodes[n1] - length(x) + sum(effnodes[x])
+ wnodes[n1] <<- wnodes[n1] + sum(wnodes[x])
+ return(NULL)
+ }
+
+ lapply(1:length(res$parts),floc3)
+ # typolo.value <- 1-exp(wnodes-lgamma(effnodes+1)) abandon
+
+ ####res$Aparam <- data.frame(x1=I(dimnodes), x2=I(effnodes), x3=I(wnodes), x4=I(typolo.value))
+ res$Aparam <- data.frame(ndir=dimnodes, nlea=effnodes, lnperm=I(wnodes))
+ #############################
+ # la composante Aparam est un data.frame de paramètre sur l'ensemble des noeuds
+ # x1 = nombre de descendants directs
+ # x2 = nombre de feuilles descendantes
+ # x3 = log du nombre de permutations compatibles avec la phylogénie extraite
+ # x4 = 1-rapport du nombre de permutations compatibles sur le nombre de permutations totales
+ # pour la phylogénie extraite dans ce noeud
+ # cet indice vaut 0 si le noeud est final et est maximal à la racine
+ # attention il ne vaut pas 1 mais 1-epsilon quand il est affiché 1
+ #############################
+
+ # Complément : la base B #
+ w1 <- matrix(0, nleaves, nnodes)
+ ####x1 <- res$Aparam$x2 #le nombre de feuilles descendantes
+ x1 <- res$Aparam$lnperm #on trie sur le log des permutations
+ # on calcule une matrice auxiliaire pour avoir la liste des feuilles descendantes
+ # pour chacun des noeuds
+ dimnames(w1) <- list(leave.names, names(x1))
+ for (i in leave.names) {
+ ancetres <- res$paths[[i]]
+ ancetres <- rev(ancetres)[-1]#rev(ancetres[-1])[-1]
+ w1[i, ancetres] <- 1
+ }
+ w1 <- cbind(w1, diag(1, nleaves))
+ dimnames(w1)[[2]] <- c(names(x1),leave.names)
+ x1 <- c(x1, rep(-1,nleaves))
+ names(x1) <-dimnames(w1)[[2]]
+ # La matrice w1 contient 1 en i-j si la feuille i descend du noeud j
+
+ ######################################
+ # on construit une famille d'indicatrices de classes
+ # Une arête de l'arborescence est un lien de descendance
+ # Chaque noeud et chaque feuille (à l'expection de la racine) a un seul ascendant
+ # Il y a n+f-1 arêtes. Le noeud j a m(j) descendants
+ # Les feuilles n'en n'ont pas. Donc m(1)+m(2)+ ... + m(n) = n+f-1
+ # Il y a n+f-1 arêtes réparties en n blocs.
+ # Il y a donc n+f-1-n=f-1 descendants indicateurs DI quand on enlève une arête descendante par noeud
+ # Rien n'est conservé pour un noeud avec un seul descendant
+ # Pour chaque DI on utilise l'indicatrice de la classe des feuilles descendant de cet noeud
+ # la composante Bindica contient f-1 indicatrices de classes de feuilles
+ # names (w) contient des noms de descendants
+ # nomuni contient les noms de DI pour l'étiquetage final
+ ####################################
+ funnoe <- function (noeud) {
+ # renvoie pour un noeud une liste dont chaque composante est un descendant immédiat du noeud
+ # caractérisé par la liste des feuilles qui en descendent sous forme de matrice
+ # d'indicatrices. Le dernier descendant immédiat du noeud est éliminé.
+ x <- res$parts[[noeud]] # les descendants immédiats
+ xval <- x1[x] # le nombre de feuilles descendantes des descendants
+ xval <- rev(sort(xval)) # triée
+ x <- names(xval) # on récupère lesquels
+ x <- x[-length(x)] # on enlève le dernier
+ if (length(x) ==0) return(NULL)
+ if (length(x) ==1) xmat <- matrix(w1[,x],ncol=1,dimnames=list(leave.names,noeud))
+ else {
+ xmat <- w1[,x]
+ dimnames(xmat)[[2]] <- rep(noeud, ncol(xmat))
+ }
+ return (list(xmat, x))
+ # les noms des colonnes de xmat repète le nom du noeud
+ # dans y on a le nom des descendants retenus
+ }
+
+ nomuni <- NULL
+ w <- matrix(1,nleaves,1)
+ dimnames(w) <- list(leave.names, "un")
+ for (i in names(x1)[1:nnodes]) {
+ provi <- funnoe(i)
+ if (!is.null(provi)) {
+ w <-cbind(w, provi[[1]])
+ nomuni <- c(nomuni,provi[[2]])
+ }
+ }
+ w <- w[,-1]
+ nomrepet <- dimnames(w)[[2]]
+ names(nomrepet) <- nomuni
+ dimnames(w)[[2]] <- nomuni
+ names(nomuni) <- nomuni
+ #############################
+ # Les indicatrices sont classées par ordre décroissant
+ # de xtQWQx la variance phylogénétique formelle de l'indicatrice centrée
+ # Bindica n'a qu'une valeur pédagogique et ne sert pas explicitement
+ # mais la procédure est simple
+ # 1) définition des indicatrices, il y en a toujours f-1
+ # 2) rangement par valeur décroissante de la forme quadratique
+ # Ce rangement est conservé dans res$Bindica
+ # les valeurs du critère de rangement dans Bvalues
+ # 3) rajout de 1n devant
+ # 4) orthonormalisation
+ # on obtient toujours une base orthonormée de l'orthogonal de 1n
+ #############################
+
+ w.val <- x1[nomuni]
+ # trie par ordre descendant
+ w.val <- rev(sort(w.val))
+ # lesquels
+ w <- w[,names(w.val)]
+ # nomrepet / w sont triés
+ nomrepet <- nomrepet[names(w.val)]
+ res$Bindica <- as.data.frame(w)
+ w <- cbind(rep(1,nleaves),w)
+ w <- qr.Q(qr(w))
+ w <- w[, -1] * sqrt(nleaves)
+ w <- data.frame(w)
+ row.names(w) <- leave.names
+ names(w) <- paste("B",1:(nleaves-1),sep="")
+ res$Bscores <- w
+ ### res$Bvalues <- w.val
+ lw <- lapply(node.names, function (x) which(nomrepet==x))
+ names(lw) <- node.names
+ fun1 <- function (x) {
+ if (length(x)==0) return("x")
+ if (length(x)==1) return(as.character(x))
+ y <- x[1]
+ for(k in 2:length(x)) y <- paste(y,x[k],sep="/")
+ return(y)
+ }
+ lw <- unlist(lapply(lw, fun1))
+ res$Blabels <- lw
+ return(res)
+}
diff --git a/R/niche.R b/R/niche.R
new file mode 100644
index 0000000..eaae821
--- /dev/null
+++ b/R/niche.R
@@ -0,0 +1,159 @@
+"niche" <- function (dudiX, Y, scannf = TRUE, nf = 2) {
+ if (!inherits(dudiX, "dudi"))
+ stop("Object of class dudi expected")
+ lig1 <- nrow(dudiX$tab)
+ if (!is.data.frame(Y))
+ stop("Y is not a data.frame")
+ lig2 <- nrow(Y)
+ if (lig1 != lig2)
+ stop("Non equal row numbers")
+ w1 <- apply(Y, 2, sum)
+ if (any(w1 <= 0))
+ stop(paste("Column sum <=0 in Y"))
+ Y <- sweep(Y, 2, w1, "/")
+ w1 <- w1/sum(w1)
+ tabcoiner <- t(as.matrix(Y)) %*% (as.matrix(dudiX$tab))
+ tabcoiner <- data.frame(tabcoiner)
+ names(tabcoiner) <- names(dudiX$tab)
+ row.names(tabcoiner) <- names(Y)
+ if (nf > dudiX$nf)
+ nf <- dudiX$nf
+ nic <- as.dudi(tabcoiner, dudiX$cw, w1, scannf = scannf,
+ nf = nf, call = match.call(), type = "niche")
+ U <- as.matrix(nic$c1) * unlist(nic$cw)
+ U <- data.frame(as.matrix(dudiX$tab) %*% U)
+ row.names(U) <- row.names(dudiX$tab)
+ names(U) <- names(nic$c1)
+ nic$ls <- U
+ U <- as.matrix(nic$c1) * unlist(nic$cw)
+ U <- data.frame(t(as.matrix(dudiX$c1)) %*% U)
+ row.names(U) <- names(dudiX$li)
+ names(U) <- names(nic$li)
+ nic$as <- U
+ return(nic)
+}
+
+"plot.niche" <- function (x, xax = 1, yax = 2, ...) {
+ if (!inherits(x, "niche"))
+ stop("Use only with 'niche' objects")
+ if (x$nf == 1) {
+ warnings("One axis only : not yet implemented")
+ return(invisible())
+ }
+ if (xax > x$nf)
+ stop("Non convenient xax")
+ if (yax > x$nf)
+ stop("Non convenient yax")
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3),
+ respect = TRUE)
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ s.corcircle(x$as, xax, yax, sub = "Axis", csub = 2,
+ clabel = 1.25)
+ s.arrow(x$c1, xax, yax, sub = "Variables", csub = 2,
+ clabel = 1.25)
+ scatterutil.eigen(x$eig, wsel = c(xax, yax))
+ s.label(x$ls, xax, yax, clabel = 0, cpoint = 2, sub = "Samples and Species",
+ csub = 2)
+ s.label(x$li, xax, yax, clabel = 1.5, add.plot = TRUE)
+ s.label(x$ls, xax, yax, clabel = 1.25, sub = "Samples",
+ csub = 2)
+ s.distri(x$ls, eval.parent(as.list(x$call)[[3]]),
+ cstar = 0, axesell = FALSE, cellipse = 1, sub = "Niches", csub = 2)
+}
+
+"print.niche" <- function (x, ...) {
+ if (!inherits(x, "niche"))
+ stop("to be used with 'niche' object")
+ cat("Niche analysis\n")
+ cat("call: ")
+ print(x$call)
+ cat("class: ")
+ cat(class(x), "\n")
+ cat("\n$rank (rank) :", x$rank)
+ cat("\n$nf (axis saved) :", x$nf)
+ cat("\n$RV (RV coeff) :", x$RV)
+ cat("\n\neigen values: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n\n")
+ else cat("\n\n")
+ sumry <- array("", c(3, 4), list(1:3, c("vector", "length",
+ "mode", "content")))
+ sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
+ sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weigths (crossed array)")
+ sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), "col weigths (crossed array)")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(7, 4), list(1:7, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "crossed array (averaging species/sites)")
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "species coordinates")
+ sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "species normed scores")
+ sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "variables coordinates")
+ sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "variables normed scores")
+ sumry[6, ] <- c("$ls", nrow(x$ls), ncol(x$ls), "sites coordinates")
+ sumry[7, ] <- c("$as", nrow(x$as), ncol(x$as), "axis upon niche axis")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+}
+
+"niche.param" <- function(x) {
+ if (!inherits(x, "niche"))
+ stop("Object of class 'niche' expected")
+ appel <- as.list(x$call)
+ X <- eval.parent(appel[[2]])$tab
+ Y <- eval.parent(appel[[3]])
+ w1 <- apply(Y, 2, sum)
+ if (any(w1 <= 0))
+ stop(paste("Column sum <=0 in Y"))
+ Y <- sweep(Y, 2, w1, "/")
+ calcul.param <- function(freq,mil) {
+ inertia <- sum(freq * mil * mil)
+ m <- apply(freq * mil, 2, sum)
+ margi <- sum(m^2)
+ mil <- t(t(mil) - m)
+ tolt <- sum(freq * mil * mil)
+ u <- m/sqrt(sum(m^2))
+ z <- mil %*% u
+ tolm <- sum(freq * z * z)
+ tolr <- tolt - tolm
+ w <- c(inertia, margi, tolm, tolr)
+ names(w) <- c("inertia", "OMI", "Tol", "Rtol")
+ w1 <- round(w[2:4]/w[1], digits = 3) * 100
+ names(w1) <- c("omi", "tol", "rtol")
+ return(c(w, w1))
+ }
+ res <- apply(Y, 2, calcul.param,mil=X)
+ t(res)
+}
+
+
+rtest.niche <- function(xtest, nrepet = 99,...){
+ if (!inherits(xtest, "dudi"))
+ stop("Object of class dudi expected")
+ if (!inherits(xtest, "niche"))
+ stop("Type 'niche' expected")
+ appel <- as.list(xtest$call)
+ X <- eval.parent(appel$dudiX)$tab
+ Y <- eval.parent(appel$Y)
+ w1 <- apply(Y, 2, sum)
+ if (any(w1 <= 0))
+ stop(paste("Column sum <=0 in Y"))
+ Y <- sweep(Y, 2, w1, "/")
+ calcul.margi <- function(freq,mil) {
+ m <- apply(freq * mil, 2, sum)
+ return(sum(m^2))
+ }
+ obs <- apply(Y,2,calcul.margi,mil=X)
+ ## we compute and test the average marginality for all species (OMI.mean)
+ obs <- c(obs, OMI.mean = mean(obs))
+ sim <- sapply(1:nrepet,function(x) apply(apply(Y,2,sample),2,calcul.margi,mil=X))
+ sim <- rbind(sim, OMI.mean=apply(sim,2,mean))
+ res <- as.krandtest(obs=obs,sim=t(sim), ...)
+ return(res)
+}
diff --git a/R/nipals.R b/R/nipals.R
new file mode 100644
index 0000000..62b2520
--- /dev/null
+++ b/R/nipals.R
@@ -0,0 +1,134 @@
+"nipals" <-
+function(df, nf=2, rec=FALSE,niter=100, tol = 1e-9){
+# df est un data frame contenant eventuellement des valeurs manquantes (NA)
+# nf nombre de facteurs a conserver
+# rec, si rec=T, la reconstitution des donnees sur les nf premiers axes est realisee
+# **********************************************************************************
+# df is a data frame which can contain missing values (NA)
+# nf number of axes to keep
+# rec, if rec=T, data recontsitution is performed with the nf first axes
+# n.max.iter= maximum number of iterations
+
+ df <- data.frame(df)
+ tol<-1e-9 # tol pour la convergence
+ nc <- ncol(df)
+ nr <- nrow(df)
+ nr.na <- apply(df, 2, function(x) sum(!is.na(x)))
+ if (rec)
+ x<-list(li=matrix(0,nr,nf),c1=matrix(0,nc,nf),co=matrix(0,nc,nf),
+ eig=rep(0,nf),nb=rep(0,nf),rec=matrix(0,nr,nc))
+ else
+ x<-list(li=matrix(0,nr,nf),c1=matrix(0,nc,nf),co=matrix(0,nc,nf),
+ eig=rep(0,nf),nb=rep(0,nf))
+ row.names(x$c1)<-names(df)
+ row.names(x$co)<-names(df)
+ row.names(x$li)<-row.names(df)
+
+ #X<-scale(df, center=T, scale=T, na.rm=TRUE)
+ cmeans <- colMeans(df, na.rm=TRUE)
+ csd <- apply(df, 2, sd, na.rm=TRUE) * (nr.na - 1) / nr.na
+ X <- sweep(sweep(df, 2, cmeans, "-"), 2, csd, "/")
+ x$tab<-X
+ for (h in 1:nf) {
+ th<-X[,1]
+ ph1<-rep(1/sqrt(nc),nc)
+ ph2<-rep(1/sqrt(nc),nc)
+ diff<-rep(1,nc)
+ nb<-0
+ while (sum(diff^2, na.rm=TRUE)>tol & nb<=niter) {
+ for (i in 1:nc) {
+ the<-th[!is.na(X[,i])]
+ ph2[i]<-sum(X[,i]*th, na.rm=TRUE)/sum(the*the,na.rm=TRUE)
+ }
+ ph2<-ph2/sqrt(sum(ph2*ph2,na.rm=TRUE))
+ for (i in 1:nr) {
+ ph2e<-ph2[!is.na(X[i,])]
+ th[i]<-sum(X[i,]*ph2, na.rm=TRUE)/sum(ph2e*ph2e,na.rm=TRUE)
+ }
+ diff<-ph2-ph1
+ ph1<-ph2
+ nb<-nb+1
+ }
+ if(nb>niter) stop(paste("Maximum number of iterations reached for axis", h))
+ X<-X-th%*%t(ph1)
+ x$nb[h]<-nb # nombre d'iterations (number of iterations)
+ x$li[,h]<-th # coordonnees des lignes (row coordinates)
+ x$c1[,h]<-ph1 # coordonnees des colonnes de variance unit' (columns coordinates of unit variance)
+ x$eig[h]<-sum(th*th,na.rm=TRUE)/(nr-1) # valeurs propres (pseudo-eigenvalues)
+ x$co[,h]<-x$c1[,h]*sqrt(x$eig[h]) # coord. col. de variance lambda (column coordinates of variance lambda)
+
+ }
+ if (rec) {
+ for (h in 1:nf) {
+ x$rec<-x$rec+x$li[,h]%*%t(x$c1[,h]) # tableau reconstitue (reconstitued data)
+ }
+ }
+ if (rec){
+ x$rec=as.data.frame(x$rec)
+ names(x$rec)<-names (df)
+ row.names(x$rec)<-row.names(df)
+ }
+
+ x$call<-match.call()
+ x$nf<-nf
+ class(x)<-"nipals"
+ if(any(diff(x$eig)>0)) warning("Eigenvalues are not in decreasing order. Results of the analysis could be problematics")
+ return(x)
+}
+
+print.nipals<-function (x, ...)
+{
+ cat("NIPALS ANALYSIS\n")
+ cat("class: ")
+ cat(class(x))
+ cat("\n$call: ")
+ print(x$call)
+ cat("\n$nf:", x$nf, "axis-components saved")
+ cat("\neigen values: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n")
+ else cat("\n")
+ sumry <- array("", c(2, 4), list(1:2, c("vector", "length",
+ "mode", "content")))
+ sumry[1, ] <- c("$nb", length(x$nb), mode(x$nb), "number of iterations")
+ sumry[2, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(4, 4), list(1:4, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "modified array")
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates")
+ sumry[3, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates")
+ sumry[4, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores")
+
+ print(sumry, quote = FALSE)
+ cat("other elements: ")
+ if (length(names(x))==8)
+ cat("NULL\n")
+ else cat("$rec", "reconstituted data", "\n")
+}
+
+scatter.nipals<-function (x, xax = 1, yax = 2, clab.row = 0.75, clab.col = 1, posieig = "top", sub = NULL, ...)
+{
+ if (!inherits(x, "nipals"))
+ stop("Object of class 'nipals' expected")
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ coolig <- x$li[, c(xax, yax)]
+ coocol <- x$c1[, c(xax, yax)]
+ s.label(coolig, clabel = clab.row)
+ born <- par("usr")
+ k1 <- min(coocol[, 1])/born[1]
+ k2 <- max(coocol[, 1])/born[2]
+ k3 <- min(coocol[, 2])/born[3]
+ k4 <- max(coocol[, 2])/born[4]
+ k <- c(k1, k2, k3, k4)
+ coocol <- 0.9 * coocol/max(k)
+ s.arrow(coocol, clabel = clab.col, add.plot = TRUE, sub = sub,
+ possub = "bottomright")
+ add.scatter.eig(x$eig, x$nf, xax, yax, posi = posieig, ratio = 1/4)
+}
+
diff --git a/R/optimEH.R b/R/optimEH.R
new file mode 100644
index 0000000..51e0698
--- /dev/null
+++ b/R/optimEH.R
@@ -0,0 +1,39 @@
+"optimEH" <- function(phyl, nbofsp, tol = 1e-8, give.list = TRUE)
+{
+ if (!inherits(phyl, "phylog")) stop("unconvenient phyl")
+ if(is.null(phyl$Wdist)) phyl <- newick2phylog.addtools(phyl)
+ phy.h <- hclust(phyl$Wdist^2 / 2)
+ nbesp <- length(phy.h$labels)
+ if (length(nbofsp) != 1) stop("unconvenient nbofsp")
+ if (nbofsp == 0) return(0)
+ if (!((0 < nbofsp) & (nbofsp <= nbesp))) stop("unconvenient nbofsp")
+ nbofsp <- round(nbofsp)
+ sp.names <- phy.h$labels
+ if (nbofsp == nbesp) {
+ res1 <- EH(phyl)
+ sauv.names <- sp.names
+ }
+ else {
+ phyl.D <- as.matrix(phyl$Wdist^2 / 2)
+ Orig <- (solve(phyl.D)%*%rep(1, nbesp) / sum(solve(phyl.D)))
+ Orig <- as.data.frame(Orig)
+ car1 <- split(Orig, cutree(phy.h, nbofsp))
+ name1 <- lapply(car1,function(x) rownames(x)[abs(x - max(x)) < tol])
+ sauv.names <- lapply(name1, paste, collapse = " OR ")
+ comp <- as.character(as.vector(lapply(name1, function(x) x[1])))
+ nb1 <- as.vector(sapply(comp, function(x) (1:nbesp)[sp.names == x]))
+ if (nbofsp == 2)
+ res1 <- max(phyl$Wdist^2 / 2) * 2
+ else {
+ if (nbofsp == 1)
+ res1 <- max(phyl$Wdist^2 / 2)
+ else {
+ res1 <- EH(phyl, select = nb1)
+ }
+ }
+ }
+ if (give.list == TRUE)
+ return(list(value = res1, selected.sp = cbind.data.frame(names = unlist(sauv.names))))
+ else
+ return(res1)
+}
diff --git a/R/originality.R b/R/originality.R
new file mode 100644
index 0000000..9885635
--- /dev/null
+++ b/R/originality.R
@@ -0,0 +1,146 @@
+originality <- function (phyl, method = 5)
+{
+ if (!inherits(phyl, "phylog"))
+ stop("unconvenient phyl")
+ if (any(is.na(match(method, 1:7))))
+ stop("unconvenient method")
+ nbMeth <- length(method)
+ nbesp <- length(phyl$leaves)
+ nbnodes <- length(phyl$nodes)
+ resWeights <- as.data.frame(matrix(0, nbesp, nbMeth))
+ rownames(resWeights) <- names(phyl$leaves)
+ for (k in 1:nbMeth) {
+ meth <- method[k]
+ if (meth == 1) {
+ interm <- (unlist(lapply(phyl$paths, length))[1:length(phyl$leaves)] -
+ 1)
+ res <- max(interm)/interm/sum(max(interm)/interm)
+ resWeights[, k] <- res
+ names(resWeights)[k] <- "VW"
+ }
+ if (meth == 2) {
+ nbesp <- length(phyl$leaves)
+ es1 <- lapply(phyl$paths[1:nbesp], function(x) x[-length(x)])
+ fun <- function(x) {
+ interm <- 0
+ for (i in 1:length(x)) {
+ interm <- interm + length(phyl$parts[[x[i]]])
+ }
+ return(interm)
+ }
+ es2 <- lapply(es1, fun)
+ es2 <- unlist(es2)
+ res <- max(es2)/es2/sum(max(es2)/es2)
+ resWeights[, k] <- res
+ names(resWeights)[k] <- "M"
+ }
+ if (meth == 3) {
+ len <- length(phyl$path)
+ nam <- names(phyl$path)
+ NbPerNode <- cbind.data.frame(Nb = rep(0, len))
+ rownames(NbPerNode) <- nam
+ NbPerNode[1:nbesp, ] <- 1
+ for (i in (nbesp + 1):len) {
+ NbPerNode[i, ] <- sum(NbPerNode[phyl$parts[[i -
+ nbesp]], ])
+ }
+ BinPerNode <- cbind.data.frame(Nb = rep(0, len))
+ CoPerNode <- NbPerNode - 1
+ for (i in 1:(len - nbesp)) {
+ index <- phyl$parts[[i]]
+ len.index <- length(index)
+ interm <- sapply(index, function(x) CoPerNode[x,
+ ])
+ if (sum(interm) == 0) {
+ BinPerNode[index, ] <- 0
+ }
+ else {
+ if (len.index == 2) {
+ if (interm[1] == interm[2]) {
+ BinPerNode[index, ] <- 1/2
+ }
+ else {
+ BinPerNode[index[rank(interm)], ] <- c(0,
+ 1)
+ }
+ }
+ else {
+ if (length(unique(interm)) == 1) {
+ BinPerNode[index[rank(interm)], ] <- 1/len.index
+ }
+ else {
+ Rank.1 <- as.factor(rank(interm))
+ Rank.1 <- as.numeric(Rank.1)
+ nb.groups <- length(unique(interm))
+ if (nb.groups == 2)
+ Rank.2 <- c(0, 1)
+ else Rank.2 <- c(((nb.groups - 1):1)/nb.groups,
+ 0)[nb.groups:1]
+ BinPerNode[index, ] <- Rank.2[Rank.1]
+ }
+ }
+ }
+ }
+ res <- lapply(phyl$path[1:nbesp], function(x) if (length(x) >
+ 2)
+ sum(BinPerNode[x[2:(length(x) - 1)], ])
+ else BinPerNode[x[2], ])
+ res <- 1/(unlist(res) + 1)
+ res <- res/sum(res)
+ resWeights[, k] <- res
+ names(resWeights)[k] <- "NWU*"
+ }
+ if (meth == 4) {
+ len <- length(phyl$path)
+ nam <- names(phyl$path)
+ NbPerNode <- cbind.data.frame(Nb = rep(0, len))
+ rownames(NbPerNode) <- nam
+ NbPerNode[1:nbesp, ] <- 1
+ for (i in (nbesp + 1):len) {
+ NbPerNode[i, ] <- sum(NbPerNode[phyl$parts[[i -
+ nbesp]], ])
+ }
+ res <- lapply(phyl$path[1:nbesp], function(x) sum(NbPerNode[x[2:(length(x) -
+ 1)], ]))
+ res <- 1/unlist(res)
+ res <- res/sum(res)
+ resWeights[, k] <- res
+ names(resWeights)[k] <- "NWW"
+ }
+ if (meth == 5) {
+ D <- as.matrix(phyl$Wdist^2/2)
+ res <- solve(D) %*% rep(1, nbesp)/sum(solve(D))
+ resWeights[, k] <- res
+ names(resWeights)[k] <- "QEbased"
+ }
+ if (meth == 6) {
+ pathsp <- phyl$paths[1:nbesp]
+ mat1 <- matrix(0, nbesp, nbnodes)
+ colnames(mat1) <- names(phyl$nodes)
+ for(i in 1:nbesp){
+ pathi <- phyl$path[[i]]
+ pathi <- pathi[-length(pathi)]
+ mat1[i, pathi] <- 1
+ }
+ wedges <- cbind.data.frame(apply(mat1, 2, sum))
+ rownames(wedges) <- names(phyl$nodes)
+ ndescendents <- unlist(lapply(phyl$parts, length))
+ reslist <- lapply(pathsp, function(x) sum(c(unlist(phyl$nodes[x[-length(x)]])/wedges[x[-length(x)], ], phyl$leaves[x[length(x)]])))
+ res <- unlist(reslist)
+ resWeights[, k] <- res
+ names(resWeights)[k] <- "ED"
+ }
+ if (meth == 7) {
+ pathsp <- phyl$paths[1:nbesp]
+ ndescendents <- unlist(lapply(phyl$parts, length))
+ reslist <- lapply(pathsp, function(x)
+ sum(c(unlist(phyl$nodes[x[-length(x)]]) /
+ rev(cumprod(rev(ndescendents[x[-length(x)]]))),
+ phyl$leaves[x[length(x)]])))
+ res <- unlist(reslist)
+ resWeights[, k] <- res
+ names(resWeights)[k] <- "eqsplit"
+ }
+ }
+ return(resWeights)
+}
diff --git a/R/orisaved.R b/R/orisaved.R
new file mode 100644
index 0000000..60f8b36
--- /dev/null
+++ b/R/orisaved.R
@@ -0,0 +1,27 @@
+"orisaved" <- function(phyl, rate = 0.1, method = 1)
+{
+ if (!inherits(phyl, "phylog")) stop("unconvenient phyl")
+ if(is.null(phyl$Wdist)) phyl <- newick2phylog.addtools(phyl)
+ if (any(is.na(match(method, 1:2)))) stop("unconvenient method")
+ if (length(method) != 1) stop("only one method can be chosen")
+ if (length(rate) != 1) stop("unconvenient rate")
+ if (!is.numeric(rate)) stop("rate must be a real value")
+ if (!(rate>=0 & rate<=1)) stop("rate must be between 0 and 1")
+ if (rate == 0) return(0)
+ phy.h <- hclust(phyl$Wdist^2 / 2)
+ nbesp <- length(phy.h$labels)
+ Rate <- round(seq(0, nbesp, by = nbesp * rate))
+ Rate <- Rate[-1]
+ phyl.D <- as.matrix(phyl$Wdist^2 / 2)
+ Orig <- (solve(phyl.D)%*%rep(1, nbesp) / sum(solve(phyl.D)))
+ OrigCalc <- function(i) {
+ if (method == 1) {
+ return(sum(unlist(lapply(split(Orig, cutree(phy.h, i)), max))))
+ }
+ if (method == 2) {
+ return(sum(unlist(lapply(split(Orig, cutree(phy.h, i)), min))))
+ }
+ }
+ res <- c(0, sapply(Rate, OrigCalc))
+ return(res)
+}
diff --git a/R/orthobasis.R b/R/orthobasis.R
new file mode 100644
index 0000000..f00fc4e
--- /dev/null
+++ b/R/orthobasis.R
@@ -0,0 +1,351 @@
+## define 'orthobasis' as a subclass of 'data.frame'. This allows to introduce an 'orthobasis' object in slot @data in sp objects.
+setOldClass(c("orthobasis","data.frame"))
+
+## TODO NEW
+is.orthobasis <- function(x){
+ if(!inherits(x,"orthobasis"))
+ return(FALSE)
+ wt <- attr(x,"weights")
+ x <- as.matrix(x)
+ # vectors should be centred
+ test <- isTRUE(all.equal(rep(0, ncol(x)), apply(x, 2, weighted.mean, w = wt), check.attributes = FALSE))
+ # test orthogonality
+ if(test){
+ test <- test & isTRUE(all.equal(diag(1,ncol(x)), crossprod(x*wt,x), check.attributes = FALSE))
+ }
+ return(test)
+}
+
+## TODO updated
+print.orthobasis <- function(x,..., nr = 6, nc = 4) {
+ cat("Orthobasis with", nrow(x),"rows and", ncol(x),"columns\n")
+ cat("Only", min(nr, nrow(x)), "rows and", min(nc, ncol(x)) , "columns are shown\n")
+ print.data.frame(x[1:min(nr, nrow(x)), 1:min(nc, ncol(x))])
+}
+
+## TODO new
+summary.orthobasis <- function(object,...) {
+ if (!inherits(object,"orthobasis")) stop ("for 'orthobasis' object")
+ cat("Orthonormal basis: ")
+ n <- nrow(object)
+ p <- ncol(object)
+ cat("data.frame with",n,"rows and",ncol(object),"columns\n")
+ cat("----------------------------------------------------------------\n")
+ cat("Columns form a centred orthonormal basis (i.e. 1n-orthogonal)\n")
+ cat("for the inner product defined by the 'weights' attribute\n")
+ cat("----------------------------------------------------------------\n")
+ w <- attributes(object)
+ cat("\nAttributes:\n")
+ if (!is.null(w$names)) cat("- names:", w$names[1],"...",w$names[p],"\n")
+ if (!is.null(w$row.names)) cat("- row.names:", w$row.names[1],"...",w$row.names[n],"\n")
+ if (!is.null(w$weights)) cat("- weights:", w$weights[1],"...",w$weights[n],"\n")
+ if (!is.null(w$values)) cat("- values:", w$values[1],"...",w$values[p],"\n")
+ if (!is.null(w$class)) cat("- class:", w$class,"\n")
+ if (!is.null(w$call)) cat("- call:", deparse(w$call), "\n\n")
+
+}
+
+## TODO new
+plot.orthobasis <- function(x,...){
+ table.value(x,...)
+}
+
+
+orthobasis.mat <- function(mat, cnw=TRUE) {
+ if (!is.matrix(mat)) stop ("matrix expected")
+ if (any(mat<0)) stop ("negative value in 'mat'")
+ if (nrow(mat)!=ncol(mat)) stop ("squared matrix expected")
+ mat <- (mat+t(mat))/2
+ nlig <- nrow(mat)
+ if (is.null(dimnames(mat))) {
+ w <- paste("P",1:nrow(mat),sep="")
+ dimnames(mat) <- list(w,w)
+ }
+ labels <- dimnames(mat)[[1]]
+ if (cnw) {
+ margi <- apply(mat,1,sum)
+ margi <- max(margi)-margi
+ mat <- mat+diag(margi)
+ }
+ mat <- mat/sum(mat)
+ wt <- rep ((1/nlig),nlig)
+ # calculs extensibles à une pondération quelconque
+ wt <- wt/sum(wt)
+ # si mat wt est la pondération marginale associée à mat
+ # tot = sum(mat)
+ # mat = mat-matrix(wt,nlig,nlig,byrow=TRUE)*wt*tot
+ # encore plus particulier mat = mat-1/nlig/nlig
+ # en général les précédents sont des cas particuliers
+ U <- matrix(1,nlig,nlig)
+ U <- diag(1,nlig)-U*wt
+ mat <- U%*%mat%*%t(U)
+ wt <- sqrt(wt)
+ mat <- t(t(mat)/wt)
+ mat <- mat/wt
+ eig <- eigen(mat,symmetric = TRUE)
+ w0 <- abs(eig$values)/max(abs(eig$values))
+ tol <- 1e-07
+ w0 <- which(w0<tol)
+ if (length(w0)==0) stop ("abnormal output : no null eigenvalue")
+ else if (length(w0)==1) w0 <- (1:nlig)[-w0]
+ else if (length(w0)>1) {
+ # on ajoute le vecteur dérivé de 1n
+ w <- cbind(wt,eig$vectors[,w0])
+ # on orthonormalise l'ensemble
+ w <- qr.Q(qr(w))
+ # on met les valeurs propres à 0
+ eig$values[w0] <- 0
+ # on remplace les vecteurs du noyau par une base orthonormée contenant
+ # en première position le parasite
+ eig$vectors[,w0] <- w[,-ncol(w)]
+ # on enlève la position du parasite
+ w0 <- (1:nlig)[-w0[1]]
+ }
+ mat <- eig$vectors[,w0]/wt
+ mat <- data.frame(mat)
+ row.names(mat) <- labels
+ names(mat) <- paste("S",1:(nlig-1),sep="")
+ attr(mat,"values") <- eig$values[w0]
+ attr(mat,"weights") <- rep(1/nlig,nlig)
+ attr(mat,"call") <- match.call()
+ attr(mat,"class") <- c("orthobasis","data.frame")
+ return(mat)
+}
+
+"orthobasis.haar" <- function(n) {
+# on définit deux fonctions :
+ appel = match.call()
+ a <- log(n)/log(2)
+ b <- floor(a)
+ if ((a-b)^2>1e-10) stop ("Haar is not a power of 2")
+# la première est écrite par Daniel et elle donne la démonstration (par analogie avec la fonction qui construit la base Bscores)
+# que la base Bscores est exactement la base de Haar quand on prend une phylogénie régulière résolue.
+"haar.basis.1" <- function (n) {
+ pari <- matrix(c(1,n),1)
+ "div2" <- function (mat) {
+ res <- NULL
+ for (k in 1 : nrow(mat)) {
+ n1 <- mat[k,1]
+ n2 <- mat[k,2]
+ diff <- n2-n1
+ if (diff <=0) break
+ n3 <- floor((n1+n2)/2)
+ res <- rbind(res,c(n1,n3),c(n3+1,n2))
+ }
+ if (!is.null(res)) pari <<- rbind(pari,res)
+ return(res)
+ }
+ mat <- div2(pari)
+ while (!is.null(mat)) mat <- div2(mat)
+ res <- NULL
+ for (k in 1:nrow(pari)) {
+ x<-rep(0,n)
+ x[(pari[k,1]):(pari[k,2])] <- 1
+ res <-c(res,x)
+ }
+ res = matrix(res,n)
+ res <- qr.Q(qr(res))
+ res <- res[, -1] * sqrt(n)
+ res <- data.frame(res)
+ row.names(res) <- paste("u",1:n,sep="")
+ names(res) <- paste("B",1:(n-1),sep="")
+return(res)
+}
+
+# la seconde exploite les potentialités de la librairie waveslim, en remarquant qu'il existe un lien étroit entre la définition des filtres et la définition
+# des bases. Cette stratégie permettra à l'avenir de définir les bases associées à d'autres famille de fonctions.
+"haar.basis.2" <- function (n) {
+ J <- a #nombre de niveau
+ res <- matrix(0, nrow = n,ncol = n-1)
+ filter.seq <- "H" #filtre correspondant au niveau 1
+ h <- waveslim::wavelet.filter(wf.name = "haar", filter.seq = filter.seq) #paramètre du filtre au niveau 1
+ k <- 0
+ for(i in 1:J){
+ z <- rep(h,2**(J-i))
+ x <- 1:n
+ y <- rep((n-1-k):(n-2**(J-i)-k),rep(2**i,2**(J-i)))
+ for(j in 1:n) res[x[j],y[j]] <- z[j]
+ k <- k+2**(J-i)
+ filter.seq <- paste(filter.seq, "L", sep = "")
+ h <- waveslim::wavelet.filter(wf.name = "haar", filter.seq = filter.seq)
+ }
+ res <- res*sqrt(n)
+ res <- data.frame(res)
+ row.names(res) <- paste("u", 1:n, sep = "")
+ names(res) <- paste("B", 1:(n-1), sep = "")
+return(res)
+}
+
+# suivant que n est grand (n > 257) ou non, on choisit l'une des deux stratégies :
+ if (n < 257)
+ res <- haar.basis.1(n)
+ else
+ res <- haar.basis.2(n)
+
+ attr(res,"values") <- NULL
+ attr(res,"weights") <- rep(1/n,n)
+ attr(res,"call") <- appel
+ attr(res,"class") <- c("orthobasis","data.frame")
+ return(res)
+}
+
+"orthobasis.line" <- function (n) {
+ appel <- match.call()
+ # solution de Cornillon p. 12
+ res <- NULL
+ for (k in 1:(n-1)) {
+ x <- cos(k*pi*(2*(1:n)-1)/2/n)
+ x <- sqrt(n)*x/sqrt(sum(x*x))
+ res <-c(res,x)
+ }
+ res=matrix(res,n)
+ res <- data.frame(res)
+ row.names(res) <- paste("u",1:n,sep="")
+ names(res) <- paste("B",1:(n-1),sep="")
+ w <- (1:(n-1))*pi/2/n
+ valpro <- 4*(sin(w)^2)/n
+ poivoisi <- c(1,rep(2,n-2),1)
+ poivoisi <- poivoisi/sum(poivoisi)
+ norm <- unlist(apply(res, 2, function(a) sum(a*a*poivoisi)))
+ y <- valpro*n*n/2/(n-1)
+ val <- norm - y
+ attr(res,"values") <- val
+ attr(res,"weights") <- rep(1/n,n)
+ attr(res,"call") <- appel
+ attr(res,"class") <- c("orthobasis","data.frame")
+
+ # vérification locale. Ce paragraphe vérifie que les vecteurs et les valeurs
+ # proposée par Cornillon p. 12 sont bien les vecteurs propres de l'opérateur de voisinage
+ # rangée dans la solution analytique par variance locale croissante
+ # l'article de Méot est erroné et a donné le graphe circulaire pour le graphe linéaire
+ # d0=neig2mat(neig(n.lin=n))
+ # d0 = d0/n
+ # d1=apply(d0,1,sum)
+ # d0=diag(d1)-d0
+ # fun2 <- function(x) {
+ # z <- sum(t(d0*x)*x)/n
+ # z <- z/sum(x*x)
+ # return(z)
+ # }
+ # lambda <- unlist(apply(res,2,fun2))
+ # print(lambda)
+ # print(attr(res,"values"))
+ # plot(lambda,attr(res,"values"))
+ # abline(lm(attr(res,"values")~lambda))
+ # print(coefficients(lm(attr(res,"values")~lambda)))
+
+ # vérification que les valeurs dérivées des valeurs propres sont exactement des indices de Moran
+ # d = neig2mat(neig(n.lin=n))
+ # d = d/sum(d) # Moran type W
+ # moran <- unlist(lapply(res,function(x) sum(t(d*x)*x)))
+ # print(moran)
+ # plot(moran,attr(res,"values"))
+ # abline(lm(attr(res,"values")~moran))
+ # print(summary(lm(attr(res,"values")~moran)))
+ return(res)
+}
+
+"orthobasis.circ" <- function (n) {
+ appel = match.call()
+ if (n<3) stop ("'n' too small")
+ "vecprosin" <- function(k) {
+ x <- sin(2*k*pi*(1:n)/n)
+ x <- x/sqrt(sum(x*x))
+ }
+ "vecprocos" <- function(k) {
+ x <- cos(2*k*pi*(1:n)/n)
+ x <- x/sqrt(sum(x*x))
+ }
+ "valpro" <- function(k,bis=TRUE) {
+ x <- (4/n)*((sin(k*pi/n))^2)
+ if (bis) x <- c(x,x)
+ return(x)
+ }
+
+ k <- floor(n/2)
+ if (k==n/2) {
+ #n est pair
+ w1 <- matrix(unlist(lapply(1:k,vecprocos)),n,k)
+ w2 <- matrix(unlist(lapply(1:(k-1),vecprosin)),n,k-1)
+ res <- cbind(w1,w2)
+ res[,seq(1,2*k-1,by=2)]<-w1
+ res[,seq(2,2*k-2,by=2)]<-w2
+ vp <- unlist(lapply(1:(k-1),valpro))
+ vp <- c(vp, valpro(k,FALSE))
+ } else {
+ # n est impair
+ w1 <- matrix(unlist(lapply(1:k,vecprocos)),n,k)
+ w2 <- matrix(unlist(lapply(1:k,vecprosin)),n,k)
+ res <- cbind(w1,w2)
+ res[,seq(1,2*k-1,by=2)]<-w1
+ res[,seq(2,2*k,by=2)]<-w2
+ vp <- unlist(lapply(1:k,valpro))
+ }
+ res=sqrt(n)*res
+ res <- as.data.frame(res)
+ row.names(res) <- paste("u",1:n,sep="")
+ names(res) <- paste("B",1:(n-1),sep="")
+ attr(res,"values") <- 1 - n*vp/2
+ attr(res,"weights") <- rep(1/n,n)
+ attr(res,"call") <- appel
+ attr(res,"class") <- c("orthobasis","data.frame")
+ # vérification qu'on a exactement des indices de Moran à partie des valeurs propres
+ # d = neig2mat(neig(n.cir=n))
+ # d = d/sum(d) # Moran type W
+ # moran <- unlist(lapply(res,function(x) sum(t(d*x)*x)))
+ # print(moran)
+ # plot(moran,attr(res,"values"))
+ # abline(lm(attr(res,"values")~moran))
+ # print(summary(lm(attr(res,"values")~moran)))
+ return(res)
+}
+
+
+
+"orthobasis.neig" <- function( neig) {
+ appel = match.call()
+ if(!inherits(neig,"neig")) stop ("object of class 'neig' expected")
+ n <- length(attr(neig,"degree"))
+ m <- sum(attr(neig,"degree"))
+ poivoisi <- attr(neig,"degree")/m
+ if (is.null(names(poivoisi))) names(poivoisi) <- as.character(1:n)
+ d0 = neig2mat(neig)
+ d0 = diag(poivoisi)-d0/m
+ eig <- eigen(d0, symmetric = TRUE)
+ ########
+ tol <- 1e-07
+ w0 <- abs(eig$values)/max(abs(eig$values))
+ w0 <- which(w0<tol)
+ if (length(w0)==0) stop ("abnormal output : no null eigenvalue")
+ else if (length(w0)==1) w0 <- (1:n)[-w0]
+ else if (length(w0)>1) {
+ # on ajoute le vecteur dérivé de 1n
+ wt <- rep(1,n)
+ w <- cbind(wt,eig$vectors[,w0])
+ # on orthonormalise l'ensemble
+ w <- qr.Q(qr(w))
+ # on met les valeurs propres à 0
+ eig$values[w0] <- 0
+ # on remplace les vecteurs du noyau par une base orthonormée contenant
+ # en première position le parasite
+ eig$vectors[,w0] <- w[,-ncol(w)]
+ # on enlève la position du parasite
+ w0 <- (1:n)[-w0[1]]
+ }
+ w0 <- rev(w0)
+ valpro <- eig$values[w0]
+ eig <- eig$vectors[,w0]
+ eig <- as.data.frame(eig)*sqrt(n)
+ z <- apply(eig,2,function(x) sum(x*x*poivoisi))
+ z <- z - valpro*n
+ w <- rev(order(z))
+ z <- z[w]
+ eig <- eig[,w]
+ row.names(eig) <- names(poivoisi)
+ names(eig) <- paste("VP", 1:(n-1), sep = "")
+ attr(eig,"values") <- z
+ attr(eig,"weights") <- rep(1/n,n)
+ attr(eig,"call") <- appel
+ attr(eig,"class") <- c("orthobasis","data.frame")
+ return(eig)
+}
diff --git a/R/orthogram.R b/R/orthogram.R
new file mode 100644
index 0000000..0c9cbf8
--- /dev/null
+++ b/R/orthogram.R
@@ -0,0 +1,183 @@
+"orthogram"<- function (x, orthobas = NULL, neig = NULL, phylog = NULL,
+ nrepet = 999, posinega = 0, tol = 1e-07,
+ na.action = c("fail", "mean"),
+ cdot = 1.5, cfont.main = 1.5, lwd = 2, nclass, high.scores = 0,alter=c("greater", "less", "two-sided"), ...)
+{
+ .Deprecated("orthogram", "ade4", msg="This function is now deprecated. Please use the fuction 'orthogram' in adephylo.")
+ "orthoneig" <- function (obj) {
+ if (!inherits(obj, "neig"))
+ stop("Object of class 'neig' expected")
+ b0 <- neig.util.LtoG(obj)
+ deg <- attr(obj, "degrees")
+ m <- sum(deg)
+ n <- length(deg)
+ b0 <- -b0/m + diag(deg)/m
+ # b0 est la matrice D-P
+ eig <- eigen (b0, symmetric = TRUE)
+ w0 <- abs(eig$values)/max(abs(eig$values))
+ w0 <- which(w0<tol)
+ if (length(w0)==0) stop ("abnormal output : no null eigenvalue")
+ if (length(w0)==1) w0 <- (1:n)[-w0]
+ else if (length(w0)>1) {
+ # on ajoute le vecteur dérivé de 1n
+ w <- cbind(rep(1,n),eig$vectors[,w0])
+ # on orthonormalise l'ensemble
+ w <- qr.Q(qr(w))
+ # on met les valeurs propres à 0
+ eig$values[w0] <- 0
+ # on remplace les vecteurs du noyau par une base orthonormée contenant
+ # en première position le parasite
+ eig$vectors[,w0] <- w[,-ncol(w)]
+ # on enlève la position du parasite
+ w0 <- (1:n)[-w0[1]]
+ }
+ w0=rev(w0)
+ rank <- length(w0)
+ values <- n-eig$values[w0]*n
+ eig <- eig$vectors[,w0]*sqrt(n)
+ eig <- data.frame(eig)
+ row.names(eig) <- names(deg)
+ names(eig) <- paste("V",1:rank,sep="")
+ attr(eig,"values")<-values
+ eig
+ }
+
+ if (!is.numeric(x)) stop("x is not numeric")
+ nobs <- length(x)
+ if (!is.null(neig)) {
+ orthobas <- orthoneig(neig)
+ } else if (!is.null(phylog)) {
+ if (!inherits(phylog, "phylog")) stop ("'phylog' expected with class 'phylog'")
+ orthobas <- phylog$Bscores
+ }
+
+ if (is.null(orthobas)){
+ stop ("'orthobas','neig','phylog' all NULL")
+ }
+
+ if (!inherits(orthobas, "data.frame")) stop ("'orthobas' is not a data.frame")
+ if (nrow(orthobas) != nobs) stop ("non convenient dimensions")
+ if (ncol(orthobas) != (nobs-1)) stop (paste("'orthobas' has",ncol(orthobas),"columns, expected:",nobs-1))
+ vecpro <- as.matrix(orthobas)
+ npro <- ncol(vecpro)
+ if (any(is.na(x))) {
+ if (na.action == "fail")
+ stop("missing value in 'x'")
+ else if (na.action == "mean")
+ x[is.na(x)] <- mean(na.omit(x))
+ else stop("unknown method for 'na.action'")
+ }
+ w <- t(vecpro/nobs)%*%vecpro
+ if (any(abs(diag(w)-1)>tol)) {
+ # print(abs(diag(w)-1))
+ stop("'orthobas' is not orthonormal for uniform weighting")
+ }
+ diag(w) <- 0
+ if ( any( abs(as.numeric(w))>tol) )
+ stop("'orthobas' is not orthogonal for uniform weighting")
+ if (nrepet < 99) nrepet <- 99
+ if (posinega !=0) {
+ if (posinega >= nobs-1) stop ("Non convenient value in 'posinega'")
+ if (posinega <0) stop ("Non convenient value in 'posinega'")
+ }
+
+ # préparation d'un graphique à 6 fenêtres
+ # 1 pgram
+ # 2 pgram cumulé
+ # 3-6 Tests de randomisation
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ layout (matrix(c(1,1,2,2,1,1,2,2,3,4,5,6),4,3))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ par(usr = c(0,1,-0.05,1))
+ # layout.show(6)
+
+ z <- x - mean(x)
+ et <- sqrt(mean(z * z))
+ if ( et <= tol*(max(z)-min(z))) stop ("No variance")
+ z <- z/et
+ sig50 <- (1:npro)/npro
+ w <- .C("VarianceDecompInOrthoBasis",
+ param = as.integer(c(nobs,npro,nrepet,posinega)),
+ observed = as.double(z),
+ vecpro = as.double(vecpro),
+ phylogram = double(npro),
+ phylo95 = double(npro),
+ sig025 = double(npro),
+ sig975 = double(npro),
+ R2Max = double(nrepet+1),
+ SkR2k = double(nrepet+1),
+ Dmax = double(nrepet+1),
+ SCE = double(nrepet+1),
+ ratio = double(nrepet+1),
+ PACKAGE="ade4"
+ )
+ ylim <- max(c(w$phylogram, w$phylo95))
+ z0 <- apply(vecpro, 2, function(x) sum(z * x))
+ names(w$phylogram) <- as.character(1:npro)
+ phylocum <- cumsum(w$phylogram)
+ lwd0=2
+ fun <- function (y, last=FALSE) {
+ delta <- (mp[2]-mp[1])/3
+ sel <- 1:(npro - 1)
+ segments(mp[sel]-delta,y[sel],mp[sel]+delta, y[sel],lwd=lwd0)
+ if(last) segments(mp[npro]-delta,y[npro],mp[npro]+delta, y[npro],lwd=lwd0)
+ }
+ y0 <- phylocum - sig50
+ h.obs <- max(y0)
+ x0 <- min(which(y0 == h.obs))
+ par(mar = c(3.1, 2.5, 2.1, 2.1))
+ mp <- barplot(w$phylogram, col = grey(1 - 0.3 * (sign(z0) > 0)),
+ ylim = c(0, ylim * 1.05))
+ scores.order <- (1:length(w$phylogram))[order(w$phylogram, decreasing=TRUE)[1:high.scores]]
+ fun(w$phylo95,TRUE)
+ abline(h = 1/npro)
+ if (posinega!=0) {
+ verti = (mp[posinega]+mp[posinega+1])/2
+ abline (v=verti, col="red",lwd=1.5)
+ }
+ title(main = "Variance decomposition",font.main=1, cex.main=cfont.main)
+ box()
+ obs0 <- rep(0, npro)
+ names(obs0) <- as.character(1:npro)
+ barplot(obs0, ylim = c(-0.05, 1.05))
+ abline(h=0,col="white")
+ if (posinega!=0) {
+ verti = (mp[posinega]+mp[posinega+1])/2
+ abline (v=verti, col="red",lwd=1.5)
+ }
+
+ title(main = "Cumulative decomposition",font.main=1, cex.main=cfont.main)
+ points(mp, phylocum, pch = 21, cex = cdot, type = "b")
+ segments(mp[1], 1/npro, mp[npro], 1, lty = 1)
+ fun(w$sig975)
+ fun(w$sig025)
+ arrows(mp[x0], sig50[x0], mp[x0], phylocum[x0], angle = 15, length = 0.15,
+ lwd = 2)
+ box()
+ if (missing(nclass)) {
+ nclass <- as.integer (nrepet/25)
+ nclass <- min(c(nclass,40))
+ }
+ plot.randtest (as.randtest (w$R2Max[-1],w$R2Max[1],call=match.call(), output = "full"),main = "R2Max",nclass=nclass)
+ if (posinega !=0) {
+ plot.randtest (as.randtest (w$ratio[-1],w$ratio[1],call=match.call(), output = "full"),main = "Ratio",nclass=nclass)
+ } else {
+ plot.randtest (as.randtest (w$SkR2k[-1],w$SkR2k[1],call=match.call(), output = "full"),main = "SkR2k",nclass=nclass)
+ }
+ plot.randtest (as.randtest (w$Dmax[-1],w$Dmax[1], call=match.call(), output = "full"),main = "DMax",nclass=nclass)
+ plot.randtest (as.randtest (w$SCE[-1],w$SCE[1], call=match.call(), output = "full"),main = "SCE", nclass=nclass)
+
+ w$param <- w$observed <- w$vecpro <- NULL
+ w$phylogram <- NULL
+ w$phylo95 <- w$sig025 <- w$sig975 <- NULL
+ if (posinega==0) {
+ w <- as.krandtest(obs=c(w$R2Max[1],w$SkR2k[1],w$Dmax[1],w$SCE[1]),sim=cbind(w$R2Max[-1],w$SkR2k[-1],w$Dmax[-1],w$SCE[-1]),names=c("R2Max","SkR2k","Dmax","SCE"),alter=alter,call=match.call(), ...)
+ } else {
+ w <- as.krandtest(obs=c(w$R2Max[1],w$SkR2k[1],w$Dmax[1],w$SCE[1],w$ratio[1]),sim=cbind(w$R2Max[-1],w$SkR2k[-1],w$Dmax[-1],w$SCE[-1],w$ratio[-1]),names=c("R2Max","SkR2k","Dmax","SCE","ratio"),alter=alter,call=match.call(), ...)
+ }
+
+ if (high.scores != 0)
+ w$scores.order <- scores.order
+ return(w)
+}
diff --git a/R/p.adjust.4thcorner.R b/R/p.adjust.4thcorner.R
new file mode 100644
index 0000000..30f49f7
--- /dev/null
+++ b/R/p.adjust.4thcorner.R
@@ -0,0 +1,40 @@
+p.adjust.4thcorner <- function(x, p.adjust.method.G = p.adjust.methods, p.adjust.method.D = p.adjust.methods, p.adjust.D = c("global", "levels")){
+
+ if(!inherits(x, "4thcorner") & !inherits(x, "4thcorner.rlq"))
+ stop("x must be of class '4thcorner' or '4thcorner.rlq'")
+
+ p.adjust.D <- match.arg(p.adjust.D)
+ p.adjust.method.D <- match.arg(p.adjust.method.D)
+ p.adjust.method.G <- match.arg(p.adjust.method.G)
+
+ ## for objects created by fourthcorner, fourthcorner2 or fourthcorner.rlq
+ x$tabG$adj.pvalue <- p.adjust(x$tabG$pvalue, method=p.adjust.method.G)
+ x$tabG$adj.method <- p.adjust.method.G
+
+ ## tabD and tabD2 (i.e. not fourthcorner2)
+ if(!inherits(x, "4thcorner.rlq")){
+ if(p.adjust.D == "global"){
+ x$tabD$adj.pvalue <- p.adjust(x$tabD$pvalue, method=p.adjust.method.D)
+ x$tabD2$adj.pvalue <- p.adjust(x$tabD2$pvalue, method=p.adjust.method.D)
+ x$tabD$adj.method <- x$tabD2$adj.method <- p.adjust.method.D
+ }
+
+ if(p.adjust.D == "levels"){
+ ## adjustment only between levels of a factor (corresponds to the original paper of Legendre et al. 1997)
+ for (i in 1:length(x$varnames.Q)){
+ for (j in 1:length(x$varnames.R)){
+ idx.varR <- which(x$assignR == j)
+ idx.varQ <- which(x$assignQ == i)
+ idx.vars <- length(x$varnames.R) * (idx.varQ - 1) + idx.varR
+ x$tabD$adj.pvalue[idx.vars] <- p.adjust(x$tabD$pvalue[idx.vars], method = p.adjust.method.D)
+ x$tabD2$adj.pvalue[idx.vars] <- p.adjust(x$tabD2$pvalue[idx.vars], method = p.adjust.method.D)
+ }
+ }
+ x$tabD$adj.method <- x$tabD2$adj.method <- paste(p.adjust.method.D, "by levels")
+ }
+
+ }
+
+ return(x)
+
+}
diff --git a/R/pcaiv.R b/R/pcaiv.R
new file mode 100644
index 0000000..57b4ccf
--- /dev/null
+++ b/R/pcaiv.R
@@ -0,0 +1,189 @@
+"pcaiv" <- function (dudi, df, scannf = TRUE, nf = 2) {
+ lm.pcaiv <- function(x, df, weights, use) {
+ if (!inherits(df, "data.frame"))
+ stop("data.frame expected")
+ reponse.generic <- x
+ begin <- "reponse.generic ~ "
+ fmla <- as.formula(paste(begin, paste(names(df), collapse = "+")))
+ df <- cbind.data.frame(reponse.generic, df)
+ lm0 <- lm(fmla, data = df, weights = weights)
+ if (use == 0)
+ return(predict(lm0))
+ else if (use == 1)
+ return(residuals(lm0))
+ else if (use == -1)
+ return(lm0)
+ else stop("Non convenient use")
+ }
+ if (!inherits(dudi, "dudi"))
+ stop("dudi is not a 'dudi' object")
+ df <- data.frame(df)
+ if (!inherits(df, "data.frame"))
+ stop("df is not a 'data.frame'")
+ if (nrow(df) != length(dudi$lw))
+ stop("Non convenient dimensions")
+ weights <- dudi$lw
+ isfactor <- unlist(lapply(as.list(df), is.factor))
+ for (i in 1:ncol(df)) {
+ if (!isfactor[i])
+ df[, i] <- scalewt(df[, i], weights)
+ }
+ tab <- data.frame(apply(dudi$tab, 2, lm.pcaiv, df = df, use = 0,
+ weights = dudi$lw))
+ X <- as.dudi(tab, dudi$cw, dudi$lw, scannf = scannf, nf = nf,
+ call = match.call(), type = "pcaiv")
+ X$X <- df
+ X$Y <- dudi$tab
+ U <- as.matrix(X$c1) * unlist(X$cw)
+ U <- as.matrix(dudi$tab) %*% U
+ U <- data.frame(U)
+ row.names(U) <- row.names(dudi$tab)
+ names(U) <- names(X$li)
+ X$ls <- U
+
+ U <- as.matrix(X$c1) * unlist(X$cw)
+ U <- data.frame(t(as.matrix(dudi$c1)) %*% U)
+ row.names(U) <- names(dudi$li)
+ names(U) <- names(X$li)
+ X$as <- U
+ w <- apply(X$ls, 2, function(x) coefficients(lm.pcaiv(x,
+ df, weights, -1)))
+ w <- data.frame(w)
+ names(w) <- names(X$l1)
+ X$fa <- w
+ fmla <- as.formula(paste("~ ", paste(names(df), collapse = "+")))
+ w <- scalewt(model.matrix(fmla, data = df)[,-1], weights) * weights
+ w <- t(w) %*% as.matrix(X$l1)
+ w <- data.frame(w)
+ X$cor <- w
+ if (inherits(dudi, "coa"))
+ class(X) <- c("caiv", class(X))
+ return(X)
+}
+
+"plot.pcaiv" <- function (x, xax = 1, yax = 2, ...) {
+ if (!inherits(x, "pcaiv"))
+ stop("Use only with 'pcaiv' objects")
+ if (x$nf == 1) {
+ warnings("One axis only : not yet implemented")
+ return(invisible())
+ }
+ if (xax > x$nf)
+ stop("Non convenient xax")
+ if (yax > x$nf)
+ stop("Non convenient yax")
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3),
+ respect = TRUE)
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ # modif mail P. Giraudoux 25/10/2004
+ s.arrow(na.omit(x$fa), xax, yax, sub = "Loadings", csub = 2,
+ clabel = 1.25)
+ s.arrow(na.omit(x$cor), xax = xax, yax = yax, sub = "Correlation",
+ csub = 2, clabel = 1.25)
+ s.corcircle(x$as, xax, yax, sub = "Inertia axes", csub = 2)
+ s.match(x$li, x$ls, xax, yax, clabel = 1.5, sub = "Scores and predictions",
+ csub = 2)
+ if (inherits(x, "caiv"))
+ s.label(x$co, xax, yax, clabel = 0, cpoint = 3, add.plot = TRUE)
+ if (inherits(x, "caiv"))
+ s.label(x$co, xax, yax, clabel = 1.25, sub = "Species", csub = 2)
+ else s.arrow(x$c1, xax = xax, yax = yax, sub = "Variables", csub = 2,
+ clabel = 1.25)
+ scatterutil.eigen(x$eig, wsel = c(xax, yax))
+}
+
+"print.pcaiv" <- function (x, ...) {
+ if (!inherits(x, "pcaiv"))
+ stop("to be used with 'pcaiv' object")
+ if (inherits(x, "caiv"))
+ cat("Canonical correspondence analysis\n")
+ else
+ cat("Principal Component Analysis with Instrumental Variables\n")
+ cat("call: ")
+ print(x$call)
+ cat("class: ")
+ cat(class(x), "\n")
+ cat("\n$rank (rank) :", x$rank)
+ cat("\n$nf (axis saved) :", x$nf)
+ cat("\n\neigen values: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n\n")
+ else cat("\n\n")
+ sumry <- array("", c(3, 4), list(rep("", 3), c("vector",
+ "length", "mode", "content")))
+ sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
+ sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weigths (from dudi)")
+ sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), "col weigths (from dudi)")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(3, 4), list(rep("", 3), c("data.frame",
+ "nrow", "ncol", "content")))
+ sumry[1, ] <- c("$Y", nrow(x$Y), ncol(x$Y), "Dependant variables")
+ sumry[2, ] <- c("$X", nrow(x$X), ncol(x$X), "Explanatory variables")
+ sumry[3, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "modified array (projected variables)")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(4, 4), list(rep("", 4), c("data.frame",
+ "nrow", "ncol", "content")))
+ sumry[1, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "PPA Pseudo Principal Axes")
+ sumry[2, ] <- c("$as", nrow(x$as), ncol(x$as), "Principal axis of dudi$tab on PAP")
+ sumry[3, ] <- c("$ls", nrow(x$ls), ncol(x$ls), "projection of lines of dudi$tab on PPA")
+ sumry[4, ] <- c("$li", nrow(x$li), ncol(x$li), "$ls predicted by X")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(4, 4), list(rep("", 4), c("data.frame",
+ "nrow", "ncol", "content")))
+ sumry[1, ] <- c("$fa", nrow(x$fa), ncol(x$fa), "Loadings (CPC as linear combinations of X")
+ sumry[2, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "CPC Constraint Principal Components")
+ sumry[3, ] <- c("$co", nrow(x$co), ncol(x$co), "inner product CPC - Y")
+ sumry[4, ] <- c("$cor", nrow(x$cor), ncol(x$cor), "correlation CPC - X")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+
+}
+
+summary.pcaiv <- function(object, ...){
+ if (inherits(object, "caiv"))
+ thetitle <- "Canonical correspondence analysis"
+ else
+ thetitle <- "Principal component analysis with instrumental variables"
+
+ cat(thetitle)
+ cat("\n\n")
+ NextMethod()
+
+ appel <- as.list(object$call)
+ dudi <- eval.parent(appel$dudi)
+
+ cat(paste("Total unconstrained inertia (", deparse(appel$dudi), "): ", sep = ""))
+ cat(signif(sum(dudi$eig), 4))
+ cat("\n\n")
+
+ cat(paste("Inertia of", deparse(appel$dudi), "explained by", deparse(appel$df), "(%): "))
+ cat(signif(sum(object$eig) / sum(dudi$eig) * 100, 4))
+ cat("\n\n")
+
+ if (!inherits(object, "caiv")) {
+ cat("Decomposition per axis:\n")
+
+ sumry <- array(0, c(object$nf, 7), list(1:object$nf, c("iner", "inercum", "inerC", "inercumC", "ratio", "R2", "lambda")))
+ sumry[, 1] <- dudi$eig[1:object$nf]
+ sumry[, 2] <- cumsum(dudi$eig[1:object$nf])
+ varpro <- apply(object$ls, 2, function(x) sum(x * x * object$lw))
+ sumry[, 3] <- varpro
+ sumry[, 4] <- cumsum(varpro)
+ sumry[, 5] <- cumsum(varpro)/cumsum(dudi$eig[1:object$nf])
+ sumry[, 6] <- object$eig[1:object$nf]/varpro
+ sumry[, 7] <- object$eig[1:object$nf]
+ print(sumry, digits = 3)
+ invisible(sumry)
+ }
+}
diff --git a/R/pcaivortho.R b/R/pcaivortho.R
new file mode 100644
index 0000000..b449663
--- /dev/null
+++ b/R/pcaivortho.R
@@ -0,0 +1,82 @@
+"pcaivortho" <- function (dudi, df, scannf = TRUE, nf = 2) {
+ lm.pcaiv <- function(x, df, weights, use) {
+ if (!inherits(df, "data.frame"))
+ stop("data.frame expected")
+ reponse.generic <- x
+ begin <- "reponse.generic ~ "
+ fmla <- as.formula(paste(begin, paste(names(df), collapse = "+")))
+ df <- cbind.data.frame(reponse.generic, df)
+ lm0 <- lm(fmla, data = df, weights = weights)
+ if (use == 0)
+ return(predict(lm0))
+ else if (use == 1)
+ return(residuals(lm0))
+ else if (use == -1)
+ return(lm0)
+ else stop("Non convenient use")
+ }
+ if (!inherits(dudi, "dudi"))
+ stop("dudi is not a 'dudi' object")
+ df <- data.frame(df)
+ if (!inherits(df, "data.frame"))
+ stop("df is not a 'data.frame'")
+ if (nrow(df) != length(dudi$lw))
+ stop("Non convenient dimensions")
+ weights <- dudi$lw
+ isfactor <- unlist(lapply(as.list(df), is.factor))
+ for (i in 1:ncol(df)) {
+ if (!isfactor[i])
+ df[, i] <- scalewt(df[, i], weights)
+ }
+ tab <- data.frame(apply(dudi$tab, 2, lm.pcaiv, df = df, use = 1,
+ weights = dudi$lw))
+ X <- as.dudi(tab, dudi$cw, dudi$lw, scannf = scannf, nf = nf,
+ call = match.call(), type = "pcaivortho")
+ X$X <- df
+ X$Y <- dudi$tab
+ U <- as.matrix(X$c1) * unlist(X$cw)
+ U <- as.matrix(dudi$tab) %*% U
+ U <- data.frame(U)
+ row.names(U) <- row.names(dudi$tab)
+ names(U) <- names(X$li)
+ X$ls <- U
+
+ U <- as.matrix(X$c1) * unlist(X$cw)
+ U <- data.frame(t(as.matrix(dudi$c1)) %*% U)
+ row.names(U) <- names(dudi$li)
+ names(U) <- names(X$li)
+ X$as <- U
+ return(X)
+}
+
+
+summary.pcaivortho <- function(object, ...){
+ thetitle <- "Orthogonal principal component analysis with instrumental variables"
+ cat(thetitle)
+ cat("\n\n")
+ NextMethod()
+
+ appel <- as.list(object$call)
+ dudi <- eval.parent(appel$dudi)
+
+ cat(paste("Total unconstrained inertia (",deparse(appel$dudi),"): ", sep = ""))
+ cat(signif(sum(dudi$eig), 4))
+ cat("\n\n")
+
+ cat(paste("Inertia of" ,deparse(appel$dudi),"not explained by", deparse(appel$df), "(%): "))
+ cat(signif(sum(object$eig) / sum(dudi$eig) * 100, 4))
+ cat("\n\n")
+
+ cat("Decomposition per axis:\n")
+ sumry <- array(0, c(object$nf, 7), list(1:object$nf, c("iner", "inercum", "inerC", "inercumC", "ratio", "R2", "lambda")))
+ sumry[, 1] <- dudi$eig[1:object$nf]
+ sumry[, 2] <- cumsum(dudi$eig[1:object$nf])
+ varpro <- apply(object$ls, 2, function(x) sum(x * x * object$lw))
+ sumry[, 3] <- varpro
+ sumry[, 4] <- cumsum(varpro)
+ sumry[, 5] <- cumsum(varpro)/cumsum(dudi$eig[1:object$nf])
+ sumry[, 6] <- object$eig[1:object$nf]/varpro
+ sumry[, 7] <- object$eig[1:object$nf]
+ print(sumry, digits = 3)
+ invisible(sumry)
+ }
diff --git a/R/pcoscaled.R b/R/pcoscaled.R
new file mode 100644
index 0000000..6ca871d
--- /dev/null
+++ b/R/pcoscaled.R
@@ -0,0 +1,27 @@
+"pcoscaled" <- function (distmat, tol = 1e-07) {
+ if (!inherits(distmat, "dist"))
+ stop("Object of class 'dist' expected")
+ if (!is.euclid(distmat))
+ stop("Euclidean distance expected")
+ lab <- attr(distmat, "Labels")
+ distmat <- as.matrix(distmat)
+ n <- ncol(distmat)
+ if (is.null(lab))
+ lab <- as.character(1:n)
+ delta <- -0.5 * bicenter.wt(distmat * distmat)
+ eig <- eigen(delta, symmetric = TRUE)
+ w0 <- eig$values[n]/eig$values[1]
+ if ((w0 < -tol))
+ stop("Euclidean distance matrix expected")
+ ncomp <- sum(eig$values > (eig$values[1] * tol))
+ x <- as.matrix(eig$vectors[, 1:ncomp])
+ variances <- eig$values[1:ncomp]
+ x <- sweep(x,2,sqrt(variances),"*")
+ inertot <- sum(variances)
+ x <- x/sqrt(inertot)
+ x <- x*sqrt(n)
+ x <- data.frame(x)
+ names(x) <- paste("C", 1:ncomp, sep = "")
+ row.names(x) <- lab
+ return(x)
+}
diff --git a/R/phylog.R b/R/phylog.R
new file mode 100644
index 0000000..828da6c
--- /dev/null
+++ b/R/phylog.R
@@ -0,0 +1,281 @@
+"print.phylog" <- function (x, ...) {
+ phylog <- x
+ if (!inherits(phylog, "phylog"))
+ stop("for 'phylog' object")
+ leaves.n <- length(phylog$leaves)
+ nodes.n <- length(phylog$nodes)
+ cat("Phylogenetic tree with",leaves.n,"leaves and",nodes.n,"nodes\n")
+ cat("$class: ")
+ cat(class(phylog))
+ cat("\n$call: ")
+ print(phylog$call)
+ cat("$tre: ")
+ l0 <- nchar(phylog$tre)
+ if (l0 < 50)
+ cat(phylog$tre, "\n")
+ else {
+ cat(substring(phylog$tre, 1, 25))
+ cat("...")
+ cat(substring(phylog$tre, l0 - 26, l0), "\n")
+ }
+ cat("\n")
+ n1 <-paste("$",names(phylog)[2:6],sep="")
+ sumry <- array(" ", c(length(n1), 3), list(n1, c("class", "length", "content")))
+ # leaves
+ k <- 1; sumry[k,1] <- "numeric" ; sumry[k,2] <- as.character(length(phylog$leaves))
+ sumry[k,3] <- "length of the first preceeding adjacent edge"
+ #nodes
+ k <- 2 ; sumry[k,1] <- "numeric" ; sumry[k,2] <- as.character(length(phylog$nodes))
+ sumry[k,3] <- "length of the first preceeding adjacent edge"
+ #parts
+ k <-3; sumry[k,1] <- "list";sumry[k,2] <- as.character(length(phylog$parts))
+ sumry[k,3] <- "subsets of descendant nodes"
+ #paths
+ k = 4; sumry[k,1] <- "list";sumry[k,2] <- as.character(length(phylog$paths))
+ sumry[k,3] <- "path from root to node or leave"
+ #droot
+ k = 5; sumry[k,1] <- "numeric";sumry[k,2] <- as.character(length(phylog$droot))
+ sumry[k,3] <- "distance to root"
+ print.noquote(sumry)
+ cat("\n")
+ if (is.null(phylog$Wmat)) return(invisible())
+
+ n1 <- names(phylog)[-(1:7)]
+ n1 <- paste("$",n1,sep="")
+ sumry <- array(" ", c(length(n1), 3), list(n1, c("class", "dim", "content")))
+ # 8 Wmat
+ k = 1
+ sumry[k,1] <- "matrix"
+ sumry[k,2] <- paste(nrow(phylog$Wmat),ncol(phylog$Wmat),sep="-")
+ sumry[k,3] <- "W matrix : root to the closest ancestor"
+ #9 Wdist
+ k = 2
+ sumry[k,1] <- "dist" ;
+ sumry[k,2] <- as.character(length(phylog$Wdist))
+ sumry[k,3] <- "Nodal distances"
+ # 10 Wvalues
+ k = 3
+ sumry[k,1] <- "numeric"
+ sumry[k,2] <- length(phylog$Avalues)
+ sumry[k,3] <- "Eigen values of QWQ/sum(Q)"
+ #11 "Wscores"
+ k = 4
+ sumry[k,1] <- "data.frame"
+ sumry[k,2] <- paste(nrow(phylog$Wscores),ncol(phylog$Wscores),sep="-")
+ sumry[k,3] <- "Eigen vectors of QWQ '1/n' normed"
+ #12 "Amat"
+ k = 5
+ sumry[k,1] <- "matrix"
+ sumry[k,2] <- paste(nrow(phylog$Amat),ncol(phylog$Amat),sep="-")
+ sumry[k,3] <- "Topological proximity matrix A"
+ #13 Avalues
+ k = 6
+ sumry[k,1] <- "numeric"
+ sumry[k,2] <- length(phylog$Avalues)
+ sumry[k,3] <- "Eigen values of QAQ matrix"
+ #14 Adim
+ k = 7
+ sumry[k,1] <- "integer"
+ sumry[k,2] <- "1"
+ sumry[k,3] <- "number of positive eigen values of QAQ"
+ #15 Ascores
+ k = 8
+ sumry[k,1] <- "data.frame"
+ sumry[k,2] <- paste(nrow(phylog$Ascores),ncol(phylog$Ascores),sep="-")
+ sumry[k,3] <- "Eigen vectors of QAQ '1/n' normed"
+ #16 Aparam
+ k = 9
+ sumry[k,1] <- "data.frame"
+ sumry[k,2] <- paste(nrow(phylog$Aparam),ncol(phylog$Aparam),sep="-")
+ sumry[k,3] <- "Topological indices for nodes"
+ # 17 Bindica
+ k = 10
+ sumry[k,1] <- "data.frame"
+ sumry[k,2] <- paste(nrow(phylog$Bindica),ncol(phylog$Bindica),sep="-")
+ sumry[k,3] <- "class indicator from nodes"
+ # 18 Bscores
+ k = 11
+ sumry[k,1] <- "data.frame"
+ sumry[k,2] <- paste(nrow(phylog$Bscores),ncol(phylog$Bscores),sep="-")
+ sumry[k,3] <- "Topological orthonormal basis '1/n' normed"
+ # 19 Bvalues
+ # 20 Blabels
+ k=12
+ sumry[k,1] <- "character"
+ sumry[k,2] <- length(phylog$Blabels)
+ sumry[k,3] <- "Nodes labelling from orthonormal basis"
+ print.noquote(sumry)
+ return(invisible())
+}
+
+#######################################################################################
+"phylog.extract" <- function (phylog, node, distance = TRUE){
+ local <- lapply(phylog$paths, function(x) sum(x == node))
+ tu.names <- names(which(local == 1))
+ tre <- phylog$tre
+ local1 <- paste(tu.names, ")", sep = "")
+ local2 <- paste(tu.names, ",", sep = "")
+ local3 <- paste(tu.names, ";", sep = "")
+ tu.pos1 <- unlist(lapply(local1, function(x) regexpr(x, tre)))
+ tu.pos2 <- unlist(lapply(local2, function(x) regexpr(x, tre)))
+ tu.pos3 <- unlist(lapply(local3, function(x) regexpr(x, tre)))
+ tu.pos <- cbind(tu.pos1, tu.pos2, tu.pos3)
+ tu.pos <- apply(tu.pos, 1, function(x) x[which(x != -1)])
+ leave.pos <- min(tu.pos)
+ node.pos <- tu.pos[which(tu.names == node)]
+ res <- substr(tre, leave.pos, node.pos - 1)
+ res <- paste(res, node, sep = "")
+ res <- paste(res, ";", sep = "")
+ n.fermante <- length(unlist(gregexpr(")", res)))
+ n.ouvrante <- length(unlist(gregexpr("(", res, fixed = TRUE)))
+ parentheses <- rep("(", n.fermante - n.ouvrante)
+ parentheses <- paste(parentheses, collapse = "")
+ res <- paste(parentheses, res, sep = "")
+
+ if (distance){
+ nodes.names <- names(phylog$nodes)
+ leaves.names <- names(phylog$leaves)
+
+ "tre2tre" <- function(res){
+ for (i in 1:length(leaves.names)) {
+ res <- sub(paste(leaves.names[i], ",", sep = ""),
+ paste(leaves.names[i], ":", phylog$leaves[i],
+ ",", sep = ""), res)
+ }
+ for (i in 1:length(leaves.names)) {
+ res <- sub(paste(leaves.names[i], ")", sep = ""),
+ paste(leaves.names[i], ":", phylog$leaves[i],
+ ")", sep = ""), res)
+ }
+ for (i in 1:length(nodes.names)) {
+ res <- sub(paste(nodes.names[i], ",", sep = ""),
+ paste(nodes.names[i], ":", phylog$nodes[i], ",",
+ sep = ""), res)
+ }
+ for (i in 1:length(nodes.names)) {
+ res <- sub(paste(nodes.names[i], ")", sep = ""),
+ paste(nodes.names[i], ":", phylog$nodes[i], ")",
+ sep = ""), res)
+ }
+ return(res)
+ }
+
+ res <- tre2tre(res)
+ }
+
+ add.t <- !is.null(phylog$Wmat)
+ res <- newick2phylog(res, add.tools = add.t, call = match.call())
+
+return(res)
+}
+
+#######################################################################################
+phylog.permut <- function(phylog,list.nodes = NULL, distance = TRUE){
+ if (is.null(list.nodes)) list.nodes <- lapply(phylog$parts,function(a) if (length(a)==1) a else sample(a))
+ #############################
+ adddistances<-function(){
+ # cette fonction assure la conversion de tre
+ # en son équivalent muni des distances
+ for(i in 1:length(leaves.names)) {
+ tre<<- sub(paste(leaves.names[i],",",sep=""),paste(leaves.names[i],":",phylog$leaves[i],",",sep=""),tre,fixed=TRUE)
+ }
+ for(i in 1:length(leaves.names)) {
+ tre<<- sub(paste(leaves.names[i],")",sep=""),paste(leaves.names[i],":",phylog$leaves[i],")",sep=""),tre,fixed=TRUE)
+ }
+ for(i in 1:length(nodes.names)) {
+ tre<<- sub(paste(nodes.names[i],",",sep=""),paste(nodes.names[i],":",phylog$nodes[i],",",sep=""),tre,fixed=TRUE)
+ }
+ for(i in 1:length(nodes.names)) {
+ tre<<- sub(paste(nodes.names[i],")",sep=""),paste(nodes.names[i],":",phylog$nodes[i],")",sep=""),tre,fixed=TRUE)
+ }
+ }
+ #############################
+ extract<-function(node) {
+ # extrait de tre le sous-arbre enraciné au noeud node
+ # il serait intéressant de traduire cett fonction en C,
+ # en ne travaillant que sur les chaines de caractères newick
+ # node.number<- grep(node, nodes.names)
+ # on détermine la feuilles la plus à gauche associée au noeud
+ # utilise la liste phylogparts contenant les descendants
+ leave <- node
+ k <- 0
+ while(length(grep(leave,leaves.names))==0) {
+ k <- k+1
+ leave <- phylogparts[[leave]][1]
+ }
+ #on construit la chaine de caractère associée à l'arbre enraciné au noeud
+ if (regexpr(paste(leave,")",sep=""),tre) == -1) {
+ leave.pos <- regexpr(paste(leave,",",sep=""),tre)
+ } else {
+ leave.pos <- regexpr(paste(leave,")",sep=""),tre)
+ }
+ if (regexpr(paste(node,")",sep=""),tre) == -1) {
+ node.pos <- regexpr(paste(node,",",sep=""),tre)
+ } else {
+ node.pos <- regexpr(paste(node,")",sep=""),tre)
+ }
+ res<-substr(tre,leave.pos,node.pos-1)
+ res<-paste(res,node,sep="")
+ if (k==0) parentheses<-"" else parentheses<-"("
+ if(k > 1) {
+ for(i in 2:k){
+ parentheses<-paste(parentheses,"(", sep="")
+ }
+ }
+ res<-(paste(parentheses, res, sep=""))
+ return(res)
+ }
+ #############################
+ permute <- function (node) {
+ # cette fonction assure la permutation dans tre des branches descendantes du noeud node
+ # on remplace l'ordre initial conservé dans phylogparts[[node]]
+ # par l'ordre final conservé dans list.nodes[[node]]
+ # phylogparts[[node]] est mis à jour à la sortie
+ new.part <- list.nodes[[node]]
+ if (length(new.part)==1) return(invisible())
+ old.part <- phylogparts[[node]]
+ if (all (old.part==new.part)) return(invisible())
+ for (k in 1:(length(new.part)-1)) {
+ if (old.part[k]!=new.part[k]) {
+ n1 <- old.part[k]
+ n2 <- new.part[k]
+ u1 <- extract(n1)
+ u1.pos <- regexpr(paste(u1,"[,\\);]",sep=""),tre)
+ u1.fin <- u1.pos+attr(u1.pos,"match.length")-1
+ lastcar1 <- substring(tre, u1.fin, u1.fin)
+ u2 <- extract(n2)
+ u2.pos<-regexpr(paste(u2,"[,\\);]",sep=""),tre)
+ u2.fin <- u2.pos+attr(u2.pos,"match.length")-1
+ lastcar2 <- substring(tre, u2.fin, u2.fin)
+ tre <<- sub(paste(u1,lastcar1,sep=""),"Restunlogicielformidable",tre,fixed = TRUE)
+ tre <<- sub(paste(u2,lastcar2,sep=""), paste(u1,lastcar2,sep=""),tre,fixed=TRUE)
+ tre <<- sub("Restunlogicielformidable",paste(u2,lastcar1,sep=""), tre,fixed=TRUE)
+ old.part[old.part==n1] <- "1234564789"
+ old.part[old.part==n2] <- n1
+ old.part[old.part=="1234564789"] <- n2
+ }
+ }
+ phylogparts[[node]] <<- new.part
+ }
+ #############################
+ verif <- function(node) {
+ new.part <- sort(list.nodes[[node]])
+ old.part <- sort(phylogparts[[node]])
+ if (!(all(new.part==old.part))) return (FALSE)
+ return (TRUE)
+ }
+ if(!inherits(phylog,"phylog")) stop ("Object with class 'phylog' expected")
+ nodes.names<- names(phylog$nodes)
+ leaves.names<- names(phylog$leaves)
+ new.names <- names(list.nodes)
+ phylogparts <- phylog$parts
+ if (any(!new.names%in%nodes.names)) stop ("Non convient name in 'list.nodes'")
+ wverif <- unlist(lapply(new.names,verif))
+ if (any(!wverif)) stop ("Non convient content in 'list.nodes'")
+ tre <- phylog$tre
+ add.t <- !is.null(phylog$Wmat)
+ for (node in new.names) permute(node)
+ if (distance) adddistances ()
+ res <- newick2phylog(tre, add.tools= add.t, call = match.call())
+ return(res)
+}
diff --git a/R/plot.4thcorner.R b/R/plot.4thcorner.R
new file mode 100644
index 0000000..9ec1177
--- /dev/null
+++ b/R/plot.4thcorner.R
@@ -0,0 +1,235 @@
+plot.4thcorner <- function(x, stat = c("D", "D2", "G"), type = c("table", "biplot"), xax = 1, yax = 2, x.rlq = NULL, alpha = 0.05, col = c("lightgrey", "red", "deepskyblue", "purple"),...) {
+ ## function to display the results obtained with the fourthcorner, fourthcorner2 or fourthcorner.rlq functions
+ ## biplot available only for D and D2 stats
+
+ stat <- match.arg(stat)
+ type <- match.arg(type)
+ appel <- as.list(x$call)
+ fctn <- appel[[1]]
+
+ if(!inherits(x, "4thcorner") & !inherits(x, "4thcorner.rlq"))
+ stop("x must be of class '4thcorner' or '4thcorner.rlq'")
+ if(inherits(x, "4thcorner.rlq") & stat != "G")
+ stop("stat should be 'G' for object of class '4thcorner.rlq' (created by the 'fourthcorner2' function)")
+ if(type == "biplot" & stat == "G")
+ stop("'biplot not available for the 'G' statistic")
+
+ if((stat == "D2" | stat=="D")){
+ ## For D and D2 stats
+ res <- data.frame(matrix(1, length(x$colnames.Q),length(x$colnames.R)))
+ names(res) <- x$colnames.R
+ row.names(res) <- x$colnames.Q
+ if(stat == "D2") {
+ xrand <- x$tabD2
+ } else {
+ xrand <- x$tabD
+ }
+
+ for(i in 1:nrow(res)){
+ for(j in 1:ncol(res)){
+ ## in res, 1 corresponds to white, 2 to dark grey and 3 to light grey
+ idx.var <- ncol(res) * (i - 1) + j
+ if(!is.na(xrand$adj.pvalue[idx.var])){
+ if(xrand$adj.pvalue[idx.var] < alpha){
+ ## for significant associations
+ res[i,j] <- ifelse(xrand$alter[idx.var]=="greater", 2, 3)
+
+ if((x$indexR[x$assignR[j]]==1) != (x$indexQ[x$assignQ[i]]==1)){
+ if(stat == "D")
+ ## homogeneity has no sign and test only "positive" association
+ res[i,j] <- 2
+ if(stat == "D2")
+ ## sign of the correlation (two-sided test)
+ res[i,j] <- ifelse(xrand$obs[idx.var] > 0, 2, 3)
+ }
+ else if((x$indexR[x$assignR[j]]==1) & (x$indexQ[x$assignQ[i]]==1)){
+ ## sign of the correlation (two-sided test)
+ res[i,j] <- ifelse(xrand$obs[idx.var] > 0, 2, 3)
+ }
+ else if((x$indexR[x$assignR[j]]==2) & (x$indexQ[x$assignQ[i]]==2)){
+ ## sign relative to the mean of permuted values
+ res[i,j] <- ifelse(xrand$obs[idx.var] > xrand$expvar$Expectation[idx.var], 2, 3)
+ }
+ }
+ }
+ }
+ }
+ } else if(stat=="G"){
+ ## for G stats
+ res <- data.frame(matrix(1, length(x$varnames.Q),length(x$varnames.R)))
+ names(res) <- x$varnames.R
+ row.names(res) <- x$varnames.Q
+ xrand <- x$tabG
+ for(i in 1:nrow(res)){
+ for(j in 1:ncol(res)){
+ idx.var <- ncol(res) * (i - 1) + j
+ if(xrand$adj.pvalue[idx.var] < alpha){
+ res[i,j] <- ifelse(xrand$alter[idx.var]=="greater", 2, 3)
+ if((x$indexR[j]==1) & (x$indexQ[i]==1)){
+ ## sign of the correlation (two-sided test)
+ res[i,j] <- ifelse(xrand$obs[idx.var] > 0, 2, 3)
+ }
+ }
+ }
+ }
+ }
+
+
+
+ table4thcorner <- function (df, stat, assignR, assignQ, col)
+ {
+ ## plot results as a table with white, light grey and dark grey
+ x1 <- 1:ncol(df)
+ y <- nrow(df):1
+ opar <- par(mai = par("mai"), srt = par("srt"))
+ on.exit(par(opar))
+ table.prepare(x = x1, y = y, row.labels = row.names(df), col.labels = names(df),
+ clabel.row = 1, clabel.col = 1, grid = FALSE,
+ pos = "paint")
+ xtot <- x1[col(as.matrix(df))]
+ ytot <- y[row(as.matrix(df))]
+ xdelta <- (max(x1) - min(x1))/(length(x1) - 1)/2
+ ydelta <- (max(y) - min(y))/(length(y) - 1)/2
+
+ ##valgris <- c("white","grey20","grey80")
+
+ z <- unlist(df)
+ rect(xtot - xdelta, ytot - ydelta, xtot + xdelta, ytot +
+ ydelta, col = col[1:3][z], border = "grey90")
+
+ if((stat == "D") | (stat == "D2")){
+
+ idR <- which(diff(assignR)==1)
+ idQ <- which(diff(assignQ)==1)
+ if(length(idR) > 0)
+ segments(sort(unique(xtot))[idR]+xdelta, max(ytot+ydelta), sort(unique(xtot))[idR]+xdelta, min(ytot-ydelta), lwd=2)
+ if(length(idQ) > 0)
+ segments(max(xtot+xdelta), sort(unique(ytot), decreasing = TRUE)[idQ+1]+ydelta, min(xtot-xdelta), sort(unique(ytot), decreasing = TRUE)[idQ+1]+ydelta, lwd=2)
+ }
+ rect(min(xtot) - xdelta, min(ytot) - ydelta, max(xtot) + xdelta, max(ytot) + ydelta, col = NULL)
+
+ }
+
+
+ biplot.rlq4thcorner <- function (res.4thcorner, obj.rlq, stat, alpha, xax, yax, clab.traits, clab.env, col)
+ {
+ ## plot associations between variables on a biplot
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ coolig <- obj.rlq$li[, c(xax, yax)]
+ coocol <- obj.rlq$c1[, c(xax, yax)]
+
+ s.label(coolig, clabel = 0, cpoint = 0, xlim = 1.2 * range(coolig[,1]))
+
+ born <- par("usr")
+ k1 <- min(coocol[, 1])/born[1]
+ k2 <- max(coocol[, 1])/born[2]
+ k3 <- min(coocol[, 2])/born[3]
+ k4 <- max(coocol[, 2])/born[4]
+ k <- c(k1, k2, k3, k4)
+ coocol <- 0.9 * coocol/max(k)
+
+ idx.pos <- which(t(res.4thcorner)==2, arr.ind=TRUE) ## positive association
+ idx.neg <- which(t(res.4thcorner)==3, arr.ind=TRUE) ## negative association
+ idx.tot <- list(unique(c(idx.pos[,1],idx.neg[,1])), unique(c(idx.pos[,2],idx.neg[,2])))
+
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+
+ ## variables with no significant links
+ if(length(idx.tot[[1]]) > 0)
+ {
+
+ scatterutil.eti(coolig[-idx.tot[[1]],1], coolig[-idx.tot[[1]],2],label=row.names(coolig)[-idx.tot[[1]]], clabel = clab.env, boxes = FALSE, coul = rep(col[1], nrow(coolig) - length(idx.tot[[1]])))
+ scatterutil.eti(coocol[-idx.tot[[2]],1], coocol[-idx.tot[[2]],2],label=row.names(coocol)[-idx.tot[[2]]], clabel = clab.traits, boxes = FALSE, coul = rep(col[1], nrow(coocol) - length(idx.tot[[2]])))
+ } else {
+ scatterutil.eti(coolig[,1], coolig[,2],label=row.names(coolig), clabel = clab.env, boxes = FALSE, coul = rep(col[1], nrow(coolig)))
+ scatterutil.eti(coocol[,1], coocol[,2],label=row.names(coocol), clabel = clab.traits, boxes = FALSE, coul = rep(col[1], nrow(coocol)))
+ }
+
+ if(nrow(idx.pos) > 0)
+ segments(coolig[idx.pos[,1],1],coolig[idx.pos[,1],2],coocol[idx.pos[,2],1],coocol[idx.pos[,2],2], lty = 1, lwd = 2, col = col[2])
+
+ if(nrow(idx.neg) > 0)
+ segments(coolig[idx.neg[,1],1],coolig[idx.neg[,1],2],coocol[idx.neg[,2],1],coocol[idx.neg[,2],2], lty = 1, lwd = 2, col = col[3])
+
+ if(length(idx.tot[[1]]) > 0)
+ {
+ scatterutil.eti.circ(coolig[idx.tot[[1]],1], coolig[idx.tot[[1]],2], label=row.names(coolig)[idx.tot[[1]]], clabel = clab.env, boxes = FALSE)
+ ##s.label(coolig[idx.tot[[1]],], clabel = clab.env, add.plot = TRUE)
+ ##scatterutil.eti(coocol[idx.tot[[2]],1], coocol[idx.tot[[2]],2],label=row.names(coocol)[idx.tot[[2]]], clabel = clab.traits, boxes = TRUE,bg = 'grey')
+ scatterutil.eti.circ(coocol[idx.tot[[2]],1], coocol[idx.tot[[2]],2],label=row.names(coocol)[idx.tot[[2]]], clabel = clab.traits, boxes = FALSE)
+ points(coolig[idx.tot[[1]],], pch = 17)
+ points(coocol[idx.tot[[2]],], pch = 19)
+ }
+ }
+
+
+
+
+ biplot.axesrlq4thcorner <- function(res.4thcorner, coo, alpha, xax, yax, type.axes, col){
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+
+ s.label(coo, clabel = 0, cpoint = 0)
+
+ if(type.axes == "R.axes")
+ res.4thcorner <- res.4thcorner[c(xax,yax),]
+ if(type.axes == "Q.axes"){
+ res.4thcorner <- res.4thcorner[,c(xax,yax)]
+ res.4thcorner <- t(res.4thcorner)
+ }
+
+ ##idx.pos.xax <- which(res.4thcorner[1,] == 2) ## positive association with xax
+ ##idx.pos.yax <- which(res.4thcorner[2,] == 2) ## positive association with yax
+
+ ##idx.neg.xax <- which(res.4thcorner[1,] == 3) ## negative association with xax
+ ##idx.neg.yax <- which(res.4thcorner[2,] == 3) ## negative association with yax
+
+ ##idx.tot <- unique(c(idx.pos.xax, idx.pos.yax, idx.neg.xax, idx.neg.yax))
+ idx.xax <- which((res.4thcorner[1,] > 1) & (res.4thcorner[2,] == 1))
+ idx.yax <- which((res.4thcorner[1,] == 1) & (res.4thcorner[2,] > 1))
+ idx.both <- which((res.4thcorner[1,] > 1) & (res.4thcorner[2,] > 1))
+ idx.tot <- c(idx.xax, idx.yax, idx.both)
+
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+
+ if(length(idx.tot) > 0)
+ {
+ scatterutil.eti(coo[-idx.tot,1], coo[-idx.tot,2],label=row.names(coo)[-idx.tot], clabel = 1, boxes = FALSE, coul = rep(col[1], nrow(coo) - length(idx.tot)))
+ } else {
+ scatterutil.eti(coo[,1], coo[,2],label=row.names(coo), clabel = 1, boxes = FALSE, coul = rep(col[1], nrow(coo)))
+ }
+
+ if(length(idx.xax) > 0)
+ scatterutil.eti(coo[idx.xax,1], coo[idx.xax,2],label=row.names(coo)[idx.xax], clabel = 1, boxes = TRUE, coul = rep(col[2], length(idx.xax)))
+
+ if(length(idx.yax) > 0)
+ scatterutil.eti(coo[idx.yax,1], coo[idx.yax,2],label=row.names(coo)[idx.yax], clabel = 1, boxes = TRUE, coul = rep(col[3], length(idx.xax)))
+
+ if(length(idx.both) > 0)
+ scatterutil.eti(coo[idx.both,1], coo[idx.both,2],label=row.names(coo)[idx.both], clabel = 1, boxes = TRUE, coul = rep(col[4], length(idx.both)))
+
+
+ }
+
+ if(type=="table"){
+ table4thcorner(res, stat = stat, assignR = x$assignR, assignQ = x$assignQ, col = col)
+ } else if(type=="biplot"){
+ if(fctn =="fourthcorner" | fctn =="fourthcorner2"){
+ if (!inherits(x.rlq, "rlq"))
+ stop("'x.rlq' should be of class 'rlq'")
+ biplot.rlq4thcorner(res.4thcorner = res, obj.rlq = x.rlq, stat = stat, alpha = alpha, xax = xax, yax = yax, clab.traits = 1, clab.env = 1, col = col)
+ } else if(fctn=="fourthcorner.rlq"){
+ obj.rlq <- eval(appel$xtest, sys.frame(0))
+ type.axes <- eval(appel$typetest, sys.frame(0))
+
+ if(type.axes == "axes")
+ stop("The option 'axes' is only implemented for pedagogic purposes and is not relevant to analyse data")
+ if(type.axes == "R.axes")
+ coo <- obj.rlq$li[, c(xax, yax)]
+ if(type.axes == "Q.axes")
+ coo <- obj.rlq$co[, c(xax, yax)]
+ biplot.axesrlq4thcorner(res.4thcorner = res, coo = coo, alpha = alpha, xax = xax, yax = yax, type.axes = type.axes, col = col)
+ }
+ }
+}
diff --git a/R/plot.phylog.R b/R/plot.phylog.R
new file mode 100644
index 0000000..59cdb78
--- /dev/null
+++ b/R/plot.phylog.R
@@ -0,0 +1,263 @@
+"plot.phylog" <- function (x, y = NULL,
+ f.phylog = 0.5, cleaves = 1, cnodes = 0,
+ labels.leaves = names(x$leaves), clabel.leaves = 1,
+ labels.nodes = names(x$nodes), clabel.nodes = 0,
+ sub = "", csub = 1.25, possub = "bottomleft", draw.box = FALSE, ...)
+ {
+ if (!inherits(x, "phylog"))
+ stop("Non convenient data")
+ leaves.number <- length(x$leaves)
+ leaves.names <- names(x$leaves)
+ nodes.number <- length(x$nodes)
+ nodes.names <- names(x$nodes)
+ if (length(labels.leaves) != leaves.number) labels.leaves <- names(x$leaves)
+ if (length(labels.nodes) != nodes.number) labels.nodes <- names(x$nodes)
+ leaves.car <- gsub("[_]"," ",labels.leaves)
+ nodes.car <- gsub("[_]"," ",labels.nodes)
+ mar.old <- par("mar")
+ on.exit(par(mar=mar.old))
+
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+
+ if (f.phylog < 0.05) f.phylog <- 0.05
+ if (f.phylog > 0.95) f.phylog <- 0.95
+
+ maxx <- max(x$droot)
+ plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n",
+ yaxt = "n", xlim = c(-maxx*0.15, maxx/f.phylog), ylim = c(-0.05, 1), xaxs = "i",
+ yaxs = "i", frame.plot = FALSE)
+
+ x.leaves <- x$droot[leaves.names]
+ x.nodes <- x$droot[nodes.names]
+ if (is.null(y)) y <- (leaves.number:1)/(leaves.number + 1)
+ else y <- (leaves.number+1-y)/(leaves.number+1)
+ names(y) <- leaves.names
+ xcar <- maxx*1.05
+ xx <- c(x.leaves, x.nodes)
+
+ if (clabel.leaves > 0) {
+ for (i in 1:leaves.number) {
+ text(xcar, y[i], leaves.car[i], adj = 0, cex = par("cex") *
+ clabel.leaves)
+ segments(xcar, y[i], xx[i], y[i], col = grey(0.7))
+ }
+ }
+ yleaves <- y[1:leaves.number]
+ xleaves <- xx[1:leaves.number]
+ if (cleaves > 0) {
+ for (i in 1:leaves.number) {
+ points(xx[i], y[i], pch = 21, bg=1, cex = par("cex") * cleaves)
+ }
+ }
+ yn <- rep(0, nodes.number)
+ names(yn) <- nodes.names
+ y <- c(y, yn)
+ for (i in 1:length(x$parts)) {
+ w <- x$parts[[i]]
+ but <- names(x$parts)[i]
+ y[but] <- mean(y[w])
+ b <- range(y[w])
+ segments(xx[but], b[1], xx[but], b[2])
+ x1 <- xx[w]
+ y1 <- y[w]
+ x2 <- rep(xx[but], length(w))
+ segments(x1, y1, x2, y1)
+ }
+ if (cnodes > 0) {
+ for (i in nodes.names) {
+ points(xx[i], y[i], pch = 21, bg="white", cex = cnodes)
+ }
+ }
+ if (clabel.nodes > 0) {
+ scatterutil.eti(xx[names(x.nodes)], y[names(x.nodes)], nodes.car,
+ clabel.nodes)
+ }
+ x <- (x.leaves - par("usr")[1])/(par("usr")[2]-par("usr")[1])
+ y <- y[leaves.names]
+ xbase <- (xcar - par("usr")[1])/(par("usr")[2]-par("usr")[1])
+ if (csub>0) scatterutil.sub(sub, csub=csub, possub=possub)
+ if (draw.box) box()
+ if (cleaves > 0) points(xleaves, yleaves, pch = 21, bg=1, cex = par("cex") * cleaves)
+
+ return(invisible(list(xy=data.frame(x=x, y=y), xbase= xbase, cleaves=cleaves)))
+}
+
+
+
+"radial.phylog" <- function (phylog, circle = 1,
+ cleaves = 1, cnodes = 0,
+ labels.leaves = names(phylog$leaves), clabel.leaves = 1,
+ labels.nodes = names(phylog$nodes), clabel.nodes = 0,
+ draw.box = FALSE)
+{
+ if (!inherits(phylog, "phylog"))
+ stop("Non convenient data")
+ leaves.number <- length(phylog$leaves)
+ leaves.names <- names(phylog$leaves)
+ nodes.number <- length(phylog$nodes)
+ nodes.names <- names(phylog$nodes)
+ if (length(labels.leaves) != leaves.number) labels.leaves <- names(phylog$leaves)
+ if (length(labels.nodes) != nodes.number) labels.nodes <- names(phylog$nodes)
+ if (circle<0) stop("'circle': non convenient value")
+ leaves.car <- gsub("[_]"," ",labels.leaves)
+ nodes.car <- gsub("[_]"," ",labels.nodes)
+
+ opar <- par(mar = par("mar"), srt = par("srt"))
+ on.exit(par(opar))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+
+ dis <- phylog$droot
+ dis <- dis/max(dis)
+ rayon <- circle
+ dis <- dis * rayon
+ dist.leaves <- dis[leaves.names]
+ dist.nodes <- dis[nodes.names]
+ plot.default(0, 0, type = "n", asp = 1, xlab = "", ylab = "",
+ xaxt = "n", yaxt = "n", xlim = c(-2, 2), ylim = c(-2,
+ 2), xaxs = "i", yaxs = "i", frame.plot = FALSE)
+ d.rayon <- rayon/(nodes.number - 1)
+ alpha <- 2 * pi * (1:leaves.number)/leaves.number
+ names(alpha) <- leaves.names
+ x <- dist.leaves * cos(alpha)
+ y <- dist.leaves * sin(alpha)
+ xcar <- (rayon + d.rayon) * cos(alpha)
+ ycar <- (rayon + d.rayon) * sin(alpha)
+ if (clabel.leaves>0) {
+ for (i in 1:leaves.number) {
+ segments(xcar[i], ycar[i], x[i], y[i], col = grey(0.7))
+ }
+ for (i in 1:leaves.number) {
+ par(srt = alpha[i] * 360/2/pi)
+ text(xcar[i], ycar[i], leaves.car[i], adj = 0, cex = par("cex") *
+ clabel.leaves)
+ segments(xcar[i], ycar[i], x[i], y[i], col = grey(0.7))
+ }
+ }
+ if (cleaves > 0) {
+ for (i in 1:leaves.number) points(x[i], y[i], pch = 21, bg="black", cex = par("cex") *
+ cleaves)
+ }
+ ang <- rep(0, length(dist.nodes))
+ names(ang) <- names(dist.nodes)
+ ang <- c(alpha, ang)
+ for (i in 1:length(phylog$parts)) {
+ w <- phylog$parts[[i]]
+ but <- names(phylog$parts)[i]
+ ang[but] <- mean(ang[w])
+ b <- range(ang[w])
+ a.seq <- c(seq(b[1], b[2], by = pi/180), b[2])
+ lines(dis[but] * cos(a.seq), dis[but] * sin(a.seq))
+ x1 <- dis[w] * cos(ang[w])
+ y1 <- dis[w] * sin(ang[w])
+ x2 <- dis[but] * cos(ang[w])
+ y2 <- dis[but] * sin(ang[w])
+ segments(x1, y1, x2, y2)
+ }
+ if (cnodes > 0) {
+ for (i in 1:length(phylog$parts)) {
+ w <- phylog$parts[[i]]
+ but <- names(phylog$parts)[i]
+ ang[but] <- mean(ang[w])
+ points(dis[but] * cos(ang[but]), dis[but] * sin(ang[but]),
+ pch = 21, bg="white", cex = par("cex") * cnodes)
+ }
+ }
+ points(0, 0, pch = 21, cex = par("cex") * 2, bg = "red")
+ if (clabel.nodes > 0) {
+ delta <- strwidth(as.character(length(dist.nodes)), cex = par("cex") *
+ clabel.nodes)
+ for (j in 1:length(dist.nodes)) {
+ i <- names(dist.nodes)[j]
+ par(srt = (ang[i] * 360/2/pi + 90))
+ x1 <- dis[i] * cos(ang[i])
+ y1 <- dis[i] * sin(ang[i])
+ symbols(x1, y1, delta, bg = "white", add = TRUE, inches = FALSE)
+ text(x1, y1, nodes.car[j], adj = 0.5, cex = par("cex") *
+ clabel.nodes)
+ }
+ }
+ if (draw.box) box()
+ return(invisible())
+}
+
+#######################################################################################
+enum.phylog<-function (phylog, no.over=1000) {
+
+ # Pour chaque phylogénie phylog, il existe un grand nombre de représentations
+ # toutes équivalentes ssociées à la même topologie
+ # Il y en a exactement 2^k pour une phylogénie résolue
+ # (que des dichotomies), ou k représente le nombre de noeuds
+ # Cette fonction énumère tous les possibles
+ if (!inherits(phylog, "phylog")) stop("Object 'phylog' expected")
+ leaves.number<- length(phylog$leaves)
+ leaves.names<- names(phylog$leaves)
+ # les descendants sont pris par la racine
+ parts <- rev(phylog$parts)
+ nodes.number<- length(parts)
+ nodes.names<- (names(parts))
+ nodes.dim <- unlist(lapply(parts,length))
+ perms.number <- prod(gamma(nodes.dim+1))
+ if (perms.number>no.over) {
+ cat("Permutation number =",perms.number,"( no.over =", no.over,")\n")
+ return(invisible())
+ }
+
+ "perm" <- function(cha=as.character(1:n),a=matrix(1,1,1)) {
+ n0 <- ncol(a)
+ n <- length(cha)
+ if (n0 == n) {
+ a <- apply(a,c(1,2),function(x) cha[x])
+ return(a)
+ }
+ fun1 <- function(x) {
+ xplus <- length(x)+1
+ fun2 <- function (j) {
+ if (j==1) w <- c(xplus,x)
+ else if (j==xplus) w <- c(x,xplus)
+ else w <- c(x[1:j-1],xplus,x[j:length(x)])
+ return(w)
+ }
+ return(sapply(1:(length(x)+1) , fun2))
+ }
+ a <- matrix(unlist(apply(a,1,fun1)),ncol=n0+1,byrow=TRUE)
+ Recall(cha,a)
+ }
+
+ res <- matrix (1,1,1)
+
+ lw <- lapply(parts,perm)
+ names(lw) <- nodes.names
+ res <- lw[[1]]
+
+ lw[[1]]<- NULL
+
+ "permtot" <- function (matcar) {
+ n1 <- nrow(res) ; n2 <- nrow(matcar)
+ p1 <- ncol(res) ; p2 <- ncol(matcar)
+ f1 <- function(x) unlist(apply(res,1,function(y) c(y,x)))
+ res <<- matrix(unlist(apply(matcar,1,f1)),n1*n2, p1+p2,byrow=TRUE)
+ }
+
+ lapply(lw, permtot)
+
+ ##############################################
+ fac <- factor(rep(1:nodes.number,nodes.dim))
+ renum <- function (cha) {
+ cha <- split(cha, fac)
+ names(cha) <- nodes.names
+ w <- cha[[1]]
+ for (j in nodes.names[-1]) {
+ k <- which(w==j)
+ wcha <- cha[[j]]
+ if (k==1) w <- c(wcha,w[-k])
+ else if (k == length(w)) w <- c(w[-k],wcha)
+ else w <- c(w[1:(k-1)],wcha,w[(k+1):length(w)])
+ }
+ res <- 1:leaves.number
+ names(res) <- w
+ return(res[leaves.names])
+ }
+ return(t(apply(res,1,renum)))
+
+
+}
diff --git a/R/print.4thcorner.R b/R/print.4thcorner.R
new file mode 100644
index 0000000..0b88561
--- /dev/null
+++ b/R/print.4thcorner.R
@@ -0,0 +1,46 @@
+"print.4thcorner" <-
+ function(x,varQ = 1:length(x$varnames.Q), varR = 1:length(x$varnames.R), stat = c("D","D2"), ...){
+
+ stat <- match.arg(stat)
+ if(!inherits(x, "4thcorner.rlq")){
+ if(stat=="D"){
+ xrand <- x$tabD
+ } else {
+ xrand <- x$tabD2
+ }
+ idx.colR <- which(x$assignR %in% varR)
+ idx.colQ <- which(x$assignQ %in% varQ)
+ idx.vars <- sort(as.vector(outer(X = idx.colQ, Y = idx.colR, function(X,Y) length(x$assignR) * (X - 1) + Y)))
+ } else {
+ xrand <- x$tabG
+ idx.vars <- 1:length(xrand$names)
+ }
+
+ cat("Fourth-corner Statistics\n")
+ cat("------------------------\n")
+ cat("Permutation method ",x$model," (",x$npermut," permutations)\n")
+ cat("\nAdjustment method for multiple comparisons: ", xrand$adj.method, "\n")
+ cat("call: ",deparse(x$call),"\n\n")
+ cat("---\n\n")
+
+ ## idx.vars <- length(x$assignR) * (idx.colQ - 1) + idx.colR
+
+ sumry <- list(Test = xrand$names, Stat= xrand$statnames, Obs = xrand$obs, Std.Obs = xrand$expvar[, 1], Alter = xrand$alter)
+ sumry <- as.matrix(as.data.frame(sumry))
+ if (any(xrand$rep[1] != xrand$rep)) {
+ sumry <- cbind(sumry[, 1:4], N.perm = xrand$rep)
+ }
+
+ sumry <- cbind(sumry, Pvalue = xrand$pvalue)
+ if (xrand$adj.method != "none")
+ sumry <- cbind(sumry, Pvalue.adj = xrand$adj.pvalue)
+ signifpval <- symnum(xrand$adj.pvalue, corr = FALSE, na = FALSE, cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), symbols = c("***", "**", "*", ".", " "))
+ sumry <- cbind(sumry,signifpval)
+ colnames(sumry)[ncol(sumry)] <- " "
+ sumry <- sumry[idx.vars, , drop = FALSE]
+ rownames(sumry) <- 1:nrow(sumry)
+
+ print(sumry, quote = FALSE, right = TRUE)
+ cat("\n---\nSignif. codes: ", attr(signifpval, "legend"), "\n")
+ invisible(sumry)
+ }
diff --git a/R/procuste.R b/R/procuste.R
new file mode 100644
index 0000000..29a53d8
--- /dev/null
+++ b/R/procuste.R
@@ -0,0 +1,149 @@
+"procuste" <- function (dfX, dfY, scale = TRUE, nf = 4, tol = 1e-07) {
+ dfX <- data.frame(dfX)
+ dfY <- data.frame(dfY)
+ if (!is.data.frame(dfX))
+ stop("data.frame expected")
+ if (!is.data.frame(dfY))
+ stop("data.frame expected")
+ if (nrow(dfY) != nrow(dfX))
+ stop("Row numbers are different")
+ if (any(row.names(dfY) != row.names(dfX)))
+ stop("row names are different")
+
+ X <- scale(dfX, scale = FALSE)
+ Y <- scale(dfY, scale = FALSE)
+
+ if (scale) {
+ X <- X/sqrt(sum(apply(X, 2, function(x) sum(x^2))))
+ Y <- Y/sqrt(sum(apply(Y, 2, function(x) sum(x^2))))
+ }
+
+ X <-as.matrix(X)
+ Y <- as.matrix(Y)
+ PS <- t(X) %*% Y
+ svd1 <- svd(PS)
+ rank <- sum((svd1$d/svd1$d[1]) > tol)
+ if (nf > rank)
+ nf <- rank
+ u <- svd1$u[, 1:nf]
+ v <- svd1$v[, 1:nf]
+ scorX <- X %*% u
+ scorY <- Y %*% v
+ rotX <- X %*% u %*% t(v)
+ rotY <- Y %*% v %*% t(u)
+ res <- list()
+ X <- data.frame(X)
+ row.names(X) <- row.names(dfX)
+ names(X) <- names(dfX)
+ Y <- data.frame(Y)
+ row.names(Y) <- row.names(dfY)
+ names(Y) <- names(dfY)
+ res$d <- svd1$d
+ res$rank <- rank
+ res$nf <- nf
+ u <- data.frame(u)
+ row.names(u) <- names(dfX)
+ names(u) <- paste("ax", 1:nf, sep = "")
+ v <- data.frame(v)
+ row.names(v) <- names(dfY)
+ names(v) <- paste("ax", 1:nf, sep = "")
+ scorX <- data.frame(scorX)
+ row.names(scorX) <- row.names(dfX)
+ names(scorX) <- paste("ax", 1:nf, sep = "")
+ scorY <- data.frame(scorY)
+ row.names(scorY) <- row.names(dfX)
+ names(scorY) <- paste("ax", 1:nf, sep = "")
+ if ((nf == ncol(dfX)) & (nf == ncol(dfY))) {
+ rotX <- data.frame(rotX)
+ row.names(rotX) <- row.names(dfX)
+ names(rotX) <- names(dfY)
+ rotY <- data.frame(rotY)
+ row.names(rotY) <- row.names(dfX)
+ names(rotY) <- names(dfX)
+ res$rotX <- rotX
+ res$rotY <- rotY
+ }
+ res$tabX <- X
+ res$tabY <- Y
+ res$loadX <- u
+ res$loadY <- v
+ res$scorX <- scorX
+ res$scorY <- scorY
+ res$call <- match.call()
+ class(res) <- "procuste"
+ return(res)
+}
+
+"plot.procuste" <- function (x, xax = 1, yax = 2, ...) {
+ if (!inherits(x, "procuste"))
+ stop("Use only with 'procuste' objects")
+ if (x$nf == 1) {
+ warnings("One axis only : not yet implemented")
+ return(invisible())
+ }
+ if (xax > x$nf)
+ stop("Non convenient xax")
+ if (yax > x$nf)
+ stop("Non convenient yax")
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3),
+ respect = TRUE)
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ s.arrow(x$loadX, xax, yax, sub = "X loadings", csub = 2,
+ clabel = 1.25)
+ s.arrow(x$loadY, xax, yax, sub = "Y loadings", csub = 2,
+ clabel = 1.25)
+ scatterutil.eigen(x$d^2, wsel = c(xax, yax))
+ s.match(x$scorX, x$scorY, xax, yax, clabel = 1.5, sub = "Row scores (X -> Y)",
+ csub = 2)
+ s.label(x$scorX, xax = xax, yax = yax, sub = "X row scores",
+ csub = 2, clabel = 1.25)
+ s.label(x$scorY, xax = xax, yax = yax, sub = "Y row scores",
+ csub = 2, clabel = 1.25)
+}
+
+"print.procuste" <- function (x, ...) {
+ cat("Procustes rotation\n")
+ cat("call: ")
+ print(x$call)
+ cat(paste("class:", class(x)))
+ cat(paste("\nrank:", x$rank))
+ cat(paste("\naxis number:", x$nf))
+ cat("\nSingular value decomposition: ")
+ l0 <- length(x$d)
+ cat(signif(x$d, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n")
+ else cat("\n")
+ cat("tabX data.frame ", nrow(x$tabX), " ", ncol(x$tabX),
+ " scaled table X\n")
+ cat("tabY data.frame ", nrow(x$tabY), " ", ncol(x$tabY),
+ " scaled table Y\n")
+ cat("scorX data.frame ", nrow(x$scorX), " ", ncol(x$scorX),
+ " X row scores\n")
+ cat("scorY data.frame ", nrow(x$scorY), " ", ncol(x$scorY),
+ " Y row scores\n")
+ cat("loadX data.frame ", nrow(x$loadX), " ", ncol(x$loadX),
+ " X loadings\n")
+ cat("loadY data.frame ", nrow(x$loadY), " ", ncol(x$loadY),
+ " Y loadings\n")
+ if (length(names(x)) > 12) {
+ cat("other elements: ")
+ cat(names(x)[11:(length(x))], "\n")
+ }
+}
+
+
+"randtest.procuste" <- function(xtest, nrepet = 999, ...) {
+ if(!inherits(xtest,"procuste"))
+ stop("Object of class 'procuste' expected")
+
+
+ lig <- nrow(xtest$tabX)
+ c1 <- ncol(xtest$tabX)
+ c2 <- ncol(xtest$tabY)
+ isim <- testprocuste(nrepet, lig, c1, c2, as.matrix(xtest$tabX), as.matrix(xtest$tabY))
+ obs <- isim[1]
+ return(as.randtest(isim[-1], obs, call = match.call(), ...))
+}
diff --git a/R/procuste.randtest.R b/R/procuste.randtest.R
new file mode 100644
index 0000000..9f4403b
--- /dev/null
+++ b/R/procuste.randtest.R
@@ -0,0 +1,25 @@
+"procuste.randtest" <- function(df1, df2, nrepet = 999, ...) {
+ if (!is.data.frame(df1))
+ stop("data.frame expected")
+ if (!is.data.frame(df2))
+ stop("data.frame expected")
+ l1 <- nrow(df1)
+ if (nrow(df2) != l1)
+ stop("Row numbers are different")
+ if (any(row.names(df2) != row.names(df1)))
+ stop("row names are different")
+ X <- scale(df1, scale = FALSE)
+ Y <- scale(df2, scale = FALSE)
+ var1 <- apply(X, 2, function(x) sum(x^2))
+ var2 <- apply(Y, 2, function(x) sum(x^2))
+ tra1 <- sum(var1)
+ tra2 <- sum(var2)
+ X <- X/sqrt(tra1)
+ Y <- Y/sqrt(tra2)
+ lig<-nrow(X)
+ c1<-ncol(X)
+ c2<-ncol(Y)
+ isim<-testprocuste(nrepet, lig, c1, c2, as.matrix(X), as.matrix(Y))
+ obs<-isim[1]
+ return(as.randtest(sim = isim[-1], obs = obs, call = match.call(), ...))
+}
diff --git a/R/procuste.rtest.R b/R/procuste.rtest.R
new file mode 100644
index 0000000..719afff
--- /dev/null
+++ b/R/procuste.rtest.R
@@ -0,0 +1,29 @@
+"procuste.rtest" <- function (df1, df2, nrepet = 99, ...) {
+ if (!is.data.frame(df1))
+ stop("data.frame expected")
+ if (!is.data.frame(df2))
+ stop("data.frame expected")
+ l1 <- nrow(df1)
+ if (nrow(df2) != l1)
+ stop("Row numbers are different")
+ if (any(row.names(df2) != row.names(df1)))
+ stop("row names are different")
+ X <- scale(df1, scale = FALSE)
+ Y <- scale(df2, scale = FALSE)
+ var1 <- apply(X, 2, function(x) sum(x^2))
+ var2 <- apply(Y, 2, function(x) sum(x^2))
+ tra1 <- sum(var1)
+ tra2 <- sum(var2)
+ X <- X/sqrt(tra1)
+ Y <- Y/sqrt(tra2)
+ X <- as.matrix(X)
+ Y <- as.matrix(Y)
+ obs <- sum(svd(t(X) %*% Y)$d)
+ if (nrepet == 0)
+ return(obs)
+ perm <- matrix(0, nrow = nrepet, ncol = 1)
+ perm <- apply(perm, 1, function(x) sum(svd(t(X) %*% Y[sample(l1),
+ ])$d))
+ w <- as.randtest(obs = obs, sim = perm, call = match.call(), ...)
+ return(w)
+}
diff --git a/R/pta.R b/R/pta.R
new file mode 100644
index 0000000..7ec1f7f
--- /dev/null
+++ b/R/pta.R
@@ -0,0 +1,298 @@
+"pta" <- function (X, scannf = TRUE, nf = 2) {
+ # 21/08/02 Correction d'un bug suite à message de G. BALENT balent at toulouse.inra.fr
+ if (!inherits(X, "ktab"))
+ stop("object 'ktab' expected")
+ auxinames <- ktab.util.names(X)
+ sepa <- sepan(X, nf = 4)
+ blocks <- X$blo
+ nblo <- length(blocks)
+ tnames <- tab.names(X)
+ lw <- X$lw
+ lwsqrt <- sqrt(X$lw)
+ nl <- length(lw)
+ r.n <- row.names(X[[1]])
+ for (i in 1:nblo) {
+ r.new <- row.names(X[[i]])
+ if (any(r.new != r.n))
+ stop("non equal row.names among array")
+ }
+ if (length(unique(blocks)) != 1)
+ stop("non equal col numbers among array")
+ unique.col.names <- names(X[[1]])
+ for (i in 1:nblo) {
+ c.new <- names(X[[i]])
+ if (any(c.new != unique.col.names))
+ stop("non equal col.names among array")
+ }
+ indica <- as.factor(rep(1:nblo, blocks))
+ w <- split(X$cw, indica)
+ cw <- w[[1]]
+ for (i in 1:nblo) {
+ col.w.new <- w[[i]]
+ if (any(cw != col.w.new))
+ stop("non equal column weights among array")
+ }
+ cwsqrt <- sqrt(cw)
+ nc <- length(cw)
+ atp <- list()
+ for (i in 1:nblo) {
+ w <- as.matrix(X[[i]]) * lwsqrt
+ w <- t(t(w) * cwsqrt)
+ atp[[i]] <- w
+ }
+ atp <- matrix(unlist(atp), nl * nc, nblo)
+ RV <- t(atp) %*% atp
+ ak <- sqrt(diag(RV))
+ RV <- sweep(RV, 1, ak, "/")
+ RV <- sweep(RV, 2, ak, "/")
+ dimnames(RV) <- list(tnames, tnames)
+ atp <- list()
+ inter <- eigen(as.matrix(RV))
+ if (any(inter$vectors[, 1] < 0))
+ inter$vectors[, 1] <- -inter$vectors[, 1]
+ is <- inter$vectors[, (1:min(c(nblo, 4)))]
+ tabw <- as.vector(is[, 1])
+ is <- t(t(is) * sqrt(inter$values[1:ncol(is)]))
+ is <- as.data.frame(is)
+ row.names(is) <- tnames
+ names(is) <- paste("IS", 1:ncol(is), sep = "")
+ atp$RV <- RV
+ atp$RV.eig <- inter$values
+ atp$RV.coo <- is
+ atp$tabw <- tabw
+ tab <- X[[1]] * tabw[1]
+ for (i in 2:nblo) {
+ tab <- tab + X[[i]] * tabw[i]
+ }
+ tab <- as.data.frame(tab, row.names = row.names(X))
+ names(tab) <- unique.col.names
+ comp <- as.dudi(tab, col.w = cw, row.w = lw, nf = nf, scannf = scannf,
+ call = match.call(), type = "pta")
+ atp$rank <- comp$rank
+ nf <- atp$nf <- comp$nf
+ atp$tab <- comp$tab
+ atp$lw <- comp$lw
+ atp$cw <- comp$cw
+ atp$eig <- comp$eig
+ atp$li <- comp$li
+ atp$co <- comp$co
+ atp$l1 <- comp$l1
+ atp$c1 <- comp$c1
+ w1 <- matrix(0, nblo * 4, nf)
+ w2 <- matrix(0, nblo * 4, nf)
+ i1 <- 0
+ i2 <- 0
+ for (k in 1:nblo) {
+ i1 <- i2 + 1
+ i2 <- i2 + 4
+ tab1 <- as.matrix(sepa$L1[X$TL[, 1] == levels(X$TL[,1])[k], ])
+ tab1 <- t(tab1 * lw) %*% as.matrix(comp$l1)
+ tab2 <- as.matrix(sepa$C1[X$TC[, 1] == levels(X$TC[, 1])[k], ])
+ tab2 <- (t(tab2) * cw) %*% as.matrix(comp$c1)
+ for (i in 1:min(nf, 4)) {
+ if (tab2[i, i] < 0) {
+ for (j in 1:nf) tab2[i, j] <- -tab2[i, j]
+ }
+ if (tab1[i, i] < 0) {
+ for (j in 1:nf) tab1[i, j] <- -tab1[i, j]
+ }
+ }
+ w1[i1:i2, ] <- tab1
+ w2[i1:i2, ] <- tab2
+ }
+ w1 <- data.frame(w1, row.names = auxinames$tab)
+ w2 <- data.frame(w2, row.names = auxinames$tab)
+ names(w2) <- names(w1) <- paste("C", 1:nf, sep = "")
+ atp$Tcomp <- w1
+ atp$Tax <- w2
+ tab <- as.matrix(X[[1]])
+ w <- as.matrix(comp$c1)
+ cooli <- t(t(tab) * cw) %*% w
+ for (k in 2:nblo) {
+ tab <- as.matrix(X[[k]])
+ cooliauxi <- t(t(tab) * cw) %*% w
+ cooli <- rbind(cooli, cooliauxi)
+ }
+ cooli <- data.frame(cooli, row.names = auxinames$row)
+ atp$Tli <- cooli
+ tab <- as.matrix(X[[1]])
+ w <- as.matrix(comp$l1) * lw
+ cooco <- t(tab) %*% w
+ for (k in 2:nblo) {
+ tab <- as.matrix(X[[k]])
+ coocoauxi <- t(tab) %*% w
+ cooco <- rbind(cooco, coocoauxi)
+ }
+ cooco <- data.frame(cooco, row.names = auxinames$col)
+ atp$Tco <- cooco
+ normcompro <- sum(atp$eig)
+ indica <- as.factor(rep(1:nblo, sepa$rank))
+ w <- split(sepa$Eig, indica)
+ normtab <- unlist(lapply(w, sum))
+ covv <- rep(0, nblo)
+ w1 <- atp$tab * lwsqrt
+ w1 <- t(t(w1) * cwsqrt)
+ for (k in 1:nblo) {
+ wk <- X[[k]] * lwsqrt
+ wk <- t(t(wk) * cwsqrt)
+ covv[k] <- sum(w1 * wk)
+ }
+ atp$cos2 <- covv/sqrt(normcompro)/sqrt(normtab)
+ atp$TL <- X$TL
+ atp$TC <- X$TC
+ atp$T4 <- X$T4
+ atp$blo <- X$blo
+ atp$tab.names <- tnames
+ atp$call <- match.call()
+ class(atp) <- c("pta", "dudi")
+ if (!inherits (X,"kcoinertia")) return(atp)
+ # Modifs pour prendre en compte STATICO
+ # on a affaire a une pta de type STATICO
+ # nblo nombre de tableau
+ blocks <- X$supblo
+ nblo <- length(blocks)
+ w <- NULL
+ for (i in 1:nblo) w <- c(w, 1:blocks[i])
+ w <- cbind.data.frame(factor(rep(1:nblo, blocks)), factor(w))
+ names(w) <- c("T", "I")
+ atp$supTI <- w
+ supTInames <- as.data.frame(matrix(unlist(strsplit(auxinames$Trow, "[.]")), ncol=2, byrow=T))
+ levels(atp$supTI$T) <- atp$tab.names
+ levels(atp$supTI$I) <- supTInames[,2]
+# atp$supTI <- auxinames$Trow
+# atp$supTI <- as.data.frame(matrix(unlist(strsplit(auxinames$Trow, "[.]")), ncol=2, byrow=T))
+# names(atp$supTI) <- c("T", "I")
+ lw <- X$suplw
+ lw <- split(lw, factor(rep(1:length(blocks),blocks)))
+ lw <- lapply(lw, function(x) x/sum(x))
+ lw <- unlist(lw)
+ # les lignes d'origine en supplémentaires X
+ w <- X$supX%*%as.matrix(atp$l1*atp$lw)
+# Correction des row names - JT 7 - Jan 2014
+ w <- data.frame(w, row.names = auxinames$Trow)
+ w <- scalewt(w, lw, center = FALSE, scale = TRUE)
+ w <- as.data.frame(w)
+ names(w) <- gsub("RS","sco",names(atp$l1))
+ atp$supIX <- w
+ # les lignes d'origine en supplémentaires Y
+ w <- X$supY%*%as.matrix(atp$c1*atp$cw)
+# Correction des row names - JT - 7 Jan 2014
+ w <- data.frame(w, row.names = auxinames$Trow)
+ w <- scalewt(w, lw, center = FALSE, scale = TRUE)
+ w <- as.data.frame(w)
+ names(w) <- gsub("RS","sco",names(atp$l1))
+ atp$supIY <- w
+ return(atp)
+}
+
+
+"plot.pta" <- function (x, xax = 1, yax = 2, option = 1:4, ...) {
+ if (!inherits(x, "pta"))
+ stop("Object of type 'pta' expected")
+ nf <- x$nf
+ if (xax > nf)
+ stop("Non convenient xax")
+ if (yax > nf)
+ stop("Non convenient yax")
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ mfrow <- n2mfrow(length(option))
+ par(mfrow = mfrow)
+ for (j in option) {
+ if (j == 1) {
+ coolig <- x$RV.coo[, c(1, 2)]
+ s.corcircle(coolig, label = x$tab.names,
+ cgrid = 0, sub = "Interstructure", csub = 1.5,
+ possub = "topleft", fullcircle = TRUE)
+ l0 <- length(x$RV.eig)
+ add.scatter.eig(x$RV.eig, l0, 1, 2, posi = "bottomleft",
+ ratio = 1/4)
+ }
+ if (j == 2) {
+ coolig <- x$li[, c(xax, yax)]
+ s.label(coolig, sub = "Compromise", csub = 1.5,
+ possub = "topleft", )
+ add.scatter.eig(x$eig, x$nf, xax, yax, posi = "bottomleft",
+ ratio = 1/4)
+ }
+ if (j == 3) {
+ cooco <- x$co[, c(xax, yax)]
+ s.arrow(cooco, sub = "Compromise", csub = 1.5,
+ possub = "topleft")
+ }
+ if (j == 4) {
+ plot(x$tabw, x$cos2, xlab = "Tables weights",
+ ylab = "Cos 2")
+ scatterutil.grid(0)
+ title(main = "Typological value")
+ par(xpd = TRUE)
+ scatterutil.eti(x$tabw, x$cos2, label = x$tab.names,
+ clabel = 1)
+ }
+ }
+}
+
+
+"print.pta" <- function (x, ...) {
+ cat("Partial Triadic Analysis\n")
+ cat("class:")
+ cat(class(x), "\n")
+ cat("table number:", length(x$blo), "\n")
+ cat("row number:", length(x$lw), " column number:", length(x$cw),
+ "\n")
+ cat("\n **** Interstructure ****\n")
+ cat("\neigen values: ")
+ l0 <- length(x$RV.eig)
+ cat(signif(x$RV.eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n")
+ else cat("\n")
+ cat(" $RV matrix ", nrow(x$RV), " ", ncol(x$RV), " RV coefficients\n")
+ cat(" $RV.eig vector ", length(x$RV.eig), " eigenvalues\n")
+ cat(" $RV.coo data.frame ", nrow(x$RV.coo), " ", ncol(x$RV.coo),
+ " array scores\n")
+ cat(" $tab.names vector ", length(x$tab.names), " array names\n")
+ cat("\n **** Compromise ****\n")
+ cat("\neigen values: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n")
+ else cat("\n")
+ cat("\n $nf:", x$nf, "axis-components saved")
+ cat("\n $rank: ")
+ cat(x$rank, "\n\n")
+ sumry <- array("", c(5, 4), list(rep("", 5), c("vector",
+ "length", "mode", "content")))
+ sumry[1, ] <- c("$tabw", length(x$tabw), mode(x$tabw), "array weights")
+ sumry[2, ] <- c("$cw", length(x$cw), mode(x$cw), "column weights")
+ sumry[3, ] <- c("$lw", length(x$lw), mode(x$lw), "row weights")
+ sumry[4, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
+ sumry[5, ] <- c("$cos2", length(x$cos2), mode(x$cos2), "cosine^2 between compromise and arrays")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(5, 4), list(rep("", 5), c("data.frame",
+ "nrow", "ncol", "content")))
+ sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "modified array")
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates")
+ sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "row normed scores")
+ sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates")
+ sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores")
+
+ print(sumry, quote = FALSE)
+ cat("\n **** Intrastructure ****\n\n")
+ sumry <- array("", c(7, 4), list(rep("", 7), c("data.frame",
+ "nrow", "ncol", "content")))
+ sumry[1, ] <- c("$Tli", nrow(x$Tli), ncol(x$Tli), "row coordinates (each table)")
+ sumry[2, ] <- c("$Tco", nrow(x$Tco), ncol(x$Tco), "col coordinates (each table)")
+ sumry[3, ] <- c("$Tcomp", nrow(x$Tcomp), ncol(x$Tcomp), "principal components (each table)")
+ sumry[4, ] <- c("$Tax", nrow(x$Tax), ncol(x$Tax), "principal axis (each table)")
+ sumry[5, ] <- c("$TL", nrow(x$TL), ncol(x$TL), "factors for Tli")
+ sumry[6, ] <- c("$TC", nrow(x$TC), ncol(x$TC), "factors for Tco")
+ sumry[7, ] <- c("$T4", nrow(x$T4), ncol(x$T4), "factors for Tax Tcomp")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+}
+
diff --git a/R/quasieuclid.R b/R/quasieuclid.R
new file mode 100644
index 0000000..215aca3
--- /dev/null
+++ b/R/quasieuclid.R
@@ -0,0 +1,17 @@
+"quasieuclid" <- function (distmat) {
+ if (is.euclid(distmat)) {
+ warning("Euclidean distance found : no correction need")
+ return(distmat)
+ }
+ res <- as.matrix(distmat)
+ n <- ncol(res)
+ delta <- -0.5 * bicenter.wt(res * res)
+ eig <- eigen(delta, symmetric = TRUE)
+ ncompo <- sum(eig$value > 0)
+ tabnew <- eig$vectors[, 1:ncompo] * rep(sqrt(eig$values[1:ncompo]),
+ rep(n, ncompo))
+ res <- dist(tabnew)
+ attributes(res) <- attributes(distmat)
+ attr(res, "call") <- match.call()
+ return(res)
+}
diff --git a/R/randEH.R b/R/randEH.R
new file mode 100644
index 0000000..db557d5
--- /dev/null
+++ b/R/randEH.R
@@ -0,0 +1,30 @@
+"randEH" <- function(phyl, nbofsp, nbrep = 10)
+{
+ if (!inherits(phyl, "phylog")) stop("unconvenient phyl")
+ if(is.null(phyl$Wdist)) phyl <- newick2phylog.addtools(phyl)
+ if (length(nbofsp)!= 1) stop("unconvenient nbofsp")
+ nbesp <- length(phyl$leaves)
+ if (!((0 <= nbofsp) & (nbofsp <= nbesp))) stop("unconvenient nbofsp")
+ nbofsp <- round(nbofsp)
+ if (nbofsp == 0) return(rep(0, nbrep))
+ if (nbofsp == nbesp) {
+ return(rep(EH(phyl), nbrep))
+ }
+ simuA1 <- function(i, phy) {
+ comp = sample(1:nbesp, nbofsp)
+ if (nbofsp == 2) {
+ phyl.D <- as.matrix(phyl$Wdist^2 / 2)
+ resc <- (max(phyl.D) + phyl.D[comp[1], comp[2]])
+ }
+ else {
+ if (nbofsp == 1)
+ resc <- max(phyl$Wdist^2 / 2)
+ else {
+ resc <- EH(phyl, select = comp)
+ }
+ }
+ return(resc)
+ }
+ res <- sapply(1:nbrep, simuA1, phyl)
+ return(res)
+}
diff --git a/R/randboot.R b/R/randboot.R
new file mode 100644
index 0000000..6c61378
--- /dev/null
+++ b/R/randboot.R
@@ -0,0 +1,29 @@
+randboot <- function (object, ...) {
+ UseMethod("randboot")
+}
+
+as.randboot <- function(obs, boot, quantiles = c(0.025, 0.975), call = match.call()){
+ ## obs: observed value of the statistic
+ ## boot: a vector (length n) with bootstrapped values
+ ## n: number of repetitions
+
+ res <- list(obs = obs, boot = boot, rep = length(na.omit(boot)))
+ res$stats <- obs - quantile(boot - obs, probs = rev(quantiles), na.rm = TRUE)
+ names(res$stats) <- rev(names(res$stats))
+ res$call <- call
+ class(res) <- "randboot"
+ return(res)
+}
+
+
+print.randboot <- function(x, ...){
+ if (!inherits(x, "randboot"))
+ stop("Non convenient data")
+ cat("Bootstrap\n")
+ cat("Call: ")
+ print(x$call)
+ cat("\nObservation:", x$obs, "\n")
+ cat("\nBased on", x$rep, "replicates\n")
+ cat("\nConfidence Interval:\n")
+ print(x$stats)
+}
diff --git a/R/randtest-internal.R b/R/randtest-internal.R
new file mode 100644
index 0000000..a1ccc9b
--- /dev/null
+++ b/R/randtest-internal.R
@@ -0,0 +1,146 @@
+testdiscrimin <- function(npermut, rank, pl, indica, tab, l1, c1)
+ .C("testdiscrimin",
+ as.integer(npermut),
+ as.double(rank),
+ as.double(pl),
+ as.integer(length(pl)),
+ as.double(indica),
+ as.integer(length(indica)),
+ as.double(t(tab)),
+ as.integer(l1),
+ as.integer(c1),
+ inersim = double(npermut+1),
+ PACKAGE="ade4")$inersim
+
+testertrace <- function(npermut, pc1, pc2, tab1, tab2, l1, c1, c2)
+ .C("testertrace",
+ as.integer(npermut),
+ as.double(pc1),
+ as.double(pc2),
+ as.double(t(tab1)),
+ as.integer(l1),
+ as.integer(c1),
+ as.double(t(tab2)),
+ as.integer(c2),
+ inersim = double(npermut+1),
+ PACKAGE="ade4")$inersim
+
+testertracenu <- function(npermut, pc1, pc2, pl, tab1, tab2, l1, c1, c2, Xinit, Yinit, typX, typY)
+ .C("testertracenu",
+ as.integer(npermut),
+ as.double(pc1),
+ as.double(pc2),
+ as.double(pl),
+ as.double(t(tab1)),
+ as.integer(l1),
+ as.integer(c1),
+ as.double(t(tab2)),
+ as.integer(c2),
+ as.double(t(Xinit)),
+ as.double(t(Yinit)),
+ as.integer(typX),
+ as.integer(typY),
+ inersim = double(npermut+1),
+ PACKAGE="ade4")$inersim
+
+testertracenubis <- function(npermut, pc1, pc2, pl, tab1, tab2, l1, c1, c2, Xinit, Yinit, typX, typY, fixed)
+ .C("testertracenubis",
+ as.integer(npermut),
+ as.double(pc1),
+ as.double(pc2),
+ as.double(pl),
+ as.double(t(tab1)),
+ as.integer(l1),
+ as.integer(c1),
+ as.double(t(tab2)),
+ as.integer(c2),
+ as.double(t(Xinit)),
+ as.double(t(Yinit)),
+ as.integer(typX),
+ as.integer(typY),
+ as.integer(fixed),
+ inersim = double(npermut+1),
+ PACKAGE="ade4")$inersim
+
+testinter <- function(npermut, pl, pc, moda, indica, tab, l1, c1)
+ .C("testinter",
+ as.integer(npermut),
+ as.double(pl),
+ as.integer(length(pl)),
+ as.double(pc),
+ as.integer(length(pc)),
+ as.integer(moda),
+ as.double(indica),
+ as.integer(length(indica)),
+ as.double(t(tab)),
+ as.integer(l1),
+ as.integer(c1),
+ inersim = double(npermut+1),
+ PACKAGE="ade4")$inersim
+
+testprocuste <- function(npermut, lig, c1, c2, tab1, tab2)
+ .C("testprocuste",
+ as.integer(npermut),
+ as.integer(lig),
+ as.integer(c1),
+ as.integer(c2),
+ as.double(t(tab1)),
+ as.double(t(tab2)),
+ inersim = double(npermut+1),
+ PACKAGE="ade4")$inersim
+
+testmantel <- function(npermut, col, tab1, tab2)
+ .C("testmantel",
+ as.integer(npermut),
+ as.integer(col),
+ as.double(t(tab1)),
+ as.double(t(tab2)),
+ inersim = double(npermut+1),
+ PACKAGE="ade4")$inersim
+
+testamova <- function(distab, l1, c1, samtab, l2, c2, strtab, l3, c3, indic, nbhapl, npermut, divtotal, df, r2)
+ .C("testamova",
+ as.double(t(distab)),
+ as.integer(l1),
+ as.integer(c1),
+ as.integer(t(samtab)),
+ as.integer(l2),
+ as.integer(c2),
+ as.integer(t(strtab)),
+ as.integer(l3),
+ as.integer(c3),
+ as.integer(indic),
+ as.integer(nbhapl),
+ as.integer(npermut),
+ as.double(divtotal),
+ as.double(df),
+ result = double(r2),
+ PACKAGE="ade4")$result
+
+
+testertracerlq <- function (npermut, pcR, pcQ, plL, pcL, tabR, tabQ, tabL, typQ, typR, indexR, assignR, indexQ, assignQ, modeltype)
+ .C("testertracerlq",
+ as.integer(npermut),
+ as.double(pcR),
+ as.integer(length(pcR)),
+ as.double(pcQ),
+ as.integer(length(pcQ)),
+ as.double(plL),
+ as.integer(length(plL)),
+ as.double(pcL),
+ as.integer(length(pcL)),
+ as.double(t(tabR)),
+ as.double(t(tabQ)),
+ as.double(t(tabL)),
+ as.integer(assignR),
+ as.integer(assignQ),
+ as.integer(indexR),
+ as.integer (length(indexR)),
+ as.integer(indexQ),
+ as.integer (length(indexQ)),
+ as.integer(typQ),
+ as.integer(typR),
+ inersim = double(npermut+1),
+ modeltype=as.integer(modeltype),
+ PACKAGE = "ade4")$inersim
+
diff --git a/R/randtest.R b/R/randtest.R
new file mode 100644
index 0000000..d63c7b9
--- /dev/null
+++ b/R/randtest.R
@@ -0,0 +1,78 @@
+"randtest" <- function (xtest, ...) {
+ UseMethod("randtest")
+}
+
+"as.randtest" <- function (sim, obs, alter = c("greater", "less", "two-sided"), output = c("light", "full"), call = match.call() ) {
+ output <- match.arg(output)
+ if(output == "full")
+ res <- list(sim = sim, obs = obs)
+ else
+ res <- list(obs = obs)
+
+ res$alter <- match.arg(alter)
+ sim <- na.omit(sim)
+ res$rep <- length(sim)
+ res$expvar <- c(Std.Obs=(res$obs-mean(sim))/sd(sim),Expectation=mean(sim),Variance=var(sim))
+ if(res$alter=="greater"){
+ res$pvalue <- (sum(sim >= obs) + 1)/(length(sim) + 1)
+ }
+ else if(res$alter=="less"){
+ res$pvalue <- (sum(sim <= obs) + 1)/(length(sim) + 1)
+ }
+ else if(res$alter=="two-sided") {
+ sim0 <- abs(sim-mean(sim))
+ obs0 <- abs(obs-mean(sim))
+ res$pvalue <- (sum(sim0 >= obs0) + 1)/(length(sim) +1)
+ }
+
+ ## compute histogram (mainly used for 'light' randtest)
+ if(length(sim) > 0){
+ r0 <- c(sim, obs)
+ l0 <- max(sim) - min(sim)
+ w0 <- l0/(log(length(sim), base = 2) + 1)
+ xlim0 <- range(r0) + c(-w0, w0)
+ h0 <- hist(sim, plot = FALSE, nclass = 10)
+ res$plot <- list(hist = h0, xlim = xlim0)
+ }
+
+ res$call <- call
+ class(res) <- "randtest"
+ if(output == "light")
+ class(res) <- c(class(res), "lightrandtest")
+ return(res)
+}
+
+"print.randtest" <- function (x, ...) {
+ if (!inherits(x, "randtest"))
+ stop("Non convenient data")
+ cat("Monte-Carlo test\n")
+ cat("Call: ")
+ print(x$call)
+ cat("\nObservation:", x$obs, "\n")
+ cat("\nBased on", x$rep, "replicates\n")
+ cat("Simulated p-value:", x$pvalue, "\n")
+ cat("Alternative hypothesis:", x$alter, "\n\n")
+ print(x$expvar)
+}
+
+"plot.randtest" <- function (x, nclass = 10, coeff = 1, ...) {
+ if (!inherits(x, "randtest"))
+ stop("Non convenient data")
+ if(!inherits(x, "lightrandtest") & nclass != 10){
+ r0 <- c(x$sim, x$obs)
+ l0 <- max(x$sim) - min(x$sim)
+ w0 <- l0/(log(length(x$sim), base = 2) + 1)
+ w0 <- w0 * coeff
+ xlim0 <- range(r0) + c(-w0, w0)
+ h0 <- hist(x$sim, plot = FALSE, nclass = nclass)
+ } else {
+ h0 <- x$plot$hist
+ xlim0 <- x$plot$xlim
+ }
+ y0 <- max(h0$counts)
+
+ plot(h0, xlim = xlim0, col = grey(0.8), ...)
+ lines(c(x$obs, x$obs), c(y0/2, 0))
+ points(x$obs, y0/2, pch = 18, cex = 2)
+ invisible()
+}
diff --git a/R/randtest.amova.R b/R/randtest.amova.R
new file mode 100644
index 0000000..e9bde11
--- /dev/null
+++ b/R/randtest.amova.R
@@ -0,0 +1,34 @@
+randtest.amova <- function(xtest, nrepet = 99, ...) {
+ if (!inherits(xtest, "amova")) stop("Object of class 'amova' expected for xtest")
+ if (nrepet <= 1) stop("Non convenient nrepet")
+ distances <- as.matrix(xtest$distances) / 2
+ samples <- as.matrix(xtest$samples)
+ structures <- xtest$structures
+ ddl <- xtest$results$Df
+ ddl[1:(length(ddl) - 1)] <- ddl[(length(ddl) - 1):1]
+ sigma <- xtest$componentsofcovariance$Sigma
+ lesss <- xtest$results$"Sum Sq"
+ if (is.null(structures)) {
+ structures <- cbind.data.frame(rep(1, nrow(samples)))
+ indic <- 0
+ }
+ else {
+ for (i in 1:ncol(structures)) {
+ structures[, i] <- factor(as.numeric(structures[, i]))
+ }
+ indic <- 1
+ }
+ if (indic != 0) {
+ longueurresult <- nrepet * (length(sigma) - 1)
+ res <- testamova(distances, nrow(distances), nrow(distances), samples, nrow(samples), ncol(samples), structures, nrow(structures), ncol(structures), indic, sum(samples), nrepet, lesss[length(lesss)] / sum(samples), ddl, longueurresult)
+ restests <- matrix(res, nrepet, length(sigma) - 1, byrow = TRUE)
+ alts <- rep("greater", length(names(structures)) + 1)
+ permutationtests <- as.krandtest(sim=restests,obs=sigma[(length(sigma) - 1):1],names = paste("Variations", c("within samples", "between samples", paste("between", names(structures)))), alter=c("less", alts), call = match.call(), ...)
+ }
+ else {
+ longueurresult <- nrepet * (length(sigma) - 2)
+ res <- testamova(distances, nrow(distances), nrow(distances), samples, nrow(samples), ncol(samples), structures, nrow(structures), ncol(structures), indic, sum(samples), nrepet, lesss[length(lesss)] / sum(samples), ddl, longueurresult)
+ permutationtests <- as.randtest(sim = res, obs = sigma[1], ...)
+ }
+ return(permutationtests)
+}
diff --git a/R/randtest.between.R b/R/randtest.between.R
new file mode 100644
index 0000000..f9580c5
--- /dev/null
+++ b/R/randtest.between.R
@@ -0,0 +1,24 @@
+"randtest.between" <- function(xtest, nrepet = 999, ...) {
+ if (!inherits(xtest,"dudi"))
+ stop("Object of class dudi expected")
+ if (!inherits(xtest,"between"))
+ stop ("Type 'between' expected")
+ appel <- as.list(xtest$call)
+ dudi1 <- eval.parent(appel[[2]]) ## could work with bca (appel$x) or between (appel$dudi)
+ fac <- eval.parent(appel$fac)
+ X <- dudi1$tab
+ X.lw <- dudi1$lw
+ if ((!(identical(all.equal(X.lw,rep(1/nrow(X), nrow(X))),TRUE)))) {
+ if(as.list(dudi1$call)[[1]] == "dudi.acm" )
+ stop ("Not implemented for non-uniform weights in the case of dudi.acm")
+ else if(as.list(dudi1$call)[[1]] == "dudi.hillsmith" )
+ stop ("Not implemented for non-uniform weights in the case of dudi.hillsmith")
+ else if(as.list(dudi1$call)[[1]] == "dudi.mix" )
+ stop ("Not implemented for non-uniform weights in the case of dudi.mix")
+ }
+
+ inertot <- sum(dudi1$eig)
+ isim <- testinter(nrepet, dudi1$lw, dudi1$cw, length(unique(fac)), fac, dudi1$tab, nrow(X), ncol(X))/inertot
+ obs <- isim[1]
+ return(as.randtest(sim = isim[-1], obs = obs, call = match.call(), ...))
+}
diff --git a/R/randtest.coinertia.R b/R/randtest.coinertia.R
new file mode 100644
index 0000000..8b5b479
--- /dev/null
+++ b/R/randtest.coinertia.R
@@ -0,0 +1,81 @@
+"randtest.coinertia" <- function(xtest, nrepet = 999, fixed = 0, ...) {
+ if(!inherits(xtest,"dudi"))
+ stop("Object of class dudi expected")
+ if(!inherits(xtest,"coinertia"))
+ stop("Object of class 'coinertia' expected")
+ appel <- as.list(xtest$call)
+ dudiX <- eval.parent(appel$dudiX)
+ dudiY <- eval.parent(appel$dudiY)
+
+ ## X table
+ X <- dudiX$tab
+ X.cw <- dudiX$cw
+ X.lw <- dudiX$lw
+ appelX <- as.list(dudiX$call)
+ apx <- appelX$df
+ Xinit <- eval.parent(appelX$df)
+
+ ## Test the different cases
+ typX <- dudi.type(dudiX$call)
+ if(typX == 2)
+ Xinit <- acm.disjonctif(Xinit)
+ if(!(typX %in% (1:7)))
+ stop ("Not yet available")
+
+ ## Y table
+ Y <- dudiY$tab
+ Y.cw <- dudiY$cw
+ Y.lw <- dudiY$lw
+ appelY <- as.list(dudiY$call)
+ apy <- appelY$df
+ Yinit <- eval.parent(appelY$df)
+
+ ## Test the different cases
+ typY <- dudi.type(dudiY$call)
+ if(typY == 2)
+ Yinit <- acm.disjonctif(Yinit)
+ if(!(typY %in% (1:7)))
+ stop ("Not yet available")
+
+ if(identical(all.equal(X.lw, Y.lw), TRUE)) {
+ if(identical(all.equal(X.lw, rep(1/nrow(X), nrow(X))), TRUE)) {
+ isim <- testertrace(nrepet, X.cw, Y.cw, X, Y, nrow(X), ncol(X), ncol(Y))
+ } else {
+ if(fixed == 0) {
+ cat("Warning: non uniform weight. The results from simulations\n")
+ cat("are not valid if weights are computed from analysed data.\n")
+ isim <- testertracenu(nrepet, X.cw, Y.cw, X.lw, X, Y, nrow(X), ncol(X), ncol(Y), Xinit, Yinit, typX, typY)
+ if(typX == 2)
+ isim[-1] <- isim[-1]/ncol(eval.parent(appelX$df))
+ if(typY == 2)
+ isim[-1] <- isim[-1]/ncol(eval.parent(appelY$df))
+ } else if(fixed == 1) {
+ cat("Warning: non uniform weight. The results from permutations\n")
+ cat("are valid only if the row weights come from the fixed table.\n")
+ cat("The fixed table is table X : ")
+ print(apx)
+ isim <- testertracenubis(nrepet, X.cw, Y.cw, X.lw, X, Y, nrow(X), ncol(X), ncol(Y), Xinit, Yinit, typX, typY, fixed)
+ if(typY == 2)
+ isim[-1] <- isim[-1]/ncol(eval.parent(appelY$df))
+ } else if (fixed==2) {
+ cat("Warning: non uniform weight. The results from permutations\n")
+ cat("are valid only if the row weights come from the fixed table.\n")
+ cat("The fixed table is table Y : ")
+ print(apy)
+ isim <- testertracenubis(nrepet, X.cw, Y.cw, X.lw, X, Y, nrow(X), ncol(X), ncol(Y), Xinit, Yinit, typX, typY, fixed)
+ if(typX == 2)
+ isim[-1] <- isim[-1]/ncol(eval.parent(appelX$df))
+
+ }
+ else
+ stop ("Error : fixed must be =< 2")
+ }
+
+ ## RV computed using the coinertia
+ isim <- isim/sqrt(sum(dudiX$eig^2))/sqrt(sum(dudiY$eig^2))
+ obs <- isim[1]
+ return(as.randtest(sim = isim[-1], obs = obs, call = match.call(), ...))
+ } else {
+ stop ("Equal row weights expected")
+ }
+}
diff --git a/R/randtest.discrimin.R b/R/randtest.discrimin.R
new file mode 100644
index 0000000..fa54b15
--- /dev/null
+++ b/R/randtest.discrimin.R
@@ -0,0 +1,26 @@
+"randtest.discrimin" <- function(xtest, nrepet=999, ...) {
+ if (!inherits(xtest, "discrimin"))
+ stop("'discrimin' object expected")
+ appel <- as.list(xtest$call)
+ dudi <- eval.parent(appel$dudi)
+ fac <- eval.parent(appel$fac)
+ lig <- nrow(dudi$tab)
+ if (length(fac) != lig) stop ("Non convenient dimension")
+ rank <- dudi$rank
+ dudi <- redo.dudi(dudi,rank)
+ X <- dudi$l1
+ X.lw <- dudi$lw
+ # dudi et dudi.lw sont soumis a la permutation
+ # fac reste fixe
+ if ((!(identical(all.equal(X.lw,rep(1/nrow(X), nrow(X))),TRUE)))) {
+ if(as.list(dudi$call)[[1]] == "dudi.acm" )
+ stop ("Not implemented for non-uniform weights in the case of dudi.acm")
+ else if(as.list(dudi$call)[[1]] == "dudi.hillsmith" )
+ stop ("Not implemented for non-uniform weights in the case of dudi.hillsmith")
+ else if(as.list(dudi$call)[[1]] == "dudi.mix" )
+ stop ("Not implemented for non-uniform weights in the case of dudi.mix")
+ }
+ isim <- testdiscrimin(nrepet, rank, X.lw, fac, X, nrow(X), ncol(X))
+ obs <- isim[1]
+ return(as.randtest(isim[-1], obs, call = match.call(), ...))
+}
diff --git a/R/randtest.dpcoa.R b/R/randtest.dpcoa.R
new file mode 100644
index 0000000..07e5dc0
--- /dev/null
+++ b/R/randtest.dpcoa.R
@@ -0,0 +1,50 @@
+randtest.dpcoa <- function(xtest, model = c("1p","1s"), nrep = 99, alter = c("greater", "less", "two-sided"), ...){
+
+ if (!inherits(xtest, "dpcoa"))
+ stop("Type 'dpcoa' expected")
+
+ appel <- as.list(xtest$call)
+ df0 <- eval.parent(appel$df)
+ df <- as.data.frame(t(df0))
+ dis <- eval.parent(appel$dis)
+ if(is.character(model)) model <- model[1]
+
+ if(nrow(df) < 3) stop("df is too small for a permutation test")
+ obs <- apqe(df, dis)
+ obs <- obs$results[1,]/obs$results[3,]
+
+ funrandomization <- function(i){
+ if(is.function(model))
+ simdf <- as.data.frame(t(model(df0, ...)))
+ else{
+ if(model=="1s"){
+ funperm <- function(x){
+ begin <- (1:length(x))[x>0]
+ if(length(begin)==1) return(x)
+ else{
+ end <- sample(begin)
+ simx <- x
+ simx[begin] <- x[end]
+ return(simx)
+ }
+ }
+ simdf <- sapply(df, funperm)
+ }
+ else{
+ if(model=="1p")
+ simdf <- df[sample(1:nrow(df)), ]
+ else
+ stop("The definition of the parameter 'model' is not correct")
+ }
+ }
+ sim <- apqe(simdf, dis)
+ sim <- sim$results[1,]/sim$results[3,]
+ return(sim)
+
+ }
+
+ ressim <- sapply(1:nrep, funrandomization)
+ res <- as.randtest(obs = obs, sim = ressim, alter = alter, call = match.call(), ...)
+ return(res)
+
+}
diff --git a/R/randtest.pcaiv.R b/R/randtest.pcaiv.R
new file mode 100644
index 0000000..a3368ac
--- /dev/null
+++ b/R/randtest.pcaiv.R
@@ -0,0 +1,27 @@
+"randtest.pcaiv" <- function (xtest, nrepet = 99, ...) {
+ if (!inherits(xtest, "dudi"))
+ stop("Object of class dudi expected")
+ if (!inherits(xtest, "pcaiv"))
+ stop("Type 'pcaiv' expected")
+ appel <- as.list(xtest$call)
+ dudi1 <- eval.parent(appel$dudi)
+ df <- data.frame(eval.parent(appel$df))
+ y <- as.matrix(dudi1$tab)
+ inertot <- sum(dudi1$eig)
+ sqlw <- sqrt(dudi1$lw)
+ sqcw <- sqrt(dudi1$cw)
+
+ fmla <- as.formula(paste("y ~", paste(names(df)[[2]], collapse = "+")))
+ mf <- model.frame(fmla, data = cbind.data.frame(y, df))
+ mt <- attr(mf, "terms")
+ x <- model.matrix(mt, mf)
+ wt <- outer(sqlw, sqcw)
+ ## Fast function for computing sum of squares of the fitted table
+ obs <- sum((lm.wfit(y = y,x = x, w = dudi1$lw)$fitted.values * wt)^2) / inertot
+
+ isim <- rep(NA, nrepet)
+ for(i in 1:nrepet)
+ isim[i] <- sum((lm.wfit(y = y, x = x[sample(nrow(x)), ], w = dudi1$lw)$fitted.values * wt)^2) / inertot
+ return(as.randtest(sim = isim, obs = obs, call = match.call(), ...))
+ }
+
diff --git a/R/randtest.pcaivortho.R b/R/randtest.pcaivortho.R
new file mode 100644
index 0000000..f01cd49
--- /dev/null
+++ b/R/randtest.pcaivortho.R
@@ -0,0 +1,29 @@
+"randtest.pcaivortho" <- function (xtest, nrepet = 99, ...) {
+ if (!inherits(xtest, "dudi"))
+ stop("Object of class dudi expected")
+ if (!inherits(xtest, "pcaivortho"))
+ stop("Type 'pcaivortho' expected")
+ appel <- as.list(xtest$call)
+ dudi1 <- eval.parent(appel$dudi)
+ df <- data.frame(eval.parent(appel$df))
+ y <- as.matrix(dudi1$tab)
+ inertot <- sum(dudi1$eig)
+ sqlw <- sqrt(dudi1$lw)
+ sqcw <- sqrt(dudi1$cw)
+
+
+ fmla <- as.formula(paste("y ~", paste(names(df), collapse = "+")))
+ mf <- model.frame(fmla,data=cbind.data.frame(y,df))
+ mt <- attr(mf,"terms")
+ x <- model.matrix(mt,mf)
+ wt <- outer(sqlw, sqcw)
+ ## Fast function for computing sum of squares of the fitted table
+ obs <- sum((lm.wfit(y = y,x = x, w = dudi1$lw)$residuals * wt)^2) / inertot
+ isim <- c()
+ for(i in 1:nrepet)
+ isim[i] <- sum((lm.wfit(y = y,x = x[sample(nrow(x)),], w = dudi1$lw)$residuals * wt)^2) / inertot
+
+ return(as.randtest(sim = isim, obs = obs,call = match.call(), ...))
+
+ }
+
diff --git a/R/randtest.rlq.R b/R/randtest.rlq.R
new file mode 100644
index 0000000..1dd16af
--- /dev/null
+++ b/R/randtest.rlq.R
@@ -0,0 +1,121 @@
+randtest.rlq <- function(xtest, nrepet = 999, modeltype = 6, ...) {
+ if (!inherits(xtest,"dudi"))
+ stop("Object of class dudi expected")
+ if (!inherits(xtest,"rlq"))
+ stop("Object of class 'rlq' expected")
+ if (!(modeltype %in% c(2, 4, 5, 6)))
+ stop("modeltype should be 2, 4, 5 or 6")
+
+ if(modeltype == 6){
+ test1 <- randtest.rlq(xtest, modeltype = 2, nrepet = nrepet, output = "full", ...)
+ test2 <- randtest.rlq(xtest, modeltype = 4, nrepet = nrepet, output = "full", ...)
+ res <- combine.randtest.rlq(test1,test2)
+ res$call <- match.call()
+ return(res)
+ }
+
+ appel <- as.list(xtest$call)
+ dudiR <- eval.parent(appel$dudiR)
+ dudiQ <- eval.parent(appel$dudiQ)
+ dudiL <- eval.parent(appel$dudiL)
+
+
+ R.cw <- dudiR$cw
+ appelR <- as.list(dudiR$call)
+ Rinit <- as.data.frame(eval.parent(appelR$df))
+
+ ## Test the different cases
+ typR <- dudi.type(dudiR$call)
+
+ ## index can take two values (1 quantitative / 2 factor)
+ if(typR %in% c(1,3,4,5,6,7)) {
+ indexR <- rep(1,ncol(Rinit))
+ assignR <- 1:ncol(Rinit)
+ } else if (typR == 2) {
+ indexR <- rep(2, ncol(Rinit))
+ assignR <- rep(1:ncol(Rinit), apply(Rinit, 2, function(x) nlevels(as.factor(x))))
+ Rinit <- acm.disjonctif(Rinit)
+ } else if (typR == 8) {
+ indexR <- ifelse(dudiR$index == 'q', 1, 2)
+ assignR <- dudiR$assign
+
+ res <- matrix(0, nrow(Rinit), 1)
+
+ for (j in 1:(ncol(Rinit))) {
+ if (indexR[j] == 1) {
+ res <- cbind(res, Rinit[, j])
+ } else if (indexR[j] == 2) {
+ w <- fac2disj(Rinit[, j], drop = TRUE)
+ res <- cbind(res, w)
+ }
+ }
+
+ Rinit <- res[,-1]
+
+ } else stop ("Not yet available")
+
+
+
+ Q.cw <- dudiQ$cw
+ appelQ <- as.list(dudiQ$call)
+ Qinit <- as.data.frame(eval.parent(appelQ$df))
+ typQ <- dudi.type(dudiQ$call)
+
+ if (typQ %in% c(1,3,4,5,6,7)) {
+ indexQ <- rep(1,ncol(Qinit))
+ assignQ <- 1:ncol(Qinit)
+ } else if (typQ == 2) {
+ indexQ <- rep(2,ncol(Qinit))
+ assignQ <- rep(1:ncol(Qinit), apply(Qinit, 2, function(x) nlevels(as.factor(x))))
+ Qinit <- acm.disjonctif(Qinit)
+ } else if (typQ == 8) {
+ indexQ <- ifelse(dudiQ$index == 'q',1,2)
+ assignQ <- dudiQ$assign
+
+ res <- matrix(0, nrow(Qinit), 1)
+
+ for (j in 1:(ncol(Qinit))) {
+ if (indexQ[j] == 1) {
+ res <- cbind(res, Qinit[, j])
+ } else if (indexQ[j] == 2) {
+ w <- fac2disj(Qinit[, j], drop = TRUE)
+ res <- cbind(res, w)
+ }
+ }
+ Qinit <- res[,-1]
+
+ } else stop ("Not yet available")
+
+ L <- dudiL$tab
+ L.cw <- dudiL$cw
+ L.lw <- dudiL$lw
+ isim <- testertracerlq(nrepet, R.cw, Q.cw, L.lw, L.cw, Rinit, Qinit, L, typQ, typR,indexR, assignR, indexQ, assignQ, modeltype)
+
+ obs <- isim[1]
+ return(as.randtest(isim[-1], obs, call = match.call(), ...))
+}
+
+
+combine.randtest.rlq <- function(obj1, obj2, ...) {
+ if(!inherits(obj1, "randtest") | !inherits(obj2, "randtest"))
+ stop("Not a 'randtest' object")
+
+ call1 <- as.list(obj1$call)
+ call2 <- as.list(obj2$call)
+
+ if((call1[[1]] != "randtest.rlq") | (call2[[1]] != "randtest.rlq"))
+ stop("Objects must obtained by the 'randtest.rlq' function")
+
+ ## if argument is missing, modeltype = 5 (default)
+ if(is.null(call1$modeltype) | is.null(call2$modeltype))
+ stop("modeltype(s) must be 2 or 4")
+ ## modeltype 2 and 4 should be combined
+ modeltypes <- c(call1$modeltype, call2$modeltype)
+ if(sum(sort(modeltypes) == c(2,4))!=2)
+ stop("modeltype(s) must be 2 and 4")
+ sim <- cbind(obj1$sim, obj2$sim)
+ colnames(sim) <- paste("Model",modeltypes)
+ res <- as.krandtest(sim, c(obj1$obs,obj2$obs), alter = c(obj1$alter, obj2$alter), call=match.call(), p.adjust.method = "none", ...)
+ res$comb.pvalue <- max(obj1$pvalue, obj2$pvalue)
+ return(res)
+}
diff --git a/R/randxval.R b/R/randxval.R
new file mode 100644
index 0000000..81e90dc
--- /dev/null
+++ b/R/randxval.R
@@ -0,0 +1,26 @@
+as.randxval <- function(RMSEc, RMSEv, quantiles = c(0.25, 0.75), call = match.call()){
+ ## RMSEc: a vector (length n) with residual mean square error of calibration
+ ## RMSEv: a vector (length n) with residual mean square error of validation
+ ## n: number of repetitions
+ if(length(RMSEc) != length(RMSEv))
+ stop("Both RMSE should be computed on the same number of repetitions")
+
+ res <- list(RMSEc = RMSEc, RMSEv = RMSEv, rep = c(length(na.omit(RMSEc)), length(na.omit(RMSEv))))
+ res$stats <- rbind(quantile(RMSEc, probs = quantiles, na.rm = TRUE), quantile(RMSEv, probs = quantiles, na.rm = TRUE))
+ res$stats <- cbind(Mean = c(mean(RMSEc), mean(RMSEv)), res$stats)
+ rownames(res$stats) <- c("RMSEc", "RMSEv")
+ res$call <- call
+ class(res) <- "randxval"
+ return(res)
+}
+
+
+print.randxval <- function(x, ...){
+ if (!inherits(x, "randxval"))
+ stop("Non convenient data")
+ cat("Two-fold cross-validation\n")
+ cat("Call: ")
+ print(x$call)
+ cat("\nRoot mean square error of calibration and validation:\n")
+ print(cbind.data.frame(N.rep = x$rep, x$stats))
+}
diff --git a/R/reconst.R b/R/reconst.R
new file mode 100644
index 0000000..32782e6
--- /dev/null
+++ b/R/reconst.R
@@ -0,0 +1,51 @@
+"reconst" <- function (dudi, ...) {
+ UseMethod("reconst")
+}
+
+ "reconst.pca" <- function (dudi, nf = 1, ...) {
+ if (!inherits(dudi, "dudi"))
+ stop("Object of class 'dudi' expected")
+ if (nf > dudi$nf)
+ stop(paste(nf, "factors need >", dudi$nf, "factors available\n"))
+ if (!inherits(dudi, "pca"))
+ stop("Object of class 'dudi' expected")
+ cent <- dudi$cent
+ norm <- dudi$norm
+ n <- nrow(dudi$tab)
+ p <- ncol(dudi$tab)
+ res <- matrix(0, n, p)
+ for (i in 1:nf) {
+ xli <- dudi$li[, i]
+ yc1 <- dudi$c1[, i]
+ res <- res + matrix(xli, n, 1) %*% matrix(yc1, 1, p)
+ }
+ res <- t(apply(res, 1, function(x) x * norm))
+ res <- t(apply(res, 1, function(x) x + cent))
+ res <- data.frame(res)
+ names(res) <- names(dudi$tab)
+ row.names(res) <- row.names(dudi$tab)
+ return(res)
+}
+
+"reconst.coa" <- function (dudi, nf = 1, ...) {
+ if (!inherits(dudi, "dudi"))
+ stop("Object of class 'dudi' expected")
+ if (nf > dudi$nf)
+ stop(paste(nf, "factors need >", dudi$nf, "factors available\n"))
+ if (!inherits(dudi, "coa"))
+ stop("Object of class 'dudi' expected")
+ pl <- dudi$lw
+ pc <- dudi$cw
+ n <- dudi$N
+ res0 <- outer(pl,pc)*n
+ res <- data.frame(res0)
+ names(res) <- names(dudi$tab)
+ row.names(res) <- row.names(dudi$tab)
+ if (nf ==0) return(res)
+ for (i in 1:nf) {
+ xli <- dudi$li[, i]
+ yc1 <- dudi$c1[, i]
+ res <- res + outer(xli,yc1)*res0
+ }
+ return(res)
+}
diff --git a/R/rlq.R b/R/rlq.R
new file mode 100644
index 0000000..f8134a8
--- /dev/null
+++ b/R/rlq.R
@@ -0,0 +1,199 @@
+"plot.rlq" <- function (x, xax = 1, yax = 2, ...) {
+ if (!inherits(x, "rlq"))
+ stop("Use only with 'rlq' objects")
+ if (x$nf == 1) {
+ warnings("One axis only : not yet implemented")
+ return(invisible())
+ }
+ if (xax > x$nf)
+ stop("Non convenient xax")
+ if (yax > x$nf)
+ stop("Non convenient yax")
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ layout(matrix(c(1, 1, 3, 1, 1, 4, 2, 2,5,2,2,6,8,8,7), 3, 5),
+ respect = TRUE)
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ s.label(x$lR[, c(xax, yax)], sub = "R row scores",csub = 2,clabel = 1.25)
+ s.label(x$lQ[, c(xax, yax)], sub = "Q row scores",csub = 2,clabel = 1.25)
+ s.corcircle(x$aR, xax, yax, sub = "R axes", csub = 2, clabel = 1.25)
+ s.arrow(x$l1, xax = xax, yax = yax, sub = "R Canonical weights", csub = 2, clabel = 1.25)
+ s.arrow(x$c1, xax = xax, yax = yax, sub = "Q Canonical weights", csub = 2, clabel = 1.25)
+ s.corcircle(x$aQ, xax, yax, sub = "Q axes", csub = 2, clabel = 1.25)
+ scatterutil.eigen(x$eig, wsel = c(xax, yax))
+}
+
+"print.rlq" <- function (x, ...) {
+ if (!inherits(x, "rlq"))
+ stop("to be used with 'rlq' object")
+ cat("RLQ analysis\n")
+ cat("call: ")
+ print(x$call)
+ cat("class: ")
+ cat(class(x), "\n")
+ cat("\n$rank (rank) :", x$rank)
+ cat("\n$nf (axis saved) :", x$nf)
+ ## cat("\n$RV (RV coeff) :", x$RV)
+ cat("\n\neigen values: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n\n")
+ else cat("\n\n")
+ sumry <- array("", c(3, 4), list(1:3, c("vector", "length",
+ "mode", "content")))
+ sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "Eigenvalues")
+ sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), paste("Row weigths (for", x$call[[2]], "cols)"))
+ sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), paste("Col weigths (for", x$call[[4]], "cols)"))
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(11, 4), list(1:11, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), paste("Crossed Table (CT): cols(", x$call[[2]], ") x cols(", x$call[[4]], ")", sep=""))
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), paste("CT row scores (cols of ", x$call[[2]], ")", sep=""))
+ sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), paste("Principal components (loadings for ", x$call[[2]], " cols)", sep=""))
+ sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), paste("CT col scores (cols of ", x$call[[4]], ")", sep=""))
+ sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), paste("Principal axes (loadings for ", x$call[[4]], " cols)", sep=""))
+ sumry[6, ] <- c("$lR", nrow(x$lR), ncol(x$lR), paste("Row scores (rows of ", x$call[[2]], ")", sep=""))
+ sumry[7, ] <- c("$mR", nrow(x$mR), ncol(x$mR), paste("Normed row scores (rows of ", x$call[[2]], ")", sep=""))
+ sumry[8, ] <- c("$lQ", nrow(x$lQ), ncol(x$lQ), paste("Row scores (rows of ", x$call[[4]], ")", sep=""))
+ sumry[9, ] <- c("$mQ", nrow(x$mQ), ncol(x$mQ), paste("Normed row scores (rows of ", x$call[[4]], ")", sep=""))
+ sumry[10, ] <- c("$aR", nrow(x$aR), ncol(x$aR), paste("Corr ", x$call[[2]], " axes / rlq axes", sep=""))
+ sumry[11, ] <- c("$aQ", nrow(x$aQ), ncol(x$aQ), paste("Corr ", x$call[[3]], " axes / coinertia axes", sep=""))
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+}
+
+"rlq" <- function( dudiR, dudiL, dudiQ , scannf = TRUE, nf = 2) {
+
+ normalise.w <- function(X, w) {
+ f2 <- function(v) sqrt(sum(v * v * w)/sum(w))
+ norm <- apply(X, 2, f2)
+ X <- sweep(X, 2, norm, "/")
+ return(X)
+ }
+
+ if (!inherits(dudiR, "dudi"))
+ stop("Object of class dudi expected")
+ lig1 <- nrow(dudiR$tab)
+
+ if (!inherits(dudiL, "dudi"))
+ stop("Object of class dudi expected")
+ if (!inherits(dudiL, "coa"))
+ stop("dudi.coa expected for table L")
+ lig2 <- nrow(dudiL$tab)
+ col2 <- ncol(dudiL$tab)
+ if (!inherits(dudiQ, "dudi"))
+ stop("Object of class dudi expected")
+ lig3 <- nrow(dudiQ$tab)
+
+ if (lig1 != lig2)
+ stop("Non equal row numbers")
+ if (any((dudiR$lw - dudiL$lw)^2 > 1e-07))
+ stop("Non equal row weights")
+ if (col2 != lig3)
+ stop("Non equal row numbers")
+ if (any((dudiL$cw - dudiQ$lw)^2 > 1e-07))
+ stop("Non equal row weights")
+ tabcoiner <- t(as.matrix(dudiR$tab)) %*% diag(dudiL$lw) %*% (as.matrix(dudiL$tab)) %*% diag(dudiL$cw) %*% (as.matrix(dudiQ$tab))
+ tabcoiner <- data.frame(tabcoiner)
+ names(tabcoiner) <- names(dudiQ$tab)
+ row.names(tabcoiner) <- names(dudiR$tab)
+ if (nf > dudiR$nf)
+ nf <- dudiR$nf
+ if (nf > dudiQ$nf)
+ nf <- dudiQ$nf
+ coi <- as.dudi(tabcoiner, dudiQ$cw, dudiR$cw, scannf = scannf, nf = nf, call = match.call(), type = "rlq")
+ U <- as.matrix(coi$c1) * unlist(coi$cw)
+ U <- data.frame(as.matrix(dudiQ$tab) %*% U)
+ row.names(U) <- row.names(dudiQ$tab)
+ names(U) <- paste("AxcQ", (1:coi$nf), sep = "")
+ coi$lQ <- U
+ U <- normalise.w(U, dudiQ$lw)
+ row.names(U) <- row.names(dudiQ$tab)
+ names(U) <- paste("NorS", (1:coi$nf), sep = "")
+ coi$mQ <- U
+ U <- as.matrix(coi$l1) * unlist(coi$lw)
+ U <- data.frame(as.matrix(dudiR$tab) %*% U)
+ row.names(U) <- row.names(dudiR$tab)
+ names(U) <- paste("AxcR", (1:coi$nf), sep = "")
+ coi$lR <- U
+ U <- normalise.w(U, dudiR$lw)
+ row.names(U) <- row.names(dudiR$tab)
+ names(U) <- paste("NorS", (1:coi$nf), sep = "")
+ coi$mR <- U
+ U <- as.matrix(coi$c1) * unlist(coi$cw)
+ U <- data.frame(t(as.matrix(dudiQ$c1)) %*% U)
+ row.names(U) <- paste("Ax", (1:dudiQ$nf), sep = "")
+ names(U) <- paste("AxcQ", (1:coi$nf), sep = "")
+ coi$aQ <- U
+ U <- as.matrix(coi$l1) * unlist(coi$lw)
+ U <- data.frame(t(as.matrix(dudiR$c1)) %*% U)
+ row.names(U) <- paste("Ax", (1:dudiR$nf), sep = "")
+ names(U) <- paste("AxcR", (1:coi$nf), sep = "")
+ coi$aR <- U
+ ## remove RV which is probably wrong or at least not defined
+ ## RV <- sum(coi$eig)/sqrt(sum(dudiQ$eig^2))/sqrt(sum(dudiR$eig^2))
+ ## coi$RV <- RV
+ return(coi)
+
+}
+
+"summary.rlq" <- function (object, ...) {
+ if (!inherits(object, "rlq"))
+ stop("to be used with 'rlq' object")
+
+ thetitle <- "RLQ analysis"
+ cat(thetitle)
+ cat("\n\n")
+ NextMethod()
+
+ appel <- as.list(object$call)
+ dudiL <- eval.parent(appel$dudiL)
+ dudiR <- eval.parent(appel$dudiR)
+ dudiQ <- eval.parent(appel$dudiQ)
+ norm.w <- function(X, w) {
+ f2 <- function(v) sqrt(sum(v * v * w)/sum(w))
+ norm <- apply(X, 2, f2)
+ return(norm)
+ }
+ util <- function(n) {
+ return(sapply(1:n, function(x) paste(1:x, collapse = "")))
+ }
+ eig <- object$eig[1:object$nf]
+ covar <- sqrt(eig)
+ sdR <- norm.w(object$lR, dudiR$lw)
+ sdQ <- norm.w(object$lQ, dudiQ$lw)
+ corr <- covar/sdR/sdQ
+ U <- cbind.data.frame(eig, covar, sdR, sdQ, corr)
+ row.names(U) <- as.character(1:object$nf)
+ res <- list(EigDec = U)
+ cat("\nEigenvalues decomposition:\n")
+ print(U)
+ cat(paste("\nInertia & coinertia R (", deparse(appel$dudiR),"):\n", sep=""))
+ inertia <- cumsum(sdR^2)
+ max <- cumsum(dudiR$eig[1:object$nf])
+ ratio <- inertia/max
+ U <- cbind.data.frame(inertia, max, ratio)
+ row.names(U) <- util(object$nf)
+ res$InerR <- U
+ print(U)
+ cat(paste("\nInertia & coinertia Q (", deparse(appel$dudiR),"):\n", sep=""))
+ inertia <- cumsum(sdQ^2)
+ max <- cumsum(dudiQ$eig[1:object$nf])
+ ratio <- inertia/max
+ U <- cbind.data.frame(inertia, max, ratio)
+ row.names(U) <- util(object$nf)
+ res$InerQ <- U
+ print(U)
+ cat(paste("\nCorrelation L (", deparse(appel$dudiL),"):\n", sep=""))
+ max <- sqrt(dudiL$eig[1:object$nf])
+ ratio <- corr/max
+ U <- cbind.data.frame(corr, max, ratio)
+ row.names(U) <- 1:object$nf
+ res$CorL <- U
+ print(U)
+}
+
diff --git a/R/rtest.R b/R/rtest.R
new file mode 100644
index 0000000..ef5e42a
--- /dev/null
+++ b/R/rtest.R
@@ -0,0 +1,3 @@
+"rtest" <- function (xtest, ...) {
+ UseMethod("rtest")
+}
diff --git a/R/rtest.between.R b/R/rtest.between.R
new file mode 100644
index 0000000..add35a5
--- /dev/null
+++ b/R/rtest.between.R
@@ -0,0 +1,38 @@
+"rtest.between" <- function (xtest, nrepet = 99, ...) {
+ if (!inherits(xtest, "dudi"))
+ stop("Object of class dudi expected")
+ if (!inherits(xtest, "between"))
+ stop("Type 'between' expected")
+ appel <- as.list(xtest$call)
+ dudi1 <- eval.parent(appel[[2]]) ## could work with bca (appel$x) or between (appel$dudi)
+ fac <- eval.parent(appel$fac)
+ X <- dudi1$tab
+ X.lw <- dudi1$lw
+ X.lw <- X.lw/sum(X.lw)
+ if ((!(identical(all.equal(X.lw,rep(1/nrow(X), nrow(X))),TRUE)))) {
+ if(as.list(dudi1$call)[[1]] == "dudi.acm" )
+ stop ("Not implemented for non-uniform weights in the case of dudi.acm")
+ else if(as.list(dudi1$call)[[1]] == "dudi.hillsmith" )
+ stop ("Not implemented for non-uniform weights in the case of dudi.hillsmith")
+ else if(as.list(dudi1$call)[[1]] == "dudi.mix" )
+ stop ("Not implemented for non-uniform weights in the case of dudi.mix")
+ }
+
+ X.cw <- sqrt(dudi1$cw)
+ X <- t(t(X) * X.cw)
+ inertot <- sum(dudi1$eig)
+ inerinter <- function(perm = TRUE) {
+ if (perm)
+ sel <- sample(nrow(X))
+ else sel <- 1:nrow(X)
+ Y <- X[sel, ]
+ Y.lw <- X.lw[sel]
+ cla.w <- tapply(Y.lw, fac, sum)
+ Y <- apply(Y * Y.lw, 2, function(x) tapply(x, fac, sum)/cla.w)
+ inerb <- sum(apply(Y, 2, function(x) sum(x * x * cla.w)))
+ return(inerb/inertot)
+ }
+ obs <- inerinter(FALSE)
+ sim <- unlist(lapply(1:nrepet, inerinter))
+ return(as.randtest(sim, obs, call = match.call(), ...))
+}
diff --git a/R/rtest.discrimin.R b/R/rtest.discrimin.R
new file mode 100644
index 0000000..b01aae8
--- /dev/null
+++ b/R/rtest.discrimin.R
@@ -0,0 +1,47 @@
+ "rtest.discrimin" <- function (xtest, nrepet = 99, ...) {
+ if (!inherits(xtest, "discrimin"))
+ stop("'discrimin' object expected")
+ appel <- as.list(xtest$call)
+ dudi <- eval.parent(appel$dudi)
+ fac <- eval.parent(appel$fac)
+ lig <- nrow(dudi$tab)
+ if (length(fac) != lig)
+ stop("Non convenient dimension")
+ rank <- dudi$rank
+ dudi <- redo.dudi(dudi, rank)
+ dudi.lw <- dudi$lw
+
+ dudi <- dudi$l1
+ if ((!(identical(all.equal(dudi.lw,rep(1/nrow(dudi), nrow(dudi))),TRUE)))) {
+ if(as.list(eval.parent(appel$dudi)$call)[[1]] == "dudi.acm" )
+ stop ("Not implemented for non-uniform weights in the case of dudi.acm")
+ else if(as.list(eval.parent(appel$dudi)$call)[[1]] == "dudi.hillsmith" )
+ stop ("Not implemented for non-uniform weights in the case of dudi.hillsmith")
+ else if(as.list(eval.parent(appel$dudi)$call)[[1]] == "dudi.mix" )
+ stop ("Not implemented for non-uniform weights in the case of dudi.mix")
+ }
+
+ between.var <- function(x, w, group, group.w) {
+ z <- x * w
+ z <- tapply(z, group, sum)/group.w
+ return(sum(z * z * group.w))
+ }
+ inertia.ratio <- function(perm = TRUE) {
+ if (perm) {
+ sigma <- sample(lig)
+ Y <- dudi[sigma, ]
+ Y.w <- dudi.lw[sigma]
+ }
+ else {
+ Y <- dudi
+ Y.w <- dudi.lw
+ }
+ cla.w <- tapply(Y.w, fac, sum)
+ ww <- apply(Y, 2, between.var, w = Y.w, group = fac,
+ group.w = cla.w)
+ return(sum(ww)/rank)
+ }
+ obs <- inertia.ratio(perm = FALSE)
+ sim <- unlist(lapply(1:nrepet, inertia.ratio))
+ return(as.randtest(sim, obs, call = match.call(), ...))
+}
diff --git a/R/s.arrow.R b/R/s.arrow.R
new file mode 100644
index 0000000..9bb0b3e
--- /dev/null
+++ b/R/s.arrow.R
@@ -0,0 +1,45 @@
+"s.arrow" <- function (dfxy, xax = 1, yax = 2, label = row.names(dfxy), clabel = 1,
+ pch = 20, cpoint = 0, boxes = TRUE, edge = TRUE, origin = c(0, 0), xlim = NULL,
+ ylim = NULL, grid = TRUE, addaxes = TRUE, cgrid = 1, sub = "",
+ csub = 1.25, possub = "bottomleft", pixmap = NULL, contour = NULL,
+ area = NULL, add.plot = FALSE)
+{
+ arrow1 <- function(x0, y0, x1, y1, len = 0.1, ang = 15, lty = 1,
+ edge) {
+ d0 <- sqrt((x0 - x1)^2 + (y0 - y1)^2)
+ if (d0 < 1e-07)
+ return(invisible())
+ segments(x0, y0, x1, y1, lty = lty)
+ h <- strheight("A", cex = par("cex"))
+ if (d0 > 2 * h) {
+ x0 <- x1 - h * (x1 - x0)/d0
+ y0 <- y1 - h * (y1 - y0)/d0
+ if (edge)
+ arrows(x0, y0, x1, y1, angle = ang, length = len,
+ lty = 1)
+ }
+ }
+ dfxy <- data.frame(dfxy)
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ coo <- scatterutil.base(dfxy = dfxy, xax = xax, yax = yax,
+ xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes,
+ cgrid = cgrid, include.origin = TRUE, origin = origin,
+ sub = sub, csub = csub, possub = possub, pixmap = pixmap,
+ contour = contour, area = area, add.plot = add.plot)
+ if (grid & !add.plot)
+ scatterutil.grid(cgrid)
+ if (addaxes & !add.plot)
+ abline(h = 0, v = 0, lty = 1)
+ if (cpoint > 0)
+ points(coo$x, coo$y, pch = pch, cex = par("cex") * cpoint)
+ for (i in 1:(length(coo$x))) arrow1(origin[1], origin[2],
+ coo$x[i], coo$y[i], edge = edge)
+ if (clabel > 0)
+ scatterutil.eti.circ(coo$x, coo$y, label, clabel, origin, boxes)
+ if (csub > 0)
+ scatterutil.sub(sub, csub, possub)
+ box()
+ invisible(match.call())
+}
diff --git a/R/s.chull.R b/R/s.chull.R
new file mode 100644
index 0000000..bb5287a
--- /dev/null
+++ b/R/s.chull.R
@@ -0,0 +1,28 @@
+"s.chull" <- function (dfxy, fac, xax = 1, yax = 2, optchull = c(0.25, 0.5,
+ 0.75, 1), label = levels(fac), clabel = 1, cpoint = 0, col = rep(1, length(levels(fac))),
+ xlim = NULL, ylim = NULL, grid = TRUE, addaxes = TRUE, origin = c(0, 0),
+ include.origin = TRUE, sub = "", csub = 1, possub = "bottomleft",
+ cgrid = 1, pixmap = NULL, contour = NULL, area = NULL, add.plot = FALSE)
+{
+ dfxy <- data.frame(dfxy)
+ opar <- par(mar = par("mar"))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ on.exit(par(opar))
+ coo <- scatterutil.base(dfxy = dfxy, xax = xax, yax = yax,
+ xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes,
+ cgrid = cgrid, include.origin = include.origin, origin = origin,
+ sub = sub, csub = csub, possub = possub, pixmap = pixmap,
+ contour = contour, area = area, add.plot = add.plot)
+ scatterutil.chull(coo$x, coo$y, fac, optchull = optchull, col=col)
+ if (cpoint > 0)
+ for (i in 1:nlevels(fac)) {
+ points(coo$x[fac == levels(fac)[i]], coo$y[fac == levels(fac)[i]], pch = 20, cex = par("cex") * cpoint, col=col[i])
+ }
+ if (clabel > 0) {
+ coox <- tapply(coo$x, fac, mean)
+ cooy <- tapply(coo$y, fac, mean)
+ scatterutil.eti(coox, cooy, label, clabel, coul = col)
+ }
+ box()
+ invisible(match.call())
+}
diff --git a/R/s.class.R b/R/s.class.R
new file mode 100644
index 0000000..0e419d0
--- /dev/null
+++ b/R/s.class.R
@@ -0,0 +1,50 @@
+"s.class" <- function (dfxy, fac, wt = rep(1, length(fac)), xax = 1, yax = 2,
+ cstar = 1, cellipse = 1.5, axesell = TRUE, label = levels(fac),
+ clabel = 1, cpoint = 1, pch = 20, col = rep(1, length(levels(fac))), xlim = NULL, ylim = NULL,
+ grid = TRUE, addaxes = TRUE, origin = c(0, 0), include.origin = TRUE,
+ sub = "", csub = 1, possub = "bottomleft", cgrid = 1, pixmap = NULL,
+ contour = NULL, area = NULL, add.plot = FALSE)
+{
+
+ opar <- par(mar = par("mar"))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ on.exit(par(opar))
+ dfxy <- data.frame(dfxy)
+ if (!is.data.frame(dfxy))
+ stop("Non convenient selection for dfxy")
+ if (any(is.na(dfxy)))
+ stop("NA non implemented")
+ if (!is.factor(fac))
+ stop("factor expected for fac")
+ dfdistri <- fac2disj(fac) * wt
+ coul <- col
+ w1 <- unlist(lapply(dfdistri, sum))
+ dfdistri <- t(t(dfdistri)/w1)
+ coox <- as.matrix(t(dfdistri)) %*% dfxy[, xax]
+ cooy <- as.matrix(t(dfdistri)) %*% dfxy[, yax]
+ if (nrow(dfxy) != nrow(dfdistri))
+ stop(paste("Non equal row numbers", nrow(dfxy), nrow(dfdistri)))
+ coo <- scatterutil.base(dfxy = dfxy, xax = xax, yax = yax,
+ xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes,
+ cgrid = cgrid, include.origin = include.origin, origin = origin,
+ sub = sub, csub = csub, possub = possub, pixmap = pixmap,
+ contour = contour, area = area, add.plot = add.plot)
+ if (cpoint > 0)
+ for (i in 1:ncol(dfdistri)) {
+ pch <- rep(pch, length = nrow(dfxy))
+ points(coo$x[dfdistri[,i] > 0], coo$y[dfdistri[,i] > 0], pch = pch[dfdistri[,i] > 0], cex = par("cex") * cpoint, col=coul[i])
+ }
+ if (cstar > 0)
+ for (i in 1:ncol(dfdistri)) {
+ scatterutil.star(coo$x, coo$y, dfdistri[, i], cstar = cstar, coul[i])
+ }
+ if (cellipse > 0)
+ for (i in 1:ncol(dfdistri)) {
+ scatterutil.ellipse(coo$x, coo$y, dfdistri[, i],
+ cellipse = cellipse, axesell = axesell, coul[i])
+ }
+ if (clabel > 0)
+ scatterutil.eti(coox, cooy, label, clabel, coul = col)
+ box()
+ invisible(match.call())
+}
diff --git a/R/s.corcircle.R b/R/s.corcircle.R
new file mode 100644
index 0000000..df45298
--- /dev/null
+++ b/R/s.corcircle.R
@@ -0,0 +1,91 @@
+"s.corcircle" <- function (dfxy, xax = 1, yax = 2, label = row.names(df), clabel = 1,
+ grid = TRUE, sub = "", csub = 1, possub = "bottomleft", cgrid = 0,
+ fullcircle = TRUE, box = FALSE, add.plot = FALSE)
+{
+ arrow1 <- function(x0, y0, x1, y1, len = 0.1, ang = 15, lty = 1,
+ edge) {
+ d0 <- sqrt((x0 - x1)^2 + (y0 - y1)^2)
+ if (d0 < 1e-07)
+ return(invisible())
+ segments(x0, y0, x1, y1, lty = lty)
+ h <- strheight("A", cex = par("cex"))
+ if (d0 > 2 * h) {
+ x0 <- x1 - h * (x1 - x0)/d0
+ y0 <- y1 - h * (y1 - y0)/d0
+ if (edge)
+ arrows(x0, y0, x1, y1, angle = ang, length = len,
+ lty = 1)
+ }
+ }
+ scatterutil.circ <- function(cgrid, h, grid) {
+ cc <- seq(from = -1, to = 1, by = h)
+ col <- "lightgray"
+ if(grid){
+ for (i in 1:(length(cc))) {
+ x <- cc[i]
+ a1 <- sqrt(1 - x * x)
+ a2 <- (-a1)
+ segments(x, a1, x, a2, col = col)
+ segments(a1, x, a2, x, col = col)
+ }
+ }
+ symbols(0, 0, circles = 1, inches = FALSE, add = TRUE)
+ segments(-1, 0, 1, 0)
+ segments(0, -1, 0, 1)
+ if (cgrid <= 0 | !grid)
+ return(invisible())
+ cha <- paste("d = ", h, sep = "")
+ cex0 <- par("cex") * cgrid
+ xh <- strwidth(cha, cex = cex0)
+ yh <- strheight(cha, cex = cex0) + strheight(" ", cex = cex0)/2
+ x0 <- strwidth(" ", cex = cex0)
+ y0 <- strheight(" ", cex = cex0)/2
+ x1 <- par("usr")[2]
+ y1 <- par("usr")[4]
+ rect(x1 - x0, y1 - y0, x1 - xh - x0, y1 - yh - y0, col = "white",
+ border = 0)
+ text(x1 - xh/2 - x0/2, y1 - yh/2 - y0/2, cha, cex = cex0)
+ }
+ origin <-c(0,0)
+ df <- data.frame(dfxy)
+ if (!is.data.frame(df))
+ stop("Non convenient selection for df")
+ if ((xax < 1) || (xax > ncol(df)))
+ stop("Non convenient selection for xax")
+ if ((yax < 1) || (yax > ncol(df)))
+ stop("Non convenient selection for yax")
+ x <- df[, xax]
+ y <- df[, yax]
+ if (add.plot) {
+ for (i in 1:length(x)) arrow1(0, 0, x[i], y[i], len = 0.1,
+ ang = 15, edge = TRUE)
+ if (clabel > 0)
+ scatterutil.eti.circ(x, y, label, clabel)
+ return(invisible())
+ }
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ x1 <- x
+ y1 <- y
+ x1 <- c(x1, -0.01, +0.01)
+ y1 <- c(y1, -0.01, +0.01)
+ if (fullcircle) {
+ x1 <- c(x1, -1, 1)
+ y1 <- c(y1, -1, 1)
+ }
+ x1 <- c(x1 - diff(range(x1)/20), x1 + diff(range(x1))/20)
+ y1 <- c(y1 - diff(range(y1)/20), y1 + diff(range(y1))/20)
+ plot(x1, y1, type = "n", ylab = "", asp = 1, xaxt = "n",
+ yaxt = "n", frame.plot = FALSE)
+ scatterutil.circ(cgrid = cgrid, h = 0.2,grid=grid)
+ for (i in 1:length(x)) arrow1(0, 0, x[i], y[i], len = 0.1,
+ ang = 15, edge = TRUE)
+ if (clabel > 0)
+ scatterutil.eti.circ(x, y, label, clabel,origin)
+ if (csub > 0)
+ scatterutil.sub(sub, csub, possub)
+ if (box)
+ box()
+ invisible(match.call())
+}
diff --git a/R/s.distri.R b/R/s.distri.R
new file mode 100644
index 0000000..908930f
--- /dev/null
+++ b/R/s.distri.R
@@ -0,0 +1,48 @@
+"s.distri" <- function (dfxy, dfdistri, xax = 1, yax = 2, cstar = 1, cellipse = 1.5,
+ axesell = TRUE, label = names(dfdistri), clabel = 0, cpoint = 1,
+ pch = 20, xlim = NULL, ylim = NULL, grid = TRUE, addaxes = TRUE,
+ origin = c(0, 0), include.origin = TRUE, sub = "", csub = 1,
+ possub = "bottomleft", cgrid = 1, pixmap = NULL, contour = NULL,
+ area = NULL, add.plot = FALSE)
+{
+ opar <- par(mar = par("mar"))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ on.exit(par(opar))
+ dfxy <- data.frame(dfxy)
+ dfdistri <- data.frame(dfdistri)
+ if (!is.data.frame(dfxy))
+ stop("Non convenient selection for dfxy")
+ if (!is.data.frame(dfdistri))
+ stop("Non convenient selection for dfdistri")
+ if (any(dfdistri < 0))
+ stop("Non convenient selection for dfdistri")
+ if (nrow(dfxy) != nrow(dfdistri))
+ stop("Non equal row numbers")
+ if (any(is.na(dfxy)))
+ stop("NA non implemented")
+ w1 <- unlist(lapply(dfdistri, sum))
+ label <- label
+ dfdistri <- t(t(dfdistri)/w1)
+ coox <- as.matrix(t(dfdistri)) %*% as.matrix(dfxy[, xax])
+ cooy <- as.matrix(t(dfdistri)) %*% as.matrix(dfxy[, yax])
+ coo <- scatterutil.base(dfxy = dfxy, xax = xax, yax = yax,
+ xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes,
+ cgrid = cgrid, include.origin = include.origin, origin = origin,
+ sub = sub, csub = csub, possub = possub, pixmap = pixmap,
+ contour = contour, area = area, add.plot = add.plot)
+ if (cpoint > 0)
+ points(coo$x, coo$y, pch = pch, cex = par("cex") * cpoint)
+ if (cstar > 0)
+ for (i in 1:ncol(dfdistri)) {
+ scatterutil.star(coo$x, coo$y, dfdistri[, i], cstar = cstar)
+ }
+ if (cellipse > 0)
+ for (i in 1:ncol(dfdistri)) {
+ scatterutil.ellipse(coo$x, coo$y, dfdistri[, i],
+ cellipse = cellipse, axesell = axesell)
+ }
+ if (clabel > 0)
+ scatterutil.eti(unlist(coox), unlist(cooy), label, clabel)
+ box()
+ invisible(match.call())
+}
diff --git a/R/s.hist.R b/R/s.hist.R
new file mode 100644
index 0000000..5d1a590
--- /dev/null
+++ b/R/s.hist.R
@@ -0,0 +1,89 @@
+"s.hist" <- function(dfxy, xax = 1, yax = 2, cgrid=1, cbreaks=2, adjust=1,...) {
+ def.par <- par(no.readonly = TRUE)# save default, for resetting...
+ layout(matrix(c(2,4,1,3),2,2,byrow=TRUE), c(3,1), c(1,3), TRUE)
+ ## pour avoir des quadrillages compatibles
+ if (cbreaks>=1) cbreaks <- floor(cbreaks)
+ else if (cbreaks<0.1) cbreaks <- 2
+ else cbreaks <- 1/floor(1/cbreaks)
+ ## tracé du nuage
+ s.label(dfxy,xax,yax,cgrid=cgrid,...)
+ par(mar=c(0.1,0.1,0.1,0.1))
+ ## quadrillage du plan
+ col <- "lightgray"
+ lty <- 1
+ xmin <- par("xaxp")[1]
+ xmax <- par("xaxp")[2]
+ xampli <- par("xaxp")[3]
+ ax <- (xmax-xmin)/xampli/cbreaks
+
+ ymin <- par("yaxp")[1]
+ ymax <- par("yaxp")[2]
+ yampli <- par("yaxp")[3]
+ ay <- (ymax-ymin)/yampli/cbreaks
+ a <- min(ax, ay)
+ while ((xmin-a)>par("usr")[1]) xmin<-xmin-a
+ while ((xmax+a)<par("usr")[2]) xmax<-xmax+a
+ while ((ymin-a)>par("usr")[3]) ymin<-ymin-a
+ while ((ymax+a)<par("usr")[4]) ymax<-ymax+a
+ v0 <- seq(xmin, xmax, by = a)
+ h0 <- seq(ymin, ymax, by = a)
+ if (par("usr")[1] < xmin) v0 <- c(par("usr")[1],v0)
+ if (par("usr")[2] > xmax) v0 <- c(v0,par("usr")[2])
+ if (par("usr")[3] < ymin) h0 <- c(par("usr")[3],h0)
+ if (par("usr")[4] > ymax) h0 <- c(h0,par("usr")[4])
+ abline(v = v0[v0!=0], col = col, lty = lty)
+ abline(h = h0[h0!=0], col = col, lty = lty)
+ if (cgrid > 0) {
+ a1 = round(a, digits = 3)
+ cha <- paste(" d = ", a1, " ", sep = "")
+ cex0 <- par("cex") * cgrid
+ xh <- strwidth(cha, cex = cex0)
+ yh <- strheight(cha, cex = cex0) * 5/3
+ x1 <- par("usr")[2]
+ y1 <- par("usr")[4]
+ rect(x1 - xh, y1 - yh, x1 + xh, y1 + yh, col = "white", border = 0)
+ text(x1 - xh/2, y1 - yh/2, cha, cex = cex0)
+ }
+ para<-par("usr")
+ abline(h = 0, v = 0, lty = 1)
+ box()
+
+ ## calcul des histogrammes
+ nlig <- nrow(dfxy)
+ w <- dfxy[,xax]
+ xhist <- hist(w, breaks=v0,plot=FALSE)
+ xdens <- density(w,adjust=adjust)
+ xdensx <- xdens[[1]]
+ xdensy <- xdens[[2]]*nlig*a
+ w <- dfxy[,yax]
+ yhist <- hist(w, breaks=h0,plot=FALSE)
+ ydens <- density(w,adjust=adjust)
+ ydensx <- ydens[[2]]*nlig*a
+ ydensy <- ydens[[1]]
+ top <- max(c(xhist$counts, yhist$counts))
+ leg <- pretty(0:top)
+ leg <- leg[-c(1,length(leg))]
+ ## l'histogramme des x
+ plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n", yaxt = "n", xaxs = "i", yaxs = "i", frame.plot = TRUE)
+ par(usr=c(para[1:2],c(0,top)))
+ abline(h=leg,lty=2)
+ rect(xhist$mids-a/2,rep(0,length(xhist$mids)),xhist$mids+a/2,xhist$counts,col=grey(0.8))
+ lines(xdensx,xdensy)
+ ## l'histogramme des y
+ plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n", yaxt = "n", xaxs = "i", yaxs = "i", frame.plot = TRUE)
+ par(usr=c(c(0,top),para[3:4]))
+ abline(v=leg,lty=2)
+ rect(rep(0,length(yhist$mids)),yhist$mids-a/2,yhist$counts,yhist$mids+a/2,col=grey(0.8))
+ lines(ydensx,ydensy)
+ ## la légende dans le petit carré
+ plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n", yaxt = "n", xaxs = "i", yaxs = "i", frame.plot = FALSE)
+ par(usr=c(c(0,top),c(0,top)))
+ print(leg)
+ symbols(rep(0,length(leg)),rep(0,length(leg)),circles = leg,lty=2, inches = FALSE, add=TRUE)
+ scatterutil.eti (sqrt(0.5)*leg, sqrt(0.5)*leg, as.character(leg), clabel=1)
+ ## restauration des paramètres
+ par(def.par)#- reset to default
+ invisible(match.call())
+}
+
+
diff --git a/R/s.image.R b/R/s.image.R
new file mode 100644
index 0000000..9d3612a
--- /dev/null
+++ b/R/s.image.R
@@ -0,0 +1,51 @@
+s.image <- function(dfxy, z, xax=1, yax=2, span=0.5,
+ xlim = NULL, ylim = NULL,
+ kgrid=2, scale=TRUE,
+ grid = FALSE, addaxes = FALSE, cgrid = 0, include.origin = FALSE,
+ origin = c(0, 0), sub = "", csub = 1, possub = "topleft",
+ neig = NULL, cneig = 1, image.plot=TRUE, contour.plot=TRUE,
+ pixmap = NULL, contour = NULL, area = NULL, add.plot = FALSE)
+{
+ dfxy <- data.frame(dfxy)
+ if(scale)
+ z <- scalewt(z)
+ if(length(z) != nrow(dfxy))
+ stop(paste("Non equal row numbers", nrow(dfxy), length(z)))
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ xy <- dfxy[,c(xax,yax)]
+ names(xy) <- c("x","y")
+ scatterutil.base(dfxy = xy, xax = xax, yax = yax,
+ xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes,
+ cgrid = cgrid, include.origin = include.origin, origin = origin,
+ sub = sub, csub = csub, possub = possub, pixmap = pixmap,
+ contour = contour, area = area, add.plot = add.plot)
+ w <- cbind.data.frame(xy,z)
+ ngrid <- floor(kgrid*sqrt(nrow(w)))
+ if (ngrid<5)
+ ngrid<-5
+ lo <- loess(z~x+y,data=w,span=span)
+ xg <- seq(from=par("usr")[1],to=par("usr")[2],le=ngrid)
+ yg <- seq(from=par("usr")[3],to=par("usr")[4],le=ngrid)
+ gr <- expand.grid(xg, yg)
+ names(gr) <- names(xy)
+ mod <- predict(lo,newdata=gr)
+ if(is.null(area)) {
+ polyin <- w[chull(xy),]
+ grin <- splancs::inpip(gr,polyin)
+ mod[-grin] <- NA
+ } else {
+ grin <- rep(0,nrow(gr))
+ larea <- split(area[,2:3],area[,1])
+ lapply(larea,function(x) grin <<- grin+splancs::inout(gr,x))
+ mod[!grin] <- NA
+ }
+
+ mod <- matrix(mod,ngrid,ngrid)
+ if(image.plot)
+ image(xg,yg,mod,add=TRUE, col=gray((32:0)/32))
+ if(contour.plot)
+ contour(xg,yg,mod,add=TRUE,labcex=1,lwd=2,nlevels=5,levels=pretty(z,7)[-c(1,7)],col="red")
+ invisible(match.call())
+}
diff --git a/R/s.kde2d.R b/R/s.kde2d.R
new file mode 100644
index 0000000..2c8ffa1
--- /dev/null
+++ b/R/s.kde2d.R
@@ -0,0 +1,52 @@
+"s.kde2d" <- function(dfxy, xax = 1, yax = 2,
+ pch = 20, cpoint = 1, neig = NULL, cneig = 2, xlim = NULL,
+ ylim = NULL, grid = TRUE, addaxes = TRUE,
+ cgrid = 1, include.origin = TRUE, origin = c(0, 0), sub = "",
+ csub = 1.25, possub = "bottomleft", pixmap = NULL, contour = NULL,
+ area = NULL, add.plot = FALSE) {
+
+ # kde2d is a function of the library MASS
+ # Venables, W. N. and Ripley, B. D. (2002) _Modern Applied
+ # Statistics with S._ Fourth edition. Springer.
+ # "kde2d" <- function (x, y, h, n = 25, lims = c(range(x), range(y))) {
+ # nx <- length(x)
+ # if (length(y) != nx)
+ # stop("Data vectors must be the same length")
+ # gx <- seq(lims[1], lims[2], length = n)
+ # gy <- seq(lims[3], lims[4], length = n)
+ # if (missing(h))
+ # h <- c(bandwidth.nrd(x), bandwidth.nrd(y))
+ # h <- h/4
+ # ax <- outer(gx, x, "-")/h[1]
+ # ay <- outer(gy, y, "-")/h[2]
+ # z <- matrix(dnorm(ax), n, nx) %*% t(matrix(dnorm(ay), n,
+ # nx))/(nx * h[1] * h[2])
+ # return(list(x = gx, y = gy, z = z))
+ # }
+ # "bandwidth.nrd" <- function(x) {
+ # r <- quantile(x, c(0.25, 0.75))
+ # h <- (r[2] - r[1])/1.34 4 * 1.06 * min(sqrt(var(x)), h) * length(x)^(-1/5)
+ # }
+
+ par(mar=c(0.1,0.1,0.1,0.1))
+ s.label(dfxy, xax = xax, yax = yax, clabel = 0,
+ pch = pch, cpoint = cpoint, neig = neig,
+ cneig = cneig, xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes,
+ cgrid = cgrid, include.origin = include.origin, origin = origin,
+ sub = sub, csub = csub, possub = possub, pixmap = pixmap, contour = contour,
+ area = area, add.plot = add.plot)
+
+ x <- as.numeric(dfxy[,xax])
+ y <- as.numeric(dfxy[,yax])
+ xykde = MASS::kde2d(x, y, lims=par("usr"))
+ zlim = range(xykde$z, finite = TRUE)
+ lev=seq(zlim[1],zlim[2],le=8)
+ lev=lev[2:7]
+ # col0 = gray(seq(0,.9,len=6))
+ # col0 = heat.colors(6)
+ # col0 = rainbow(6)
+ col0="blue"
+ contour(xykde,add=TRUE,lwd=2,col=col0,levels=lev,drawlabels=FALSE)
+ invisible(match.call())
+ }
+
diff --git a/R/s.label.R b/R/s.label.R
new file mode 100644
index 0000000..a425695
--- /dev/null
+++ b/R/s.label.R
@@ -0,0 +1,39 @@
+"s.label" <- function (dfxy, xax = 1, yax = 2, label = row.names(dfxy), clabel = 1,
+ pch = 20, cpoint = if (clabel == 0) 1 else 0, boxes = TRUE, neig = NULL,
+ cneig = 2, xlim = NULL, ylim = NULL, grid = TRUE, addaxes = TRUE,
+ cgrid = 1, include.origin = TRUE, origin = c(0, 0), sub = "",
+ csub = 1.25, possub = "bottomleft", pixmap = NULL, contour = NULL,
+ area = NULL, add.plot = FALSE)
+{
+ dfxy <- data.frame(dfxy)
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ coo <- scatterutil.base(dfxy = dfxy, xax = xax, yax = yax,
+ xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes,
+ cgrid = cgrid, include.origin = include.origin, origin = origin,
+ sub = sub, csub = csub, possub = possub, pixmap = pixmap,
+ contour = contour, area = area, add.plot = add.plot)
+ if (!is.null(neig)) {
+ if (is.null(class(neig)))
+ neig <- NULL
+ if (class(neig) != "neig")
+ neig <- NULL
+ deg <- attr(neig, "degrees")
+ if ((length(deg)) != (length(coo$x)))
+ neig <- NULL
+ }
+ if (!is.null(neig)) {
+ fun <- function(x, coo) {
+ segments(coo$x[x[1]], coo$y[x[1]], coo$x[x[2]], coo$y[x[2]],
+ lwd = par("lwd") * cneig)
+ }
+ apply(unclass(neig), 1, fun, coo = coo)
+ }
+ if (clabel > 0)
+ scatterutil.eti(coo$x, coo$y, label, clabel, boxes)
+ if (cpoint > 0 & clabel < 1e-6)
+ points(coo$x, coo$y, pch = pch, cex = par("cex") * cpoint)
+ box()
+ invisible(match.call())
+}
diff --git a/R/s.logo.R b/R/s.logo.R
new file mode 100644
index 0000000..e9f5b7f
--- /dev/null
+++ b/R/s.logo.R
@@ -0,0 +1,83 @@
+"s.logo" <- function (dfxy, listlogo, klogo=NULL,
+ clogo=1, rectlogo=TRUE,
+ xax = 1, yax = 2, neig = NULL,
+ cneig = 1, xlim = NULL, ylim = NULL, grid = TRUE, addaxes = TRUE,
+ cgrid = 1, include.origin = TRUE, origin = c(0, 0), sub = "",
+ csub = 1.25, possub = "bottomleft", pixmap = NULL, contour = NULL,
+ area = NULL, add.plot = FALSE)
+{
+ dfxy <- data.frame(dfxy)
+ if (!is.list(listlogo)) stop (paste(deparse(substitute(listlogo)),' is not a list'))
+ nlogo <- length(listlogo)
+ if(is.null(klogo)) klogo <- 1:nlogo
+ npoi <- nrow(dfxy)
+ classico <- unlist(lapply(listlogo, function(x) (charmatch("pixmap",class(x))==1)))
+ if (is.null(classico))
+ stop(paste(deparse(substitute(listlogo)),'is not a list of pixmap objects'))
+ if (any(is.na(classico)))
+ stop(paste(deparse(substitute(listlogo)),'is not a list of pixmap objects'))
+ if (!all(classico))
+ stop(paste(deparse(substitute(listlogo)),'is not a list of pixmap objects'))
+ klogo <- rep(klogo,length=npoi)
+ if (any(klogo>nlogo)) stop('invalid index')
+ rectlogo=rep(rectlogo,length=npoi)
+ if (!is.logical(rectlogo))
+ stop(paste(deparse(substitute(rectlogo)),'is not logical'))
+ clogo=rep(clogo,length=npoi)
+ if (!is.numeric(clogo))
+ stop(paste(deparse(substitute(clogo)),'is not numeric'))
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ coo <- scatterutil.base(dfxy = dfxy, xax = xax, yax = yax,
+ xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes,
+ cgrid = cgrid, include.origin = include.origin, origin = origin,
+ sub = sub, csub = csub, possub = possub, pixmap = pixmap,
+ contour = contour, area = area, add.plot = add.plot)
+ if (!is.null(neig)) {
+ if (is.null(class(neig)))
+ neig <- NULL
+ if (class(neig) != "neig")
+ neig <- NULL
+ deg <- attr(neig, "degrees")
+ if ((length(deg)) != (length(coo$x)))
+ neig <- NULL
+ }
+ if (!is.null(neig)) {
+ fun <- function(x, coo) {
+ segments(coo$x[x[1]], coo$y[x[1]], coo$x[x[2]], coo$y[x[2]],
+ lwd = par("lwd") * cneig)
+ }
+ apply(unclass(neig), 1, fun, coo = coo)
+ }
+ scatterutil.logo(coo$x, coo$y, listlogo, klogo, clogo, rectlogo)
+ box()
+ invisible(match.call())
+}
+
+"scatterutil.logo" <- function(coox,cooy,lico,kico,cico,rico) {
+ drawlogo <- function (pixmap, x , y, clogo=1, rectangle = TRUE) {
+ w <- par("usr")
+ luser <- w[2]-w[1]
+ lpixe <- 96*(par("pin")[1])/clogo
+ llogo <- attr(pixmap,"size")[2]
+ l <- llogo*luser/lpixe/2
+ huser <- w[4]-w[3]
+ hpixe <- 96*(par("pin")[2])/clogo
+ hlogo <- attr(pixmap,"size")[1]
+ h <- hlogo*huser/hpixe/2
+ pixmap::addlogo(pixmap, c(x-l,x+l),c(y-h,y+h))
+ if (rectangle) rect(x-l,y-h,x+l,y+h)
+ }
+
+ for (k in 1:length(coox)) {
+ x <- coox[k]
+ y <- cooy[k]
+ numico <- kico[k]
+ clogo <- cico[numico]
+ pixmap <- lico[[numico]]
+ rec <- rico[numico]
+ drawlogo(pixmap, x , y, clogo, rec)
+ #text(x,y,as.character(k),cex=3)
+ }
+}
diff --git a/R/s.match.R b/R/s.match.R
new file mode 100644
index 0000000..03cc285
--- /dev/null
+++ b/R/s.match.R
@@ -0,0 +1,57 @@
+"s.match" <- function (df1xy, df2xy, xax = 1, yax = 2, pch = 20, cpoint = 1,
+ label = row.names(df1xy), clabel = 1, edge = TRUE, xlim = NULL,
+ ylim = NULL, grid = TRUE, addaxes = TRUE, cgrid = 1, include.origin = TRUE,
+ origin = c(0, 0), sub = "", csub = 1.25, possub = "bottomleft",
+ pixmap = NULL, contour = NULL, area = NULL, add.plot = FALSE)
+{
+ arrow1 <- function(x0, y0, x1, y1, len = 0.1, ang = 15, lty = 1,
+ edge) {
+ d0 <- sqrt((x0 - x1)^2 + (y0 - y1)^2)
+ if (d0 < 1e-07)
+ return(invisible())
+ segments(x0, y0, x1, y1, lty = lty)
+ h <- strheight("A", cex = par("cex"))
+ if (d0 > 2 * h) {
+ x0 <- x1 - h * (x1 - x0)/d0
+ y0 <- y1 - h * (y1 - y0)/d0
+ if (edge)
+ arrows(x0, y0, x1, y1, angle = ang, length = len,
+ lty = 1)
+ }
+ }
+ df1xy <- data.frame(df1xy)
+ df2xy <- data.frame(df2xy)
+ if (!is.data.frame(df1xy))
+ stop("Non convenient selection for df1xy")
+ if (!is.data.frame(df2xy))
+ stop("Non convenient selection for df2xy")
+ if (any(is.na(df1xy)))
+ stop("NA non implemented")
+ if (any(is.na(df2xy)))
+ stop("NA non implemented")
+ n <- nrow(df1xy)
+ if (n != nrow(df2xy))
+ stop("Non equal row numbers")
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ coo <- scatterutil.base(dfxy = rbind.data.frame(df1xy, df2xy),
+ xax = xax, yax = yax, xlim = xlim, ylim = ylim, grid = grid,
+ addaxes = addaxes, cgrid = cgrid, include.origin = include.origin,
+ origin = origin, sub = sub, csub = csub, possub = possub,
+ pixmap = pixmap, contour = contour, area = area, add.plot = add.plot)
+ for (i in 1:n) {
+ arrow1(coo$x[i], coo$y[i], coo$x[i + n], coo$y[i + n],
+ lty = 1, edge = edge)
+ }
+ if (cpoint > 0)
+ points(coo$x[1:n], coo$y[1:n], pch = pch, cex = par("cex") *
+ cpoint)
+ if (clabel > 0) {
+ a <- (coo$x[1:n] + coo$x[(n + 1):(2 * n)])/2
+ b <- (coo$y[1:n] + coo$y[(n + 1):(2 * n)])/2
+ scatterutil.eti(a, b, label, clabel)
+ }
+ box()
+ invisible(match.call())
+}
diff --git a/R/s.match.class.R b/R/s.match.class.R
new file mode 100644
index 0000000..8b9ab13
--- /dev/null
+++ b/R/s.match.class.R
@@ -0,0 +1,81 @@
+s.match.class <-
+function(df1xy, df2xy, fac, wt = rep(1/nrow(df1xy),nrow(df1xy)), xax = 1, yax = 2,
+ pch1 = 16, pch2 = 15, col1 = rep("lightgrey",nlevels(fac)),
+ col2 = rep("darkgrey",nlevels(fac)), cpoint = 1, label = levels(fac), clabel = 1,
+ cstar = 1, cellipse = 0, axesell = TRUE,xlim = NULL,
+ ylim = NULL, grid = TRUE, addaxes = TRUE, cgrid = 1, include.origin = TRUE,
+ origin = c(0, 0), sub = "", csub = 1.25, possub = "bottomleft",
+ pixmap = NULL, contour = NULL, area = NULL, add.plot = FALSE) {
+
+
+ df1xy <- data.frame(df1xy)
+ df2xy <- data.frame(df2xy)
+ if (!is.data.frame(df1xy))
+ stop("Non convenient selection for df1xy")
+ if (!is.data.frame(df2xy))
+ stop("Non convenient selection for df2xy")
+ if (any(is.na(df1xy)))
+ stop("NA non implemented")
+ if (any(is.na(df2xy)))
+ stop("NA non implemented")
+ n <- nrow(df1xy)
+ if (n != nrow(df2xy))
+ stop("Non equal row numbers")
+ if (!is.factor(fac))
+ stop("factor expected for fac")
+
+ dfdistri <- fac2disj(fac) * wt
+ w1 <- unlist(lapply(dfdistri, sum))
+ dfdistri <- t(t(dfdistri)/w1)
+ coox1 <- as.matrix(t(dfdistri)) %*% df1xy[, xax]
+ cooy1 <- as.matrix(t(dfdistri)) %*% df1xy[, yax]
+ coox2 <- as.matrix(t(dfdistri)) %*% df2xy[, xax]
+ cooy2 <- as.matrix(t(dfdistri)) %*% df2xy[, yax]
+ if (nrow(df1xy) != nrow(dfdistri))
+ stop(paste("Non equal row numbers", nrow(df1xy), nrow(dfdistri)))
+
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ coo <- scatterutil.base(dfxy = rbind.data.frame(df1xy, df2xy),
+ xax = xax, yax = yax, xlim = xlim, ylim = ylim, grid = grid,
+ addaxes = addaxes, cgrid = cgrid, include.origin = include.origin,
+ origin = origin, sub = sub, csub = csub, possub = possub,
+ pixmap = pixmap, contour = contour, area = area, add.plot = add.plot)
+
+ points(cbind(coox1,cooy1),pch=pch1,cex=4 * par("cex") * cpoint,col=col1)
+ points(cbind(coox2,cooy2),pch=pch2,cex=4 * par("cex") * cpoint,col=col2)
+ coo1=list(x=coo$x[1:n],y=coo$y[1:n])
+ coo2=list(x=coo$x[(n+1):(2*n)],y=coo$y[(n+1):(2*n)])
+ if (cpoint > 0){
+ for (i in 1:ncol(dfdistri)) {
+ points(coo1$x[dfdistri[, i] > 0], coo1$y[dfdistri[, i] > 0], pch = pch1, cex = par("cex") * cpoint, col = col1[i])
+ points(coo2$x[dfdistri[, i] > 0], coo2$y[dfdistri[, i] > 0], pch = pch2, cex = par("cex") * cpoint, col = col2[i])
+ }
+ }
+ if (cstar > 0) {
+ for (i in 1:ncol(dfdistri)) {
+ scatterutil.star(coo1$x, coo1$y, dfdistri[, i], cstar = cstar, col1[i])
+ scatterutil.star(coo2$x, coo2$y, dfdistri[, i], cstar = cstar, col2[i])
+ }
+ }
+ if (cellipse > 0) {
+ for (i in 1:ncol(dfdistri)) {
+ scatterutil.ellipse(coo1$x, coo1$y, dfdistri[, i], cellipse = cellipse, axesell = axesell, col1[i])
+ scatterutil.ellipse(coo2$x, coo2$y, dfdistri[, i], cellipse = cellipse, axesell = axesell, col2[i])
+ }
+ }
+
+ for (i in 1:n) {
+ segments(coox1[i], cooy1[i], coox2[i], cooy2[i], lty = 1, lwd=2)
+ }
+ if (clabel > 0) {
+ a <- (coox1 + coox2)/2
+ b <- (cooy1 + cooy2)/2
+ scatterutil.eti(a, b, label, clabel)
+ }
+
+ box()
+ invisible(match.call())
+}
+
diff --git a/R/s.multinom.R b/R/s.multinom.R
new file mode 100644
index 0000000..c7baa26
--- /dev/null
+++ b/R/s.multinom.R
@@ -0,0 +1,112 @@
+ "s.multinom" <- function (dfxy, dfrowprof, translate = FALSE,
+ xax=1, yax=2,
+ labelcat = row.names(dfxy), clabelcat = 1,
+ cpointcat = if (clabelcat == 0) 2 else 0,
+ labelrowprof = row.names(dfrowprof), clabelrowprof = 0.75,
+ cpointrowprof = if (clabelrowprof == 0) 2 else 0,
+ pchrowprof = 20, coulrowprof = grey(0.8),
+ proba = 0.95, n.sample = apply(dfrowprof,1,sum),
+ axesell = TRUE,
+ ...
+ ) {
+
+ if (proba<0.5) proba <- 0.5
+ if (proba>0.999) proba <- 0.999
+ coeff <- sqrt(-2*log(1-proba))
+
+ # les scores forment un data.frame comme dans toute fonction s
+ dfxy <- data.frame(dfxy)
+ dfrowprof <- data.frame(dfrowprof)
+ if (!(inherits(dfxy,"data.frame"))) stop ("data.frame expected for dfxy")
+ if (!(inherits(dfrowprof,"data.frame"))) stop ("data.frame expected for dfrowprof")
+ # les noms des lignes de dfxy sont les noms des colonnes de dfrowprof
+ nrowprof <- nrow(dfrowprof)
+ ncat <- ncol(dfrowprof)
+ if (nrow(dfxy)!= ncat) stop ("non convenient matching : nrow(dfxy)!= ncat")
+ if (all(row.names(dfxy)!= names(dfrowprof))) stop ("non convenient matching : row.names(dfxy)!= names(dfrowprof)")
+
+ n.sample <- rep(n.sample, len = nrowprof)
+ wt <- rep(1, nrowprof)/nrowprof
+ if (sum(n.sample)>0) wt <- n.sample/sum(n.sample)
+
+ coulrowprof <- rep(coulrowprof, len = nrowprof)
+ x <- dfxy[,xax]
+ y <- dfxy[,yax]
+
+ util.ellipse <- function(param, coeftai) {
+ vx <- param[3] ; cxy <- param[4]; vy <- param[5]
+ lig <- 100
+ if (vx < 0) vx <- 0 ; if (vy < 0) vy <- 0
+ if (vx == 0 && vy == 0) return(NULL)
+ covmat <- matrix(c(vx,cxy,cxy,vy),2,2)
+ cov.eig <- eigen(covmat, symmetric =TRUE)
+ l1 = sqrt(max(0,cov.eig$values[1]))
+ l2 = sqrt(max(0,cov.eig$values[2]))
+ c11 <- coeftai * cov.eig$vectors[1,1] * l1
+ c12 <- (-coeftai) * cov.eig$vectors[2,1] * l2
+ c21 <- coeftai * cov.eig$vectors[2,1] * l1
+ c22 <- coeftai * cov.eig$vectors[1,1] * l2
+ angle <- 2 * pi * (1:lig)/lig
+ x <- param[1] + c11 * cos(angle) + c12 * sin(angle)
+ y <- param[2] + c21 * cos(angle) + c22 * sin(angle)
+ res <- list(x = x, y = y, seg1 = c(param[1] + c11, param[2] + c21,
+ param[1] - c11, param[2] - c21), seg2 = c(param[1] + c12, param[2] + c22,
+ param[1] - c12, param[2] - c22))
+ return (res)
+ }
+
+ calcul.rowprof<- function(k) {
+ w1 <- dfrowprof[k,]
+ if (sum(w1)<1e-07) stop (paste("number",k,"profile without data"))
+ w1 <- w1/sum(w1)
+ mx <- sum(w1*x)
+ my <- sum(w1*y)
+ x0 <- x-mx
+ y0 <- y-my
+ vx <- sum(w1*x0*x0)
+ vy <- sum(w1*y0*y0)
+ cxy <- sum(w1*x0*y0)
+ return(c(mx,my,vx,cxy,vy))
+ }
+
+ draw.rowprof<- function(k) {
+ w <- as.numeric(unlist(res[k,]))
+ if (n.sample[k] >0) cell <- coeff/sqrt(n.sample[k]) else cell <- 0
+ ell <- util.ellipse(w, cell)
+ if (!is.null(ell)) {
+ polygon(ell$x, ell$y,border=coulrowprof[k],col=coulrowprof[k], lwd=2)
+ if (axesell) {
+ segments(ell$seg1[1], ell$seg1[2], ell$seg1[3], ell$seg1[4]) #, lty = 2
+ segments(ell$seg2[1], ell$seg2[2], ell$seg2[3], ell$seg2[4]) #, lty = 2
+ }
+ }
+ }
+ opar <- par(mar = par("mar"))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ on.exit(par(opar))
+
+ # calcul des paramètres de position et dispersion
+ res <- t( matrix(unlist(lapply(1:nrowprof,calcul.rowprof)),nrow=5))
+ res <- as.data.frame(res)
+ names(res) <- c("mx","my","vx","cxy","vy")
+ if (translate) {
+ mgene <- c(sum(wt*res$mx),sum(wt*res$my))
+ res[,1:2] <- sweep(res[,1:2],2,mgene,"-")
+ dfxy <- sweep(dfxy[,c(xax,yax)],2,mgene,"-")
+ } else mgene <- c(0,0)
+ row.names(res) <- labelrowprof
+
+ row.names(res) <- labelrowprof
+ s.label(dfxy, 1, 2, clabel = 0, cpoint = cpointcat, ...)
+ s.arrow(dfxy, add.plot = TRUE,origin = -mgene,clabel = clabelcat, label = labelcat)
+ s.chull(dfxy, add.plot = TRUE, fac = factor(rep(1,ncat)), optchull = 1, clabel = 0)
+ for (k in 1:nrowprof) draw.rowprof(k)
+ if (clabelrowprof > 0)
+ scatterutil.eti(as.numeric(res$mx), as.numeric(res$my),labelrowprof, clabelrowprof, coul = coulrowprof)
+ if (clabelrowprof == 0)
+ points(as.numeric(res$mx), as.numeric(res$my), pch=pchrowprof, cex=par("cex")*cpointrowprof)
+ box()
+ res[,1:2] <- sweep(res[,1:2],2,mgene,"+")
+ return(invisible(list(ell=res,tra=mgene,call=match.call())))
+
+}
diff --git a/R/s.traject.R b/R/s.traject.R
new file mode 100644
index 0000000..b6400b1
--- /dev/null
+++ b/R/s.traject.R
@@ -0,0 +1,81 @@
+"s.traject" <- function (dfxy, fac = factor(rep(1, nrow(dfxy))), ord = (1:length(fac)),
+ xax = 1, yax = 2, label = levels(fac), clabel = 1, cpoint = 1,
+ pch = 20, xlim = NULL, ylim = NULL, grid = TRUE, addaxes = TRUE,
+ edge = TRUE, origin = c(0, 0), include.origin = TRUE, sub = "",
+ csub = 1, possub = "bottomleft", cgrid = 1, pixmap = NULL,
+ contour = NULL, area = NULL, add.plot = FALSE)
+{
+ opar <- par(mar = par("mar"))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ on.exit(par(opar))
+ dfxy <- data.frame(dfxy)
+ if (!is.data.frame(dfxy))
+ stop("Non convenient selection for dfxy")
+ if (any(is.na(dfxy)))
+ stop("NA non implemented")
+ if (!is.factor(fac))
+ stop("factor expected for fac")
+ if (length(fac) != nrow(dfxy))
+ stop("Non convenient length (fac)")
+ if (length(ord) != nrow(dfxy))
+ stop("Non convenient length (ord)")
+ coo <- scatterutil.base(dfxy = dfxy, xax = xax, yax = yax,
+ xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes,
+ cgrid = cgrid, include.origin = include.origin, origin = origin,
+ sub = sub, csub = csub, possub = possub, pixmap = pixmap,
+ contour = contour, area = area, add.plot = add.plot)
+ arrow1 <- function(x0, y0, x1, y1, length = 0.15, angle = 15,
+ lty = 1, edge) {
+ d0 <- sqrt((x0 - x1)^2 + (y0 - y1)^2)
+ if (d0 < 1e-07)
+ return(invisible())
+ segments(x0, y0, x1, y1, lty = lty)
+ h <- strheight("A", cex = par("cex"))
+ x0 <- x1 - h * (x1 - x0)/d0
+ y0 <- y1 - h * (y1 - y0)/d0
+ if (edge)
+ arrows(x0, y0, x1, y1, angle = 15, length = 0.1, lty = 1)
+ }
+ trajec <- function(X, cpoint, clabel, label) {
+ if (nrow(X) == 1)
+ return(as.numeric(X[1, ]))
+ x <- X$x
+ y <- X$y
+ ord <- order(X$ord)
+ fac <- as.numeric(X$fac)
+ dmax <- 0
+ xmax <- 0
+ ymax <- 0
+ for (i in 1:(length(x) - 1)) {
+ x0 <- x[ord[i]]
+ y0 <- y[ord[i]]
+ x1 <- x[ord[i + 1]]
+ y1 <- y[ord[i + 1]]
+ arrow1(x0, y0, x1, y1, lty = fac, edge = edge)
+ if (cpoint > 0)
+ points(x0, y0, pch = (14 + fac)%%25, cex = par("cex") *
+ cpoint)
+ d0 <- sqrt((origin[1] - (x0 + x1)/2)^2 + (origin[2] -
+ (y0 + y1)/2)^2)
+ if (d0 > dmax) {
+ xmax <- (x0 + x1)/2
+ ymax <- (y0 + y1)/2
+ dmax <- d0
+ }
+ }
+ if (cpoint > 0)
+ points(x[ord[length(x)]], y[ord[length(x)]], pch = (14 +
+ fac)%%25, cex = par("cex") * cpoint)
+ return(c(xmax, ymax))
+ }
+ provi <- cbind.data.frame(x = coo$x, y = coo$y, fac = fac,
+ ord = ord)
+ provi <- split(provi, fac)
+ w <- lapply(provi, trajec, cpoint = cpoint, clabel = clabel,
+ label = label)
+ w <- t(data.frame(w))
+ if (clabel > 0)
+ scatterutil.eti(w[, 1], w[, 2], label, clabel)
+ box()
+ invisible(match.call())
+}
diff --git a/R/s.value.R b/R/s.value.R
new file mode 100644
index 0000000..01f5c6d
--- /dev/null
+++ b/R/s.value.R
@@ -0,0 +1,89 @@
+"s.value" <- function (dfxy, z, xax = 1, yax = 2, method = c("squaresize",
+ "greylevel"), zmax=NULL, csize = 1, cpoint = 0, pch = 20,
+ clegend = 0.75, neig = NULL, cneig = 1, xlim = NULL, ylim = NULL,
+ grid = TRUE, addaxes = TRUE, cgrid = 0.75, include.origin = TRUE,
+ origin = c(0, 0), sub = "", csub = 1, possub = "topleft",
+ pixmap = NULL, contour = NULL, area = NULL, add.plot = FALSE)
+{
+ # modif samedi, novembre 29, 2003 at 08:43 le coefficient de taille
+ # est rapporté aux bornes utilisateurs pour reproduire les mêmes
+ # valeurs sur plusieurs fenêtres
+ dfxy <- data.frame(dfxy)
+ if (length(z) != nrow(dfxy))
+ stop(paste("Non equal row numbers", nrow(dfxy), length(z)))
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ coo <- scatterutil.base(dfxy = dfxy, xax = xax, yax = yax,
+ xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes,
+ cgrid = cgrid, include.origin = include.origin, origin = origin,
+ sub = sub, csub = csub, possub = possub, pixmap = pixmap,
+ contour = contour, area = area, add.plot = add.plot)
+ if (!is.null(neig)) {
+ if (is.null(class(neig)))
+ neig <- NULL
+ if (class(neig) != "neig")
+ neig <- NULL
+ deg <- attr(neig, "degrees")
+ if ((length(deg)) != (length(coo$x)))
+ neig <- NULL
+ }
+ if (!is.null(neig)) {
+ fun <- function(x, coo) {
+ segments(coo$x[x[1]], coo$y[x[1]], coo$x[x[2]], coo$y[x[2]],
+ lwd = par("lwd") * cneig)
+ }
+ apply(unclass(neig), 1, fun, coo = coo)
+ }
+
+ method <- method [1]
+ if (method == "greylevel") {
+ br0 <- pretty(z, 6)
+ nborn <- length(br0)
+ coeff <- diff(par("usr")[1:2])/15
+ numclass <- cut.default(z, br0, include.lowest = TRUE, labels = FALSE)
+ valgris <- seq(1, 0, le = (nborn - 1))
+ h <- csize * coeff
+ for (i in 1:(nrow(dfxy))) {
+ symbols(coo$x[i], coo$y[i], squares = h, bg = gray(valgris[numclass[i]]),
+ add = TRUE, inches = FALSE)
+ }
+ scatterutil.legend.square.grey(br0, valgris, h/2, clegend)
+ if (cpoint > 0)
+ points(coo$x, coo$y, pch = pch, cex = par("cex") *
+ cpoint)
+ }
+ else if (method == "squaresize") {
+ coeff <- diff(par("usr")[1:2])/15
+ sq <- sqrt(abs(z))
+ if (is.null(zmax)) zmax <- max(abs(z))
+ w1 <- sqrt(zmax)
+ sq <- csize * coeff * sq/w1
+ for (i in 1:(nrow(dfxy))) {
+ if (sign(z[i]) >= 0) {
+ symbols(coo$x[i], coo$y[i], squares = sq[i],
+ bg = "black", fg = "white", add = TRUE, inches = FALSE)
+ }
+ else {
+ symbols(coo$x[i], coo$y[i], squares = sq[i],
+ bg = "white", fg = "black", add = TRUE, inches = FALSE)
+ }
+ }
+ br0 <- pretty(z, 4)
+ l0 <- length(br0)
+ br0 <- (br0[1:(l0 - 1)] + br0[2:l0])/2
+ sq0 <- sqrt(abs(br0))
+ sq0 <- csize * coeff * sq0/w1
+ sig0 <- sign(br0)
+ if (clegend > 0)
+ scatterutil.legend.bw.square(br0, sq0, sig0, clegend)
+ if (cpoint > 0)
+ points(coo$x, coo$y, pch = pch, cex = par("cex") *
+ cpoint)
+ }
+ else if (method == "circlesize") {
+ print("not yet implemented")
+ }
+ if (!add.plot) box()
+ invisible(match.call())
+}
diff --git a/R/scalewt.R b/R/scalewt.R
new file mode 100644
index 0000000..2cd0e55
--- /dev/null
+++ b/R/scalewt.R
@@ -0,0 +1,173 @@
+varwt <- function(x, wt, na.rm = FALSE) {
+ ## compute weighted biased (divided by n) variance
+ if (na.rm) {
+ wt <- wt[i <- !is.na(x)]
+ x <- x[i]
+ }
+ sum.wt <- sum(wt)
+ mean.wt <- sum(x * wt) / sum(wt)
+ res <- sum(wt * (x - mean.wt)^2, na.rm = na.rm) / sum.wt
+ return(res)
+}
+
+
+covwt <- function(x, wt, na.rm = FALSE) {
+ ## compute weighted biased (divided by n) covariance matrix
+ x <- as.matrix(x)
+ if (na.rm) {
+ x <- na.omit(x)
+ wt <- wt[- attr(x,"na.action")]
+ }
+ wt <- wt / sum(wt)
+ mean.x <- colSums(wt * x)
+ x <- sqrt(wt) * sweep(x, 2, mean.x, FUN = "-", check.margin = FALSE)
+ res <- crossprod(x) / sum(wt)
+ return(res)
+}
+
+scalewt <- function (df, wt = rep(1/nrow(df), nrow(df)), center = TRUE, scale = TRUE) {
+ df <- as.matrix(df)
+ mean.df <- FALSE
+ if(center){
+ mean.df <- apply(df, 2, weighted.mean, w = wt)
+ df <- sweep(df, 2, mean.df, "-")
+ }
+
+ var.df <- FALSE
+ if(scale){
+ f <- function(x, w) sum(w * x^2) / sum(w)
+ var.df <- apply(df, 2, f, w = wt)
+ temp <- var.df < 1e-14
+ if (any(temp)) {
+ warning("Variables with null variance not standardized.")
+ var.df[temp] <- 1
+ }
+ var.df <- sqrt(var.df)
+ df <- sweep(df, 2, var.df, "/")
+ }
+
+ if (is.numeric(mean.df))
+ attr(df, "scaled:center") <- mean.df
+ if (is.numeric(var.df))
+ attr(df, "scaled:scale") <- var.df
+
+ return(df)
+}
+
+
+
+meanfacwt <- function(df, fac = NULL, wt = rep(1/nrow(df), nrow(df)), drop = FALSE) {
+ ## return res: rows are groups, columns variables
+ df <- data.frame(df)
+ if(identical(all.equal(wt, rep(1 / nrow(df), nrow(df))), TRUE)) { ## uniform weights
+ if(is.null(fac)) { ## no factor
+ res <- colMeans(df)
+ } else {
+ fac <- as.factor(fac)
+ if(drop)
+ fac <- factor(fac)
+ res <- t(sapply(split(df,fac),colMeans))
+ }
+ } else {
+ if(is.null(fac)) { ## no factor
+ res <- apply(df, 2, weighted.mean, w = wt)
+ } else {
+ fac <- as.factor(fac)
+ if(drop)
+ fac <- factor(fac)
+ df.list <- split(df, fac)
+ wt.list <- split(wt, fac)
+ if(ncol(df) > 1)
+ res <- t(sapply(1:nlevels(fac), function(x) apply(df.list[[x]], 2, weighted.mean, w = wt.list[[x]])))
+ else
+ res <- as.matrix(sapply(1:nlevels(fac), function(x) apply(df.list[[x]], 2, weighted.mean, w = wt.list[[x]])))
+ rownames(res) <- names(df.list)
+ }
+ }
+ return(res)
+}
+
+
+
+covfacwt <- function(df, fac = NULL, wt = rep(1/nrow(df), nrow(df)), drop = FALSE) {
+ df <- data.frame(df)
+ nr <- nrow(df)
+ if(identical(all.equal(wt, rep(1/nrow(df), nrow(df))), TRUE)) { ## uniform weights
+ if(is.null(fac)) { ## no factor
+ res <- cov(df) * (nr - 1) / nr
+ } else {
+ fac <- as.factor(fac)
+ if(drop)
+ fac <- factor(fac) ## to drop unused levels
+ res <- lapply(split(df,fac), function(x) cov(x) * (nrow(x) - 1) / nrow(x))
+ }
+ } else {
+ if(is.null(fac)) {## no factor
+ res <- covwt(df, wt = wt)
+ } else {
+ fac <- as.factor(fac)
+ if(drop)
+ fac <- factor(fac)
+ df.list <- split(df, fac)
+ wt.list <- split(wt, fac)
+ res <- lapply(1:nlevels(fac), function(x) covwt(df.list[[x]], wt = wt.list[[x]]))
+ names(res) <- names(df.list)
+ }
+ }
+ return(res)
+ ## liste, matrix var/covar, 1 element=1 group (order according to levels(fac))
+}
+
+
+
+
+## attention works only with data.frame or matrix
+varfacwt <- function(df, fac = NULL, wt = rep(1 / nrow(df), nrow(df)), drop = FALSE) {
+ df <- data.frame(df)
+ nr <- nrow(df)
+ if(identical(all.equal(wt, rep(1 / nrow(df), nrow(df))), TRUE)) { ## uniform weights
+ if(is.null(fac)) { ## no factor
+ res <- apply(df, 2, var) * (nr - 1) / nr
+ } else {
+ fac <- as.factor(fac)
+ if(drop)
+ fac <- factor(fac)
+ df.list <- split(df, fac)
+ res <- t(sapply(1:nlevels(fac), FUN = function(x) {apply(df.list[[x]], 2, function(y) var(y) * (NROW(y) - 1) / NROW(y))}))
+ }
+ } else {
+ if(is.null(fac)) { ## no factor
+ res <- apply(df, 2, varwt, wt = wt)
+ } else {
+ fac <- as.factor(fac)
+ if(drop)
+ fac <- factor(fac)
+ df.list <- split(df, fac)
+ wt.list <- split(wt, fac)
+ res <- t(sapply(1:nlevels(fac), FUN = function(x) {apply(df.list[[x]], 2, varwt, wt = wt.list[[x]])}))
+ rownames(res) <- names(df.list)
+ }
+ }
+ return(res)
+}
+
+
+scalefacwt <- function(df, fac = NULL, wt = rep(1 / nrow(df), nrow(df)), scale = TRUE, drop = FALSE) {
+ mean.df <- meanfacwt(df = df, fac = fac, wt = wt)
+ if(scale)
+ var.df <- varfacwt(df = df, fac = fac, wt = wt)
+ else
+ var.df <- FALSE
+
+ if(is.null(fac))
+ res <- scale(df, scale = sqrt(var.df), center = mean.df)
+ else {
+ fac <- as.factor(fac)
+ if(drop)
+ fac <- factor(fac)
+ df.list <- split(df, fac)
+ res <- lapply(1:nlevels(fac), function(x) as.data.frame(scale(df.list[[x]], scale = ifelse(scale, sqrt(var.df[x,]), FALSE), center = mean.df[x,])))
+ res <- unsplit(res,fac)
+ }
+ return(res)
+}
diff --git a/R/scatter.R b/R/scatter.R
new file mode 100644
index 0000000..51a5cf5
--- /dev/null
+++ b/R/scatter.R
@@ -0,0 +1,2 @@
+############ scatter #################
+"scatter" <- function (x, ...) UseMethod("scatter")
diff --git a/R/scatter.acm.R b/R/scatter.acm.R
new file mode 100644
index 0000000..c0b73be
--- /dev/null
+++ b/R/scatter.acm.R
@@ -0,0 +1,24 @@
+"scatter.acm" <- function (x, xax = 1, yax = 2, mfrow=NULL, csub = 2, possub = "topleft", ...) {
+ if (!inherits(x, "acm"))
+ stop("For 'acm' object")
+ if (x$nf == 1) {
+ score.acm(x, 1)
+ return(invisible())
+ }
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ oritab <- eval.parent(as.list(x$call)[[2]])
+ nvar <- ncol(oritab)
+ # modif samedi, juin 11, 2005 at 15:38
+ # message de Ivailo Stoyanov istoyanov at ecolab.bas.bg
+ if (is.null(mfrow)) mfrow = n2mfrow(nvar)
+ old.par <- par(no.readonly = TRUE)
+ on.exit(par(old.par))
+ par(mfrow = mfrow)
+ if (prod(mfrow)<nvar) par(ask=TRUE)
+ # modif lundi, décembre 16, 2002 at 16:48
+ # suite à message d'Alain Guerreau
+ for (i in 1:(nvar)) s.class(x$li, oritab[, i], xax=xax, yax=yax, clabel = 1.5,
+ sub = names(oritab)[i], csub = csub, possub = possub,
+ cgrid = 0, cstar = 0, ...)
+}
diff --git a/R/scatter.coa.R b/R/scatter.coa.R
new file mode 100644
index 0000000..51d3d7f
--- /dev/null
+++ b/R/scatter.coa.R
@@ -0,0 +1,38 @@
+"scatter.coa" <- function (x, xax = 1, yax = 2, method = 1:3, clab.row = 0.75,
+ clab.col = 1.25, posieig = "top", sub = NULL, csub = 2, ...)
+{
+ if (!inherits(x, "dudi"))
+ stop("Object of class 'dudi' expected")
+ if (!inherits(x, "coa"))
+ stop("Object of class 'coa' expected")
+ nf <- x$nf
+ if ((xax > nf) || (xax < 1) || (yax > nf) || (yax < 1) ||
+ (xax == yax))
+ stop("Non convenient selection")
+ method <- method[1]
+ if (method == 1) {
+ coolig <- x$li[, c(xax, yax)]
+ coocol <- x$co[, c(xax, yax)]
+ names(coocol) <- names(coolig)
+ s.label(rbind.data.frame(coolig, coocol), clabel = 0,
+ cpoint = 0, sub = sub, csub = csub)
+ # samedi, mars 29, 2003 at 15:35 correction SD pour ZAN
+ s.label(coolig, clabel = clab.row, add.plot = TRUE)
+ s.label(coocol, clabel = clab.col, add.plot = TRUE)
+ }
+ else if (method == 2) {
+ coocol <- x$c1[, c(xax, yax)]
+ coolig <- x$li[, c(xax, yax)]
+ s.label(coocol, clabel = clab.col, sub = sub, csub = csub)
+ s.label(coolig, clabel = clab.row, add.plot = TRUE)
+ }
+ else if (method == 3) {
+ coolig <- x$l1[, c(xax, yax)]
+ coocol <- x$co[, c(xax, yax)]
+ s.label(coolig, clabel = clab.col, sub = sub, csub = csub)
+ s.label(coocol, clabel = clab.row, add.plot = TRUE)
+ }
+ else stop("Unknown method")
+ add.scatter.eig(x$eig, x$nf, xax, yax, posi = posieig, ratio = 1/4)
+}
+
diff --git a/R/scatter.dudi.R b/R/scatter.dudi.R
new file mode 100644
index 0000000..4848f5e
--- /dev/null
+++ b/R/scatter.dudi.R
@@ -0,0 +1,25 @@
+"scatter.dudi" <- function (x, xax = 1, yax = 2, clab.row = .75, clab.col = 1,
+ permute = FALSE, posieig = "top", sub = NULL, ...)
+{
+ if (!inherits(x, "dudi"))
+ stop("Object of class 'dudi' expected")
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ coolig <- x$li[, c(xax, yax)]
+ coocol <- x$c1[, c(xax, yax)]
+ if (permute) {
+ coolig <- x$co[, c(xax, yax)]
+ coocol <- x$l1[, c(xax, yax)]
+ }
+ s.label(coolig, clabel = clab.row)
+ born <- par("usr")
+ k1 <- min(coocol[, 1])/born[1]
+ k2 <- max(coocol[, 1])/born[2]
+ k3 <- min(coocol[, 2])/born[3]
+ k4 <- max(coocol[, 2])/born[4]
+ k <- c(k1, k2, k3, k4)
+ coocol <- 0.9 * coocol/max(k)
+ s.arrow(coocol, clabel = clab.col, add.plot = TRUE, sub = sub,
+ possub = "bottomright")
+ add.scatter.eig(x$eig, x$nf, xax, yax, posi = posieig, ratio = 1/4)
+}
diff --git a/R/scatter.fca.R b/R/scatter.fca.R
new file mode 100644
index 0000000..be7f6bd
--- /dev/null
+++ b/R/scatter.fca.R
@@ -0,0 +1,15 @@
+"scatter.fca" <- function (x, xax = 1, yax = 2, clab.moda = 1, labels = names(x$tab),
+ sub = NULL, csub = 2, ...)
+{
+ opar <- par(mfrow = par("mfrow"))
+ on.exit(par(opar))
+ if ((xax == yax) || (x$nf == 1))
+ stop("Unidimensional plot (xax=yax) not yet implemented")
+ par(mfrow = n2mfrow(length(x$blo)))
+ oritab <- eval.parent(as.list(x$call)[[2]])
+ indica <- factor(rep(names(x$blo), x$blo))
+ for (j in levels(indica))
+ s.distri(x$l1, xax= xax, yax=yax, oritab[, which(indica == j)],
+ clabel = clab.moda, sub = as.character(j), cellipse = 0,
+ cstar = 0.5, csub = csub, label = labels[which(indica == j)])
+}
diff --git a/R/scatterutil.R b/R/scatterutil.R
new file mode 100644
index 0000000..6834a04
--- /dev/null
+++ b/R/scatterutil.R
@@ -0,0 +1,689 @@
+############ scatterutil.base #################
+"scatterutil.base" <- function (dfxy, xax, yax, xlim, ylim, grid, addaxes, cgrid, include.origin,
+ origin, sub, csub, possub, pixmap, contour, area, add.plot)
+{
+ df <- data.frame(dfxy)
+ if (!is.data.frame(df))
+ stop("Non convenient selection for df")
+ if ((xax < 1) || (xax > ncol(df)))
+ stop("Non convenient selection for xax")
+ if ((yax < 1) || (yax > ncol(df)))
+ stop("Non convenient selection for yax")
+ x <- df[, xax]
+ y <- df[, yax]
+ if (is.null(xlim)) {
+ x1 <- x
+ if (include.origin)
+ x1 <- c(x1, origin[1])
+ x1 <- c(x1 - diff(range(x1)/10), x1 + diff(range(x1))/10)
+ xlim <- range(x1)
+ }
+ if (is.null(ylim)) {
+ y1 <- y
+ if (include.origin)
+ y1 <- c(y1, origin[2])
+ y1 <- c(y1 - diff(range(y1)/10), y1 + diff(range(y1))/10)
+ ylim <- range(y1)
+ }
+ if (!is.null(pixmap)) {
+ if (is.null(class(pixmap)))
+ pixmap <- NULL
+ if (is.na(charmatch("pixmap", class(pixmap))))
+ pixmap <- NULL
+ }
+
+ if (!is.null(contour)) {
+ if (!is.data.frame(contour))
+ contour <- NULL
+ if (ncol(contour) != 4)
+ contour <- NULL
+ }
+ if (!is.null(area)) {
+ if (!is.data.frame(area))
+ area <- NULL
+ if (!is.factor(area[, 1]))
+ area <- NULL
+ if (ncol(area) < 3)
+ area <- NULL
+ }
+ if ( !add.plot)
+ plot.default(0, 0, type = "n", asp = 1, xlab = "", ylab = "",
+ xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim, xaxs = "i",
+ yaxs = "i", frame.plot = FALSE)
+
+ if (!is.null(pixmap)) {
+ pixmap::plot(pixmap, add = TRUE)
+ }
+
+ if (!is.null(contour)) {
+ apply(contour, 1, function(x) segments(x[1], x[2], x[3],
+ x[4], lwd = 1))
+ }
+ if (grid & !add.plot)
+ scatterutil.grid(cgrid)
+ if (addaxes & !add.plot)
+ abline(h = 0, v = 0, lty = 1)
+ if (!is.null(area)) {
+ nlev <- nlevels(area[, 1])
+ x1 <- area[, 2]
+ x2 <- area[, 3]
+ for (i in 1:nlev) {
+ lev <- levels(area[, 1])[i]
+ a1 <- x1[area[, 1] == lev]
+ a2 <- x2[area[, 1] == lev]
+ polygon(a1, a2)
+ }
+ }
+ if (csub > 0)
+ scatterutil.sub(sub, csub, possub)
+ return(list(x = x, y = y))
+}
+
+
+############ scatterutil.chull #################
+"scatterutil.chull" <- function (x, y, fac, optchull = c(0.25, 0.5, 0.75, 1), col=rep(1,length(levels(fac)))) {
+ if (!is.factor(fac))
+ return(invisible())
+ if (length(x) != length(fac))
+ return(invisible())
+ if (length(y) != length(fac))
+ return(invisible())
+ for (i in 1:nlevels(fac)) {
+ x1 <- x[fac == levels(fac)[i]]
+ y1 <- y[fac == levels(fac)[i]]
+ long <- length(x1)
+ longinit <- long
+ cref <- 1
+ repeat {
+ if (long < 3)
+ break
+ if (cref == 0)
+ break
+ num <- chull(x1, y1)
+ x2 <- x1[num]
+ y2 <- y1[num]
+ taux <- long/longinit
+ if ((taux <= cref) & (cref == 1)) {
+ cref <- 0.75
+ if (any(optchull == 1))
+ polygon(x2, y2, lty = 1, border=col[i])
+ }
+ if ((taux <= cref) & (cref == 0.75)) {
+ if (any(optchull == 0.75))
+ polygon(x2, y2, lty = 5, border=col[i])
+ cref <- 0.5
+ }
+ if ((taux <= cref) & (cref == 0.5)) {
+ if (any(optchull == 0.5))
+ polygon(x2, y2, lty = 3, border=col[i])
+ cref <- 0.25
+ }
+ if ((taux <= cref) & (cref == 0.25)) {
+ if (any(optchull == 0.25))
+ polygon(x2, y2, lty = 2, border=col[i])
+ cref <- 0
+ }
+ x1 <- x1[-num]
+ y1 <- y1[-num]
+ long <- length(x1)
+ }
+ }
+}
+
+############ scatterutil.eigen #################
+"scatterutil.eigen" <- function (w, nf = NULL, xmax = length(w), ymin=min(0,min(w)), ymax = max(w), wsel = 1, sub = "Eigenvalues",
+ csub = 2, possub = "topright",box=FALSE,yaxt="n")
+{
+ opar <- par(mar = par("mar"),plt=par("plt"))
+ on.exit(par(opar))
+ par(mar = c(0.8, 2.8, 0.8, 0.8),plt=par("plt"))
+ if (length(w) < xmax)
+ w <- c(w, rep(0, xmax - length(w)))
+ # modif by TJ to handle 3 colors (respented/kept/others)
+ col.w <- rep("white", length(w))
+ if(!is.null(nf)) {col.w[1:nf] <- "grey"}
+ col.w[wsel] <- "black"
+ #
+ barplot(w, col = col.w, ylim = c(ymin, ymax)*1.1,yaxt=yaxt)
+ scatterutil.sub(cha = sub, csub = max(.8,csub), possub = possub)
+ if(box) box()
+}
+
+############ scatterutil.ellipse #################
+"scatterutil.ellipse" <- function (x, y, z, cellipse, axesell, coul = rep(1,length(x)))
+{
+ if (any(is.na(z)))
+ return(invisible())
+ if (sum(z * z) == 0)
+ return(invisible())
+ util.ellipse <- function(mx, my, vx, cxy, vy, coeff) {
+ lig <- 100
+ epsi <- 1e-10
+ x <- 0
+ y <- 0
+ if (vx < 0)
+ vx <- 0
+ if (vy < 0)
+ vy <- 0
+ if (vx == 0 && vy == 0)
+ return(NULL)
+ delta <- (vx - vy) * (vx - vy) + 4 * cxy * cxy
+ delta <- sqrt(delta)
+ l1 <- (vx + vy + delta)/2
+ l2 <- vx + vy - l1
+ if (l1 < 0)
+ l1 <- 0
+ if (l2 < 0)
+ l2 <- 0
+ l1 <- sqrt(l1)
+ l2 <- sqrt(l2)
+ test <- 0
+ if (vx == 0) {
+ a0 <- 0
+ b0 <- 1
+ test <- 1
+ }
+ if ((vy == 0) && (test == 0)) {
+ a0 <- 1
+ b0 <- 0
+ test <- 1
+ }
+ if (((abs(cxy)) < epsi) && (test == 0)) {
+ if(vx > vy){
+ a0 <- 1
+ b0 <- 0
+ } else {
+ a0 <- 0
+ b0 <- 1
+ }
+ test <- 1
+ }
+ if (test == 0) {
+ a0 <- 1
+ b0 <- (l1 * l1 - vx)/cxy
+ norm <- sqrt(a0 * a0 + b0 * b0)
+ a0 <- a0/norm
+ b0 <- b0/norm
+ }
+ a1 <- 2 * pi/lig
+ c11 <- coeff * a0 * l1
+ c12 <- (-coeff) * b0 * l2
+ c21 <- coeff * b0 * l1
+ c22 <- coeff * a0 * l2
+ angle <- 0
+ for (i in 1:lig) {
+ cosinus <- cos(angle)
+ sinus <- sin(angle)
+ x[i] <- mx + c11 * cosinus + c12 * sinus
+ y[i] <- my + c21 * cosinus + c22 * sinus
+ angle <- angle + a1
+ }
+ return(list(x = x, y = y, seg1 = c(mx + c11, my + c21,
+ mx - c11, my - c21), seg2 = c(mx + c12, my + c22,
+ mx - c12, my - c22)))
+ }
+ z <- z/sum(z)
+ m1 <- sum(x * z)
+ m2 <- sum(y * z)
+ v1 <- sum((x - m1) * (x - m1) * z)
+ v2 <- sum((y - m2) * (y - m2) * z)
+ cxy <- sum((x - m1) * (y - m2) * z)
+ ell <- util.ellipse(m1, m2, v1, cxy, v2, cellipse)
+ if (is.null(ell))
+ return(invisible())
+ polygon(ell$x, ell$y, border=coul)
+ if (axesell)
+ segments(ell$seg1[1], ell$seg1[2], ell$seg1[3], ell$seg1[4],
+ lty = 2, col=coul)
+ if (axesell)
+ segments(ell$seg2[1], ell$seg2[2], ell$seg2[3], ell$seg2[4],
+ lty = 2, col=coul)
+}
+
+############ scatterutil.eti.circ #################
+"scatterutil.eti.circ" <- function (x, y, label, clabel, origin=c(0,0), boxes=TRUE) {
+ if (is.null(label))
+ return(invisible())
+ # message de JT warning pour R 1.7 modif samedi, mars 29, 2003 at 14:31
+ if (any(is.na(label)))
+ return(invisible())
+ if (any(label == ""))
+ return(invisible())
+ # modif mercredi, juillet 2, 2003 at 17:26
+ # pour les cas où le centre n'est pas l'origine
+ xref <- x - origin[1]
+ yref <- y - origin[2]
+ for (i in 1:(length(x))) {
+ cha <- as.character(label[i])
+ cha <- paste(" ", cha, " ", sep = "")
+ cex0 <- par("cex") * clabel
+
+ xh <- strwidth(cha, cex = cex0)
+ yh <- strheight(cha, cex = cex0) * 5/6
+ if ((xref[i] > yref[i]) & (xref[i] > -yref[i])) {
+ x1 <- x[i] + xh/2
+ y1 <- y[i]
+ }
+ else if ((xref[i] > yref[i]) & (xref[i] <= (-yref[i]))) {
+ x1 <- x[i]
+ y1 <- y[i] - yh
+ }
+ else if ((xref[i] <= yref[i]) & (xref[i] <= (-yref[i]))) {
+ x1 <- x[i] - xh/2
+ y1 <- y[i]
+ }
+ else if ((xref[i] <= yref[i]) & (xref[i] > (-yref[i]))) {
+ x1 <- x[i]
+ y1 <- y[i] + yh
+ }
+ # modif JT du 7 dec 2005
+ # le bloc if(boxes) ne doit contenir que la fonction rect, sinon ca plante
+ # si boxes = FALSE
+ if (boxes) {
+ rect(x1 - xh/2, y1 - yh, x1 + xh/2, y1 + yh, col = "white",
+ border = 1)
+ }
+ text(x1, y1, cha, cex = cex0)
+ }
+}
+
+############ scatterutil.eti #################
+"scatterutil.convrot90" <- function(xh,yh){
+ xusr <- par("usr")
+ tmp <- xh
+ xh <- yh/(xusr[4]-xusr[3])*par("pin")[2]
+ xh <- xh/ par("pin")[1] * (xusr[2]-xusr[1])
+ yh <- tmp/(xusr[2]-xusr[1])* par("pin")[1]
+ yh <- yh/ par("pin")[2] * (xusr[4]-xusr[3])
+ return(c(xh,yh))
+}
+
+"scatterutil.eti" <- function (x, y, label, clabel, boxes = TRUE, coul = rep(1, length(x)), horizontal = TRUE, bg = "white")
+{
+ if (length(label) == 0)
+ return(invisible())
+ if (is.null(label))
+ return(invisible())
+ if (any(label == ""))
+ return(invisible())
+ cex0 <- par("cex") * clabel
+ for (i in 1:(length(x))) {
+ cha <- as.character(label[i])
+ cha <- paste(" ", cha, " ", sep = "")
+ x1 <- x[i]
+ y1 <- y[i]
+ xh <- strwidth(cha, cex = cex0)
+ yh <- strheight(cha, cex = cex0) * 5/3
+ if(!horizontal){
+ tmp <- scatterutil.convrot90(xh,yh)
+ xh <- tmp[1]
+ yh <- tmp[2]
+
+ }
+ if (boxes) {
+ rect(x1 - xh/2, y1 - yh/2, x1 + xh/2, y1 + yh/2,
+ col = bg, border = coul[i])
+ }
+ if(horizontal){
+ text(x1, y1, cha, cex = cex0, col = coul[i])
+ } else {
+ text(x1, y1, cha, cex = cex0, col = coul[i], srt = 90)
+ }
+
+ }
+}
+
+############ scatterutil.sco #################
+
+"scatterutil.sco" <- function(score, lim, grid, cgrid, include.origin, origin, sub, csub, horizontal, reverse){
+ if (is.null(lim)) {
+ x1 <- score
+ if (include.origin)
+ x1 <- c(x1, origin)
+ x1 <- c(x1 - diff(range(x1)/10), x1 + diff(range(x1))/10)
+ lim <- range(x1)
+ }
+ if(horizontal){
+ ylim <- c(0, 1)
+ xlim <- lim
+ } else {
+ xlim <- c(0,1)
+ ylim <- lim
+ }
+
+ plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n",
+ yaxt = "n", xlim = xlim, ylim = ylim, xaxs = "i", yaxs = "i",
+ frame.plot = FALSE)
+
+ if (grid) {
+ if(horizontal){
+ axp <- par("xaxp")
+ } else {
+ axp <- par("yaxp")
+ }
+
+ nline <- axp[3] + 1
+ v0 <- seq(axp[1], axp[2], le = nline)
+ if(horizontal){
+ segments(v0, rep(0, nline), v0, rep( 1, nline), col = gray(0.5), lty = 1)
+ segments(0, 0 , 0, 1, col = 1, lwd = 3)
+ } else {
+ segments(rep(0, nline), v0, rep( 1, nline), v0, col = gray(0.5), lty = 1)
+ segments(0, 0 , 1, 0, col = 1, lwd = 3)
+ }
+ if (cgrid > 0) {
+ a <- (axp[2] - axp[1])/axp[3]
+ cha <- paste(" d = ", a," ",sep = "")
+ cex0 <- par("cex") * cgrid
+ xh <- strwidth(cha, cex = cex0)
+ yh <- strheight(cha, cex = cex0) * 5/3
+ x0 <- strwidth(" ", cex = cex0)
+ y0 <- strheight(" ", cex = cex0)/2
+ if(horizontal){
+ if(reverse){
+ x1 <- par("usr")[1]
+ y1 <- par("usr")[4]
+ rect(x1 + x0, y1 - y0 -yh, x1 + xh + x0, y1 - y0, col = "white", border = "white")
+ text(x1 + xh/2 + x0, y1 - yh/2 - y0, cha, cex = cex0)
+
+ } else {
+ x1 <- par("usr")[1]
+ y1 <- par("usr")[3]
+ rect(x1 + x0, y1 + y0, x1 + xh + x0, y1 + yh + y0, col = "white", border = "white")
+ text(x1 + xh/2 + x0, y1 + yh/2 + y0, cha, cex = cex0)
+ }
+ } else {
+
+ tmp <- scatterutil.convrot90(xh,yh)
+ xh <- tmp[1]
+ yh <- tmp[2]
+ tmp <- scatterutil.convrot90(x0,y0)
+ x0 <- tmp[1]
+ y0 <- tmp[2]
+ if(reverse) {
+ x1 <- par("usr")[2]
+ y1 <- par("usr")[4]
+ rect(x1 - x0 - xh, y1 - y0 - yh, x1 - x0, y1 - y0, col = "white", border = "white")
+ text(x1 - xh/2 - x0, y1 - yh/2 - y0, cha, cex = cex0, srt=270)
+ } else {
+ x1 <- par("usr")[1]
+ y1 <- par("usr")[4]
+ rect(x1 + x0, y1 - y0 - yh, x1 + xh + x0, y1 - y0, col = "white", border = "white")
+ text(x1 + xh/2 + x0, y1 - yh/2 - y0, cha, cex = cex0, srt=90)
+ }
+ }
+ }
+ }
+
+ href <- max(3, 2 * cgrid, 2 * csub)
+ href <- strheight("A", cex = par("cex") * href)
+ if(!horizontal){
+ tmp <- scatterutil.convrot90(0,href)
+ href <- tmp[1]
+ }
+
+
+ if (csub > 0) {
+ cha <- as.character(sub)
+ y1 <- par("usr")[3] + href/2
+ if (all(c(length(cha) > 0, !is.null(cha), !is.na(cha), cha != ""))) {
+ cha <- paste(" ",cha," ",sep="")
+ cex0 <- par("cex") * csub
+ xh <- strwidth(cha, cex = cex0)
+ yh <- strheight(cha, cex = cex0) *5/3
+ x0 <- strwidth(" ", cex = cex0)/2
+ y0 <- strheight(" ", cex = cex0)/2
+ if(horizontal){
+ if(reverse) {
+ x1 <- par("usr")[2]
+ y1 <- par("usr")[4]
+ rect(x1 - x0 - xh, y1 - y0 -yh, x1 -x0, y1 - y0, col = "white", border = "white")
+ text(x1 - xh/2 - x0, y1 - yh/2 - y0, cha, cex = cex0)
+ } else {
+ x1 <- par("usr")[2]
+ y1 <- par("usr")[3]
+ rect(x1 - x0 - xh, y1 + y0, x1 -x0, y1 + yh + y0, col = "white", border = "white")
+ text(x1 - xh/2 - x0, y1 + yh/2 + y0, cha, cex = cex0)
+ }
+ } else {
+ tmp <- scatterutil.convrot90(xh,yh)
+ xh <- tmp[1]
+ yh <- tmp[2]
+ tmp <- scatterutil.convrot90(x0,y0)
+ x0 <- tmp[1]
+ y0 <- tmp[2]
+ if(reverse) {
+ x1 <- par("usr")[2]
+ y1 <- par("usr")[3]
+ rect(x1 - x0 - xh, y1 + y0, x1 - x0 , y1 + yh + y0, col = "white", border = "white")
+ text(x1 - xh/2 - x0, y1 + yh/2 + y0, cha, cex = cex0,srt=270)
+
+ } else {
+ x1 <- par("usr")[1]
+ y1 <- par("usr")[3]
+ rect(x1 + x0, y1 + y0, x1 + x0 + xh, y1 + yh + y0, col = "white", border = "white")
+ text(x1 + xh/2 + x0, y1 + yh/2 + y0, cha, cex = cex0,srt=90)
+ }
+ }
+
+ }
+ }
+ box()
+ if(horizontal){
+ if(reverse){
+ abline( h = par("usr")[4] - href)
+ } else {
+ abline( h = par("usr")[3] + href)
+ }
+ return(c(min = par("usr")[1] , max = par("usr")[2], href = href))
+ } else {
+ if(reverse) {
+ abline( v = par("usr")[2] - href)
+ } else {
+ abline( v = par("usr")[1] + href)
+ }
+ return(c(min = par("usr")[3] , max = par("usr")[4], href = href))
+ }
+
+}
+
+
+############ scatterutil.grid #################
+"scatterutil.grid" <- function (cgrid) {
+ col <- "lightgray"
+ lty <- 1
+ xaxp <- par("xaxp")
+ ax <- (xaxp[2] - xaxp[1])/xaxp[3]
+ yaxp <- par("yaxp")
+ ay <- (yaxp[2] - yaxp[1])/yaxp[3]
+ a <- min(ax, ay)
+ v0 <- seq(xaxp[1], xaxp[2], by = a)
+ h0 <- seq(yaxp[1], yaxp[2], by = a)
+ abline(v = v0, col = col, lty = lty)
+ abline(h = h0, col = col, lty = lty)
+ if (cgrid <= 0)
+ return(invisible())
+ cha <- paste(" d = ", a, " ", sep = "")
+ cex0 <- par("cex") * cgrid
+ xh <- strwidth(cha, cex = cex0)
+ yh <- strheight(cha, cex = cex0) * 5/3
+ x1 <- par("usr")[2]
+ y1 <- par("usr")[4]
+ rect(x1 - xh, y1 - yh, x1 + xh, y1 + yh, col = "white", border = 0)
+ text(x1 - xh/2, y1 - yh/2, cha, cex = cex0)
+}
+
+############ scatterutil.legend.bw.square #################
+"scatterutil.legend.bw.square" <- function (br0, sq0, sig0, clegend) {
+ br0 <- round(br0, digits = 6)
+ cha <- as.character(br0[1])
+ for (i in (2:(length(br0)))) cha <- paste(cha, br0[i], sep = " ")
+ cex0 <- par("cex") * clegend
+ yh <- max(c(strheight(cha, cex = cex0), sq0))
+ h <- strheight(cha, cex = cex0)
+ y0 <- par("usr")[3] + yh/2 + h/2
+ ltot <- strwidth(cha, cex = cex0) + sum(sq0) + h
+ rect(par("usr")[1] + h/4, y0 - yh/2 - h/4, par("usr")[1] +
+ ltot + h/4, y0 + yh/2 + h/4, col = "white")
+ x0 <- par("usr")[1] + h/2
+ for (i in (1:(length(sq0)))) {
+ cha <- br0[i]
+ cha <- paste(" ", cha, sep = "")
+ xh <- strwidth(cha, cex = cex0)
+ text(x0 + xh/2, y0, cha, cex = cex0)
+ z0 <- sq0[i]
+ x0 <- x0 + xh + z0/2
+ if (sig0[i] >= 0)
+ symbols(x0, y0, squares = z0, bg = "black", fg = "white",
+ add = TRUE, inches = FALSE)
+ else symbols(x0, y0, squares = z0, bg = "white", fg = "black",
+ add = TRUE, inches = FALSE)
+ x0 <- x0 + z0/2
+ }
+ invisible()
+}
+
+############ scatterutil.legend.square.grey #################
+"scatterutil.legend.square.grey" <- function (br0, valgris, h, clegend) {
+ if (clegend <= 0)
+ return(invisible())
+ br0 <- round(br0, digits = 6)
+ nborn <- length(br0)
+ cex0 <- par("cex") * clegend
+ x0 <- par("usr")[1] + h
+ x1 <- x0
+ for (i in (2:(nborn))) {
+ x1 <- x1 + h
+ cha <- br0[i]
+ cha <- paste(cha, "]", sep = "")
+ xh <- strwidth(cha, cex = cex0)
+ if (i == (nborn))
+ break
+ x1 <- x1 + xh + h
+ }
+ yh <- max(strheight(paste(br0), cex = cex0), h)
+ y0 <- par("usr")[3] + yh/2 + h/2
+ rect(par("usr")[1] + h/4, y0 - yh/2 - h/4, x1 - h/4, y0 +
+ yh/2 + h/4, col = "white")
+ x0 <- par("usr")[1] + h
+ for (i in (2:(nborn))) {
+ symbols(x0, y0, squares = h, bg = gray(valgris[i - 1]),
+ add = TRUE, inches = FALSE)
+ x0 <- x0 + h
+ cha <- br0[i]
+ if (cha < 1e-05)
+ cha <- round(cha, digits = 3)
+ cha <- paste(cha, "]", sep = "")
+ xh <- strwidth(cha, cex = cex0)
+ if (i == (nborn))
+ break
+ text(x0 + xh/2, y0, cha, cex = cex0)
+ x0 <- x0 + xh + h
+ }
+ invisible()
+}
+
+############ scatterutil.legendgris #################
+"scatterutil.legendgris" <- function (w, nclasslegend, clegend) {
+ l0 <- as.integer(nclasslegend)
+ if (l0 == 0)
+ return(invisible())
+ if (l0 == 1)
+ l0 <- 2
+ if (l0 > 10)
+ l0 <- 10
+ h0 <- 1/(l0 + 1)
+ mid0 <- seq(h0/2, 1 - h0/2, le = l0 + 1)
+ qq <- quantile(w, seq(0, 1, le = l0 + 1))
+ w0 <- as.numeric(cut(w, br = qq, inc = TRUE))
+ w0 <- seq(0, 1, le = l0)[w0]
+ opar <- par(new = par("new"), mar = par("mar"), usr = par("usr"))
+ on.exit(par(opar))
+ par(new = TRUE)
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ plot(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n",
+ yaxt = "n", xlim = c(0, 2), ylim = c(0, 1.5))
+ rect(rep(0, l0), seq(h0/2, by = h0, le = l0), rep(h0, l0),
+ seq(3 * h0/2, by = h0, le = l0), col = gray(seq(1, 0,
+ le = l0)))
+ text(rep(h0, 9), mid0, as.character(signif(qq, digits = 2)),
+ pos = 4, cex = par("cex") * clegend)
+ box(col = "white")
+}
+
+############ scatterutil.scaling #################
+"scatterutil.scaling" <- function (refold, refnew, xyold) {
+ refold <- as.matrix(data.frame(refold))
+ refnew <- as.matrix(data.frame(refnew))
+ meanold <- apply(refold, 2, mean)
+ meannew <- apply(refnew, 2, mean)
+ refold0 <- sweep(refold, 2, meanold)
+ refnew0 <- sweep(refnew, 2, meannew)
+ sold <- sqrt(sum(refold0^2))
+ snew <- sqrt(sum(refnew0^2))
+ xyold <- sweep(xyold, 2, meanold)
+ xyold <- t(t(xyold)/sold)
+ xynew <- t(t(xyold) * snew)
+ xynew <- sweep(xynew, 2, meannew, "+")
+ xynew <- data.frame(xynew)
+ names(xynew) <- names(xyold)
+ row.names(xynew) <- row.names(xyold)
+ return(xynew)
+}
+############ scatterutil.star #################
+"scatterutil.star" <- function (x, y, z, cstar, coul = rep(1,length(x)))
+{
+ z <- z/sum(z)
+ x1 <- sum(x * z)
+ y1 <- sum(y * z)
+ for (i in which(z > 0)) {
+ hx <- cstar * (x[i] - x1)
+ hy <- cstar * (y[i] - y1)
+ segments(x1, y1, x1 + hx, y1 + hy, col=coul)
+ }
+}
+
+
+############ scatterutil.sub #################
+"scatterutil.sub" <- function (cha, csub, possub = "bottomleft") {
+ cha <- as.character(cha)
+ if (length(cha) == 0)
+ return(invisible())
+ if (is.null(cha))
+ return(invisible())
+ if (is.na(cha))
+ return(invisible())
+ if (any(cha == ""))
+ return(invisible())
+ if (csub == 0)
+ return(invisible())
+ cex0 <- par("cex") * csub
+ cha <- paste(" ", cha, " ", sep = "")
+ xh <- strwidth(cha, cex = cex0)
+ yh <- strheight(cha, cex = cex0) * 5/3
+ if (possub == "bottomleft") {
+ x1 <- par("usr")[1]
+ y1 <- par("usr")[3]
+ rect(x1, y1, x1 + xh, y1 + yh, col = "white", border = 0)
+ text(x1 + xh/2, y1 + yh/2, cha, cex = cex0)
+ }
+ else if (possub == "topleft") {
+ x1 <- par("usr")[1]
+ y1 <- par("usr")[4]
+ rect(x1, y1, x1 + xh, y1 - yh, col = "white", border = 0)
+ text(x1 + xh/2, y1 - yh/2, cha, cex = cex0)
+ }
+ else if (possub == "bottomright") {
+ x1 <- par("usr")[2]
+ y1 <- par("usr")[3]
+ rect(x1, y1, x1 - xh, y1 + yh, col = "white", border = 0)
+ text(x1 - xh/2, y1 + yh/2, cha, cex = cex0)
+ }
+ else if (possub == "topright") {
+ x1 <- par("usr")[2]
+ y1 <- par("usr")[4]
+ rect(x1, y1, x1 - xh, y1 - yh, col = "white", border = 0)
+ text(x1 - xh/2, y1 - yh/2, cha, cex = cex0)
+ }
+}
+
diff --git a/R/sco.boxplot.R b/R/sco.boxplot.R
new file mode 100644
index 0000000..89d1be6
--- /dev/null
+++ b/R/sco.boxplot.R
@@ -0,0 +1,79 @@
+"sco.boxplot" <- function (score, df, labels = names(df), clabel = 1, xlim = NULL,
+ grid = TRUE, cgrid = 0.75, include.origin = TRUE, origin = 0, sub = NULL,
+ csub = 1)
+{
+ if (!is.vector(score))
+ stop("vector expected for score")
+ if (!is.numeric(score))
+ stop("numeric expected for score")
+ if (!is.data.frame(df))
+ stop("data.frame expected for df")
+ if (!all(unlist(lapply(df, is.factor))))
+ stop("All variables must be factors")
+ n <- length(score)
+ if ((nrow(df) != n))
+ stop("Non convenient match")
+ n <- length(score)
+ nvar <- ncol(df)
+ nlev <- unlist(lapply(df, nlevels))
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ ymin <- scoreutil.base(y = score, xlim = xlim, grid = grid,
+ cgrid = cgrid, include.origin = include.origin, origin = origin,
+ sub = sub, csub = csub)
+ n1 <- sum(nlev)
+ ymax <- par("usr")[4]
+ ylabel <- strheight("A", cex = par("cex") * max(1, clabel)) *
+ 1.4
+ yunit <- (ymax - ymin - nvar * ylabel)/n1
+ y1 <- ymin + ylabel
+ xmin <- par("usr")[1]
+ xmax <- par("usr")[2]
+ xaxp <- par("xaxp")
+ nline <- xaxp[3] + 1
+ v0 <- seq(xaxp[1], xaxp[2], le = nline)
+ for (i in 1:nvar) {
+ y2 <- y1 + nlev[i] * yunit
+ rect(xmin, y1, xmax, y2)
+ if (clabel > 0) {
+ text((xmin + xmax)/2, y1 - ylabel/2, labels[i], cex = par("cex") *
+ clabel)
+ }
+ param <- tapply(score, df[, i], function(x) quantile(x,
+ seq(0, 1, by = 0.25)))
+ moy <- tapply(score, df[, i], mean)
+ nbox <- length(param)
+ namebox <- names(param)
+ pp <- ppoints(n = (nbox + 2), a = 1)
+ pp <- pp[2:(nbox + 1)]
+ ypp <- y1 + (y2 - y1) * pp
+ hbar <- (y2 - y1)/nbox/4
+ if (grid) {
+ segments(v0, rep(y1, nline), v0, rep(y2, nline),
+ col = gray(0.5), lty = 1)
+ }
+ for (j in 1:nbox) {
+ stat <- unlist(param[j])
+ amin <- stat[1]
+ aq1 <- stat[2]
+ amed <- stat[3]
+ aq2 <- stat[4]
+ amax <- stat[5]
+ rect(aq1, ypp[j] - hbar, aq2, ypp[j] + hbar, col = "white")
+ segments(amed, ypp[j] - hbar, amed, ypp[j] + hbar,
+ lwd = 2)
+ segments(amin, ypp[j], aq1, ypp[j])
+ segments(amax, ypp[j], aq2, ypp[j])
+ segments(amin, ypp[j] - hbar, amin, ypp[j] + hbar)
+ segments(amax, ypp[j] - hbar, amax, ypp[j] + hbar)
+ points(moy[j], ypp[j], pch = 20)
+ if (clabel > 0) {
+ text(amax, ypp[j], namebox[j], pos = 4, cex = par("cex") *
+ clabel * 0.8, offset = 0.2)
+ }
+ }
+ y1 <- y2 + ylabel
+ }
+ invisible()
+}
diff --git a/R/sco.class.R b/R/sco.class.R
new file mode 100644
index 0000000..cdfb001
--- /dev/null
+++ b/R/sco.class.R
@@ -0,0 +1,106 @@
+"sco.class" <- function(score, fac, label = levels(fac), clabel = 1, horizontal = TRUE, reverse = FALSE, pos.lab = 0.5, pch = 20, cpoint = 1, boxes = TRUE, col = rep(1, length(levels(fac))), lim = NULL, grid = TRUE, cgrid = 1, include.origin = TRUE, origin = c(0,0), sub = "", csub = 1.25, possub = "bottomleft"){
+
+ if(!is.vector(score))
+ stop("score should be a vector")
+ nval <- length(score)
+ if(is.null(label))
+ label <- 1:nlevels(fac)
+ if(nlevels(fac) != length(label))
+ stop("length of 'label' is not convenient")
+
+ if (pos.lab>1 | pos.lab<0)
+ stop("pos.lab should be between 0 and 1")
+ if (!is.factor(fac))
+ stop("factor expected for fac")
+
+
+ oldpar <- par(mar=rep(0.1, 4))
+ on.exit(par(oldpar))
+ res <- scatterutil.sco(score = score, lim = lim, grid = grid, cgrid = cgrid, include.origin = include.origin, origin = origin, sub = sub, csub = csub, horizontal = horizontal, reverse = reverse)
+ ymean <- tapply(score,fac,mean)
+ y2 <- rep(0, nlevels(fac))
+ if(horizontal){
+ if(reverse) {
+ points(score, rep(1- res[3], nval), pch = pch, cex = par("cex") * cpoint, col=col[fac])
+ } else {
+ points(score, rep(res[3], nval), pch = pch, cex = par("cex") * cpoint, col=col[fac])
+ }
+ if(clabel>0){
+ if(is.null(pos.lab))
+ pos.lab <- 0.5
+ if(reverse){
+ pos.lab <- 1 - res[3] - pos.lab * (1 - res[3])
+ pos.elbow <- 1- res[3] - (pos.lab - res[3])/5
+ } else {
+ pos.lab <- res[3] + pos.lab * (1 - res[3])
+ pos.elbow <- res[3] + (pos.lab - res[3])/5
+ }
+
+ for (i in 1:nlevels(fac))
+ {
+ xh <- strwidth(paste(" ", label[order(ymean)][i], " ", sep = ""), cex = par("cex") * clabel)
+ tmp <- scatterutil.convrot90(xh,0)
+ yh <- tmp[2]
+ y2[i] <- res[1] + (res[2] - res[1])/(nlevels(fac) + 1) * i
+
+ if(reverse) {
+ scatterutil.eti(y2[i], pos.lab - yh/2, label[order(ymean)][i], clabel = clabel, boxes = boxes, horizontal = FALSE, coul = col[order(ymean)][i])
+ } else {
+ scatterutil.eti(y2[i], pos.lab + yh/2, label[order(ymean)][i], clabel = clabel, boxes = boxes, horizontal = FALSE, coul = col[order(ymean)][i])
+ }
+ }
+ for (i in 1:nval)
+ {
+ lev <- which(levels(fac)==fac[i])
+ segments(score[i],pos.elbow ,y2[which(order(ymean)==lev)], pos.lab, col = col[lev])
+ if(reverse) {
+ segments(score[i], 1 - res[3], score[i], pos.elbow, col = col[lev])
+ } else {
+ segments(score[i], res[3], score[i], pos.elbow, col = col[lev])
+ }
+ }
+ }
+ } else {
+ if(reverse){
+ points(rep(1 - res[3], nval), score, pch = pch, cex = par("cex") * cpoint, col=col[fac])
+ } else {
+ points(rep(res[3], nval), score, pch = pch, cex = par("cex") * cpoint, col=col[fac])
+ }
+ if(clabel>0){
+ if(is.null(pos.lab))
+ pos.lab <- 0.5
+ if(reverse){
+ pos.lab <- 1 - res[3] - pos.lab * (1 - res[3])
+ pos.elbow <- 1- res[3] - (pos.lab - res[3])/5
+ } else {
+ pos.lab <- res[3] + pos.lab * (1 - res[3])
+ pos.elbow <- res[3] + (pos.lab - res[3])/5
+ }
+
+ for (i in 1:nlevels(fac))
+ {
+ xh <- strwidth(paste(" ", label[order(ymean)][i], " ", sep = ""), cex = par("cex") * clabel)
+ y2[i] <- res[1] + (res[2] - res[1])/(nlevels(fac) + 1) * i
+
+ if(reverse) {
+ scatterutil.eti(pos.lab - xh/2, y2[i], label[order(ymean)][i], clabel = clabel, boxes = boxes, horizontal = TRUE, coul = col[order(ymean)][i])
+ } else {
+ scatterutil.eti(pos.lab + xh/2, y2[i], label[order(ymean)][i], clabel = clabel, boxes = boxes, horizontal = TRUE, coul = col[order(ymean)][i])
+ }
+ }
+ for (i in 1:nval)
+ {
+ lev <- which(levels(fac)==fac[i])
+ segments(pos.elbow,score[i],pos.lab ,y2[which(order(ymean)==lev)], col = col[lev])
+ if(reverse) {
+ segments(1 - res[3],score[i], pos.elbow, score[i], col = col[lev])
+
+ } else {
+ segments(res[3],score[i], pos.elbow, score[i], col = col[lev])
+
+ }
+ }
+ }
+ }
+ invisible(match.call())
+}
diff --git a/R/sco.distri.R b/R/sco.distri.R
new file mode 100644
index 0000000..5d27745
--- /dev/null
+++ b/R/sco.distri.R
@@ -0,0 +1,83 @@
+"sco.distri" <- function (score, df, y.rank = TRUE, csize = 1, labels = names(df),
+ clabel = 1, xlim = NULL, grid = TRUE, cgrid = 0.75, include.origin = TRUE,
+ origin = 0, sub = NULL, csub = 1)
+{
+ if (!is.vector(score))
+ stop("vector expected for score")
+ if (!is.numeric(score))
+ stop("numeric expected for score")
+ if (!is.data.frame(df))
+ stop("data.frame expected for df")
+ if (any(df < 0))
+ stop("data >=0 expected in df")
+ n <- length(score)
+ if ((nrow(df) != n))
+ stop("Non convenient match")
+ n <- length(score)
+ nvar <- ncol(df)
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ ymin <- scoreutil.base(y = score, xlim = xlim, grid = grid,
+ cgrid = cgrid, include.origin = include.origin, origin = origin,
+ sub = sub, csub = csub)
+ ymax <- par("usr")[4]
+ ylabel <- strheight("A", cex = par("cex") * max(1, clabel)) *
+ 1.4
+ xmin <- par("usr")[1]
+ xmax <- par("usr")[2]
+ xaxp <- par("xaxp")
+ nline <- xaxp[3] + 1
+ v0 <- seq(xaxp[1], xaxp[2], le = nline)
+ if (grid) {
+ segments(v0, rep(ymin, nline), v0, rep(ymax, nline),
+ col = gray(0.5), lty = 1)
+ }
+ rect(xmin, ymin, xmax, ymax)
+ sum.col <- apply(df, 2, sum)
+ labels <- labels[sum.col > 0]
+ df <- df[, sum.col > 0]
+ nvar <- ncol(df)
+ sum.col <- apply(df, 2, sum)
+ df <- sweep(df, 2, sum.col, "/")
+ y.distri <- (nvar:1)
+ if (y.rank) {
+ y.distri <- drop(score %*% as.matrix(df))
+ y.distri <- rank(y.distri)
+ }
+ ylabel <- strheight("A", cex = par("cex") * max(1, clabel)) *
+ 1.4
+ y.distri <- (y.distri - min(y.distri))/(max(y.distri) - min(y.distri))
+ y.distri <- ymin + ylabel + (ymax - ymin - 2 * ylabel) *
+ y.distri
+ res <- matrix(0,nvar,2)
+ for (i in 1:nvar) {
+ w <- df[, i]
+ y0 <- y.distri[i]
+ x.moy <- sum(w * score)
+ x.et <- sqrt(sum(w * (score - x.moy)^2))
+ res[i,1] <- x.moy
+ res[i,2] <- x.et * x.et
+ x1 <- x.moy - x.et * csize
+ x2 <- x.moy + x.et * csize
+ etiagauche <- TRUE
+ if ((x1 - xmin) < (xmax - x2))
+ etiagauche <- FALSE
+ segments(x1, y0, x2, y0)
+ if (clabel > 0) {
+ cha <- labels[i]
+ cex0 <- par("cex") * clabel
+ xh <- strwidth(cha, cex = cex0)
+ xh <- xh + strwidth("x", cex = cex0)
+ if (etiagauche)
+ x0 <- x1 - xh/2
+ else x0 <- x2 + xh/2
+ text(x0, y0, cha, cex = cex0)
+ }
+ points(x.moy, y0, pch = 20, cex = par("cex") * 2)
+ }
+ res <- as.data.frame(res)
+ names(res) <- c("mean","var")
+ rownames(res) <- names(df)
+ invisible(res)
+}
diff --git a/R/sco.gauss.R b/R/sco.gauss.R
new file mode 100644
index 0000000..66ac69a
--- /dev/null
+++ b/R/sco.gauss.R
@@ -0,0 +1,57 @@
+################################
+# Gauss curves on score categories
+################################
+# Takes one vector containing quantitative values and one dataframe of factors
+# giving categories to wich these values belong. Computes the mean and variance
+# of the values in each category for each factor, and draws a Gauss curve with
+# the same mean and variance for each category and each factor.
+# Can optionaly set the start and end point of the curves (xlim) and the number # of segments.
+################################
+"sco.gauss" <- function(score, df, xlim = NULL, steps = 200, ymax = NULL, sub = names(df), csub = 1.25, possub = "topleft", legen = TRUE, label = row.names(df), clabel = 1, grid = TRUE, cgrid = 1, include.origin = TRUE, origin = c(0,0) ) {
+ if (!is.vector(score))
+ stop("score should be a vector")
+ if (!is.numeric(score))
+ stop("score should be numeric")
+ if (!is.data.frame(df))
+ stop("df should be a data.frame")
+ if (nrow(df) != length(score))
+ stop("Wrong dimensions for df and score")
+ if (!all(unlist(lapply(df, is.factor))))
+ stop("All variables in df must be factors")
+ opar <- par(mar = par("mar"), mfrow = par("mfrow"))
+ on.exit(par(opar))
+ par(mar=rep(0.1, 4))
+ nfig <- ncol(df)
+ par(mfrow = n2mfrow(nfig+1))
+ if (legen){
+ par(mfrow = n2mfrow(nfig+1))
+ sco.label(score = score, label = label, clabel = clabel, grid = grid, cgrid = cgrid, include.origin = include.origin, origin = origin )
+ } else {
+ par(mfrow = n2mfrow(nfig))
+ }
+
+
+ for (i in 1:nfig) {
+ res <- scatterutil.sco(score = score, lim = xlim, grid = grid, cgrid = cgrid, include.origin = include.origin, origin = origin, sub = sub[i], csub = csub, horizontal = TRUE, reverse = FALSE)
+ nlevs <- nlevels(df[,i])
+ means <- by(score, df[,i], mean)
+ sds <- by(score, df[,i], sd)
+ xi <- seq(res[1], res[2], by=(res[2]-res[1])/steps)
+ yi <- lapply(1:nlevs,function(x) dnorm(xi, means[[x]], sds[[x]]))
+ if(is.null(ymax)){
+ maxy <- (max(unlist(yi))) * 1.15
+ } else {
+ maxy <- ymax
+ }
+ for (j in 1:nlevs) {
+
+ lines(xi, yi[[j]] * (1 - res[3])/maxy + res[3])
+ xmaxi <- xi[which.max(yi[[j]])]
+ ymaxi <- max(yi[[j]])
+ text(xmaxi, ymaxi * (1 - res[3])/maxy + res[3], levels(df[,i])[j], pos=3, offset=.2, cex=clabel * par("cex"))
+ }
+
+ }
+ invisible(match.call())
+}
+
diff --git a/R/sco.label.R b/R/sco.label.R
new file mode 100644
index 0000000..19ac9be
--- /dev/null
+++ b/R/sco.label.R
@@ -0,0 +1,91 @@
+################################
+## Evenly spaced labels for a score
+################################
+## Can be used as a legend for the Gauss curve function.
+## Takes one vector of quantitative values (abscissae) and draws lines connecting
+## these abscissae to evenly spaced labels.
+################################
+"sco.label" <- function(score, label = names(score), clabel = 1, horizontal = TRUE, reverse = FALSE, pos.lab = 0.5, pch = 20, cpoint = 1, boxes = TRUE, lim = NULL, grid = TRUE, cgrid = 1, include.origin = TRUE, origin = c(0,0), sub = "", csub = 1.25, possub = "bottomleft"){
+
+ if(!is.vector(score))
+ stop("score should be a vector")
+ nval <- length(score)
+ if(is.null(label))
+ label <- 1:nval
+ if(nval != length(label))
+ stop("length of 'label' is not convenient")
+
+ if (pos.lab>1 | pos.lab<0)
+ stop("pos.lab should be between 0 and 1")
+
+
+ oldpar <- par(mar=rep(0.1, 4))
+ on.exit(par(oldpar))
+ res <- scatterutil.sco(score = score, lim = lim, grid = grid, cgrid = cgrid, include.origin = include.origin, origin = origin, sub = sub, csub = csub, horizontal = horizontal, reverse = reverse)
+ if(horizontal){
+ if(reverse) {
+ points(score, rep(1- res[3], nval), pch = pch, cex = par("cex") * cpoint)
+ } else {
+ points(score, rep(res[3], nval), pch = pch, cex = par("cex") * cpoint)
+ }
+ if(clabel>0){
+ if(is.null(pos.lab))
+ pos.lab <- 0.5
+ if(reverse){
+ pos.lab <- 1 - res[3] - pos.lab * (1 - res[3])
+ pos.elbow <- 1- res[3] - (pos.lab - res[3])/5
+ } else {
+ pos.lab <- res[3] + pos.lab * (1 - res[3])
+ pos.elbow <- res[3] + (pos.lab - res[3])/5
+ }
+
+ for (i in 1:nval)
+ {
+ xh <- strwidth(paste(" ", label[order(score)][i], " ", sep = ""), cex = par("cex") * clabel)
+ tmp <- scatterutil.convrot90(xh,0)
+ yh <- tmp[2]
+ y2 <- res[1] + (res[2] - res[1])/(nval + 1) * i
+ segments(score[order(score)][i],pos.elbow ,y2, pos.lab)
+ if(reverse) {
+ segments(score[order(score)][i], 1 - res[3], score[order(score)][i], pos.elbow)
+ scatterutil.eti(y2, pos.lab - yh/2, label[order(score)][i], clabel = clabel, boxes = boxes, horizontal = FALSE)
+ } else {
+ segments(score[order(score)][i], res[3], score[order(score)][i], pos.elbow)
+ scatterutil.eti(y2, pos.lab + yh/2, label[order(score)][i], clabel = clabel, boxes = boxes, horizontal = FALSE)
+ }
+ }
+ }
+ } else {
+ if(reverse){
+ points(rep(1 - res[3], nval), score, pch = pch, cex = par("cex") * cpoint)
+ } else {
+ points(rep(res[3], nval), score, pch = pch, cex = par("cex") * cpoint)
+ }
+ if(clabel>0){
+ if(is.null(pos.lab))
+ pos.lab <- 0.5
+ if(reverse){
+ pos.lab <- 1 - res[3] - pos.lab * (1 - res[3])
+ pos.elbow <- 1- res[3] - (pos.lab - res[3])/5
+ } else {
+ pos.lab <- res[3] + pos.lab * (1 - res[3])
+ pos.elbow <- res[3] + (pos.lab - res[3])/5
+ }
+
+ for (i in 1:nval)
+ {
+ xh <- strwidth(paste(" ", label[order(score)][i], " ", sep = ""), cex = par("cex") * clabel)
+ y2 <- res[1] + (res[2] - res[1])/(nval + 1) * i
+ segments(pos.elbow,score[order(score)][i],pos.lab ,y2)
+ if(reverse) {
+ segments(1 - res[3],score[order(score)][i], pos.elbow, score[order(score)][i])
+ scatterutil.eti(pos.lab - xh/2, y2, label[order(score)][i], clabel = clabel, boxes = boxes, horizontal = TRUE)
+ } else {
+ segments(res[3],score[order(score)][i], pos.elbow, score[order(score)][i])
+ scatterutil.eti(pos.lab + xh/2, y2, label[order(score)][i], clabel = clabel, boxes = boxes, horizontal = TRUE)
+ }
+ }
+ }
+ }
+ invisible(match.call())
+}
diff --git a/R/sco.match.R b/R/sco.match.R
new file mode 100644
index 0000000..8eaf269
--- /dev/null
+++ b/R/sco.match.R
@@ -0,0 +1,100 @@
+"sco.match" <- function(score1, score2, label = names(score1), clabel = 1, horizontal = TRUE, reverse = FALSE, pos.lab = 0.5, wmatch=3,pch = 20, cpoint = 1, boxes = TRUE, lim = NULL, grid = TRUE, cgrid = 1, include.origin = TRUE, origin = c(0,0), sub = "", csub = 1.25, possub = "bottomleft"){
+
+ if(!is.vector(score1))
+ stop("score1 should be a vector")
+ if(!is.vector(score2))
+ stop("score2 should be a vector")
+ nval <- length(score1)
+ if(nval != length(score2))
+ stop("length of 'score1' or 'score2' is not convenient")
+ if(is.null(label))
+ label <- 1:nval
+ if(nval != length(label))
+ stop("length of 'label' is not convenient")
+
+ if (pos.lab>1 | pos.lab<0)
+ stop("pos.lab should be between 0 and 1")
+
+
+ oldpar <- par(mar=rep(0.1, 4))
+ on.exit(par(oldpar))
+ res <- scatterutil.sco(score = c(score1,score2), lim = lim, grid = grid, cgrid = cgrid, include.origin = include.origin, origin = origin, sub = sub, csub = csub, horizontal = horizontal, reverse = reverse)
+ if(horizontal){
+ if(reverse) {
+ points(score1, rep(1- res[3], nval), pch = pch, cex = par("cex") * cpoint)
+ abline(h=1- wmatch*res[3])
+ points(score2, rep(1- wmatch*res[3], nval), pch = pch, cex = par("cex") * cpoint)
+ segments(score1,rep(1- res[3], nval),score2,rep(1- wmatch*res[3], nval))
+ } else {
+ points(score1, rep(res[3], nval), pch = pch, cex = par("cex") * cpoint)
+ abline(h=wmatch*res[3])
+ points(score2, rep(wmatch*res[3], nval), pch = pch, cex = par("cex") * cpoint)
+ segments(score1,rep(res[3], nval),score2,rep(wmatch*res[3], nval))
+ }
+ if(clabel>0){
+ if(is.null(pos.lab))
+ pos.lab <- 0.5
+ if(reverse){
+ pos.lab <- 1 - wmatch * res[3] - pos.lab * (1 - wmatch * res[3])
+ pos.elbow <- 1 - wmatch * res[3] - (1 - wmatch * res[3] - pos.lab)/5
+ } else {
+ pos.lab <- wmatch * res[3] + pos.lab * (1 - wmatch * res[3])
+ pos.elbow <- wmatch * res[3] + (pos.lab - wmatch * res[3])/5
+ }
+
+ for (i in 1:nval)
+ {
+ xh <- strwidth(paste(" ", label[order(score2)][i], " ", sep = ""), cex = par("cex") * clabel)
+ tmp <- scatterutil.convrot90(xh,0)
+ yh <- tmp[2]
+ yreg <- res[1] + (res[2] - res[1])/(nval + 1) * i
+ segments(score2[order(score2)][i],pos.elbow ,yreg, pos.lab)
+ if(reverse) {
+ segments(score2[order(score2)][i], 1 - wmatch * res[3], score2[order(score2)][i], pos.elbow)
+ scatterutil.eti(yreg, pos.lab - yh/2, label[order(score2)][i], clabel = clabel, boxes = boxes, horizontal = FALSE)
+ } else {
+ segments(score2[order(score2)][i], wmatch * res[3], score2[order(score2)][i], pos.elbow)
+ scatterutil.eti(yreg, pos.lab + yh/2, label[order(score2)][i], clabel = clabel, boxes = boxes, horizontal = FALSE)
+ }
+ }
+ }
+ } else {
+ if(reverse){
+ points(rep(1 - res[3], nval), score1, pch = pch, cex = par("cex") * cpoint)
+ abline(v=1- wmatch*res[3])
+ points(rep(1- wmatch*res[3], nval), score2, pch = pch, cex = par("cex") * cpoint)
+ segments(rep(1- res[3], nval),score1,rep(1- wmatch*res[3], nval), score2)
+ } else {
+ points(rep(res[3], nval), score1, pch = pch, cex = par("cex") * cpoint)
+ abline(v=wmatch*res[3])
+ points(rep(wmatch*res[3], nval), score2, pch = pch, cex = par("cex") * cpoint)
+ segments(rep(res[3], nval),score1,rep(wmatch*res[3], nval), score2)
+ }
+ if(clabel>0){
+ if(is.null(pos.lab))
+ pos.lab <- 0.5
+ if(reverse){
+ pos.lab <- 1 - wmatch * res[3] - pos.lab * (1 - wmatch * res[3])
+ pos.elbow <- 1- wmatch * res[3] - (1 - wmatch * res[3]- pos.lab)/5
+ } else {
+ pos.lab <- wmatch * res[3] + pos.lab * (1 - wmatch * res[3])
+ pos.elbow <- wmatch * res[3] + (pos.lab - wmatch * res[3])/5
+ }
+
+ for (i in 1:nval)
+ {
+ xh <- strwidth(paste(" ", label[order(score2)][i], " ", sep = ""), cex = par("cex") * clabel)
+ yreg <- res[1] + (res[2] - res[1])/(nval + 1) * i
+ segments(pos.elbow,score2[order(score2)][i],pos.lab ,yreg)
+ if(reverse) {
+ segments(1 - wmatch * res[3],score2[order(score2)][i], pos.elbow, score2[order(score2)][i])
+ scatterutil.eti(pos.lab - xh/2, yreg, label[order(score2)][i], clabel = clabel, boxes = boxes, horizontal = TRUE)
+ } else {
+ segments(wmatch * res[3],score2[order(score2)][i], pos.elbow, score2[order(score2)][i])
+ scatterutil.eti(pos.lab + xh/2, yreg, label[order(score2)][i], clabel = clabel, boxes = boxes, horizontal = TRUE)
+ }
+ }
+ }
+ }
+ invisible(match.call())
+}
diff --git a/R/sco.quant.R b/R/sco.quant.R
new file mode 100644
index 0000000..e96da43
--- /dev/null
+++ b/R/sco.quant.R
@@ -0,0 +1,34 @@
+"sco.quant" <- function (score, df, fac = NULL, clabel = 1, abline = FALSE,
+ sub = names(df), csub = 2, possub = "topleft")
+{
+ if (!is.vector(score))
+ stop("vector expected for score")
+ if (!is.numeric(score))
+ stop("numeric expected for score")
+ if (!is.data.frame(df))
+ stop("data.frame expected for df")
+ if (nrow(df) != length(score))
+ stop("Not convenient dimensions")
+ if (!is.null(fac)) {
+ fac <- factor(fac)
+ if (length(fac) != length(score))
+ stop("Not convenient dimensions")
+ }
+ opar <- par(mar = par("mar"), mfrow = par("mfrow"))
+ on.exit(par(opar))
+ par(mar = c(2.6, 2.6, 1.1, 1.1))
+ nfig <- ncol(df)
+ par(mfrow = n2mfrow(nfig))
+ for (i in 1:nfig) {
+ plot(score, df[, i], type = "n")
+ if (!is.null(fac)) {
+ s.class(cbind.data.frame(score, df[, i]), fac,
+ axesell = FALSE, add.plot = TRUE, clabel = clabel)
+ }
+ else points(score, df[, i])
+ if (abline) {
+ abline(lm(df[, i] ~ score))
+ }
+ scatterutil.sub(sub[i], csub, possub)
+ }
+}
diff --git a/R/score.R b/R/score.R
new file mode 100644
index 0000000..3b33887
--- /dev/null
+++ b/R/score.R
@@ -0,0 +1,65 @@
+"score" <- function (x, ...) UseMethod("score")
+
+"scoreutil.base" <- function (y, xlim, grid, cgrid, include.origin, origin, sub,
+ csub)
+{
+ if (is.null(xlim)) {
+ x1 <- y
+ if (include.origin)
+ x1 <- c(x1, origin)
+ x1 <- c(x1 - diff(range(x1)/10), x1 + diff(range(x1))/10)
+ xlim <- range(x1)
+ }
+ ylim <- c(0, 1)
+ plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n",
+ yaxt = "n", xlim = xlim, ylim = ylim, xaxs = "i", yaxs = "i",
+ frame.plot = FALSE)
+ href <- max(3, 2 * cgrid, 2 * csub)
+ href <- strheight("A", cex = par("cex") * href)
+ if (grid) {
+ xaxp <- par("xaxp")
+ nline <- xaxp[3] + 1
+ v0 <- seq(xaxp[1], xaxp[2], le = nline)
+ segments(v0, rep(par("usr")[3], nline), v0, rep(par("usr")[3] +
+ href, nline), col = gray(0.5), lty = 1)
+ segments(0, par("usr")[3], 0, par("usr")[3] + href, col = 1,
+ lwd = 3)
+ if (cgrid > 0) {
+ a <- (xaxp[2] - xaxp[1])/xaxp[3]
+ cha <- paste("d = ", a, sep = "")
+ cex0 <- par("cex") * cgrid
+ xh <- strwidth(cha, cex = cex0)
+ yh <- strheight(cha, cex = cex0) + strheight(" ",
+ cex = cex0)/2
+ x0 <- strwidth(" ", cex = cex0)
+ y0 <- strheight(" ", cex = cex0)/2
+ x1 <- par("usr")[1]
+ y1 <- par("usr")[3]
+ rect(x1 + x0, y1 + y0, x1 + xh + x0, y1 + yh + y0,
+ col = "white", border = 0)
+ text(x1 + xh/2 + x0/2, y1 + yh/2 + y0/2, cha, cex = cex0)
+ }
+ }
+ y1 <- rep(par("usr")[3] + href/2, length(y))
+ y2 <- rep(par("usr")[3] + href, length(y))
+ segments(y, y1, y, y2)
+ if (csub > 0) {
+ cha <- as.character(sub)
+ if (all(c(length(cha) > 0, !is.null(cha), !is.na(cha),
+ cha != ""))) {
+ cex0 <- par("cex") * csub
+ xh <- strwidth(cha, cex = cex0)
+ yh <- strheight(cha, cex = cex0)
+ x0 <- strwidth(" ", cex = cex0)
+ y0 <- strheight(" ", cex = cex0)
+ x1 <- par("usr")[2]
+ y1 <- par("usr")[3]
+ rect(x1 - x0 - xh, y1, x1, y1 + yh + y0, col = "white",
+ border = 0)
+ text(x1 - xh/2 - x0/2, y1 + yh/2 + y0/2, cha, cex = cex0)
+ }
+ }
+ rect(par("usr")[1], par("usr")[3], par("usr")[2], par("usr")[3] +
+ href)
+ return(par("usr")[3] + href)
+}
diff --git a/R/score.acm.R b/R/score.acm.R
new file mode 100644
index 0000000..a57e1b5
--- /dev/null
+++ b/R/score.acm.R
@@ -0,0 +1,34 @@
+"score.acm" <- function (x, xax = 1, which.var = NULL, mfrow = NULL, sub = names(oritab),
+ csub = 2, possub = "topleft", ...)
+{
+ if (!inherits(x, "acm"))
+ stop("Object of class 'acm' expected")
+ if (x$nf == 1)
+ xax <- 1
+ if ((xax < 1) || (xax > x$nf))
+ stop("non convenient axe number")
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ oritab <- eval.parent(as.list(x$call)[[2]])
+ nvar <- ncol(oritab)
+ if (is.null(which.var))
+ which.var <- (1:nvar)
+ if (is.null(mfrow))
+ par(mfrow = n2mfrow(length(which.var)))
+ if (prod(par("mfrow")) < length(which.var))
+ par(ask = TRUE)
+ par(mar = c(2.6, 2.6, 1.1, 1.1))
+ score <- x$l1[, xax]
+ for (i in which.var) {
+ y <- oritab[, i]
+ moy <- unlist(tapply(score, y, mean))
+ plot(score, score, type = "n")
+ h <- (max(score) - min(score))/40
+ abline(h = moy)
+ segments(score, moy[y] - h, score, moy[y] + h)
+ abline(0, 1)
+ scatterutil.eti(moy, moy, label = as.character(levels(y)),
+ clabel = 1.5)
+ scatterutil.sub(sub[i], csub = csub, possub = possub)
+ }
+}
diff --git a/R/score.coa.R b/R/score.coa.R
new file mode 100644
index 0000000..22fd8bf
--- /dev/null
+++ b/R/score.coa.R
@@ -0,0 +1,185 @@
+"score.coa" <- function (x, xax = 1, dotchart = FALSE, clab.r = 1, clab.c = 1,
+ csub = 1, cpoi = 1.5, cet = 1.5, ...)
+{
+ if (!inherits(x, "coa"))
+ stop("Object of class 'coa' expected")
+ if (x$nf == 1)
+ xax <- 1
+ if ((xax < 1) || (xax > x$nf))
+ stop("non convenient axe number")
+ "dudi.coa.dotchart" <- function(dudi, numfac, clab) {
+ if (!inherits(dudi, "coa"))
+ stop("Object of class 'coa' expected")
+ sli <- dudi$li[, numfac]
+ sco <- dudi$co[, numfac]
+ oli <- order(sli)
+ oco <- order(sco)
+ a <- c(sli[oli], sco[oco])
+ gr <- as.factor(rep(c("Rows", "Columns"), c(length(sli),
+ length(sco))))
+ lab <- c(row.names(dudi$li)[oli], row.names(dudi$co)[oco])
+ if (clab > 0)
+ labels <- lab
+ else labels <- NULL
+ dotchart(a, labels = labels, groups = gr, pch = 20)
+ }
+ if (dotchart) {
+ clab <- clab.r * clab.c
+ dudi.coa.dotchart(x, xax, clab)
+ return(invisible())
+ }
+ def.par <- par(mar = par("mar"))
+ on.exit(par(def.par))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ sco.distri.class.2g <- function(score, fac1, fac2, weight,
+ labels1 = as.character(levels(fac1)), labels2 = as.character(levels(fac2)),
+ clab1, clab2, cpoi, cet) {
+ nvar1 <- nlevels(fac1)
+ nvar2 <- nlevels(fac2)
+ ymin <- scoreutil.base(y = score, xlim = NULL, grid = TRUE,
+ cgrid = 0.75, include.origin = TRUE, origin = 0,
+ sub = NULL, csub = 0)
+ ymax <- par("usr")[4]
+ ylabel <- strheight("A", cex = par("cex") * max(1, clab1,
+ clab2)) * 1.4
+ xmin <- par("usr")[1]
+ xmax <- par("usr")[2]
+ xaxp <- par("xaxp")
+ nline <- xaxp[3] + 1
+ v0 <- seq(xaxp[1], xaxp[2], le = nline)
+ segments(v0, rep(ymin, nline), v0, rep(ymax, nline),
+ col = gray(0.5), lty = 1)
+ rect(xmin, ymin, xmax, ymax)
+ sum.col1 <- unlist(tapply(weight, fac1, sum))
+ sum.col2 <- unlist(tapply(weight, fac2, sum))
+ sum.col1[sum.col1 == 0] <- 1
+ sum.col2[sum.col2 == 0] <- 1
+ weight1 <- weight/sum.col1[fac1]
+ weight2 <- weight/sum.col2[fac2]
+ y.distri1 <- tapply(score * weight1, fac1, sum)
+ y.distri1 <- rank(y.distri1)
+ y.distri2 <- tapply(score * weight2, fac2, sum)
+ y.distri2 <- rank(y.distri2) + nvar1 + 2
+ y.distri <- c(y.distri1, y.distri2)
+ ylabel <- strheight("A", cex = par("cex") * max(1, clab1,
+ clab2)) * 1.4
+ y.distri1 <- (y.distri1 - min(y.distri))/(max(y.distri) -
+ min(y.distri))
+ y.distri1 <- ymin + ylabel + (ymax - ymin - 2 * ylabel) *
+ y.distri1
+ y.distri2 <- (y.distri2 - min(y.distri))/(max(y.distri) -
+ min(y.distri))
+ y.distri2 <- ymin + ylabel + (ymax - ymin - 2 * ylabel) *
+ y.distri2
+ for (i in 1:nvar1) {
+ w <- weight1[fac1 == levels(fac1)[i]]
+ y0 <- y.distri1[i]
+ score0 <- score[fac1 == levels(fac1)[i]]
+ x.moy <- sum(w * score0)
+ x.et <- sqrt(sum(w * (score0 - x.moy)^2))
+ x1 <- x.moy - cet * x.et
+ x2 <- x.moy + cet * x.et
+ etiagauche <- TRUE
+ if ((x1 - xmin) < (xmax - x2))
+ etiagauche <- FALSE
+ segments(x1, y0, x2, y0)
+ if (clab1 > 0) {
+ cha <- labels1[i]
+ cex0 <- par("cex") * clab1
+ xh <- strwidth(cha, cex = cex0)
+ xh <- xh + strwidth("x", cex = cex0)
+ yh <- strheight(cha, cex = cex0) * 5/6
+ if (etiagauche)
+ x0 <- x1 - xh/2
+ else x0 <- x2 + xh/2
+ rect(x0 - xh/2, y0 - yh, x0 + xh/2, y0 + yh,
+ col = "white", border = 1)
+ text(x0, y0, cha, cex = cex0)
+ }
+ points(x.moy, y0, pch = 20, cex = par("cex") * cpoi)
+ }
+ for (i in 1:nvar2) {
+ w <- weight2[fac2 == levels(fac2)[i]]
+ y0 <- y.distri2[i]
+ score0 <- score[fac2 == levels(fac2)[i]]
+ x.moy <- sum(w * score0)
+ x.et <- sqrt(sum(w * (score0 - x.moy)^2))
+ x1 <- x.moy - cet * x.et
+ x2 <- x.moy + cet * x.et
+ etiagauche <- TRUE
+ if ((x1 - xmin) < (xmax - x2))
+ etiagauche <- FALSE
+ segments(x1, y0, x2, y0)
+ if (clab2 > 0) {
+ cha <- labels2[i]
+ cex0 <- par("cex") * clab2
+ xh <- strwidth(cha, cex = cex0)
+ xh <- xh + strwidth("x", cex = cex0)
+ yh <- strheight(cha, cex = cex0) * 5/6
+ if (etiagauche)
+ x0 <- x1 - xh/2
+ else x0 <- x2 + xh/2
+ rect(x0 - xh/2, y0 - yh, x0 + xh/2, y0 + yh,
+ col = "white", border = 1)
+ text(x0, y0, cha, cex = cex0)
+ }
+ points(x.moy, y0, pch = 20, cex = par("cex") * cpoi)
+ }
+ }
+ if (inherits(x, "witwit")) {
+ y <- eval.parent(as.list(x$call)[[2]])
+ oritab <- eval.parent(as.list(y$call)[[2]])
+ }
+ else oritab <- eval.parent(as.list(x$call)[[2]])
+ l.names <- row.names(oritab)
+ c.names <- names(oritab)
+ oritab <- as.matrix(oritab)
+ a <- x$co[col(oritab), xax]
+ a <- a + x$li[row(oritab), xax]
+ a <- a/sqrt(2 * x$eig[xax] * (1 + sqrt(x$eig[xax])))
+ a <- a[oritab > 0]
+ aco <- col(oritab)[oritab > 0]
+ aco <- factor(aco)
+ levels(aco) <- c.names
+ ali <- row(oritab)[oritab > 0]
+ ali <- factor(ali)
+ levels(ali) <- l.names
+ aw <- oritab[oritab > 0]/sum(oritab)
+ sco.distri.class.2g(a, aco, ali, aw, clab1 = clab.c, clab2 = clab.r,
+ cpoi = cpoi, cet = cet)
+ scatterutil.sub("Rows", csub = csub, possub = "topleft")
+ scatterutil.sub("Columns", csub = csub, possub = "bottomright")
+}
+
+
+
+"reciprocal.coa" <- function (x) {
+ if (!inherits(x, "coa"))
+ stop("Object of class 'coa' expected")
+ if (inherits(x, "witwit")) {
+ y <- eval.parent(as.list(x$call)[[2]])
+ oritab <- eval.parent(as.list(y$call)[[2]])
+ }
+ else oritab <- eval.parent(as.list(x$call)[[2]])
+ l.names <- row.names(oritab)
+ c.names <- names(oritab)
+ oritab <- as.matrix(oritab)
+ f1 <- function(x,oritab,xax){
+ a <- x$co[col(oritab), xax]
+ a <- a + x$li[row(oritab), xax]
+ a <- a/sqrt(2 * x$eig[xax] * (1 + sqrt(x$eig[xax])))
+ a <- a[oritab > 0]
+ }
+ res <- sapply(1:x$nf,f1,x=x,oritab=oritab)
+ aco <- col(oritab)[oritab > 0]
+ aco <- factor(aco)
+ levels(aco) <- c.names
+ ali <- row(oritab)[oritab > 0]
+ ali <- factor(ali)
+ levels(ali) <- l.names
+ aw <- oritab[oritab > 0]/sum(oritab)
+ res <- cbind.data.frame(res,Row=ali,Col=aco,Weight=aw)
+ names(res)[1:x$nf] <- paste("Scor",1:x$nf,sep="")
+ rownames(res) <- paste(ali,aco,sep="")
+ return(res)
+}
diff --git a/R/score.mix.R b/R/score.mix.R
new file mode 100644
index 0000000..b4b52a7
--- /dev/null
+++ b/R/score.mix.R
@@ -0,0 +1,78 @@
+"score.mix" <- function (x, xax = 1, csub = 2, mfrow = NULL, which.var = NULL, ...) {
+ if (!inherits(x, "mix"))
+ stop("For 'mix' object")
+ if (x$nf == 1)
+ xax <- 1
+ lm.pcaiv <- function(x, df, weights, use) {
+ if (!inherits(df, "data.frame"))
+ stop("data.frame expected")
+ reponse.generic <- x
+ begin <- "reponse.generic ~ "
+ fmla <- as.formula(paste(begin, paste(names(df), collapse = "+")))
+ df <- cbind.data.frame(reponse.generic, df)
+ lm0 <- lm(fmla, data = df, weights = weights)
+ if (use == 0)
+ return(predict(lm0))
+ else if (use == 1)
+ return(residuals(lm0))
+ else if (use == -1)
+ return(lm0)
+ else stop("Non convenient use")
+ }
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ oritab <- eval.parent(as.list(x$call)[[2]])
+ nvar <- length(x$index)
+ if (is.null(which.var))
+ which.var <- (1:nvar)
+ index <- as.character(x$index)
+ if (is.null(mfrow))
+ par(mfrow = n2mfrow(length(which.var)))
+ if (prod(par("mfrow")) < length(which.var))
+ par(ask = TRUE)
+ sub <- names(oritab)
+ par(mar = c(2.6, 2.6, 1.1, 1.1))
+ score <- x$l1[, xax]
+ for (i in which.var) {
+ type.var <- index[i]
+ col.var <- which(x$assign == i)
+ if (type.var == "q") {
+ if (length(col.var) == 1) {
+ y <- x$tab[, col.var]
+ plot(score, y, type = "n")
+ points(score, y, pch = 20)
+ abline(lm(y ~ score), lwd = 2)
+ }
+ else {
+ y <- x$tab[, col.var]
+ plot(score, y[, 1], type = "n")
+ points(score, y[, 1], pch = 20)
+ score.est <- lm.pcaiv(score, y, w = rep(1, nrow(y))/nrow(y),
+ use = 0)
+ ord0 <- order(y[, 1])
+ lines(score.est[ord0], y[, 1][ord0], lwd = 2)
+ }
+ }
+ else if (type.var == "f") {
+ y <- oritab[, i]
+ moy <- unlist(tapply(score, y, mean))
+ plot(score, score, type = "n")
+ h <- (max(score) - min(score))/40
+ abline(h = moy)
+ segments(score, moy[y] - h, score, moy[y] + h)
+ abline(0, 1)
+ scatterutil.eti(moy, moy, label = as.character(levels(y)),
+ clabel = 1)
+ }
+ else if (type.var == "o") {
+ y <- x$tab[, col.var]
+ plot(score, y[, 1], type = "n")
+ points(score, y[, 1], pch = 20)
+ score.est <- lm.pcaiv(score, y, w = rep(1, nrow(y))/nrow(y),
+ use = 0)
+ ord0 <- order(y[, 1])
+ lines(score.est[ord0], y[, 1][ord0])
+ }
+ scatterutil.sub(sub[i], csub, "topleft")
+ }
+}
diff --git a/R/score.pca.R b/R/score.pca.R
new file mode 100644
index 0000000..c1a5b6f
--- /dev/null
+++ b/R/score.pca.R
@@ -0,0 +1,31 @@
+"score.pca" <- function (x, xax = 1, which.var = NULL, mfrow = NULL, csub = 2,
+ sub = names(x$tab), abline = TRUE, ...)
+{
+ if (!inherits(x, "pca"))
+ stop("Object of class 'pca' expected")
+ if (x$nf == 1)
+ xax <- 1
+ if ((xax < 1) || (xax > x$nf))
+ stop("non convenient axe number")
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ oritab <- eval.parent(as.list(x$call)[[2]])
+ nvar <- ncol(oritab)
+ if (is.null(which.var))
+ which.var <- (1:nvar)
+ if (is.null(mfrow))
+ mfrow <- n2mfrow(length(which.var))
+ par(mfrow = mfrow)
+ if (prod(par("mfrow")) < length(which.var))
+ par(ask = TRUE)
+ par(mar = c(2.6, 2.6, 1.1, 1.1))
+ score <- x$l1[, xax]
+ for (i in which.var) {
+ y <- oritab[, i]
+ plot(score, y, type = "n")
+ points(score, y, pch = 20)
+ if (abline)
+ abline(lm(y ~ score))
+ scatterutil.sub(sub[i], csub = csub, "topleft")
+ }
+}
diff --git a/R/sepan.R b/R/sepan.R
new file mode 100644
index 0000000..c3a9828
--- /dev/null
+++ b/R/sepan.R
@@ -0,0 +1,151 @@
+"sepan" <- function (X, nf = 2) {
+ if (!inherits(X, "ktab"))
+ stop("object 'ktab' expected")
+ complete.dudi <- function(dudi, nf1, nf2) {
+ pcolzero <- nf2 - nf1 + 1
+ w <- data.frame(matrix(0, nrow(dudi$li), pcolzero))
+ names(w) <- paste("Axis", (nf1:nf2), sep = "")
+ dudi$li <- cbind.data.frame(dudi$li, w)
+ w <- data.frame(matrix(0, nrow(dudi$li), pcolzero))
+ names(w) <- paste("RS", (nf1:nf2), sep = "")
+ dudi$l1 <- cbind.data.frame(dudi$l1, w)
+ w <- data.frame(matrix(0, nrow(dudi$co), pcolzero))
+ names(w) <- paste("Comp", (nf1:nf2), sep = "")
+ dudi$co <- cbind.data.frame(dudi$co, w)
+ w <- data.frame(matrix(0, nrow(dudi$co), pcolzero))
+ names(w) <- paste("CS", (nf1:nf2), sep = "")
+ dudi$c1 <- cbind.data.frame(dudi$c1, w)
+ return(dudi)
+ }
+ lw <- X$lw
+ cw <- X$cw
+ blo <- X$blo
+ ntab <- length(blo)
+ tab <- as.data.frame(X[[1]])
+ j1 <- 1
+ j2 <- as.numeric(blo[1])
+ auxi <- as.dudi(tab, col.w = cw[j1:j2], row.w = lw, nf = nf,
+ scannf = FALSE, call = match.call(), type = "sepan")
+ if (auxi$nf < nf)
+ auxi <- complete.dudi(auxi, auxi$nf + 1, nf)
+ Eig <- auxi$eig
+ Co <- auxi$co
+ Li <- auxi$li
+ C1 <- auxi$c1
+ L1 <- auxi$l1
+ row.names(Li) <- paste(row.names(Li), j1, sep = ".")
+ row.names(L1) <- paste(row.names(L1), j1, sep = ".")
+ row.names(Co) <- paste(row.names(Co), j1, sep = ".")
+ row.names(C1) <- paste(row.names(C1), j1, sep = ".")
+ rank <- auxi$rank
+ for (i in 2:ntab) {
+ j1 <- j2 + 1
+ j2 <- j2 + as.numeric(blo[i])
+ tab <- as.data.frame(X[[i]])
+ auxi <- as.dudi(tab, col.w = cw[j1:j2], row.w = lw, nf = nf,
+ scannf = FALSE, call = match.call(), type = "sepan")
+ Eig <- c(Eig, auxi$eig)
+ row.names(auxi$li) <- paste(row.names(auxi$li), i, sep = ".")
+ row.names(auxi$l1) <- paste(row.names(auxi$l1), i, sep = ".")
+ row.names(auxi$co) <- paste(row.names(auxi$co), i, sep = ".")
+ row.names(auxi$c1) <- paste(row.names(auxi$c1), i, sep = ".")
+ if (auxi$nf < nf)
+ auxi <- complete.dudi(auxi, auxi$nf + 1, nf)
+ Co <- rbind.data.frame(Co, auxi$co)
+ Li <- rbind.data.frame(Li, auxi$li)
+ C1 <- rbind.data.frame(C1, auxi$c1)
+ L1 <- rbind.data.frame(L1, auxi$l1)
+ rank <- c(rank, auxi$rank)
+ }
+ res <- list()
+ res$Li <- Li
+ res$L1 <- L1
+ res$Co <- Co
+ res$C1 <- C1
+ res$Eig <- Eig
+ res$TL <- X$TL
+ res$TC <- X$TC
+ res$T4 <- X$T4
+ res$blo <- blo
+ res$rank <- rank
+ res$tab.names <- names(X)[1:ntab]
+ res$call <- match.call()
+ class(res) <- c("sepan", "list")
+ return(res)
+}
+
+"summary.sepan" <- function (object, ...) {
+ if (!inherits(object, "sepan"))
+ stop("to be used with 'sepan' object")
+ cat("Separate Analyses of a 'ktab' object\n")
+ x1 <- object$tab.names
+ ntab <- length(x1)
+ indica <- factor(rep(1:length(object$blo), object$rank))
+ nrow <- nlevels(object$TL[, 2])
+ sumry <- array("", c(ntab, 9), list(1:ntab, c("names", "nrow",
+ "ncol", "rank", "lambda1", "lambda2", "lambda3", "lambda4",
+ "")))
+ for (k in 1:ntab) {
+ eig <- zapsmall(object$Eig[indica == k], digits = 4)
+ l0 <- min(length(eig), 4)
+ sumry[k, 4 + (1:l0)] <- round(eig[1:l0], digits = 3)
+ if (length(eig) > 4)
+ sumry[k, 9] <- "..."
+ }
+ sumry[, 1] <- x1
+ sumry[, 2] <- rep(nrow, ntab)
+ sumry[, 3] <- object$blo
+ sumry[, 4] <- object$rank
+
+ print(sumry, quote = FALSE)
+}
+
+"plot.sepan" <- function (x, mfrow = NULL, csub = 2, ...) {
+ if (!inherits(x, "sepan"))
+ stop("Object of type 'sepan' expected")
+ opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
+ on.exit(par(opar))
+ par(mar = c(0.6, 2.6, 0.6, 0.6))
+ nbloc <- length(x$blo)
+ if (is.null(mfrow))
+ mfrow <- n2mfrow(nbloc)
+ par(mfrow = mfrow)
+ if (nbloc > prod(mfrow))
+ par(ask = TRUE)
+ rank.fac <- factor(rep(1:nbloc, x$rank))
+ nf <- ncol(x$Li)
+ neig <- max(x$rank)
+ maxeig <- max(x$Eig)
+ for (ianal in 1:nbloc) {
+ w <- x$Eig[rank.fac == ianal]
+ scatterutil.eigen(w, xmax = neig, ymax = maxeig, wsel = 1:nf,
+ sub = x$tab.names[ianal], csub = csub, possub = "topright",yaxt="s")
+ }
+}
+
+"print.sepan" <- function (x, ...) {
+ if (!inherits(x, "sepan"))
+ stop("to be used with 'sepan' object")
+ cat("class:", class(x), "\n")
+ cat("$call: ")
+ print(x$call)
+ sumry <- array("", c(4, 4), list(1:4, c("vector", "length",
+ "mode", "content")))
+ sumry[1, ] <- c("$tab.names", length(x$tab.names), mode(x$tab.names),
+ "tab names")
+ sumry[2, ] <- c("$blo", length(x$blo), mode(x$blo), "column number")
+ sumry[3, ] <- c("$rank", length(x$rank), mode(x$rank), "tab rank")
+ sumry[4, ] <- c("$Eig", length(x$Eig), mode(x$Eig), "All the eigen values")
+
+ print(sumry, quote = FALSE)
+ sumry <- array("", c(6, 4), list(1:6, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$Li", nrow(x$Li), ncol(x$Li), "row coordinates")
+ sumry[2, ] <- c("$L1", nrow(x$L1), ncol(x$L1), "row normed scores")
+ sumry[3, ] <- c("$Co", nrow(x$Co), ncol(x$Co), "column coordinates")
+ sumry[4, ] <- c("$C1", nrow(x$C1), ncol(x$C1), "column normed coordinates")
+ sumry[5, ] <- c("$TL", nrow(x$TL), ncol(x$TL), "factors for Li L1")
+ sumry[6, ] <- c("$TC", nrow(x$TC), ncol(x$TC), "factors for Co C1")
+
+ print(sumry, quote = FALSE)
+}
diff --git a/R/statico.R b/R/statico.R
new file mode 100755
index 0000000..0ebe57b
--- /dev/null
+++ b/R/statico.R
@@ -0,0 +1,77 @@
+"statico" <- function (KTX, KTY, scannf = TRUE) {
+####
+#### STATICO analysis
+#### k-table analysis of the cross-tables at each date of two ktabs
+#### Jean Thioulouse, 06 Nov 2009
+#### This function takes 2 ktabs. It crosses each pair of tables of these ktabs
+#### and does a partial triadic analysis on this new ktab.
+####
+ if (!inherits(KTX, "ktab")) stop("The first argument must be a 'ktab'")
+ if (!inherits(KTY, "ktab")) stop("The second argument must be a 'ktab'")
+#### Parameters of first ktab
+ lwX <- KTX$lw
+ cwX <- KTX$cw
+ ncolX <- length(cwX)
+ bloX <- KTX$blo
+ ntabX <- length(KTX$blo)
+#### Parameters of second ktab
+ lwY <- KTY$lw
+ nligY <- length(lwY)
+ cwY <- KTY$cw
+ ncolY <- length(cwY)
+ bloY <- KTY$blo
+ ntabY <- length(KTY$blo)
+#### Tests of coherence of the two ktabs
+ if (ncolX != ncolY) stop("The two ktabs must have the same column numbers")
+ if (any(cwX != cwY)) stop("The two ktabs must have the same column weights")
+ if (ntabX != ntabY) stop("The two ktabs must have the same number of tables")
+ if (!all(bloX == bloY)) stop("The two tables of one pair must have the same number of columns")
+#### compute the crossed ktab
+ kcoi <- ktab.match2ktabs(KTX, KTY)
+#### pta on the ktab
+ res <- pta(kcoi, scannf = scannf)
+ return(res)
+}
+
+"statico.krandtest" <- function (KTX, KTY, nrepet = 999, ...) {
+ if (!inherits(KTX, "ktab")) stop("The first argument must be the environmental 'ktab'")
+ if (!inherits(KTY, "ktab")) stop("The second argument must be the species 'ktab'")
+#### crossed ktab
+ res <- list()
+#### Parameters of first ktab
+ lwX <- KTX$lw
+ cwX <- KTX$cw
+ ncolX <- length(cwX)
+ bloX <- KTX$blo
+ ntabX <- length(KTX$blo)
+#### Parameters of second ktab
+ lwY <- KTY$lw
+ nligY <- length(lwY)
+ cwY <- KTY$cw
+ ncolY <- length(cwY)
+ bloY <- KTY$blo
+ ntabY <- length(KTY$blo)
+#### Tests of coherence of the two ktabs
+ if (ncolX != ncolY) stop("The two ktabs must have the same column numbers")
+ if (any(cwX != cwY)) stop("The two ktabs must have the same column weights")
+ if (ntabX != ntabY) stop("The two ktabs must have the same number of tables")
+ if (!all(bloX == bloY)) stop("The two tables of one pair must have the same number of columns")
+ ntab <- ntabX
+ indica <- as.factor(rep(1:ntab, KTX$blo))
+ lw <- split(cwX, indica)
+ ksim <- matrix(0, nrow=nrepet, ncol=ntab, dimnames=list(NULL, tab.names(KTX)))
+ kobs <- vector("numeric", ntab)
+#### Compute coinertias and randtests
+ for (i in 1:ntab) {
+ tx <- t(as.matrix(KTX[[i]]))
+ ty <- t(as.matrix(KTY[[i]]))
+ pcax <- dudi.pca(tx, row.w=lw[[i]], col.w=lwX, scannf=FALSE)
+ pcay <- dudi.pca(ty, scale = FALSE, row.w=lw[[i]], col.w=lwY, scannf=FALSE)
+ coin1 <- coinertia(pcax, pcay, scannf=FALSE)
+ tmp <- randtest(coin1, nrepet = nrepet, output = "full")
+ ksim[,i] <- tmp$sim
+ kobs[i] <- tmp$obs
+ }
+#### Return a krandtest
+ as.krandtest(ksim, kobs, call = match.call(), ...)
+}
diff --git a/R/statis.R b/R/statis.R
new file mode 100644
index 0000000..53351f8
--- /dev/null
+++ b/R/statis.R
@@ -0,0 +1,206 @@
+"statis" <- function (X, scannf = TRUE, nf = 3, tol = 1e-07) {
+ if (!inherits(X, "ktab"))
+ stop("object 'ktab' expected")
+ lw <- X$lw
+ nlig <- length(lw)
+ cw <- X$cw
+ ncol <- length(cw)
+ ntab <- length(X$blo)
+ indicablo <- X$TC[, 1]
+ tab.names <- tab.names(X)
+ auxinames <- ktab.util.names(X)
+ statis <- list()
+ sep <- list()
+ lwsqrt <- sqrt(lw)
+ for (k in 1:ntab) {
+ ak <- sqrt(cw[indicablo == levels(X$TC[,1])[k]])
+ wk <- as.matrix(X[[k]]) * lwsqrt
+ wk <- t(t(wk) * ak)
+ wk <- wk %*% t(wk)
+ sep[[k]] <- wk
+ }
+ ############## calcul des RV ###########
+ sep <- matrix(unlist(sep), nlig * nlig, ntab)
+ RV <- t(sep) %*% sep
+ ak <- sqrt(diag(RV))
+ RV <- sweep(RV, 1, ak, "/")
+ RV <- sweep(RV, 2, ak, "/")
+ dimnames(RV) <- list(tab.names, tab.names)
+ statis$RV <- RV
+ ############## diagonalisation de la matrice des RV ###########
+ eig1 <- eigen(RV, symmetric = TRUE)
+ statis$RV.eig <- eig1$values
+ if (any(eig1$vectors[, 1] < 0))
+ eig1$vectors[, 1] <- -eig1$vectors[, 1]
+ tabw <- eig1$vectors[, 1]
+ statis$RV.tabw <- tabw
+ w <- t(t(eig1$vectors) * sqrt(eig1$values))
+ w <- as.data.frame(w)
+ row.names(w) <- tab.names
+ names(w) <- paste("S", 1:ncol(w), sep = "")
+ statis$RV.coo <- w[, 1:min(4, ncol(w))]
+ ############## combinaison des operateurs d'inertie normes ###########
+ sep <- t(t(sep)/ak)
+ C.ro <- rowSums(sweep(sep,2,tabw,"*"))
+ C.ro <- matrix(unlist(C.ro), nlig, nlig)
+ ############## diagonalisation du compromis ###########
+ eig1 <- eigen(C.ro, symmetric = TRUE)
+ rm(C.ro)
+ eig <- eig1$values
+ rank <- sum((eig/eig[1]) > tol)
+ if (scannf) {
+ barplot(eig[1:rank])
+ cat("Select the number of axes: ")
+ nf <- as.integer(readLines(n = 1))
+ }
+ if (nf <= 0)
+ nf <- 2
+ if (nf > rank)
+ nf <- rank
+ statis$C.eig <- eig[1:rank]
+ statis$C.nf <- nf
+ statis$C.rank <- rank
+ wref <- eig1$vectors[, 1:nf]
+ rm(eig1)
+ wref <- wref/lwsqrt
+ w <- data.frame(t(t(wref) * sqrt(eig[1:nf])))
+ row.names(w) <- row.names(X)
+ names(w) <- paste("C", 1:nf, sep = "")
+ statis$C.li <- w
+ w <- as.matrix(X[[1]])
+ for (k in 2:ntab) {
+ w <- cbind(w, as.matrix(X[[k]]))
+ }
+ w <- w * lw
+ w <- t(w) %*% wref
+ w <- data.frame(w, row.names = auxinames$col)
+ names(w) <- paste("C", 1:nf, sep = "")
+ statis$C.Co <- w
+ sepanL1 <- sepan(X, nf = 4)$L1
+ w <- matrix(0, ntab * 4, nf)
+ i1 <- 0
+ i2 <- 0
+ for (k in 1:ntab) {
+ i1 <- i2 + 1
+ i2 <- i2 + 4
+ tab <- as.matrix(sepanL1[X$TL[, 1] == levels(X$TL[,1])[k], ])
+ tab <- t(tab * lw) %*% wref
+ for (i in 1:min(nf, 4)) {
+ if (tab[i, i] < 0) {
+ for (j in 1:nf) tab[i, j] <- -tab[i, j]
+ }
+ }
+ w[i1:i2, ] <- tab
+ }
+ w <- data.frame(w, row.names = auxinames$tab)
+ names(w) <- paste("C", 1:nf, sep = "")
+ statis$C.T4 <- w
+ w <- as.matrix(statis$C.li) * lwsqrt
+ w <- w %*% t(w)
+ w <- w/sqrt(sum(w * w))
+ w <- as.vector(unlist(w))
+ sep <- sep * unlist(w)
+ w <- apply(sep, 2, sum)
+ statis$cos2 <- w
+ statis$tab.names <- tab.names
+ statis$TL <- X$TL
+ statis$TC <- X$TC
+ statis$T4 <- X$T4
+ class(statis) <- "statis"
+ return(statis)
+}
+
+"plot.statis" <- function (x, xax = 1, yax = 2, option = 1:4, ...) {
+ if (!inherits(x, "statis"))
+ stop("Object of type 'statis' expected")
+ nf <- x$C.nf
+ if (xax > nf)
+ stop("Non convenient xax")
+ if (yax > nf)
+ stop("Non convenient yax")
+ opar <- par(mar = par("mar"), mfrow = par("mfrow"), xpd = par("xpd"))
+ on.exit(par(opar))
+ mfrow <- n2mfrow(length(option))
+ par(mfrow = mfrow)
+ for (j in option) {
+ if (j == 1) {
+ coolig <- x$RV.coo[, c(1, 2)]
+ s.corcircle(coolig, label = x$tab.names,
+ cgrid = 0, sub = "Interstructure", csub = 1.5,
+ possub = "topleft", fullcircle = TRUE)
+ l0 <- length(x$RV.eig)
+ add.scatter.eig(x$RV.eig, l0, 1, 2, posi = "bottomleft",
+ ratio = 1/4)
+ }
+ if (j == 2) {
+ coolig <- x$C.li[, c(xax, yax)]
+ s.label(coolig, sub = "Compromise", csub = 1.5,
+ possub = "topleft", )
+ add.scatter.eig(x$C.eig, x$C.nf, xax, yax,
+ posi = "bottomleft", ratio = 1/4)
+ }
+ if (j == 4) {
+ cooax <- x$C.T4[x$T4[, 2] == 1, ]
+ s.corcircle(cooax, xax, yax, fullcircle = TRUE, sub = "Component projection",
+ possub = "topright", csub = 1.5)
+ add.scatter.eig(x$C.eig, x$C.nf, xax, yax,
+ posi = "bottomleft", ratio = 1/5)
+ }
+ if (j == 3) {
+ plot(x$RV.tabw, x$cos2, xlab = "Tables weights",
+ ylab = "Cos 2")
+ scatterutil.grid(0)
+ title(main = "Typological value")
+ par(xpd = TRUE)
+ scatterutil.eti(x$RV.tabw, x$cos2, label = x$tab.names,
+ clabel = 1)
+ }
+ }
+}
+
+"print.statis" <- function (x, ...) {
+ cat("STATIS Analysis\n")
+ cat("class:")
+ cat(class(x), "\n")
+ cat("table number:", length(x$RV.tabw), "\n")
+ cat("row number:", nrow(x$C.li), " total column number:",
+ nrow(x$C.Co), "\n")
+ cat("\n **** Interstructure ****\n")
+ cat("\neigen values: ")
+ l0 <- length(x$RV.eig)
+ cat(signif(x$RV.eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n")
+ else cat("\n")
+ cat(" $RV matrix ", nrow(x$RV), " ", ncol(x$RV), " RV coefficients\n")
+ cat(" $RV.eig vector ", length(x$RV.eig), " eigenvalues\n")
+ cat(" $RV.coo data.frame ", nrow(x$RV.coo), " ", ncol(x$RV.coo),
+ " array scores\n")
+ cat(" $tab.names vector ", length(x$tab.names), " array names\n")
+ cat(" $RV.tabw vector ", length(x$RV.tabw), " array weigths\n")
+ cat("\nRV coefficient\n")
+ w <- x$RV
+ w[row(w) < col(w)] <- NA
+ print(w, na = "")
+ cat("\n **** Compromise ****\n")
+ cat("\neigen values: ")
+ l0 <- length(x$C.eig)
+ cat(signif(x$C.eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n")
+ else cat("\n")
+ cat("\n $nf:", x$C.nf, "axis-components saved")
+ cat("\n $rank: ")
+ cat(x$C.rank, "\n")
+ sumry <- array("", c(6, 4), list(rep("", 6), c("data.frame",
+ "nrow", "ncol", "content")))
+ sumry[1, ] <- c("$C.li", nrow(x$C.li), ncol(x$C.li), "row coordinates")
+ sumry[2, ] <- c("$C.Co", nrow(x$C.Co), ncol(x$C.Co), "column coordinates")
+ sumry[3, ] <- c("$C.T4", nrow(x$C.T4), ncol(x$C.T4), "principal vectors (each table)")
+ sumry[4, ] <- c("$TL", nrow(x$TL), ncol(x$TL), "factors (not used)")
+ sumry[5, ] <- c("$TC", nrow(x$TC), ncol(x$TC), "factors for Co")
+ sumry[6, ] <- c("$T4", nrow(x$T4), ncol(x$T4), "factors for T4")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+}
diff --git a/R/summary.4thcorner.R b/R/summary.4thcorner.R
new file mode 100644
index 0000000..eb89f60
--- /dev/null
+++ b/R/summary.4thcorner.R
@@ -0,0 +1,38 @@
+"summary.4thcorner" <- function(object,...){
+
+ cat("Fourth-corner Statistics\n")
+ cat("------------------------\n")
+ cat("Permutation method ",object$model," (",object$npermut," permutations)\n")
+ if(inherits(object, "4thcorner.rlq")){
+ cat("trRLQ statistic","\n\n")
+ cat("---\n\n")
+ print(object$trRLQ)
+ } else {
+ cat("\nAdjustment method for multiple comparisons: ", object$tabG$adj.method, "\n")
+
+
+ xrand <- object$tabG
+ sumry <- list(Test = xrand$names, Stat= xrand$statnames, Obs = xrand$obs, Std.Obs = xrand$expvar[, 1], Alter = xrand$alter)
+ sumry <- as.matrix(as.data.frame(sumry))
+ if (any(xrand$rep[1] != xrand$rep)) {
+ sumry <- cbind(sumry[, 1:4], N.perm = xrand$rep)
+ }
+
+ sumry <- cbind(sumry, Pvalue = format.pval(xrand$pvalue))
+
+ if (xrand$adj.method != "none") {
+ sumry <- cbind(sumry, Pvalue.adj = format.pval(xrand$adj.pvalue))
+ }
+ signifpval <- symnum(xrand$adj.pvalue, corr = FALSE, na = FALSE, cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), symbols = c("***", "**", "*", ".", " "))
+ sumry <- cbind(sumry,signifpval)
+ colnames(sumry)[ncol(sumry)] <- " "
+ rownames(sumry) <- 1:nrow(sumry)
+
+ print(sumry, quote = FALSE, right = TRUE)
+
+ cat("\n---\nSignif. codes: ", attr(signifpval, "legend"), "\n")
+ invisible(sumry)
+ }
+
+}
+
diff --git a/R/supcol.R b/R/supcol.R
new file mode 100644
index 0000000..cd1fe5d
--- /dev/null
+++ b/R/supcol.R
@@ -0,0 +1,36 @@
+"supcol" <- function (x, ...) UseMethod("supcol")
+
+"supcol.coa" <- function (x, Xsup, ...) {
+ # modif pour Culhane, Aedin" <a.culhane at ucc.ie>
+ # supcol renvoie une liste à deux éléments tabsup et cosup
+ Xsup <- data.frame(Xsup)
+ if (!inherits(x, "dudi"))
+ stop("Object of class 'dudi' expected")
+ if (!inherits(x, "coa"))
+ stop("Object of class 'coa' expected")
+ if (!inherits(Xsup, "data.frame"))
+ stop("Xsup is not a data.frame")
+ if (nrow(Xsup) != nrow(x$tab))
+ stop("non convenient row numbers")
+ cwsup <- apply(Xsup, 2, sum)
+ cwsup[cwsup == 0] <- 1
+ Xsup <- sweep(Xsup, 2, cwsup, "/")
+ coosup <- t(as.matrix(Xsup)) %*% as.matrix(x$l1)
+ coosup <- data.frame(coosup, row.names = names(Xsup))
+ names(coosup) <- names(x$co)
+ return(list(tabsup=Xsup, cosup=coosup))
+}
+
+"supcol.dudi" <- function (x, Xsup, ...) {
+ Xsup <- data.frame(Xsup)
+ if (!inherits(x, "dudi"))
+ stop("Object of class 'dudi' expected")
+ if (!inherits(Xsup, "data.frame"))
+ stop("Xsup is not a data.frame")
+ if (nrow(Xsup) != nrow(x$tab))
+ stop("non convenient row numbers")
+ coosup <- t(as.matrix(Xsup)) %*% (as.matrix(x$l1) * x$lw)
+ coosup <- data.frame(coosup, row.names = names(Xsup))
+ names(coosup) <- names(x$co)
+ return(list(tabsup=Xsup, cosup=coosup))
+}
diff --git a/R/supdist.R b/R/supdist.R
new file mode 100644
index 0000000..a664272
--- /dev/null
+++ b/R/supdist.R
@@ -0,0 +1,66 @@
+"supdist" <- function (d, fsup, tol = 1e-07)
+{
+#
+# This function takes a distance matrix between Supplementary and Active items.
+# It computes the PCO of the distance matrix between Active items, and projects
+# the distance matrix between Supplementary and Active elements in this PCO.
+# Jean Thioulouse 06/2017. Based on : https://doi.org/10.1371/journal.pone.0019094
+#
+ if (!inherits(d, "dist"))
+ stop("Distance matrix expected")
+ n <- attr(d, "Size")
+ if (class(fsup) != "factor")
+ stop("Argument fsup must be a factor")
+ if (length(fsup) != attr(d, "Size"))
+ stop("Incompatible factor length")
+ if (length(levels(fsup)) != 2)
+ stop("The factor must have exactly two levels")
+ if (any(levels(fsup) != c("A","S")))
+ stop("The factor must give the Active (A) / Supplementary (S) status for each item in the distance matrix")
+
+ # distance matrix between Supplementary and Active items
+ DSup <- as.matrix(d)[fsup == "S", fsup == "A", drop = FALSE]
+ nS <- table(fsup)[2]
+ nA <- table(fsup)[1]
+ nT <- nS + nA
+ Id <- diag(nrow = nA)
+ One <- matrix(1, nrow = nA, ncol = nA)
+
+ # distance matrix between Active items
+ DAct <- as.matrix(d)[fsup == "A", fsup == "A"]
+ # squared distances
+ DAct <- DAct * DAct
+ # Double centering, cross-product matrix
+ SAct <- -0.5 * (Id - One * 1 / nA) %*% DAct %*% (Id - One * 1 / nA)
+
+ # PCO of Active items
+ eigAct<- eigen(SAct)
+ rAct <- sum(eigAct$values > (eigAct$values[1] * tol))
+ # coordinates of Active items
+ FAct <- t(t(eigAct$vectors[, 1:rAct]) * sqrt(eigAct$values[1:rAct]))
+
+ OneS <- matrix(1, nrow = nS, ncol = nA)
+ # squared distances between Supplementary and Active items
+ DSup <- DSup * DSup
+ # Double centering, cross-product matrix
+ SSup <- -0.5 * (Id - One * 1 / nA) %*% (t(DSup) - DAct %*% t(OneS) * 1 / nA)
+ # coordinates of Supplementary items
+ FSup <- t(SSup) %*% t(t(FAct) * 1 / eigAct$values[1:rAct])
+
+ # conversion to dataframes and creation of the returned object
+ # Supplementary items
+ FSup <- as.data.frame(FSup)
+ names(FSup) <- paste("A", 1:rAct, sep = "")
+ row.names(FSup) <- attr(d, "Labels")[fsup == "S"]
+
+ # Active items
+ FAct <- as.data.frame(FAct)
+ names(FAct) <- paste("A", 1:rAct, sep = "")
+ row.names(FAct) <- attr(d, "Labels")[fsup == "A"]
+
+ # Active + Supplementary items
+ FTot <- rbind.data.frame(FAct, FSup)
+
+ res <- list(coordSup = FSup, coordAct = FAct, coordTot = FTot)
+ return(res)
+}
diff --git a/R/suprow.R b/R/suprow.R
new file mode 100644
index 0000000..548baa6
--- /dev/null
+++ b/R/suprow.R
@@ -0,0 +1,143 @@
+"suprow" <- function (x, ...) UseMethod("suprow")
+
+"predict.dudi" <- function(object, newdata, ...){
+ return(suprow(x = object, Xsup = newdata, ...)$lisup)
+}
+
+"suprow.coa" <- function (x, Xsup, ...) {
+ Xsup <- data.frame(Xsup)
+ if (!inherits(x, "dudi"))
+ stop("Object of class 'dudi' expected")
+ if (!inherits(x, "coa"))
+ stop("Object of class 'coa' expected")
+ if (!inherits(Xsup, "data.frame"))
+ stop("Xsup is not a data.frame")
+ if (ncol(Xsup) != ncol(x$tab))
+ stop("non convenient col numbers")
+ lwsup <- apply(Xsup, 1, sum)
+ lwsup[lwsup == 0] <- 1
+ Xsup <- sweep(Xsup, 1, lwsup, "/")
+ coosup <- as.matrix(Xsup) %*% as.matrix(x$c1)
+ coosup <- data.frame(coosup, row.names = row.names(Xsup))
+ names(coosup) <- names(x$li)
+ # bug 25/11/2004 On reproduisait bien les coordonnées supplémentaires
+ # mais pas les valeurs du tableau, donc pas de transferts possibles en inter-intra
+ # voir fiche QR8
+ cwsup <- x$cw
+ cwsup[cwsup == 0] <- 1
+ Xsup <- sweep(Xsup, 2, cwsup, "/")
+ # le centrage n'est pas indispensable
+ Xsup <- Xsup-1
+ Xsup[,cwsup == 1] <- 0
+ return(list(tabsup = Xsup, lisup = coosup))
+}
+
+"suprow.dudi" <- function (x, Xsup, ...) {
+ # modif pour Culhane, Aedin" <a.culhane at ucc.ie>
+ # suprow renvoie une liste à deux éléments tabsup et lisup
+ warning("The use of the 'suprow.dudi' method requires that the
+ supplementary table has been transformed as the original table")
+ Xsup <- data.frame(Xsup)
+ if (!inherits(x, "dudi"))
+ stop("Object of class 'dudi' expected")
+ if (!inherits(Xsup, "data.frame"))
+ stop("Xsup is not a data.frame")
+ if (ncol(Xsup) != ncol(x$tab))
+ stop("non convenient col numbers")
+ # bug 25/11/2004 vue par fiche QR8
+ coosup <- as.matrix(Xsup) %*% (as.matrix(x$c1) * x$cw)
+ coosup <- data.frame(coosup, row.names = row.names(Xsup))
+ names(coosup) <- names(x$li)
+ return(list(tabsup = Xsup, lisup = coosup))
+}
+
+"suprow.pca" <- function (x, Xsup, ...) {
+ Xsup <- data.frame(Xsup)
+ if (!inherits(x, "dudi"))
+ stop("Object of class 'dudi' expected")
+ if (!inherits(x, "pca"))
+ stop("Object of class 'pca' expected")
+ if (!inherits(Xsup, "data.frame"))
+ stop("Xsup is not a data.frame")
+ if (ncol(Xsup) != ncol(x$tab))
+ stop("non convenient col numbers")
+ f1 <- function(w) (w - x$cent)/x$norm
+ Xsup <- t(apply(Xsup, 1, f1))
+ coosup <- as.matrix(Xsup) %*% (as.matrix(x$c1) * x$cw)
+ coosup <- data.frame(coosup, row.names = row.names(Xsup))
+ names(coosup) <- names(x$li)
+ return(list(tabsup = Xsup, lisup = coosup))
+}
+
+"suprow.acm" <- function (x, Xsup, ...) {
+ Xsup <- data.frame(Xsup)
+ if (!inherits(x, "dudi"))
+ stop("Object of class 'dudi' expected")
+ if (!inherits(x, "acm"))
+ stop("Object of class 'acm' expected")
+ if (!inherits(Xsup, "data.frame"))
+ stop("Xsup is not a data.frame")
+ if (ncol(Xsup) != nrow(x$cr))
+ stop("non convenient col numbers")
+
+ appel <- as.list(x$call)
+ Xori <- as.data.frame(eval.parent(appel$df))
+ for(j in 1:ncol(Xsup)){
+ ## modify Xsup to ensure that factors have the same levels
+ ## than the original table
+ Xsup[,j] <- factor(Xsup[,j], levels = levels(Xori[,j]))
+ if(any(is.na(Xsup[,j])))
+ stop(paste("the factor", names(Xsup)[j] ,"in Xsup contains unknown levels)"))
+ }
+
+ nvar <- ncol(Xsup)
+ Xsup <- acm.disjonctif(Xsup)
+ Xsup <- t(t(Xsup)/ (x$cw * nvar)) - 1
+ coosup <- Xsup %*% (as.matrix(x$c1) * x$cw)
+ coosup <- data.frame(coosup, row.names = row.names(Xsup))
+ names(coosup) <- names(x$li)
+ return(list(tabsup = Xsup, lisup = coosup))
+}
+
+
+"suprow.mix" <- function (x, Xsup, ...) {
+ Xsup <- data.frame(Xsup)
+ appel <- as.list(x$call)
+ if (!inherits(x, "dudi"))
+ stop("Object of class 'dudi' expected")
+ if (!inherits(x, "mix"))
+ stop("Object of class 'mix' expected")
+ if (appel[[1]] != "dudi.hillsmith")
+ stop("Not yet implemented for 'dudi.mix'. Please use 'dudi.hillsmith'.")
+ if (!inherits(Xsup, "data.frame"))
+ stop("Xsup is not a data.frame")
+ if (ncol(Xsup) != nrow(x$cr))
+ stop("non convenient col numbers")
+
+ Xori <- as.data.frame(eval.parent(appel$df))
+ res <- matrix(0, nrow(Xsup), 1)
+ for(j in 1:ncol(Xsup)){
+ if (x$index[j] == "q") {
+ var.tmp <- scale(Xsup[,j], scale = x$norm[j], center = x$center[j])
+ res <- cbind(res, var.tmp)
+ } else if(x$index[j] == "f"){
+ ## modify Xsup to ensure that factors have the same levels
+ ## than the original table
+ Xsup[,j] <- factor(Xsup[,j], levels = levels(factor(Xori[,j])))
+ if(any(is.na(Xsup[,j])))
+ stop(paste("the factor", names(Xsup)[j] ,"in Xsup contains unknown levels)"))
+ var.tmp <- fac2disj(Xsup[, j], drop = FALSE)
+ col.w <- x$cw[x$assign == j]
+ var.tmp <- t(t(var.tmp)/col.w) - 1
+ res <- cbind(res, var.tmp)
+ }
+ }
+
+ res <- res[,-1]
+ coosup <- res %*% (as.matrix(x$c1) * x$cw)
+ coosup <- data.frame(coosup, row.names = row.names(Xsup))
+ names(coosup) <- names(x$li)
+ res <- data.frame(res, row.names = row.names(Xsup))
+ names(res) <- names(x$tab)
+ return(list(tabsup = res, lisup = coosup))
+}
diff --git a/R/symbols.phylog.R b/R/symbols.phylog.R
new file mode 100644
index 0000000..4846462
--- /dev/null
+++ b/R/symbols.phylog.R
@@ -0,0 +1,146 @@
+"symbols.phylog" <- function (phylog, circles, squares, csize = 1, clegend = 1, sub = "",
+ csub = 1, possub = "topleft")
+{
+ if (!inherits(phylog, "phylog"))
+ stop("Non convenient data")
+ count <- 0
+ if (!missing(circles)) {
+ count <- count + 1
+ data <- circles
+ type <- 2
+ }
+ if (!missing(squares)) {
+ count <- count + 1
+ data <- squares
+ type <- 1
+ }
+ if (count > 1)
+ stop("no more than one symbol type must be specified")
+ if (csize <= 0) {
+ data <- NULL
+ }
+ if (!is.null(data)) {
+ if (is.null(names(data)))
+ names(data) <- names(phylog$leaves)
+ if (length(data) != length(phylog$leaves)) data <- NULL
+ if (!is.null(data)) {
+ w1 <- sort(names(data))
+ w2 <- sort(names(phylog$leaves))
+ if (!all(w1 == w2)) {
+ print(w1)
+ print(w2)
+ warning("names(data) non convenient for 'phylog' : we use the names of the leaves in 'phylog'")
+ names(data) <- names(phylog$leaves)
+ }
+ data <- data[names(phylog$leaves)]
+ }
+ }
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n",
+ yaxt = "n", ylim = c(-0.2, 1.05), xlim = c(0, 1), xaxs = "i",
+ yaxs = "i", frame.plot = TRUE)
+ symbol.max <- csize/20
+ if (symbol.max > 0.5)
+ symbol.max <- 0.5
+ dis <- phylog$droot
+ dis <- 1 - ((1 - symbol.max) * dis/max(dis))
+ xinit <- dis[names(phylog$leaves)]
+ dn <- dis[names(phylog$nodes)]
+ n <- length(xinit)
+ yinit <- (n:1)/(n + 1)
+ names(yinit) <- names(phylog$leaves)
+ x <- dis
+ yn <- rep(0, length(dn))
+ names(yn) <- names(dn)
+ y <- c(yinit, yn)
+ legender <- function(br0, sq0, sig0, clegend, type) {
+ br0 <- round(br0, digits = 6)
+ cha <- as.character(br0[1])
+ for (i in (2:(length(br0)))) cha <- paste(cha, br0[i],
+ sep = " ")
+ cex0 <- par("cex") * clegend
+ yh <- max(c(strheight(cha, cex = cex0), sq0))
+ h <- strheight(cha, cex = cex0)
+ y0 <- par("usr")[3] + yh/2 + h
+ x0 <- par("usr")[1] + h/2
+ for (i in (1:(length(sq0)))) {
+ cha <- br0[i]
+ cha <- paste(" ", cha, sep = "")
+ xh <- strwidth(cha, cex = cex0)
+ text(x0 + xh/2, y0, cha, cex = cex0)
+ z0 <- sq0[i]
+ x0 <- x0 + xh + z0/2
+ if (sig0[i] >= 0) {
+ if (type == 1)
+ symbols(x0, y0, squares = z0, bg = "black",
+ fg = "white", add = TRUE, inches = FALSE)
+ else if (type == 2)
+ symbols(x0, y0, circles = z0/2, bg = "black",
+ fg = "white", add = TRUE, inches = FALSE)
+ }
+ else {
+ if (type == 1)
+ symbols(x0, y0, squares = z0, bg = "white",
+ fg = "black", add = TRUE, inches = FALSE)
+ else if (type == 2)
+ symbols(x0, y0, circles = z0/2, bg = "white",
+ fg = "black", add = TRUE, inches = FALSE)
+ }
+ x0 <- x0 + z0/2
+ }
+ invisible()
+ }
+ for (i in 1:length(phylog$parts)) {
+ w <- phylog$parts[[i]]
+ but <- names(phylog$parts)[i]
+ y[but] <- mean(y[w])
+ b <- range(y[w])
+ segments(b[1], x[but], b[2], x[but])
+ x1 <- x[w]
+ y1 <- y[w]
+ x2 <- rep(x[but], length(w))
+ segments(y1, x1, y1, x2)
+ }
+ if (!is.null(data)) {
+ sq <- sqrt(abs(data))
+ w1 <- max(sq)
+ sq <- symbol.max * sq/w1
+ if (type == 1) {
+ for (i in 1:n) {
+ if (sign(data[i]) >= 0) {
+ symbols(yinit[i], xinit[i], squares = sq[i],
+ bg = "black", fg = "white", add = TRUE, inches = FALSE)
+ }
+ else {
+ symbols(yinit[i], xinit[i], squares = sq[i],
+ bg = "white", fg = "black", add = TRUE, inches = FALSE)
+ }
+ }
+ }
+ else if (type == 2) {
+ for (i in 1:n) {
+ if (sign(data[i]) >= 0) {
+ symbols(yinit[i], xinit[i], circles = sq[i]/2,
+ bg = "black", fg = "white", add = TRUE, inches = FALSE)
+ }
+ else {
+ symbols(yinit[i], xinit[i], circles = sq[i]/2,
+ bg = "white", fg = "black", add = TRUE, inches = FALSE)
+ }
+ }
+ }
+ if (clegend > 0) {
+ br0 <- pretty(data, 4)
+ l0 <- length(br0)
+ br0 <- (br0[1:(l0 - 1)] + br0[2:l0])/2
+ sq0 <- sqrt(abs(br0))
+ sq0 <- symbol.max * sq0/w1
+ sig0 <- sign(br0)
+ legender(br0, sq0, sig0, clegend = clegend, type = type)
+ }
+ }
+ if (csub > 0)
+ scatterutil.sub(sub, csub, possub)
+}
diff --git a/R/table.cont.R b/R/table.cont.R
new file mode 100644
index 0000000..ee8e395
--- /dev/null
+++ b/R/table.cont.R
@@ -0,0 +1,62 @@
+"table.cont" <- function (df, x = 1:ncol(df), y = 1:nrow(df), row.labels = row.names(df),
+ col.labels = names(df), clabel.row = 1, clabel.col = 1, abmean.x = FALSE,
+ abline.x = FALSE, abmean.y = FALSE, abline.y = FALSE, csize = 1, clegend = 0,
+ grid = TRUE)
+{
+ opar <- par(mai = par("mai"), srt = par("srt"))
+ on.exit(par(opar))
+ if (any(df < 0))
+ stop("Non negative values expected")
+ df <- df/sum(df)
+ table.prepare(x = x, y = y, row.labels = row.labels, col.labels = col.labels,
+ clabel.row = clabel.row, clabel.col = clabel.col, grid = grid,
+ pos = "leftbottom")
+ xtot <- x[col(as.matrix(df))]
+ ytot <- y[row(as.matrix(df))]
+ coeff <- diff(range(x))/15
+ z <- unlist(df)
+ sq <- sqrt(abs(z))
+ w1 <- max(sq)
+ sq <- csize * coeff * sq/w1
+ for (i in 1:length(z)) symbols(xtot[i], ytot[i], squares = sq[i],
+ bg = "white", fg = 1, add = TRUE, inches = FALSE)
+ f1 <- function(x,xval) {
+ w1 <- weighted.mean(xval, x)
+ xval <- (xval - w1)^2
+ w2 <- sqrt(weighted.mean(xval, x))
+ return(c(w1, w2))
+ }
+ if (abmean.x) {
+ val <- y
+ w <- t(apply(df, 2, f1,xval=val))
+ points(x, w[, 1], pch = 20, cex = 2)
+ segments(x, w[, 1] - w[, 2], x, w[, 1] + w[, 2])
+ }
+ if (abmean.y) {
+ val <- x
+ w <- t(apply(df, 1, f1,xval=val))
+ points(w[, 1], y, pch = 20, cex = 2)
+ segments(w[, 1] - w[, 2], y, w[, 1] + w[, 2], y)
+ }
+ df <- as.matrix(df)
+ x <- x[col(df)]
+ y <- y[row(df)]
+ df <- as.vector(df)
+ if (abline.x) {
+ abline(lm(y ~ x, weights = df))
+ }
+ if (abline.y) {
+ w <- coefficients(lm(x ~ y, weights = df))
+ if (w[2] == 0)
+ abline(h = w[1])
+ else abline(c(-w[1]/w[2], 1/w[2]))
+ }
+ br0 <- pretty(z, 4)
+ l0 <- length(br0)
+ br0 <- (br0[1:(l0 - 1)] + br0[2:l0])/2
+ sq0 <- sqrt(abs(br0))
+ sq0 <- csize * coeff * sq0/w1
+ sig0 <- sign(br0)
+ if (clegend > 0)
+ scatterutil.legend.bw.square(br0, sq0, sig0, clegend)
+}
diff --git a/R/table.dist.R b/R/table.dist.R
new file mode 100644
index 0000000..c58e452
--- /dev/null
+++ b/R/table.dist.R
@@ -0,0 +1,21 @@
+"table.dist" <- function (d, x = 1:(attr(d, "Size")), labels = as.character(x),
+ clabel = 1, csize = 1, grid = TRUE)
+{
+ opar <- par(mai = par("mai"), srt = par("srt"))
+ on.exit(par(opar))
+ if (!inherits(d, "dist"))
+ stop("object of class 'dist expected")
+ table.prepare(x, x, labels, labels, clabel, clabel, grid,
+ "leftbottom")
+ n <- attr(d, "Size")
+ d <- as.matrix(d)
+ xtot <- x[col(d)]
+ ytot <- x[row(d)]
+ coeff <- diff(range(x))/n
+ z <- as.vector(d)
+ sq <- sqrt(z * pi)
+ w1 <- max(sq)
+ sq <- csize * coeff * sq/w1
+ symbols(xtot, ytot, circles = sq, fg = 1, bg = grey(0.8),
+ add = TRUE, inches = FALSE)
+}
diff --git a/R/table.paint.R b/R/table.paint.R
new file mode 100644
index 0000000..7659423
--- /dev/null
+++ b/R/table.paint.R
@@ -0,0 +1,28 @@
+"table.paint" <- function (df, x = 1:ncol(df), y = nrow(df):1, row.labels = row.names(df),
+ col.labels = names(df), clabel.row = 1, clabel.col = 1, csize = 1,
+ clegend = 1)
+{
+ x <- rank(x)
+ y <- rank(y)
+ opar <- par(mai = par("mai"), srt = par("srt"))
+ on.exit(par(opar))
+ table.prepare(x = x, y = y, row.labels = row.labels, col.labels = col.labels,
+ clabel.row = clabel.row, clabel.col = clabel.col, grid = FALSE,
+ pos = "paint")
+ xtot <- x[col(as.matrix(df))]
+ ytot <- y[row(as.matrix(df))]
+ xdelta <- (max(x) - min(x))/(length(x) - 1)/2
+ ydelta <- (max(y) - min(y))/(length(y) - 1)/2
+ coeff <- diff(range(xtot))/15
+ z <- unlist(df)
+ br0 <- pretty(z, 6)
+ nborn <- length(br0)
+ coeff <- diff(range(x))/15
+ numclass <- cut.default(z, br0, include.lowest = TRUE, labels = FALSE)
+ valgris <- seq(1, 0, le = (nborn - 1))
+ h <- csize * coeff
+ rect(xtot - xdelta, ytot - ydelta, xtot + xdelta, ytot +
+ ydelta, col = gray(valgris[numclass]))
+ if (clegend > 0)
+ scatterutil.legend.square.grey(br0, valgris, h/2, clegend)
+}
diff --git a/R/table.phylog.R b/R/table.phylog.R
new file mode 100644
index 0000000..93ba837
--- /dev/null
+++ b/R/table.phylog.R
@@ -0,0 +1,139 @@
+"table.phylog" <- function (df, phylog, x = 1:ncol(df), f.phylog = 0.5,
+ labels.row = gsub("[_]"," ",row.names(df)), clabel.row = 1,
+ labels.col = names(df), clabel.col = 1,
+ labels.nod = names(phylog$nodes), clabel.nod = 0, cleaves = 1,
+ cnodes = 1, csize = 1, grid = TRUE, clegend=0.75)
+{
+ df <- as.data.frame(df)
+ if (!inherits(df,"data.frame")) stop ("data.frame expected for 'df'")
+ if (!inherits(phylog,"phylog")) stop ("class 'phylog' expected for 'phylog'")
+ leave.names <- names(phylog$leaves)
+ node.names <- names(phylog$nodes)
+ n.leave <- length(leave.names)
+ n.node <- length(node.names)
+ if (f.phylog > 0.8) f.phylog <- 0.8
+ if (f.phylog < 0.2) f.phylog <- 0.2
+ opar <- par(mai = par("mai"), srt = par("srt"))
+ on.exit(par(opar))
+ w1 <- sort(row.names(df))
+ w2 <- sort(names(phylog$leaves))
+ if (!all(w1 == w2)) {
+ print.noquote("names from 'df'")
+ print(w1)
+ print.noquote("names from 'phylog'")
+ print(w2)
+ stop ("non convenient matching information")
+ }
+
+ df <- df[names(phylog$leaves), ]
+ # df données phylog structure
+ frame()
+ labels.row <- paste(" ", labels.row, " ", sep = "")
+ labels.col <- paste(" ", labels.col, " ", sep = "")
+ cexrow <- par("cex") * clabel.row
+ strx <- 0.1
+ if (cexrow > 0) {
+ strx <- max( strwidth(labels.row, units = "inches", cex = cexrow))+0.1
+ }
+ cexcol <- par("cex") * clabel.col
+ stry <- 0.1
+ if (cexcol > 0) {
+ stry <- max( strwidth(labels.col, units = "inches", cex = cexcol))+0.1
+ }
+ par(mai = c(0.1, 0.1, stry, strx))
+ #nc <- ncol(df)
+ #x <- 1/2/nc+(0:(nc-1))/nc
+ # modif du 06/01/2005 le oaramètre x avait été oublié
+ intermin <- abs(min(diff(sort(x))))
+ intertot <- abs(max(x)-min(x))
+ x <- (x-min(x)+intermin)/(intertot+2*intermin)
+ x <- (1 - f.phylog) * x + f.phylog
+ nl <- nrow(df)
+ y <- 1/2/nl+((nl-1):0)/nl
+ par(new = TRUE)
+ plot.default(0, 0, type = "n", xlab = "", ylab = "",
+ xaxt = "n", yaxt = "n", xlim = c(-0.075,1), ylim = c(0,1),
+ xaxs = "i", yaxs = "i", frame.plot = FALSE)
+ if (cexrow > 0) {
+ for (i in 1:length(y)) {
+ text(1.01, y[i], labels.row[i], adj = 0,
+ cex = cexrow, xpd = NA)
+ segments(1, y[i], 1.01, y[i], xpd = NA)
+ }
+ }
+ if (cexcol > 0) {
+ par(srt = 90)
+ for (i in 1:length(x)) {
+ text(x[i], 1.01, labels.col[i], adj = 0,
+ cex = cexcol, xpd = NA)
+ segments(x[i], 1.0, x[i], 1.01,, xpd = NA)
+ }
+ par(srt = 0)
+ }
+ if (grid) {
+ col <- "lightgray"
+ for (i in 1:length(y)) segments(1,y[i],
+ f.phylog, y[i], col = col)
+ for (i in 1:length(x)) segments(x[i], 0,
+ x[i], 1, col = col)
+ }
+ rect(f.phylog, 0, 1, 1)
+ xtot <- x[col(as.matrix(df))]
+ ytot <- y[row(as.matrix(df))]
+ coeff <- diff(range(xtot))/15
+ z <- unlist(df)
+ sq <- sqrt(abs(z))
+ w1 <- max(sq)
+ sq <- csize * coeff * sq/w1
+ for (i in 1:length(z)) {
+ if (sign(z[i]) >= 0) {
+ symbols(xtot[i], ytot[i], squares = sq[i], bg = "black",
+ fg = "white", add = TRUE, inches = FALSE)
+ }
+ else {
+ symbols(xtot[i], ytot[i], squares = sq[i], bg = "white",
+ fg = "black", add = TRUE, inches = FALSE)
+ }
+ }
+ br0 <- pretty(z, 4)
+ l0 <- length(br0)
+ br0 <- (br0[1:(l0 - 1)] + br0[2:l0])/2
+ sq0 <- sqrt(abs(br0))
+ sq0 <- csize * coeff * sq0/w1
+ sig0 <- sign(br0)
+
+ dis <- phylog$droot
+ dn <- phylog$droot[node.names]
+ names(y) <- leave.names
+ x <- dis
+ x <- (x/max(x)) * f.phylog
+ for (i in 1:n.leave) {
+ segments(f.phylog, y[i], x[i], y[i], col = grey(0.7))
+ points(x[i], y[i], pch = 20, cex = par("cex") * cleaves)
+ }
+ newlab <- as.character(1:length(phylog$nodes))
+ newx <- NULL
+ newy <- NULL
+ yn <- rep(0, length(dn))
+ names(yn) <- names(dn)
+ y <- c(y, yn)
+ for (i in 1:n.node) {
+ w <- phylog$parts[[i]]
+ if (clabel.nod>0) newlab[i] <- labels.nod[i]
+ but <- names(phylog$parts)[i]
+ y[but] <- mean(y[w])
+ newy[i] <- y[but]
+ newx[i] <- x[but]
+ b <- range(y[w])
+ segments(x[but], b[1], x[but], b[2])
+ x1 <- x[w]
+ y1 <- y[w]
+ x2 <- rep(x[but], length(w))
+ segments(x1, y1, x2, y1)
+ }
+ if (cnodes > 0) points(newx, newy, pch = 21, bg="white", cex = par("cex") * cnodes, xpd=NA)
+ if (clabel.nod>0) (scatterutil.eti(newx,newy,newlab,clabel.nod))
+ if (clegend > 0)
+ scatterutil.legend.bw.square(br0, sq0, sig0, clegend)
+
+}
diff --git a/R/table.value.R b/R/table.value.R
new file mode 100644
index 0000000..9b47813
--- /dev/null
+++ b/R/table.value.R
@@ -0,0 +1,208 @@
+"table.prepare" <- function (x, y, row.labels, col.labels, clabel.row, clabel.col,
+ grid, pos)
+{
+ cexrow <- par("cex") * clabel.row
+ cexcol <- par("cex") * clabel.col
+ wx <- range(x)
+ wy <- range(y)
+ maxx <- max(x)
+ maxy <- max(y)
+ minx <- min(x)
+ miny <- min(y)
+ dx <- diff(wx)/(length(x))
+ dy <- diff(wy)/(length(y))
+ if (cexrow > 0) {
+ ## ncar <- max(nchar(paste(" ", row.labels, " ", sep = "")))
+ ## strx <- par("cin")[1] * ncar * cexrow/2 + 0.1
+ strx <- max(strwidth(paste(" ", row.labels, " ", sep = ""), units = "inches", cex=cexrow))
+ }
+ else strx <- 0.1
+ if (cexcol > 0) {
+ ##ncar <- max(nchar(paste(" ", col.labels, " ", sep = "")))
+ ##stry <- par("cin")[1] * ncar * cexcol/2 + 0.1
+ stry <- max(strwidth(paste(" ", col.labels, " ", sep = ""), units = "inches", cex=cexcol))
+ }
+ else stry <- 0.1
+ if (pos == "righttop") {
+ par(mai = c(0.1, 0.1, stry, strx))
+ xlim <- wx + c(-dx, 2 * dx)
+ ylim <- wy + c(-2 * dy, 2 * dy)
+ plot.default(0, 0, type = "n", xlab = "", ylab = "",
+ xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim,
+ xaxs = "i", yaxs = "i", frame.plot = FALSE)
+ if (cexrow > 0) {
+ for (i in 1:length(y)) {
+ ynew <- seq(miny, maxy, le = length(y))
+ ynew <- ynew[rank(y)]
+ text(maxx + 2 * dx, ynew[i], row.labels[i], adj = 0,
+ cex = cexrow, xpd = NA)
+ segments(maxx + 2 * dx, ynew[i], maxx + dx, y[i])
+ }
+ }
+ if (cexcol > 0) {
+ par(srt = 90)
+ for (i in 1:length(x)) {
+ xnew <- seq(minx, maxx, le = length(x))
+ xnew <- xnew[rank(x)]
+ text(xnew[i], maxy + 2 * dy, col.labels[i], adj = 0,
+ cex = cexcol, xpd = NA)
+ segments(xnew[i], maxy + 2 * dy, x[i], maxy +
+ dy)
+ }
+ par(srt = 0)
+ }
+ if (grid) {
+ col <- "lightgray"
+ for (i in 1:length(y)) segments(maxx + dx, y[i],
+ minx - dx, y[i], col = col)
+ for (i in 1:length(x)) segments(x[i], miny - dy,
+ x[i], maxy + dy, col = col)
+ }
+ rect(minx - dx, miny - dy, maxx + dx, maxy + dy)
+ return(invisible())
+ }
+ if (pos == "phylog") {
+ par(mai = c(0.1, 0.1, stry, strx))
+ xlim <- wx + c(-dx, 2 * dx)
+ ylim <- wy + c(-dy, 2 * dy)
+ plot.default(0, 0, type = "n", xlab = "", ylab = "",
+ xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim,
+ xaxs = "i", yaxs = "i", frame.plot = FALSE)
+ if (cexrow > 0) {
+ for (i in 1:length(y)) {
+ ynew <- seq(miny, maxy, le = length(y))
+ ynew <- ynew[rank(y)]
+ text(maxx + 2 * dx, ynew[i], row.labels[i], adj = 0,
+ cex = cexrow, xpd = NA)
+ segments(maxx + 2 * dx, ynew[i], maxx + dx, y[i])
+ }
+ }
+ if (cexcol > 0) {
+ par(srt = 90)
+ xnew <- x[2:length(x)]
+ x <- xnew
+ for (i in 1:length(x)) {
+ text(xnew[i], maxy + 2 * dy, col.labels[i], adj = 0,
+ cex = cexcol, xpd = NA)
+ segments(xnew[i], maxy + 2 * dy, x[i], maxy +
+ dy)
+ }
+ par(srt = 0)
+ }
+ minx <- min(x)
+ if (grid) {
+ col <- "lightgray"
+ for (i in 1:length(y)) segments(maxx + dx, y[i],
+ minx - dx, y[i], col = col)
+ for (i in 1:length(x)) segments(x[i], miny - dy,
+ x[i], maxy + dy, col = col)
+ }
+ rect(minx - dx, miny - dy, maxx + dx, maxy + dy)
+ rect(-dx, miny - dy, minx - dx, maxy + dy)
+ return(c(0, minx - dx))
+ }
+ if (pos == "leftbottom") {
+ par(mai = c(stry, strx, 0.05, 0.05))
+ xlim <- wx + c(-2 * dx, dx)
+ ylim <- wy + c(-2 * dy, dy)
+ plot.default(0, 0, type = "n", xlab = "", ylab = "",
+ xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim,
+ xaxs = "i", yaxs = "i", frame.plot = FALSE)
+ if (cexrow > 0) {
+ for (i in 1:length(y)) {
+ ynew <- seq(miny, maxy, le = length(y))
+ ynew <- ynew[rank(y)]
+ w9 <- strwidth(row.labels[i], cex = cexrow)
+ text(minx - w9 - 2 * dx, ynew[i], row.labels[i],
+ adj = 0, cex = cexrow, xpd = NA)
+ segments(minx - 2 * dx, ynew[i], minx - dx, y[i])
+ }
+ }
+ if (cexcol > 0) {
+ par(srt = -90)
+ for (i in 1:length(x)) {
+ xnew <- seq(minx, maxx, le = length(x))
+ xnew <- xnew[rank(x)]
+ text(xnew[i], miny - 2 * dy, col.labels[i], adj = 0,
+ cex = cexcol, xpd = NA)
+ segments(xnew[i], miny - 2 * dy, x[i], miny -
+ dy)
+ }
+ par(srt = 0)
+ }
+ if (grid) {
+ col <- "lightgray"
+ for (i in 1:length(y)) segments(maxx + 2 * dx, y[i],
+ minx - dx, y[i], col = col)
+ for (i in 1:length(x)) segments(x[i], miny - 2 *
+ dy, x[i], maxy + dy, col = col)
+ }
+ rect(minx - dx, miny - dy, maxx + dx, maxy + dy)
+ return(invisible())
+ }
+ if (pos == "paint") {
+
+ dx <- diff(wx)/(length(x) - 1)/2
+ dy <- diff(wy)/(length(y) - 1)/2
+
+ par(mai = c(0.2, strx, stry, 0.1))
+ xlim <- wx + c(-dx, dx)
+ ylim <- wy + c(-dy, dy)
+ plot.default(0, 0, type = "n", xlab = "", ylab = "",
+ xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim,
+ xaxs = "i", yaxs = "i", frame.plot = TRUE)
+ if (cexrow > 0) {
+ ynew <- seq(miny, maxy, le = length(y))
+ ynew <- ynew[rank(y)]
+ ##w9 <- strwidth(row.labels, cex = cexrow)
+ ##text(minx - w9 - 3 * dx/4, ynew, row.labels, adj = 0, cex = cexrow, xpd = NA)
+ mtext(at = ynew, side = 2, text = paste(row.labels," ", sep = ""), adj = 1, cex = cexrow, las = 1)
+ }
+ if (cexcol > 0) {
+ xnew <- seq(minx, maxx, le = length(x))
+ xnew <- xnew[rank(x)]
+ ## par(srt = 90)
+ ## text(xnew, maxy + 3 * dy/4, col.labels, adj = 0, cex = cexcol, xpd = NA)
+ mtext(at = xnew, side = 3, text = paste(" ", col.labels, sep = ""), adj = 0, cex = cexcol, las = 2)
+ par(srt = 0)
+ }
+ return(invisible())
+ }
+}
+
+
+"table.value" <- function (df, x = 1:ncol(df), y = nrow(df):1, row.labels = row.names(df),
+ col.labels = names(df), clabel.row = 1, clabel.col = 1, csize = 1,
+ clegend = 1, grid = TRUE)
+{
+ opar <- par(mai = par("mai"), srt = par("srt"))
+ on.exit(par(opar))
+ table.prepare(x = x, y = y, row.labels = row.labels, col.labels = col.labels,
+ clabel.row = clabel.row, clabel.col = clabel.col, grid = grid,
+ pos = "righttop")
+ xtot <- x[col(as.matrix(df))]
+ ytot <- y[row(as.matrix(df))]
+ coeff <- diff(range(xtot))/15
+ z <- unlist(df)
+ sq <- sqrt(abs(z))
+ w1 <- max(sq)
+ sq <- csize * coeff * sq/w1
+ for (i in 1:length(z)) {
+ if (sign(z[i]) >= 0) {
+ symbols(xtot[i], ytot[i], squares = sq[i], bg = 1,
+ fg = 0, add = TRUE, inches = FALSE)
+ }
+ else {
+ symbols(xtot[i], ytot[i], squares = sq[i], bg = "white",
+ fg = 1, add = TRUE, inches = FALSE)
+ }
+ }
+ br0 <- pretty(z, 4)
+ l0 <- length(br0)
+ br0 <- (br0[1:(l0 - 1)] + br0[2:l0])/2
+ sq0 <- sqrt(abs(br0))
+ sq0 <- csize * coeff * sq0/w1
+ sig0 <- sign(br0)
+ if (clegend > 0)
+ scatterutil.legend.bw.square(br0, sq0, sig0, clegend)
+}
diff --git a/R/testdim.R b/R/testdim.R
new file mode 100755
index 0000000..dbf9f6d
--- /dev/null
+++ b/R/testdim.R
@@ -0,0 +1,42 @@
+"testdim" <- function (object, ...) UseMethod("testdim")
+
+"testdim.pca" <-
+ function(object, nrepet = 99, nbax = object$rank, alpha = 0.05, ...){
+ if (!inherits(object, "dudi"))
+ stop("Object of class 'dudi' expected")
+ if (!inherits(object, "pca"))
+ stop("Object of class 'pca' expected")
+ appel <- as.list(object$call)
+ appel$scale <- eval.parent(appel$scale)
+ appel$center <- eval.parent(appel$center)
+ if (is.null(appel$scale)) appel$scale <- TRUE
+ if (is.null(appel$center)) appel$center <- TRUE
+ if (!(is.logical(appel$center))) stop("Not implemented for decentred PCA")
+ if (!(appel$center == TRUE && appel$scale == TRUE))
+ stop("Only implemented for PCA on correlation matrix (center=TRUE and scale=TRUE)")
+ X <- as.matrix(object$tab)
+ if (!(identical(all.equal(object$lw,rep(1/nrow(X), nrow(X))),TRUE)))
+ stop("Not implemented for non-uniform row weights")
+ if (!(identical(all.equal(object$cw,rep(1, ncol(X))),TRUE)))
+ stop("Not implemented for non-uniform column weights")
+ if (nbax<1)
+ stop("Incorrect number of axes")
+ nbax <- ifelse(nbax>min(nrow(X),ncol(X)),min(nrow(X),ncol(X)),nbax)
+ res <- list()
+ res <- .C("testdimRVpca", ok = as.integer(0), as.double(t(X)), as.integer(nrow(X)), as.integer(ncol(X)), as.integer(nrepet),nbax=as.integer(nbax),sim=as.double(rep(0,nbax*nrepet)),obs=as.double(rep(0,nbax)),PACKAGE="ade4")[c("ok","obs","sim")]
+ if(res$ok < -0.5){
+ stop("Error in the svd decomposition")
+ } else {
+ res <- res[-1]
+ }
+
+ res$sim <- matrix(res$sim[1:(nbax*nrepet)],nrepet,nbax,byrow=TRUE)
+ res$obs <- res$obs[1:nbax]
+ res <- as.krandtest(sim=res$sim,obs=res$obs,names=paste("Axis", 1:length(res$obs)),call=match.call(), ...)
+
+ nb <- which(res$pvalue>alpha)
+ if(length(nb)==0) {res$nb <- length(res$obs)} else {res$nb <- min(nb)-1}
+ nb2 <- which(res$pvalue>(alpha/1:length(res$obs)))
+ if(length(nb2)==0) {res$nb.cor <- length(res$obs)} else {res$nb.cor <- min(nb2)-1}
+ return(res)
+ }
diff --git a/R/triangle.class.R b/R/triangle.class.R
new file mode 100644
index 0000000..705280a
--- /dev/null
+++ b/R/triangle.class.R
@@ -0,0 +1,95 @@
+######################### triangle.class ######################################
+"triangle.class" <- function (ta, fac,
+ col = rep(1, length(levels(fac))), wt = rep(1, length(fac)),cstar = 1,
+ cellipse = 0, axesell = TRUE, label = levels(fac),
+ clabel = 1, cpoint = 1, pch=20,
+ draw.line = TRUE, addaxes = FALSE, addmean = FALSE, labeltriangle = TRUE,
+ sub = "", csub = 1, possub = "bottomright", show.position = TRUE,
+ scale = TRUE, min3 = NULL, max3 = NULL)
+{
+ # modifiée le 18/11/2004 par cohérence avec triangle.param
+
+ seg <- function(a, b, col = par("col")) {
+ segments(a[1], a[2], b[1], b[2], col = col)
+ }
+
+ ta <- data.frame(ta)
+ if (!is.data.frame(ta)) stop("Non convenient selection for ta")
+ if (any(is.na(ta))) stop("NA non implemented")
+ if (!is.factor(fac)) stop("factor expected for fac")
+ if (ncol(ta)!=3) stop("3 columns expected for ta")
+ if (nrow(ta)!=length(fac)) stop ("Non convenient dimension")
+ dfdistri <- fac2disj(fac) * wt
+ coul <- col
+ w1 <- unlist(lapply(dfdistri, sum))
+ dfdistri <- t(t(dfdistri)/w1)
+
+ nam <- names(ta)
+ ta <- t(apply(ta, 1, function(x) x/sum(x)))
+ d <- triangle.param(ta, scale = scale, min3 = min3, max3 = max3)
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ A <- d$A
+ B <- d$B
+ C <- d$C
+ xy <- d$xy
+ xymoy <- as.matrix(t(dfdistri)) %*% as.matrix(xy)
+ mini <- d$mini
+ maxi <- d$maxi
+ if (show.position) add.position.triangle(d)
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ plot(0, 0, type = "n", xlim = c(-0.8, 0.8), ylim = c(-0.6,
+ 1), xlab = "", ylab = "", xaxt = "n", yaxt = "n", asp = 1,
+ frame.plot = FALSE)
+ seg(A, B)
+ seg(B, C)
+ seg(C, A)
+ text(C[1], C[2], labels = paste(mini[1]), pos = 2)
+ text(C[1], C[2], labels = paste(maxi[3]), pos = 4)
+ if (labeltriangle)
+ text((A + C)[1]/2, (A + C)[2]/2, labels = nam[1], cex = 1.5,
+ pos = 2)
+ text(A[1], A[2], labels = paste(maxi[1]), pos = 2)
+ text(A[1], A[2], labels = paste(mini[2]), pos = 1)
+ if (labeltriangle)
+ text((A + B)[1]/2, (A + B)[2]/2, labels = nam[2], cex = 1.5,
+ pos = 1)
+ text(B[1], B[2], labels = paste(maxi[2]), pos = 1)
+ text(B[1], B[2], labels = paste(mini[3]), pos = 4)
+ if (labeltriangle)
+ text((B + C)[1]/2, (B + C)[2]/2, labels = nam[3], cex = 1.5,
+ pos = 4)
+ if (draw.line) {
+ nlg <- 10 * (maxi[1] - mini[1])
+ for (i in 1:(nlg - 1)) {
+ x1 <- A + (i/nlg) * (B - A)
+ x2 <- C + (i/nlg) * (B - C)
+ seg(x1, x2, col = "lightgrey")
+ x1 <- A + (i/nlg) * (B - A)
+ x2 <- A + (i/nlg) * (C - A)
+ seg(x1, x2, col = "lightgrey")
+ x1 <- C + (i/nlg) * (A - C)
+ x2 <- C + (i/nlg) * (B - C)
+ seg(x1, x2, col = "lightgrey")
+ }
+ }
+ if (cpoint > 0)
+ for (i in 1:ncol(dfdistri)) {
+ points(xy[dfdistri[,i] > 0,],pch = pch, cex = par("cex") * cpoint, col=coul[i])
+ }
+
+ if (cstar > 0)
+ for (i in 1:ncol(dfdistri)) {
+ scatterutil.star(xy[,1], xy[,2], dfdistri[, i], cstar = cstar, coul[i])
+ }
+
+ if (cellipse > 0)
+ for (i in 1:ncol(dfdistri)) {
+ scatterutil.ellipse(xy[,1], xy[,2], dfdistri[, i],
+ cellipse = cellipse, axesell = axesell, coul[i])
+ }
+ if (clabel > 0)
+ scatterutil.eti(xymoy[,1], xymoy[,2], label, clabel, coul = col)
+ if (csub > 0) scatterutil.sub(sub, csub, possub)
+
+}
diff --git a/R/triangle.plot.R b/R/triangle.plot.R
new file mode 100644
index 0000000..cb4f0c5
--- /dev/null
+++ b/R/triangle.plot.R
@@ -0,0 +1,285 @@
+######################### triangle.plot ######################################
+"triangle.plot" <- function (ta, label = as.character(1:nrow(ta)), clabel = 0, cpoint = 1,
+ draw.line = TRUE, addaxes = FALSE, addmean = FALSE, labeltriangle = TRUE,
+ sub = "", csub = 0, possub = "topright", show.position = TRUE,
+ scale = TRUE, min3 = NULL, max3 = NULL, box = FALSE)
+{
+ seg <- function(a, b, col = par("col")) {
+ segments(a[1], a[2], b[1], b[2], col = col)
+ }
+ nam <- names(ta)
+ ta <- t(apply(ta, 1, function(x) x/sum(x)))
+ d <- triangle.param(ta, scale = scale, min3 = min3, max3 = max3)
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ A <- d$A
+ B <- d$B
+ C <- d$C
+ xy <- d$xy
+ mini <- d$mini
+ maxi <- d$maxi
+ if (show.position)
+ add.position.triangle(d)
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ plot(0, 0, type = "n", xlim = c(-0.8, 0.8), ylim = c(-0.6,
+ 1), xlab = "", ylab = "", xaxt = "n", yaxt = "n", asp = 1,
+ frame.plot = FALSE)
+ seg(A, B)
+ seg(B, C)
+ seg(C, A)
+ text(C[1], C[2], labels = paste(mini[1]), pos = 2)
+ text(C[1], C[2], labels = paste(maxi[3]), pos = 4)
+ if (labeltriangle)
+ text((A + C)[1]/2, (A + C)[2]/2, labels = nam[1], cex = 1.5,
+ pos = 2)
+ text(A[1], A[2], labels = paste(maxi[1]), pos = 2)
+ text(A[1], A[2], labels = paste(mini[2]), pos = 1)
+ if (labeltriangle)
+ text((A + B)[1]/2, (A + B)[2]/2, labels = nam[2], cex = 1.5,
+ pos = 1)
+ text(B[1], B[2], labels = paste(maxi[2]), pos = 1)
+ text(B[1], B[2], labels = paste(mini[3]), pos = 4)
+ if (labeltriangle)
+ text((B + C)[1]/2, (B + C)[2]/2, labels = nam[3], cex = 1.5,
+ pos = 4)
+ if (draw.line) {
+ nlg <- 10 * (maxi[1] - mini[1])
+ for (i in 1:(nlg - 1)) {
+ x1 <- A + (i/nlg) * (B - A)
+ x2 <- C + (i/nlg) * (B - C)
+ seg(x1, x2, col = "lightgrey")
+ x1 <- A + (i/nlg) * (B - A)
+ x2 <- A + (i/nlg) * (C - A)
+ seg(x1, x2, col = "lightgrey")
+ x1 <- C + (i/nlg) * (A - C)
+ x2 <- C + (i/nlg) * (B - C)
+ seg(x1, x2, col = "lightgrey")
+ }
+ }
+ if (cpoint > 0)
+ points(xy, pch = 20, cex = par("cex") * cpoint)
+ if (clabel > 0)
+ scatterutil.eti(xy[, 1], xy[, 2], label, clabel)
+ if (addaxes) {
+ pr0 <- dudi.pca(ta, scale = FALSE, scannf = FALSE)$c1
+ w1 <- triangle.posipoint(apply(ta, 2, mean), mini, maxi)
+ points(w1[1], w1[2], pch = 16, cex = 2)
+ a1 <- pr0[, 1]
+ x1 <- a1[1] * A + a1[2] * B + a1[3] * C
+ seg(w1 - x1, w1 + x1)
+ a1 <- pr0[, 2]
+ x1 <- a1[1] * A + a1[2] * B + a1[3] * C
+ seg(w1 - x1, w1 + x1)
+ }
+ if (addmean) {
+ m <- apply(ta, 2, mean)
+ w1 <- triangle.posipoint(m, mini, maxi)
+ points(w1[1], w1[2], pch = 16, cex = 2)
+ w2 <- triangle.posipoint(c(m[1], mini[2], 1 - m[1] -
+ mini[2]), mini, maxi)
+ w3 <- triangle.posipoint(c(1 - m[2] - mini[3], m[2],
+ mini[3]), mini, maxi)
+ w4 <- triangle.posipoint(c(mini[1], 1 - m[3] - mini[1],
+ m[3]), mini, maxi)
+ points(w2[1], w2[2], pch = 20, cex = 2)
+ points(w3[1], w3[2], pch = 20, cex = 2)
+ points(w4[1], w4[2], pch = 20, cex = 2)
+ seg(w1, w2)
+ seg(w1, w3)
+ seg(w1, w4)
+ text(w2[1], w2[2], labels = as.character(round(m[1],
+ digits = 3)), cex = 1.5, pos = 2)
+ text(w3[1], w3[2], labels = as.character(round(m[2],
+ digits = 3)), cex = 1.5, pos = 1)
+ text(w4[1], w4[2], labels = as.character(round(m[3],
+ digits = 3)), cex = 1.5, pos = 4)
+ }
+ if (csub > 0)
+ scatterutil.sub(sub, csub, possub)
+ if (box) box()
+ return(invisible(xy))
+}
+
+######################### triangle.posipoint ######################################
+"triangle.posipoint" <- function (x, mini, maxi) {
+ x <- (x - mini)/(maxi - mini)
+ x <- x/sum(x)
+ x1 <- (x[2] - x[1])/sqrt(2)
+ y1 <- (2 * x[3] - x[2] - x[1])/sqrt(6)
+ return(c(x1, y1))
+}
+
+######################### add.position.triangle ######################################
+"add.position.triangle" <- function (d) {
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ w <- matrix(0, 3, 3)
+ w[1, 1] <- d$mini[1]
+ w[1, 2] <- d$mini[2]
+ w[1, 3] <- d$maxi[3]
+ w[2, 1] <- d$maxi[1]
+ w[2, 2] <- d$mini[2]
+ w[2, 3] <- d$mini[3]
+ w[3, 1] <- d$mini[1]
+ w[3, 2] <- d$maxi[2]
+ w[3, 3] <- d$mini[3]
+ A <- triangle.posipoint(c(0, 0, 1), c(0, 0, 0), c(1, 1, 1))
+ B <- triangle.posipoint(c(1, 0, 0), c(0, 0, 0), c(1, 1, 1))
+ C <- triangle.posipoint(c(0, 1, 0), c(0, 0, 0), c(1, 1, 1))
+ a <- triangle.posipoint(w[1, ], c(0, 0, 0), c(1, 1, 1))
+ b <- triangle.posipoint(w[2, ], c(0, 0, 0), c(1, 1, 1))
+ c <- triangle.posipoint(w[3, ], c(0, 0, 0), c(1, 1, 1))
+ plot(0, 0, type = "n", xlim = c(-0.71, 4 - 0.71), ylim = c(-4 +
+ 0.85, 0.85), xlab = "", ylab = "", xaxt = "n", yaxt = "n",
+ asp = 1, frame.plot = FALSE)
+ polygon(c(A[1], B[1], C[1]), c(A[2], B[2], C[2]))
+ polygon(c(a[1], b[1], c[1]), c(a[2], b[2], c[2]), col = grey(0.75))
+ par(new = TRUE)
+
+}
+
+######################### triangle.biplot ######################################
+"triangle.biplot" <- function (ta1, ta2, label = as.character(1:nrow(ta1)), draw.line = TRUE,
+ show.position = TRUE, scale = TRUE)
+{
+ seg <- function(a, b, col = 1) {
+ segments(a[1], a[2], b[1], b[2], col = col)
+ }
+ nam <- names(ta1)
+ ta1 <- t(apply(ta1, 1, function(x) x/sum(x)))
+ ta2 <- t(apply(ta2, 1, function(x) x/sum(x)))
+ d <- triangle.param(rbind(ta1, ta2), scale = scale)
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ A <- d$A
+ B <- d$B
+ C <- d$C
+ xy <- d$xy
+ mini <- d$mini
+ maxi <- d$maxi
+ if (show.position)
+ add.position.triangle(d)
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ plot(0, 0, type = "n", xlim = c(-0.8, 0.8), ylim = c(-0.6,
+ 1), xlab = "", ylab = "", xaxt = "n", yaxt = "n", asp = 1,
+ frame.plot = FALSE)
+ seg(A, B)
+ seg(B, C)
+ seg(C, A)
+ text(C[1], C[2], labels = paste(mini[1]), pos = 2)
+ text(C[1], C[2], labels = paste(maxi[3]), pos = 4)
+ text((A + C)[1]/2, (A + C)[2]/2, labels = nam[1], cex = 1.5,
+ pos = 2)
+ text(A[1], A[2], labels = paste(maxi[1]), pos = 2)
+ text(A[1], A[2], labels = paste(mini[2]), pos = 1)
+ text((A + B)[1]/2, (A + B)[2]/2, labels = nam[2], cex = 1.5,
+ pos = 1)
+ text(B[1], B[2], labels = paste(maxi[2]), pos = 1)
+ text(B[1], B[2], labels = paste(mini[3]), pos = 4)
+ text((B + C)[1]/2, (B + C)[2]/2, labels = nam[3], cex = 1.5,
+ pos = 4)
+ if (draw.line) {
+ nlg <- 10 * (maxi[1] - mini[1])
+ for (i in (1:(nlg - 1))) {
+ x1 <- A + (i/nlg) * (B - A)
+ x2 <- C + (i/nlg) * (B - C)
+ seg(x1, x2, col = "lightgrey")
+ x1 <- A + (i/nlg) * (B - A)
+ x2 <- A + (i/nlg) * (C - A)
+ seg(x1, x2, col = "lightgrey")
+ x1 <- C + (i/nlg) * (A - C)
+ x2 <- C + (i/nlg) * (B - C)
+ seg(x1, x2, col = "lightgrey")
+ }
+ }
+ nl <- nrow(ta1)
+ for (i in (1:nl)) {
+ arrows(xy[i, 1], xy[i, 2], xy[i + nl, 1], xy[i + nl,
+ 2], length = 0.1, angle = 15)
+ }
+ points(xy[1:nrow(ta1), ])
+ text(xy[1:nrow(ta1), ], label, pos = 4)
+ }
+
+######################### triangle.param ######################################
+"triangle.param" <- function (ta, scale = TRUE, min3 = NULL, max3 = NULL) {
+ if (ncol(ta) != 3)
+ stop("Non convenient data")
+ if (min(ta) < 0)
+ stop("Non convenient data")
+ if ((!is.null(min3)) & (!is.null(max3)))
+ scale <- TRUE
+ cal <- matrix(0, 9, 3)
+ tb <- t(apply(ta, 1, function(x) x/sum(x)))
+ mini <- apply(tb, 2, min)
+ maxi <- apply(tb, 2, max)
+ mini <- (floor(mini/0.1))/10
+ maxi <- (floor(maxi/0.1) + 1)/10
+ mini[mini<0] <- 0
+ maxi[maxi>1] <- 1
+ if (!is.null(min3))
+ mini <- min3
+ if (!is.null(max3))
+ maxi <- min3
+ ampli <- maxi - mini
+ amplim <- max(ampli)
+ # correction d'un bug trouvé par J. Lobry 15/11/2004
+ if (!all(ampli==amplim)) {
+ for (j in 1:3) {
+ k <- amplim - ampli[j]
+ while (k > 0) {
+ if ((k > 0) & (maxi[j] < 1)) {
+ maxi[j] <- maxi[j] + 0.1
+ k <- k - 1
+ }
+ if ((k > 0) & (mini[j] > 0)) {
+ mini[j] <- mini[j] - 0.1
+ k <- k - 1
+ }
+ }
+ }
+ }
+ cal[1, 1] <- mini[1]
+ cal[1, 2] <- mini[2]
+ cal[1, 3] <- 1 - cal[1, 1] - cal[1, 2]
+ cal[2, 1] <- mini[1]
+ cal[2, 2] <- maxi[2]
+ cal[2, 3] <- 1 - cal[2, 1] - cal[2, 2]
+ cal[3, 1] <- maxi[1]
+ cal[3, 2] <- mini[2]
+ cal[3, 3] <- 1 - cal[3, 1] - cal[3, 2]
+ cal[4, 1] <- mini[1]
+ cal[4, 3] <- mini[3]
+ cal[4, 2] <- 1 - cal[4, 1] - cal[4, 3]
+ cal[5, 1] <- mini[1]
+ cal[5, 3] <- maxi[3]
+ cal[5, 2] <- 1 - cal[5, 1] - cal[5, 3]
+ cal[6, 1] <- maxi[1]
+ cal[6, 3] <- mini[3]
+ cal[6, 2] <- 1 - cal[6, 1] - cal[6, 3]
+ cal[7, 2] <- mini[2]
+ cal[7, 3] <- mini[3]
+ cal[7, 1] <- 1 - cal[7, 2] - cal[7, 3]
+ cal[8, 2] <- mini[2]
+ cal[8, 3] <- maxi[3]
+ cal[8, 1] <- 1 - cal[8, 2] - cal[8, 3]
+ cal[9, 2] <- maxi[2]
+ cal[9, 3] <- mini[3]
+ cal[9, 1] <- 1 - cal[9, 2] - cal[9, 3]
+ mini <- apply(cal, 2, min)
+ mini <- round(mini, digits = 4)
+ maxi <- apply(cal, 2, max)
+ maxi <- round(maxi, digits = 4)
+ ampli <- maxi - mini
+ if (!scale) {
+ mini <- c(0, 0, 0)
+ maxi <- c(1, 1, 1)
+ }
+ A <- c(-1/sqrt(2), -1/sqrt(6))
+ B <- c(1/sqrt(2), -1/sqrt(6))
+ C <- c(0, 2/sqrt(6))
+ xy <- t(apply(tb, 1, FUN = triangle.posipoint, mini = mini,
+ maxi = maxi))
+ # pour avoir en sortie une matrice des coordonnées
+ dimnames(xy) <- list(row.names(ta),c("x","y"))
+ return(list(A = A, B = B, C = C, xy = xy, mini = mini, maxi = maxi))
+}
diff --git a/R/uniquewt.df.R b/R/uniquewt.df.R
new file mode 100644
index 0000000..0ce0673
--- /dev/null
+++ b/R/uniquewt.df.R
@@ -0,0 +1,15 @@
+"uniquewt.df" <- function (x) {
+ x <- data.frame(x)
+ col <- ncol(x)
+ w <- unlist(x[1])
+ for (j in 2:col) {
+ w <- paste(w, x[, j], sep = "")
+ }
+ w <- factor(w, unique(w))
+ levels(w) <- 1:length(unique(w))
+ select <- match(1:length(w), w)[1:nlevels(w)]
+ x <- x[select, ]
+ attr(x, "factor") <- w
+ attr(x, "len.class") <- as.vector(table(w))
+ return(x)
+}
diff --git a/R/utilities.R b/R/utilities.R
new file mode 100644
index 0000000..8e8f6cc
--- /dev/null
+++ b/R/utilities.R
@@ -0,0 +1,48 @@
+dudi.type <- function(x){
+ ## Test the different types of dudi
+ ## typ=1 no modification (PCA on original variable)
+ ## typ=2 ACM
+ ## typ=3 normed and centred PCA
+ ## typ=4 centred PCA
+ ## typ=5 normed and non-centred PCA
+ ## typ=6 COA
+ ## typ=7 FCA
+ ## typ=8 Hill-smith
+ ## typ=9 Decentred PCA
+ if(!is.call(x))
+ stop("Argument x should be a 'call' object")
+ x <- match.call(eval(x[[1]]),call = x) ## fill arguments names
+ call.list <- as.list(x)
+ dudi.name <- deparse(call.list[[1]])
+ call.list <- modifyList(formals(dudi.name), call.list[-1]) ## fill with default for unused arguments
+
+ if (dudi.name == "dudi.pca") {
+ call.list$scale <- eval(call.list$scale)
+ call.list$center <- eval(call.list$center)
+
+ if(!(is.logical(call.list$center)))
+ typ <- 9
+ if (!call.list$center & !call.list$scale) typ <- 1
+ if (!call.list$center & call.list$scale) typ <- 5
+ if (call.list$center & !call.list$scale) typ <- 4
+ if (call.list$center & call.list$scale) typ <- 3
+ } else if (dudi.name == "dudi.fpca") {
+ typ <- 4
+ } else if (dudi.name == "dudi.coa") {
+ typ <- 6
+ } else if (dudi.name == "dudi.fca") {
+ typ <- 7
+ } else if (dudi.name == "dudi.acm") {
+ typ <- 2
+ } else if (dudi.name == "dudi.hillsmith") {
+ typ <- 8
+ } else stop ("Not yet available")
+ return(typ)
+}
+
+
+adegraphicsLoaded <- function() {
+ ## check if adegraphics is loaded
+ "package:adegraphics"%in%search()
+}
+
diff --git a/R/variance.phylog.R b/R/variance.phylog.R
new file mode 100644
index 0000000..13af04d
--- /dev/null
+++ b/R/variance.phylog.R
@@ -0,0 +1,58 @@
+"variance.phylog" <- function (phylog, z, bynames = TRUE, na.action = c("fail", "mean")) {
+ if (!is.numeric(z))
+ stop("z is not numeric")
+ n <- length(z)
+ if (!inherits(phylog, "phylog"))
+ stop("Object of class 'phylog' expected")
+ if (n != length(phylog$leaves))
+ stop("Non convenient dimension")
+ if (bynames) {
+ if (is.null(names(z)))
+ stop("names(z) is NULL & bynames = TRUE")
+ w1 <- sort(names(z))
+ w2 <- sort(names(phylog$leaves))
+ if (!all(w1 == w2) & bynames) {
+ stop("names(z) non convenient for 'phylog' : bynames = FALSE ?")
+ }
+ z <- z[names(phylog$leaves)]
+ }
+ if (any(is.na(z))) {
+ if (na.action == "fail")
+ stop(" missing values in 'z'")
+ else if (na.action == "mean")
+ z[is.na(z)] <- mean(na.omit(z))
+ else stop("unknown method for 'na.action'")
+ }
+ res <- list()
+ z <- (z - mean(z))/sqrt(var(z))
+ w1 <- sort(names(z))
+ w2 <- sort(names(phylog$leaves))
+ if (!all(w1 == w2)) {
+ warning("names(z) non convenient for 'phylog' : we use the names of the leaves in 'phylog'")
+ names(z) <- names(phylog$leaves)
+ }
+ z <- z[names(phylog$leaves)]
+ df <- cbind.data.frame(z, phylog$Ascores[, 1:phylog$Adim])
+ begin <- paste(names(df)[1], "~", sep = "")
+ fmla <- as.formula(paste(begin, paste(names(df)[-1], collapse = "+")))
+ lm0 <- lm(fmla, data = df)
+ res$lm <- lm0
+ res$anova <- anova(lm0)
+ a1 <- sum(res$anova$"Sum Sq"[1:phylog$Adim])
+ df1 <- phylog$Adim
+ r1 <- a1/df1
+ a2 <- res$anova$"Sum Sq"[1 + phylog$Adim]
+ df2 <- res$anova$Df[1 + phylog$Adim]
+ r2 <- a2/df2
+ Fvalue <- r1/r2
+ proba <- 1 - pf(Fvalue, df1, df2)
+ dig1 <- max(getOption("digits") - 2, 3)
+ sumry <- array(0, c(2, 5), list(c("Phylogenetic", "Residuals"),
+ c("Df", "Sum Sq", "Mean Sq", "F value", "Pr(>F)")))
+ sumry[1, ] <- c(df1, a1, r1, Fvalue, proba)
+ sumry[2, 1:3] <- c(df2, a2, r2)
+ sumry[2, 4:5] <- NA
+ res$sumry <- data.frame(sumry, check.names = FALSE)
+ class(res$sumry) <- c("anova", "data.frame")
+ return(res)
+}
diff --git a/R/varipart.R b/R/varipart.R
new file mode 100644
index 0000000..92d538a
--- /dev/null
+++ b/R/varipart.R
@@ -0,0 +1,57 @@
+varipart <- function(dudiY, X, W, nrepet = 999, type = c("simulated", "parametric"), ...){
+
+
+ response.generic <- as.matrix(dudiY$tab)
+ inertot <- sum(dudiY$eig)
+ sqlw <- sqrt(dudiY$lw)
+ sqcw <- sqrt(dudiY$cw)
+ type <- match.arg(type)
+
+ # fast computation of R2/adjusted
+ R2test <- function(df){
+ df <- data.frame(df)
+ fmla <- as.formula(paste("response.generic ~", paste(names(df), collapse = "+")))
+ mf <- model.frame(fmla, data = cbind.data.frame(response.generic,df))
+ mt <- attr(mf,"terms")
+ x <- model.matrix(mt, mf)
+ wt <- outer(sqlw, sqcw)
+
+ ## Fast function for computing sum of squares of the fitted table
+ obs <- sum((lm.wfit(y = response.generic, x = x, w = dudiY$lw)$fitted.values * wt)^2) / inertot
+ isim <- c()
+ for(i in 1:nrepet)
+ isim[i] <- sum((lm.wfit(y = response.generic, x = x[sample(nrow(x)),], w = dudiY$lw)$fitted.values * wt)^2) / inertot
+
+ r2 <- c(obs, isim)
+
+ ## adjustment
+ p <- ncol(x) - 1 ## we remove 1 for the intercept
+ if(type == "parametric") ## rajouter test pour acp
+ r2.adj <- 1 - (1 - r2) / (1 - p / (nrow(x) - 1))
+ else if(type == "simulated")
+ r2.adj <- 1 - (1 - r2) / (1 - mean(r2[-1]))
+
+ return(list(r2 = r2, r2.adj = r2.adj))
+ }
+
+ # y=pop, x=env, w=space, n=nb of permutation
+ rda.ab <- R2test(X)
+ rda.bc <- R2test(W)
+ rda.abc <- R2test(cbind(X, W))
+
+ test <- as.krandtest(obs = c(rda.ab$r2[1], rda.bc$r2[1], rda.abc$r2[1]), sim = cbind(rda.ab$r2, rda.bc$r2, rda.abc$r2)[-1,], names = c("ab", "bc", "abc"), call = match.call(), ...)
+
+ a.adj <- rda.abc$r2.adj[1] - rda.bc$r2.adj[1]
+ c.adj <- rda.abc$r2.adj[1] - rda.ab$r2.adj[1]
+ b.adj <- rda.abc$r2.adj[1]- a.adj - c.adj
+ d.adj <- 1 - rda.abc$r2.adj[1]
+
+ a <- rda.abc$r2[1] - rda.bc$r2[1]
+ c <- rda.abc$r2[1] - rda.ab$r2[1]
+ b <- rda.abc$r2[1]- a - c
+ d <- 1 - rda.abc$r2[1]
+
+ res <- list(test = test, R2 = c(a = a, b = b, c = c, d = d), R2.adj = c(a = a.adj, b = b.adj, c = c.adj, d = d.adj), call = match.call())
+ class(res) <- c("varipart", "list")
+ return(res)
+}
diff --git a/R/wca.rlq.R b/R/wca.rlq.R
new file mode 100644
index 0000000..08c0380
--- /dev/null
+++ b/R/wca.rlq.R
@@ -0,0 +1,137 @@
+"wca.rlq" <- function (x, fac, scannf = TRUE, nf = 2, ...)
+{
+ if (!inherits(x, "rlq"))
+ stop("Object of class rlq expected")
+ if (!is.factor(fac))
+ stop("factor expected")
+ appel <- as.list(x$call)
+ dudiR <- eval.parent(appel$dudiR)
+ dudiL <- eval.parent(appel$dudiL)
+ dudiQ <- eval.parent(appel$dudiQ)
+ ligR <- nrow(dudiR$tab)
+ if (length(fac) != ligR)
+ stop("Non convenient dimension")
+ cla.w <- tapply(dudiR$lw, fac, sum)
+ mean.w <- function(x, w, fac, cla.w) {
+ z <- x * w
+ z <- tapply(z, fac, sum)/cla.w
+ return(z)
+ }
+ tabmoyR <- apply(dudiR$tab, 2, mean.w, w = dudiR$lw, fac = fac,
+ cla.w = cla.w)
+ tabmoyR <- data.frame(tabmoyR)
+ tabwitR <- dudiR$tab - tabmoyR[fac, ]
+
+ tabmoyL <- apply(dudiL$tab, 2, mean.w, w = dudiL$lw, fac = fac,
+ cla.w = cla.w)
+ tabmoyL <- data.frame(tabmoyL)
+ tabwitL <- dudiL$tab - tabmoyL[fac, ]
+
+ dudiwitR <- as.dudi(tabwitR, dudiR$cw, dudiR$lw, scannf = FALSE,
+ nf = nf, call = match.call(), type = "wit")
+ dudiwitL <- as.dudi(tabwitL, dudiL$cw, dudiL$lw, scannf = FALSE,
+ nf = nf, call = match.call(), type = "coa")
+
+ res <- rlq(dudiwitR, dudiwitL, dudiQ, scannf = scannf,
+ nf = nf)
+ res$call <- match.call()
+
+ U <- as.matrix(res$l1) * unlist(res$lw)
+ U <- data.frame(as.matrix(dudiR$tab) %*% U)
+ row.names(U) <- row.names(dudiR$tab)
+ names(U) <- names(res$l1)
+ res$lsR <- U
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(t(as.matrix(x$c1)) %*% U)
+ row.names(U) <- names(x$c1)
+ names(U) <- names(res$c1)
+ res$acQ <- U
+
+ U <- as.matrix(res$l1) * unlist(res$lw)
+ U <- data.frame(t(as.matrix(x$l1)) %*% U)
+ row.names(U) <- names(x$l1)
+ names(U) <- names(res$l1)
+ res$acR <- U
+
+ class(res) <- c("witrlq", "dudi")
+ return(res)
+}
+
+"print.witrlq" <- function (x, ...)
+{
+ if (!inherits(x, "witrlq"))
+ stop("to be used with 'witrlq' object")
+ cat("Within RLQ analysis\n")
+ cat("call: ")
+ print(x$call)
+ cat("class: ")
+ cat(class(x), "\n")
+ cat("\n$rank (rank):", x$rank)
+ cat("\n$nf (axis saved):", x$nf)
+ cat("\n\neigen values: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n\n")
+ else cat("\n\n")
+ sumry <- array("", c(3, 4), list(1:3, c("vector", "length",
+ "mode", "content")))
+ sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
+ sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weigths (crossed array)")
+ sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), "col weigths (crossed array)")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(14, 4), list(1:14, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "crossed array (CA)")
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "R col = CA row: coordinates")
+ sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "R col = CA row: normed scores")
+ sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "Q col = CA column: coordinates")
+ sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "Q col = CA column: normed scores")
+ sumry[6, ] <- c("$lR", nrow(x$lR), ncol(x$lR), "row coordinates (R)")
+ sumry[7, ] <- c("$lsR", nrow(x$lsR), ncol(x$lsR), "supplementary row coordinates (R)")
+ sumry[8, ] <- c("$mR", nrow(x$mR), ncol(x$mR), "normed row scores (R)")
+ sumry[9, ] <- c("$lQ", nrow(x$lQ), ncol(x$lQ), "row coordinates (Q)")
+ sumry[10, ] <- c("$mQ", nrow(x$mQ), ncol(x$mQ), "normed row scores (Q)")
+ sumry[11, ] <- c("$aR", nrow(x$aR), ncol(x$aR), "axes onto within-RLQ axes (R)")
+ sumry[12, ] <- c("$aQ", nrow(x$aQ), ncol(x$aQ), "axes onto within-RLQ axes (Q)")
+ sumry[13, ] <- c("$acR", nrow(x$acR), ncol(x$acR), "RLQ axes onto within-RLQ axes (R)")
+ sumry[14, ] <- c("$acQ", nrow(x$acQ), ncol(x$acQ), "RLQ axes onto within-RLQ axes (Q)")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+}
+
+
+"plot.witrlq" <- function (x, xax = 1, yax = 2, ...)
+{
+ if (!inherits(x, "witrlq"))
+ stop("Use only with 'witrlq' objects")
+ if (x$nf == 1) {
+ warnings("One axis only : not yet implemented")
+ return(invisible())
+ }
+ if (xax > x$nf)
+ stop("Non convenient xax")
+ if (yax > x$nf)
+ stop("Non convenient yax")
+ fac <- eval.parent(as.list(x$call)$fac)
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ layout(matrix(c(1, 1, 3, 1, 1, 4, 2, 2, 5, 2, 2, 6, 8, 8,
+ 7), 3, 5), respect = TRUE)
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ s.class(x$lsR[, c(xax, yax)], fac = fac, sub = "R row scores and classes", csub = 2,
+ clabel = 1.25)
+ s.label(x$lQ[, c(xax, yax)], sub = "Q row scores", csub = 2,
+ clabel = 1.25)
+ s.corcircle(x$aR, xax, yax, sub = "R axes", csub = 2, clabel = 1.25)
+ s.arrow(x$l1, xax = xax, yax = yax, sub = "R Canonical weights",
+ csub = 2, clabel = 1.25)
+ s.corcircle(x$aQ, xax, yax, sub = "Q axes", csub = 2, clabel = 1.25)
+ s.arrow(x$c1, xax = xax, yax = yax, sub = "Q Canonical weights",
+ csub = 2, clabel = 1.25)
+ scatterutil.eigen(x$eig, wsel = c(xax, yax))
+}
+
diff --git a/R/within.R b/R/within.R
new file mode 100644
index 0000000..0cf074f
--- /dev/null
+++ b/R/within.R
@@ -0,0 +1,134 @@
+wca <- function (x, ...) UseMethod("wca")
+
+"wca.dudi" <- function (x, fac, scannf = TRUE, nf = 2, ...) {
+ if (!inherits(x, "dudi"))
+ stop("Object of class dudi expected")
+ if (!is.factor(fac))
+ stop("factor expected")
+ lig <- nrow(x$tab)
+ if (length(fac) != lig)
+ stop("Non convenient dimension")
+ cla.w <- tapply(x$lw, fac, sum)
+ mean.w <- function(x, w, fac, cla.w) {
+ z <- x * w
+ z <- tapply(z, fac, sum)/cla.w
+ return(z)
+ }
+ tabmoy <- apply(x$tab, 2, mean.w, w = x$lw, fac = fac,
+ cla.w = cla.w)
+ tabw <- unlist(tapply(x$lw, fac, sum))
+ tabw <- tabw/sum(tabw)
+ tabwit <- x$tab - tabmoy[fac, ]
+ res <- as.dudi(tabwit, x$cw, x$lw, scannf = scannf, nf = nf,
+ call = match.call(), type = "wit")
+ res$ratio <- sum(res$eig)/sum(x$eig)
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(as.matrix(x$tab) %*% U)
+ row.names(U) <- row.names(x$tab)
+ names(U) <- names(res$li)
+ res$ls <- U
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(t(as.matrix(x$c1)) %*% U)
+ row.names(U) <- names(x$li)
+ names(U) <- names(res$li)
+ res$as <- U
+ res$tabw <- tabw
+ res$fac <- fac
+ class(res) <- c("within", "dudi")
+ return(res)
+}
+
+"within" <- function (dudi, fac, scannf = TRUE, nf = 2) {
+ .Deprecated("wca", "ade4", "To avoid some name conflicts, the 'within' function is now deprecated. Please use 'wca' instead")
+ res <- wca(x=dudi, fac=fac, scannf = scannf, nf = nf)
+ res$call <- match.call()
+ return(res)
+}
+
+"plot.within" <- function (x, xax = 1, yax = 2, ...) {
+ if (!inherits(x, "within"))
+ stop("Use only with 'within' objects")
+ if ((x$nf == 1) || (xax == yax)) {
+ return(invisible())
+ }
+ if (xax > x$nf)
+ stop("Non convenient xax")
+ if (yax > x$nf)
+ stop("Non convenient yax")
+ fac <- x$fac
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3),
+ respect = TRUE)
+ par(mar = c(0.2, 0.2, 0.2, 0.2))
+ s.arrow(x$c1, xax = xax, yax = yax, sub = "Canonical weights",
+ csub = 2, clabel = 1.25)
+ s.arrow(x$co, xax = xax, yax = yax, sub = "Variables",
+ csub = 2, clabel = 1.25)
+ scatterutil.eigen(x$eig, wsel = c(xax, yax))
+ s.class(x$ls, fac, wt = x$lw, xax = xax, yax = yax, sub = "Scores and classes",
+ csub = 2, clabel = 1.5, cpoint = 2)
+ s.corcircle(x$as, xax = xax, yax = yax, sub = "Inertia axes",
+ csub = 2, cgrid = 0, clabel = 1.25)
+ s.class(x$li, fac, wt = x$lw, xax = xax, yax = yax, axesell = FALSE,
+ clabel = 0, cstar = 0, sub = "Common centring", csub = 2)
+}
+
+"print.within" <- function (x, ...) {
+ if (!inherits(x, "within"))
+ stop("to be used with 'within' object")
+ cat("Within analysis\n")
+ cat("call: ")
+ print(x$call)
+ cat("class: ")
+ cat(class(x), "\n")
+ cat("\n$nf (axis saved) :", x$nf)
+ cat("\n$rank: ", x$rank)
+ cat("\n$ratio: ", x$ratio)
+ cat("\n\neigen values: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n\n")
+ else cat("\n\n")
+ sumry <- array("", c(5, 4), list(1:5, c("vector", "length",
+ "mode", "content")))
+ sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
+ sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weigths")
+ sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), "col weigths")
+ sumry[4, ] <- c("$tabw", length(x$tabw), mode(x$tabw), "class weigths")
+ sumry[5, ] <- c("$fac", length(x$fac), mode(x$fac), "factor for grouping")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(7, 4), list(1:7, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "array class-variables")
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates")
+ sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "row normed scores")
+ sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates")
+ sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores")
+ sumry[6, ] <- c("$ls", nrow(x$ls), ncol(x$ls), "supplementary row coordinates")
+ sumry[7, ] <- c("$as", nrow(x$as), ncol(x$as), "inertia axis onto within axis")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+}
+
+
+summary.within <- function(object, ...){
+ thetitle <- "Within-class analysis"
+ cat(thetitle)
+ cat("\n\n")
+ NextMethod()
+ appel <- as.list(object$call)
+ dudi <- eval.parent(appel$x)
+ cat(paste("Total unconstrained inertia (", deparse(appel$x),
+ "): ", sep = ""))
+ cat(signif(sum(dudi$eig), 4))
+ cat("\n\n")
+ cat(paste("Inertia of", deparse(appel$x), "independent of",
+ deparse(appel$fac), "(%): "))
+ cat(signif(object$ratio * 100, 4))
+ cat("\n\n")
+}
diff --git a/R/withincoinertia.R b/R/withincoinertia.R
new file mode 100644
index 0000000..246057f
--- /dev/null
+++ b/R/withincoinertia.R
@@ -0,0 +1,178 @@
+wca.coinertia <- function (x, fac, scannf = TRUE, nf = 2, ...){
+ if (!inherits(x, "coinertia"))
+ stop("Object of class coinertia expected")
+ if (!is.factor(fac))
+ stop("factor expected")
+ appel <- as.list(x$call)
+ dudiX <- eval.parent(appel$dudiX)
+ dudiY <- eval.parent(appel$dudiY)
+ ligX <- nrow(dudiX$tab)
+ if (length(fac) != ligX)
+ stop("Non convenient dimension")
+
+ mean.w <- function(x, w, fac, cla.w) {
+ z <- x * w
+ z <- tapply(z, fac, sum)/cla.w
+ return(z)
+ }
+ cla.w <- tapply(dudiX$lw, fac, sum)
+ tabmoyX <- apply(dudiX$tab, 2, mean.w, w = dudiX$lw, fac = fac,
+ cla.w = cla.w)
+
+ tabmoyY <- apply(dudiY$tab, 2, mean.w, w = dudiY$lw, fac = fac,
+ cla.w = cla.w)
+ tabwitX <- dudiX$tab - tabmoyX[fac, ]
+ names(tabwitX) <- names(dudiX$tab)
+ row.names(tabwitX) <- row.names(dudiX$tab)
+ tabwitY <- dudiY$tab - tabmoyY[fac, ]
+ names(tabwitY) <- names(dudiY$tab)
+ row.names(tabwitY) <- row.names(dudiY$tab)
+
+ dudiwitX <- as.dudi(tabwitX, dudiX$cw, dudiX$lw, scannf = FALSE,
+ nf = nf, call = match.call(), type = "wit")
+ dudiwitY <- as.dudi(tabwitY, dudiY$cw, dudiY$lw, scannf = FALSE,
+ nf = nf, call = match.call(), type = "wit")
+
+ res <- coinertia(dudiwitX, dudiwitY, scannf = scannf,
+ nf = nf)
+ res$call <- match.call()
+ ## cov=covB+covW, donc ce n'est pas vrai pour les carres et donc la coinertie
+ ##res$ratio <- sum(res$eig)/sum(x$eig)
+ U <- as.matrix(res$l1) * unlist(res$lw)
+ U <- data.frame(as.matrix(dudiY$tab) %*% U)
+ row.names(U) <- row.names(dudiY$tab)
+ names(U) <- names(res$l1)
+ res$lsY <- U
+
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(as.matrix(dudiX$tab) %*% U)
+ row.names(U) <- row.names(dudiX$tab)
+ names(U) <- names(res$c1)
+ res$lsX <- U
+
+ ratioX<-unlist(res$mX[1,]/res$lX[1,])
+ res$msX<-data.frame(t(t(res$lsX)*ratioX))
+ row.names(res$msX) <- row.names(res$lsX)
+ names(res$msX) <- names(res$mX)
+
+ ratioY<-unlist(res$mY[1,]/res$lY[1,])
+ res$msY<-data.frame(t(t(res$lsY)*ratioY))
+ row.names(res$msY) <- row.names(res$lsY)
+ names(res$msY) <- names(res$mY)
+
+ U <- as.matrix(res$l1) * unlist(res$lw)
+ U <- data.frame(t(as.matrix(x$l1)) %*% U)
+ row.names(U) <- paste("AxcY", (1:x$nf), sep = "")
+ names(U) <- paste("AxwcY", (1:res$nf), sep = "")
+ res$acY <- U
+ names(res$aY)<-names(res$lY)<-names(res$lsY)<-names(res$acY)
+
+ U <- as.matrix(res$c1) * unlist(res$cw)
+ U <- data.frame(t(as.matrix(x$c1)) %*% U)
+ row.names(U) <- paste("AxcX", (1:x$nf), sep = "")
+ names(U) <- paste("AxwcX", (1:res$nf), sep = "")
+ res$acX <- U
+ names(res$aX)<-names(res$lX)<-names(res$lsX)<-names(res$acX)
+
+ class(res) <- c("witcoi","dudi")
+ return(res)
+}
+
+
+withincoinertia <- function (obj, fac, scannf = TRUE, nf = 2){
+ .Deprecated("wca", "ade4", "To avoid some name conflicts, the 'withincoinertia' function is now deprecated. Please use 'wca.coinertia' instead")
+ res <- wca(x=obj, fac=fac, scannf = scannf, nf = nf)
+ res$call <- match.call()
+ return(res)
+}
+
+
+plot.witcoi <-
+function(x, xax = 1, yax = 2, ...) {
+ if (!inherits(x, "witcoi"))
+ stop("Use only with 'witcoi' objects")
+ if (x$nf == 1) {
+ warnings("One axis only : not yet implemented")
+ return(invisible())
+ }
+ if (xax > x$nf)
+ stop("Non convenient xax")
+ if (yax > x$nf)
+ stop("Non convenient yax")
+ appel <- as.list(x$call)
+ fac <- eval.parent(appel$fac)
+ def.par <- par(no.readonly = TRUE)
+ on.exit(par(def.par))
+ nf <- layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3),
+ respect = TRUE)
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ s.arrow(x$aX, xax, yax, sub = "X axes", csub = 2, clabel = 1.25)
+ s.arrow(x$aY, xax, yax, sub = "Y axes", csub = 2, clabel = 1.25)
+ scatterutil.eigen(x$eig, wsel = c(xax, yax))
+ s.match.class(df1xy = x$msX, df2xy = x$msY, fac = fac, clabel = 1.5) # wt?
+
+ s.arrow(x$l1, xax = xax, yax = yax, sub = "Y Canonical weights",
+ csub = 2, clabel = 1.25)
+ s.arrow(x$c1, xax = xax, yax = yax, sub = "X Canonical weights",
+ csub = 2, clabel = 1.25)
+
+}
+
+print.witcoi <-
+function (x, ...)
+{
+ if (!inherits(x, "witcoi"))
+ stop("to be used with 'witcoi' object")
+ cat("Within coinertia analysis\n")
+ cat("call: ")
+ print(x$call)
+ cat("class: ")
+ cat(class(x), "\n")
+ cat("\n$rank (rank) :", x$rank)
+ cat("\n$nf (axis saved) :", x$nf)
+ cat("\n$RV (RV coeff) :", x$RV)
+ cat("\n\neigen values: ")
+ l0 <- length(x$eig)
+ cat(signif(x$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n\n")
+ else cat("\n\n")
+ sumry <- array("", c(3, 4), list(1:3, c("vector", "length",
+ "mode", "content")))
+ sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
+ sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weigths (crossed array)")
+ sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), "col weigths (crossed array)")
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(17, 4), list(1:17, c("data.frame", "nrow",
+ "ncol", "content")))
+ sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "crossed array (CA)")
+ sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "Y col = CA row: coordinates")
+ sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "Y col = CA row: normed scores")
+ sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "X col = CA column: coordinates")
+ sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "X col = CA column: normed scores")
+ sumry[6, ] <- c("$lX", nrow(x$lX), ncol(x$lX), "row coordinates (X)")
+ sumry[7, ] <- c("$mX", nrow(x$mX), ncol(x$mX), "normed row scores (X)")
+ sumry[8, ] <- c("$lY", nrow(x$lY), ncol(x$lY), "row coordinates (Y)")
+ sumry[9, ] <- c("$mY", nrow(x$mY), ncol(x$mY), "normed row scores (Y)")
+
+ sumry[10, ] <- c("$lsX", nrow(x$lsX), ncol(x$lsX), "supplementary row coordinates (X)")
+ sumry[11, ] <- c("$msX", nrow(x$msX), ncol(x$msX), "supplementary normed row scores (X)")
+ sumry[12, ] <- c("$lsY", nrow(x$lsY), ncol(x$lsY), "supplementaryrow coordinates (Y)")
+ sumry[13, ] <- c("$msY", nrow(x$msY), ncol(x$msY), "supplementary normed row scores (Y)")
+ sumry[14, ] <- c("$aX", nrow(x$aX), ncol(x$aX),
+ "within axis onto within co-inertia axis (X)")
+ sumry[15, ] <- c("$aY", nrow(x$aY), ncol(x$aY),
+ "within axis onto within co-inertia axis (Y)")
+ sumry[16, ] <- c("$acX", nrow(x$acX), ncol(x$acX),
+ "co-inertia axis onto within co-inertia axis (X)")
+ sumry[17, ] <- c("$acY", nrow(x$acY), ncol(x$acY),
+ "co-inertia axis onto within co-inertia axis (Y)")
+
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+}
+
+
diff --git a/R/withinpca.R b/R/withinpca.R
new file mode 100644
index 0000000..22f6221
--- /dev/null
+++ b/R/withinpca.R
@@ -0,0 +1,56 @@
+"withinpca" <- function (df, fac, scaling = c("partial", "total"), scannf = TRUE,
+ nf = 2)
+{
+ if (!inherits(df, "data.frame"))
+ stop("Object of class 'data.frame' expected")
+ if (!is.factor(fac))
+ stop("factor expected")
+ lig <- nrow(df)
+ if (length(fac) != lig)
+ stop("Non convenient dimension")
+ cla.w <- tapply(rep(1, length(fac)), fac, sum)
+ df <- data.frame(scalewt(df))
+ mean.w <- function(x) tapply(x, fac, sum)/cla.w
+ tabmoy <- apply(df, 2, mean.w)
+ tabw <- cla.w
+ tabw <- tabw/sum(tabw)
+ tabwit <- df
+ tabwit <- tabwit - tabmoy[fac, ]
+ scaling <- match.arg(scaling)
+ if (scaling == "total") {
+ tabwit <- scalewt(tabwit, center = FALSE, scale = TRUE)
+ }
+ else if (scaling == "partial") {
+ for (j in levels(fac)) {
+ w <- tabwit[fac == j, ]
+ w <- scalewt(w)
+ tabwit[fac == j, ] <- w
+ }
+ }
+
+ tabwit <- data.frame(tabwit)
+
+ df <- tabwit + tabmoy[fac, ]
+
+ dudi <- as.dudi(df, row.w = rep(1, nrow(df))/nrow(df), col.w = rep(1,
+ ncol(df)), scannf = FALSE, nf = 4, call = match.call(),
+ type = "tmp")
+ X <- as.dudi(tabwit, row.w = rep(1, nrow(df))/nrow(df), col.w = rep(1,
+ ncol(df)), scannf = scannf, nf = nf, call = match.call(),
+ type = "wit")
+ X$ratio <- sum(X$eig)/sum(dudi$eig)
+ U <- as.matrix(X$c1) * unlist(X$cw)
+ U <- data.frame(as.matrix(dudi$tab) %*% U)
+ row.names(U) <- row.names(dudi$tab)
+ names(U) <- names(X$c1)
+ X$ls <- U
+ U <- as.matrix(X$c1) * unlist(X$cw)
+ U <- data.frame(t(as.matrix(dudi$c1)) %*% U)
+ row.names(U) <- names(dudi$li)
+ names(U) <- names(X$li)
+ X$as <- U
+ X$tabw <- tabw
+ X$fac <- fac
+ class(X) <- c("within", "dudi")
+ return(X)
+}
diff --git a/R/witwit.R b/R/witwit.R
new file mode 100644
index 0000000..0b58574
--- /dev/null
+++ b/R/witwit.R
@@ -0,0 +1,126 @@
+"witwit.coa" <- function (dudi, row.blocks, col.blocks, scannf = TRUE, nf = 2) {
+ if (!inherits(dudi, "coa"))
+ stop("Object of class coa expected")
+ lig <- nrow(dudi$tab)
+ col <- ncol(dudi$tab)
+ row.fac <- rep(1:length(row.blocks),row.blocks)
+ col.fac <- rep(1:length(col.blocks),col.blocks)
+ if (length(col.fac)!=col) stop ("Non convenient col.fac")
+ if (length(row.fac)!=lig) stop ("Non convenient row.fac")
+ tabinit <- as.matrix(eval.parent(as.list(dudi$call)$df))
+
+ tabinit <- tabinit/sum(tabinit)
+ # tabinit contient les pij
+ wrmat <- rowsum(tabinit,row.fac, reorder = FALSE)[row.fac,]
+ wrvec <- tapply(dudi$lw,row.fac,sum)[row.fac]
+ wrvec <- as.numeric(wrvec)
+ wrvec <- dudi$lw/wrvec
+ wrmat <- wrmat*wrvec
+ # wrmat contient les pi.*pd(i)j/pd(i)+
+
+ wcmat <- rowsum(t(tabinit),col.fac, reorder = FALSE)[col.fac,]
+ wcvec <- tapply(dudi$cw,col.fac,sum)[col.fac]
+ wcvec <- as.numeric(wcvec)
+ wcvec <- dudi$cw/wcvec
+ wcmat <- t(wcmat*wcvec)
+ # wcmat contient les pj.*pim(j)/p+m(j)
+ wcmat <- wrmat+wcmat
+
+ wrmat <- rowsum(tabinit,row.fac, reorder = FALSE)
+ wrmat <- t(rowsum(t(wrmat),col.fac, reorder = FALSE))
+ wrmat <- wrmat[row.fac,col.fac]
+ wrmat <- wrmat*wrvec
+ wrmat <- t(t(wrmat)*wcvec)
+ # wrmat contient les pi.*p.j*pd(i)m(j)/pd(i)+/p+m(j)
+
+ tabinit <- tabinit-wcmat+wrmat
+ # le tableau est doublement centré par classe de lignes et de colonnes
+ tabinit <- tabinit/dudi$lw
+ tabinit <- t(t(tabinit)/dudi$cw)
+ tabinit <- data.frame(tabinit)
+ ww <- as.dudi(tabinit, dudi$cw, dudi$lw, scannf = scannf, nf = nf,
+ call = match.call(), type = "witwit")
+ class(ww) <- c("witwit", "coa", "dudi")
+
+ wr <- ww$li*ww$li*wrvec
+ wr <- rowsum(as.matrix(wr),row.fac, reorder = FALSE)
+ cha <- names(row.blocks)
+ if (is.null(cha)) cha <- as.character(1:length(row.blocks))
+ wr <- data.frame(wr)
+ names(wr) <- names(ww$li)
+ row.names(wr) <- cha
+ ww$lbvar <- wr
+ ww$lbw <- tapply(dudi$lw,row.fac,sum)
+
+ wr <- ww$co*ww$co*wcvec
+ wr <- rowsum(as.matrix(wr),col.fac, reorder = FALSE)
+ cha <- names(col.blocks)
+ if (is.null(cha)) cha <- as.character(1:length(col.blocks))
+ wr <- data.frame(wr)
+ names(wr) <- names(ww$co)
+ row.names(wr) <- cha
+ ww$cbvar <- wr
+ ww$cbw <- tapply(dudi$cw,col.fac,sum)
+
+
+ return(ww)
+}
+
+"summary.witwit" <- function (object, ...) {
+ if (!inherits(object, "witwit"))
+ stop("For 'witwit' object")
+ cat("Internal correspondence analysis\n")
+ cat("class: ")
+ cat(class(object))
+ cat("\n$call: ")
+ print(object$call)
+ cat(object$nf, "axis-components saved")
+ cat("\neigen values: ")
+ l0 <- length(object$eig)
+ cat(signif(object$eig, 4)[1:(min(5, l0))])
+ if (l0 > 5)
+ cat(" ...\n")
+ else cat("\n")
+ cat("\n")
+ cat("Eigen value decomposition among row blocks\n")
+ nf <- object$nf
+ nrb <- nrow(object$lbvar)
+ aa <- as.matrix(object$lbvar)
+ sumry <- array("", c(nrb + 1, nf + 1), list(c(row.names(object$lbvar),
+ "mean"), c(names(object$lbvar), "weights")))
+ sumry[(1:nrb), (1:nf)] <- round(aa, digits = 4)
+ sumry[(1:nrb), (nf + 1)] <- round(object$lbw, digits = 4)
+ sumry[(nrb + 1), (1:nf)] <- round(object$eig[1:nf], digits = 4)
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(nrb + 1, nf), list(c(row.names(object$lbvar),
+ "sum"), names(object$lbvar)))
+ aa <- object$lbvar * object$lbw
+ aa <- 1000 * t(t(aa)/object$eig[1:nf])
+ sumry[(1:nrb), (1:nf)] <- round(aa, digits = 0)
+ sumry[(nrb + 1), (1:nf)] <- rep(1000, nf)
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ cat("Eigen value decomposition among column blocks\n")
+ nrb <- nrow(object$cbvar)
+ aa <- as.matrix(object$cbvar)
+ sumry <- array("", c(nrb + 1, nf + 1), list(c(row.names(object$cbvar),
+ "mean"), c(names(object$cbvar), "weights")))
+ sumry[(1:nrb), (1:nf)] <- round(aa, digits = 4)
+ sumry[(1:nrb), (nf + 1)] <- round(object$cbw, digits = 4)
+ sumry[(nrb + 1), (1:nf)] <- round(object$eig[1:nf], digits = 4)
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+ sumry <- array("", c(nrb + 1, nf), list(c(row.names(object$cbvar),
+ "sum"), names(object$cbvar)))
+ aa <- object$cbvar * object$cbw
+ aa <- 1000 * t(t(aa)/object$eig[1:nf])
+ sumry[(1:nrb), (1:nf)] <- round(aa, digits = 0)
+ sumry[(nrb + 1), (1:nf)] <- rep(1000, nf)
+
+ print(sumry, quote = FALSE)
+ cat("\n")
+}
diff --git a/R/witwitsepan.R b/R/witwitsepan.R
new file mode 100644
index 0000000..f8dcd78
--- /dev/null
+++ b/R/witwitsepan.R
@@ -0,0 +1,57 @@
+witwitsepan <- function (ww, mfrow = NULL, csub = 2, plot = TRUE) {
+ if (!inherits(ww, "witwit")) stop ("witwit object expected")
+ appel <- as.list(ww$call)
+ rowblo <- eval.parent(appel[[3]])
+ colblo <- eval.parent(appel[[4]])
+ anal <- eval.parent(appel[[2]])
+ tab <- eval.parent(as.list(anal$call)[[2]])
+
+ rowfac=as.factor(rep(1:length(rowblo),rowblo))
+ if (is.null(names(rowblo))) names(rowblo) <- as.character(1:length(rowblo))
+ levels(rowfac)=names(rowblo)
+
+ colfac=as.factor(rep(1:length(colblo),colblo))
+ if (is.null(names(colblo))) names(colblo) <- as.character(1:length(colblo))
+ levels(colfac)=names(colblo)
+
+ listblocrow = split(tab,rowfac)
+ listbloc = NULL
+ lapply(listblocrow, function(x)
+ listbloc <<- c(listbloc,split(as.data.frame(t(x)),colfac)))
+
+ fun1 <- function(x) {
+ x <- data.frame(x)
+ if (nrow(x) <2) return (NULL)
+ if (ncol(x) <2) return (NULL)
+ sumlig <- apply(x,1,sum)
+ if (sum(sumlig>0)<2) return (NULL)
+ sumcol <- apply(x,2,sum)
+ if (sum(sumcol>0)<2) return (NULL)
+ return(dudi.coa(x, scannf = FALSE)$eig)
+ }
+
+ names(listbloc) <- t(outer(names(rowblo),names(colblo),function(x,y) paste(x,y,sep="/")))
+
+ result <- lapply(listbloc,fun1)
+ if (!plot) return(result)
+
+ opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
+ on.exit(par(opar))
+ par(mar = c(0.6, 2.6, 0.6, 0.6))
+ nbloc <- length(result)
+ if (is.null(mfrow))
+ mfrow <- n2mfrow(nbloc)
+ par(mfrow = mfrow)
+ if (nbloc > prod(mfrow))
+ par(ask = TRUE)
+ neig <- max(unlist(lapply(result,length)))
+ maxeig <- max(unlist(result))
+ for (ianal in 1:nbloc) {
+ w <- result[[ianal]]
+ su0 <- names(result)[ianal]
+ scatterutil.eigen(w, xmax = neig, ymax = maxeig, wsel = 0,
+ sub = su0, csub = csub, possub = "topright",yaxt="s")
+ }
+ return(invisible(result))
+
+}
diff --git a/data/abouheif.eg.rda b/data/abouheif.eg.rda
new file mode 100644
index 0000000..f9d8659
Binary files /dev/null and b/data/abouheif.eg.rda differ
diff --git a/data/acacia.rda b/data/acacia.rda
new file mode 100644
index 0000000..a91f4fd
Binary files /dev/null and b/data/acacia.rda differ
diff --git a/data/aminoacyl.rda b/data/aminoacyl.rda
new file mode 100644
index 0000000..be29f8a
Binary files /dev/null and b/data/aminoacyl.rda differ
diff --git a/data/apis108.rda b/data/apis108.rda
new file mode 100644
index 0000000..f62ec76
Binary files /dev/null and b/data/apis108.rda differ
diff --git a/data/aravo.rda b/data/aravo.rda
new file mode 100644
index 0000000..e3887ea
Binary files /dev/null and b/data/aravo.rda differ
diff --git a/data/ardeche.rda b/data/ardeche.rda
new file mode 100644
index 0000000..efe8e69
Binary files /dev/null and b/data/ardeche.rda differ
diff --git a/data/arrival.rda b/data/arrival.rda
new file mode 100644
index 0000000..ac2b012
Binary files /dev/null and b/data/arrival.rda differ
diff --git a/data/atlas.rda b/data/atlas.rda
new file mode 100644
index 0000000..a3f0d97
Binary files /dev/null and b/data/atlas.rda differ
diff --git a/data/atya.rda b/data/atya.rda
new file mode 100644
index 0000000..95ba433
Binary files /dev/null and b/data/atya.rda differ
diff --git a/data/avijons.rda b/data/avijons.rda
new file mode 100644
index 0000000..04c12d6
Binary files /dev/null and b/data/avijons.rda differ
diff --git a/data/avimedi.rda b/data/avimedi.rda
new file mode 100644
index 0000000..7a875cd
Binary files /dev/null and b/data/avimedi.rda differ
diff --git a/data/aviurba.rda b/data/aviurba.rda
new file mode 100644
index 0000000..9a8e648
Binary files /dev/null and b/data/aviurba.rda differ
diff --git a/data/bacteria.rda b/data/bacteria.rda
new file mode 100644
index 0000000..8406dd2
Binary files /dev/null and b/data/bacteria.rda differ
diff --git a/data/banque.rda b/data/banque.rda
new file mode 100644
index 0000000..d3d312d
Binary files /dev/null and b/data/banque.rda differ
diff --git a/data/baran95.rda b/data/baran95.rda
new file mode 100644
index 0000000..331e9dd
Binary files /dev/null and b/data/baran95.rda differ
diff --git a/data/bf88.rda b/data/bf88.rda
new file mode 100644
index 0000000..c68d10c
Binary files /dev/null and b/data/bf88.rda differ
diff --git a/data/bordeaux.rda b/data/bordeaux.rda
new file mode 100644
index 0000000..cbec37a
Binary files /dev/null and b/data/bordeaux.rda differ
diff --git a/data/bsetal97.rda b/data/bsetal97.rda
new file mode 100644
index 0000000..7c148f0
Binary files /dev/null and b/data/bsetal97.rda differ
diff --git a/data/buech.rda b/data/buech.rda
new file mode 100644
index 0000000..d90bbcc
Binary files /dev/null and b/data/buech.rda differ
diff --git a/data/butterfly.rda b/data/butterfly.rda
new file mode 100644
index 0000000..ecf365f
Binary files /dev/null and b/data/butterfly.rda differ
diff --git a/data/capitales.rda b/data/capitales.rda
new file mode 100644
index 0000000..31905b8
Binary files /dev/null and b/data/capitales.rda differ
diff --git a/data/carni19.rda b/data/carni19.rda
new file mode 100644
index 0000000..f5cafb6
Binary files /dev/null and b/data/carni19.rda differ
diff --git a/data/carni70.rda b/data/carni70.rda
new file mode 100644
index 0000000..fa6f53f
Binary files /dev/null and b/data/carni70.rda differ
diff --git a/data/carniherbi49.rda b/data/carniherbi49.rda
new file mode 100644
index 0000000..889a0d5
Binary files /dev/null and b/data/carniherbi49.rda differ
diff --git a/data/casitas.rda b/data/casitas.rda
new file mode 100644
index 0000000..9baf418
Binary files /dev/null and b/data/casitas.rda differ
diff --git a/data/chatcat.rda b/data/chatcat.rda
new file mode 100644
index 0000000..46af2e0
Binary files /dev/null and b/data/chatcat.rda differ
diff --git a/data/chats.rda b/data/chats.rda
new file mode 100644
index 0000000..dfc7160
Binary files /dev/null and b/data/chats.rda differ
diff --git a/data/chazeb.rda b/data/chazeb.rda
new file mode 100644
index 0000000..048d4db
Binary files /dev/null and b/data/chazeb.rda differ
diff --git a/data/chevaine.rda b/data/chevaine.rda
new file mode 100644
index 0000000..859b0d8
Binary files /dev/null and b/data/chevaine.rda differ
diff --git a/data/chickenk.rda b/data/chickenk.rda
new file mode 100644
index 0000000..a1f5e38
Binary files /dev/null and b/data/chickenk.rda differ
diff --git a/data/clementines.rda b/data/clementines.rda
new file mode 100644
index 0000000..27caf6b
Binary files /dev/null and b/data/clementines.rda differ
diff --git a/data/cnc2003.rda b/data/cnc2003.rda
new file mode 100644
index 0000000..7c67fe2
Binary files /dev/null and b/data/cnc2003.rda differ
diff --git a/data/coleo.rda b/data/coleo.rda
new file mode 100644
index 0000000..2a87774
Binary files /dev/null and b/data/coleo.rda differ
diff --git a/data/corvus.rda b/data/corvus.rda
new file mode 100644
index 0000000..8d56335
Binary files /dev/null and b/data/corvus.rda differ
diff --git a/data/datalist b/data/datalist
new file mode 100644
index 0000000..c1f7c3d
--- /dev/null
+++ b/data/datalist
@@ -0,0 +1,108 @@
+abouheif.eg
+acacia
+aminoacyl
+apis108
+aravo
+ardeche
+arrival
+atlas
+atya
+avijons
+avimedi
+aviurba
+bacteria
+banque
+baran95
+bf88
+bordeaux
+bsetal97
+buech
+butterfly
+capitales
+carni19
+carni70
+carniherbi49
+casitas
+chatcat
+chats
+chazeb
+chevaine
+chickenk
+clementines
+cnc2003
+coleo
+corvus
+deug
+doubs
+dunedata
+ecg
+ecomor
+elec88
+escopage
+euro123
+fission
+friday87
+fruits
+ggtortoises
+granulo
+hdpg
+housetasks
+humDNAm
+ichtyo
+irishdata
+julliot
+jv73
+kcponds
+lascaux
+lizards
+macaca
+macon
+macroloire
+mafragh
+maples
+mariages
+meau
+meaudret
+microsatt
+mjrochet
+mollusc
+monde84
+morphosport
+newick.eg
+njplot
+olympic
+oribatid
+ours
+palm
+pap
+pcw
+perthi02
+piosphere
+presid2002
+procella
+rankrock
+rhizobium
+rhone
+rpjdl
+santacatalina
+sarcelles
+seconde
+skulls
+steppe
+syndicats
+t3012
+tarentaise
+taxo.eg
+tintoodiel
+tithonia
+tortues
+toxicity
+trichometeo
+ungulates
+vegtf
+veuvage
+westafrica
+woangers
+worksurv
+yanomama
+zealand
diff --git a/data/deug.rda b/data/deug.rda
new file mode 100644
index 0000000..90385ed
Binary files /dev/null and b/data/deug.rda differ
diff --git a/data/doubs.rda b/data/doubs.rda
new file mode 100644
index 0000000..52f6c0b
Binary files /dev/null and b/data/doubs.rda differ
diff --git a/data/dunedata.rda b/data/dunedata.rda
new file mode 100644
index 0000000..03407e1
Binary files /dev/null and b/data/dunedata.rda differ
diff --git a/data/ecg.rda b/data/ecg.rda
new file mode 100644
index 0000000..74d7dd5
Binary files /dev/null and b/data/ecg.rda differ
diff --git a/data/ecomor.rda b/data/ecomor.rda
new file mode 100644
index 0000000..ed6f43a
Binary files /dev/null and b/data/ecomor.rda differ
diff --git a/data/elec88.rda b/data/elec88.rda
new file mode 100644
index 0000000..ade4790
Binary files /dev/null and b/data/elec88.rda differ
diff --git a/data/escopage.rda b/data/escopage.rda
new file mode 100644
index 0000000..c8a2f65
Binary files /dev/null and b/data/escopage.rda differ
diff --git a/data/euro123.rda b/data/euro123.rda
new file mode 100644
index 0000000..5060f5d
Binary files /dev/null and b/data/euro123.rda differ
diff --git a/data/fission.rda b/data/fission.rda
new file mode 100644
index 0000000..10f3ad3
Binary files /dev/null and b/data/fission.rda differ
diff --git a/data/friday87.rda b/data/friday87.rda
new file mode 100644
index 0000000..5c4a935
Binary files /dev/null and b/data/friday87.rda differ
diff --git a/data/fruits.rda b/data/fruits.rda
new file mode 100644
index 0000000..cecc210
Binary files /dev/null and b/data/fruits.rda differ
diff --git a/data/ggtortoises.rda b/data/ggtortoises.rda
new file mode 100644
index 0000000..d6da74a
Binary files /dev/null and b/data/ggtortoises.rda differ
diff --git a/data/granulo.rda b/data/granulo.rda
new file mode 100644
index 0000000..254a9e8
Binary files /dev/null and b/data/granulo.rda differ
diff --git a/data/hdpg.rda b/data/hdpg.rda
new file mode 100644
index 0000000..39bedc1
Binary files /dev/null and b/data/hdpg.rda differ
diff --git a/data/housetasks.rda b/data/housetasks.rda
new file mode 100644
index 0000000..8e0e6d0
Binary files /dev/null and b/data/housetasks.rda differ
diff --git a/data/humDNAm.rda b/data/humDNAm.rda
new file mode 100644
index 0000000..d06b863
Binary files /dev/null and b/data/humDNAm.rda differ
diff --git a/data/ichtyo.rda b/data/ichtyo.rda
new file mode 100644
index 0000000..58d8a71
Binary files /dev/null and b/data/ichtyo.rda differ
diff --git a/data/irishdata.rda b/data/irishdata.rda
new file mode 100644
index 0000000..dd24519
Binary files /dev/null and b/data/irishdata.rda differ
diff --git a/data/julliot.rda b/data/julliot.rda
new file mode 100644
index 0000000..e7554e6
Binary files /dev/null and b/data/julliot.rda differ
diff --git a/data/jv73.rda b/data/jv73.rda
new file mode 100644
index 0000000..c25f2a0
Binary files /dev/null and b/data/jv73.rda differ
diff --git a/data/kcponds.rda b/data/kcponds.rda
new file mode 100644
index 0000000..8015c5d
Binary files /dev/null and b/data/kcponds.rda differ
diff --git a/data/lascaux.rda b/data/lascaux.rda
new file mode 100644
index 0000000..96c752e
Binary files /dev/null and b/data/lascaux.rda differ
diff --git a/data/lizards.rda b/data/lizards.rda
new file mode 100644
index 0000000..da2f10c
Binary files /dev/null and b/data/lizards.rda differ
diff --git a/data/macaca.rda b/data/macaca.rda
new file mode 100644
index 0000000..3f7fbda
Binary files /dev/null and b/data/macaca.rda differ
diff --git a/data/macon.rda b/data/macon.rda
new file mode 100644
index 0000000..2c120b4
Binary files /dev/null and b/data/macon.rda differ
diff --git a/data/macroloire.rda b/data/macroloire.rda
new file mode 100755
index 0000000..9052e57
Binary files /dev/null and b/data/macroloire.rda differ
diff --git a/data/mafragh.rda b/data/mafragh.rda
new file mode 100644
index 0000000..87604c4
Binary files /dev/null and b/data/mafragh.rda differ
diff --git a/data/maples.rda b/data/maples.rda
new file mode 100644
index 0000000..e8ccd6f
Binary files /dev/null and b/data/maples.rda differ
diff --git a/data/mariages.rda b/data/mariages.rda
new file mode 100644
index 0000000..0ccacc8
Binary files /dev/null and b/data/mariages.rda differ
diff --git a/data/meau.rda b/data/meau.rda
new file mode 100644
index 0000000..a51d097
Binary files /dev/null and b/data/meau.rda differ
diff --git a/data/meaudret.rda b/data/meaudret.rda
new file mode 100644
index 0000000..d12afc2
Binary files /dev/null and b/data/meaudret.rda differ
diff --git a/data/microsatt.rda b/data/microsatt.rda
new file mode 100644
index 0000000..3e7e595
Binary files /dev/null and b/data/microsatt.rda differ
diff --git a/data/mjrochet.rda b/data/mjrochet.rda
new file mode 100644
index 0000000..c1d1456
Binary files /dev/null and b/data/mjrochet.rda differ
diff --git a/data/mollusc.rda b/data/mollusc.rda
new file mode 100644
index 0000000..a5ea4ef
Binary files /dev/null and b/data/mollusc.rda differ
diff --git a/data/monde84.rda b/data/monde84.rda
new file mode 100644
index 0000000..bb18b3e
Binary files /dev/null and b/data/monde84.rda differ
diff --git a/data/morphosport.rda b/data/morphosport.rda
new file mode 100644
index 0000000..ae3d478
Binary files /dev/null and b/data/morphosport.rda differ
diff --git a/data/newick.eg.rda b/data/newick.eg.rda
new file mode 100644
index 0000000..e77604e
Binary files /dev/null and b/data/newick.eg.rda differ
diff --git a/data/njplot.rda b/data/njplot.rda
new file mode 100644
index 0000000..a2022d8
Binary files /dev/null and b/data/njplot.rda differ
diff --git a/data/olympic.rda b/data/olympic.rda
new file mode 100644
index 0000000..e1bdc10
Binary files /dev/null and b/data/olympic.rda differ
diff --git a/data/oribatid.rda b/data/oribatid.rda
new file mode 100644
index 0000000..c156dd2
Binary files /dev/null and b/data/oribatid.rda differ
diff --git a/data/ours.rda b/data/ours.rda
new file mode 100644
index 0000000..085cb2d
Binary files /dev/null and b/data/ours.rda differ
diff --git a/data/palm.rda b/data/palm.rda
new file mode 100644
index 0000000..de2fbbd
Binary files /dev/null and b/data/palm.rda differ
diff --git a/data/pap.rda b/data/pap.rda
new file mode 100644
index 0000000..963b3f7
Binary files /dev/null and b/data/pap.rda differ
diff --git a/data/pcw.rda b/data/pcw.rda
new file mode 100644
index 0000000..4c00908
Binary files /dev/null and b/data/pcw.rda differ
diff --git a/data/perthi02.rda b/data/perthi02.rda
new file mode 100644
index 0000000..abf92da
Binary files /dev/null and b/data/perthi02.rda differ
diff --git a/data/piosphere.rda b/data/piosphere.rda
new file mode 100644
index 0000000..d5874b0
Binary files /dev/null and b/data/piosphere.rda differ
diff --git a/data/presid2002.rda b/data/presid2002.rda
new file mode 100644
index 0000000..ff60312
Binary files /dev/null and b/data/presid2002.rda differ
diff --git a/data/procella.rda b/data/procella.rda
new file mode 100644
index 0000000..b001380
Binary files /dev/null and b/data/procella.rda differ
diff --git a/data/rankrock.rda b/data/rankrock.rda
new file mode 100644
index 0000000..ab0fb97
Binary files /dev/null and b/data/rankrock.rda differ
diff --git a/data/rhizobium.rda b/data/rhizobium.rda
new file mode 100755
index 0000000..3afbc79
Binary files /dev/null and b/data/rhizobium.rda differ
diff --git a/data/rhone.rda b/data/rhone.rda
new file mode 100644
index 0000000..65235b8
Binary files /dev/null and b/data/rhone.rda differ
diff --git a/data/rpjdl.rda b/data/rpjdl.rda
new file mode 100644
index 0000000..4c63fd4
Binary files /dev/null and b/data/rpjdl.rda differ
diff --git a/data/santacatalina.rda b/data/santacatalina.rda
new file mode 100644
index 0000000..8102824
Binary files /dev/null and b/data/santacatalina.rda differ
diff --git a/data/sarcelles.rda b/data/sarcelles.rda
new file mode 100644
index 0000000..d4d2b23
Binary files /dev/null and b/data/sarcelles.rda differ
diff --git a/data/seconde.rda b/data/seconde.rda
new file mode 100644
index 0000000..c067b97
Binary files /dev/null and b/data/seconde.rda differ
diff --git a/data/skulls.rda b/data/skulls.rda
new file mode 100644
index 0000000..3ced8da
Binary files /dev/null and b/data/skulls.rda differ
diff --git a/data/steppe.rda b/data/steppe.rda
new file mode 100644
index 0000000..7908617
Binary files /dev/null and b/data/steppe.rda differ
diff --git a/data/syndicats.rda b/data/syndicats.rda
new file mode 100644
index 0000000..5d535ad
Binary files /dev/null and b/data/syndicats.rda differ
diff --git a/data/t3012.rda b/data/t3012.rda
new file mode 100644
index 0000000..d2dbbcc
Binary files /dev/null and b/data/t3012.rda differ
diff --git a/data/tarentaise.rda b/data/tarentaise.rda
new file mode 100644
index 0000000..486db06
Binary files /dev/null and b/data/tarentaise.rda differ
diff --git a/data/taxo.eg.rda b/data/taxo.eg.rda
new file mode 100644
index 0000000..8e0a9c9
Binary files /dev/null and b/data/taxo.eg.rda differ
diff --git a/data/tintoodiel.rda b/data/tintoodiel.rda
new file mode 100644
index 0000000..3496c91
Binary files /dev/null and b/data/tintoodiel.rda differ
diff --git a/data/tithonia.rda b/data/tithonia.rda
new file mode 100644
index 0000000..b579b9b
Binary files /dev/null and b/data/tithonia.rda differ
diff --git a/data/tortues.rda b/data/tortues.rda
new file mode 100644
index 0000000..388ee6d
Binary files /dev/null and b/data/tortues.rda differ
diff --git a/data/toxicity.rda b/data/toxicity.rda
new file mode 100644
index 0000000..e090c02
Binary files /dev/null and b/data/toxicity.rda differ
diff --git a/data/trichometeo.rda b/data/trichometeo.rda
new file mode 100644
index 0000000..bb93643
Binary files /dev/null and b/data/trichometeo.rda differ
diff --git a/data/ungulates.rda b/data/ungulates.rda
new file mode 100644
index 0000000..70510f0
Binary files /dev/null and b/data/ungulates.rda differ
diff --git a/data/vegtf.rda b/data/vegtf.rda
new file mode 100644
index 0000000..d3b06ec
Binary files /dev/null and b/data/vegtf.rda differ
diff --git a/data/veuvage.rda b/data/veuvage.rda
new file mode 100644
index 0000000..6de93b3
Binary files /dev/null and b/data/veuvage.rda differ
diff --git a/data/westafrica.rda b/data/westafrica.rda
new file mode 100644
index 0000000..b5ff240
Binary files /dev/null and b/data/westafrica.rda differ
diff --git a/data/woangers.rda b/data/woangers.rda
new file mode 100755
index 0000000..8444842
Binary files /dev/null and b/data/woangers.rda differ
diff --git a/data/worksurv.rda b/data/worksurv.rda
new file mode 100644
index 0000000..af5bacf
Binary files /dev/null and b/data/worksurv.rda differ
diff --git a/data/yanomama.rda b/data/yanomama.rda
new file mode 100644
index 0000000..f44d410
Binary files /dev/null and b/data/yanomama.rda differ
diff --git a/data/zealand.rda b/data/zealand.rda
new file mode 100644
index 0000000..76a43a3
Binary files /dev/null and b/data/zealand.rda differ
diff --git a/debian/README.source b/debian/README.source
deleted file mode 100644
index 0f8de61..0000000
--- a/debian/README.source
+++ /dev/null
@@ -1,40 +0,0 @@
-Explanation for binary files inside source package according to
- http://lists.debian.org/debian-devel/2013/09/msg00332.html
-
-Files: data/*.rda
- Each binary data file is explicitly documented in a matching file
- man/*.Rd that is specifying the publication where the data were published
- and examples how the data can be used.
-
-Files: inst/pictures/atya*.pnm
- The origin of these files is documented in man/atya.Rd
-
-
-Files: inst/pictures/avijons*.pnm
- The origin of these files is documented in man/avijons.Rd
-
-Files: inst/pictures/butterfly.pnm
- The origin of this file is documented in man/butterfly.Rd
-
-Files: inst/pictures/capitales.pnm
- The origin of this file is documented in man/capitales.Rd
-
-Files: inst/pictures/butterfly.pnm
- The origin of this file is documented in man/butterfly.Rd
-
-Files: inst/pictures/fatala.pnm
- The origin of this file is documented in man/baran95.Rd
-
-Files: inst/pictures/{france_sm00,ireland,paris}.pnm
- No documentation about origin and no obvious use inside the code or
- documentation
-
-Files: inst/pictures/sarcelles.pnm
- The origin of this file is documented in man/sarcelles.Rd
-
-Files: inst/pictures/tintoodiel.pnm
- The origin of this file is documented in man/tintoodiel.Rd
-
-
- -- Andreas Tille <tille at debian.org> Sat, 09 May 2015 08:52:18 +0200
-
diff --git a/debian/changelog b/debian/changelog
deleted file mode 100644
index 6108e75..0000000
--- a/debian/changelog
+++ /dev/null
@@ -1,28 +0,0 @@
-r-cran-ade4 (1.7-8-1) unstable; urgency=medium
-
- * New upstream version
- * Standards-Version: 4.1.0 (no changes needed)
-
- -- Andreas Tille <tille at debian.org> Fri, 08 Sep 2017 08:36:00 +0200
-
-r-cran-ade4 (1.7-5-1) unstable; urgency=medium
-
- * New upstream version
- * debhelper 10
-
- -- Andreas Tille <tille at debian.org> Sat, 07 Jan 2017 22:35:48 +0100
-
-r-cran-ade4 (1.7-4-1) unstable; urgency=medium
-
- * New upstream version
- * Convert to dh-r
- * Canonical homepage for CRAN
- * d/watch: version=4
-
- -- Andreas Tille <tille at debian.org> Fri, 11 Nov 2016 11:02:30 +0100
-
-r-cran-ade4 (1.7-2-1) unstable; urgency=medium
-
- * Initial upload (Closes: #785204)
-
- -- Andreas Tille <tille at debian.org> Sat, 09 May 2015 08:52:18 +0200
diff --git a/debian/compat b/debian/compat
deleted file mode 100644
index f599e28..0000000
--- a/debian/compat
+++ /dev/null
@@ -1 +0,0 @@
-10
diff --git a/debian/control b/debian/control
deleted file mode 100644
index e53b82d..0000000
--- a/debian/control
+++ /dev/null
@@ -1,25 +0,0 @@
-Source: r-cran-ade4
-Maintainer: Debian Med Packaging Team <debian-med-packaging at lists.alioth.debian.org>
-Uploaders: Andreas Tille <tille at debian.org>,
-Section: gnu-r
-Priority: optional
-Build-Depends: debhelper (>= 10),
- dh-r,
- r-base-dev
-Standards-Version: 4.1.0
-Vcs-Browser: https://anonscm.debian.org/viewvc/debian-med/trunk/packages/R/r-cran-ade4/
-Vcs-Svn: svn://anonscm.debian.org/debian-med/trunk/packages/R/r-cran-ade4/
-Homepage: https://cran.r-project.org/package=ade4
-
-Package: r-cran-ade4
-Architecture: any
-Depends: ${shlibs:Depends},
- ${misc:Depends},
- ${R:Depends}
-Recommends: ${R:Recommends}
-Suggests: ${R:Suggests}
-Description: GNU R analysis of ecological data
- This GNU R package allows analysis of ecological data and contains
- exploratory and euclidean methods in environmental sciences.
- .
- It supports multivariate data analysis and graphical display.
diff --git a/debian/copyright b/debian/copyright
deleted file mode 100644
index 37014d7..0000000
--- a/debian/copyright
+++ /dev/null
@@ -1,28 +0,0 @@
-Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
-Upstream-Contact: Aurélie Siberchicot <aurelie.siberchicot at univ-lyon1.fr>
-Upstream-Name: ade4
-Source: https://cran.r-project.org/package=ade4
-
-Files: *
-Copyright: 2007-2016 Stéphane Dray, Anne-Béatrice Dufour, Jean Thioulouse,
- Thibaut Jombart, Sandrine Pavoine, Jean R. Lobry,
- Sébastien Ollier, Aurélie Siberchicot, Daniel Chessel
-License: GPL-2+
-
-Files: debian/*
-Copyright: 2015-2016 Andreas Tille <tille at debian.org>
-License: GPL-2+
-
-License: GPL-2+
- 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.
- .
- On Debian systems, the complete text of the GNU General Public License
- version 2 can be found in ‘/usr/share/common-licenses/GPL-2’.
diff --git a/debian/rules b/debian/rules
deleted file mode 100755
index 68d9a36..0000000
--- a/debian/rules
+++ /dev/null
@@ -1,4 +0,0 @@
-#!/usr/bin/make -f
-
-%:
- dh $@ --buildsystem R
diff --git a/debian/source/format b/debian/source/format
deleted file mode 100644
index 163aaf8..0000000
--- a/debian/source/format
+++ /dev/null
@@ -1 +0,0 @@
-3.0 (quilt)
diff --git a/debian/upstream/metadata b/debian/upstream/metadata
deleted file mode 100644
index 1caa550..0000000
--- a/debian/upstream/metadata
+++ /dev/null
@@ -1,10 +0,0 @@
-Reference:
- Author: Stéphane Dray and Anne-Béatrice Dufour
- Title: "The ade4 Package: Implementing the Duality Diagram for Ecologists"
- Journal: Journal of Statistical Software
- Year: 2007
- Volume: 22
- Number: 4
- Pages: 1-20
- URL: http://www.jstatsoft.org/v22/i04
- eprint: http://www.jstatsoft.org/v22/i04/paper
diff --git a/debian/watch b/debian/watch
deleted file mode 100644
index 054aa06..0000000
--- a/debian/watch
+++ /dev/null
@@ -1,2 +0,0 @@
-version=4
-http://cran.r-project.org/src/contrib/ade4_([\d.-]*)\.tar.gz
diff --git a/inst/CITATION b/inst/CITATION
new file mode 100644
index 0000000..24b6740
--- /dev/null
+++ b/inst/CITATION
@@ -0,0 +1,53 @@
+citHeader("To cite ade4 in publications use one these references:")
+
+citEntry(entry="Article",
+ title = "The ade4 package: implementing the duality diagram for ecologists",
+ author = personList(as.person("S. Dray"),as.person("A.B. Dufour")),
+ journal = "Journal of Statistical Software",
+ year = "2007",
+ volume = "22",
+ pages = "1-20",
+ number = "4",
+ textVersion =
+ paste("Dray, S. and Dufour, A.B. ",
+ "(2007): ",
+ "The ade4 package: implementing the duality diagram for ecologists. ",
+ "Journal of Statistical Software. ",
+ "22(4): 1-20.",
+ sep="")
+ )
+
+citEntry(entry="Article",
+ title = "The ade4 package-{I}- {O}ne-table methods",
+ author = personList(as.person("D. Chessel"),as.person("A.B. Dufour"), as.person("J. Thioulouse")),
+ journal = "R News",
+ year = "2004",
+ volume = "4",
+ pages = "5-10",
+
+ textVersion =
+ paste("Chessel, D. and Dufour, A.B. and Thioulouse, J. ",
+ "(2004): ",
+ "The ade4 package-I- One-table methods. ",
+ "R News. ",
+ "4: 5-10.",
+ sep="")
+ )
+
+citEntry(entry="Article",
+ title = "The ade4 package-{II}: {T}wo-table and {K}-table methods.",
+ author = personList(as.person("S. Dray"),as.person("A.B. Dufour"), as.person("D. Chessel")),
+ journal = "R News",
+ year = "2007",
+ volume = "7",
+ number = "2",
+ pages = "47-52",
+
+ textVersion =
+ paste("Dray, S. and Dufour, A.B. and Chessel, D. ",
+ "(2007): ",
+ "The ade4 package-II: Two-table and K-table methods. ",
+ "R News. ",
+ "7(2): 47-52.",
+ sep="")
+ )
diff --git a/inst/pictures/atyacarto.pnm b/inst/pictures/atyacarto.pnm
new file mode 100644
index 0000000..7854f51
Binary files /dev/null and b/inst/pictures/atyacarto.pnm differ
diff --git a/inst/pictures/atyadigi.pnm b/inst/pictures/atyadigi.pnm
new file mode 100644
index 0000000..a563c1d
Binary files /dev/null and b/inst/pictures/atyadigi.pnm differ
diff --git a/inst/pictures/avijonseau.pnm b/inst/pictures/avijonseau.pnm
new file mode 100644
index 0000000..e029a1b
Binary files /dev/null and b/inst/pictures/avijonseau.pnm differ
diff --git a/inst/pictures/avijonsrou.pnm b/inst/pictures/avijonsrou.pnm
new file mode 100644
index 0000000..712fc21
Binary files /dev/null and b/inst/pictures/avijonsrou.pnm differ
diff --git a/inst/pictures/avijonsveg.pnm b/inst/pictures/avijonsveg.pnm
new file mode 100644
index 0000000..ffa04a5
Binary files /dev/null and b/inst/pictures/avijonsveg.pnm differ
diff --git a/inst/pictures/avijonsvil.pnm b/inst/pictures/avijonsvil.pnm
new file mode 100644
index 0000000..4d4d677
Binary files /dev/null and b/inst/pictures/avijonsvil.pnm differ
diff --git a/inst/pictures/butterfly.pnm b/inst/pictures/butterfly.pnm
new file mode 100644
index 0000000..63d9a6a
Binary files /dev/null and b/inst/pictures/butterfly.pnm differ
diff --git a/inst/pictures/capitales.pnm b/inst/pictures/capitales.pnm
new file mode 100644
index 0000000..84c4bbf
Binary files /dev/null and b/inst/pictures/capitales.pnm differ
diff --git a/inst/pictures/fatala.pnm b/inst/pictures/fatala.pnm
new file mode 100644
index 0000000..e416f38
Binary files /dev/null and b/inst/pictures/fatala.pnm differ
diff --git a/inst/pictures/france_sm00.pnm b/inst/pictures/france_sm00.pnm
new file mode 100644
index 0000000..68a728c
Binary files /dev/null and b/inst/pictures/france_sm00.pnm differ
diff --git a/inst/pictures/ireland.pnm b/inst/pictures/ireland.pnm
new file mode 100644
index 0000000..d805517
Binary files /dev/null and b/inst/pictures/ireland.pnm differ
diff --git a/inst/pictures/paris.pnm b/inst/pictures/paris.pnm
new file mode 100644
index 0000000..08a977e
Binary files /dev/null and b/inst/pictures/paris.pnm differ
diff --git a/inst/pictures/sarcelles.pnm b/inst/pictures/sarcelles.pnm
new file mode 100644
index 0000000..ffcca83
Binary files /dev/null and b/inst/pictures/sarcelles.pnm differ
diff --git a/inst/pictures/tintoodiel.pnm b/inst/pictures/tintoodiel.pnm
new file mode 100644
index 0000000..32b3a3f
Binary files /dev/null and b/inst/pictures/tintoodiel.pnm differ
diff --git a/man/EH.Rd b/man/EH.Rd
new file mode 100644
index 0000000..3bdee2d
--- /dev/null
+++ b/man/EH.Rd
@@ -0,0 +1,33 @@
+\name{EH}
+\alias{EH}
+\title{Amount of Evolutionary History
+}
+\description{
+computes the sum of branch lengths on an ultrametric phylogenetic tree.
+}
+\usage{
+EH(phyl, select = NULL)
+}
+\arguments{
+ \item{phyl}{an object of class phylog}
+ \item{select}{a vector containing the numbers of the leaves (species) which must be considered
+ in the computation of the amount of Evolutionary History. This parameter allows the calculation
+ of the amount of Evolutionary History for a subset of species. }
+}
+\value{
+returns a real value.
+}
+\references{
+Nee, S. and May, R.M. (1997) Extinction and the loss of evolutionary history. \emph{Science},
+\bold{278}, 692--694.
+}
+\author{
+Sandrine Pavoine \email{pavoine at mnhn.fr}
+}
+\examples{
+data(carni70)
+carni70.phy <- newick2phylog(carni70$tre)
+EH(carni70.phy)
+EH(carni70.phy, select = 1:15) # Felidae
+}
+\keyword{multivariate}
diff --git a/man/PI2newick.Rd b/man/PI2newick.Rd
new file mode 100644
index 0000000..2b36a8d
--- /dev/null
+++ b/man/PI2newick.Rd
@@ -0,0 +1,36 @@
+\name{PI2newick}
+\alias{PI2newick}
+\title{Import data files from Phylogenetic Independance Package}
+\description{
+This function ensures to transform a data set written for the Phylogenetic Independance package of Abouheif (1999) in a data set formatting for the functions of ade4.
+}
+\usage{
+PI2newick(x)
+}
+\arguments{
+ \item{x}{is a data frame that contains information on phylogeny topology and trait values}
+}
+\value{
+Returns a list containing :
+ \item{tre}{: a character string giving the phylogenetic tree in Newick format}
+ \item{trait}{: a vector containing values of the trait}
+}
+\references{
+Abouheif, E. (1999) A method for testing the assumption of phylogenetic independence in comparative data. \emph{Evolutionary Ecology Research}, \bold{1}, 895--909.
+}
+\author{Sébastien Ollier \email{sebastien.ollier at u-psud.fr} \cr
+Daniel Chessel
+}
+\examples{
+x <- c(2.0266, 0.5832, 0.2460, 1.2963, 0.2460, 0.1565, -99.0000,
+ -99.0000, 10.1000, -99.0000, 20.2000, 28.2000, -99.0000,
+ 14.1000, 11.2000, -99.0000, 21.3000, 27.5000, 1.0000, 2.0000,
+ -1.0000, 4.0000, -1.0000, -1.0000, 3.0000, -1.0000, -1.0000,
+ 5.0000, -1.0000, -1.0000, 0.0000, 0.0000, 0.0000, 0.0000,
+ 0.0000, 0.0000)
+x <- matrix(x, nrow = 6)
+x <- as.data.frame(x)
+res <- PI2newick(x)
+dotchart.phylog(newick2phylog(res$tre), res$trait)
+}
+\keyword{manip}
diff --git a/man/RV.rtest.Rd b/man/RV.rtest.Rd
new file mode 100644
index 0000000..b2c5b7a
--- /dev/null
+++ b/man/RV.rtest.Rd
@@ -0,0 +1,32 @@
+\name{RV.rtest}
+\alias{RV.rtest}
+\title{Monte-Carlo Test on the sum of eigenvalues of a co-inertia analysis (in R).}
+\description{
+performs a Monte-Carlo Test on the sum of eigenvalues of a co-inertia analysis.
+}
+\usage{
+RV.rtest(df1, df2, nrepet = 99, ...)
+}
+\arguments{
+ \item{df1, df2}{two data frames with the same rows}
+ \item{nrepet}{the number of permutations}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+returns a list of class 'rtest'
+}
+\references{
+Heo, M. & Gabriel, K.R. (1997) A permutation test of association between configurations by means of the RV coefficient.
+Communications in Statistics - Simulation and Computation, \bold{27}, 843-856.
+}
+\author{Daniel Chessel }
+\examples{
+data(doubs)
+pca1 <- dudi.pca(doubs$env, scal = TRUE, scann = FALSE)
+pca2 <- dudi.pca(doubs$fish, scal = FALSE, scann = FALSE)
+rv1 <- RV.rtest(pca1$tab, pca2$tab, 99)
+rv1
+plot(rv1)
+}
+\keyword{multivariate}
+\keyword{nonparametric}
diff --git a/man/RVdist.randtest.Rd b/man/RVdist.randtest.Rd
new file mode 100644
index 0000000..13a3f97
--- /dev/null
+++ b/man/RVdist.randtest.Rd
@@ -0,0 +1,24 @@
+\name{RVdist.randtest}
+\alias{RVdist.randtest}
+\title{Tests of randomization on the correlation between two distance matrices (in R).}
+\description{
+performs a RV Test between two distance matrices.
+}
+\usage{
+RVdist.randtest(m1, m2, nrepet = 999, ...)
+}
+\arguments{
+ \item{m1, m2}{two Euclidean matrices}
+ \item{nrepet}{the number of permutations}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+returns a list of class 'randtest'
+}
+\references{
+Heo, M. & Gabriel, K.R. (1997) A permutation test of association between configurations by means of the RV coefficient.
+Communications in Statistics - Simulation and Computation, \bold{27}, 843-856.
+}
+\author{Daniel Chessel }
+\keyword{multivariate}
+\keyword{nonparametric}
diff --git a/man/abouheif.eg.Rd b/man/abouheif.eg.Rd
new file mode 100644
index 0000000..5d4a5c8
--- /dev/null
+++ b/man/abouheif.eg.Rd
@@ -0,0 +1,43 @@
+\name{abouheif.eg}
+\alias{abouheif.eg}
+\docType{data}
+\title{Phylogenies and quantitative traits from Abouheif}
+\description{
+This data set gathers three phylogenies with three sets of traits as reported by Abouheif (1999).
+}
+\usage{data(abouheif.eg)}
+\format{
+\code{abouheif.eg} is a list containing the 6 following objects :
+\describe{
+ \item{tre1}{is a character string giving the first phylogenetic tree made up of 8 leaves.}
+ \item{vec1}{is a numeric vector with 8 values.}
+ \item{tre2}{is a character string giving the second phylogenetic tree made up of 7 leaves.}
+ \item{vec2}{is a numeric vector with 7 values.}
+ \item{tre3}{is a character string giving the third phylogenetic tree made up of 15 leaves.}
+ \item{vec3}{is a numeric vector with 15 values.}
+}}
+\source{
+Data taken from the phylogenetic independence program developped by Ehab Abouheif
+}
+\references{
+Abouheif, E. (1999) A method for testing the assumption of phylogenetic independence in comparative data. \emph{Evolutionary Ecology Research}, \bold{1}, 895--909.
+}
+\examples{
+data(abouheif.eg)
+par(mfrow=c(2,2))
+symbols.phylog(newick2phylog(abouheif.eg$tre1), abouheif.eg$vec1,
+ sub = "Body Mass (kg)", csi = 2, csub = 2)
+symbols.phylog(newick2phylog(abouheif.eg$tre2), abouheif.eg$vec2,
+ sub = "Body Mass (kg)", csi = 2, csub = 2)
+dotchart.phylog(newick2phylog(abouheif.eg$tre1), abouheif.eg$vec1,
+ sub = "Body Mass (kg)", cdot = 2, cnod = 1, possub = "topleft",
+ csub = 2, ceti = 1.5)
+dotchart.phylog(newick2phylog(abouheif.eg$tre2), abouheif.eg$vec2,
+ sub = "Body Mass (kg)", cdot = 2, cnod = 1, possub = "topleft",
+ csub = 2, ceti = 1.5)
+par(mfrow = c(1,1))
+
+w.phy=newick2phylog(abouheif.eg$tre3)
+dotchart.phylog(w.phy,abouheif.eg$vec3, clabel.n = 1)
+}
+\keyword{datasets}
diff --git a/man/acacia.Rd b/man/acacia.Rd
new file mode 100644
index 0000000..eb5cbb1
--- /dev/null
+++ b/man/acacia.Rd
@@ -0,0 +1,39 @@
+\name{acacia}
+\alias{acacia}
+\docType{data}
+\title{Spatial pattern analysis in plant communities}
+\description{
+Counts of individuals of \emph{Acacia ehrenbergiana} from five parallel transects of 32 quadrats.
+}
+\usage{data(acacia)}
+\format{
+\code{acacia} is a data frame with 15 variables :\cr
+se.T1, se.T2, se.T3, se.T4, se.T5 are five numeric vectors containing quadrats counts of
+seedlings from transects 1 to 5 respectively;\cr
+sm.T1, sm.T2, sm.T3, sm.T4, sm.T5 are five numeric vectors containing quadrats counts of
+ small trees (crown < 1 \eqn{m^{2}}{m^2} in canopy) of transects 1 to 5 respectively; \cr
+la.T1, la.T2, la.T3, la.T4, la.T5 are five numeric vectors containing quadrats counts of
+trees with large crown (crown > 1 \eqn{m^{2}}{m^2} in canopy) of transects 1 to 5 respectively.
+}
+\source{
+Greig-Smith, P. and Chadwick, M.J. (1965) Data on pattern within plant communities. III. \emph{Acacia-Capparis}
+semi-desert scrub in the Sudan. \emph{Journal of Ecology}, \bold{53}, 465--474.
+}
+\references{
+Hill, M.O. (1973) The intensity of spatial pattern in plant communities. \emph{Journal of Ecology}, \bold{61}, 225--235.
+}
+\examples{data(acacia)
+if(adegraphicsLoaded()) {
+ gg <- s1d.barchart(acacia, p1d.horizontal = FALSE, psub.position = "topleft",
+ plabels.cex = 0, ylim = c(0,20))
+} else {
+ par(mfcol = c(5, 3))
+ par(mar = c(2, 2, 2, 2))
+ for(k in 1:15) {
+ barplot(acacia[, k], ylim = c(0, 20), col = grey(0.8))
+ ade4:::scatterutil.sub(names(acacia)[k], 1.5, "topleft")
+ }
+ par(mfcol = c(1, 1))
+}
+}
+\keyword{datasets}
diff --git a/man/add.scatter.Rd b/man/add.scatter.Rd
new file mode 100644
index 0000000..c446c38
--- /dev/null
+++ b/man/add.scatter.Rd
@@ -0,0 +1,119 @@
+\name{add.scatter}
+\alias{add.scatter}
+\alias{add.scatter.eig}
+\title{Add graphics to an existing plot}
+\description{
+ \code{add.scatter} is a function which defines a new plot area within an existing plot and displays an additional graphic inside this area. The additional graphic is determined by a function which is the first argument taken by \code{add.scatter}. It can be used in various ways, for instance to add a screeplot to an ordination scatterplot (\code{add.scatter.eig}).\cr
+ The function \code{add.scatter.eig} uses the following colors: black (represented axes), grey(axes retained in the analysis) and white (others).
+}
+\usage{
+add.scatter(func,posi = c("bottomleft","bottomright","topleft","topright"),
+ratio = 0.2, inset = 0.01, bg.col = 'white')
+add.scatter.eig(w, nf = NULL, xax, yax, posi = "bottomleft", ratio =
+.25, inset = 0.01, sub = "Eigenvalues", csub = 2 * ratio)
+}
+\arguments{
+ \item{func}{an - evaluated - function producing a graphic}
+ \item{posi}{a character vector (only its first element being
+ considered) giving the position of the added graph. Possible values
+ are "bottomleft" (="bottom"),"bottomright","topleft"
+ (="top"),"topright", and "none" (no plot).}
+ \item{ratio}{the size of the added graph in proportion of the current
+ plot region}
+ \item{inset}{the inset from which the graph is drawn, in proportion of the whole
+ plot region. Can be a vector of length 2, giving the inset in x and y. If atomic, same inset is
+ used in x and y}
+ \item{bg.col}{the color of the background of the added graph}
+ \item{w}{numeric vector of eigenvalues}
+ \item{nf}{the number of retained factors, NULL if not provided}
+ \item{xax}{first represented axis}
+ \item{yax}{second represented axis}
+ \item{sub}{title of the screeplot}
+ \item{csub}{size of the screeplot title}
+}
+\value{
+The matched call (invisible).
+}
+\details{
+ \code{add.scatter} uses \code{par("plt")} to redefine the new plot region.
+ As stated in \code{par} documentation, this produces to (sometimes
+ surprising) interactions with other parameters such as "mar".
+ In particular, such interactions are likely to reset the plot region
+ by default which would cause the additional graphic to take the whole
+ plot region. To avoid such inconvenient, add \code{par([other
+ options], plt=par("plt"))} when using \code{par} in your graphical
+ function (argument \code{func}).
+}
+\seealso{\code{\link{scatter}}
+}
+\author{Thibaut Jombart \email{t.jombart at imperial.ac.uk}}
+\examples{
+ data(microsatt)
+ w <- dudi.coa(data.frame(t(microsatt$tab)), scann = FALSE, nf = 3)
+
+ if(adegraphicsLoaded()) {
+ a1 <- rnorm(100)
+ b1 <- s1d.barchart(sort(a1), p1d.horizontal = FALSE, plot = FALSE)
+ h1 <- s1d.hist(a1, pgrid.draw = FALSE, porigin.draw = FALSE, pbackground.col = "grey",
+ plot = FALSE, ppoly.col = "white", ppoly.alpha = 1)
+ g1 <- insert(h1, b1, posi = "topleft", plot = FALSE)
+
+ a2 <- rnorm(100)
+ b2 <- s1d.barchart(sort(a2), p1d.horizontal = FALSE, plot = FALSE)
+ h2 <- s1d.hist(a2, pgrid.draw = FALSE, porigin.draw = FALSE, pbackground.col = "grey",
+ plot = FALSE, ppoly.col = "white", ppoly.alpha = 1)
+ g2 <- insert(h2, b2, posi = "topleft", inset = c(0.25, 0.01), plot = FALSE)
+
+ a3 <- rnorm(100)
+ b3 <- s1d.barchart(sort(a3), p1d.horizontal = FALSE, plot = FALSE)
+ h3 <- s1d.hist(a3, pgrid.draw = FALSE, porigin.draw = FALSE, pbackground.col = "grey",
+ plot = FALSE, ppoly.col = "white", ppoly.alpha = 1)
+ g3 <- insert(h3, b3, posi = "bottomleft", inset = 0.4, ratio = 0.2, plot = FALSE)
+
+ a4 <- rnorm(100)
+ b4 <- s1d.barchart(sort(a4), p1d.horizontal = FALSE, plot = FALSE)
+ h4 <- s1d.hist(a4, pgrid.draw = FALSE, porigin.draw = FALSE, pbackground.col = "grey",
+ plot = FALSE, ppoly.col = "white", ppoly.alpha = 1)
+ g4 <- insert(h3, b3, posi = "bottomright", ratio = 0.3, plot = FALSE)
+
+ G1 <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2), plot = TRUE)
+
+ g5 <- s.label(w$co, plot = FALSE)
+ g6 <- plotEig(w$eig, w$nf, psub = list(text = "Eigenvalues"),
+ pbackground = list(box = TRUE), plot = FALSE)
+ G2 <- insert(g6, g5, posi = "bottomright", ratio = 0.25)
+
+ } else {
+ par(mfrow=c(2,2))
+ f1 <- function(a){
+ opar=par("mar","xaxt","yaxt","plt")
+ on.exit(par(opar))
+ par(mar=rep(.1,4),xaxt="n",yaxt="n",plt=par("plt"))
+
+ hist(a,xlab="",ylab="",main="",col="white",proba=TRUE)
+ lines(seq(-4,4,le=50),dnorm(seq(-4,4,le=50)),col="red")
+ }
+
+ a <- rnorm(100)
+ barplot(sort(a))
+ add.scatter(f1(a),posi="topleft",bg.col="grey")
+
+ a <- rnorm(100)
+ barplot(sort(a))
+ add.scatter(f1(a),posi="topleft",bg.col="grey",inset=c(.25,.01))
+
+ a <- rnorm(100)
+ barplot(sort(a))
+ add.scatter(f1(a),posi="topleft",bg.col="grey",inset=.25,ratio=.1)
+
+ a <- rnorm(100)
+ barplot(sort(a))
+ add.scatter(f1(a),posi="bottomright",bg.col="grey",ratio=.3)
+ par(mfrow=c(1,1))
+
+ s.label(w$co)
+ add.scatter.eig(w$eig,w$nf,posi="bottomright",1,2)
+ }
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/ade4-deprecated.Rd b/man/ade4-deprecated.Rd
new file mode 100644
index 0000000..8c1dbde
--- /dev/null
+++ b/man/ade4-deprecated.Rd
@@ -0,0 +1,9 @@
+\encoding{UTF-8}
+\name{Deprecated functions}
+\alias{ade4-deprecated}
+\title{Deprecated functions in ade4}
+\description{
+ The functions/data listed below are deprecated:
+
+ - \code{orthogram}: replaced by \code{orthogram} in adephylo.
+}
diff --git a/man/ade4-internal.Rd b/man/ade4-internal.Rd
new file mode 100644
index 0000000..a38ede6
--- /dev/null
+++ b/man/ade4-internal.Rd
@@ -0,0 +1,21 @@
+\name{ade4-internal}
+\alias{testdiscrimin}
+\alias{testertrace}
+\alias{testertracenu}
+\alias{testertracenubis}
+\alias{testinter}
+\alias{testprocuste}
+\alias{testmantel}
+\alias{testertracerlq}
+\alias{testamova}
+\alias{dudi.type}
+\alias{fac2disj}
+\title{Internal ade4 functions}
+\description{
+Internal ade4 functions
+}
+
+\details{
+These are not to be called by the user.
+}
+\keyword{ internal }
diff --git a/man/ade4.package.Rd b/man/ade4.package.Rd
new file mode 100644
index 0000000..cc6bfd9
--- /dev/null
+++ b/man/ade4.package.Rd
@@ -0,0 +1,21 @@
+\name{ade4-package}
+\alias{ade4-package}
+\alias{ade4}
+\docType{package}
+\title{The ade4 package}
+
+\description{This package is developed in the Biometry and Evolutionary Biology Lab (UMR 5558) - University Lyon 1.
+It contains Data Analysis functions to analyse Ecological and Environmental data in the framework of Euclidean Exploratory methods, hence the name ade4.\cr
+
+ade4 is characterized by (1) the implementation of graphical and statistical functions, (2) the availability of numerical data, (3) the redaction of technical and thematic documentation and (4) the inclusion of bibliographic references. \cr
+
+To cite ade4, please use \code{citation("ade4")}.
+ }
+
+\author{Daniel Chessel, Anne-Béatrice Dufour, Stéphane Dray with the contributions from J.R. Lobry, S. Ollier, S. Pavoine and J. Thioulouse}
+\references{
+ See ade4 website: \url{http://pbil.univ-lyon1.fr/ADE-4/}
+}
+\keyword{manip}
+\keyword{multivariate}
+\seealso{\code{ade4TkGUI}, \code{adegenet}, \code{adehabitat}, \code{adegraphics}}
diff --git a/man/adegraphicsLoaded.Rd b/man/adegraphicsLoaded.Rd
new file mode 100644
index 0000000..2f07372
--- /dev/null
+++ b/man/adegraphicsLoaded.Rd
@@ -0,0 +1,14 @@
+\name{adegraphicsLoaded}
+\alias{adegraphicsLoaded}
+\title{Utility function to test if the package adegraphics is loaded}
+\description{This function check if the package adegraphics is loaded. Mainly used to run examples using either ade4 or adegraphics function
+}
+\usage{
+adegraphicsLoaded()
+}
+
+\value{A logical}
+
+\author{Stéphane Dray (\email{stephane.dray at univ-lyon1.fr})}
+
+\keyword{ internal }
diff --git a/man/aminoacyl.Rd b/man/aminoacyl.Rd
new file mode 100644
index 0000000..ed863d7
--- /dev/null
+++ b/man/aminoacyl.Rd
@@ -0,0 +1,36 @@
+\name{aminoacyl}
+\alias{aminoacyl}
+\docType{data}
+\title{Codon usage}
+\description{
+ \code{aminoacyl} is a list containing the codon counts of 36 genes encoding yeast aminoacyl-tRNA-synthetase(S.Cerevisiae).
+}
+\usage{data(aminoacyl)}
+\format{
+ \code{aminoacyl} is a list containing the 5 following objects:
+\describe{
+ \item{genes}{is a vector giving the gene names.}
+ \item{localisation}{is a vector giving the cellular localisation
+ of the proteins (M = mitochondrial, C = cytoplasmic,
+ I = indetermined, CI = cyto and mito).}
+ \item{codon}{is a vector containing the 64 triplets.}
+ \item{AA}{is a factor giving the amino acid names for each codon.}
+ \item{usage.codon}{is a dataframe containing the codon counts for each gene.}
+ }
+}
+\source{
+ Data prepared by D. Charif \email{Delphine.Charif at versailles.inra.fr} starting from:\cr
+ \url{http://www.expasy.org/sprot/}
+}
+\references{
+Chiapello H., Olivier E., Landes-Devauchelle C., Nitschké P. and Risler J.L (1999)
+Codon usage as a tool to predict the cellular localisation of eukariotic ribosomal
+proteins and aminoacyl-tRNA synthetases. \emph{Nucleic Acids Res.}, \bold{27}, 14, 2848--2851.
+}
+\examples{
+data(aminoacyl)
+aminoacyl$genes
+aminoacyl$usage.codon
+dudi.coa(aminoacyl$usage.codon, scannf = FALSE)
+}
+\keyword{datasets}
diff --git a/man/amova.Rd b/man/amova.Rd
new file mode 100644
index 0000000..56883ec
--- /dev/null
+++ b/man/amova.Rd
@@ -0,0 +1,47 @@
+\name{amova}
+\alias{amova}
+\alias{print.amova}
+\title{Analysis of molecular variance}
+\description{
+The analysis of molecular variance tests the differences among population and/or groups of populations
+in a way similar to ANOVA. It includes evolutionary distances among alleles.
+}
+\usage{
+amova(samples, distances, structures)
+\method{print}{amova}(x, full = FALSE, \dots)
+}
+\arguments{
+ \item{samples}{a data frame with haplotypes (or genotypes) as rows, populations as columns
+ and abundance as entries}
+ \item{distances}{an object of class \code{dist} computed from Euclidean distance.
+ If \code{distances} is null, equidistances are used.}
+ \item{structures}{a data frame containing, in the jth row and the kth column,
+ the name of the group of level k to which the jth population belongs}
+ \item{x}{an object of class \code{amova}}
+ \item{full}{a logical value indicating whether the original data ('distances', 'samples', 'structures')
+ should be printed}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+Returns a list of class \code{amova}
+ \item{call}{call}
+ \item{results}{a data frame with the degrees of freedom, the sums of squares, and the mean squares.
+ Rows represent levels of variability.}
+ \item{componentsofcovariance}{a data frame containing the components
+ of covariance and their contribution to the total covariance}
+ \item{statphi}{a data frame containing the phi-statistics}
+}
+\references{
+Excoffier, L., Smouse, P.E. and Quattro, J.M. (1992) Analysis of molecular variance inferred
+from metric distances among DNA haplotypes: application to human mitochondrial DNA restriction
+data. \emph{Genetics}, \bold{131}, 479--491.
+}
+\author{Sandrine Pavoine \email{pavoine at mnhn.fr}
+}
+\seealso{\code{\link{randtest.amova}}}
+\examples{
+data(humDNAm)
+amovahum <- amova(humDNAm$samples, sqrt(humDNAm$distances), humDNAm$structures)
+amovahum
+}
+\keyword{multivariate}
diff --git a/man/apis108.Rd b/man/apis108.Rd
new file mode 100644
index 0000000..2788511
--- /dev/null
+++ b/man/apis108.Rd
@@ -0,0 +1,25 @@
+\name{apis108}
+\docType{data}
+\alias{apis108}
+\title{Allelic frequencies in ten honeybees populations at eight microsatellites loci}
+\description{
+This data set gives the occurences for the allelic form on 8 loci in 10 populations of honeybees.
+}
+\usage{data(apis108)}
+\format{
+A data frame containing 180 rows (allelic forms on 8 loci) and 10 columns (populations of honeybees : El.Hermel, Al.Hoceima,
+Nimba, Celinda, Pretoria, Chalkidiki, Forli, Valenciennes, Umea and Seville).
+}
+\source{
+\url{http://www.montpellier.inra.fr/URLB/apis/libanfreq.pdf}\cr
+
+Franck P., Garnery L., Solignac M. and Cornuet J.M. (2000) Molecular confirmation of a fourth lineage in honeybees from the Near-East.
+\emph{Apidologie}, \bold{31}, 167--180.
+}
+\examples{
+data(apis108)
+apis <- count2genet(as.data.frame(t(apis108)))
+apis.pca <- dudi.pca(apis$tab, center = apis$center,
+ scale = FALSE, scannf = FALSE, nf = 3)
+}
+\keyword{datasets}
diff --git a/man/apqe.Rd b/man/apqe.Rd
new file mode 100644
index 0000000..87e335a
--- /dev/null
+++ b/man/apqe.Rd
@@ -0,0 +1,46 @@
+\name{apqe}
+\alias{apqe}
+\alias{print.apqe}
+\title{Apportionment of Quadratic Entropy}
+\description{
+The hierarchical apportionment of quadratic entropy defined by Rao (1982).
+}
+\usage{
+apqe(samples, dis = NULL, structures)
+\method{print}{apqe}(x, full = FALSE, \dots)
+}
+\arguments{
+ \item{samples}{a data frame with haplotypes (or genotypes) as rows, populations as columns
+ and abundance or presence-absence as entries}
+ \item{dis}{an object of class \code{dist} computed from Euclidean distance.
+ If \code{dis} is null, equidistances are used.}
+ \item{structures}{a data frame that contains, in the jth row and the kth column,
+ the name of the group of level k to which the jth population belongs}
+ \item{x}{an object of class \code{apqe}}
+ \item{full}{a logical value that indicates whether the original data ('distances', 'samples', 'structures')
+ should be printed}
+ \item{\dots}{\code{\dots} further arguments passed to or from other methods}
+}
+\value{
+Returns a list of class \code{apqe}
+ \item{call}{call}
+ \item{results}{a data frame that contains the components of diversity.}
+}
+\references{
+ Rao, C.R. (1982) Diversity: its measurement, decomposition, apportionment and analysis.
+ \emph{Sankhya: The Indian Journal of Statistics}, \bold{A44}, 1--22.
+
+ Pavoine S. and Dolédec S. (2005) The apportionment of quadratic entropy:
+ a useful alternative for partitioning diversity in ecological data.
+ \emph{Environmental and Ecological Statistics}, \bold{12}, 125--138.
+}
+\author{Sandrine Pavoine \email{pavoine at mnhn.fr}
+}
+%\seealso{\code{\link{randtest.apqe}}}
+\examples{
+data(ecomor)
+ecomor.phylog <- taxo2phylog(ecomor$taxo)
+apqe(ecomor$habitat, ecomor.phylog$Wdist)
+}
+\keyword{multivariate}
+
diff --git a/man/aravo.Rd b/man/aravo.Rd
new file mode 100644
index 0000000..2e39b2b
--- /dev/null
+++ b/man/aravo.Rd
@@ -0,0 +1,61 @@
+\name{aravo}
+\alias{aravo}
+\docType{data}
+\title{Distribution of Alpine plants in Aravo (Valloire, France)}
+\description{This dataset describe the distribution of 82 species of
+ Alpine plants in 75 sites. Species traits and environmental variables
+ are also measured.
+}
+\usage{data(aravo)}
+\format{
+ \code{aravo} is a list containing the following objects :
+\describe{
+ \item{spe}{is a data.frame with the abundance values of 82 species (columns)
+ in 75 sites (rows).}
+ \item{env}{is a data.frame with the measurements of 6 environmental
+ variables for the sites.}
+ \item{traits}{is data.frame with the measurements of 8 traits for the species.}
+ \item{spe.names}{is a vector with full species names.}
+ }
+}
+\details{The environmental variables are:
+ \tabular{lll}{
+ Aspect \tab Relative south aspect (opposite of the sine of aspect
+ with flat coded 0)\cr
+ Slope \tab Slope inclination (degrees)\cr
+ Form \tab Microtopographic landform index: 1 (convexity); 2
+ (convex slope); 3 (right slope); 4 (concave slope); 5 (concavity) \cr
+ Snow \tab Mean snowmelt date (Julian day) averaged over 1997-1999 \cr
+ PhysD \tab Physical disturbance, i.e., percentage of unvegetated
+ soil due to physical processes \cr
+ ZoogD \tab Zoogenic disturbance, i.e., quantity of unvegetated soil
+ due to marmot activity: no; some; high
+ }
+ The species traits for the plants are:
+ \tabular{ll}{
+ Height \tab Vegetative height (cm) \cr
+ Spread \tab Maximum lateral spread of clonal plants (cm)\cr
+ Angle \tab Leaf elevation angle estimated at the middle of the lamina\cr
+ Area \tab Area of a single leaf\cr
+ Thick \tab Maximum thickness of a leaf cross section (avoiding the midrib)\cr
+ SLA \tab Specific leaf area\cr
+ Nmass \tab Mass-based leaf nitrogen content\cr
+ Seed \tab Seed mass
+ }
+}
+
+\source{
+ Choler, P. (2005)
+ Consistent shifts in Alpine plant traits along a mesotopographical gradient.
+\emph{Arctic, Antarctic, and Alpine Research}, \bold{37},444--453.
+}
+
+\examples{
+data(aravo)
+coa1 <- dudi.coa(aravo$spe, scannf = FALSE, nf = 2)
+dudienv <- dudi.hillsmith(aravo$env, scannf = FALSE, nf = 2, row.w = coa1$lw)
+duditrait <- dudi.pca(aravo$traits, scannf = FALSE, nf = 2, row.w = coa1$cw)
+rlq1 <- rlq(dudienv, coa1, duditrait, scannf = FALSE, nf = 2)
+plot(rlq1)
+}
+\keyword{datasets}
diff --git a/man/ardeche.Rd b/man/ardeche.Rd
new file mode 100644
index 0000000..3bd6a64
--- /dev/null
+++ b/man/ardeche.Rd
@@ -0,0 +1,39 @@
+\name{ardeche}
+\alias{ardeche}
+\docType{data}
+\title{Fauna Table with double (row and column) partitioning}
+\description{
+ This data set gives information about species of benthic macroinvertebrates in different sites and dates.
+}
+\usage{data(ardeche)}
+\format{
+ \code{ardeche} is a list with 6 components.
+ \describe{
+ \item{tab}{is a data frame containing fauna table with 43 species (rows) and 35 samples (columns).}
+ \item{col.blocks}{is a vector containing the repartition of samples for the 6 dates : july 1982, august 1982,
+ november 1982, february 1983, april 1983 and july 1983.}
+ \item{row.blocks}{is a vector containing the repartition of species in the 4 groups defining the species order.}
+ \item{dat.fac}{is a date factor for samples (6 dates).}
+ \item{sta.fac}{is a site factor for samples (6 sites).}
+ \item{esp.fac}{is a species order factor (Ephemeroptera, Plecoptera, Coleoptera, Trichoptera).}
+ }
+}
+\details{
+The columns of the data frame \code{ardeche$tab} define the samples by a number between 1 and 6 (the date)
+and a letter between A and F (the site).
+}
+\source{
+ Cazes, P., Chessel, D., and Dolédec, S. (1988) L'analyse des correspondances internes d'un tableau partitionné :
+ son usage en hydrobiologie. \emph{Revue de Statistique Appliquée}, \bold{36}, 39--54.
+}
+\examples{
+data(ardeche)
+dudi1 <- dudi.coa(ardeche$tab, scan = FALSE)
+s.class(dudi1$co, ardeche$dat.fac)
+if(adegraphicsLoaded()) {
+ s.label(dudi1$co, plab.cex = 0.5, add = TRUE)
+} else {
+ s.label(dudi1$co, clab = 0.5, add.p = TRUE)
+}
+}
+\keyword{datasets}
diff --git a/man/area.plot.Rd b/man/area.plot.Rd
new file mode 100644
index 0000000..f901897
--- /dev/null
+++ b/man/area.plot.Rd
@@ -0,0 +1,179 @@
+\name{area.plot}
+\alias{area.plot}
+\alias{poly2area}
+\alias{area2poly}
+\alias{area2link}
+\alias{area.util.contour}
+\alias{area.util.xy}
+\alias{area.util.class}
+\title{Graphical Display of Areas}
+\description{
+'area' is a data frame with three variables.\cr
+The first variable is a factor defining the polygons.\cr
+The second and third variables are the xy coordinates of the
+polygon vertices in the order where they are found.
+
+area.plot : grey levels areas mapping
+
+poly2area takes an object of class 'polylist' (maptools package) and returns a data frame of type area.\cr
+area2poly takes an object of type 'area' and returns a list of class 'polylist'\cr
+area2link takes an object of type 'area' and returns a proximity matrix which terms are given by
+the length of the frontier between two polygons. \cr
+area.util.contour,area.util.xy and area.util.class are three utility functions.
+}
+\usage{
+area.plot(x, center = NULL, values = NULL, graph = NULL, lwdgraph = 2,
+nclasslegend = 8, clegend = 0.75, sub = "", csub = 1,
+possub = "topleft", cpoint = 0, label = NULL, clabel = 0, ...)
+
+area2poly(area)
+poly2area(polys)
+area2link(area)
+area.util.contour(area)
+area.util.xy(area)
+}
+\arguments{
+\item{x}{a data frame with three variables}
+\item{center}{a matrix with the same row number as x and two columns, the coordinates
+of polygone centers. If NULL, it is computed with \code{area.util.xy}}
+\item{values}{if not NULL, a vector which values will be mapped to grey levels.
+The values must be in the same order as the values in \code{unique(x.area[,1])}}
+\item{graph}{if not NULL, \code{graph} is a neighbouring graph (object of class "neig") between polygons}
+\item{lwdgraph}{a line width to draw the neighbouring graph}
+\item{nclasslegend}{if \code{value} not NULL, a number of classes for the legend}
+\item{clegend}{if not NULL, a character size for the legend, used with \code{par("cex")*clegend}}
+\item{sub}{a string of characters to be inserted as sub-title}
+\item{csub}{a character size for the sub-titles, used with \code{par("cex")*csub}}
+\item{possub}{a string of characters indicating the sub-titles position
+("topleft", "topright", "bottomleft", "bottomright")}
+\item{cpoint}{if positive, a character size for drawing the polygons vertices (check up),
+used with \code{par("cex")*cpoint}}
+\item{label}{if not NULL, by default the levels of the factor that define the polygons
+are used as labels. To change this value, use label. These labels must be in the same order than
+\code{unique(x.area[,1])}}
+\item{clabel}{if not NULL, a character size for the polygon labels, \cr
+used with \code{par("cex")*clabel}}
+\item{polys}{a list belonging to the 'polylist' class in the spdep package}
+\item{area}{a data frame of class 'area'}
+\item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+poly2area returns a data frame 'factor,x,y'. \cr
+area2poly returns a list of class \code{polylist}. \cr
+}
+\author{
+Daniel Chessel
+}
+\examples{
+data(elec88)
+par(mfrow = c(2, 2))
+area.plot(elec88$area, cpoint = 1)
+area.plot(elec88$area, lab = elec88$lab$dep, clab = 0.75)
+area.plot(elec88$area, clab = 0.75)
+# elec88$neig <- neig(area = elec88$area)
+area.plot(elec88$area, graph = elec88$neig, sub = "Neighbourhood graph", possub = "topright")
+par(mfrow = c(1, 1))
+
+\dontrun{
+ par(mfrow = c(3, 3))
+ for(i in 1:9) {
+ x <- elec88$tab[,i]
+ area.plot(elec88$area, val = x, sub = names(elec88$tab)[i], csub = 3, cleg = 1.5)
+ }
+ par(mfrow = c(1, 1))
+
+ if(adegraphicsLoaded()) {
+ if(requireNamespace("sp", quietly = TRUE)) {
+ s.value(elec88$xy, elec88$tab, Sp = elec88$Spatial,
+ method = "color", psub.text = names(elec88$tab), psub.cex = 3,
+ pSp.col = "white", pgrid.draw = FALSE, porigin.include = FALSE)
+ }
+ } else {
+ par(mfrow = c(3, 3))
+ for(i in 1:9) {
+ x <- elec88$tab[, i]
+ s.value(elec88$xy, elec88$tab[, i], contour = elec88$contour,
+ meth = "greylevel", sub = names(elec88$tab)[i], csub = 3,
+ cleg = 1.5, incl = FALSE)
+ }
+ par(mfrow = c(1, 1))
+ }
+
+ if(!adegraphicsLoaded()) {
+ data(irishdata)
+ par(mfrow = c(2, 2))
+ w <- ade4:::area.util.contour(irishdata$area)
+ xy <- ade4:::area.util.xy(irishdata$area)
+ area.plot(irishdata$area, cpoint = 1)
+ apply(w, 1, function(x) segments(x[1], x[2], x[3], x[4], lwd = 3))
+ area.plot(irishdata$area, clabel = 1)
+ s.label(xy, area = irishdata$area, incl = FALSE, clab = 0,
+ cpoi = 3, addax = FALSE, contour = w)
+ s.label(xy, area = irishdata$area, incl = FALSE,
+ addax = FALSE, contour = w)
+ if(requireNamespace("maptools", quietly = TRUE) & requireNamespace("spdep", quietly = TRUE)) {
+ data(columbus, package = "spdep")
+ par(mfrow = c(2, 2))
+ plot(col.gal.nb, coords, pch = 20, cex = 2)
+ col.gal.neig <- nb2neig(col.gal.nb)
+ s.label(data.frame(coords), neig = col.gal.neig,
+ inc = FALSE, addax = FALSE, clab = 0, cneig = 1, cpo = 2)
+ maptools:::plot.polylist(polys, bbs)
+ area.plot(poly2area(polys))
+
+ # 1
+ crime.f <- as.ordered(cut(columbus$CRIME,
+ breaks = quantile(columbus$CRIME, probs = seq(0, 1, 0.2)),
+ include.lowest = TRUE))
+ colours <- c("salmon1", "salmon2", "red3", "brown", "black")
+ plot(bbs[, 1], bbs[, 4], xlab = "", ylab = "", asp = 1, type = "n",
+ xlim = range(c(bbs[, 1], bbs[, 3])), ylim = range(c(bbs[, 2],
+ bbs[, 4])))
+ for(i in 1:length(polys))
+ polygon(polys[[i]], col = colours[unclass(crime.f[i])])
+ legend(x = c(6, 7.75), y = c(13.5, 15), legend = levels(crime.f),
+ fill = colours, cex = 0.7)
+ title(sub = paste("Columbus OH: residential burglaries and ",
+ "vehicle\nthefts", "per thousand households, 1980"))
+
+ # 2
+ area1 <- poly2area(polys)
+ w <- ade4:::area.util.contour(area1)
+ wxy <- ade4:::area.util.xy(area1)
+ area.plot(area1, values = columbus$CRIME, sub = paste("Columbus ",
+ "OH: residential burglaries and vehicle\nthefts",
+ "per thousand households, 1980"))
+ apply(w, 1, function(x) segments(x[1], x[2], x[3], x[4], lwd = 2))
+
+ # 3
+ data(elec88)
+ fr.area <- elec88$area
+ fr.xy <- ade4:::area.util.xy(fr.area)
+ fr.neig <- elec88$neig # neig(area = fr.area)
+
+ # 4
+ fr.poly <- area2poly(fr.area)
+ fr.nb <- neig2nb(fr.neig)
+ maptools:::plot.polylist(fr.poly, attr(fr.poly, "region.rect"), border = "grey")
+ plot(fr.nb, fr.xy, add = TRUE)
+ s.label(fr.xy, clab = 0, area = fr.area, neig = fr.neig,
+ cneig = 1, cpo = 2, inc = FALSE, addax = FALSE)
+ par(mfrow = c(1, 1))
+ }
+ par(mfrow = c(1, 1))
+ }
+}
+
+data(irishdata)
+w <- irishdata$area[c(42:53, 18:25), ]
+w
+w$poly <- as.factor(as.character(w$poly))
+area.plot(w, clab = 2)
+
+points(68, 59, pch = 20, col = "red", cex = 3)
+points(68, 35, pch = 20, col = "red", cex = 3)
+points(45, 12, pch = 20, col = "red", cex = 3)
+sqrt((59 - 35) ^ 2) + sqrt((68 - 45) ^ 2 + (35 - 12) ^ 2)
+area2link(w)
+}
+\keyword{hplot}
diff --git a/man/arrival.Rd b/man/arrival.Rd
new file mode 100644
index 0000000..b6ac1ed
--- /dev/null
+++ b/man/arrival.Rd
@@ -0,0 +1,26 @@
+\name{arrival}
+\alias{arrival}
+\docType{data}
+\title{Arrivals at an intensive care unit}
+\description{
+This data set gives arrival times of 254 patients at an intensive care unit during one day.
+}
+\usage{data(arrival)}
+\format{
+\code{arrival} is a list containing the 2 following objects :
+\describe{
+ \item{times}{is a vector giving the arrival times in the form HH:MM}
+ \item{hours}{is a vector giving the number of arrivals per hour for the day considered}
+}}
+\source{
+Data taken from the Oriana software developped by Warren L. Kovach \email{sales at kovcomp.com} starting from \url{http://www.kovcomp.com/oriana/index.html}.
+}
+\references{
+Fisher, N. I. (1993) \emph{Statistical Analysis of Circular Data}. Cambridge University Press.
+}
+\examples{
+data(arrival)
+dotcircle(arrival$hours, pi/2 + pi/12)
+}
+\keyword{datasets}
+\keyword{chron}
diff --git a/man/as.taxo.Rd b/man/as.taxo.Rd
new file mode 100644
index 0000000..1060216
--- /dev/null
+++ b/man/as.taxo.Rd
@@ -0,0 +1,40 @@
+\name{as.taxo}
+\alias{as.taxo}
+\alias{dist.taxo}
+\title{Taxonomy}
+\description{
+The function \code{as.taxo} creates an object of class \code{taxo} that is a sub-class of \code{data.frame}.
+Each column of the data frame must be a factor corresponding to a level \emph{j} of the taxonomy (genus, family, \dots).
+The levels of factor \emph{j} define some classes that must be completly included in classes of factor \emph{j+1}.\cr
+A factor with exactly one level is not allowed. A factor with exactly one individual in each level is not allowed.
+The function \code{dist.taxo} compute taxonomic distances.
+}
+\usage{
+as.taxo(df)
+dist.taxo(taxo)
+}
+\arguments{
+\item{df}{a data frame}
+\item{taxo}{a data frame of class \code{taxo}}
+}
+\value{
+\code{as.taxo} returns a data frame of class \code{taxo}.
+\code{dist.taxo} returns a numeric of class \code{dist}.
+}
+\author{Daniel Chessel \cr
+Sébastien Ollier \email{sebastien.ollier at u-psud.fr}
+}
+\seealso{\code{\link{taxo2phylog}} to transform an object of class \code{taxo} into an object of class \code{phylog}
+}
+\examples{
+data(taxo.eg)
+tax <- as.taxo(taxo.eg[[1]])
+tax.phy <- taxo2phylog(as.taxo(taxo.eg[[1]]),add.tools=TRUE)
+par(mfrow = c(1,2))
+plot(tax.phy, clabel.l = 1.25, clabel.n = 1.25, f = 0.75)
+plot(taxo2phylog(as.taxo(taxo.eg[[1]][sample(15),])),
+ clabel.l = 1.25, clabel.n = 1.25, f = 0.75)
+par(mfrow = c(1,1))
+all(dist.taxo(tax)==tax.phy$Wdist)
+}
+\keyword{manip}
diff --git a/man/atlas.Rd b/man/atlas.Rd
new file mode 100644
index 0000000..a8e8744
--- /dev/null
+++ b/man/atlas.Rd
@@ -0,0 +1,86 @@
+\name{atlas}
+\alias{atlas}
+\docType{data}
+
+\title{Small Ecological Dataset}
+
+\description{\code{atlas} is a list containing three kinds of information about 23 regions (The French Alps) : \cr
+geographical coordinates, meteorology and bird presences.}
+
+\usage{data(atlas)}
+
+\format{
+ \code{atlas} is a list of 9 components:
+ \describe{
+ \item{area}{is a convex hull of 23 geographical regions.}
+ \item{xy}{are the coordinates of the region centers and altitude (in meters).}
+ \item{names.district}{is a vector of region names.}
+ \item{meteo}{is a data frame with 7 variables: min and max temperature in january;
+ min and max temperature in july; january, july and total rainfalls.}
+ \item{birds}{is a data frame with 15 variables (species).}
+ \item{contour}{is a data frame with 4 variables (x1, y1, x2, y2) for the contour display of The French Alps.}
+ \item{alti}{is a data frame with 3 variables altitude in percentage [0,800], ]800,1500] and ]1500,5000].}
+ \item{Spatial}{is the map of the 23 regions of The French Alps (an object of the class \code{SpatialPolygons} of \code{sp}).}
+ \item{Spatial.contour}{is the contour of the map of the 23 regions of the French Alps (an object of the class \code{SpatialPolygons} of \code{sp}).}
+}}
+
+\source{
+Extract from: \cr
+Lebreton, Ph. (1977) Les oiseaux nicheurs rhonalpins. \emph{Atlas ornithologique Rhone-Alpes}.
+Centre Ornithologique Rhone-Alpes, Universite Lyon 1, 69621 Villeurbanne.
+Direction de la Protection de la Nature, Ministere de la Qualite de la Vie. 1--354.
+}
+
+\examples{
+data(atlas)
+if(adegraphicsLoaded()) {
+ if(requireNamespace("sp", quietly = TRUE)) {
+ g11 <- s.Spatial(atlas$Spatial, pSp.col = "white", plot = FALSE)
+ g12 <- s.label(atlas$area[, 2:3], plabels.cex = 0, plot = FALSE)
+ g1 <- superpose(g11, g12, plot = FALSE)
+ g2 <- s.label(atlas$xy, lab = atlas$names.district, Sp = atlas$Spatial,
+ pgrid.dra = FALSE, pSp.col = "white", plot = FALSE)
+ obj3 <- sp::SpatialPolygonsDataFrame(Sr = atlas$Spatial, data = atlas$meteo)
+ g3 <- s.Spatial(obj3[, 1], nclass = 12, psub = list(position = "topleft",
+ text = "Temp Mini January", cex = 2), plot = FALSE)
+ g4 <- s.corcircle((dudi.pca(atlas$meteo, scann = FALSE)$co), plabels.cex = 1, plot = FALSE)
+ G1 <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+ obj5 <- sp::SpatialPolygonsDataFrame(Sr = atlas$Spatial,
+ data = dudi.pca(atlas$meteo, scann = FALSE)$li)
+ g5 <- s.Spatial(obj5[, 1], nclass = 12, psub = list(position = "topleft",
+ text = "Principal Component Analysis analysis", cex = 1.5), plot = FALSE)
+ coa1 <- dudi.coa(atlas$birds, scann = FALSE, nf = 1)
+ obj6 <- sp::SpatialPolygonsDataFrame(Sr = atlas$Spatial, data = coa1$li)
+ g6 <- s.Spatial(obj6[, 1], nclass = 12, psub = list(position = "topleft",
+ text = "Correspondence analysis", cex = 1.5), plot = FALSE)
+ g7 <- s.value(atlas$xy, coa1$li$Axis1, Sp = atlas$Spatial.contour, ppoints.cex = 2,
+ porigin.include = FALSE, paxes.draw = FALSE, pSp.col = "white", plot = FALSE)
+ g8 <- triangle.label(atlas$alti, plabels.cex = 0, plot = FALSE)
+ G2 <- ADEgS(list(g5, g6, g7, g8), layout = c(2, 2))
+
+ }
+} else {
+ op <- par(no.readonly = TRUE)
+ par(mfrow = c(2, 2))
+ area.plot(atlas$area, cpoin = 1.5)
+ area.plot(atlas$area, lab = atlas$names.district, clab = 1)
+ x <- atlas$meteo$mini.jan
+
+ names(x) <- row.names(atlas$meteo)
+ area.plot(atlas$area, val = x, ncl = 12, sub = "Temp Mini January", csub = 2, cleg = 1)
+ s.corcircle((dudi.pca(atlas$meteo, scann = FALSE)$co), clab = 1)
+
+ area.plot(atlas$area, val = dudi.pca(atlas$meteo,scann=FALSE)$li[, 1], ncl = 12,
+ sub = "Principal Component Analysis analysis", csub = 1.5, cleg = 1)
+ birds.coa <- dudi.coa(atlas$birds, sca = FALSE, nf = 1)
+ x <- birds.coa$li$Axis1
+ area.plot(atlas$area, val = x, ncl = 12, sub = "Correspondence analysis", csub = 1.5, cleg = 1)
+
+ s.value(atlas$xy, x, contour = atlas$contour, csi = 2, incl = FALSE, addax = FALSE)
+ triangle.plot(atlas$alti)
+ par(op)
+ par(mfrow = c(1, 1))}
+}
+
+\keyword{datasets}
\ No newline at end of file
diff --git a/man/atya.Rd b/man/atya.Rd
new file mode 100644
index 0000000..cb6513b
--- /dev/null
+++ b/man/atya.Rd
@@ -0,0 +1,37 @@
+\name{atya}
+\alias{atya}
+\docType{data}
+\title{Genetic variability of Cacadors}
+\description{
+This data set contains information about genetic variability of \emph{Atya innocous} and \emph{Atya scabra} in Guadeloupe (France).
+}
+\usage{data(atya)}
+\format{
+\code{atya} is a list with the following objects :
+\describe{
+ \item{xy}{: a data frame with the coordinates of the 31 sites}
+ \item{gen}{: a data frame with 22 variables collected on 31 sites}
+ \item{neig}{: an object of class \code{neig}}
+}}
+\source{
+Fievet, E., Eppe, F. and Dolédec, S. (2001) Etude de la variabilité morphométrique et génétique des populations de Cacadors (\emph{Atya innocous} et \emph{Atya scabra}) de l'île de Basse-Terre. Direction Régionale de L'Environnement Guadeloupe, Laboratoire des hydrosystèmes fluviaux, Université Lyon 1.
+}
+\examples{
+\dontrun{
+data(atya)
+if(requireNamespace("pixmap", quietly = TRUE)) {
+ atya.digi <- pixmap::read.pnm(system.file("pictures/atyadigi.pnm",
+ package = "ade4"))
+ atya.carto <- pixmap::read.pnm(system.file("pictures/atyacarto.pnm",
+ package = "ade4"))
+ par(mfrow = c(1, 2))
+ pixmap:::plot(atya.digi)
+ pixmap:::plot(atya.carto)
+ points(atya$xy, pch = 20, cex = 2)
+}
+if(requireNamespace("maptools", quietly = TRUE) & requireNamespace("spdep", quietly = TRUE)) {
+ plot(neig2nb(atya$neig), atya$xy, col = "red", add = TRUE, lwd = 2)
+ par(mfrow = c(1,1))
+}
+}}
+\keyword{datasets}
diff --git a/man/avijons.Rd b/man/avijons.Rd
new file mode 100644
index 0000000..9848d78
--- /dev/null
+++ b/man/avijons.Rd
@@ -0,0 +1,91 @@
+\name{avijons}
+\alias{avijons}
+\docType{data}
+\title{Bird species distribution}
+\description{
+This data set contains information about spatial distribution of bird species in a zone surrounding the river Rhône near Lyon (France).
+}
+\usage{data(avijons)}
+\format{
+\code{avijons} is a list with the following objects :
+\describe{
+ \item{xy}{: a data frame with the coordinates of the sites}
+ \item{area}{: an object of class \code{area}}
+ \item{fau}{: a data frame with the abundance of 64 bird species in 91 sites}
+ \item{spe.names.fr}{: a vector of strings of character with the species names in french}
+}}
+\source{
+Bournaud, M., Amoros, C., Chessel, D., Coulet, M., Doledec, S., Michelot, J.L., Pautou, G., Rostan, J.C., Tachet, H. and Thioulouse, J. (1990)
+\emph{Peuplements d'oiseaux et propriétés des écocomplexes de la plaine du Rhône : descripteurs de fonctionnement global et gestion des berges.} Rapport programme S.R.E.T.I.E., Ministère de l'Environnement CORA et URA CNRS 367, Univ. Lyon I.
+}
+\references{
+Thioulouse, J., Chessel, D. and Champely, S. (1995) Multivariate analysis of spatial patterns:
+a unified approach to local and global structures. \emph{Environmental and Ecological Statistics}, \bold{2}, 1--14.
+
+See a data description at \url{http://pbil.univ-lyon1.fr/R/pdf/pps051.pdf} (in French).
+}
+\examples{
+data(avijons)
+w1 <- dudi.coa(avijons$fau, scannf = FALSE)$li
+area.plot(avijons$area, center = avijons$xy, val = w1[, 1], clab = 0.75,
+ sub = "CA Axis 1", csub = 3)
+
+\dontrun{
+data(avijons)
+if(!adegraphicsLoaded()) {
+ if(requireNamespace("pixmap", quietly = TRUE)) {
+ pnm.eau <- pixmap::read.pnm(system.file("pictures/avijonseau.pnm", package = "ade4"))
+ pnm.rou <- pixmap::read.pnm(system.file("pictures/avijonsrou.pnm", package = "ade4"))
+ pnm.veg <- pixmap::read.pnm(system.file("pictures/avijonsveg.pnm", package = "ade4"))
+ pnm.vil <- pixmap::read.pnm(system.file("pictures/avijonsvil.pnm", package = "ade4"))
+ jons.coa <- dudi.coa(avijons$fau, scan = FALSE, nf = 4)
+
+ par(mfcol = c(3, 2))
+ s.value(avijons$xy, jons.coa$li[, 1], pixmap = pnm.rou, inclu = FALSE,
+ grid = FALSE, addax = FALSE, cleg = 0, sub = "F1+ROADS", csub = 3)
+ s.value(avijons$xy, jons.coa$li[, 1], pixmap = pnm.veg, inclu = FALSE,
+ grid = FALSE, addax = FALSE, cleg = 0, sub = "F1+TREES", csub = 3)
+ s.value(avijons$xy, jons.coa$li[, 1], pixmap = pnm.eau, inclu = FALSE,
+ grid = FALSE, addax = FALSE, cleg = 0, sub = "F1+WATER", csub = 3)
+ s.value(avijons$xy, jons.coa$li[, 2], pixmap = pnm.rou, inclu = FALSE,
+ grid = FALSE, addax = FALSE, cleg = 0, sub = "F2+ROADS", csub = 3)
+ s.value(avijons$xy, jons.coa$li[, 2], pixmap = pnm.veg, inclu = FALSE,
+ grid = FALSE, addax = FALSE, cleg = 0, sub = "F2+TREES", csub = 3)
+ s.value(avijons$xy, jons.coa$li[, 2], pixmap = pnm.eau, inclu = FALSE,
+ grid = FALSE, addax = FALSE, cleg = 0, sub = "F2+WATER", csub = 3)
+ par(mfrow = c(1, 1))
+ }
+
+ if(requireNamespace("maptools", quietly = TRUE) & requireNamespace("spdep", quietly = TRUE) &
+ requireNamespace("pixmap", quietly = TRUE)) {
+
+ link1 <- area2link(avijons$area)
+ lw1 <- apply(link1, 1, function(x) x[x > 0])
+ neig1 <- neig(mat01 = 1*(link1 > 0))
+ nb1 <- neig2nb(neig1)
+ listw1 <- spdep::nb2listw(nb1,lw1)
+ jons.ms <- multispati(jons.coa, listw1, scan = FALSE, nfp = 3, nfn = 2)
+ summary(jons.ms)
+ par(mfrow = c(2, 2))
+ barplot(jons.coa$eig)
+ barplot(jons.ms$eig)
+ s.corcircle(jons.ms$as)
+ plot(jons.coa$li[, 1], jons.ms$li[, 1])
+ par(mfrow = c(1, 1))
+
+ par(mfcol = c(3, 2))
+ s.value(avijons$xy, jons.ms$li[, 1], pixmap = pnm.rou, inclu = FALSE,
+ grid = FALSE, addax = FALSE, cleg = 0, sub = "F1+ROADS", csub = 3)
+ s.value(avijons$xy, jons.ms$li[, 1], pixmap = pnm.veg, inclu = FALSE,
+ grid = FALSE, addax = FALSE, cleg = 0, sub = "F1+TREES", csub = 3)
+ s.value(avijons$xy, jons.ms$li[, 1], pixmap = pnm.eau, inclu = FALSE,
+ grid = FALSE, addax = FALSE, cleg = 0, sub = "F1+WATER", csub = 3)
+ s.value(avijons$xy, jons.ms$li[, 2], pixmap = pnm.rou, inclu = FALSE,
+ grid = FALSE, addax = FALSE, cleg = 0, sub = "F2+ROADS", csub = 3)
+ s.value(avijons$xy, jons.ms$li[, 2], pixmap = pnm.veg, inclu = FALSE,
+ grid = FALSE, addax = FALSE, cleg = 0, sub = "F2+TREES", csub = 3)
+ s.value(avijons$xy, jons.ms$li[, 2], pixmap = pnm.eau, inclu = FALSE,
+ grid = FALSE, addax = FALSE, cleg = 0, sub = "F2+WATER", csub = 3)
+ par(mfrow = c(1, 1))
+}}}}
+\keyword{datasets}
diff --git a/man/avimedi.Rd b/man/avimedi.Rd
new file mode 100644
index 0000000..5ca3470
--- /dev/null
+++ b/man/avimedi.Rd
@@ -0,0 +1,61 @@
+\name{avimedi}
+\alias{avimedi}
+\docType{data}
+\title{Fauna Table for Constrained Ordinations}
+\description{
+\code{avimedi} is a list containing the information about 302 sites : \cr
+frequencies of 51 bird species ; two factors (habitats and Mediterranean origin).
+}
+\usage{data(avimedi)}
+\format{
+ This list contains the following objects:
+ \describe{
+ \item{fau}{is a data frame 302 sites - 51 bird species. }
+ \item{plan}{is a data frame 302 sites - 2 factors : \code{reg} with two levels Provence (\code{Pr},
+ South of France) and Corsica (\code{Co}) ;
+ \code{str} with six levels describing the vegetation from a very low matorral (1) up to a mature forest of holm oaks (6).}
+ \item{nomesp}{is a vector 51 latin names. }
+ }
+}
+\source{
+Blondel, J., Chessel, D., & Frochot, B. (1988)
+Bird species impoverishment, niche expansion, and density inflation in mediterranean island habitats.
+\emph{Ecology}, \bold{69}, 1899--1917.
+}
+\examples{
+\dontrun{
+data(avimedi)
+coa1 <- dudi.coa(avimedi$fau, scan = FALSE, nf = 3)
+bet1 <- bca(coa1, avimedi$plan$str, scan = FALSE)
+wit1 <- wca(coa1, avimedi$plan$reg, scan=FALSE)
+pcaiv1 <- pcaiv(coa1, avimedi$plan, scan = FALSE)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.class(coa1$li, avimedi$plan$str:avimedi$plan$reg,
+ psub.text = "Correspondences Analysis", plot = FALSE)
+ g2 <- s.class(bet1$ls, avimedi$plan$str, psub.text = "Between Analysis", plot = FALSE)
+ g3 <- s.class(wit1$li, avimedi$plan$str, psub.text = "Within Analysis", plot = FALSE)
+
+ g41 <- s.match(pcaiv1$li, pcaiv1$ls, plabels.cex = 0,
+ psub.text = "Canonical Correspondences Analysis", plot = FALSE)
+ g42 <- s.class(pcaiv1$li, avimedi$plan$str:avimedi$plan$reg, plot = FALSE)
+ g4 <- superpose(g41, g42, plot = FALSE)
+
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2,2))
+ s.class(coa1$li,avimedi$plan$str:avimedi$plan$reg,
+ sub = "Correspondences Analysis")
+ s.class(bet1$ls, avimedi$plan$str,
+ sub = "Between Analysis")
+ s.class(wit1$li, avimedi$plan$str,
+ sub = "Within Analysis")
+ s.match(pcaiv1$li, pcaiv1$ls, clab = 0,
+ sub = "Canonical Correspondences Analysis")
+ s.class(pcaiv1$li, avimedi$plan$str:avimedi$plan$reg,
+ add.plot = TRUE)
+ par(mfrow=c(1,1))
+}
+}}
+\keyword{datasets}
diff --git a/man/aviurba.Rd b/man/aviurba.Rd
new file mode 100644
index 0000000..79e1673
--- /dev/null
+++ b/man/aviurba.Rd
@@ -0,0 +1,41 @@
+\name{aviurba}
+\alias{aviurba}
+\docType{data}
+\title{Ecological Tables Triplet}
+\description{
+This data set is a list of information about 51 sites : bird species and environmental variables. \cr
+A data frame contains biological traits for each species.
+}
+\usage{data(aviurba)}
+\format{
+ This list contains the following objects:
+ \describe{
+ \item{fau}{is a data frame 51 sites 40 bird species. }
+ \item{mil}{is a data frame 51 sites 11 environmental variables (see details). }
+ \item{traits}{is a data frame 40 species 4 biological traits (see details).}
+ \item{species.names.fr}{is a vector of the species names in french. }
+ \item{species.names.la}{is a vector of the species names in latin. }
+ \item{species.family}{is a factor : the species families. }
+ }
+}
+\details{
+\code{aviurba$mil} contains for each site, 11 habitat attributes describing the degree of urbanization.
+The presence or absence of farms or villages, small buildings, high buildings, industry, fields, grassland, scrubby areas,
+deciduous woods, coniferous woods, noisy area are noticed. At least, the vegetation cover (variable 11) is a factor with 8 levels
+from a minimum cover (R5) up to a maximum (R100).\cr
+
+\code{aviurba$traits} contains four factors : feeding habit (insectivor, granivore, omnivore), feeding stratum (ground, aerial, foliage and scrub),
+breeding stratum (ground, building, scrub, foliage) and migration strategy (resident, migrant).
+}
+\source{
+Dolédec, S., Chessel, D., Ter Braak,C. J. F. and Champely S. (1996)
+Matching species traits to environmental variables: a new three-table ordination method.
+\emph{Environmental and Ecological Statistics}, \bold{3}, 143--166.
+}
+\examples{
+data(aviurba)
+a1 <- dudi.coa(aviurba$fau, scan = FALSE, nf=4)
+a2 <- dudi.acm(aviurba$mil, row.w = a1$lw, scan = FALSE, nf = 4)
+plot(coinertia(a1, a2, scan = FALSE))
+}
+\keyword{datasets}
diff --git a/man/bacteria.Rd b/man/bacteria.Rd
new file mode 100644
index 0000000..afdb377
--- /dev/null
+++ b/man/bacteria.Rd
@@ -0,0 +1,37 @@
+\name{bacteria}
+\alias{bacteria}
+\docType{data}
+\title{Genomes of 43 Bacteria}
+\description{
+ \code{bacteria} is a list containing 43 species and genomic informations : codons, amino acid and bases.
+}
+\usage{data(bacteria)}
+\format{
+ This list contains the following objects:
+ \describe{
+ \item{code}{is a factor with the amino acid names for each codon. }
+ \item{espcodon}{is a data frame 43 species 64 codons. }
+ \item{espaa}{is a data frame 43 species 21 amino acid. }
+ \item{espbase}{is a data frame 43 species 4 bases. }
+ }
+}
+\source{
+Data prepared by J. Lobry \email{Jean.Lobry at univ-lyon1.fr}
+starting from:\cr
+\url{http://www.tigr.org/tdb/mdb/mdbcomplete.html}
+}
+\examples{
+data(bacteria)
+names(bacteria$espcodon)
+names(bacteria$espaa)
+names(bacteria$espbase)
+sum(bacteria$espcodon) # 22,619,749 codons
+
+if(adegraphicsLoaded()) {
+ g <- scatter(dudi.coa(bacteria$espcodon, scann = FALSE),
+ posi = "bottomleft")
+} else {
+ scatter(dudi.coa(bacteria$espcodon, scann = FALSE),
+ posi = "bottom")
+}}
+\keyword{datasets}
diff --git a/man/banque.Rd b/man/banque.Rd
new file mode 100644
index 0000000..6ad29e9
--- /dev/null
+++ b/man/banque.Rd
@@ -0,0 +1,163 @@
+\name{banque}
+\alias{banque}
+\docType{data}
+\title{Table of Factors}
+\description{
+ \code{banque} gives the results of a bank survey onto 810 customers.
+}
+\usage{data(banque)}
+\format{
+ This data frame contains the following columns:
+ \enumerate{
+ \item csp: "Socio-professional categories" a factor with levels
+ \itemize{
+ \item \code{agric} Farmers
+ \item \code{artis} Craftsmen, Shopkeepers, Company directors
+ \item \code{cadsu} Executives and higher intellectual professions
+ \item \code{inter} Intermediate professions
+ \item \code{emplo} Other white-collar workers
+ \item \code{ouvri} Manual workers
+ \item \code{retra} Pensionners
+ \item \code{inact} Non working population
+ \item \code{etudi} Students}
+
+ \item duree: "Time relations with the customer" a factor with levels
+ \itemize{
+ \item \code{dm2} <2 years
+ \item \code{d24} [2 years, 4 years[
+ \item \code{d48} [4 years, 8 years[
+ \item \code{d812} [8 years, 12 years[
+ \item \code{dp12} >= 12 years}
+
+ \item oppo: "Stopped a check?" a factor with levels
+ \itemize{
+ \item \code{non} no
+ \item \code{oui} yes}
+
+ \item age: "Customer's age" a factor with levels
+ \itemize{
+ \item \code{ai25} [18 years, 25 years[
+ \item \code{ai35} [25 years, 35 years[
+ \item \code{ai45} [35 years, 45 years[
+ \item \code{ai55} [45 years, 55 years[
+ \item \code{ai75} [55 years, 75 years[}
+
+ \item sexe: "Customer's gender" a factor with levels
+ \itemize{
+ \item \code{hom} Male
+ \item \code{fem} Female}
+
+ \item interdit: "No checkbook allowed" a factor with levels
+ \itemize{
+ \item \code{non} no
+ \item \code{oui} yes }
+
+ \item cableue: "Possess a bank card?" a factor with levels
+ \itemize{
+ \item \code{non} no
+ \item \code{oui} yes }
+
+ \item assurvi: "Contrat of life insurance?" a factor with levels
+ \itemize{
+ \item \code{non} no\cr
+ \item \code{oui} yes}
+
+ \item soldevu: "Balance of the current accounts" a factor with levels
+ \itemize{
+ \item \code{p4} credit balance > 20000
+ \item \code{p3} credit balance 12000-20000
+ \item \code{p2} credit balance 4000-120000
+ \item \code{p1} credit balance >0-4000
+ \item \code{n1} debit balance 0-4000
+ \item \code{n2} debit balance >4000 }
+
+ \item eparlog: "Savings and loan association account amount" a factor with levels
+ \itemize{
+ \item \code{for} > 20000
+ \item \code{fai} >0 and <20000
+ \item \code{nul} nulle }
+
+ \item eparliv: "Savings bank amount" a factor with levels
+ \itemize{
+ \item \code{for} > 20000
+ \item \code{fai} >0 and <20000
+ \item \code{nul} nulle }
+
+ \item credhab: "Home loan owner" a factor with levels
+ \itemize{
+ \item \code{non} no
+ \item \code{oui} yes }
+
+ \item credcon: "Consumer credit amount" a factor with levels
+ \itemize{
+ \item \code{nul} none
+ \item \code{fai} >0 and <20000
+ \item \code{for} > 20000 }
+
+ \item versesp: "Check deposits" a factor with levels
+ \itemize{
+ \item \code{oui} yes
+ \item \code{non} no }
+
+ \item retresp: "Cash withdrawals" a factor with levels
+ \itemize{
+ \item \code{fai} < 2000
+ \item \code{moy} 2000-5000
+ \item \code{for} > 5000 }
+
+ \item remiche: "Endorsed checks amount" a factor with levels
+ \itemize{
+ \item \code{for} >10000
+ \item \code{moy} 10000-5000
+ \item \code{fai} 1-5000
+ \item \code{nul} none }
+
+ \item preltre: "Treasury Department tax deductions" a factor with levels
+ \itemize{
+ \item \code{nul} none
+ \item \code{fai} <1000
+ \item \code{moy} >1000 }
+
+ \item prelfin: "Financial institution deductions" a factor with levels
+ \itemize{
+ \item \code{nul} none
+ \item \code{fai} <1000
+ \item \code{moy} >1000 }
+
+ \item viredeb: "Debit transfer amount" a factor with levels
+ \itemize{
+ \item \code{nul} none
+ \item \code{fai} <2500
+ \item \code{moy} 2500-5000
+ \item \code{for} >5000}
+
+ \item virecre: "Credit transfer amount" a factor with levels
+ \itemize{
+ \item \code{for} >10000
+ \item \code{moy} 10000-5000
+ \item \code{fai} <5000
+ \item \code{nul} aucun}
+
+ \item porttit: "Securities portfolio estimations" a factor with levels
+ \itemize{
+ \item \code{nul} none
+ \item \code{fai} < 20000
+ \item \code{moy} 20000-100000
+ \item \code{for} >100000}
+ }
+}
+\source{
+ anonymous
+}
+\examples{
+data(banque)
+banque.acm <- dudi.acm(banque, scannf = FALSE, nf = 3)
+apply(banque.acm$cr, 2, mean)
+banque.acm$eig[1:banque.acm$nf] # the same thing
+
+if(adegraphicsLoaded()) {
+ g <- s.arrow(banque.acm$c1, plabels.cex = 0.75)
+} else {
+ s.arrow(banque.acm$c1, clab = 0.75)
+}}
+\keyword{datasets}
diff --git a/man/baran95.Rd b/man/baran95.Rd
new file mode 100644
index 0000000..1ab7817
--- /dev/null
+++ b/man/baran95.Rd
@@ -0,0 +1,76 @@
+\name{baran95}
+\alias{baran95}
+\docType{data}
+\title{African Estuary Fishes}
+\description{
+This data set is a list containing relations between sites and fish species linked to dates.
+}
+\usage{data(baran95)}
+\format{
+ This list contains the following objects:
+ \describe{
+ \item{fau}{is a data frame 95 seinings and 33 fish species. }
+ \item{plan}{is a data frame 2 factors : date and site. The \code{date} has 6 levels (april 1993, june 1993,
+ august 1993, october 1993, december 1993 and february 1994) and the \code{sites} are defined by 4 distances to the
+ Atlantic Ocean (km03, km17, km33 and km46). }
+ \item{species.names}{is a vector of species latin names. }
+ }
+}
+\source{
+Baran, E. (1995) \emph{Dynamique spatio-temporelle des peuplements de Poissons estuariens en Guinée (Afrique de l'Ouest)}.
+Thèse de Doctorat, Université de Bretagne Occidentale.
+Data collected by net fishing sampling in the Fatala river estuary.
+}
+\references{
+See a data description at \url{http://pbil.univ-lyon1.fr/R/pdf/pps027.pdf} (in French).
+}
+\examples{
+data(baran95)
+w <- dudi.pca(log(baran95$fau + 1), scal = FALSE, scann = FALSE,
+ nf = 3)
+w1 <- wca(w, baran95$plan$date, scann = FALSE)
+fatala <- ktab.within(w1)
+stat1 <- statis(fatala, scan = FALSE, nf = 3)
+mfa1 <- mfa(fatala, scan = FALSE, nf = 3)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.class(stat1$C.Co, baran95$plan$site, facets = baran95$plan$date,
+ pellipses.axes.draw = FALSE, ppoints.cex = 0.5, plot = FALSE)
+ n1 <- length(g1 at ADEglist)
+ g2 <- ADEgS(lapply(1:n1, function(i) s.label(stat1$C.Co, plabels.cex = 0,
+ ppoints.cex = 0.5, plot = FALSE)), positions = g1 at positions, plot = FALSE)
+ G1 <- superpose(g2, g1, plot = TRUE)
+
+ G2 <- kplot(stat1, arrow = FALSE, traject = FALSE, class = baran95$plan$site,
+ col.plabels.cex = 0, ppoints.cex = 0.5)
+
+ g3 <- s.class(mfa1$co, baran95$plan$site, facets = baran95$plan$date,
+ pellipses.axes.draw = FALSE, ppoints.cex = 0.5, plot = FALSE)
+ n2 <- length(g3 at ADEglist)
+ g4 <- ADEgS(lapply(1:n2, function(i) s.label(mfa1$co, plabels.cex = 0,
+ ppoints.cex = 0.5, plot = FALSE)), positions = g3 at positions, plot = FALSE)
+ G3 <- superpose(g4, g3, plot = TRUE)
+
+} else {
+ par(mfrow = c(3, 2))
+ w2 <- split(stat1$C.Co, baran95$plan$date)
+ w3 <- split(baran95$plan$site, baran95$plan$date)
+ for (j in 1:6) {
+ s.label(stat1$C.Co[,1:2], clab = 0, sub = tab.names(fatala)[j], csub = 3)
+ s.class(w2[[j]][, 1:2], w3[[j]], clab = 2, axese = FALSE, add.plot = TRUE)
+ }
+ par(mfrow = c(1, 1))
+
+ kplot(stat1, arrow = FALSE, traj = FALSE, clab = 2, uni = TRUE,
+ class = baran95$plan$site) #simpler
+
+ par(mfrow = c(3, 2))
+ w4 <- split(mfa1$co, baran95$plan$date)
+ for (j in 1:6) {
+ s.label(mfa1$co[, 1:2], clab = 0, sub = tab.names(fatala)[j], csub = 3)
+ s.class(w4[[j]][, 1:2], w3[[j]], clab = 2, axese = FALSE, add.plot = TRUE)
+ }
+ par(mfrow = c(1, 1))
+}
+}
+\keyword{datasets}
diff --git a/man/bca.rlq.Rd b/man/bca.rlq.Rd
new file mode 100644
index 0000000..6fafc6f
--- /dev/null
+++ b/man/bca.rlq.Rd
@@ -0,0 +1,63 @@
+\name{bca.rlq}
+\alias{bca.rlq}
+\alias{plot.betrlq}
+\alias{print.betrlq}
+\title{
+Between-Class RLQ analysis
+}
+\description{
+Performs a particular RLQ analysis where a partition of sites (rows of
+R) is taken into account. The between-class RLQ analysis search for
+linear combinations of traits and environmental variables maximizing the
+covariances between the traits and the average environmental conditions of classes.
+}
+\usage{
+\method{bca}{rlq}(x, fac, scannf = TRUE, nf = 2, ...)
+\method{plot}{betrlq}(x, xax = 1, yax = 2, ...)
+\method{print}{betrlq}(x, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{an object of class rlq (created by the \code{rlq} function)
+ for the \code{bca.rlq} function. An object of class \code{betrlq} for
+ the \code{print} and \code{plot} functions}
+ \item{fac}{a factor partitioning the rows of R}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+ \item{xax}{the column number for the x-axis}
+ \item{yax}{the column number for the y-axis}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+
+\value{
+ The \code{bca.rlq} function returns an object of class 'betrlq'
+ (sub-class of 'dudi'). See the outputs of the \code{print} function
+ for more details.
+}
+\references{
+Wesuls, D., Oldeland, J. and Dray, S. (2012) Disentangling plant trait
+responses to livestock grazing from spatio-temporal variation: the
+partial RLQ approach. \emph{Journal of Vegetation Science}, \bold{23}, 98--113.
+}
+\author{
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+
+\seealso{\code{\link{rlq}}, \code{\link{bca}}, \code{\link{wca.rlq}}
+}
+
+\examples{
+data(piosphere)
+afcL <- dudi.coa(log(piosphere$veg + 1), scannf = FALSE)
+acpR <- dudi.pca(piosphere$env, scannf = FALSE, row.w = afcL$lw)
+acpQ <- dudi.hillsmith(piosphere$traits, scannf = FALSE, row.w =
+ afcL$cw)
+rlq1 <- rlq(acpR, afcL, acpQ, scannf = FALSE)
+
+brlq1 <- bca(rlq1, fac = piosphere$habitat, scannf = FALSE)
+brlq1
+plot(brlq1)
+}
+
+\keyword{ multivariate }
+
diff --git a/man/between.Rd b/man/between.Rd
new file mode 100644
index 0000000..cb6d256
--- /dev/null
+++ b/man/between.Rd
@@ -0,0 +1,87 @@
+\name{bca}
+\alias{between}
+\alias{bca}
+\alias{bca.dudi}
+\title{Between-Class Analysis}
+\description{
+Performs a particular case of a Principal Component Analysis with
+respect to Instrumental Variables (pcaiv), in which there is only a
+single factor as explanatory variable.
+}
+\usage{
+between(dudi, fac, scannf = TRUE, nf = 2)
+\method{bca}{dudi}(x, fac, scannf = TRUE, nf = 2, \dots)
+}
+\arguments{
+ \item{dudi}{a duality diagram, object of class \code{\link{dudi}}
+ obtained from the functions \code{dudi.coa}, \code{dudi.pca},...}
+ \item{x}{a duality diagram, object of class \code{\link{dudi}} from
+ one of the functions \code{dudi.coa}, \code{dudi.pca},...}
+ \item{fac}{a factor partitioning the rows of \code{dudi$tab} in classes}
+ \item{scannf}{a logical value indicating whether the eigenvalues barplot should be displayed}
+ \item{nf}{if scannf FALSE, a numeric value indicating the number of kept axes}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+Returns a list of class \code{\link{dudi}}, subclass 'between' containing
+ \item{tab}{a data frame class-variables containing the means per class
+ for each variable}
+ \item{cw}{a numeric vector of the column weigths}
+ \item{lw}{a numeric vector of the class weigths}
+ \item{eig}{a numeric vector with all the eigenvalues}
+ \item{rank}{the rank of the analysis}
+ \item{nf}{an integer value indicating the number of kept axes}
+ \item{c1}{a data frame with the column normed scores}
+ \item{l1}{a data frame with the class normed scores}
+ \item{co}{a data frame with the column coordinates}
+ \item{li}{a data frame with the class coordinates}
+ \item{call}{the matching call}
+ \item{ratio}{the bewteen-class inertia percentage}
+ \item{ls}{a data frame with the row coordinates}
+ \item{as}{a data frame containing the projection of inertia axes onto between axes}
+}
+\references{
+Dolédec, S. and Chessel, D. (1987) Rythmes saisonniers et composantes stationnelles en milieu aquatique
+I- Description d'un plan d'observations complet par projection de variables. \emph{Acta Oecologica, Oecologia Generalis}, \bold{8}, 3, 403--426.
+}
+
+\note{
+To avoid conflict names with the \code{base:::within} function, the
+function \code{within} is now deprecated and will be removed. To be
+consistent, the \code{between} function is also deprecated and
+is replaced by the method \code{bca.dudi} of the new generic \code{bca} function.
+}
+
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(meaudret)
+pca1 <- dudi.pca(meaudret$env, scan = FALSE, nf = 4)
+pca2 <- dudi.pca(meaudret$spe, scal = FALSE, scan = FALSE, nf = 4)
+bet1 <- bca(pca1, meaudret$design$site, scan = FALSE, nf = 2)
+bet2 <- bca(pca2, meaudret$design$site, scan = FALSE, nf = 2)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.class(pca1$li, meaudret$design$site, psub.text = "Principal Component Analysis (env)",
+ plot = FALSE)
+ g2 <- s.class(pca2$li, meaudret$design$site, psub.text = "Principal Component Analysis (spe)",
+ plot = FALSE)
+ g3 <- s.class(bet1$ls, meaudret$design$site, psub.text = "Between sites PCA (env)", plot = FALSE)
+ g4 <- s.class(bet2$ls, meaudret$design$site, psub.text = "Between sites PCA (spe)", plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2, 2))
+ s.class(pca1$li, meaudret$design$site, sub = "Principal Component Analysis (env)", csub = 1.75)
+ s.class(pca2$li, meaudret$design$site, sub = "Principal Component Analysis (spe)", csub = 1.75)
+ s.class(bet1$ls, meaudret$design$site, sub = "Between sites PCA (env)", csub = 1.75)
+ s.class(bet2$ls, meaudret$design$site, sub = "Between sites PCA (spe)", csub = 1.75)
+ par(mfrow = c(1, 1))
+}
+
+coib <- coinertia(bet1, bet2, scann = FALSE)
+plot(coib)
+}
+\keyword{multivariate}
diff --git a/man/betweencoinertia.Rd b/man/betweencoinertia.Rd
new file mode 100644
index 0000000..c047ca7
--- /dev/null
+++ b/man/betweencoinertia.Rd
@@ -0,0 +1,62 @@
+\name{bca.coinertia}
+\alias{betweencoinertia}
+\alias{bca.coinertia}
+\title{Between-class coinertia analysis}
+\description{Performs a between-class analysis after a coinertia analysis}
+\usage{
+betweencoinertia(obj, fac, scannf = TRUE, nf = 2)
+\method{bca}{coinertia}(x, fac, scannf = TRUE, nf = 2, \dots)
+}
+
+\arguments{
+ \item{obj}{a coinertia analysis (object of class \link{coinertia})
+ obtained by the function \link{coinertia}}
+ \item{x}{a coinertia analysis (object of class \link{coinertia})
+ obtained by the function \link{coinertia}}
+ \item{fac}{a factor partitioning the rows in classes}
+ \item{scannf}{a logical value indicating whether the eigenvalues barplot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\details{
+ This analysis is equivalent to do a between-class analysis on each
+ initial dudi, and a coinertia analysis on the two between analyses. This function returns additional outputs for the interpretation.
+}
+\value{
+ An object of the class \code{betcoi}. Outputs are described by the
+ \code{print} function
+}
+\references{
+Franquet E., Doledec S., and Chessel D. (1995) Using multivariate analyses for separating spatial and temporal effects within species-environment relationships. \emph{Hydrobiologia}, \bold{300}, 425--431.
+}
+
+\note{
+To avoid conflict names with the \code{base:::within} function, the
+function \code{within} is now deprecated and will be removed. To be
+consistent, the \code{betweencoinertia} function is also deprecated and
+is replaced by the method \code{bca.coinertia} of the new generic \code{bca} function.
+}
+
+\author{
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr} and Jean Thioulouse \email{jean.thioulouse at univ-lyon1.fr}
+}
+
+\seealso{\code{\link{coinertia}}, \code{\link{between}}}
+\examples{
+data(meaudret)
+pca1 <- dudi.pca(meaudret$env, scan = FALSE, nf = 4)
+pca2 <- dudi.pca(meaudret$spe, scal = FALSE, scan = FALSE, nf = 4)
+
+bet1 <- bca(pca1, meaudret$design$site, scan = FALSE, nf = 2)
+bet2 <- bca(pca2, meaudret$design$site, scan = FALSE, nf = 2)
+coib <- coinertia(bet1, bet2, scannf = FALSE)
+
+coi <- coinertia(pca1, pca2, scannf = FALSE, nf = 3)
+coi.b <- bca(coi,meaudret$design$site, scannf = FALSE)
+## coib and coi.b are equivalent
+
+plot(coi.b)
+}
+
+\keyword{multivariate}
+
diff --git a/man/bf88.Rd b/man/bf88.Rd
new file mode 100644
index 0000000..a842f01
--- /dev/null
+++ b/man/bf88.Rd
@@ -0,0 +1,46 @@
+\name{bf88}
+\alias{bf88}
+\docType{data}
+\title{Cubic Ecological Data}
+\description{
+\code{bf88} is a list of 6 data frames corresponding to 6 stages of vegetation. \cr
+Each data frame gives some bird species informations for 4 counties.
+}
+\usage{data(bf88)}
+\format{
+A list of six data frames with 79 rows (bird species) and 4 columns (counties).\cr
+The 6 arrays (S1 to S6) are the 6 stages of vegetation.\cr
+The attribut 'nomesp' of this list is a vector of species French names.
+}
+\source{
+Blondel, J. and Farre, H. (1988)
+The convergent trajectories of bird communities along ecological successions in european forests.
+\emph{Oecologia} (Berlin), \bold{75}, 83--93.
+}
+\examples{
+data(bf88)
+fou1 <- foucart(bf88, scann = FALSE, nf = 3)
+fou1
+
+if(adegraphicsLoaded()) {
+ g1 <- scatter(fou1, plot = FALSE)
+ g2 <- s.traject(fou1$Tco, fou1$TC[, 1], plines.lty = 1:length(levels(fou1$TC[, 1])), plot = FALSE)
+ g3 <- s.traject(fou1$Tco, fou1$TC[, 2], plines.lty = 1:length(levels(fou1$TC[, 2])), plot = FALSE)
+ g41 <- s.label(fou1$Tco, plot = FALSE)
+ g42 <- s.label(fou1$co, plab.cex = 2, plot = FALSE)
+ g4 <- superpose(g41, g42, plot = FALSE)
+ G1 <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+ G2 <- kplot(fou1, row.plab.cex = 0, psub.cex = 2)
+
+} else {
+ par(mfrow = c(2,2))
+ scatter(fou1)
+ s.traject(fou1$Tco, fou1$TC[, 1])
+ s.traject(fou1$Tco, fou1$TC[, 2])
+ s.label(fou1$Tco)
+ s.label(fou1$co, add.p = TRUE, clab = 2)
+ par(mfrow = c(1, 1))
+ kplot(fou1, clab.c = 2, clab.r = 0, csub = 3)
+}}
+\keyword{datasets}
diff --git a/man/bicenter.wt.Rd b/man/bicenter.wt.Rd
new file mode 100644
index 0000000..d0c66bf
--- /dev/null
+++ b/man/bicenter.wt.Rd
@@ -0,0 +1,28 @@
+\name{bicenter.wt}
+\alias{bicenter.wt}
+\title{Double Weighted Centring}
+\description{
+This function creates a doubly centred matrix.
+}
+\usage{
+bicenter.wt(X, row.wt = rep(1, nrow(X)), col.wt = rep(1, ncol(X)))
+}
+\arguments{
+ \item{X}{a matrix with n rows and p columns}
+ \item{row.wt}{a vector of positive or null weights of length n}
+ \item{col.wt}{a vector of positive or null weights of length p}
+}
+\value{
+returns a doubly centred matrix
+}
+\author{
+Daniel Chessel
+}
+\examples{
+w <- matrix(1:6, 3, 2)
+bicenter.wt(w, c(0.2,0.6,0.2), c(0.3,0.7))
+
+w <- matrix(1:20, 5, 4)
+sum(bicenter.wt(w, runif(5), runif(4))^2)
+}
+\keyword{utilities}
diff --git a/man/bordeaux.Rd b/man/bordeaux.Rd
new file mode 100644
index 0000000..8f858f9
--- /dev/null
+++ b/man/bordeaux.Rd
@@ -0,0 +1,23 @@
+\name{bordeaux}
+\alias{bordeaux}
+\docType{data}
+\title{Wine Tasting}
+\description{
+The \code{bordeaux} data frame gives the opinions of 200 judges in a blind tasting of five different types of claret
+(red wine from the Bordeaux area in the south western parts of France).
+}
+\usage{data(bordeaux)}
+\format{
+ This data frame has 5 rows (the wines) and 4 columns (the judgements) divided in excellent,
+ good, mediocre and boring.
+ }
+\source{
+ van Rijckevorsel, J. (1987) \emph{The application of fuzzy coding and horseshoes in multiple correspondence analysis}.
+ DSWO Press, Leiden (p. 32)
+}
+\examples{
+data(bordeaux)
+bordeaux
+score(dudi.coa(bordeaux, scan = FALSE))
+}
+\keyword{datasets}
diff --git a/man/bsetal97.Rd b/man/bsetal97.Rd
new file mode 100644
index 0000000..ad8518f
--- /dev/null
+++ b/man/bsetal97.Rd
@@ -0,0 +1,58 @@
+\name{bsetal97}
+\alias{bsetal97}
+\docType{data}
+\title{Ecological and Biological Traits}
+\description{
+This data set gives ecological and biological characteristics of 131 species of aquatic insects.
+}
+\usage{data(bsetal97)}
+\format{
+\code{bsetal97} is a list of 8 components.\cr
+ \describe{
+ \item{species.names}{is a vector of the names of aquatic insects.}
+ \item{taxo}{is a data frame containing the taxonomy of species: genus, family and order. }
+ \item{biol}{is a data frame containing 10 biological traits for a total of 41 modalities. }
+ \item{biol.blo}{is a vector of the numbers of items for each biological trait. }
+ \item{biol.blo.names}{is a vector of the names of the biological traits. }
+ \item{ecol}{is a data frame with 7 ecological traits for a total of 34 modalities. }
+ \item{ecol.blo}{is a vector of the numbers of items for each ecological trait. }
+ \item{ecol.blo.names}{is a vector of the names of the ecological traits. }
+ }
+}
+\details{
+The 10 variables of the data frame \code{bsetal97$biol} are called in \code{bsetal97$biol.blo.names}
+and the number of modalities per variable given in \code{bsetal97$biol.blo}. The variables are:
+female size - the body length from the front of the head to the end of the abdomen (7 length modalities),
+egg length - the egg size (6 modalities), egg number - count of eggs actually oviposited,
+generations per year (3 modalities: \eqn{\leq 1}{<= 1}, 2, > 2),
+oviposition period - the length of time during which oviposition occurred (3 modalities: \eqn{\leq 2}{<= 2} months,
+between 2 and 5 months, > 5 months), incubation time - the time between oviposition and hatching of the larvae
+(3 modalities: \eqn{\leq 4}{<= 4} weeks, between 4 and 12 weeks, > 12 weeks), egg shape (1-spherical, 2-oval, 3-cylindrical),
+ egg attachment - physiological feature of the egg and of the female (4 modalities), clutch structure (1-single eggs, 2-grouped eggs,
+ 3-egg masses), clutch number (3 modalities : 1, 2, > 2).
+
+
+The 7 variables of the data frame \code{bsetal97$ecol} are called in \code{bsetal97$ecol.blo.names}
+and the number of modalities per variable given in \code{bsetal97$ecol.blo}. The variables are:
+oviposition site - position relative to the water (7 modalities), substratum type for eggs - the substratum to which
+the eggs are definitely attached (6 modalities), egg deposition - the position of the eggs during the oviposition process (4 modalities),
+ gross habitat - the general habitat use of the species such as temporary waters or estuaries (8 modalities), saturation variance -
+ the exposure of eggs to the risk of dessication (2 modalities), time of day (1-morning, 2-day, 3-evening, 4-night),
+ season - time of the year (1-Spring, 2-Summer, 3-Automn).
+}
+\source{
+ Statzner, B., Hoppenhaus, K., Arens, M.-F. and Richoux, P. (1997)
+ Reproductive traits, habitat use and templet theory: a synthesis of world-wide data on aquatic insects.
+ \emph{Freshwater Biology}, \bold{38}, 109--135.
+}
+\references{
+See a data description at \url{http://pbil.univ-lyon1.fr/R/pdf/pps029.pdf} (in French).
+}
+\examples{
+data(bsetal97)
+X <- prep.fuzzy.var(bsetal97$biol, bsetal97$biol.blo)
+Y <- prep.fuzzy.var(bsetal97$ecol, bsetal97$ecol.blo)
+plot(coinertia(dudi.fca(X, scan = FALSE),
+ dudi.fca(Y, scan = FALSE), scan = FALSE))
+}
+\keyword{datasets}
diff --git a/man/buech.Rd b/man/buech.Rd
new file mode 100644
index 0000000..b614509
--- /dev/null
+++ b/man/buech.Rd
@@ -0,0 +1,48 @@
+\name{buech}
+\alias{buech}
+\docType{data}
+\title{Buech basin}
+\description{
+This data set contains informations about Buech basin characteristics.
+}
+\usage{data(buech)}
+\format{
+\code{buech} is a list with the following components :
+\describe{
+ \item{tab1}{: a data frame with 10 environmental variables collected on 31 sites in Juin (1984)}
+ \item{tab2}{: a data frame with 10 environmental variables collected on 31 sites in September (1984)}
+ \item{xy}{: a data frame with the coordinates of the sites}
+ \item{neig}{: an object of class \code{neig}}
+ \item{contour}{: a data frame for background map}}
+}
+\details{
+Variables of \code{buech$tab1} and \code{buech$tab2} are the following ones :\cr
+pH ; Conductivity (\eqn{\mu} S/cm) ; Carbonate (water hardness (mg/l CaCO3)) ;
+hardness (total water hardness (mg/l CaCO3)) ; Bicarbonate (alcalinity (mg/l HCO3-)) ;
+Chloride (alcalinity (mg/l Cl-)) ; Suspens (particles in suspension (mg/l)) ;
+Organic (organic particles (mg/l)) ; Nitrate (nitrate rate (mg/l NO3-)) ;
+Ammonia (amoniac rate (mg/l NH4-))
+}
+\source{
+Vespini, F. (1985) \emph{Contribution à l'étude hydrobiologique du Buech, rivière non aménagée de Haute-Provence}. Thèse de troisième cycle, Université de Provence.
+
+Vespini, F., Légier, P. and Champeau, A. (1987) Ecologie d'une rivière non aménagée des Alpes du Sud : Le Buëch (France) I. Evolution longitudinale des descripteurs physiques et chimiques. \emph{Annales de Limnologie}, \bold{23}, 151--164.
+}
+\examples{
+data(buech)
+if(adegraphicsLoaded()) {
+ if(requireNamespace("sp", quietly = TRUE)) {
+ g1 <- s.label(buech$xy, Sp = buech$Spatial, nb = buech$nb,
+ pSp.col = "transparent", plot = FALSE)
+ g2 <- s.value(buech$xy, buech$tab2$Suspens - buech$tab1$Suspens,
+ Sp = buech$Spatial, nb = buech$nb, pSp.col = "transparent", plot = FALSE)
+ G <- cbindADEg(g1, g2, plot = TRUE)
+ }
+} else {
+ par(mfrow = c(1,2))
+ s.label(buech$xy, contour = buech$contour, neig = buech$neig)
+ s.value(buech$xy, buech$tab2$Suspens - buech$tab1$Suspens,
+ contour = buech$contour, neig = buech$neig, csi = 3)
+ par(mfrow = c(1,1))
+}}
+\keyword{datasets}
diff --git a/man/butterfly.Rd b/man/butterfly.Rd
new file mode 100644
index 0000000..17cfbbb
--- /dev/null
+++ b/man/butterfly.Rd
@@ -0,0 +1,52 @@
+\name{butterfly}
+\alias{butterfly}
+\docType{data}
+\title{Genetics-Ecology-Environment Triple}
+\description{
+This data set contains environmental and genetics informations about 16 \emph{Euphydryas editha} butterfly colonies studied in California and Oregon.
+}
+\usage{data(butterfly)}
+\format{
+\code{butterfly} is a list with 4 components.
+\describe{
+ \item{xy}{is a data frame with the two coordinates of the 16 \emph{Euphydryas editha} butterfly colonies. }
+ \item{envir}{is a environmental data frame of 16 sites - 4 variables. }
+ \item{genet}{is a genetics data frame of 16 sites - 6 allele frequencies. }
+ \item{contour}{is a data frame for background map (California map). }
+ }
+}
+\source{
+McKechnie, S.W., Ehrlich, P.R. and White, R.R. (1975)
+Population genetics of Euphydryas butterflies.
+I. Genetic variation and the neutrality hypothesis.
+\emph{Genetics}, \bold{81}, 571--594.
+}
+\references{
+Manly, B.F. (1994) \emph{Multivariate Statistical Methods. A primer.}
+Second edition. Chapman & Hall, London. 1--215.
+}
+\examples{
+data(butterfly)
+
+if(adegraphicsLoaded()) {
+ if(requireNamespace("sp", quietly = TRUE)) {
+ g1 <- s.label(butterfly$xy, Sp = butterfly$Spatial, pSp.col = "white",
+ porigin.include = FALSE, plot = FALSE)
+ g2 <- table.value(dist(butterfly$xy), plot = FALSE)
+ g3 <- s.value(butterfly$xy, dudi.pca(butterfly$envir, scan = FALSE)$li[, 1],
+ Sp = butterfly$Spatial, pori.inc = FALSE, pSp.col = "transparent", ppoints.cex = 2,
+ plot = FALSE)
+ ## mt <- mantel.randtest(dist(butterfly$xy), dist(butterfly$gen), 99)
+ G <- ADEgS(list(g1, g2, g3), layout = c(2, 2), plot = TRUE)
+ }
+} else {
+ par(mfrow = c(2, 2))
+ s.label(butterfly$xy, contour = butterfly$contour, inc = FALSE)
+ table.dist(dist(butterfly$xy), labels = row.names(butterfly$xy)) # depends of mva
+ s.value(butterfly$xy, dudi.pca(butterfly$envir, scan = FALSE)$li[,1],
+ contour = butterfly$contour, inc = FALSE, csi = 3)
+ plot(mantel.randtest(dist(butterfly$xy), dist(butterfly$gen), 99),
+ main = "genetic/spatial")
+ par(mfrow = c(1,1))
+}}
+\keyword{datasets}
diff --git a/man/bwca.dpcoa.Rd b/man/bwca.dpcoa.Rd
new file mode 100644
index 0000000..7f8113c
--- /dev/null
+++ b/man/bwca.dpcoa.Rd
@@ -0,0 +1,83 @@
+\name{bwca.dpcoa}
+\alias{bwca.dpcoa}
+\alias{bca.dpcoa}
+\alias{wca.dpcoa}
+\alias{randtest.betwit}
+\alias{summary.betwit}
+\alias{print.witdpcoa}
+\alias{print.betdpcoa}
+
+\title{
+Between- and within-class double principal coordinate analysis
+}
+\description{
+These functions allow to study the variations in diversity among communities (as in dpcoa) taking into account a partition in classes
+}
+\usage{
+bwca.dpcoa(x, fac, cofac, scannf = TRUE, nf = 2, ...)
+\method{bca}{dpcoa}(x, fac, scannf = TRUE, nf = 2, \dots)
+\method{wca}{dpcoa}(x, fac, scannf = TRUE, nf = 2, \dots)
+\method{randtest}{betwit}(xtest, nrepet = 999, ...)
+\method{summary}{betwit}(object, ...)
+\method{print}{witdpcoa}(x, ...)
+\method{print}{betdpcoa}(x, ...)
+}
+
+\arguments{
+ \item{x}{an object of class \code{\link{dpcoa}}}
+ \item{fac}{a factor partitioning the collections in classes}
+ \item{scannf}{a logical value indicating whether the eigenvalues barplot should be displayed}
+ \item{nf}{if scannf FALSE, a numeric value indicating the number of kept axes}
+ \item{\dots}{further arguments passed to or from other methods}
+ \item{cofac}{a cofactor partitioning the collections in classes used as a covariable}
+ \item{nrepet}{the number of permutations}
+ \item{xtest, object}{an object of class \code{betwit} created by a call to the function \code{bwca.dpcoa}}
+}
+
+\value{
+Objects of class \code{betdpcoa}, \code{witdpcoa} or \code{betwit}
+}
+\references{
+Dray, S., Pavoine, S. and Aguirre de Carcer, D. (2015) Considering external information to improve the phylogenetic comparison of microbial communities: a new approach based on constrained Double Principal Coordinates Analysis (cDPCoA). \emph{Molecular Ecology Resources}, \bold{15}, 242--249. doi:10.1111/1755-0998.12300
+}
+\author{
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+
+\seealso{
+\code{\link{dpcoa}}
+}
+\examples{
+\dontrun{
+
+## First example of Dray et al (2015) paper
+
+con <- url("ftp://pbil.univ-lyon1.fr/pub/datasets/dray/MER2014/soilmicrob.rda")
+load(con)
+close(con)
+
+## Partial CCA
+coa <- dudi.coa(soilmicrob$OTU, scannf = FALSE)
+wcoa <- wca(coa, soilmicrob$env$pH, scannf = FALSE)
+wbcoa <- bca(wcoa,soilmicrob$env$VegType, scannf = FALSE)
+
+## Classical DPCoA
+dp <- dpcoa(soilmicrob$OTU, soilmicrob$dphy, RaoDecomp = FALSE, scannf = FALSE)
+
+## Between DPCoA (focus on the effect of vegetation type)
+bdp <- bca(dp, fac = soilmicrob$env$VegType , scannf = FALSE)
+bdp$ratio ## 0.2148972
+randtest(bdp) ## p = 0.001
+
+## Within DPCoA (remove the effect of pH)
+wdp <- wca(dp, fac = soilmicrob$env$pH, scannf = FALSE)
+wdp$ratio ## 0.5684348
+
+## Between Within-DPCoA (remove the effect of pH and focus on vegetation type)
+wbdp <- bwca.dpcoa(dp, fac = soilmicrob$env$VegType, cofac = soilmicrob$env$pH, scannf = FALSE)
+wbdp$ratio ## 0.05452813
+randtest(wbdp) ## p = 0.001
+}
+}
+
+\keyword{multivariate}
\ No newline at end of file
diff --git a/man/cailliez.Rd b/man/cailliez.Rd
new file mode 100644
index 0000000..dd6ee62
--- /dev/null
+++ b/man/cailliez.Rd
@@ -0,0 +1,47 @@
+\name{cailliez}
+\alias{cailliez}
+\title{Transformation to make Euclidean a distance matrix}
+\description{
+This function computes the smallest positive constant that makes Euclidean a distance matrix
+and applies it.
+}
+\usage{
+cailliez(distmat, print = FALSE, tol = 1e-07, cor.zero = TRUE)
+}
+\arguments{
+ \item{distmat}{an object of class \code{dist}}
+ \item{print}{if TRUE, prints the eigenvalues of the matrix}
+ \item{tol}{a tolerance threshold for zero}
+ \item{cor.zero}{if TRUE, zero distances are not modified}
+}
+\value{
+an object of class \code{dist} containing a Euclidean distance matrix.
+}
+\references{
+Cailliez, F. (1983) The analytical solution of the additive constant problem. \emph{Psychometrika}, \bold{48}, 305--310.\cr
+
+Legendre, P. and Anderson, M.J. (1999) Distance-based redundancy analysis: testing multispecies responses in multifactorial ecological experiments. \emph{Ecological Monographs}, \bold{69}, 1--24.\cr
+
+Legendre, P., and Legendre, L. (1998) \emph{Numerical ecology}, 2nd English edition edition. Elsevier Science BV, Amsterdam.\cr
+
+From the DistPCoa program of P. Legendre et M.J. Anderson\cr
+\url{http://www.fas.umontreal.ca/BIOL/Casgrain/en/labo/distpcoa.html}
+}
+\author{
+Daniel Chessel \cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\examples{
+data(capitales)
+d0 <- capitales$dist
+is.euclid(d0) # FALSE
+d1 <- cailliez(d0, TRUE)
+# Cailliez constant = 2429.87867
+is.euclid(d1) # TRUE
+plot(d0, d1)
+abline(lm(unclass(d1)~unclass(d0)))
+print(coefficients(lm(unclass(d1)~unclass(d0))), dig = 8) # d1 = d + Cte
+is.euclid(d0 + 2428) # FALSE
+is.euclid(d0 + 2430) # TRUE the smallest constant
+}
+\keyword{array}
diff --git a/man/capitales.Rd b/man/capitales.Rd
new file mode 100644
index 0000000..ed3dc39
--- /dev/null
+++ b/man/capitales.Rd
@@ -0,0 +1,57 @@
+\name{capitales}
+\alias{capitales}
+\docType{data}
+\title{Road Distances}
+\description{
+This data set gives the road distances between 15 European capitals and their coordinates.
+}
+\usage{data(capitales)}
+\format{
+This list contains the following objects:
+ \describe{
+ \item{dist}{is dist object the road distances between 15 European capitals. }
+ \item{xy}{is a data frame containing the coordinates of capitals. }
+ \item{area}{is a data frame containing three variables, designed to be used in area.plot function.}
+ \item{logo}{is a list of pixmap objects, each one symbolizing a
+ capital}
+ \item{Spatial}{is a SpatialPolygons object containing the map}
+ }
+}
+\examples{
+data(capitales)
+attr(capitales$dist, "Labels")
+index <- pmatch(tolower(attr(capitales$dist, "Labels")), names(capitales$logo))
+w1 <- capitales$area
+
+if(adegraphicsLoaded()) {
+ if(requireNamespace("sp", quietly = TRUE)) {
+ g1 <- s.label(capitales$xy, lab = rownames(capitales$xy), porigin.include = FALSE,
+ plot = FALSE)
+ g2 <- s.logo(capitales$xy[sort(rownames(capitales$xy)), ], capitales$logo,
+ Sp = capitales$Spatial, pbackground.col = "lightblue", pSp.col = "white", pgrid.draw = FALSE,
+ plot = FALSE)
+ g3 <- table.value(capitales$dist, ptable.margin = list(b = 5, l = 5, t = 15, r = 15),
+ ptable.x.tck = 3, ptable.y.tck = 3, plot = FALSE)
+ g4 <- s.logo(pcoscaled(lingoes(capitales$dist)), capitales$logo[index], plot = FALSE)
+
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+ }
+
+} else {
+ if(requireNamespace("pixmap", quietly = TRUE)) {
+ par(mfrow = c(2, 2))
+ s.label(capitales$xy, lab = attr(capitales$dist, "Labels"), include.origin = FALSE)
+ area.plot(w1)
+ rect(min(w1$x), min(w1$y), max(w1$x), max(w1$y), col = "lightblue")
+ invisible(lapply(split(w1, w1$id), function(x) polygon(x[, -1], col = "white")))
+ s.logo(capitales$xy, capitales$logo, klogo = index, add.plot = TRUE,
+ include.origin = FALSE, clogo = 0.5) # depends on pixmap
+ table.dist(capitales$dist, lab = attr(capitales$dist, "Labels")) # depends on mva
+ s.logo(pcoscaled(lingoes(capitales$dist)), capitales$logo, klogo = index, clogo = 0.5)
+ # depends on pixmap
+ par(mfrow = c(1, 1))
+ }
+ }
+}
+
+\keyword{datasets}
diff --git a/man/carni19.Rd b/man/carni19.Rd
new file mode 100644
index 0000000..181de28
--- /dev/null
+++ b/man/carni19.Rd
@@ -0,0 +1,27 @@
+\name{carni19}
+\alias{carni19}
+\docType{data}
+\title{Phylogeny and quantative trait of carnivora}
+\description{
+This data set describes the phylogeny of carnivora as reported by Diniz-Filho et al. (1998). It also gives the body mass of these 19 species.
+}
+\usage{data(carni19)}
+\format{
+\code{carni19} is a list containing the 2 following objects :
+\describe{
+ \item{tre}{is a character string giving the phylogenetic tree in Newick format.}
+ \item{bm}{is a numeric vector which values correspond to the body mass of the 19 species (log scale).}
+}}
+\source{
+Diniz-Filho, J. A. F., de Sant'Ana, C.E.R. and Bini, L.M. (1998)
+An eigenvector method for estimating phylogenetic inertia. \emph{Evolution}, \bold{52}, 1247--1262.
+}
+\examples{
+data(carni19)
+carni19.phy <- newick2phylog(carni19$tre)
+par(mfrow = c(1,2))
+symbols.phylog(carni19.phy,carni19$bm-mean(carni19$bm))
+dotchart.phylog(carni19.phy, carni19$bm, clabel.l=0.75)
+par(mfrow = c(1,1))
+}
+\keyword{datasets}
diff --git a/man/carni70.Rd b/man/carni70.Rd
new file mode 100644
index 0000000..e239743
--- /dev/null
+++ b/man/carni70.Rd
@@ -0,0 +1,43 @@
+\name{carni70}
+\alias{carni70}
+\docType{data}
+\title{Phylogeny and quantitative traits of carnivora}
+\description{
+This data set describes the phylogeny of 70 carnivora as reported by Diniz-Filho and Torres (2002). It also gives the geographic range size and body size corresponding to these 70 species.
+}
+\usage{data(carni70)}
+\format{
+\code{carni70} is a list containing the 2 following objects:
+\describe{
+ \item{tre}{is a character string giving the phylogenetic tree in Newick format.
+ Branch lengths are expressed as divergence times (millions of years)}
+ \item{tab}{is a data frame with 70 species and two traits: size (body size (kg)) ; range (geographic range size (km)).}
+}}
+\source{
+Diniz-Filho, J. A. F., and N. M. Tôrres. (2002) Phylogenetic comparative methods and the
+geographic range size-body size relationship in new world terrestrial carnivora. \emph{Evolutionary Ecology}, \bold{16}, 351--367.
+}
+\examples{
+\dontrun{
+data(carni70)
+carni70.phy <- newick2phylog(carni70$tre)
+plot(carni70.phy)
+
+size <- scalewt(log(carni70$tab))[,1]
+names(size) <- row.names(carni70$tab)
+symbols.phylog(carni70.phy,size)
+orthogram(size, phylog = carni70.phy)
+
+yrange <- scalewt(carni70$tab[,2])
+names(yrange) <- row.names(carni70$tab)
+symbols.phylog(carni70.phy,yrange)
+orthogram(yrange, phylog = carni70.phy)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.label(cbind.data.frame(size, yrange), plabel.cex = 0)
+ g2 <- addhist(g1)
+} else {
+ s.hist(cbind.data.frame(size, yrange), clabel = 0)
+}
+}}
+\keyword{datasets}
diff --git a/man/carniherbi49.Rd b/man/carniherbi49.Rd
new file mode 100644
index 0000000..410f8e8
--- /dev/null
+++ b/man/carniherbi49.Rd
@@ -0,0 +1,40 @@
+\name{carniherbi49}
+\alias{carniherbi49}
+\docType{data}
+\title{Taxonomy, phylogenies and quantitative traits of carnivora and herbivora}
+\description{
+This data set describes the taxonomic and phylogenetic relationships of 49 carnivora and herbivora species as reported by Garland and Janis (1993) and Garland et al. (1993). It also gives seven traits corresponding to these 49 species.
+}
+\usage{data(carniherbi49)}
+\format{
+\code{carniherbi49} is a list containing the 5 following objects :
+\describe{
+ \item{taxo}{is a data frame with 49 species and 2 columns : 'fam', a factor family with 14 levels
+ and 'ord', a factor order with 3 levels.}
+ \item{tre1}{is a character string giving the phylogenetic tree in Newick format as reported by Garland et al. (1993).}
+ \item{tre2}{is a character string giving the phylogenetic tree in Newick format as reported by Garland and Janis (1993).}
+ \item{tab1}{is a data frame with 49 species and 2 traits: 'bodymass' (body mass (kg)) and 'homerange' (home range (km)).}
+ \item{tab2}{is a data frame with 49 species and 5 traits: 'clade' (dietary with two levels \code{Carnivore}
+ and \code{Herbivore}), 'runningspeed' (maximal sprint running speed (km/h)), 'bodymass' (body mass (kg)),
+ 'hindlength' (hind limb length (cm)) and 'mtfratio' (metatarsal/femur ratio).}
+}}
+\source{
+Garland, T., Dickerman, A. W., Janis, C. M. and Jones, J. A. (1993) Phylogenetic analysis of covariance by computer simulation.
+\emph{Systematics Biology}, \bold{42}, 265--292.
+
+Garland, T. J. and Janis, C.M. (1993) Does metatarsal-femur ratio predict maximal running speed in cursorial mammals?
+\emph{Journal of Zoology}, \bold{229}, 133--151.
+}
+\examples{
+\dontrun{
+data(carniherbi49)
+par(mfrow=c(1,3))
+plot(newick2phylog(carniherbi49$tre1), clabel.leaves = 0,
+ f.phylog = 2, sub ="article 1")
+plot(newick2phylog(carniherbi49$tre2), clabel.leaves = 0,
+ f.phylog = 2, sub = "article 2")
+taxo <- as.taxo(carniherbi49$taxo)
+plot(taxo2phylog(taxo), clabel.nodes = 1.2, clabel.leaves = 1.2)
+par(mfrow = c(1,1))
+}}
+\keyword{datasets}
diff --git a/man/casitas.Rd b/man/casitas.Rd
new file mode 100644
index 0000000..5e5fdd2
--- /dev/null
+++ b/man/casitas.Rd
@@ -0,0 +1,37 @@
+\name{casitas}
+\docType{data}
+\alias{casitas}
+\title{Enzymatic polymorphism in Mus musculus}
+\description{
+ This data set is a data frame with 74 rows (mice) and 15 columns (loci enzymatic polymorphism of the DNA mitochondrial).
+ Each value contains 6 characters coding for two allelles. The missing values are coding by '000000'.
+}
+\usage{data(casitas)}
+\format{
+The 74 individuals of \code{casitas} belong to 4 groups:
+ \describe{
+ \item{1}{24 mice of the sub-species \emph{Mus musculus domesticus}}
+ \item{2}{11 mice of the sub-species \emph{Mus musculus castaneus}}
+ \item{3}{9 mice of the sub-species \emph{Mus musculus musculus}}
+ \item{4}{30 mice from a population of the lake Casitas (California)}
+ }
+}
+\source{
+Exemple du logiciel GENETIX.
+Belkhir k. et al. GENETIX, logiciel sous WindowsTM pour la génétique des populations.
+Laboratoire Génome, Populations, Interactions CNRS UMR 5000, Université de Montpellier II, Montpellier (France). \cr
+\url{http://kimura.univ-montp2.fr/genetix/}
+}
+\references{
+Orth, A., T. Adama, W. Din and F. Bonhomme. (1998) Hybridation naturelle entre deux sous espèces de souris domestique
+\emph{Mus musculus domesticus} et \emph{Mus musculus castaneus} près de Lake Casitas (Californie). \emph{Genome}, \bold{41}, 104--110.
+}
+\examples{
+data(casitas)
+casitas.pop <- as.factor(rep(c("dome", "cast", "musc", "casi"),
+ c(24,11,9,30)))
+table(casitas.pop,casitas[,1])
+casi.genet <- char2genet(casitas, casitas.pop)
+names(casi.genet)
+}
+\keyword{datasets}
diff --git a/man/chatcat.Rd b/man/chatcat.Rd
new file mode 100644
index 0000000..7c357d6
--- /dev/null
+++ b/man/chatcat.Rd
@@ -0,0 +1,35 @@
+\name{chatcat}
+\alias{chatcat}
+\docType{data}
+\title{Qualitative Weighted Variables}
+\description{
+ This data set gives the age, the fecundity and the number of litters for 26 groups of cats.
+}
+\usage{data(chatcat)}
+\format{
+\code{chatcat} is a list of two objects :
+ \describe{
+ \item{tab}{is a data frame with 3 factors (age, feco, nport). }
+ \item{eff}{is a vector of numbers. }
+ }
+}
+\details{
+One row of \code{tab} corresponds to one group of cats.\cr
+The value in \code{eff} is the number of cats in this group.
+}
+\source{
+Pontier, D. (1984)
+\emph{Contribution à la biologie et à la génétique des populations de chats domestiques (Felis catus).}
+Thèse de 3ème cycle. Université Lyon 1, p. 67.
+}
+\examples{
+data(chatcat)
+summary(chatcat$tab)
+w <- acm.disjonctif(chatcat$tab) # Disjonctive table
+names(w) <- c(paste("A", 1:5, sep = ""), paste("B", 1:5, sep = ""),
+ paste("C", 1:2, sep = ""))
+w <- t(w*chatcat$num)%*%as.matrix(w)
+w <- data.frame(w)
+w # BURT table
+}
+\keyword{datasets}
diff --git a/man/chats.Rd b/man/chats.Rd
new file mode 100644
index 0000000..3748444
--- /dev/null
+++ b/man/chats.Rd
@@ -0,0 +1,46 @@
+\name{chats}
+\alias{chats}
+\docType{data}
+\title{Pair of Variables}
+\description{
+This data set is a contingency table of age classes and fecundity classes of cats \emph{Felis catus}.
+}
+\usage{data(chats)}
+\format{
+ \code{chats} is a data frame with 8 rows and 8 columns.\cr
+ The 8 rows are age classes (age1, \dots, age8).\cr
+ The 8 columns are fecundity classes (f0, f12, f34, \dots, fcd).\cr
+ The values are cats numbers (contingency table).
+}
+\source{
+Legay, J.M. and Pontier, D. (1985)
+Relation âge-fécondité dans les populations de Chats domestiques, Felis catus.
+\emph{Mammalia}, \bold{49}, 395--402.
+}
+\examples{
+data(chats)
+chatsw <- as.table(t(chats))
+chatscoa <- dudi.coa(data.frame(t(chats)), scann = FALSE)
+
+if(adegraphicsLoaded()) {
+ g1 <- table.value(chatsw, ppoints.cex = 1.3, meanX = TRUE, ablineX = TRUE, plabel.cex = 1.5,
+ plot = FALSE)
+ g2 <- table.value(chatsw, ppoints.cex = 1.3, meanY = TRUE, ablineY = TRUE, plabel.cex = 1.5,
+ plot = FALSE)
+ g3 <- table.value(chatsw, ppoints.cex = 1.3, coordsx = chatscoa$c1[,
+ 1], coordsy = chatscoa$l1[, 1], meanX = TRUE, ablineX = TRUE, plot = FALSE)
+ g4 <- table.value(chatsw, ppoints.cex = 1.3, meanY = TRUE, ablineY = TRUE,
+ coordsx = chatscoa$c1[, 1], coordsy = chatscoa$l1[, 1], plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2, 2))
+ table.cont(chatsw, abmean.x = TRUE, csi = 2, abline.x = TRUE, clabel.r = 1.5, clabel.c = 1.5)
+ table.cont(chatsw, abmean.y = TRUE, csi = 2, abline.y = TRUE, clabel.r = 1.5, clabel.c = 1.5)
+ table.cont(chatsw, x = chatscoa$c1[, 1], y = chatscoa$l1[, 1], abmean.x = TRUE, csi = 2,
+ abline.x = TRUE, clabel.r = 1.5, clabel.c = 1.5)
+ table.cont(chatsw, x = chatscoa$c1[, 1], y = chatscoa$l1[, 1], abmean.y = TRUE, csi = 2,
+ abline.y = TRUE, clabel.r = 1.5, clabel.c = 1.5)
+ par(mfrow = c(1, 1))
+}}
+\keyword{datasets}
diff --git a/man/chazeb.Rd b/man/chazeb.Rd
new file mode 100644
index 0000000..757bf6d
--- /dev/null
+++ b/man/chazeb.Rd
@@ -0,0 +1,26 @@
+\name{chazeb}
+\alias{chazeb}
+\docType{data}
+\title{Charolais-Zebus}
+\description{
+This data set gives six different weights of 23 charolais and zebu oxen.
+}
+\usage{data(chazeb)}
+\format{
+ \code{chazeb} is a list of 2 components.
+ \describe{
+ \item{tab}{is a data frame with 23 rows and 6 columns.}
+ \item{cla}{is a factor with two levels "cha" and "zeb". }
+ }
+}
+\source{
+Tomassone, R., Danzard, M., Daudin, J. J. and Masson J. P. (1988)
+\emph{Discrimination et classement}, Masson, Paris. p. 43
+}
+\examples{
+data(chazeb)
+if(!adegraphicsLoaded())
+ plot(discrimin(dudi.pca(chazeb$tab, scan = FALSE),
+ chazeb$cla, scan = FALSE))
+}
+\keyword{datasets}
diff --git a/man/chevaine.Rd b/man/chevaine.Rd
new file mode 100644
index 0000000..a9a01bd
--- /dev/null
+++ b/man/chevaine.Rd
@@ -0,0 +1,61 @@
+\name{chevaine}
+\docType{data}
+\alias{chevaine}
+\title{Enzymatic polymorphism in Leuciscus cephalus}
+\description{
+ This data set contains a list of three components: spatial map, allellic profiles and sample sizes.
+}
+\usage{data(chevaine)}
+\format{
+This data set is a list of three components:
+ \describe{
+ \item{tab}{ a data frame with 27 populations and 9 allelic frequencies (4 locus)}
+ \item{coo}{ a list containing all the elements to build a spatial map}
+ \item{eff}{ a numeric containing the numbers of fish samples per station}
+ }
+}
+\references{
+Guinand B., Bouvet Y. and Brohon B. (1996) Spatial aspects of genetic differentiation of the European
+chub in the Rhone River basin. \emph{Journal of Fish Biology}, \bold{49}, 714--726.
+
+See a data description at \url{http://pbil.univ-lyon1.fr/R/pdf/pps054.pdf} (in French).
+}
+\examples{
+data(chevaine)
+'fun.chevaine' <- function(label = TRUE) {
+ opar <- par(mar = par("mar"))
+ on.exit(par(opar))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ s.label(chevaine$coo$poi, xlim = c(-20, 400), clab = 0, cpoi = 0)
+ invisible(lapply(chevaine$coo$lac, polygon, col = "blue", lwd = 2))
+ invisible(lapply(chevaine$coo$riv, points, col = "blue", type = "l", lwd = 2))
+ if(label) {
+ s.label(chevaine$coo$poi, clab = 0.75, add.p = TRUE)
+ s.label(chevaine$coo$sta, add.p = TRUE, clab = 0.5)
+ }
+ arrows(200, 100, 300, 100, code = 3, angle = 15, length = 0.2)
+ text(250, 125, "50 Km")
+}
+
+if(!adegraphicsLoaded()) {
+ fun.chevaine()
+
+ che.genet <- freq2genet(chevaine$tab)
+ che.pca <- dudi.pca(che.genet$tab, center = che.genet$center, scannf = FALSE, nf = 3)
+
+ par(mfrow = c(1, 2))
+ fun.chevaine(FALSE)
+ s.value(chevaine$coo$sta, che.pca$li[, 1], csi = 2, add.p = TRUE)
+ fun.chevaine(FALSE)
+ s.value(chevaine$coo$sta, che.pca$li[, 2], csi = 2, add.p = TRUE)
+
+ w <- prep.fuzzy.var (che.genet$tab, che.genet$loc.blocks)
+ che.fca <- dudi.fca(w, scannf = FALSE, nf = 3)
+
+ fun.chevaine(FALSE)
+ s.value(chevaine$coo$sta, che.fca$li[, 1], csi = 1.5, add.p = TRUE)
+ fun.chevaine(FALSE)
+ s.value(chevaine$coo$sta, che.fca$li[, 2], csi = 1.5, add.p = TRUE)
+}
+}
+\keyword{datasets}
diff --git a/man/chickenk.Rd b/man/chickenk.Rd
new file mode 100644
index 0000000..95662f7
--- /dev/null
+++ b/man/chickenk.Rd
@@ -0,0 +1,26 @@
+\name{chickenk}
+\alias{chickenk}
+\docType{data}
+\title{Veterinary epidemiological study to assess the risk factors for losses in broiler chickens}
+\description{This data set contains information about potential risk factors for losses in broiler chickens}
+\usage{data(chickenk)}
+\format{
+ A list with 5 components:
+ \describe{
+\item{mortality}{a data frame with 351 observations and 4 variables which describe the losses (dependent dataset Y)}
+\item{FarmStructure}{a data frame with 351 observations and 5 variables which describe the farm structure (explanatory dataset)}
+\item{OnFarmHistory}{a data frame with 351 observations and 4 variables which describe the flock characteristics at placement (explanatory dataset)}
+\item{FlockCharacteristics}{a data frame with 351 observations and 6 variables which describe the flock characteristics during the rearing period (explanatory dataset)}
+\item{CatchingTranspSlaught}{a data frame with 351 observations and 5 variables which describe the transport, lairage conditions, slaughterhouse and inspection features (explanatory dataset)}
+}
+}
+
+\source{
+Lupo C., le Bouquin S., Balaine L., Michel V., Peraste J., Petetin I., Colin P. \& Chauvin C. (2009) Feasibility of screening broiler chicken flocks for risk markers as an aid for meat inspection. \emph{Epidemiology and Infection}, 137, 1086-1098
+}
+
+\examples{
+data(chickenk)
+kta1 <- ktab.list.df(chickenk)
+}
+\keyword{datasets}
diff --git a/man/clementines.Rd b/man/clementines.Rd
new file mode 100644
index 0000000..c461a50
--- /dev/null
+++ b/man/clementines.Rd
@@ -0,0 +1,56 @@
+\name{clementines}
+\alias{clementines}
+\docType{data}
+\title{Fruit Production}
+\description{
+The \code{clementines} is a data set containing the fruit production of 20 clementine trees during 15 years.
+}
+\usage{data(clementines)}
+\format{
+A data frame with 15 rows and 20 columns
+}
+\source{
+Tisné-Agostini, D. (1988) \emph{Description par analyse en composantes principales de l'évolution de
+la production du clémentinier en association avec 12 types de porte-greffe}.
+Rapport technique, DEA Analyse et modélisation des systèmes biologiques, Université Lyon 1.
+}
+\examples{
+data(clementines)
+
+op <- par(no.readonly = TRUE)
+par(mfrow = c(5, 4))
+par(mar = c(2, 2, 1, 1))
+for(i in 1:20) {
+ w0 <- 1:15
+ plot(w0, clementines[, i], type = "b")
+ abline(lm(clementines[, i] ~ w0))
+}
+par(op)
+
+pca1 <- dudi.pca(clementines, scan = FALSE)
+if(adegraphicsLoaded()) {
+ g1 <- s.corcircle(pca1$co, plab.cex = 0.75)
+ g2 <- s1d.barchart(pca1$li[, 1], p1d.hori = FALSE)
+} else {
+ s.corcircle(pca1$co, clab = 0.75)
+ barplot(pca1$li[, 1])
+}
+
+op <- par(no.readonly = TRUE)
+par(mfrow = c(5, 4))
+par(mar = c(2, 2, 1, 1))
+clem0 <- pca1$tab
+croi <- 1:15
+alter <- c(rep(c(1, -1), 7), 1)
+for(i in 1:20) {
+ y <- clem0[,i]
+ plot(w0, y, type = "b", ylim = c(-2, 2))
+ z <- predict(lm(clem0[, i] ~ croi * alter))
+ points(w0, z, pch = 20, cex = 2)
+ for(j in 1:15)
+ segments(j, y[j], j, z[j])
+}
+par(op)
+par(mfrow = c(1, 1))
+}
+\keyword{datasets}
diff --git a/man/cnc2003.Rd b/man/cnc2003.Rd
new file mode 100644
index 0000000..a5102ce
--- /dev/null
+++ b/man/cnc2003.Rd
@@ -0,0 +1,35 @@
+\name{cnc2003}
+\alias{cnc2003}
+\docType{data}
+\title{Frequenting movie theaters in France in 2003}
+\description{
+ \code{cnc2003} is a data frame with 94 rows (94 departments from continental Metropolitan France)and 12 variables.
+}
+\usage{data(cnc2003)}
+\format{
+ This data frame contains the following variables:
+ \describe{
+ \item{popu}{is the population department in million inhabitants. }
+ \item{entr}{is the number of movie theater visitors in million. }
+ \item{rece}{is the takings from ticket offices. }
+ \item{sean}{is the number of proposed shows in thousands. }
+ \item{comm}{is the number of equipped communes in movie theaters (units). }
+ \item{etab}{is the number of active movie theaters (units). }
+ \item{salle}{is the number of active screens. }
+ \item{faut}{is the number of proposed seats. }
+ \item{artes}{is the number of movie theaters offering "Art and Essay" movies. }
+ \item{multi}{is the number of active multiplexes. }
+ \item{depart}{is the name of the department. }
+ \item{reg}{is the administrative region of the department. }
+ }
+}
+\source{
+National Center of Cinematography (CNC), september 2003\cr
+}
+\seealso{
+This dataset is compatible with \code{elec88} and \code{presid2002}}
+\examples{
+data(cnc2003)
+sco.quant(cnc2003$popu, cnc2003[,2:10], abline = TRUE, csub = 3)
+}
+\keyword{datasets}
diff --git a/man/coinertia.Rd b/man/coinertia.Rd
new file mode 100644
index 0000000..56d2b3a
--- /dev/null
+++ b/man/coinertia.Rd
@@ -0,0 +1,86 @@
+\name{coinertia}
+\alias{coinertia}
+\alias{print.coinertia}
+\alias{plot.coinertia}
+\alias{summary.coinertia}
+\title{Coinertia Analysis}
+\description{
+The coinertia analysis performs a double inertia analysis of two tables.
+}
+\usage{
+coinertia(dudiX, dudiY, scannf = TRUE, nf = 2)
+\method{plot}{coinertia} (x, xax = 1, yax = 2, \dots)
+\method{print}{coinertia} (x, \dots)
+\method{summary}{coinertia} (object, \dots)
+}
+\arguments{
+ \item{dudiX}{a duality diagram providing from one of the functions dudi.coa, dudi.pca, \dots}
+ \item{dudiY}{a duality diagram providing from one of the functions dudi.coa, dudi.pca, \dots}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+ \cr
+ \item{x, object}{an object of class 'coinertia'}
+ \item{xax, yax}{the numbers of the x-axis and the y-axis}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+Returns a list of class 'coinertia', sub-class 'dudi' containing:
+ \item{call}{call}
+ \item{rank}{rank}
+ \item{nf}{a numeric value indicating the number of kept axes}
+ \item{RV}{a numeric value, the RV coefficient}
+ \item{eig}{a numeric vector with all the eigenvalues}
+ \item{lw}{a numeric vector with the rows weigths (crossed table)}
+ \item{cw}{a numeric vector with the columns weigths (crossed table)}
+ \item{tab}{a crossed table (CT)}
+ \item{li}{CT row scores (cols of dudiY)}
+ \item{l1}{Principal components (loadings for cols of dudiY)}
+ \item{co}{CT col scores (cols of dudiX)}
+ \item{c1}{Principal axes (cols of dudiX)}
+ \item{lX}{Row scores (rows of dudiX)}
+ \item{mX}{Normed row scores (rows of dudiX)}
+ \item{lY}{Row scores (rows of dudiY)}
+ \item{mY}{Normed row scores (rows of dudiY)}
+ \item{aX}{Correlations between dudiX axes and coinertia axes}
+ \item{aY}{Correlations between dudiY axes and coinertia axes}
+}
+\references{
+Dolédec, S. and Chessel, D. (1994) Co-inertia analysis: an alternative method for studying species-environment relationships.
+\emph{Freshwater Biology}, \bold{31}, 277--294.\cr
+
+Dray, S., Chessel, D. and J. Thioulouse (2003) Co-inertia analysis and the linking of the ecological data tables.
+\emph{Ecology}, \bold{84}, 11, 3078--3089.
+}
+\section{WARNING}{
+IMPORTANT : \code{dudi1} and \code{dudi2} must have identical row weights.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(doubs)
+dudi1 <- dudi.pca(doubs$env, scale = TRUE, scan = FALSE, nf = 3)
+dudi2 <- dudi.pca(doubs$fish, scale = FALSE, scan = FALSE, nf = 2)
+coin1 <- coinertia(dudi1,dudi2, scan = FALSE, nf = 2)
+coin1
+summary(coin1)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.arrow(coin1$l1, plab.cex = 0.7)
+ g2 <- s.arrow(coin1$c1, plab.cex = 0.7)
+ g3 <- s.corcircle(coin1$aX, plot = FALSE)
+ g4 <- s.corcircle(coin1$aY, plot = FALSE)
+ cbindADEg(g3, g4, plot = TRUE)
+ g5 <- plot(coin1)
+
+} else {
+s.arrow(coin1$l1, clab = 0.7)
+s.arrow(coin1$c1, clab = 0.7)
+par(mfrow = c(1,2))
+s.corcircle(coin1$aX)
+s.corcircle(coin1$aY)
+par(mfrow = c(1,1))
+plot(coin1)
+}}
+\keyword{multivariate}
diff --git a/man/coleo.Rd b/man/coleo.Rd
new file mode 100644
index 0000000..950d37c
--- /dev/null
+++ b/man/coleo.Rd
@@ -0,0 +1,49 @@
+\name{coleo}
+\alias{coleo}
+\docType{data}
+\title{Table of Fuzzy Biological Traits }
+\description{
+This data set coleo (coleoptera) is a a fuzzy biological traits table.
+}
+\usage{data(coleo)}
+\format{
+\code{coleo} is a list of 5 components.
+\describe{
+ \item{tab}{is a data frame with 110 rows (species) and 32 columns (categories).}
+ \item{species.names}{is a vector of species names.}
+ \item{moda.names}{is a vector of fuzzy variables names.}
+ \item{families}{is a factor species family.}
+ \item{col.blocks}{is a vector containing the number of categories of each trait.}
+ }
+}
+\source{
+Bournaud, M., Richoux, P. and Usseglio-Polatera, P. (1992)
+An approach to the synthesis of qualitative ecological information from aquatic coleoptera communities.
+\emph{Regulated rivers: Research and Management}, \bold{7}, 165--180.
+}
+\examples{
+data(coleo)
+op <- par(no.readonly = TRUE)
+coleo.fuzzy <- prep.fuzzy.var(coleo$tab, coleo$col.blocks)
+fca1 <- dudi.fca(coleo.fuzzy, sca = FALSE, nf = 3)
+indica <- factor(rep(names(coleo$col), coleo$col))
+
+if(adegraphicsLoaded()) {
+ glist <- list()
+ for(i in levels(indica)) {
+ df <- coleo$tab[, which(indica == i)]
+ names(df) <- coleo$moda.names[which(indica == i)]
+ glist[i] <- s.distri(fca1$l1, df, psub.text = as.character(i), ellipseSize = 0,
+ starSize = 0.5, plot = FALSE, storeData = TRUE)
+ }
+ G <- ADEgS(glist, layout = c(3, 3))
+
+} else {
+ par(mfrow = c(3, 3))
+ for(j in levels(indica))
+ s.distri(fca1$l1, coleo$tab[, which(indica == j)], clab = 1.5, sub = as.character(j),
+ cell = 0, csta = 0.5, csub = 3, label = coleo$moda.names[which(indica == j)])
+ par(op)
+ par(mfrow = c(1, 1))
+}}
+\keyword{datasets}
diff --git a/man/combine.4thcorner.Rd b/man/combine.4thcorner.Rd
new file mode 100644
index 0000000..cdf670f
--- /dev/null
+++ b/man/combine.4thcorner.Rd
@@ -0,0 +1,77 @@
+\name{combine.4thcorner}
+\alias{combine.randtest.rlq}
+\alias{combine.4thcorner}
+\alias{p.adjust.4thcorner}
+
+\title{Functions to combine and adjust the outputs 3-table methods}
+\description{Functions to combine and adjust the outputs of the \code{fourthcorner} and
+ \code{randtest.rlq} functions created using permutational models 2 and
+ 4 (sequential approach).
+}
+\usage{
+combine.randtest.rlq(obj1, obj2, ...)
+combine.4thcorner(four1,four2)
+p.adjust.4thcorner(x, p.adjust.method.G = p.adjust.methods,
+p.adjust.method.D = p.adjust.methods, p.adjust.D = c("global",
+"levels"))
+}
+
+\arguments{
+ \item{four1}{ an object of the class 4thcorner created with
+ modeltype = 2 (or 4)}
+ \item{four2}{ an object of the class 4thcorner created with
+ modeltype = 4 (or 2)}
+ \item{obj1}{an object created with \code{randtest.rlq} and
+ modeltype = 2 (or 4)}
+ \item{obj2}{an object created with \code{randtest.rlq} and
+ modeltype = 4 (or 2)}
+ \item{x}{ an object of the class 4thcorner}
+ \item{p.adjust.method.G}{a string indicating a method for multiple
+ adjustment used for output tabG, see \code{\link[stats]{p.adjust.methods}} for possible choices}
+ \item{p.adjust.method.D}{a string indicating a method for multiple
+ adjustment used for output tabD/tabD2, see \code{p.adjust.methods} for possible choices}
+ \item{p.adjust.D}{a string indicating if multiple adjustment for
+ tabD/tabD2 should be done globally or only between levels of a factor
+ ("levels", as in the original paper of Legendre et al. 1997)}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\details{
+
+ The functions combines the outputs of two objects (created by
+ \code{fourthcorner} and \code{randtest.rlq} functions) as described in
+ Dray and Legendre (2008) and ter Braak et al (2012).
+}
+\value{
+ The functions return objects of the same class than their
+ argument. They simply create a new object where pvalues are equal to the
+ maximum of pvalues of the two arguments.
+}
+\references{
+ Dray, S. and Legendre, P. (2008)
+ Testing the species traits-environment relationships: the fourth-corner
+ problem revisited. \emph{Ecology},
+ \bold{89}, 3400--3412.
+
+ ter Braak, C., Cormont, A., and Dray, S. (2012)
+ Improved testing of species traits-environment relationships in the
+ fourth corner problem. \emph{Ecology}, \bold{93}, 1525--1526.
+}
+\author{Stéphane Dray \email{stephane.dray at univ-lyon1.fr}}
+
+\seealso{
+\code{\link{rlq}}, \code{\link{fourthcorner}}, \code{\link[stats]{p.adjust.methods}}
+}
+\examples{
+data(aravo)
+four2 <- fourthcorner(aravo$env, aravo$spe, aravo$traits, nrepet=99,modeltype=2)
+four4 <- fourthcorner(aravo$env, aravo$spe, aravo$traits, nrepet=99,modeltype=4)
+four.comb <- combine.4thcorner(four2,four4)
+## or directly :
+## four.comb <- fourthcorner(aravo$env, aravo$spe, aravo$traits, nrepet=99,modeltype=6)
+summary(four.comb)
+plot(four.comb, stat = "G")
+
+}
+
+
+\keyword{ multivariate }
diff --git a/man/corkdist.Rd b/man/corkdist.Rd
new file mode 100644
index 0000000..1cd3524
--- /dev/null
+++ b/man/corkdist.Rd
@@ -0,0 +1,59 @@
+\name{corkdist}
+\alias{corkdist}
+\alias{mantelkdist}
+\alias{RVkdist}
+\alias{print.corkdist}
+\alias{summary.corkdist}
+\alias{plot.corkdist}
+\title{Tests of randomization between distances applied to 'kdist' objetcs}
+\description{
+The mantelkdist and RVkdist functions apply to blocks of distance matrices the mantel.rtest and RV.rtest functions.
+}
+\usage{
+mantelkdist (kd, nrepet = 999, ...)
+RVkdist (kd, nrepet = 999, ...)
+\method{plot}{corkdist}(x, whichinrow = NULL, whichincol = NULL,
+ gap = 4, nclass = 10,\dots)
+}
+\arguments{
+ \item{kd}{a list of class \code{kdist}}
+ \item{nrepet}{the number of permutations}
+ \item{x}{an objet of class \code{corkdist}, coming from RVkdist or mantelkdist}
+ \item{whichinrow}{a vector of integers to select the graphs in rows (if NULL all the graphs are computed)}
+ \item{whichincol}{a vector of integers to select the graphs in columns (if NULL all the graphs are computed)}
+ \item{gap}{an integer to determinate the space between two graphs}
+ \item{nclass}{a number of intervals for the histogram}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+a list of class \code{corkdist} containing for each pair of distances an object of class \code{randtest} (permutation tests).
+}
+\details{
+The \code{corkdist} class has some generic functions \code{print}, \code{plot} and \code{summary}. The plot shows bivariate scatterplots between semi-matrices of distances or histograms of simulated values with an error position.
+}
+\author{
+Daniel Chessel \cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\examples{
+data(friday87)
+fri.w <- ktab.data.frame(friday87$fau, friday87$fau.blo, tabnames = friday87$tab.names)
+fri.kc <- lapply(1:10, function(x) dist.binary(fri.w[[x]], 10))
+names(fri.kc) <- substr(friday87$tab.names, 1, 4)
+fri.kd <- kdist(fri.kc)
+fri.mantel <- mantelkdist(kd = fri.kd, nrepet = 999)
+
+plot(fri.mantel, 1:5, 1:5)
+plot(fri.mantel, 1:5, 6:10)
+plot(fri.mantel, 6:10, 1:5)
+plot(fri.mantel, 6:10, 6:10)
+s.corcircle(dudi.pca(as.data.frame(fri.kd), scan = FALSE)$co)
+plot(RVkdist(fri.kd), 1:5, 1:5)
+
+data(yanomama)
+m1 <- mantelkdist(kdist(yanomama), 999)
+m1
+summary(m1)
+plot(m1)
+}
+\keyword{nonparametric}
diff --git a/man/corvus.Rd b/man/corvus.Rd
new file mode 100644
index 0000000..5cdafd2
--- /dev/null
+++ b/man/corvus.Rd
@@ -0,0 +1,38 @@
+\name{corvus}
+\alias{corvus}
+\docType{data}
+\title{Corvus morphology}
+\description{
+This data set gives a morphological description of 28 species of the genus Corvus split in two habitat types and phylogeographic stocks.
+}
+\usage{data(corvus)}
+\format{
+\code{corvus} is data frame with 28 observations (the species) and 4 variables :
+\describe{
+ \item{wing}{: wing length (mm)}
+ \item{bill}{: bill length (mm)}
+ \item{habitat}{: habitat with two levels \code{clos} and \code{open}}
+ \item{phylog}{: phylogeographic stock with three levels \code{amer}(America), \code{orien}(Oriental-Australian),
+ \code{pale}(Paleoarctic-African)}
+ }
+}
+\references{
+Laiolo, P. and Rolando, A. (2003) The evolution of vocalisations in the genus Corvus: effects of phylogeny, morphology and habitat.
+\emph{Evolutionary Ecology}, \bold{17}, 111--123.
+}
+\examples{
+data(corvus)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.label(corvus[, 1:2], plab.cex = 0, porigin.include = FALSE, pgrid.draw = FALSE,
+ paxes.draw = TRUE, paxes.asp = "full", xlab = names(corvus)[2],
+ ylab = names(corvus)[2], plot = FALSE)
+ g2 <- s.class(corvus[, 1:2], corvus[, 4]:corvus[, 3], plot = FALSE)
+ G <- superpose(g1, g2, plot = TRUE)
+
+} else {
+ plot(corvus[, 1:2])
+ s.class(corvus[, 1:2], corvus[, 4]:corvus[, 3], add.p = TRUE)
+}
+}
+\keyword{datasets}
diff --git a/man/costatis.Rd b/man/costatis.Rd
new file mode 100644
index 0000000..34b974b
--- /dev/null
+++ b/man/costatis.Rd
@@ -0,0 +1,41 @@
+\name{costatis}
+\alias{costatis}
+\title{STATIS and Co-Inertia : Analysis of a series of paired ecological tables}
+\description{
+Analysis of a series of pairs of ecological tables. This function uses
+Partial Triadic Analysis (\link{pta}) and \link{coinertia}
+to do the computations.
+}
+\usage{
+costatis(KTX, KTY, scannf = TRUE)
+}
+\arguments{
+ \item{KTX}{an objet of class ktab}
+ \item{KTY}{an objet of class ktab}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+}
+\details{
+This function takes 2 ktabs. It does a PTA (partial triadic analysis: \link{pta}) on each ktab, and does a coinertia analysis (\link{coinertia}) on the compromises of the two PTAs.
+}
+\value{
+a list of class coinertia, subclass dudi. See \link{coinertia}
+}
+\references{
+Thioulouse J. (2011). Simultaneous analysis of a sequence of paired ecological tables: a comparison of several methods. \emph{Annals of Applied Statistics}, \bold{5}, 2300-2325.
+}
+\author{Jean Thioulouse \email{Jean.Thioulouse at univ-lyon1.fr}}
+\section{WARNING }{
+IMPORTANT : KTX and KTY must have the same k-tables structure, the same number
+of columns, and the same column weights.
+}
+\examples{
+data(meau)
+wit1 <- withinpca(meau$env, meau$design$season, scan = FALSE, scal = "total")
+pcaspe <- dudi.pca(meau$spe, scale = FALSE, scan = FALSE, nf = 2)
+wit2 <- wca(pcaspe, meau$design$season, scan = FALSE, nf = 2)
+kta1 <- ktab.within(wit1, colnames = rep(c("S1","S2","S3","S4","S5","S6"), 4))
+kta2 <- ktab.within(wit2, colnames = rep(c("S1","S2","S3","S4","S5","S6"), 4))
+costatis1 <- costatis(kta1, kta2, scan = FALSE)
+plot(costatis1)
+}
+\keyword{multivariate}
diff --git a/man/costatis.randtest.Rd b/man/costatis.randtest.Rd
new file mode 100644
index 0000000..69d75aa
--- /dev/null
+++ b/man/costatis.randtest.Rd
@@ -0,0 +1,34 @@
+\name{costatis.randtest}
+\alias{costatis.randtest}
+\title{Monte-Carlo test on a Costatis analysis (in C).}
+\description{
+Performs a Monte-Carlo test on a Costatis analysis.
+}
+\usage{
+costatis.randtest(KTX, KTY, nrepet = 999, ...)
+}
+\arguments{
+ \item{KTX}{an objet of class ktab}
+ \item{KTY}{an objet of class ktab}
+ \item{nrepet}{the number of permutations}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+a list of the class \code{randtest}
+}
+\references{
+Thioulouse J. (2011). Simultaneous analysis of a sequence of paired ecological tables: a comparison of several methods. \emph{Annals of Applied Statistics}, \bold{5}, 2300-2325.
+}
+\author{Jean Thioulouse \email{Jean.Thioulouse at univ-lyon1.fr}}
+\examples{
+data(meau)
+wit1 <- withinpca(meau$env, meau$design$season, scan = FALSE, scal = "total")
+pcaspe <- dudi.pca(meau$spe, scale = FALSE, scan = FALSE, nf = 2)
+wit2 <- wca(pcaspe, meau$design$season, scan = FALSE, nf = 2)
+kta1 <- ktab.within(wit1, colnames = rep(c("S1","S2","S3","S4","S5","S6"), 4))
+kta2 <- ktab.within(wit2, colnames = rep(c("S1","S2","S3","S4","S5","S6"), 4))
+costatis1 <- costatis(kta1, kta2, scan = FALSE)
+costatis.randtest(kta1, kta2)
+}
+\keyword{multivariate}
+\keyword{nonparametric}
diff --git a/man/deug.Rd b/man/deug.Rd
new file mode 100644
index 0000000..121e05c
--- /dev/null
+++ b/man/deug.Rd
@@ -0,0 +1,36 @@
+\name{deug}
+\alias{deug}
+\docType{data}
+\title{Exam marks for some students}
+\description{
+This data set gives the exam results of 104 students in the second year of a French University onto 9 subjects.
+}
+\usage{data(deug)}
+\format{
+ \code{deug} is a list of three components.
+ \describe{
+ \item{tab}{is a data frame with 104 students and 9 subjects : Algebra, Analysis, Proba, Informatic, Economy,
+ Option1, Option2, English, Sport.}
+ \item{result}{is a factor of 104 components giving the final exam levels (A+, A, B, B-, C-, D).}
+ \item{cent}{is a vector of required marks by subject to get exactly 10/20 with a coefficient.}
+ }
+}
+\source{
+University of Lyon 1
+}
+\examples{
+data(deug)
+# decentred PCA
+pca1 <- dudi.pca(deug$tab, scal = FALSE, center = deug$cent, scan = FALSE)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.class(pca1$li, deug$result, plot = FALSE)
+ g2 <- s.arrow(40 * pca1$c1, plot = FALSE)
+ G <- superpose(g1, g2, plot = TRUE)
+
+} else {
+ s.class(pca1$li, deug$result)
+ s.arrow(40 * pca1$c1, add.plot = TRUE)
+}
+}
+\keyword{datasets}
diff --git a/man/disc.Rd b/man/disc.Rd
new file mode 100644
index 0000000..c4b140c
--- /dev/null
+++ b/man/disc.Rd
@@ -0,0 +1,42 @@
+\name{disc}
+\alias{disc}
+\title{Rao's dissimilarity coefficient}
+\description{
+Calculates the root square of Rao's dissimilarity coefficient between samples.
+}
+\usage{
+disc(samples, dis = NULL, structures = NULL)
+}
+\arguments{
+ \item{samples}{a data frame with elements as rows, samples as columns,
+ and abundance, presence-absence or frequencies as entries}
+ \item{dis}{an object of class \code{dist} containing distances or dissimilarities among elements.
+ If \code{dis} is NULL, equidistances are used.}
+ \item{structures}{a data frame containing, in the jth row and the kth column,
+ the name of the group of level k to which the jth population belongs.}
+}
+\value{
+Returns a list of objects of class \code{dist}
+}
+\references{
+Rao, C.R. (1982) Diversity and dissimilarity coefficients: a unified approach.
+\emph{Theoretical Population Biology}, \bold{21}, 24--43.
+}
+\author{Sandrine Pavoine \email{pavoine at mnhn.fr}
+}
+\examples{
+data(humDNAm)
+humDNA.dist <- disc(humDNAm$samples, sqrt(humDNAm$distances), humDNAm$structures)
+humDNA.dist
+is.euclid(humDNA.dist$samples)
+is.euclid(humDNA.dist$regions)
+
+\dontrun{
+data(ecomor)
+dtaxo <- dist.taxo(ecomor$taxo)
+ecomor.dist <- disc(ecomor$habitat, dtaxo)
+ecomor.dist
+is.euclid(ecomor.dist)
+}
+}
+\keyword{multivariate}
diff --git a/man/discrimin.Rd b/man/discrimin.Rd
new file mode 100644
index 0000000..9b7716d
--- /dev/null
+++ b/man/discrimin.Rd
@@ -0,0 +1,54 @@
+\name{discrimin}
+\alias{discrimin}
+\alias{plot.discrimin}
+\alias{print.discrimin}
+\title{Linear Discriminant Analysis (descriptive statistic)}
+\description{
+performs a linear discriminant analysis.
+}
+\usage{
+discrimin(dudi, fac, scannf = TRUE, nf = 2)
+\method{plot}{discrimin}(x, xax = 1, yax = 2, \dots)
+\method{print}{discrimin}(x, \dots)
+}
+\arguments{
+ \item{dudi}{a duality diagram, object of class \code{dudi}}
+ \item{fac}{a factor defining the classes of discriminant analysis}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+ \cr
+
+ \item{x}{an object of class 'discrimin'}
+ \item{xax}{the column number of the x-axis}
+ \item{yax}{the column number of the y-axis}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+returns a list of class 'discrimin' containing :
+ \item{nf}{a numeric value indicating the number of kept axes}
+ \item{eig}{a numeric vector with all the eigenvalues}
+ \item{fa}{a matrix with the loadings: the canonical weights}
+ \item{li}{a data frame which gives the canonical scores}
+ \item{va}{a matrix which gives the cosines between the variables and the canonical scores}
+ \item{cp}{a matrix which gives the cosines between the components and the canonical scores}
+ \item{gc}{a data frame which gives the class scores}
+}
+\seealso{\code{lda} in package \code{MASS}
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(chazeb)
+dis1 <- discrimin(dudi.pca(chazeb$tab, scan = FALSE), chazeb$cla,
+ scan = FALSE)
+dis1
+if(!adegraphicsLoaded())
+ plot(dis1)
+
+data(skulls)
+plot(discrimin(dudi.pca(skulls, scan = FALSE), gl(5,30),
+ scan = FALSE))
+}
+\keyword{multivariate}
diff --git a/man/discrimin.coa.Rd b/man/discrimin.coa.Rd
new file mode 100644
index 0000000..407ca75
--- /dev/null
+++ b/man/discrimin.coa.Rd
@@ -0,0 +1,35 @@
+\name{discrimin.coa}
+\alias{discrimin.coa}
+\title{Discriminant Correspondence Analysis
+}
+\description{
+performs a discriminant correspondence analysis.
+}
+\usage{
+discrimin.coa(df, fac, scannf = TRUE, nf = 2)
+}
+\arguments{
+ \item{df}{a data frame containing positive or null values}
+ \item{fac}{a factor defining the classes of discriminant analysis}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+}
+\value{
+a list of class \code{discrimin}. See \code{\link{discrimin}}
+}
+\references{
+Perriere, G.,Lobry, J. R. and Thioulouse J. (1996) Correspondence discriminant analysis: a multivariate method for comparing
+classes of protein and nucleic acid sequences. \emph{CABIOS}, \bold{12}, 519--524.\cr
+
+Perriere, G. and Thioulouse, J. (2003) Use of Correspondence Discriminant Analysis to predict the subcellular location of bacterial proteins.
+\emph{Computer Methods and Programs in Biomedicine}, \bold{70}, 2, 99--105.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(perthi02)
+plot(discrimin.coa(perthi02$tab, perthi02$cla, scan = FALSE))
+}
+\keyword{multivariate}
diff --git a/man/dist.binary.Rd b/man/dist.binary.Rd
new file mode 100644
index 0000000..5ec434f
--- /dev/null
+++ b/man/dist.binary.Rd
@@ -0,0 +1,49 @@
+\name{dist.binary}
+\alias{dist.binary}
+\title{Computation of Distance Matrices for Binary Data}
+\description{
+computes for binary data some distance matrice.
+}
+\usage{
+dist.binary(df, method = NULL, diag = FALSE, upper = FALSE)
+}
+\arguments{
+ \item{df}{a matrix or a data frame with positive or null numeric values. Used with \code{as.matrix(1 * (df > 0))}}
+ \item{method}{an integer between 1 and 10 . If NULL the choice is made with a console message. See details}
+ \item{diag}{a logical value indicating whether the diagonal of the distance matrix should be printed by `print.dist'}
+ \item{upper}{a logical value indicating whether the upper triangle of the distance matrix should be printed by `print.dist'}
+}
+\details{
+Let be the contingency table of binary data such as \eqn{n_{11} = a}{n11 = a}, \eqn{n_{10} = b}{n10 = b}, \eqn{n_{01} = c}{n01 = c}
+and \eqn{n_{00} = d}{n00 = d}. All these distances are of type \eqn{d=\sqrt{1-s}}{d = sqrt(1 - s)} with \emph{s} a similarity coefficient.
+\describe{
+\item{1 = Jaccard index (1901)}{S3 coefficient of Gower & Legendre \eqn{s_1 = \frac{a}{a+b+c}}{s1 = a / (a+b+c)}}
+\item{2 = Simple matching coefficient of Sokal & Michener (1958)}{S4 coefficient of Gower & Legendre \eqn{s_2 =\frac{a+d}{a+b+c+d}}{s2 = (a+d) / (a+b+c+d)}}
+\item{3 = Sokal & Sneath(1963)}{S5 coefficient of Gower & Legendre \eqn{s_3 =\frac{a}{a+2(b+c)}}{s3 = a / (a + 2(b + c))}}
+\item{4 = Rogers & Tanimoto (1960)}{S6 coefficient of Gower & Legendre \eqn{s_4 =\frac{a+d}{(a+2(b+c)+d)}}{s4 = (a + d) / (a + 2(b + c) +d)}}
+\item{5 = Dice (1945) or Sorensen (1948)}{S7 coefficient of Gower & Legendre \eqn{s_5 =\frac{2a}{2a+b+c}}{s5 = 2a / (2a + b + c)}}
+\item{6 = Hamann coefficient}{S9 index of Gower & Legendre (1986) \eqn{s_6 =\frac{a-(b+c)+d}{a+b+c+d}}{s6 = (a - (b + c) + d) / (a + b + c + d)}}
+\item{7 = Ochiai (1957)}{S12 coefficient of Gower & Legendre \eqn{s_7 =\frac{a}{\sqrt{(a+b)(a+c)}}}{s7 = a / sqrt((a + b)(a + c))}}
+\item{8 = Sokal & Sneath (1963)}{S13 coefficient of Gower & Legendre \eqn{s_8 =\frac{ad}{\sqrt{(a+b)(a+c)(d+b)(d+c)}}}{s8 = ad / sqrt((a + b)(a + c)(d + b)(d + c))}}
+\item{9 = Phi of Pearson}{S14 coefficient of Gower & Legendre \eqn{s_9 =\frac{ad-bc}{\sqrt{(a+b)(a+c)(b+d)(d+c)}}}{s9 = (ad - bc) / sqrt((a + b)(a + c)(d + b)(d + c))}}
+\item{10 = S2 coefficient of Gower & Legendre}{\eqn{s_1 = \frac{a}{a+b+c+d}}{s10 = a / (a + b + c + d)}}
+}
+}
+\value{
+returns a distance matrix of class \code{dist} between the rows of the data frame
+}
+\references{Gower, J.C. and Legendre, P. (1986) Metric and Euclidean properties of dissimilarity coefficients.
+\emph{Journal of Classification}, \bold{3}, 5--48.
+}
+\author{
+Daniel Chessel \cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\examples{
+data(aviurba)
+for (i in 1:10) {
+ d <- dist.binary(aviurba$fau, method = i)
+ cat(attr(d, "method"), is.euclid(d), "\n")}
+}
+\keyword{array}
+\keyword{multivariate}
diff --git a/man/dist.dudi.Rd b/man/dist.dudi.Rd
new file mode 100644
index 0000000..c8d3a85
--- /dev/null
+++ b/man/dist.dudi.Rd
@@ -0,0 +1,29 @@
+\name{dist.dudi}
+\alias{dist.dudi}
+\title{Computation of the Distance Matrix from a Statistical Triplet
+}
+\description{
+computes for a statistical triplet a distance matrix.
+}
+\usage{
+dist.dudi(dudi, amongrow = TRUE)
+}
+\arguments{
+ \item{dudi}{a duality diagram, object of class \code{dudi}}
+ \item{amongrow}{a logical value computing the distance if TRUE, between rows, if FALSE between columns.}
+}
+\value{
+an object of class \code{dist}
+}
+\author{
+Daniel Chessel \cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\examples{
+data (meaudret)
+pca1 <- dudi.pca(meaudret$env, scan = FALSE)
+sum((dist(scalewt(meaudret$env)) - dist.dudi(pca1))^2)
+#[1] 4.045e-29 the same thing
+}
+\keyword{array}
+\keyword{multivariate}
diff --git a/man/dist.genet.Rd b/man/dist.genet.Rd
new file mode 100644
index 0000000..10cacde
--- /dev/null
+++ b/man/dist.genet.Rd
@@ -0,0 +1,97 @@
+\name{dist.genet}
+\alias{dist.genet}
+\title{ Genetic distances from gene frequencies }
+\description{
+ This program computes any one of five measures of genetic distance from a set of gene frequencies in different populations with several loci.
+}
+\usage{
+dist.genet(genet, method = 1, diag = FALSE, upper = FALSE)
+}
+\arguments{
+ \item{genet}{ a list of class \code{genet} }
+ \item{method}{ an integer between 1 and 5. See details }
+ \item{diag}{ a logical value indicating whether the diagonal of the distance matrix should be printed by \code{print.dist} }
+ \item{upper}{ a logical value indicating whether the upper triangle of the distance matrix should be printed by \code{print.dist} }
+}
+\details{
+Let \bold{A} a table containing allelic frequencies with \emph{t} populations (rows) and \emph{m} alleles (columns).\cr
+Let \eqn{\nu} the number of loci. The locus \emph{j} gets \emph{m(j)} alleles.
+\eqn{m=\sum_{j=1}^{\nu} m(j)}\cr
+
+For the row \emph{i} and the modality \emph{k} of the variable \emph{j}, notice the value \eqn{a_{ij}^k} (\eqn{1 \leq i \leq t}, \eqn{1 \leq j \leq \nu},
+\eqn{1 \leq k \leq m(j)}) the value of the initial table.\cr
+
+\eqn{a_{ij}^+=\sum_{k=1}^{m(j)}a_{ij}^k} and \eqn{p_{ij}^k=\frac{a_{ij}^k}{a_{ij}^+}}\cr
+
+Let \bold{P} the table of general term \eqn{p_{ij}^k}\cr
+\eqn{p_{ij}^+=\sum_{k=1}^{m(j)}p_{ij}^k=1}, \eqn{p_{i+}^+=\sum_{j=1}^{\nu}p_{ij}^+=\nu}, \eqn{p_{++}^+=\sum_{j=1}^{\nu}p_{i+}^+=t\nu}\cr
+
+The option \code{method} computes the distance matrices between populations using the frequencies \eqn{p_{ij}^k}. \cr
+
+1. Nei's distance: \cr
+\eqn{D_1(a,b)=- \ln(\frac{\sum_{k=1}^{\nu} \sum_{j=1}^{m(k)}
+p_{aj}^k p_{bj}^k}{\sqrt{\sum_{k=1}^{\nu} \sum_{j=1}^{m(k)}
+{(p_{aj}^k) }^2}\sqrt{\sum_{k=1}^{\nu} \sum_{j=1}^{m(k)}
+{(p_{bj}^k)}^2}})}\cr
+
+2. Angular distance or Edwards' distance:\cr
+\eqn{D_2(a,b)=\sqrt{1-\frac{1}{\nu} \sum_{k=1}^{\nu}
+\sum_{j=1}^{m(k)} \sqrt{p_{aj}^k p_{bj}^k}}}\cr
+
+3. Coancestrality coefficient or Reynolds' distance:\cr
+\eqn{D_3(a,b)=\sqrt{\frac{\sum_{k=1}^{\nu}
+\sum_{j=1}^{m(k)}{(p_{aj}^k - p_{bj}^k)}^2}{2 \sum_{k=1}^{\nu} (1-
+\sum_{j=1}^{m(k)}p_{aj}^k p_{bj}^k)}}}\cr
+
+4. Classical Euclidean distance or Rogers' distance:\cr
+\eqn{D_4(a,b)=\frac{1}{\nu} \sum_{k=1}^{\nu} \sqrt{\frac{1}{2}
+\sum_{j=1}^{m(k)}{(p_{aj}^k - p_{bj}^k)}^2}}\cr
+
+5. Absolute genetics distance or Provesti 's distance:\cr
+\eqn{D_5(a,b)=\frac{1}{2{\nu}} \sum_{k=1}^{\nu} \sum_{j=1}^{m(k)}
+|p_{aj}^k - p_{bj}^k|}
+}
+\value{
+returns a distance matrix of class \code{dist} between the rows of the data frame
+}
+\references{
+To complete informations about distances:\cr
+
+Distance 1:\cr
+Nei, M. (1972) Genetic distances between populations. \emph{American Naturalist}, \bold{106}, 283--292. \cr
+Nei M. (1978) Estimation of average heterozygosity and genetic distance from a small number of individuals. \emph{Genetics}, \bold{23}, 341--369. \cr
+Avise, J. C. (1994) Molecular markers, natural history and evolution. Chapman & Hall, London.
+
+Distance 2:\cr
+Edwards, A.W.F. (1971) Distance between populations on the basis of gene frequencies. \emph{Biometrics}, \bold{27}, 873--881. \cr
+Cavalli-Sforza L.L. and Edwards A.W.F. (1967) Phylogenetic analysis: models and estimation procedures. \emph{Evolution}, \bold{32}, 550--570. \cr
+Hartl, D.L. and Clark, A.G. (1989) Principles of population genetics. Sinauer Associates, Sunderland, Massachussetts (p. 303).
+
+Distance 3:\cr
+Reynolds, J. B., B. S. Weir, and C. C. Cockerham. (1983) Estimation of the coancestry coefficient: basis for a short-term genetic distance. \emph{Genetics}, \bold{105}, 767--779.
+
+Distance 4:\cr
+Rogers, J.S. (1972) Measures of genetic similarity and genetic distances. \emph{Studies in Genetics}, Univ. Texas Publ., \bold{7213}, 145--153. \cr
+Avise, J. C. (1994) Molecular markers, natural history and evolution. Chapman & Hall, London.
+
+Distance 5:\cr
+Prevosti A. (1974) La distancia genética entre poblaciones. \emph{Miscellanea Alcobé}, \bold{68}, 109--118. \cr
+Prevosti A., Ocaña J. and Alonso G. (1975) Distances between populations of Drosophila subobscura, based on chromosome arrangements frequencies. \emph{Theoretical and Applied Genetics}, \bold{45}, 231--241. \cr
+
+To find some useful explanations:\cr
+Sanchez-Mazas A. (2003) Cours de Génétique Moléculaire des Populations. Cours VIII Distances génétiques - Représentation des populations. \cr
+\url{http://anthro.unige.ch/GMDP/Alicia/GMDP_dist.htm}
+}
+\author{ Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(casitas)
+casi.genet <- char2genet(casitas,
+ as.factor(rep(c("dome", "cast", "musc", "casi"), c(24,11,9,30))))
+ldist <- lapply(1:5, function(method) dist.genet(casi.genet,method))
+ldist
+unlist(lapply(ldist, is.euclid))
+kdist(ldist)
+}
+\keyword{ multivariate }
diff --git a/man/dist.ktab.Rd b/man/dist.ktab.Rd
new file mode 100644
index 0000000..cc190d3
--- /dev/null
+++ b/man/dist.ktab.Rd
@@ -0,0 +1,157 @@
+\name{dist.ktab}
+\alias{dist.ktab}
+\alias{prep.binary}
+\alias{prep.circular}
+\alias{prep.fuzzy}
+\alias{ldist.ktab}
+\alias{kdist.cor}
+\title{Mixed-variables coefficient of distance}
+\description{
+The mixed-variables coefficient of distance generalizes Gower's general coefficient of distance
+to allow the treatment of various statistical types of variables when calculating distances.
+This is especially important when measuring functional diversity. Indeed, most of the indices that
+measure functional diversity depend on variables (traits) that have various statistical types (e.g. circular,
+fuzzy, ordinal) and that go through a matrix of distances among species.
+}
+\usage{
+dist.ktab(x, type, option = c("scaledBYrange", "scaledBYsd", "noscale"),
+scann = FALSE, tol = 1e-8)
+ldist.ktab(x, type, option = c("scaledBYrange", "scaledBYsd",
+"noscale"), scann = FALSE, tol = 1e-8)
+kdist.cor(x, type, option = c("scaledBYrange", "scaledBYsd", "noscale"),
+scann = FALSE, tol = 1e-8, squared = TRUE)
+prep.fuzzy(df, col.blocks, row.w = rep(1, nrow(df)), labels = paste("F",
+1:length(col.blocks), sep = ""))
+prep.binary(df, col.blocks, labels = paste("B", 1:length(col.blocks), sep = ""))
+prep.circular(df, rangemin = apply(df, 2, min, na.rm = TRUE), rangemax =
+apply(df, 2, max, na.rm = TRUE))
+}
+\arguments{
+ \item{x}{Object of class \code{ktab} (see details)}
+ \item{type}{Vector that provide the type of each table in x. The possible types are "Q"
+(quantitative), "O" (ordinal), "N" (nominal), "D" (dichotomous), "F" (fuzzy, or
+expressed as a proportion), "B" (multichoice nominal variables, coded by
+binary columns), "C" (circular). Values in type must be in the same order as in x.}
+ \item{option}{A string that can have three values: either "scaledBYrange" if the
+quantitative variables must be scaled by their range, or "scaledBYsd" if they
+must be scaled by their standard deviation, or "noscale" if they should not be
+scaled. This last option can be useful if the the values have already been
+normalized by the known range of the whole population instead of the
+observed range measured on the sample. If x contains data from various types,
+then the option "scaledBYsd" is not suitable (a warning will appear if the option selected with that condition).}
+ \item{scann}{A logical. If TRUE, then the user will have to choose among several possible
+functions of distances for the quantitative, ordinal, fuzzy and binary variables.}
+ \item{tol}{A tolerance threshold: a value less than tol is considered as
+null.}
+\item{squared}{A logical, if TRUE, the squared distances are considered.}
+\item{df}{Objet of class data.frame}
+\item{col.blocks}{A vector that contains the number of levels per variable (in the same order
+as in \code{df})}
+\item{row.w}{A vector of row weigths}
+\item{labels}{the names of the traits}
+\item{rangemin}{A numeric corresponding to the smallest level where the loop starts}
+\item{rangemax}{A numeric corresponding to the highest level where the loop closes}
+}
+\value{
+The functions provide the following results:
+ \item{dist.ktab}{returns an object of class \code{dist};}
+ \item{ldist.ktab}{returns a list of objects of class \code{dist} that correspond to the distances between species calculated per trait;}
+ \item{kdist.cor}{returns a list of three objects: "paircov" provides the covariance
+ between traits in terms of (squared) distances between species;
+ "paircor" provides the correlations between traits in terms of (squared) distances between species;
+ "glocor" provides the correlations between the (squared) distances obtained for each trait and the global (squared) distances
+ obtained by mixing all the traits (= contributions of traits to the global distances);}
+ \item{prep.binary and prep.fuzzy}{returns a data frame with the following attributes: col.blocks
+ specifies the number of columns per fuzzy variable; col.num specifies which variable
+ each column belongs to;}
+ \item{prep.circular}{returns a data frame with the following attributes: max specifies the number
+ of levels in each circular variable.}
+}
+\references{
+Pavoine S., Vallet, J., Dufour, A.-B., Gachet, S. and Daniel, H. (2009)
+On the challenge of treating various types of variables:
+Application for improving the measurement of functional diversity. \emph{Oikos}, \bold{118}, 391--402.
+}
+\author{Sandrine Pavoine \email{pavoine at mnhn.fr}
+}
+
+\details{
+When preparing the object of class \code{ktab} (object x), variables of type "Q", "O", "D", "F", "B" and "C" should be of class \code{numeric} (the class \code{ordered} is not yet considered by \code{dist.ktab}); variables of type "N" should be of class \code{character} or \code{factor}
+}
+\seealso{
+\code{\link{daisy}} in the \code{cluster} package in the case of ratio-scale (quantitative) and nominal variables;
+and \code{\link{woangers}} for an application.
+}
+\examples{
+# With fuzzy variables
+data(bsetal97)
+
+w <- prep.fuzzy(bsetal97$biol, bsetal97$biol.blo)
+w[1:6, 1:10]
+ktab1 <- ktab.list.df(list(w))
+dis <- dist.ktab(ktab1, type = "F")
+as.matrix(dis)[1:5, 1:5]
+
+\dontrun{
+# With ratio-scale and multichoice variables
+data(ecomor)
+
+wM <- log(ecomor$morpho + 1) # Quantitative variables
+wD <- ecomor$diet
+# wD is a data frame containing a multichoice nominal variable
+# (diet habit), with 8 modalities (Granivorous, etc)
+# We must prepare it by prep.binary
+head(wD)
+wD <- prep.binary(wD, col.blocks = 8, label = "diet")
+wF <- ecomor$forsub
+# wF is also a data frame containing a multichoice nominal variable
+# (foraging substrat), with 6 modalities (Foliage, etc)
+# We must prepare it by prep.binary
+head(wF)
+wF <- prep.binary(wF, col.blocks = 6, label = "foraging")
+# Another possibility is to combine the two last data frames wD and wF as
+# they contain the same type of variables
+wB <- cbind.data.frame(ecomor$diet, ecomor$forsub)
+head(wB)
+wB <- prep.binary(wB, col.blocks = c(8, 6), label = c("diet", "foraging"))
+# The results given by the two alternatives are identical
+ktab2 <- ktab.list.df(list(wM, wD, wF))
+disecomor <- dist.ktab(ktab2, type= c("Q", "B", "B"))
+as.matrix(disecomor)[1:5, 1:5]
+contrib2 <- kdist.cor(ktab2, type= c("Q", "B", "B"))
+contrib2
+
+ktab3 <- ktab.list.df(list(wM, wB))
+disecomor2 <- dist.ktab(ktab3, type= c("Q", "B"))
+as.matrix(disecomor2)[1:5, 1:5]
+contrib3 <- kdist.cor(ktab3, type= c("Q", "B"))
+contrib3
+
+# With a range of variables
+data(woangers)
+
+traits <- woangers$traits
+# Nominal variables 'li', 'pr', 'lp' and 'le'
+# (see table 1 in the main text for the codes of the variables)
+tabN <- traits[,c(1:2, 7, 8)]
+# Circular variable 'fo'
+tabC <- traits[3]
+tabCp <- prep.circular(tabC, 1, 12)
+# The levels of the variable lie between 1 (January) and 12 (December).
+# Ordinal variables 'he', 'ae' and 'un'
+tabO <- traits[, 4:6]
+# Fuzzy variables 'mp', 'pe' and 'di'
+tabF <- traits[, 9:19]
+tabFp <- prep.fuzzy(tabF, c(3, 3, 5), labels = c("mp", "pe", "di"))
+# 'mp' has 3 levels, 'pe' has 3 levels and 'di' has 5 levels.
+# Quantitative variables 'lo' and 'lf'
+tabQ <- traits[, 20:21]
+ktab1 <- ktab.list.df(list(tabN, tabCp, tabO, tabFp, tabQ))
+distrait <- dist.ktab(ktab1, c("N", "C", "O", "F", "Q"))
+is.euclid(distrait)
+contrib <- kdist.cor(ktab1, type = c("N", "C", "O", "F", "Q"))
+contrib
+dotchart(sort(contrib$glocor), labels = rownames(contrib$glocor)[order(contrib$glocor[, 1])])
+}
+}
+\keyword{multivariate}
diff --git a/man/dist.neig.Rd b/man/dist.neig.Rd
new file mode 100644
index 0000000..6487cb9
--- /dev/null
+++ b/man/dist.neig.Rd
@@ -0,0 +1,28 @@
+\name{dist.neig}
+\alias{dist.neig}
+\title{Computation of the Distance Matrix associated to a Neighbouring Graph
+}
+\description{
+ This distance matrix between two points is the length of the shortest path between
+these points.
+}
+\usage{
+dist.neig(neig)
+}
+\arguments{
+ \item{neig}{a neighbouring graph, object of class \code{neig}}
+}
+\value{
+returns a distance matrix, object of class \code{dist}
+}
+\author{
+Daniel Chessel \cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\examples{
+ data(elec88)
+ d0 <- dist.neig(elec88$neig)
+ plot(dist(elec88$xy),d0)
+}
+\keyword{array}
+\keyword{multivariate}
diff --git a/man/dist.prop.Rd b/man/dist.prop.Rd
new file mode 100644
index 0000000..99a1a45
--- /dev/null
+++ b/man/dist.prop.Rd
@@ -0,0 +1,61 @@
+\name{dist.prop}
+\alias{dist.prop}
+\title{Computation of Distance Matrices of Percentage Data
+}
+\description{
+computes for percentage data some distance matrices.
+}
+\usage{
+dist.prop(df, method = NULL, diag = FALSE, upper = FALSE)
+}
+\arguments{
+ \item{df}{a data frame containing only positive or null values, used as row percentages}
+ \item{method}{an integer between 1 and 5. If NULL the choice is made with a console message. See details}
+ \item{diag}{a logical value indicating whether the diagonal of the distance matrix should be printed by `print.dist'}
+ \item{upper}{a logical value indicating whether the upper triangle of the distance matrix should be printed by `print.dist'}
+}
+\details{
+ \describe{
+\item{1 = Manly}{\eqn{d_1=\frac{1}{2} \sum_{i=1}^{K}{|{p_i-q_i}|}}{d1 = sum|p(i) - q(i)|/2}}
+\item{2 = Overlap index Manly}{\eqn{d_2=1-\frac{\sum_{i=1}^{K}{p_i q_i}}{\sqrt{\sum_{i=1}^{K}{p_i^2}}{\sqrt{\sum_{i=1}^{K}{q_i^2}}}}}{d2 = 1 - Sum(p(i)q(i))/sqrt(Sum(p(i)^2))/sqrt(Sum(q(i)^2))}}
+\item{3 = Rogers 1972 (one locus)}{\eqn{d_3=\sqrt{\frac{1}{2} \sum_{i=1}^{K}{(p_i-q_i)^2}}}{d3 = sqrt(0.5*Sum(p(i)-q(i)^2))}}
+\item{4 = Nei 1972 (one locus)}{\eqn{d_4=\ln{\frac{\sum_{i=1}^{K}{p_i q_i}}{\sqrt{\sum_{i=1}^{K}{p_i^2}}{\sqrt{\sum_{i=1}^{K}{q_i^2}}}}}}{d4 = -ln(Sum(p(i)q(i))/sqrt(Sum(p(i)^2))/sqrt(Sum(q(i)^2)))}}
+\item{5 = Edwards 1971 (one locus)}{\eqn{d_5=\sqrt{1-\sum_{i=1}^{K}{\sqrt{p_1 q_i}}}}{d5= sqrt (1 - (Sum(sqrt(p(i)q(i)))))}}
+}
+}
+\value{
+returns a distance matrix, object of class \code{dist}
+}
+\references{
+Edwards, A. W. F. (1971) Distance between populations on the basis of gene frequencies. \emph{Biometrics}, \bold{27},
+873--881.
+
+Manly, B. F. (1994) \emph{Multivariate Statistical Methods. A primer.}, Second edition. Chapman & Hall, London.
+
+Nei, M. (1972) Genetic distances between populations. \emph{The American Naturalist}, \bold{106}, 283--292.
+}
+\author{
+Daniel Chessel \cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\examples{
+data(microsatt)
+w <- microsatt$tab[1:microsatt$loci.eff[1]]
+
+if(adegraphicsLoaded()) {
+ g1 <- scatter(dudi.pco(lingoes(dist.prop(w, 1)), scann = FALSE), plot = FALSE)
+ g2 <- scatter(dudi.pco(lingoes(dist.prop(w, 2)), scann = FALSE), plot = FALSE)
+ g3 <- scatter(dudi.pco(dist.prop(w, 3), scann = FALSE), plot = FALSE)
+ g4 <- scatter(dudi.pco(lingoes(dist.prop(w, 4)), scann = FALSE), plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2, 2))
+ scatter(dudi.pco(lingoes(dist.prop(w, 1)), scann = FALSE))
+ scatter(dudi.pco(lingoes(dist.prop(w, 2)), scann = FALSE))
+ scatter(dudi.pco(dist.prop(w, 3), scann = FALSE))
+ scatter(dudi.pco(lingoes(dist.prop(w, 4)), scann = FALSE))
+ par(mfrow = c(1, 1))
+}}
+\keyword{array}
+\keyword{multivariate}
diff --git a/man/dist.quant.Rd b/man/dist.quant.Rd
new file mode 100644
index 0000000..acf12f4
--- /dev/null
+++ b/man/dist.quant.Rd
@@ -0,0 +1,53 @@
+\name{dist.quant}
+\alias{dist.quant}
+\title{Computation of Distance Matrices on Quantitative Variables}
+\description{
+computes on quantitative variables, some distance matrices as canonical, Joreskog and Mahalanobis.
+}
+\usage{
+dist.quant(df, method = NULL, diag = FALSE, upper = FALSE,
+ tol = 1e-07)
+}
+\arguments{
+ \item{df}{a data frame containing only quantitative variables}
+ \item{method}{an integer between 1 and 3. If NULL the choice is made with a console message. See details}
+ \item{diag}{a logical value indicating whether the diagonal of the distance matrix should be printed by `print.dist'}
+ \item{upper}{a logical value indicating whether the upper triangle of the distance matrix should be printed by `print.dist'}
+ \item{tol}{used in case 3 of \code{method} as a tolerance threshold for null eigenvalues}
+}
+\details{
+All the distances are of type \eqn{d=\|x-y\|_A =
+ \sqrt{(x-y)^{t}A(x-y)}}{d = ||x-y||_A = sqrt((x-y)^t A (x-y))}
+\describe{
+ \item{1 = Canonical}{A = Identity}
+ \item{2 = Joreskog}{\eqn{A=\frac{1}{diag(cov)}}{A = 1 / diag(cov)}}
+ \item{3 = Mahalanobis}{A = inv(cov)}
+}
+}
+\value{
+an object of class \code{dist}
+}
+\author{
+Daniel Chessel \cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\examples{
+data(ecomor)
+
+if(adegraphicsLoaded()) {
+ g1 <- scatter(dudi.pco(dist.quant(ecomor$morpho, 3), scan = FALSE), plot = FALSE)
+ g2 <- scatter(dudi.pco(dist.quant(ecomor$morpho, 2), scan = FALSE), plot = FALSE)
+ g3 <- scatter(dudi.pco(dist(scalewt(ecomor$morpho)), scan = FALSE), plot = FALSE)
+ g4 <- scatter(dudi.pco(dist.quant(ecomor$morpho, 1), scan = FALSE), plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2, 2))
+ scatter(dudi.pco(dist.quant(ecomor$morpho, 3), scan = FALSE))
+ scatter(dudi.pco(dist.quant(ecomor$morpho, 2), scan = FALSE))
+ scatter(dudi.pco(dist(scalewt(ecomor$morpho)), scan = FALSE))
+ scatter(dudi.pco(dist.quant(ecomor$morpho, 1), scan = FALSE))
+ par(mfrow = c(1, 1))
+}}
+\keyword{array}
+\keyword{multivariate}
diff --git a/man/divc.Rd b/man/divc.Rd
new file mode 100644
index 0000000..64a77ed
--- /dev/null
+++ b/man/divc.Rd
@@ -0,0 +1,43 @@
+\name{divc}
+\alias{divc}
+\title{Rao's diversity coefficient also called quadratic entropy}
+\description{
+Calculates Rao's diversity coefficient within samples.
+}
+\usage{
+divc(df, dis, scale)
+}
+\arguments{
+ \item{df}{a data frame with elements as rows, samples as columns,
+ and abundance, presence-absence or frequencies as entries}
+ \item{dis}{an object of class \code{dist} containing distances or dissimilarities among elements.
+ If \code{dis} is NULL, Gini-Simpson index is performed.}
+ \item{scale}{a logical value indicating whether or not the diversity coefficient
+ should be scaled by its maximal value over all frequency distributions.}
+}
+\value{
+Returns a data frame with samples as rows and the diversity coefficient within samples as columns
+}
+\references{
+Rao, C.R. (1982) Diversity and dissimilarity coefficients: a unified approach.
+\emph{Theoretical Population Biology}, \bold{21}, 24--43.
+
+Gini, C. (1912) Variabilità e mutabilità. \emph{Universite di Cagliari III}, Parte II.
+
+Simpson, E.H. (1949) Measurement of diversity. \emph{Nature}, \bold{163}, 688.
+
+Champely, S. and Chessel, D. (2002) Measuring biological diversity using Euclidean metrics.
+\emph{Environmental and Ecological Statistics}, \bold{9}, 167--177.
+
+}
+\author{Sandrine Pavoine \email{pavoine at mnhn.fr}
+}
+\examples{
+data(ecomor)
+dtaxo <- dist.taxo(ecomor$taxo)
+divc(ecomor$habitat, dtaxo)
+
+data(humDNAm)
+divc(humDNAm$samples, sqrt(humDNAm$distances))
+}
+\keyword{multivariate}
diff --git a/man/divcmax.Rd b/man/divcmax.Rd
new file mode 100644
index 0000000..b5c3763
--- /dev/null
+++ b/man/divcmax.Rd
@@ -0,0 +1,83 @@
+\name{divcmax}
+\alias{divcmax}
+\title{Maximal value of Rao's diversity coefficient also called
+quadratic entropy}
+\description{
+For a given dissimilarity matrix, this function calculates the
+maximal value of Rao's diversity coefficient over all frequency
+distribution. It uses an optimization technique based on Rosen's
+projection gradient algorithm and is verified using the
+Kuhn-Tucker conditions.
+}
+\usage{
+divcmax(dis, epsilon, comment)
+}
+\arguments{
+ \item{dis}{an object of class \code{dist} containing distances
+ or dissimilarities among elements.}
+ \item{epsilon}{a tolerance threshold : a frequency is non null
+ if it is higher than epsilon.}
+ \item{comment}{a logical value indicating whether or not
+ comments on the optimization technique should be printed.}
+}
+\value{
+Returns a list
+ \item{value}{the maximal value of Rao's diversity coefficient.}
+ \item{vectors}{a data frame containing four frequency
+ distributions : \code{sim} is a simple distribution which is equal
+ to \eqn{\frac{D1}{1^tD1}}{D1/1^tD1}, \code{pro} is equal to
+ \eqn{\frac{z}{1^tz1}}{z/1^tz1}, where z is the nonnegative
+ eigenvector of the matrix containing the squared dissimilarities
+ among the elements, \code{met} is equal to \eqn{z^2}{z^2}, \code{num} is a
+ frequency vector maximizing Rao's diversity coefficient.}
+}
+\references{
+Rao, C.R. (1982) Diversity and dissimilarity coefficients:
+a unified approach. \emph{Theoretical Population Biology},
+\bold{21}, 24--43.
+
+Gini, C. (1912) Variabilità e mutabilità.
+\emph{Universite di Cagliari III}, Parte II.
+
+Simpson, E.H. (1949) Measurement of diversity.
+\emph{Nature}, \bold{163}, 688.
+
+Champely, S. and Chessel, D. (2002) Measuring biological diversity
+using Euclidean metrics. \emph{Environmental and Ecological Statistics},
+\bold{9}, 167--177.
+
+Pavoine, S., Ollier, S. and Pontier, D. (2005)
+Measuring diversity from dissimilarities with Rao's quadratic entropy:
+are any dissimilarities suitable? \emph{Theoretical Population Biology},
+\bold{67}, 231--239.
+
+}
+\author{
+Stéphane Champely \email{Stephane.Champely at univ-lyon1.fr} \cr
+Sandrine Pavoine \email{pavoine at mnhn.fr}
+}
+\examples{
+data(elec88)
+
+# Dissimilarity matrix.
+d0 <- dist(elec88$xy/100)
+
+# Frequency distribution maximizing spatial diversity in France
+# according to Rao's quadratic entropy.
+France.m <- divcmax(d0)
+w0 <- France.m$vectors$num
+v0 <- France.m$value
+idx <- (1:94) [w0 > 0]
+
+if(!adegraphicsLoaded()) {
+ # Smallest circle including all the 94 departments.
+ # The squared radius of that circle is the maximal value of the
+ # spatial diversity.
+ w1 <- elec88$xy[idx, ]/100
+ w.c <- apply(w1 * w0[idx], 2, sum)
+ plot(elec88$xy[, 1]/100, elec88$xy[, 2]/100, asp=1)
+ symbols(w.c[1], w.c[2], circles = sqrt(v0), inches = FALSE, add = TRUE)
+ s.value(elec88$xy/100, w0, add.plot = TRUE)
+}
+}
+\keyword{multivariate}
diff --git a/man/dotchart.phylog.Rd b/man/dotchart.phylog.Rd
new file mode 100644
index 0000000..0004249
--- /dev/null
+++ b/man/dotchart.phylog.Rd
@@ -0,0 +1,59 @@
+\name{dotchart.phylog}
+\alias{dotchart.phylog}
+\title{Representation of many quantitative variables in front of a phylogenetic tree}
+\description{
+\code{dotchart.phylog} represents the phylogenetic tree and draws Cleveland dot
+ plot of each variable.
+}
+\usage{
+dotchart.phylog(phylog, values, y = NULL, scaling = TRUE, ranging =
+TRUE, yranging = NULL, joining = TRUE, yjoining = NULL, ceti = 1, cdot =
+1, csub = 1, f.phylog = 1/(1 + ncol(values)), ...)
+}
+\arguments{
+ \item{phylog}{ an object of class \code{phylog}}
+ \item{values}{ a vector or a data frame giving the variables}
+ \item{y}{ a vector which values correspond to leaves positions}
+ \item{scaling}{ if TRUE, data are scaled}
+ \item{ranging}{ if TRUE, dotplots are drawn with the same horizontal limits}
+ \item{yranging}{ a vector with two values giving the horizontal limits.
+ If NULL, horizontal limits are defined by lower and upper values of data}
+ \item{joining}{ if TRUE, segments join each point to a central value}
+ \item{yjoining}{ a vector with the central value. If NULL, the central value equals 0}
+ \item{ceti}{ a character size for editing horizontal limits, \cr
+ used with \code{par("cex")*ceti}}
+ \item{cdot}{ a character size for plotting the points of the dot plot,
+ used with \code{par("cex")*cdot}}
+ \item{csub}{ a character size for editing the names of variables, \cr
+ used with \code{par("cex")*csub}}
+ \item{f.phylog}{ a size coefficient for tree size (a parameter to draw the tree
+ in proportion to leaves labels)}
+ \item{\dots}{ further arguments passed to or from other methods}
+}
+\author{
+Daniel Chessel \cr
+Sébastien Ollier \email{sebastien.ollier at u-psud.fr}
+}
+\seealso{\code{\link{symbols.phylog}} and \code{\link{table.phylog}}}
+\examples{
+# one variable
+tre <- c("((A,B),(C,D));")
+phy <- newick2phylog(tre)
+x <- 1:4
+par(mfrow = c(2,2))
+dotchart.phylog(phy, x, scaling = FALSE)
+dotchart.phylog(phy, x)
+dotchart.phylog(phy, x, joining = FALSE)
+dotchart.phylog(phy, x, scaling = FALSE,
+ yjoining = 0, yranging = c(-1, 5))
+par(mfrow = c(1,1))
+
+# many variables
+data(mjrochet)
+phy <- newick2phylog(mjrochet$tre)
+tab <- data.frame(log(mjrochet$tab))
+dotchart.phylog(phy, tab, ceti = 0.5, csub = 0.6,
+ cleaves = 0, cdot = 0.6)
+par(mfrow=c(1,1))
+}
+\keyword{hplot}
diff --git a/man/dotcircle.Rd b/man/dotcircle.Rd
new file mode 100644
index 0000000..aac8f9b
--- /dev/null
+++ b/man/dotcircle.Rd
@@ -0,0 +1,29 @@
+\name{dotcircle}
+\alias{dotcircle}
+\title{Representation of n values on a circle}
+\description{
+This function represents \emph{n} values on a circle. The \emph{n} points are shared out regularly over the circle and put on the radius according to the value attributed to that measure.
+}
+\usage{
+dotcircle(z, alpha0 = pi/2, xlim = range(pretty(z)),
+ labels = names(z), clabel = 1, cleg = 1)
+}
+\arguments{
+ \item{z}{: a numeric vector}
+ \item{alpha0}{: polar angle to put the first value}
+ \item{xlim}{: the ranges to be encompassed by the circle radius}
+ \item{labels}{: a vector of strings of characters for the angle labels}
+ \item{clabel}{: a character size for the labels, used with \code{par("cex")*clabel}}
+ \item{cleg}{: a character size for the ranges, used with \code{par("cex")*cleg}}
+}
+\seealso{\code{\link[CircStats]{circ.plot}}}
+\author{
+Daniel Chessel
+}
+\examples{
+w <- scores.neig(neig(n.cir = 24))
+par(mfrow = c(4,4))
+for (k in 1:16) dotcircle(w[,k],labels = 1:24)
+par(mfrow = c(1,1))
+}
+\keyword{hplot}
diff --git a/man/doubs.Rd b/man/doubs.Rd
new file mode 100644
index 0000000..8a10059
--- /dev/null
+++ b/man/doubs.Rd
@@ -0,0 +1,88 @@
+\name{doubs}
+\alias{doubs}
+\docType{data}
+\title{Pair of Ecological Tables}
+\description{
+This data set gives environmental variables, fish species and spatial coordinates for 30 sites.
+}
+\usage{data(doubs)}
+\format{
+ \code{doubs} is a list with 4 components.
+ \describe{
+ \item{env}{is a data frame with 30 rows (sites) and 11 environmental variables.}
+ \item{fish}{is a data frame with 30 rows (sites) and 27 fish species.}
+ \item{xy}{is a data frame with 30 rows (sites) and 2 spatial coordinates.}
+ \item{species}{is a data frame with 27 rows (species) and 4 columns (names).}
+ }
+}
+\details{
+The rows of \code{doubs$env}, \code{doubs$fish} and \code{doubs$xy} are 30 sites along the Doubs, a French and Switzerland river.
+
+\code{doubs$env} contains the following variables:
+dfs - distance from the source (km * 10),
+alt - altitude (m),
+slo (\eqn{\ln(x + 1)}{log(x + 1)} where \emph{x} is the slope (per mil * 100),
+flo - minimum average stream flow (m3/s * 100),
+pH (* 10),
+har - total hardness of water (mg/l of Calcium),
+pho - phosphates (mg/l * 100),
+nit - nitrates (mg/l * 100),
+amm - ammonia nitrogen (mg/l * 100),
+oxy - dissolved oxygen (mg/l * 10),
+bdo - biological demand for oxygen (mg/l * 10).
+
+\code{doubs$fish} contains the abundance of the following fish species: \emph{Cottus gobio} (Cogo), \emph{Salmo trutta fario} (Satr),
+\emph{Phoxinus phoxinus} (Phph), \emph{Nemacheilus barbatulus} (Neba), \emph{Thymallus thymallus} (Thth), \emph{Telestes soufia agassizi} (Teso),
+\emph{Chondrostoma nasus} (Chna), \emph{Chondostroma toxostoma} (Chto), \emph{Leuciscus leuciscus} (Lele), \emph{Leuciscus cephalus cephalus} (Lece),
+\emph{Barbus barbus} (Baba), \emph{Spirlinus bipunctatus} (Spbi), \emph{Gobio gobio} (Gogo), \emph{Esox lucius} (Eslu),
+\emph{Perca fluviatilis} (Pefl), \emph{Rhodeus amarus} (Rham), \emph{Lepomis gibbosus} (Legi), \emph{Scardinius erythrophtalmus} (Scer),
+\emph{Cyprinus carpio} (Cyca), \emph{Tinca tinca} (Titi), \emph{Abramis brama} (Abbr), \emph{Ictalurus melas} (Icme),
+\emph{Acerina cernua} (Acce), \emph{Rutilus rutilus} (Ruru), \emph{Blicca bjoerkna} (Blbj), \emph{Alburnus alburnus} (Alal),
+\emph{Anguilla anguilla} (Anan).
+
+\code{doubs$species} contains the names of the 27 fish species. The four columns correspond to: 1 = scientific name (Genus species), 2 = French common name, 3 = English common name, 4 = Four character code.
+
+}
+\source{
+ Verneaux, J. (1973)
+ \emph{Cours d'eau de Franche-Comté (Massif du Jura).
+ Recherches écologiques sur le réseau hydrographique du Doubs. Essai de biotypologie}.
+ Thèse d'état, Besançon. 1--257.
+}
+\references{
+See a French description of fish species at \url{http://pbil.univ-lyon1.fr/R/pdf/pps047.pdf}.\cr
+Chessel, D., Lebreton, J.D. and Yoccoz, N.G. (1987) Propriétés de l'analyse canonique des correspondances. Une illustration
+en hydrobiologie. \emph{Revue de Statistique Appliquée}, \bold{35}, 4, 55--72.
+}
+\examples{
+data(doubs)
+pca1 <- dudi.pca(doubs$env, scan = FALSE)
+pca2 <- dudi.pca(doubs$fish, scale = FALSE, scan = FALSE)
+coiner1 <- coinertia(pca1, pca2, scan = FALSE)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.corcircle(coiner1$aX, plot = FALSE)
+ g2 <- s.value(doubs$xy, coiner1$lX[, 1], plot = FALSE)
+ g3 <- s.value(doubs$xy, coiner1$lX[, 2], plot = FALSE)
+ g4 <- s.arrow(coiner1$c1, plot = FALSE)
+ g5 <- s.match(coiner1$mX, coiner1$mY, plot = FALSE)
+ g6 <- s.corcircle(coiner1$aY, plot = FALSE)
+ g7 <- s.arrow(coiner1$l1, plot = FALSE)
+ g8 <- s.value(doubs$xy, coiner1$lY[, 1], plot = FALSE)
+ g9 <- s.value(doubs$xy, coiner1$lY[, 2], plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3, g4, g5, g6, g7, g8, g9), layout = c(3, 3))
+
+} else {
+ par(mfrow = c(3, 3))
+ s.corcircle(coiner1$aX)
+ s.value(doubs$xy, coiner1$lX[, 1])
+ s.value(doubs$xy, coiner1$lX[, 2])
+ s.arrow(coiner1$c1)
+ s.match(coiner1$mX, coiner1$mY)
+ s.corcircle(coiner1$aY)
+ s.arrow(coiner1$l1)
+ s.value(doubs$xy, coiner1$lY[, 1])
+ s.value(doubs$xy, coiner1$lY[, 2])
+ par(mfrow = c(1, 1))
+}}
+\keyword{datasets}
diff --git a/man/dpcoa.Rd b/man/dpcoa.Rd
new file mode 100644
index 0000000..7ba93ae
--- /dev/null
+++ b/man/dpcoa.Rd
@@ -0,0 +1,84 @@
+\name{dpcoa}
+\alias{dpcoa}
+\alias{plot.dpcoa}
+\alias{print.dpcoa}
+\alias{summary.dpcoa}
+\title{Double principal coordinate analysis}
+\description{
+Performs a double principal coordinate analysis
+}
+\usage{
+dpcoa(df, dis = NULL, scannf = TRUE, nf = 2, full = FALSE, tol = 1e-07,
+RaoDecomp = TRUE)
+\method{plot}{dpcoa}(x, xax = 1, yax = 2, \dots)
+\method{print}{dpcoa} (x, \dots)
+\method{summary}{dpcoa} (object, \dots)
+}
+\arguments{
+ \item{df}{a data frame with samples as rows and categories
+ (i.e. species) as columns and abundance or presence-absence as
+ entries. Previous releases of \pkg{ade4} (<=1.6-2) considered the
+ transposed matrix as argument.}
+ \item{dis}{an object of class \code{dist} containing the distances between the categories.}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar
+ plot should be displayed}
+ \item{RaoDecomp}{a logical value indicating whether Rao diversity
+ decomposition should be performed}
+ \item{nf}{if scannf is FALSE, an integer indicating the number of kept axes}
+ \item{full}{a logical value indicating whether all non null eigenvalues should be kept}
+ \item{tol}{a tolerance threshold for null eigenvalues (a value less than tol times the first one is considered as null)}
+ \item{x, object}{an object of class \code{dpcoa}}
+ \item{xax}{the column number for the x-axis}
+ \item{yax}{the column number for the y-axis}
+ \item{\dots}{\code{\dots} further arguments passed to or from other methods}
+}
+\value{
+Returns a list of class \code{dpcoa} containing:
+ \item{call}{call}
+ \item{nf}{a numeric value indicating the number of kept axes}
+ \item{dw}{a numeric vector containing the weights of the elements (was
+ \code{w1} in previous releases of \pkg{ade4})}
+ \item{lw}{a numeric vector containing the weights of the samples (was
+ \code{w2} in previous releases of \pkg{ade4})}
+ \item{eig}{a numeric vector with all the eigenvalues}
+ \item{RaoDiv}{a numeric vector containing diversities within samples}
+ \item{RaoDis}{an object of class \code{dist} containing the dissimilarities between samples}
+ \item{RaoDecodiv}{a data frame with the decomposition of the diversity}
+ \item{dls}{a data frame with the coordinates of the elements (was
+ \code{l1} in previous releases of \pkg{ade4})}
+ \item{li}{a data frame with the coordinates of the samples (was
+ \code{l2} in previous releases of \pkg{ade4})}
+ \item{c1}{a data frame with the scores of the principal axes of the elements}
+}
+
+\references{
+ Pavoine, S., Dufour, A.B. and Chessel, D. (2004) From dissimilarities among species to dissimilarities among communities:
+ a double principal coordinate analysis. \emph{Journal of Theoretical Biology}, \bold{228}, 523--537.
+}
+\author{Daniel Chessel \cr
+Sandrine Pavoine \email{pavoine at mnhn.fr} \cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\examples{
+data(humDNAm)
+dpcoahum <- dpcoa(data.frame(t(humDNAm$samples)), sqrt(humDNAm$distances), scan = FALSE, nf = 2)
+dpcoahum
+if(adegraphicsLoaded()) {
+ g1 <- plot(dpcoahum)
+} else {
+ plot(dpcoahum)
+}
+
+\dontrun{
+data(ecomor)
+dtaxo <- dist.taxo(ecomor$taxo)
+dpcoaeco <- dpcoa(data.frame(t(ecomor$habitat)), dtaxo, scan = FALSE, nf = 2)
+dpcoaeco
+
+if(adegraphicsLoaded()) {
+ g1 <- plot(dpcoaeco)
+} else {
+ plot(dpcoaeco)
+}
+}}
+\keyword{multivariate}
diff --git a/man/dudi.Rd b/man/dudi.Rd
new file mode 100644
index 0000000..122edc2
--- /dev/null
+++ b/man/dudi.Rd
@@ -0,0 +1,79 @@
+\name{dudi}
+\alias{dudi}
+\alias{as.dudi}
+\alias{print.dudi}
+\alias{t.dudi}
+\alias{is.dudi}
+\alias{redo.dudi}
+\alias{summary.dudi}
+\alias{[.dudi}
+\title{Duality Diagram}
+\description{
+\code{as.dudi} is called by many functions (\code{dudi.pca}, \code{dudi.coa}, \code{dudi.acm}, ...)
+and not directly by the user. It creates duality diagrams.
+
+\code{t.dudi} returns an object of class '\code{dudi}' where the rows are the columns and the columns are the rows
+of the initial \code{dudi}.
+
+\code{is.dudi} returns TRUE if the object is of class \code{dudi}
+
+\code{redo.dudi} computes again an analysis, eventually changing the number of kept axes. Used by other functions.\cr
+}
+\usage{
+as.dudi(df, col.w, row.w, scannf, nf, call, type, tol = 1e-07,
+ full = FALSE)
+\method{print}{dudi}(x, \dots)
+is.dudi(x)
+redo.dudi(dudi, newnf = 2)
+\method{t}{dudi}(x)
+\method{summary}{dudi}(object, \dots)
+\method{[}{dudi}(x,i,j)
+}
+\arguments{
+ \item{df}{a data frame with \emph{n} rows and \emph{p} columns}
+ \item{col.w}{a numeric vector containing the row weights}
+ \item{row.w}{a numeric vector containing the column weights}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+ \item{call}{generally \code{match.call()}}
+ \item{type}{a string of characters : the returned list will be of class \code{c(type, "dudi")}}
+ \item{tol}{a tolerance threshold for null eigenvalues (a value less than tol times the first one is considered as null)}
+ \item{full}{a logical value indicating whether all non null eigenvalues should be kept}
+ \item{x, dudi, object}{objects of class \code{dudi}}
+ \item{\dots}{further arguments passed to or from other methods}
+ \item{newnf}{an integer indicating the number of kept axes}
+ \item{i,j}{elements to extract (integer or empty): index of rows (i) and columns (j)}
+}
+\value{
+as.dudi and all the functions that use it return a list with the following components :
+\item{tab}{a data frame with n rows and p columns}
+\item{cw}{column weights, a vector with n components}
+\item{lw}{row (lines) weights, a vector with p components}
+\item{eig}{eigenvalues, a vector with min(n,p) components}
+\item{nf}{integer, number of kept axes}
+\item{c1}{principal axes, data frame with p rows and nf columns}
+\item{l1}{principal components, data frame with n rows and nf columns}
+\item{co}{column coordinates, data frame with p rows and nf columns}
+\item{li}{row coordinates, data frame with n rows and nf columns}
+\item{call}{original call}
+}
+\references{Escoufier, Y. (1987)
+The duality diagram : a means of better practical applications
+In \emph{Development in numerical ecology}, Legendre, P. & Legendre, L. (Eds.)
+NATO advanced Institute, Serie G. Springer Verlag, Berlin, 139--156.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}\cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\examples{
+data(deug)
+dd1 <- dudi.pca(deug$tab, scannf = FALSE)
+dd1
+t(dd1)
+is.dudi(dd1)
+redo.dudi(dd1,3)
+summary(dd1)
+}
+\keyword{multivariate}
diff --git a/man/dudi.acm.Rd b/man/dudi.acm.Rd
new file mode 100644
index 0000000..a67ecb8
--- /dev/null
+++ b/man/dudi.acm.Rd
@@ -0,0 +1,91 @@
+\name{dudi.acm}
+\alias{dudi.acm}
+\alias{acm.burt}
+\alias{acm.disjonctif}
+\alias{boxplot.acm}
+\title{Multiple Correspondence Analysis}
+\description{
+\code{dudi.acm} performs the multiple correspondence analysis of a factor table.\cr
+\code{acm.burt} an utility giving the crossed Burt table of two factors table.\cr
+\code{acm.disjonctif} an utility giving the complete disjunctive table of a factor table.\cr
+\code{boxplot.acm} a graphic utility to interpret axes.\cr
+}
+\usage{
+dudi.acm (df, row.w = rep(1, nrow(df)), scannf = TRUE, nf = 2)
+acm.burt (df1, df2, counts = rep(1, nrow(df1)))
+acm.disjonctif (df)
+\method{boxplot}{acm}(x, xax = 1, \dots)
+}
+\arguments{
+ \item{df, df1, df2}{data frames containing only factors}
+ \item{row.w, counts}{vector of row weights, by default, uniform weighting}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+ \item{x}{an object of class \code{acm}}
+ \item{xax}{the number of factor to display}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+\code{dudi.acm} returns a list of class \code{acm} and \code{dudi} (see \link{dudi}) containing
+\item{cr}{ a data frame which rows are the variables, columns are the kept scores and the values
+are the correlation ratios}
+}
+\references{
+Tenenhaus, M. & Young, F.W. (1985) An analysis and synthesis of multiple correspondence analysis,
+optimal scaling, dual scaling, homogeneity analysis ans other methods for quantifying categorical multivariate data.
+\emph{Psychometrika}, \bold{50}, 1, 91-119.
+
+Lebart, L., A. Morineau, and M. Piron. 1995. Statistique exploratoire multidimensionnelle. Dunod, Paris.
+}
+\seealso{
+ \code{\link{s.chull}}, \code{\link{s.class}}
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(ours)
+summary(ours)
+
+if(adegraphicsLoaded()) {
+ g1 <- s1d.boxplot(dudi.acm(ours, scan = FALSE)$li[, 1], ours)
+} else {
+ boxplot(dudi.acm(ours, scan = FALSE))
+}
+\dontrun{
+data(banque)
+banque.acm <- dudi.acm(banque, scann = FALSE, nf = 3)
+
+if(adegraphicsLoaded()) {
+ g2 <- adegraphics:::scatter.dudi(banque.acm)
+} else {
+ scatter(banque.acm)
+}
+
+apply(banque.acm$cr, 2, mean)
+banque.acm$eig[1:banque.acm$nf] # the same thing
+
+if(adegraphicsLoaded()) {
+ g3 <- s1d.boxplot(banque.acm$li[, 1], banque)
+ g4 <- scatter(banque.acm)
+} else {
+ boxplot(banque.acm)
+ scatter(banque.acm)
+}
+
+
+s.value(banque.acm$li, banque.acm$li[,3])
+
+bb <- acm.burt(banque, banque)
+bbcoa <- dudi.coa(bb, scann = FALSE)
+plot(banque.acm$c1[,1], bbcoa$c1[,1])
+# mca and coa of Burt table. Lebart & coll. section 1.4
+
+bd <- acm.disjonctif(banque)
+bdcoa <- dudi.coa(bd, scann = FALSE)
+plot(banque.acm$li[,1], bdcoa$li[,1])
+# mca and coa of disjonctive table. Lebart & coll. section 1.4
+plot(banque.acm$co[,1], dudi.coa(bd, scann = FALSE)$co[,1])
+}}
+\keyword{multivariate}
diff --git a/man/dudi.coa.Rd b/man/dudi.coa.Rd
new file mode 100644
index 0000000..8814a02
--- /dev/null
+++ b/man/dudi.coa.Rd
@@ -0,0 +1,50 @@
+\name{dudi.coa}
+\alias{dudi.coa}
+\title{Correspondence Analysis}
+\description{
+performs a correspondence analysis.
+}
+\usage{
+dudi.coa(df, scannf = TRUE, nf = 2)
+}
+\arguments{
+ \item{df}{a data frame containing positive or null values}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+}
+\value{
+returns a list of class \code{coa} and \code{dudi} (see \link{dudi}) containing
+ \item{N}{the sum of all the values of the initial table}
+}
+\references{
+Benzécri, J.P. and Coll. (1973) \emph{L'analyse des données. II L'analyse des correspondances}, Bordas, Paris. 1--620.\cr
+
+Greenacre, M. J. (1984) \emph{Theory and applications of correspondence analysis}, Academic Press, London.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(rpjdl)
+chisq.test(rpjdl$fau)$statistic
+rpjdl.coa <- dudi.coa(rpjdl$fau, scannf = FALSE, nf = 4)
+sum(rpjdl.coa$eig)*rpjdl.coa$N # the same
+
+if(adegraphicsLoaded()) {
+ g1 <- s.label(rpjdl.coa$co, plab.cex = 0.6, lab = rpjdl$frlab, plot = FALSE)
+ g2 <- s.label(rpjdl.coa$li, plab.cex = 0.6, plot = FALSE)
+ cbindADEg(g1, g2, plot = TRUE)
+} else {
+ par(mfrow = c(1,2))
+ s.label(rpjdl.coa$co, clab = 0.6, lab = rpjdl$frlab)
+ s.label(rpjdl.coa$li, clab = 0.6)
+ par(mfrow = c(1,1))
+}
+
+data(bordeaux)
+db <- dudi.coa(bordeaux, scan = FALSE)
+db
+score(db)
+}
+\keyword{multivariate}
diff --git a/man/dudi.dec.Rd b/man/dudi.dec.Rd
new file mode 100644
index 0000000..f2ada52
--- /dev/null
+++ b/man/dudi.dec.Rd
@@ -0,0 +1,36 @@
+\name{dudi.dec}
+\alias{dudi.dec}
+\title{Decentred Correspondence Analysis}
+\description{
+performs a decentred correspondence analysis.
+}
+\usage{
+dudi.dec(df, eff, scannf = TRUE, nf = 2)
+}
+\arguments{
+ \item{df}{a data frame containing positive or null values}
+ \item{eff}{a vector containing the reference distribution. Its length is equal to the number of rows of df}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+}
+\value{
+Returns a list of class \code{dec} and \code{dudi} (see \code{\link{dudi}}) containing also
+ \item{R}{sum of all the values of the initial table}
+}
+\references{Dolédec, S., Chessel, D. and Olivier J. M. (1995) L'analyse des correspondances décentrée:
+application aux peuplements ichtyologiques du haut-Rhône.
+\emph{Bulletin Français de la Pêche et de la Pisciculture}, \bold{336}, 29--40.}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(ichtyo)
+dudi1 <- dudi.dec(ichtyo$tab, ichtyo$eff, scan = FALSE)
+sum(apply(ichtyo$tab, 2, function(x)
+ chisq.test(x, p = ichtyo$eff/sum(ichtyo$eff))$statistic))
+sum(dudi1$eig) * sum(ichtyo$eff) # the same
+
+s.class(dudi1$li, ichtyo$dat, wt = ichtyo$eff/sum(ichtyo$eff))
+}
+\keyword{multivariate}
diff --git a/man/dudi.fca.Rd b/man/dudi.fca.Rd
new file mode 100644
index 0000000..54c05f7
--- /dev/null
+++ b/man/dudi.fca.Rd
@@ -0,0 +1,73 @@
+\name{dudi.fca}
+\alias{dudi.fca}
+\alias{dudi.fpca}
+\alias{prep.fuzzy.var}
+\title{Fuzzy Correspondence Analysis and Fuzzy Principal Components Analysis}
+\description{
+ Theses functions analyse a table of fuzzy variables.\cr\cr
+ A fuzzy variable takes values of type \eqn{a=(a_1,\dots,a_k)}{a=(a1,\dots,ak)}
+ giving the importance of k categories.\cr\cr
+ A missing data is denoted (0,...,0).\cr
+ Only the profile a/sum(a) is used, and missing data are replaced by
+ the mean profile of the others in the function \code{prep.fuzzy.var}. See ref. for details.
+}
+\usage{
+prep.fuzzy.var (df, col.blocks, row.w = rep(1, nrow(df)))
+dudi.fca(df, scannf = TRUE, nf = 2)
+dudi.fpca(df, scannf = TRUE, nf = 2)
+}
+\arguments{
+ \item{df}{a data frame containing positive or null values}
+ \item{col.blocks}{a vector containing the number of categories for each fuzzy variable}
+ \item{row.w}{a vector of row weights}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+}
+\value{
+The function \code{prep.fuzzy.var} returns a data frame with the attribute \code{col.blocks}.
+The function \code{dudi.fca} returns a list of class \code{fca} and \code{dudi} (see \link{dudi}) containing also
+\item{cr}{a data frame which rows are the blocs, columns are the kept axes, and values are the correlation ratios.}
+The function \code{dudi.fpca} returns a list of class \code{pca} and \code{dudi} (see \link{dudi}) containing also
+\enumerate{
+\item cent
+\item norm
+\item blo
+\item indica
+\item FST
+\item inertia
+}
+}
+\references{Chevenet, F., Dolédec, S. and Chessel, D. (1994) A fuzzy coding
+approach for the analysis of long-term ecological data. \emph{Freshwater Biology}, \bold{31}, 295--309.}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+w1 <- matrix(c(1,0,0,2,1,1,0,2,2,0,1,0,1,1,1,0,1,3,1,0), 4, 5)
+w1 <- data.frame(w1)
+w2 <- prep.fuzzy.var(w1, c(2, 3))
+w1
+w2
+attributes(w2)
+
+data(bsetal97)
+w <- prep.fuzzy.var(bsetal97$biol, bsetal97$biol.blo)
+
+if(adegraphicsLoaded()) {
+ g1 <- plot(dudi.fca(w, scann = FALSE, nf = 3), plabels.cex = 1.5)
+} else {
+ scatter(dudi.fca(w, scann = FALSE, nf = 3), csub = 3, clab.moda = 1.5)
+ scatter(dudi.fpca(w, scann = FALSE, nf = 3), csub = 3, clab.moda = 1.5)
+}
+
+\dontrun{
+w1 <- prep.fuzzy.var(bsetal97$biol, bsetal97$biol.blo)
+w2 <- prep.fuzzy.var(bsetal97$ecol, bsetal97$ecol.blo)
+d1 <- dudi.fca(w1, scannf = FALSE, nf = 3)
+d2 <- dudi.fca(w2, scannf = FALSE, nf = 3)
+plot(coinertia(d1, d2, scannf = FALSE))
+}
+
+}
+\keyword{multivariate}
diff --git a/man/dudi.hillsmith.Rd b/man/dudi.hillsmith.Rd
new file mode 100644
index 0000000..0963ed3
--- /dev/null
+++ b/man/dudi.hillsmith.Rd
@@ -0,0 +1,53 @@
+\name{dudi.hillsmith}
+\alias{dudi.hillsmith}
+
+\title{ Ordination of Tables mixing quantitative variables and factors }
+\description{ performs a multivariate analysis with mixed quantitative variables and factors.}
+\usage{dudi.hillsmith(df, row.w = rep(1, nrow(df))/nrow(df),
+ scannf = TRUE, nf = 2)
+}
+\arguments{
+ \item{df}{ a data frame with mixed type variables (quantitative and factor) }
+ \item{row.w}{ a vector of row weights, by default uniform row weights are used }
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+}
+\details{
+If \code{df} contains only quantitative variables, this is equivalent to a normed PCA.\cr
+If \code{df} contains only factors, this is equivalent to a MCA.\cr
+
+This analysis is the Hill and Smith method and is very similar to \code{dudi.mix} function.
+The differences are that \code{dudi.hillsmith} allow to use various row weights, while
+\code{dudi.mix} deals with ordered variables.\cr
+The principal components of this analysis are centered and normed vectors maximizing the sum of :\cr
+ squared correlation coefficients with quantitative variables\cr
+ correlation ratios with factors\cr
+}
+\value{
+Returns a list of class \code{mix} and \code{dudi} (see \link{dudi}) containing also
+ \item{index}{a factor giving the type of each variable : f = factor, q = quantitative}
+ \item{assign}{a factor indicating the initial variable for each column of the transformed table}
+ \item{cr}{a data frame giving for each variable and each score:\cr
+ the squared correlation coefficients if it is a quantitative variable\cr
+ the correlation ratios if it is a factor
+ }
+}
+
+\references{ Hill, M. O., and A. J. E. Smith. 1976. Principal component analysis of taxonomic data with multi-state discrete characters.
+\emph{Taxon}, \bold{25}, 249-255. }
+\author{Stéphane Dray \email{stephane.dray at univ-lyon1.fr}\cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+
+\seealso{ \code{dudi.mix}}
+\examples{
+data(dunedata)
+attributes(dunedata$envir$use)$class <- "factor" # use dudi.mix for ordered data
+dd1 <- dudi.hillsmith(dunedata$envir, scann = FALSE)
+if(adegraphicsLoaded()) {
+ g <- scatter(dd1, row.plab.cex = 1, col.plab.cex = 1.5)
+} else {
+ scatter(dd1, clab.r = 1, clab.c = 1.5)
+}}
+
+\keyword{multivariate}
diff --git a/man/dudi.mix.Rd b/man/dudi.mix.Rd
new file mode 100644
index 0000000..f318804
--- /dev/null
+++ b/man/dudi.mix.Rd
@@ -0,0 +1,60 @@
+\name{dudi.mix}
+\alias{dudi.mix}
+\title{Ordination of Tables mixing quantitative variables and factors}
+\description{
+performs a multivariate analysis with mixed quantitative variables and factors.
+}
+\usage{
+dudi.mix(df, add.square = FALSE, scannf = TRUE, nf = 2)
+}
+\arguments{
+ \item{df}{a data frame with mixed type variables (quantitative, factor and ordered)}
+ \item{add.square}{a logical value indicating whether the squares of quantitative variables should be added}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+}
+\details{
+If df contains only quantitative variables, this is equivalent to a normed PCA.\cr
+If df contains only factors, this is equivalent to a MCA.\cr
+Ordered factors are replaced by \code{poly(x,deg=2)}. \cr
+
+This analysis generalizes the Hill and Smith method.\cr
+The principal components of this analysis are centered and normed vectors maximizing the sum of the:\cr
+ squared correlation coefficients with quantitative variables\cr
+ squared multiple correlation coefficients with polynoms\cr
+ correlation ratios with factors. \cr
+}
+\value{
+Returns a list of class \code{mix} and \code{dudi} (see \link{dudi}) containing also
+ \item{index}{a factor giving the type of each variable : f = factor, o = ordered, q = quantitative}
+ \item{assign}{a factor indicating the initial variable for each column of the transformed table}
+ \item{cr}{a data frame giving for each variable and each score:\cr
+ the squared correlation coefficients if it is a quantitative variable\cr
+ the correlation ratios if it is a factor\cr
+ the squared multiple correlation coefficients if it is ordered}
+}
+\references{Hill, M. O., and A. J. E. Smith. 1976. Principal component analysis of taxonomic data with multi-state discrete characters. \emph{Taxon}, \bold{25}, 249-255.\cr\cr
+De Leeuw, J., J. van Rijckevorsel, and . 1980. HOMALS and PRINCALS - Some generalizations of principal components analysis. Pages 231-242 in E. Diday and Coll., editors. Data Analysis and Informatics II. Elsevier Science Publisher, North Holland, Amsterdam.\cr\cr
+Kiers, H. A. L. 1994. Simple structure in component analysis techniques for mixtures of qualitative ans quantitative variables. \emph{Psychometrika}, \bold{56}, 197-212.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(dunedata)
+dd1 <- dudi.mix(dunedata$envir, scann = FALSE)
+if(adegraphicsLoaded()) {
+ g1 <- scatter(dd1, row.plab.cex = 1, col.plab.cex = 1.5)
+} else {
+ scatter(dd1, clab.r = 1, clab.c = 1.5)
+}
+
+dd2 <- dudi.mix(dunedata$envir, scann = FALSE, add.square = TRUE)
+if(adegraphicsLoaded()) {
+ g2 <- scatter(dd2, row.plab.cex = 1, col.plab.cex = 1.5)
+} else {
+ scatter(dd2, clab.r = 1, clab.c = 1.5)
+}
+}
+\keyword{multivariate}
diff --git a/man/dudi.nsc.Rd b/man/dudi.nsc.Rd
new file mode 100644
index 0000000..22ea2e6
--- /dev/null
+++ b/man/dudi.nsc.Rd
@@ -0,0 +1,36 @@
+\name{dudi.nsc}
+\alias{dudi.nsc}
+\title{Non symmetric correspondence analysis}
+\description{
+performs a non symmetric correspondence analysis.
+}
+\usage{
+dudi.nsc(df, scannf = TRUE, nf = 2)
+}
+\arguments{
+ \item{df}{a data frame containing positive or null values}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+}
+\value{
+Returns a list of class \code{nsc} and \code{dudi} (see \code{\link{dudi}}) containing also
+ \item{N}{sum of the values of the initial table}
+}
+\references{Kroonenberg, P. M., and Lombardo R. (1999) Nonsymmetric correspondence analysis:
+a tool for analysing contingency tables with a dependence structure. \emph{Multivariate Behavioral Research}, \bold{34}, 367--396.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(housetasks)
+nsc1 <- dudi.nsc(housetasks, scan = FALSE)
+if(adegraphicsLoaded()) {
+ g1 <- s.label(nsc1$c1, plab.cex = 1.25)
+ g2 <- s.arrow(nsc1$li, add = TRUE, plab.cex = 0.75)
+} else {
+ s.label(nsc1$c1, clab = 1.25)
+ s.arrow(nsc1$li, add.pl = TRUE, clab = 0.75) # see ref p.383
+}}
+\keyword{multivariate}
diff --git a/man/dudi.pca.Rd b/man/dudi.pca.Rd
new file mode 100644
index 0000000..7b31d1c
--- /dev/null
+++ b/man/dudi.pca.Rd
@@ -0,0 +1,85 @@
+\name{dudi.pca}
+\alias{dudi.pca}
+\title{Principal Component Analysis}
+\description{
+\code{dudi.pca} performs a principal component analysis of a data frame and
+returns the results as objects of class \code{pca} and \code{dudi}.
+}
+\usage{
+dudi.pca(df, row.w = rep(1, nrow(df))/nrow(df),
+ col.w = rep(1, ncol(df)), center = TRUE, scale = TRUE,
+ scannf = TRUE, nf = 2)
+}
+\arguments{
+ \item{df}{a data frame with n rows (individuals) and p columns (numeric variables)}
+ \item{row.w}{an optional row weights (by default, uniform row weights)}
+ \item{col.w}{an optional column weights (by default, unit column weights)}
+ \item{center}{a logical or numeric value, centring option\cr
+ if TRUE, centring by the mean\cr
+ if FALSE no centring\cr
+ if a numeric vector, its length must be equal to the number of columns of the data frame df
+ and gives the decentring}
+ \item{scale}{a logical value indicating whether the column vectors should be normed for the row.w weighting}
+ \item{scannf}{a logical value indicating whether the screeplot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+}
+\value{
+Returns a list of classes \code{pca} and \code{dudi} (see \link{dudi}) containing the used information
+for computing the principal component analysis :
+ \item{tab}{the data frame to be analyzed depending of the transformation arguments (center and scale)}
+ \item{cw}{the column weights}
+ \item{lw}{the row weights}
+ \item{eig}{the eigenvalues}
+ \item{rank}{the rank of the analyzed matrice}
+ \item{nf}{the number of kept factors}
+ \item{c1}{the column normed scores i.e. the principal axes}
+ \item{l1}{the row normed scores}
+ \item{co}{the column coordinates}
+ \item{li}{the row coordinates i.e. the principal components}
+ \item{call}{the call function}
+ \item{cent}{the \emph{p} vector containing the means for variables (Note that if \code{center = F}, the vector contains \emph{p} 0)}
+ \item{norm}{the \emph{p} vector containing the standard deviations for variables i.e. the root
+ of the sum of squares deviations of the values from their means divided by \emph{n} (Note that if \code{norm = F}, the vector contains \emph{p} 1)}
+}
+\seealso{
+ \code{prcomp}, \code{princomp} in the \code{mva} library
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(deug)
+deug.dudi <- dudi.pca(deug$tab, center = deug$cent, scale = FALSE, scan = FALSE)
+deug.dudi1 <- dudi.pca(deug$tab, center = TRUE, scale = TRUE, scan = FALSE)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.class(deug.dudi$li, deug$result, plot = FALSE)
+ g2 <- s.arrow(deug.dudi$c1, lab = names(deug$tab), plot = FALSE)
+ g3 <- s.class(deug.dudi1$li, deug$result, plot = FALSE)
+ g4 <- s.corcircle(deug.dudi1$co, lab = names(deug$tab), full = FALSE, plot = FALSE)
+ G1 <- rbindADEg(cbindADEg(g1, g2, plot = FALSE), cbindADEg(g3, g4, plot = FALSE), plot = TRUE)
+
+ G2 <- s1d.hist(deug.dudi$tab, breaks = seq(-45, 35, by = 5), type = "density", xlim = c(-40, 40),
+ right = FALSE, ylim = c(0, 0.1), porigin.lwd = 2)
+
+} else {
+ par(mfrow = c(2, 2))
+ s.class(deug.dudi$li, deug$result, cpoint = 1)
+ s.arrow(deug.dudi$c1, lab = names(deug$tab))
+ s.class(deug.dudi1$li, deug$result, cpoint = 1)
+ s.corcircle(deug.dudi1$co, lab = names(deug$tab), full = FALSE, box = TRUE)
+ par(mfrow = c(1, 1))
+
+ # for interpretations
+ par(mfrow = c(3, 3))
+ par(mar = c(2.1, 2.1, 2.1, 1.1))
+ for(i in 1:9) {
+ hist(deug.dudi$tab[,i], xlim = c(-40, 40), breaks = seq(-45, 35, by = 5),
+ prob = TRUE, right = FALSE, main = names(deug$tab)[i], xlab = "", ylim = c(0, 0.10))
+ abline(v = 0, lwd = 3)
+ }
+ par(mfrow = c(1, 1))
+}
+}
+\keyword{multivariate}
diff --git a/man/dudi.pco.Rd b/man/dudi.pco.Rd
new file mode 100644
index 0000000..3fa0857
--- /dev/null
+++ b/man/dudi.pco.Rd
@@ -0,0 +1,56 @@
+\name{dudi.pco}
+\alias{dudi.pco}
+\alias{scatter.pco}
+\title{Principal Coordinates Analysis}
+\description{
+\code{dudi.pco} performs a principal coordinates analysis of a Euclidean distance matrix
+and returns the results as objects of class \code{pco} and \code{dudi}.
+}
+\usage{
+dudi.pco(d, row.w = "uniform", scannf = TRUE, nf = 2,
+ full = FALSE, tol = 1e-07)
+\method{scatter}{pco}(x, xax = 1, yax = 2, clab.row = 1, posieig = "top",
+ sub = NULL, csub = 2, \dots)
+}
+\arguments{
+ \item{d}{an object of class \code{dist} containing a Euclidean distance matrix.}
+ \item{row.w}{an optional distance matrix row weights.
+ If not NULL, must be a vector of positive numbers with length equal to the size of the distance matrix}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+ \item{full}{a logical value indicating whether all the axes should be kept}
+ \item{tol}{a tolerance threshold to test whether the distance matrix is Euclidean :
+ an eigenvalue is considered positive if it is larger than
+ \code{-tol*lambda1} where \code{lambda1} is the largest eigenvalue.}\cr\cr
+
+ \item{x}{an object of class \code{pco}}
+ \item{xax}{the column number for the x-axis}
+ \item{yax}{the column number for the y-axis}
+ \item{clab.row}{a character size for the row labels}
+ \item{posieig}{if "top" the eigenvalues bar plot is upside,
+ if "bottom" it is downside, if "none" no plot}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+\code{dudi.pco} returns a list of class \code{pco} and \code{dudi}. See \code{\link{dudi}}
+}
+\references{Gower, J. C. (1966) Some distance properties of latent root and vector methods used in multivariate analysis. \emph{Biometrika}, \bold{53}, 325--338.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(yanomama)
+gen <- quasieuclid(as.dist(yanomama$gen))
+geo <- quasieuclid(as.dist(yanomama$geo))
+ant <- quasieuclid(as.dist(yanomama$ant))
+geo1 <- dudi.pco(geo, scann = FALSE, nf = 3)
+gen1 <- dudi.pco(gen, scann = FALSE, nf = 3)
+ant1 <- dudi.pco(ant, scann = FALSE, nf = 3)
+plot(coinertia(ant1, gen1, scann = FALSE))
+}
+\keyword{array}
+\keyword{multivariate}
diff --git a/man/dunedata.Rd b/man/dunedata.Rd
new file mode 100644
index 0000000..001391e
--- /dev/null
+++ b/man/dunedata.Rd
@@ -0,0 +1,26 @@
+\name{dunedata}
+\alias{dunedata}
+\docType{data}
+\title{Dune Meadow Data}
+\description{
+\code{dunedata} is a data set containing for 20 sites, environmental variables and plant species.
+}
+\usage{data(dunedata)}
+\format{
+ \code{dunedata} is a list with 2 components.
+ \describe{
+ \item{envir}{is a data frame with 20 rows (sites) 5 columns (environnemental variables).}
+ \item{veg}{is a data frame with 20 rows (sites) 30 columns (plant species).}
+ }
+}
+\source{
+ Jongman, R. H., ter Braak, C. J. F. and van Tongeren, O. F. R. (1987)
+ \emph{Data analysis in community and landscape ecology}, Pudoc, Wageningen.
+}
+\examples{
+data(dunedata)
+summary(dunedata$envir)
+is.ordered(dunedata$envir$use)
+score(dudi.mix(dunedata$envir, scan = FALSE))
+}
+\keyword{datasets}
diff --git a/man/ecg.Rd b/man/ecg.Rd
new file mode 100644
index 0000000..e6c8d45
--- /dev/null
+++ b/man/ecg.Rd
@@ -0,0 +1,43 @@
+\name{ecg}
+\alias{ecg}
+\docType{data}
+\title{Electrocardiogram data}
+\description{
+These data were measured during the normal sinus rhythm of a patient who occasionally experiences arrhythmia.
+There are 2048 observations measured in units of millivolts and collected at a rate of 180 samples per second.
+This time series is a good candidate for a multiresolution analysis because its components are on different scales.
+For example, the large scale (low frequency) fluctuations, known as baseline drift, are due to the patient respiration,
+while the prominent short scale (high frequency) intermittent fluctuations between 3 and 4 seconds are evidently due to patient movement.
+Heart rhythm determines most of the remaining features in the series.
+The large spikes occurring about 0.7 seconds apart the R waves of normal heart rhythm;
+the smaller, but sharp peak coming just prior to an R wave is known as a P wave;
+and the broader peak that comes after a R wave is a T wave.
+}
+\usage{data(ecg)}
+\format{
+A vector of class \code{ts} containing 2048 observations.
+}
+\source{
+Gust Bardy and Per Reinhall, University of Washington
+}
+\references{
+Percival, D. B., and Walden, A.T. (2000) \emph{Wavelet Methods for Time Series Analysis}, Cambridge University Press.
+}
+\examples{
+\dontrun{
+# figure 130 in Percival and Walden (2000)
+if (requireNamespace("waveslim") == TRUE) {
+data(ecg)
+ecg.level <- haar2level(ecg)
+ecg.haar <- orthobasis.haar(length(ecg))
+ecg.mld <- mld(ecg, ecg.haar, ecg.level, plot = FALSE)
+res <- cbind.data.frame(apply(ecg.mld[,1:5],1,sum), ecg.mld[,6:11])
+par(mfrow = c(8,1))
+par(mar = c(2, 5, 1.5, 0.6))
+plot(as.ts(ecg), ylab = "ECG")
+apply(res, 2, function(x) plot(as.ts(x), ylim = range(res),
+ ylab = ""))
+par(mfrow = c(1,1))
+}}
+}
+\keyword{datasets}
diff --git a/man/ecomor.Rd b/man/ecomor.Rd
new file mode 100644
index 0000000..e1e72ec
--- /dev/null
+++ b/man/ecomor.Rd
@@ -0,0 +1,87 @@
+\name{ecomor}
+\alias{ecomor}
+\docType{data}
+\title{Ecomorphological Convergence}
+\description{
+This data set gives ecomorphological informations about 129 bird species.
+}
+\usage{data(ecomor)}
+\format{
+ \code{ecomor} is a list of 7 components.
+\describe{
+ \item{forsub}{is a data frame with 129 species, 6 variables (the feeding place classes):
+ foliage, ground , twig , bush, trunk and aerial feeders. These dummy variables indicate the use (1)
+ or no use (0) of a given feeding place by a species. }
+ \item{diet}{is a data frame with 129 species and 8 variables (diet types): Gr (granivorous: seeds),
+ Fr (frugivorous: berries, acorns, drupes), Ne (frugivorous: nectar), Fo (folivorous: leaves),
+ In (invertebrate feeder: insects, spiders, myriapods, isopods, snails, worms),
+ Ca (carnivorous: flesh of small vertebrates), Li (limnivorous: invertebrates in fresh water),
+ and Ch (carrion feeder). These dummy variables indicate the use (1)
+ or no use (0) of a given diet type by a species.}
+ \item{habitat}{is a data frame with 129 species, 16 dummy variables (the habitats).
+ These variables indicate the species presence (1) or the species absence (0) in a given habitat.}
+ \item{morpho}{is a data frame with 129 species abd 8 morphological variables: wingl (Wing length, mm),
+ taill (Tail length, mm), culml (Culmen length, mm), bilh (Bill height, mm), bilw (Bill width, mm),
+ tarsl (Tarsus length, mm), midtl (Middle toe length, mm) and weig (Weight, g).}
+ \item{taxo}{is a data frame with 129 species and 3 factors: Genus, Family and Order.
+ It is a data frame of class \code{'taxo'}: the variables are factors giving nested classifications.}
+ \item{labels}{is a data frame with vectors of the names of species (complete and in abbreviated form.}
+ \item{categ}{is a data frame with 129 species, 2 factors : 'forsub' summarizing the feeding place and
+ 'diet' the diet type.}
+}}
+\source{
+Blondel, J., Vuilleumier, F., Marcus, L.F., and Terouanne, E. (1984). Is there ecomorphological convergence
+among mediterranean bird communities of Chile, California, and France. In \emph{Evolutionary Biology}
+(eds M.K. Hecht, B. Wallace and R.J. MacIntyre), 141--213, \bold{18}. Plenum Press, New York.
+}
+\references{
+See a data description at \url{http://pbil.univ-lyon1.fr/R/pdf/pps023.pdf} (in French).
+}
+\examples{
+data(ecomor)
+ric <- apply(ecomor$habitat, 2, sum)
+s.corcircle(dudi.pca(log(ecomor$morpho), scan = FALSE)$co)
+
+forsub <- data.frame(t(apply(ecomor$forsub, 1, function (x) x / sum(x))))
+pca1 <- dudi.pca(forsub, scan = FALSE, scale = FALSE)
+w1 <- as.matrix(forsub)%*%as.matrix(pca1$c1)
+if(adegraphicsLoaded()) {
+ g1 <- s.arrow(pca1$c1, plot = FALSE)
+ g2 <- s.label(w1, plab.cex = 0, ppoi.cex = 2, plot = FALSE)
+ G1 <- superpose(g1, g2, plot = TRUE)
+} else {
+ s.arrow(pca1$c1)
+ s.label(w1, clab = 0, add.p = TRUE, cpoi = 2)
+}
+
+diet <- data.frame(t(apply(ecomor$diet, 1, function (x) x / sum(x))))
+pca2 <- dudi.pca(diet, scan = FALSE, scale = FALSE)
+w2 <- as.matrix(diet)%*%as.matrix(pca2$c1)
+if(adegraphicsLoaded()) {
+ g3 <- s.arrow(pca2$c1, plot = FALSE)
+ g4 <- s.label(w2, plab.cex = 0, ppoi.cex = 2, plot = FALSE)
+ G2 <- superpose(g3, g4, plot = TRUE)
+} else {
+ s.arrow(pca2$c1)
+ s.label(w2, clab = 0, add.p = TRUE, cpoi = 2)
+}
+
+
+\dontrun{
+dmorpho <- dist.quant(log(ecomor$morpho), 3)
+dhabitat <- dist.binary(ecomor$habitat, 1)
+dtaxo <- dist.taxo(ecomor$taxo)
+
+mantel.randtest(dmorpho, dhabitat)
+RV.rtest(pcoscaled(dmorpho), pcoscaled(dhabitat), 999)
+procuste.randtest(pcoscaled(dmorpho), pcoscaled(dhabitat))
+
+ecophy <- taxo2phylog(ecomor$taxo, add.tools=TRUE)
+table.phylog(ecomor$habitat, ecophy, clabel.n = 0.5, f = 0.6,
+ clabel.c = 0.75, clabel.r = 0.5, csi = 0.75, cleg = 0)
+plot(ecophy, clabel.n = 0.75, clabel.l = 0.75,
+ labels.l = ecomor$labels[,"latin"])
+mantel.randtest(dmorpho, dtaxo)
+mantel.randtest(dhabitat, dtaxo)
+}}
+\keyword{datasets}
diff --git a/man/elec88.Rd b/man/elec88.Rd
new file mode 100644
index 0000000..ffc325e
--- /dev/null
+++ b/man/elec88.Rd
@@ -0,0 +1,75 @@
+\name{elec88}
+\alias{elec88}
+\docType{data}
+
+\title{Electoral Data}
+
+\description{This data set gives the results of the presidential election in France in 1988 for each department and all the candidates.}
+
+\usage{data(elec88)}
+
+\format{
+ \code{elec88} is a list of 10 components:
+ \describe{
+ \item{tab}{is a data frame with 94 rows (departments) and 9 variables (candidates)}
+ \item{res}{is the global result of the election all-over the country.}
+ \item{lab}{is a data frame with three variables:
+ \code{elec88$lab$dep} a vector containing the names of the 94 french departments,
+ \code{elec88$lab$reg} a vector containing the names of the 21 French administraitve regions.}
+ \item{area}{is the data frame of 3 variables returning the boundary lines of each department.
+ The first variable is a factor. The levels of this one are the row.names of \code{tab}.
+ The second and third variables return the coordinates (x, y) of the points of the boundary line.}
+ \item{contour}{is a data frame with 4 variables (x1, y1, x2, y2) for the contour display of France}
+ \item{xy}{is a data frame with two variables (x, y) giving the position of the center for each department}
+ \item{neig}{is the neighbouring graph between departments, object of the class \code{neig}}
+ \item{nb}{is the neighbouring graph between departments, object of the class \code{nb}}
+ \item{Spatial}{is the map of the french departments in Lambert II coordinates (an object of the class \code{SpatialPolygons} of \code{sp}).}
+ \item{Spatial.contour}{is the contour of the map of France in Lambert II coordinates (an object of the class \code{SpatialPolygons} of \code{sp}).}
+}}
+
+\source{Public data}
+
+\seealso{This dataset is compatible with \code{presid2002} and \code{cnc2003}}
+
+\examples{
+data(elec88)
+apply(elec88$tab, 2, mean)
+summary(elec88$res)
+pca1 <- dudi.pca(elec88$tab, scale = FALSE, scannf = FALSE)
+
+if(adegraphicsLoaded()) {
+ if(requireNamespace("sp", quietly = TRUE)) {
+ data1 <- as.data.frame(as.numeric(rownames(elec88$tab) == "D25"))
+ rownames(data1) <- row.names(elec88$Spatial)
+ obj1 <- sp::SpatialPolygonsDataFrame(Sr = elec88$Spatial, data = data1)
+ g1 <- s.Spatial(obj1, psub.text = "", plot = FALSE)
+ g2 <- s.Spatial(obj1, psub.text = "", nb = elec88$nb, pnb.node.cex = 0, plot = FALSE)
+
+ data3 <- as.data.frame(elec88$xy[, 1] + elec88$xy[, 2])
+ rownames(data3) <- row.names(elec88$Spatial)
+ obj3 <- sp::SpatialPolygonsDataFrame(Sr = elec88$Spatial, data = data3)
+ g3 <- s.Spatial(obj3, psub.text = "", plot = FALSE)
+
+ data4 <- as.data.frame(pca1$li[, 1])
+ rownames(data4) <- row.names(elec88$Spatial)
+ obj4 <- sp::SpatialPolygonsDataFrame(Sr = elec88$Spatial, data = data4)
+ g4 <- s.Spatial(obj4, psub.text = "F1 PCA", plot = FALSE)
+
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+ }
+
+} else {
+ par(mfrow = c(2, 2))
+ plot(elec88$area[, 2:3], type = "n", asp = 1)
+ lpoly <- split(elec88$area[, 2:3], elec88$area[, 1])
+ lapply(lpoly, function(x) {points(x, type = "l"); invisible()})
+ polygon(elec88$area[elec88$area$V1 == "D25", 2:3], col = 1)
+ area.plot(elec88$area, graph = elec88$neig, lwdg = 1)
+ polygon(elec88$area[elec88$area$V1 == "D25", 2:3], col = 1)
+ area.plot(elec88$area, val = elec88$xy[, 1] + elec88$xy[, 2])
+ area.plot(elec88$area, val = pca1$li[, 1], sub = "F1 PCA",
+ csub = 2, cleg = 1.5)
+ par(mfrow = c(1, 1))
+}}
+
+\keyword{datasets}
\ No newline at end of file
diff --git a/man/escopage.Rd b/man/escopage.Rd
new file mode 100644
index 0000000..11578ed
--- /dev/null
+++ b/man/escopage.Rd
@@ -0,0 +1,34 @@
+\name{escopage}
+\alias{escopage}
+\docType{data}
+\title{K-tables of wine-tasting}
+\description{
+This data set describes 27 characteristics of 21 wines distributed in four fields :
+rest, visual, olfactory and global.
+}
+\usage{data(escopage)}
+\format{
+ \code{escopage} is a list of 3 components.
+ \describe{
+ \item{tab}{is a data frame with 21 observations (wines) and 27 variables. }
+ \item{tab.names}{is the vector of the names of sub-tables : "rest" "visual" "olfactory" "global".}
+ \item{blo}{is a vector of the numbers of variables for each sub-table.}
+ }
+}
+\source{
+Escofier, B. and Pagès, J. (1990)
+\emph{Analyses factorielles simples et multiples : objectifs, méthodes et interprétation}
+Dunod, Paris. 1--267.
+
+Escofier, B. and Pagès, J. (1994)
+Multiple factor analysis (AFMULT package).
+\emph{Computational Statistics and Data Analysis}, \bold{18}, 121--140.
+}
+\examples{
+data(escopage)
+w <- data.frame(scale(escopage$tab))
+w <- ktab.data.frame(w, escopage$blo)
+names(w)[1:4] <- escopage$tab.names
+plot(mfa(w, scan = FALSE))
+}
+\keyword{datasets}
diff --git a/man/euro123.Rd b/man/euro123.Rd
new file mode 100644
index 0000000..4e6ec6d
--- /dev/null
+++ b/man/euro123.Rd
@@ -0,0 +1,44 @@
+\name{euro123}
+\alias{euro123}
+\docType{data}
+\title{Triangular Data}
+\description{
+This data set gives the proportions of employement in the primary, secondary and tertiary
+sectors for 12 European countries in 1978, 1986 and 1997.
+}
+\usage{data(euro123)}
+\format{
+ \code{euro123} is a list of 4 components.
+ \describe{
+ \item{in78}{is a data frame with 12 rows and 3 variables.}
+ \item{in86}{: idem in 1986}
+ \item{in97}{: idem in 1997}
+ \item{plan}{is a data frame with two factors to both organize the 3 tables.}
+ }
+}
+\source{
+Encyclopaedia Universalis, Symposium, Les chiffres du Monde. Encyclopaedia Universalis, Paris. 519.
+}
+\examples{
+data(euro123)
+
+if(adegraphicsLoaded()) {
+ g1 <- triangle.label(euro123$in78, addaxes = TRUE, plabels.cex = 0,
+ plot = FALSE)
+ g2 <- triangle.label(euro123$in86, addaxes = TRUE, plabels.cex = 0,
+ plot = FALSE)
+ g3 <- triangle.label(euro123$in97, addaxes = TRUE, plabels.cex = 0,
+ plot = FALSE)
+ g4 <- triangle.match(euro123$in78, euro123$in97, plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2,2))
+ triangle.plot(euro123$in78, addaxes = TRUE)
+ triangle.plot(euro123$in86, addaxes = TRUE)
+ triangle.plot(euro123$in97, addaxes = TRUE)
+ triangle.biplot(euro123$in78, euro123$in97)
+ par(mfrow = c(1,1))
+}}
+
+\keyword{datasets}
diff --git a/man/fission.Rd b/man/fission.Rd
new file mode 100644
index 0000000..6c04d91
--- /dev/null
+++ b/man/fission.Rd
@@ -0,0 +1,26 @@
+\name{fission}
+\alias{fission}
+\docType{data}
+\title{Fission pattern and heritable morphological traits}
+\description{
+This data set contains the mean values of five highly heritable linear combinations of cranial metric (GM1-GM3) and non metric (GN1-GN2) for 8 social groups of Rhesus Macaques on Cayo Santiago. It also describes the fission tree depicting the historical phyletic relationships.
+}
+\usage{data(fission)}
+\format{
+\code{fission} is a list containing the 2 following objects :
+\describe{
+ \item{tre}{is a character string giving the fission tree in Newick format.}
+ \item{tab}{is a data frame with 8 social groups and five traits : cranial metrics (GM1, GM2, GM3) and
+ cranial non metrics (GN1, GN2)}}
+}
+\references{
+Cheverud, J. and Dow, M.M. (1985) An autocorrelation analysis of genetic variation due to lineal fission in social groups of rhesus macaques.
+\emph{American Journal of Physical Anthropology}, \bold{67}, 113--122.
+}
+\examples{
+data(fission)
+fis.phy <- newick2phylog(fission$tre)
+table.phylog(fission$tab[names(fis.phy$leaves),], fis.phy, csi = 2)
+gearymoran(fis.phy$Amat, fission$tab)
+}
+\keyword{datasets}
diff --git a/man/foucart.Rd b/man/foucart.Rd
new file mode 100644
index 0000000..a1f63af
--- /dev/null
+++ b/man/foucart.Rd
@@ -0,0 +1,77 @@
+\name{foucart}
+\alias{foucart}
+\alias{plot.foucart}
+\alias{print.foucart}
+\title{K-tables Correspondence Analysis with the same rows and the same columns}
+\description{
+ K tables have the same rows and the same columns.\cr
+ Each table is transformed by P = X/sum(X). The average of P is computing.\cr
+ A correspondence analysis is realized on this average.\cr
+ The initial rows and the initial columns are projected in supplementary elements.
+}
+\usage{
+foucart(X, scannf = TRUE, nf = 2)
+\method{plot}{foucart}(x, xax = 1, yax = 2, clab = 1, csub = 2,
+ possub = "bottomright", \dots)
+\method{print}{foucart}(x, \dots)
+}
+\arguments{
+ \item{X}{a list of data frame where the row names and the column names are the same for each table}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+ \cr
+ \item{x}{an object of class 'foucart'}
+ \item{xax}{the column number of the x-axis}
+ \item{yax}{the column number of the y-axis}
+ \item{clab}{if not NULL, a character size for the labels, used with \code{par("cex")*clab}}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{\dots}{further arguments passed to or from other methods}
+
+}
+\value{
+ \code{foucart} returns a list of the classes 'dudi', 'coa' and 'foucart'
+ \item{call}{origine}
+ \item{nf}{axes-components saved}
+ \item{rank}{rank}
+ \item{blo}{useful vector}
+ \item{cw}{vector: column weights}
+ \item{lw}{vector: row weights}
+ \item{eig}{vector: eigen values}
+ \item{tab}{data.frame: modified array}
+ \item{li}{data.frame: row coordinates}
+ \item{l1}{data.frame: row normed scores}
+ \item{co}{data.frame: column coordinates}
+ \item{c1}{data.frame: column normed scores}
+ \item{Tli}{data.frame: row coordinates (each table)}
+ \item{Tco}{data.frame: col coordinates (each table)}
+ \item{TL}{data.frame: factors for Tli}
+ \item{TC}{data.frame: factors for Tco}
+}
+\references{Foucart, T. (1984) \emph{Analyse factorielle de tableaux multiples}, Masson, Paris.
+}
+
+\author{Pierre Bady \email{pierre.bady at univ-lyon1.fr}\cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+
+\examples{
+data(bf88)
+fou1 <- foucart(bf88, scann = FALSE, nf = 3)
+fou1
+plot(fou1)
+
+data(meaudret)
+l1 <- split(meaudret$spe, meaudret$design$season)
+l1 <- lapply(l1, function(x)
+ {row.names(x) <- paste("Sit",1:5,sep="");x})
+fou2 <- foucart(l1, scan = FALSE)
+
+if(adegraphicsLoaded()) {
+ kplot(fou2, row.plabels.cex = 2)
+} else {
+ kplot(fou2, clab.r = 2)
+}
+}
+
+\keyword{multivariate}
diff --git a/man/fourthcorner.Rd b/man/fourthcorner.Rd
new file mode 100644
index 0000000..eea6a14
--- /dev/null
+++ b/man/fourthcorner.Rd
@@ -0,0 +1,170 @@
+\name{fourthcorner}
+\alias{fourthcorner}
+\alias{fourthcorner2}
+\alias{print.4thcorner}
+\alias{summary.4thcorner}
+\alias{plot.4thcorner}
+\alias{fourthcorner.rlq}
+
+\title{ Functions to compute the fourth-corner statistic }
+\description{
+ These functions allow to compute the fourth-corner statistic for abundance or presence-absence data. The fourth-corner statistic has been developed by Legendre et al (1997) and extended in Dray and Legendre (2008). The statistic measures the link between three tables: a table L (n x p) containing the abundances of p species at n sites, a second table R (n x m) with the measurements of m environmental variables for the n sites, and a third table Q (p x s) describing s species traits for [...]
+}
+\usage{
+fourthcorner(tabR, tabL, tabQ, modeltype = 6, nrepet = 999, tr01 =
+FALSE, p.adjust.method.G = p.adjust.methods, p.adjust.method.D =
+p.adjust.methods, p.adjust.D = c("global", "levels"), ...)
+fourthcorner2(tabR, tabL, tabQ, modeltype = 6, nrepet = 999, tr01 =
+FALSE, p.adjust.method.G = p.adjust.methods, ...)
+\method{print}{4thcorner}(x, varQ = 1:length(x$varnames.Q), varR =
+1:length(x$varnames.R), stat = c("D", "D2"), ...)
+\method{summary}{4thcorner}(object,...)
+\method{plot}{4thcorner}(x, stat = c("D", "D2", "G"), type = c("table",
+"biplot"), xax = 1, yax = 2, x.rlq = NULL, alpha = 0.05, col =
+c("lightgrey", "red", "deepskyblue", "purple"), ...)
+fourthcorner.rlq(xtest, nrepet = 999, modeltype = 6, typetest =
+c("axes", "Q.axes", "R.axes"), p.adjust.method.G = p.adjust.methods,
+p.adjust.method.D = p.adjust.methods, p.adjust.D = c("global",
+"levels"), ...)
+}
+
+\arguments{
+ \item{tabR}{ a dataframe with the measurements of m environmental variables (columns) for the n sites (rows).}
+ \item{tabL}{ a dataframe containing the abundances of p species (columns) at n sites (rows).}
+ \item{tabQ}{ a dataframe describing s species traits (columns) for the p species (rows).}
+ \item{modeltype}{ an integer (1-6) indicating the permutation model used in the testing procedure (see details). }
+ \item{nrepet}{ the number of permutations }
+ \item{tr01}{ a logical indicating if data in \code{tabL} must be transformed to presence-absence data (FALSE by default)}
+ \item{object}{ an object of the class 4thcorner}
+ \item{x}{ an object of the class 4thcorner}
+ \item{varR}{ a vector with indices for variables in \code{tabR}}
+ \item{varQ}{ a vector with indices for variables in \code{tabQ}}
+ \item{type}{ results are represented by a table or on a biplot (see x.rlq)}
+ \item{alpha}{ a value of significance level}
+ \item{p.adjust.method.G}{a string indicating a method for multiple
+ adjustment used for output tabG, see \code{\link[stats]{p.adjust.methods}} for possible choices}
+ \item{p.adjust.method.D}{a string indicating a method for multiple
+ adjustment used for output tabD/tabD2, see \code{p.adjust.methods} for possible choices}
+ \item{p.adjust.D}{a string indicating if multiple adjustment for
+ tabD/tabD2 should be done globally or only between levels of a factor
+ ("levels", as in the original paper of Legendre et al. 1997)}
+ \item{stat}{a character to specify if results should be plotted for
+ cells (D and D2) or variables (G)}
+ \item{xax}{an integer indicating which rlq axis should be plotted on the x-axis}
+ \item{yax}{an integer indicating which rlq axis should be plotted on the y-axis}
+ \item{x.rlq}{an object created by the \code{rlq} function. Used to
+ represent results on a biplot (type should be "biplot" and object
+ created by the \code{fourthcorner} functions)}
+ \item{col}{a vector of length 4 containing four colors used for the
+ graphical representations. The first is used to represent non-significant
+ associations, the second positive significant, the third negative
+ significant. For the 'biplot' method and objects created by the
+ \code{fourthcorner.rlq} function, the second corresponds to variables
+ significantly linked
+ to the x-axis, the third for the y-axis and the fourth for both axes}
+ \item{xtest}{an object created by the \code{rlq} function}
+ \item{typetest}{a string indicating which tests should be performed}
+ \item{\dots}{further arguments passed to or from other methods}
+
+}
+\details{
+For the \code{fourthcorner} function, the link is measured by a Pearson correlation coefficient for two quantitative variables (trait and environmental variable), by a Pearson Chi2 and G statistic for two qualitative variables and by a Pseudo-F and Pearson r for one quantitative variable and one qualitative variable. The fourthcorner2 function offers a multivariate statistic (equal to the sum of eigenvalues of RLQ analysis) and measures the link between two variables by a square correlat [...]
+\itemize{
+\item model 1 (\code{modeltype}=1): Permute values for each species independently (i.e., permute within each column of table L)
+\item model 2 (\code{modeltype}=2): Permute values of sites (i.e., permute entire rows of table L)
+\item model 3 (\code{modeltype}=3): Permute values for each site independently (i.e., permute within each row of table L)
+\item model 4 (\code{modeltype}=4): Permute values of species (i.e., permute entire columns of table L)
+\item model 5 (\code{modeltype}=5): Permute values of species and after
+(or before) permute values of sites (i.e., permute entire columns and
+after (or before) entire rows of table L)
+\item model 6 (\code{modeltype}=6): combination of the outputs of models
+2 and 4. Dray and Legendre (2008) and ter Braak et al. (20012) showed
+that all models (except model 6) have inflated type I error.
+}
+Note that the model 5 is strictly equivalent to permuting
+simultaneously the rows of tables R and Q, as proposed by Doledec et
+al. (1996).
+
+The function \code{summary} returns results for variables (G). The
+function \code{print} returns results for cells (D and D2). In the case
+of qualitative variables, Holm's corrected pvalues are also provided.
+
+The function \code{plot} produces a graphical representation of the
+results (white for non significant, light grey for negative significant
+and dark grey for positive significant relationships). Results can be
+plotted for variables (G) or for cells (D and D2). In the case of
+qualitative / quantitative association, homogeneity (D) or correlation
+(D2) are plotted.
+}
+\value{
+ The \code{fourthcorner} function returns a a list where:
+
+ \code{tabD} is a \code{krandtest} object giving the results of tests
+ for cells of the fourth-corner (homogeneity for quant./qual.).
+ \code{tabD2} is a \code{krandtest} object giving the results of tests
+ for cells of the fourth-corner (Pearson r for quant./qual.).
+ \code{tabG} is a \code{krandtest} object giving the results of tests
+ for variables (Pearson's Chi2 for qual./qual.).
+
+ The \code{fourthcorner2} function returns a list where:
+
+ \code{tabG} is a \code{krandtest} object giving the results of tests for
+ variables.
+ \code{trRLQ} is a \code{krandtest} object giving the results of tests for
+ the multivariate statistic (i.e. equivalent to \code{randtest.rlq} function).
+}
+
+\references{
+Doledec, S., Chessel, D., ter Braak, C.J.F. and Champely, S. (1996)
+Matching species traits to environmental variables: a new three-table ordination method. \emph{Environmental and Ecological Statistics},
+\bold{3}, 143--166.
+
+Legendre, P., R. Galzin, and M. L. Harmelin-Vivien. (1997)
+Relating behavior to habitat: solutions to the fourth-corner problem. \emph{Ecology},
+\bold{78}, 547--562.
+
+Dray, S. and Legendre, P. (2008)
+Testing the species traits-environment relationships: the fourth-corner
+problem revisited. \emph{Ecology},
+\bold{89}, 3400--3412.
+
+ter Braak, C., Cormont, A., and Dray, S. (2012)
+Improved testing of species traits-environment relationships in the
+fourth corner problem. \emph{Ecology}, \bold{93}, 1525--1526.
+
+Dray, S., Choler, P., Doledec, S., Peres-Neto, P.R., Thuiller, W.,
+Pavoine, S. and ter Braak, C.J.F (2014)
+Combining the fourth-corner and the RLQ methods for assessing trait
+responses to environmental variation. \emph{Ecology}, \bold{95}, 14--21. doi:10.1890/13-0196.1
+}
+
+\author{Stéphane Dray \email{stephane.dray at univ-lyon1.fr}}
+\seealso{ \code{\link{rlq}}, \code{\link{combine.4thcorner}}, \code{\link[stats]{p.adjust.methods}}}
+\examples{
+data(aviurba)
+
+## Version using the sequential test (ter Braak et al 2012)
+## as recommended in Dray et al (2013),
+## using Holm correction of P-values (only 99 permutations here)
+four.comb.default <- fourthcorner(aviurba$mil,aviurba$fau,aviurba$traits,nrepet=99)
+summary(four.comb.default)
+plot(four.comb.default, stat = "G")
+
+## using fdr correction of P-values
+four.comb.fdr <- fourthcorner(aviurba$mil, aviurba$fau, aviurba$traits,
+nrepet = 99, p.adjust.method.G = 'fdr', p.adjust.method.D = 'fdr')
+summary(four.comb.fdr)
+plot(four.comb.fdr, stat = "G")
+
+## Explicit procedure to combine the results of two models
+## proposed in Dray and Legendre (2008);the above does this implicitly
+four2 <- fourthcorner(aviurba$mil,aviurba$fau,aviurba$traits,nrepet=99,modeltype=2)
+four4 <- fourthcorner(aviurba$mil,aviurba$fau,aviurba$traits,nrepet=99,modeltype=4)
+four.comb <- combine.4thcorner(four2, four4)
+summary(four.comb)
+plot(four.comb, stat = "G")
+
+
+}
+\keyword{ multivariate }
+
diff --git a/man/friday87.Rd b/man/friday87.Rd
new file mode 100644
index 0000000..31ce026
--- /dev/null
+++ b/man/friday87.Rd
@@ -0,0 +1,33 @@
+\name{friday87}
+\alias{friday87}
+\docType{data}
+\title{Faunistic K-tables}
+\description{
+This data set gives informations about sites, species and environmental variables.
+}
+\usage{data(friday87)}
+\format{
+ \code{friday87} is a list of 4 components.
+ \describe{
+ \item{fau}{is a data frame containing a faunistic table with 16 sites and 91 species.}
+ \item{mil}{is a data frame with 16 sites and 11 environmental variables.}
+ \item{fau.blo}{is a vector of the number of species per group.}
+ \item{tab.names}{is the name of each group of species.}
+ }
+}
+\source{
+Friday, L.E. (1987) The diversity of macroinvertebrate and macrophyte communities in ponds, \emph{Freshwater Biology}, \bold{18}, 87--104.
+}
+\examples{
+data(friday87)
+wfri <- data.frame(scale(friday87$fau, scal = FALSE))
+wfri <- ktab.data.frame(wfri, friday87$fau.blo,
+ tabnames = friday87$tab.names)
+
+if(adegraphicsLoaded()) {
+ g1 <- kplot(sepan(wfri), row.plabels.cex = 2)
+} else {
+ kplot(sepan(wfri), clab.r = 2, clab.c = 1)
+}
+}
+\keyword{datasets}
diff --git a/man/fruits.Rd b/man/fruits.Rd
new file mode 100644
index 0000000..9ce5de0
--- /dev/null
+++ b/man/fruits.Rd
@@ -0,0 +1,71 @@
+\name{fruits}
+\alias{fruits}
+\docType{data}
+\title{Pair of Tables}
+\description{
+ 28 batches of fruits -two types- are judged by two different ways.\cr
+ They are classified in order of preference, without ex aequo, by 16 individuals.\cr
+ 15 quantitative variables described the batches of fruits.\cr
+}
+\usage{data(fruits)}
+\format{
+ \code{fruits} is a list of 3 components:
+ \describe{
+ \item{typ}{is a vector returning the type of the 28 batches of fruits (peaches or nectarines).}
+ \item{jug}{is a data frame of 28 rows and 16 columns (judges).}
+ \item{var}{is a data frame of 28 rows and 16 measures (average of 2 judgements).}
+ }
+}
+\details{
+ \code{fruits$var} is a data frame of 15 variables:
+ \enumerate{
+ \item taches: quantity of cork blemishes (0=absent - maximum 5)
+ \item stries: quantity of stria (1/none - maximum 4)
+ \item abmucr: abundance of mucron (1/absent - 4)
+ \item irform: shape irregularity (0/none - 3)
+ \item allong: length of the fruit (1/round fruit - 4)
+ \item suroug: percentage of the red surface (minimum 40\% - maximum 90\%)
+ \item homlot: homogeneity of the intra-batch coloring (1/strong - 4)
+ \item homfru: homogeneity of the intra-fruit coloring (1/strong - 4)
+ \item pubesc: pubescence (0/none - 4)
+ \item verrou: intensity of green in red area (1/none - 4)
+ \item foncee: intensity of dark area (0/pink - 4)
+ \item comucr: intensity of the mucron color (1=no contrast - 4/dark)
+ \item impres: kind of impression (1/watched - 4/pointillé)
+ \item coldom: intensity of the predominating color (0/clear - 4)
+ \item calibr: grade (1/<90g - 5/>200g)
+ }
+}
+
+\source{ Kervella, J. (1991) Analyse de l'attrait d'un produit :
+exemple d'une comparaison de lots de pêches. Agro-Industrie et
+méthodes statistiques. Compte-rendu des secondes journées
+européennes. Nantes 13-14 juin 1991. Association pour la
+Statistique et ses Utilisations, Paris, 313--325.}
+
+\examples{
+data(fruits)
+pcajug <- dudi.pca(fruits$jug, scann = FALSE)
+pcavar <- dudi.pca(fruits$var, scann = FALSE)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.corcircle(pcajug$co, plot = FALSE)
+ g2 <- s.class(pcajug$li, fac = fruits$type, plot = FALSE)
+ g3 <- s.corcircle(pcavar$co, plot = FALSE)
+ g4 <- s.class(pcavar$li, fac = fruits$type, plot = FALSE)
+
+ G1 <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+ G2 <- plot(coinertia(pcajug, pcavar, scan = FALSE))
+
+} else {
+ par(mfrow = c(2,2))
+ s.corcircle(pcajug$co)
+ s.class(pcajug$li, fac = fruits$type)
+ s.corcircle(pcavar$co)
+ s.class(pcavar$li, fac = fruits$type)
+
+ par(mfrow = c(1,1))
+ plot(coinertia(pcajug, pcavar, scan = FALSE))
+}
+}
+\keyword{datasets}
diff --git a/man/fuzzygenet.Rd b/man/fuzzygenet.Rd
new file mode 100644
index 0000000..00a15c3
--- /dev/null
+++ b/man/fuzzygenet.Rd
@@ -0,0 +1,46 @@
+\name{fuzzygenet}
+\alias{fuzzygenet}
+\title{ Reading a table of genetic data (diploid individuals) }
+\description{
+ Reads data like \code{char2genet} without a priori population
+}
+\usage{
+fuzzygenet(X)
+}
+\arguments{
+ \item{X}{ a data frame of strings of characters (individuals in row, locus in variables), the value coded '000000' or two alleles of 6 characters }
+}
+\details{
+ In entry, a row is an individual, a variable is a locus and a value is a string of characters, for example,
+ 012028 for a heterozygote carying alleles 012 and 028; 020020 for a homozygote carrying two alleles 020 and
+ 000000 for a not classified locus (missing data).
+
+ In exit, a fuzzy array with the following encoding for a locus:\cr
+ 0 0 1 \dots 0 for a homozygote \cr
+ 0 0.5 0.5 \dots 0 for a heterozygote \cr
+ p1 p2 p3 \dots pm for an unknown where (p1 p2 p3 \dots pm) is the observed allelic frequencies for all tha available data.
+}
+\value{
+ returns a data frame with the 6 following attributs:
+ \item{col.blocks }{a vector containing the number of alleles by locus}
+ \item{all.names }{a vector containing the names of alleles}
+ \item{loc.names }{a vector containing the names of locus}
+ \item{row.w }{a vector containing the uniform weighting of rows}
+ \item{col.freq }{a vector containing the global allelic frequencies}
+ \item{col.num }{a factor ranking the alleles by locus}
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ Daniel Chessel }
+\note{ In the exit data frame, the alleles are numbered 1, 2, 3, \dots by locus and the loci are called L01, L02, L03, \dots for the simplification of listing.
+The original names are kept.
+}
+\seealso{ \code{\link{char2genet}} if you have the a priori definition of the groups of individuals (populations). It may be used on the created object \code{dudi.fca}
+}
+\examples{
+data(casitas)
+casitas[1:5, ]
+casitas <- fuzzygenet(casitas)
+attributes(casitas)
+rm(casitas)
+}
+\keyword{ multivariate }
diff --git a/man/gearymoran.Rd b/man/gearymoran.Rd
new file mode 100644
index 0000000..fb05f66
--- /dev/null
+++ b/man/gearymoran.Rd
@@ -0,0 +1,70 @@
+\name{gearymoran}
+\alias{gearymoran}
+\title{Moran's I and Geary'c randomization tests for spatial and phylogenetic autocorrelation}
+\description{
+This function performs Moran's I test using phylogenetic and spatial link matrix (binary or general). It uses neighbouring weights so Moran's I and Geary's c randomization tests are equivalent.
+}
+\usage{
+gearymoran(bilis, X, nrepet = 999, alter=c("greater", "less", "two-sided"))
+}
+\arguments{
+ \item{bilis}{: a \emph{n} by \emph{n} link matrix where \emph{n} is the row number of X}
+ \item{X}{: a data frame with continuous variables}
+ \item{nrepet}{: number of random vectors for the randomization test}
+ \item{alter}{a character string specifying the alternative hypothesis,
+ must be one of "greater" (default), "less" or "two-sided"}
+}
+\details{
+\code{bilis} is a squared symmetric matrix which terms are all positive or null.
+
+\code{bilis} is firstly transformed in frequency matrix A by dividing it by the total sum of data matrix :
+\deqn{a_{ij} = \frac{bilis_{ij}}{\sum_{i=1}^{n}\sum_{j=1}^{n}bilis_{ij}}}{a_ij = bilis_ij / (sum_i sum_j bilis_ij)}
+The neighbouring weights is defined by the matrix \eqn{D = diag(d_1,d_2, \ldots)} where \eqn{d_i = \sum_{j=1}^{n}bilis_{ij}}{d_i = sum_j bilis_ij}.
+For each vector x of the data frame X, the test is based on the Moran statistic \eqn{x^{t}Ax}{t(x)Ax} where x is D-centred.
+}
+\value{
+Returns an object of class \code{krandtest} (randomization tests).
+}
+\references{
+Cliff, A. D. and Ord, J. K. (1973) \emph{Spatial autocorrelation}, Pion, London.
+
+Thioulouse, J., Chessel, D. and Champely, S. (1995) Multivariate analysis of spatial patterns: a unified approach to local and global structures.
+\emph{Environmental and Ecological Statistics}, \bold{2}, 1--14.
+}
+\author{Sébastien Ollier \email{sebastien.ollier at u-psud.fr} \cr
+Daniel Chessel
+}
+\seealso{\code{\link[spdep]{moran.test}} and \code{\link[spdep]{geary.test}} for classical versions of Moran's test and Geary's one}
+\examples{
+# a spatial example
+data(mafragh)
+tab0 <- (as.data.frame(scalewt(mafragh$env)))
+bilis0 <- neig2mat(mafragh$neig)
+gm0 <- gearymoran(bilis0, tab0, 999)
+gm0
+plot(gm0, nclass = 20)
+
+\dontrun{
+# a phylogenetic example
+data(mjrochet)
+mjr.phy <- newick2phylog(mjrochet$tre)
+mjr.tab <- log(mjrochet$tab)
+gearymoran(mjr.phy$Amat, mjr.tab)
+gearymoran(mjr.phy$Wmat, mjr.tab)
+
+if(adegraphicsLoaded()) {
+ g1 <- table.value(mjr.phy$Wmat, ppoints.cex = 0.35, nclass = 5,
+ axis.text = list(cex = 0), plot = FALSE)
+ g2 <- table.value(mjr.phy$Amat, ppoints.cex = 0.35, nclass = 5,
+ axis.text = list(cex = 0), plot = FALSE)
+ G <- cbindADEg(g1, g2, plot = TRUE)
+
+} else {
+ par(mfrow = c(1, 2))
+ table.value(mjr.phy$Wmat, csi = 0.25, clabel.r = 0)
+ table.value(mjr.phy$Amat, csi = 0.35, clabel.r = 0)
+ par(mfrow = c(1, 1))
+}
+}}
+\keyword{spatial}
+\keyword{ts}
diff --git a/man/genet.Rd b/man/genet.Rd
new file mode 100644
index 0000000..240c35a
--- /dev/null
+++ b/man/genet.Rd
@@ -0,0 +1,76 @@
+\name{genet}
+\alias{genet}
+\alias{char2genet}
+\alias{count2genet}
+\alias{freq2genet}
+\title{A class of data: tables of populations and alleles}
+\description{
+There are multiple formats of genetic data. The functions of ade4 associated genetic data use the class \code{genet}.
+An object of the class \code{genet} is a list containing at least one data frame whose lines are groups of individuals (populations) and columns alleles forming blocks associated with the locus.
+They contain allelic frequencies expressed as a percentage. \cr
+The function \code{char2genet} ensures the reading of tables crossing diploid individuals arranged by groups (populations) and polymorphic loci. Data frames containing only strings of characters are transformed in tables of allelic frequencies of the class \code{genet}.
+In entry a row is an individual, a variable is a locus and a value is a string of characters, for example ' 012028 ' for a heterozygote carrying alleles 012 and 028, ' 020020 ' for a homozygote carrying two alleles 020 and ' 000000 ' for a not classified locus (missing data). \cr
+The function \code{count2genet} reads data frames containing allelic countings by populations and allelic forms classified by locus.\cr
+The function \code{freq2genet} reads data frames containing allelic frequencies by populations and allelic forms classified by locus. \cr
+In these two cases, use as names of variables of strings of characters \code{xx.yyy} where \code{xx} are the names of locus and \code{yyy} a name of allelic forms in this locus.
+The analyses on this kind of data having to use compact labels, these functions classify the names of the populations, the names of the loci and the names of the allelic forms in vectors and re-code in a simple way starting with P for population, L for locus and 1,\dots, m for the alleles.
+}
+\usage{
+char2genet(X, pop, complete)
+count2genet(PopAllCount)
+freq2genet(PopAllFreq)
+}
+\arguments{
+ \item{X}{a data frame of strings of characters (individuals in row, locus in variables), the value coded '000000' or two alleles of 6 characters}
+ \item{pop}{a factor with the same number of rows than \code{df} classifying the individuals by population}
+ \item{complete}{a logical value indicating a complete issue or not, by default FALSE}
+ \item{PopAllCount}{a data frame containing integers: the occurrences of each allelic form (column) in each population (row)}
+ \item{PopAllFreq}{a data frame containing values between 0 and 1: the frequencies of each allelic form (column) in each population (row)}
+}
+\value{
+\code{char2genet} returns a list of class \code{genet} with :
+\item{$tab}{a frequencies table of poplations (row) and alleles (column) }
+\item{$center}{the global frequency of each allelic form calculated on the overall individuals classified on each locus}
+\item{$pop.names}{a vector containing the names of populations present in the data re-coded P01, P02, \dots}
+\item{$all.names}{a vector containing the names of the alleles present in the data re-coded L01.1, L01.2, \dots}
+\item{$loc.blocks}{a vector containing the number of alleles by loci}
+\item{$loc.fac}{a factor sharing the alleles by loci}
+\item{$loc.names}{a vector containing the names of loci present in the data re-coded L01, \dots, L99 }
+\item{$pop.loc}{a data frame containing the number of genus allowing the calculation of frequencies}
+\item{$comp}{the complete individual typing with the code 02000 or 01001 if the option \code{complete} is TRUE}
+\item{$comp.pop}{a factor indicating the population if the option \code{complete} is TRUE}
+
+\code{count2genet} and \code{freq2genet} return a list of class \code{genet} which don't contain the components \code{pop.loc} and \code{complete}.
+}
+\details{
+As a lot of formats for genetic data are published in literature, a list of class \code{genet} contains at least a table of allellic frequencies and an attribut \code{loc.blocks}. The populations (row) and the variables (column) are classified by alphabetic order.
+In the component \code{comp}, each individual per locus of m alleles is re-coded by a vector of length m: for hererozygicy 0,\dots,1,\dots,1,\dots,0 and homozygocy 0,\dots,2,0.
+}
+\author{
+Daniel Chessel
+}
+\examples{
+data(casitas)
+casitas[24,]
+casitas.pop <- as.factor(rep(c("dome", "cast", "musc", "casi"), c(24,11,9,30)))
+casi.genet <- char2genet(casitas, casitas.pop, complete=TRUE)
+names(casi.genet$tab)
+casi.genet$tab[,1:8]
+casi.genet$pop.names
+casi.genet$loc.names
+casi.genet$all.names
+casi.genet$loc.blocks # number of allelic forms by loci
+casi.genet$loc.fac # factor classifying the allelic forms by locus
+casi.genet$pop.loc # table populations loci
+names(casi.genet$comp)
+casi.genet$comp[1:4,]
+casi.genet$comp.pop
+casi.genet$center
+apply(casi.genet$tab,2,mean)
+casi.genet$pop.loc[,"L15"]
+casi.genet$tab[, c("L15.1","L15.2")]
+class(casi.genet)
+casitas.coa <- dudi.coa(casi.genet$comp, scannf = FALSE)
+s.class(casitas.coa$li,casi.genet$comp.pop)
+}
+\keyword{multivariate}
diff --git a/man/ggtortoises.Rd b/man/ggtortoises.Rd
new file mode 100644
index 0000000..94f1a98
--- /dev/null
+++ b/man/ggtortoises.Rd
@@ -0,0 +1,53 @@
+\name{ggtortoises}
+\alias{ggtortoises}
+\docType{data}
+\title{Microsatellites of Galapagos tortoises populations}
+\description{
+This data set gives genetic relationships between Galapagos tortoises populations with 10 microsatellites.
+}
+\usage{data(ggtortoises)}
+\format{
+ \code{ggtortoises} is a list of 6 components.
+ \describe{
+ \item{area}{is a data frame designed to be used in area.plot function.}
+ \item{ico}{is a list of three pixmap icons representing the tortoises morphotypes.}
+ \item{pop}{is a data frame containing meta informations about populations.}
+ \item{misc}{is a data frame containing the coordinates of the island labels.}
+ \item{loc}{is a numeric vector giving the number of alleles by marker.}
+ \item{tab}{is a data frame containing the number of alleles by populations for 10 microsatellites.}
+ }
+}
+\source{
+M.C. Ciofi, C. Milinkovitch, J.P. Gibbs, A. Caccone, and J.R. Powell (2002) Microsatellite analysis of genetic divergence among populations of giant galapagos tortoises.
+\emph{Molecular Ecology} \bold{11}: 2265-2283.
+}
+\references{
+M.C. Ciofi, C. Milinkovitch, J.P. Gibbs, A. Caccone, and J.R. Powell (2002) Microsatellite analysis of genetic divergence among populations of giant galapagos tortoises.
+\emph{Molecular Ecology} \bold{11}: 2265-2283.
+
+See a data description at \url{http://pbil.univ-lyon1.fr/R/pdf/pps069.pdf} (in French).
+}
+\examples{
+if(requireNamespace("pixmap", quiet=TRUE)) {
+ data(ggtortoises)
+
+ if(adegraphicsLoaded()) {
+ if(requireNamespace("sp", quietly = TRUE)) {
+ g1 <- s.logo(ggtortoises$pop, ggtortoises$ico[as.character(ggtortoises$pop$carap)],
+ Sp = ggtortoises$Spatial, pbackground.col = "lightblue", pSp.col = "white",
+ pgrid.draw = FALSE, ppoints.cex = 0.5)
+ g1 <- s.label(ggtortoises$misc, pgrid.draw = FALSE, porigin.include = FALSE,
+ paxes.draw = FALSE, add = TRUE)
+ }
+
+ } else {
+ a1 <- ggtortoises$area
+ area.plot(a1)
+ rect(min(a1$x), min(a1$y), max(a1$x), max(a1$y), col = "lightblue")
+ invisible(lapply(split(a1, a1$id), function(x) polygon(x[, -1], col = "white")))
+ s.label(ggtortoises$misc, grid = FALSE, include.ori = FALSE, addaxes = FALSE, add.p = TRUE)
+ listico <- ggtortoises$ico[as.character(ggtortoises$pop$carap)]
+ s.logo(ggtortoises$pop, listico, add.p = TRUE)
+ }
+}}
+\keyword{datasets}
diff --git a/man/granulo.Rd b/man/granulo.Rd
new file mode 100644
index 0000000..033aefc
--- /dev/null
+++ b/man/granulo.Rd
@@ -0,0 +1,42 @@
+\name{granulo}
+\alias{granulo}
+\docType{data}
+\title{Granulometric Curves}
+\description{
+This data set gives the repartition in diameter classes of deposit samples.
+}
+\usage{data(granulo)}
+\format{
+ \code{granulo} is a list of 2 components.
+ \describe{
+ \item{tab}{contains the 49 deposit samples, 9 diameter classes, weight of grains by size class}
+ \item{born}{contains the boundaries of the diameter classes}
+ }
+}
+\source{
+Gaschignard-Fossati, O. (1986) \emph{Répartition spatiale des macroinvertébrés benthiques d'un bras vif du Rhône.
+Rôle des crues et dynamique saisonnière.}
+Thèse de doctorat, Université Lyon 1.
+}
+\examples{
+data(granulo)
+w <- t(apply(granulo$tab, 1, function (x) x / sum(x)))
+w <- data.frame(w)
+wtr <- data.frame(t(w))
+wmoy <- data.frame(matrix(apply(wtr, 1, mean), 1))
+d1 <- dudi.pca(w, scal = FALSE, scan = FALSE)
+wmoy <- suprow(d1, wmoy)$lisup
+
+if(adegraphicsLoaded()) {
+ s.arrow(d1$c1, plab.cex = 1.5)
+ s.distri(d1$c1, wtr, starSize = 0.33, ellipseSize = 0,
+ add = TRUE, plab.cex = 0.75)
+ s.label(wmoy, ppoints.cex = 5, plab.cex = 0, add = TRUE)
+} else {
+
+ s.arrow(d1$c1, clab = 1.5)
+ s.distri(d1$c1, wtr, cstar = 0.33, cell = 0,
+ axesell = FALSE, add.p = TRUE, clab = 0.75)
+ s.label(wmoy, cpoi = 5, clab = 0, add.p = TRUE)
+}}
+\keyword{datasets}
diff --git a/man/gridrowcol.Rd b/man/gridrowcol.Rd
new file mode 100644
index 0000000..c387f02
--- /dev/null
+++ b/man/gridrowcol.Rd
@@ -0,0 +1,54 @@
+\name{gridrowcol}
+\alias{gridrowcol}
+\title{Complete regular grid analysis}
+\description{
+This function defines objects to analyse data sets associated with complete regular grid.
+}
+\usage{
+gridrowcol(nrow, ncol, cell.names = NULL)
+}
+\arguments{
+ \item{nrow}{size of the grid (number of rows)}
+ \item{ncol}{size of the grid (number of columns)}
+ \item{cell.names}{grid cell labels}
+}
+\value{
+Returns a list containing the following items :
+ \item{xy}{: a data frame with grid cell coordinates}
+ \item{area}{: a data frame with three variables to display grid cells as areas}
+ \item{neig}{: an object of class \code{'neig'} corresponding to a neighbouring graph of the grid (rook case)}
+ \item{orthobasis}{: an object of class \code{'orthobasis'} corresponding to the analytical solution for the neighbouring graph}
+}
+\references{
+Méot, A., Chessel, D. and Sabatier, D. (1993) Opérateurs de voisinage et analyse des données spatio-temporelles.
+\emph{in} J.D. Lebreton and B. Asselain, editors. Biométrie et environnement. Masson, 45-72.
+
+Cornillon, P.A. (1998) \emph{Prise en compte de proximités en analyse factorielle et comparative}. Thèse, Ecole Nationale Supérieure Agronomique, Montpellier.
+}
+\author{Sébastien Ollier \email{sebastien.ollier at u-psud.fr} \cr
+Daniel Chessel
+}
+\seealso{\code{\link{orthobasis}}, \code{\link{orthogram}}, \code{\link{mld}}}
+\examples{
+w <- gridrowcol(8, 5)
+par(mfrow = c(1, 2))
+area.plot(w$area, center = w$xy, graph = w$neig, clab = 0.75)
+area.plot(w$area, center = w$xy, graph = w$neig, clab = 0.75, label = as.character(1:40))
+par(mfrow = c(1, 1))
+
+if(adegraphicsLoaded()) {
+ fac1 <- w$orthobasis
+ names(fac1) <- as.character(signif(attr(w$orthobasis, "values"), 3))
+ s.value(w$xy, fac1, porigin.include = FALSE, plegend.drawKey = FALSE, pgrid.text.cex = 0,
+ ylim = c(0, 10))
+
+} else {
+ par(mfrow = c(5,8))
+ for(k in 1:39)
+ s.value(w$xy, w$orthobasis[, k], csi = 3, cleg = 0, csub = 2,
+ sub = as.character(signif(attr(w$orthobasis, "values")[k], 3)),
+ incl = FALSE, addax = FALSE, cgr = 0, ylim = c(0,10))
+ par(mfrow = c(1,1))
+}
+}
+\keyword{spatial}
diff --git a/man/hdpg.Rd b/man/hdpg.Rd
new file mode 100644
index 0000000..8b5a1ab
--- /dev/null
+++ b/man/hdpg.Rd
@@ -0,0 +1,74 @@
+\name{hdpg}
+\alias{hdpg}
+\docType{data}
+\title{Genetic Variation In Human Populations}
+\description{
+This data set gives genotypes variation of 1066 individuals belonging to 52 predefined populations,
+for 404 microsatellite markers.
+}
+\usage{data(hdpg)}
+\format{
+\code{hdpg} is a list of 3 components. \cr
+ \describe{
+ \item{tab}{ is a data frame with the genotypes of 1066 individuals
+ encoded with 6 characters (individuals in row, locus in column), for
+ example \sQuote{123098} for a heterozygote carrying alleles \sQuote{123} and \sQuote{098},
+ \sQuote{123123} for a homozygote carrying two alleles \sQuote{123} and,
+ \sQuote{000000} for a not classified locus (missing data). }
+ \item{ind}{ is a a data frame with 4 columns containing information about the 1066 individuals:
+ \code{hdpg$ind$id} containing the Diversity Panel identification number of each individual,
+ and three factors \code{hdpg$ind$sex}, \code{hdpg$ind$population} and \code{hdpg$ind$region}
+ containing the names of the 52 populations belonging to 7 major geographic regions (see details). }
+ \item{locus}{ is a dataframe containing four columns: \code{hdpg$locus$marknames}
+ a vector of names of the microsatellite markers, \code{hdpg$locus$allbyloc}
+ a vector containing the number of alleles by loci, \code{hdpg$locus$chromosome}
+ a factor defining a number for one chromosome and,
+ \code{hdpg$locus$maposition} indicating the position of the locus in the chromosome. }
+ }
+}
+\details{
+The rows of \code{hdpg$pop} are the names of the 52 populations belonging to the geographic regions
+contained in the rows of \code{hdpg$region}. The chosen regions are: America, Asia, Europe,
+Middle East North Africa, Oceania, Subsaharan AFRICA. \cr
+
+The 52 populations are: Adygei, Balochi, Bantu, Basque, Bedouin, Bergamo, Biaka Pygmies,
+Brahui, Burusho, Cambodian, Columbian, Dai, Daur, Druze, French,
+Han, Hazara, Hezhen, Japanese, Kalash, Karitiana, Lahu, Makrani, Mandenka, Maya,
+Mbuti Pygmies, Melanesian, Miaozu, Mongola, Mozabite, Naxi, NewGuinea, Nilote, Orcadian,
+Oroqen, Palestinian, Pathan, Pima, Russian, San, Sardinian, She, Sindhi, Surui, Tu, Tujia, Tuscan,
+Uygur, Xibo, Yakut, Yizu, Yoruba. \cr
+
+\code{hdpg$freq} is a data frame with 52 rows,
+corresponding to the 52 populations described above, and 4992 microsatellite markers.
+}
+\source{
+Extract of data prepared by the Human Diversity Panel Genotypes
+(invalid http://research.marshfieldclinic.org/genetics/Freq/FreqInfo.htm)
+
+prepared by Hinda Haned, from data used in:
+Noah A. Rosenberg, Jonatahan K. Pritchard, James L. Weber, Howard M. Cabb, Kenneth K. Kidds,
+Lev A. Zhivotovsky, Marcus W. Feldman (2002)
+Genetic Structure of human Populations
+\emph{Science}, \bold{298}, 2381--2385.
+
+Lev A. Zhivotovsky, Noah Rosenberg, and Marcus W. Feldman (2003).
+Features of Evolution and Expansion of Modern Humans, Inferred from Genomewide Microsatellite Markers
+\emph{Am. J. Hum. Genet}, \bold{72}, 1171--1186.
+}
+\examples{
+\dontrun{
+ data(hdpg)
+ freq <- char2genet(hdpg$tab, hdpg$ind$population)
+ vec <- apply(freq$tab, 2, function(c) mean(c, na.rm = TRUE))
+ for (j in 1:4492){
+ freq$tab[is.na(freq$tab[,j]),j] = vec[j]}
+ pcatot <- dudi.pca(freq$tab, center = TRUE, scale = FALSE, scannf = FALSE, nf = 4)
+
+
+if(adegraphicsLoaded()) {
+ s.label(pcatot$li, xax = 1, yax = 2, psub.text = "1-2", lab = freq$pop.names)
+} else {
+ s.label(pcatot$li, xax = 1, yax = 2, sub = "1-2", lab = freq$pop.names)
+}}
+}
+\keyword{datasets}
diff --git a/man/housetasks.Rd b/man/housetasks.Rd
new file mode 100644
index 0000000..0de075a
--- /dev/null
+++ b/man/housetasks.Rd
@@ -0,0 +1,29 @@
+\name{housetasks}
+\alias{housetasks}
+\docType{data}
+\title{Contingency Table}
+\description{
+The \code{housetasks} data frame gives 13 housetasks and their repartition in the couple.
+}
+\usage{data(housetasks)}
+\format{
+ This data frame contains four columns : wife, alternating, husband and jointly.
+ Each column is a numeric vector.
+}
+\source{
+Kroonenberg, P. M. and Lombardo, R. (1999)
+Nonsymmetric correspondence analysis: a tool for analysing contingency tables with a dependence structure.
+\emph{Multivariate Behavioral Research}, \bold{34}, 367--396
+}
+\examples{
+data(housetasks)
+nsc1 <- dudi.nsc(housetasks, scan = FALSE)
+
+if(adegraphicsLoaded()) {
+ s.label(nsc1$c1, plab.cex = 1.25)
+ s.arrow(nsc1$li, add = TRUE, plab.cex = 0.75)
+} else {
+ s.label(nsc1$c1, clab = 1.25)
+ s.arrow(nsc1$li, add.pl = TRUE, clab = 0.75)
+}}
+\keyword{datasets}
diff --git a/man/humDNAm.Rd b/man/humDNAm.Rd
new file mode 100644
index 0000000..5147d67
--- /dev/null
+++ b/man/humDNAm.Rd
@@ -0,0 +1,30 @@
+\name{humDNAm}
+\alias{humDNAm}
+\docType{data}
+\title{human mitochondrial DNA restriction data}
+\description{
+This data set gives the frequencies of haplotypes of mitochondrial DNA restriction data in ten populations all over the world.\cr
+It gives also distances among the haplotypes.
+}
+\usage{data(humDNAm)}
+\format{
+ \code{humDNAm} is a list of 3 components.
+\describe{
+ \item{distances}{is an object of class \code{dist} with 56 haplotypes.
+ These distances are computed by counting the number of differences in restriction sites between two haplotypes.}
+ \item{samples}{is a data frame with 56 haplotypes, 10 abundance variables (populations).
+ These variables give the haplotype abundance in a given population.}
+ \item{structures}{is a data frame with 10 populations, 1 variable (classification).
+ This variable gives the name of the continent in which a given population is located. }
+}}
+\source{
+ Excoffier, L., Smouse, P.E. and Quattro, J.M. (1992) Analysis of molecular variance inferred from metric distances
+ among DNA haplotypes: application to human mitochondrial DNA restriction data. \emph{Genetics}, \bold{131}, 479--491.
+}
+\examples{
+data(humDNAm)
+dpcoahum <- dpcoa(data.frame(t(humDNAm$samples)),
+ sqrt(humDNAm$distances), scan = FALSE, nf = 2)
+plot(dpcoahum)
+}
+\keyword{datasets}
diff --git a/man/ichtyo.Rd b/man/ichtyo.Rd
new file mode 100644
index 0000000..1a5e9e9
--- /dev/null
+++ b/man/ichtyo.Rd
@@ -0,0 +1,33 @@
+\name{ichtyo}
+\alias{ichtyo}
+\docType{data}
+\title{Point sampling of fish community}
+\description{
+This data set gives informations between a faunistic array,
+the total number of sampling points made at each sampling occasion and
+the year of the sampling occasion.
+}
+\usage{data(ichtyo)}
+\format{
+ \code{ichtyo} is a list of 3 components.
+ \describe{
+ \item{tab}{is a faunistic array with 9 columns and 32 rows.}
+ \item{eff}{is a vector of the 32 sampling effort.}
+ \item{dat}{is a factor where the levels are the 10 years of the sampling occasion.}
+ }
+}
+\details{
+ The value \emph{n(i,j)} at the \emph{ith} row and the \emph{jth} column in \code{tab} corresponds
+ to the number of sampling points of the \emph{ith} sampling occasion (in \code{eff}) that contains the \emph{jth} species.
+}
+\source{
+Dolédec, S., Chessel, D. and Olivier, J. M. (1995)
+L'analyse des correspondances décentrée: application aux peuplements ichtyologiques du haut-Rhône.
+\emph{Bulletin Français de la Pêche et de la Pisciculture}, \bold{336}, 29--40.
+}
+\examples{
+data(ichtyo)
+dudi1 <- dudi.dec(ichtyo$tab, ichtyo$eff, scannf = FALSE)
+s.class(dudi1$li, ichtyo$dat, wt = ichtyo$eff / sum(ichtyo$eff))
+}
+\keyword{datasets}
diff --git a/man/inertia.dudi.Rd b/man/inertia.dudi.Rd
new file mode 100644
index 0000000..edb1637
--- /dev/null
+++ b/man/inertia.dudi.Rd
@@ -0,0 +1,56 @@
+\name{inertia.dudi}
+\alias{inertia}
+\alias{inertia.dudi}
+\alias{print.inertia}
+\alias{summary.inertia}
+\title{Decomposition of inertia (i.e. contributions) in multivariate methods}
+\description{
+Computes the decomposition of inertia to measure the contributions of row and/or columns in multivariate methods
+}
+\usage{
+\method{inertia}{dudi}(x, row.inertia = FALSE, col.inertia = FALSE, ...)
+\method{print}{inertia}(x, ...)
+\method{summary}{inertia}(object, subset = 5, ...)
+}
+\arguments{
+ \item{x, object}{a duality diagram, object of class \code{dudi} for \code{inertia.dudi}. An object of class \code{inertia} for the methods \code{print} and \code{summary}}
+ \item{row.inertia}{if TRUE, returns the decomposition of inertia for the rows}
+ \item{col.inertia}{if TRUE, returns the decomposition of inertia for the columns}
+ \item{subset}{the number of rows and/or columns to display in the summary}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+An object of class \code{inertia}, i.e. a list containing :
+\item{TOT}{repartition of the total inertia between axes}
+\item{row.contrib}{contributions of the rows to the total inertia}
+\item{row.abs}{absolute contributions of the rows (i.e. decomposition per axis)}
+\item{row.rel}{relative contributions of the rows}
+\item{row.cum}{cumulative relative contributions of the rows (i.e. decomposition per row)}
+\item{col.contrib}{contributions of the columns to the total inertia}
+\item{col.abs}{absolute contributions of the columns (i.e. decomposition per axis)}
+\item{col.rel}{relative contributions of the columns}
+\item{col.cum}{cumulative relative contributions of the columns (i.e. decomposition per column)}
+}
+\references{
+Lebart, L., Morineau, A. and Tabart, N. (1977) \emph{Techniques de la description statistique, méthodes et logiciels pour la description des grands tableaux}, Dunod, Paris, 61--62.\cr\cr
+Volle, M. (1981) \emph{Analyse des données}, Economica, Paris, 89--90 and 118\cr\cr
+Lebart, L., Morineau, L. and Warwick, K.M. (1984) \emph{Multivariate descriptive analysis: correspondence and related techniques for large matrices}, John Wiley and Sons, New York.\cr\cr
+Greenacre, M. (1984) \emph{Theory and applications of correspondence analysis}, Academic Press, London, 66.\cr\cr
+Rouanet, H. and Le Roux, B. (1993) \emph{Analyse des données multidimensionnelles}, Dunod, Paris, 143--144.\cr\cr
+Tenenhaus, M. (1994) \emph{Méthodes statistiques en gestion}, Dunod, Paris, p. 160, 161, 166, 204.\cr\cr
+Lebart, L., Morineau, A. and Piron, M. (1995) \emph{Statistique exploratoire multidimensionnelle}, Dunod, Paris, p. 56,95-96.\cr
+}
+\details{Contributions are printed in percentage and the sign is the sign of the coordinates}
+\author{
+Daniel Chessel \cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}\cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(housetasks)
+coa1 <- dudi.coa(housetasks, scann = FALSE)
+res <- inertia(coa1, col = TRUE, row = FALSE)
+res
+summary(res)
+}
+\keyword{multivariate}
diff --git a/man/irishdata.Rd b/man/irishdata.Rd
new file mode 100644
index 0000000..f370000
--- /dev/null
+++ b/man/irishdata.Rd
@@ -0,0 +1,72 @@
+\name{irishdata}
+\alias{irishdata}
+\docType{data}
+
+\title{Geary's Irish Data}
+
+\description{This data set contains geographical informations about 25 counties of Ireland.}
+
+\usage{data(irishdata)}
+
+\format{
+ \code{irishdata} is a list of 13 components:
+ \describe{
+ \item{area}{is a data frame with polygons for each of the 25 contiguous counties.}
+ \item{county.names}{is a vector with the names of the 25 counties.}
+ \item{xy}{is a data frame with the coordinates centers of the 25 counties.}
+ \item{tab}{is a data frame with 25 rows (counties) and 12 variables.}
+ \item{contour}{is a data frame with the global polygon of all the 25 counties.}
+ \item{link}{is a matrix containing the common length between two counties from \code{area}.}
+ \item{area.utm}{is a data frame with polygons for each of the 25 contiguous counties expressed in Universal Transverse Mercator (UTM) coordinates.}
+ \item{xy.utm}{is a data frame with the UTM coordinates centers of the 25 counties.}
+ \item{link.utm}{is a matrix containing the common length between two counties from \code{area.utm}.}
+ \item{tab.utm}{is a data frame with the 25 counties (explicitly named) and 12 variables.}
+ \item{contour.utm}{is a data frame with the global polygon of all the 25 counties expressed in UTM coordinates.}
+ \item{Spatial}{is the map of the 25 counties of Ireland (an object of the class \code{SpatialPolygons} of \code{sp}).}
+ \item{Spatial.contour}{is the contour of the map of the 25 counties of Ireland (an object of the class \code{SpatialPolygons} of \code{sp}).}
+}}
+
+\source{
+Geary, R.C. (1954) The contiguity ratio and statistical mapping. \emph{The incorporated Statistician}, \bold{5}, 3, 115--145.
+
+Cliff, A.D. and Ord, J.K. (1973) \emph{Spatial autocorrelation}, Pion, London. 1--178.
+}
+
+\examples{
+data(irishdata)
+
+if(adegraphicsLoaded()) {
+
+ if(requireNamespace("sp", quietly = TRUE)){
+ g1 <- s.label(irishdata$xy.utm, Sp = irishdata$Spatial, pSp.col = "white", plot = FALSE)
+
+ g21 <- s.label(irishdata$xy.utm, Sp = irishdata$Spatial, pSp.col = "white", plab.cex = 0,
+ ppoints.cex = 0, plot = FALSE)
+ g22 <- s.label(irishdata$xy.utm, Sp = irishdata$Spatial.contour, pSp.col = "transparent",
+ plab.cex = 0, ppoints.cex = 0, pSp.lwd = 3, plot = FALSE)
+ g2 <- superpose(g21, g22)
+
+ g3 <- s.corcircle(dudi.pca(irishdata$tab, scan = FALSE)$co, plot = FALSE)
+
+ score <- dudi.pca(irishdata$tab, scannf = FALSE, nf = 1)$li$Axis1
+ names(score) <- row.names(irishdata$Spatial)
+
+ obj <- sp::SpatialPolygonsDataFrame(Sr = irishdata$Spatial, data = as.data.frame(score))
+ g4 <- s.Spatial(obj, plot = FALSE)
+
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+ }
+
+} else {
+ par(mfrow = c(2, 2))
+ area.plot(irishdata$area, lab = irishdata$county.names, clab = 0.75)
+ area.plot(irishdata$area)
+ apply(irishdata$contour, 1, function(x) segments(x[1], x[2], x[3], x[4], lwd = 3))
+ s.corcircle(dudi.pca(irishdata$tab, scannf = FALSE)$co)
+ score <- dudi.pca(irishdata$tab, scannf = FALSE, nf = 1)$li$Axis1
+ names(score) <- row.names(irishdata$tab)
+ area.plot(irishdata$area, score)
+ par(mfrow = c(1, 1))
+}}
+
+\keyword{datasets}
\ No newline at end of file
diff --git a/man/is.euclid.Rd b/man/is.euclid.Rd
new file mode 100644
index 0000000..f5605d8
--- /dev/null
+++ b/man/is.euclid.Rd
@@ -0,0 +1,40 @@
+\name{is.euclid}
+\alias{is.euclid}
+\alias{summary.dist}
+\title{Is a Distance Matrix Euclidean?}
+\description{
+Confirmation of the Euclidean nature of a distance matrix by the Gower's theorem.\cr
+\code{is.euclid} is used in \code{summary.dist}.\cr
+}
+\usage{
+is.euclid(distmat, plot = FALSE, print = FALSE, tol = 1e-07)
+\method{summary}{dist}(object, \dots)
+}
+\arguments{
+ \item{distmat}{an object of class 'dist'}
+ \item{plot}{a logical value indicating whether the eigenvalues bar plot of the matrix of the term \eqn{-\frac{1}{2} {d_{ij}^2}}{-1/2 dij²} centred by rows and columns should be diplayed}
+ \item{print}{a logical value indicating whether the eigenvalues of the matrix of the term \eqn{-\frac{1}{2} {d_{ij}^2}}{-1/2 dij²} centred by rows and columns should be printed}
+ \item{tol}{a tolerance threshold : an eigenvalue is considered positive if it is larger than \code{-tol*lambda1} where \code{lambda1} is the largest eigenvalue.}
+ \item{object}{an object of class 'dist'}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+returns a logical value indicating if all the eigenvalues are positive or equal to zero
+}
+\references{Gower, J.C. and Legendre, P. (1986) Metric and Euclidean properties of dissimilarity coefficients. \emph{Journal of Classification}, \bold{3}, 5--48.
+}
+\author{
+Daniel Chessel \cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\examples{
+w <- matrix(runif(10000), 100, 100)
+w <- dist(w)
+summary(w)
+is.euclid (w) # TRUE
+w <- quasieuclid(w) # no correction need in: quasieuclid(w)
+w <- lingoes(w) # no correction need in: lingoes(w)
+w <- cailliez(w) # no correction need in: cailliez(w)
+rm(w)
+}
+\keyword{array}
diff --git a/man/julliot.Rd b/man/julliot.Rd
new file mode 100644
index 0000000..d01b484
--- /dev/null
+++ b/man/julliot.Rd
@@ -0,0 +1,96 @@
+\name{julliot}
+\alias{julliot}
+\docType{data}
+\title{Seed dispersal}
+\description{
+This data set gives the spatial distribution of seeds (quadrats counts) of seven species in the understorey of tropical rainforest.
+}
+\usage{data(julliot)}
+\format{
+\code{julliot} is a list containing the 3 following objects :
+\describe{
+ \item{tab}{is a data frame with 160 rows (quadrats) and 7 variables (species).}
+ \item{xy}{is a data frame with the coordinates of the 160 quadrats (positioned by their centers).}
+ \item{area}{is a data frame with 3 variables returning the boundary lines of each quadrat. The first variable is a factor. The levels of this one are the row.names of \code{tab}. The second and third variables return the coordinates (x,y) of the points of the boundary line.}
+}
+
+Species names of \code{julliot$tab} are \emph{Pouteria torta}, \emph{Minquartia guianensis}, \emph{Quiina obovata}, \emph{Chrysophyllum lucentifolium}, \emph{Parahancornia fasciculata}, \emph{Virola michelii}, \emph{Pourouma spp}.
+}
+\references{
+Julliot, C. (1992) Utilisation des ressources alimentaires par le singe hurleur roux,
+\emph{Alouatta seniculus} (Atelidae, Primates), en Guyane :
+impact de la dissémination des graines sur la régénération forestière. Thèse de troisième cycle, Université de Tours.
+
+Julliot, C. (1997) Impact of seed dispersal by red howler monkeys \emph{Alouatta seniculus}
+on the seedling population in the understorey of tropical rain forest. \emph{Journal of Ecology}, \bold{85}, 431--440.
+}
+\examples{
+data(julliot)
+
+\dontrun{
+if(adegraphicsLoaded()) {
+ if(requireNamespace("sp", quietly = TRUE)) {
+ obj1 <- sp::SpatialPolygonsDataFrame(Sr = julliot$Spatial, data = log(julliot$tab + 1))
+ g1 <- s.Spatial(obj1)
+ g2 <- s.value(julliot$xy, scalewt(log(julliot$tab + 1)), Sp = julliot$Spatial,
+ pSp.col = "white", pgrid.draw = FALSE)
+ }
+} else {
+ if(requireNamespace("splancs", quietly = TRUE)) {
+ par(mfrow = c(3, 3))
+ for(k in 1:7)
+ area.plot(julliot$area, val = log(julliot$tab[, k] + 1),
+ sub = names(julliot$tab)[k], csub = 2.5)
+ par(mfrow = c(1, 1))
+
+ par(mfrow = c(3, 3))
+ for(k in 1:7) {
+ area.plot(julliot$area)
+ s.value(julliot$xy, scalewt(log(julliot$tab[, k] + 1)),
+ sub = names(julliot$tab)[k], csub = 2.5, add.p = TRUE)
+ }
+ par(mfrow = c(1, 1))
+ }
+}}
+
+
+if(adegraphicsLoaded()) {
+ if(requireNamespace("sp", quietly = TRUE)) {
+ g3 <- s.image(julliot$xy, log(julliot$tab + 1), span = 0.25)
+ }
+ g4 <- s.value(julliot$xy, log(julliot$tab + 1))
+
+} else {
+ if(requireNamespace("splancs", quietly = TRUE)) {
+ par(mfrow = c(3, 3))
+ for(k in 1:7)
+ s.image(julliot$xy, log(julliot$tab[, k] + 1), kgrid = 3, span = 0.25,
+ sub = names(julliot$tab)[k], csub = 2.5)
+ par(mfrow = c(1, 1))
+
+ par(mfrow = c(3, 3))
+ for(k in 1:7)
+ s.value(julliot$xy, log(julliot$tab[, k] + 1),
+ sub = names(julliot$tab)[k], csub = 2.5)
+ par(mfrow = c(1, 1))
+ }
+}
+
+\dontrun{
+if(requireNamespace("spdep", quietly = TRUE)) {
+ neig0 <- nb2neig(spdep::dnearneigh(as.matrix(julliot$xy), 1, 1.8))
+ if(adegraphicsLoaded()) {
+ g5 <- s.label(julliot$xy, nb = spdep::dnearneigh(as.matrix(julliot$xy), 1, 1.8))
+
+ } else {
+ par(mfrow = c(1, 1))
+ s.label(julliot$xy, neig = neig0, clab = 0.75, incl = FALSE,
+ addax = FALSE, grid = FALSE)
+ }
+ gearymoran(ade4:::neig.util.LtoG(neig0), log(julliot$tab + 1))
+ orthogram(log(julliot$tab[, 3] + 1), ortho = scores.neig(neig0),
+ nrepet = 9999)
+}}
+}
+
+\keyword{datasets}
diff --git a/man/jv73.Rd b/man/jv73.Rd
new file mode 100644
index 0000000..60ce23b
--- /dev/null
+++ b/man/jv73.Rd
@@ -0,0 +1,53 @@
+\name{jv73}
+\alias{jv73}
+\docType{data}
+\title{K-tables Multi-Regions}
+\description{
+This data set gives physical and physico-chemical variables, fish species, spatial coordinates about 92 sites.
+}
+\usage{data(jv73)}
+\format{
+ \code{jv73} is a list of 6 components.
+ \describe{
+ \item{morpho}{is a data frame with 92 sites and 6 physical variables.}
+ \item{phychi}{is a data frame with 92 sites and 12 physico-chemical variables.}
+ \item{poi}{is a data frame with 92 sites and 19 fish species.}
+ \item{xy}{is a data frame with 92 sites and 2 spatial coordinates.}
+ \item{contour}{is a data frame for mapping.}
+ \item{fac.riv}{is a factor distributing the 92 sites on 12 rivers.}
+ }
+}
+\source{
+Verneaux, J. (1973) Cours d'eau de Franche-Comté (Massif du Jura).
+Recherches écologiques sur le réseau hydrographique du Doubs.
+Essai de biotypologie. Thèse d'Etat, Besançon.
+}
+\references{
+See a data description at \url{http://pbil.univ-lyon1.fr/R/pdf/pps047.pdf} (in French).
+}
+\examples{
+data(jv73)
+
+w <- split(jv73$morpho, jv73$fac.riv)
+w <- lapply(w, function(x) t(dudi.pca(x, scann = FALSE)))
+w <- ktab.list.dudi(w)
+
+if(adegraphicsLoaded()) {
+ if(requireNamespace("sp", quietly = TRUE)) {
+ g11 <- s.label(jv73$xy, Sp = jv73$Spatial, pori.incl = FALSE, plab.cex = 0.75, plot = FALSE)
+ g12 <- s.class(jv73$xy, jv73$fac.riv, ellipseSize = 0, pellipses.axes.draw = FALSE,
+ starSize = 0, ppoints.cex = 0, plab.cex = 1.25, plot = FALSE)
+ g1 <- superpose(g11, g12, plot = TRUE)
+
+ g2 <- kplot(sepan(w), perm = TRUE, row.plab.cex = 0, posieig = "none")
+ }
+
+} else {
+ s.label(jv73$xy, contour = jv73$contour, incl = FALSE, clab = 0.75)
+ s.class(jv73$xy, jv73$fac.riv, add.p = TRUE, cell = 0, axese = FALSE, csta = 0,
+ cpoi = 0, clab = 1.25)
+
+ kplot(sepan(w), perm = TRUE, clab.r = 0, clab.c = 2, show = FALSE)
+}}
+
+\keyword{datasets}
diff --git a/man/kcponds.Rd b/man/kcponds.Rd
new file mode 100644
index 0000000..ecbed84
--- /dev/null
+++ b/man/kcponds.Rd
@@ -0,0 +1,66 @@
+\name{kcponds}
+\alias{kcponds}
+\docType{data}
+\title{Ponds in a nature reserve}
+\description{
+This data set contains informations about 33 ponds in De Maten reserve (Genk, Belgium).
+}
+\usage{data(kcponds)}
+\format{
+\describe{
+ \item{tab}{: a data frame with 15 environmental variables(columns) on 33 ponds(rows)}
+ \item{area}{: an object of class \code{area}}
+ \item{xy}{: a data frame with the coordinates of ponds}
+ \item{neig}{: an object of class \code{neig}} }}
+
+\details{
+Variables of \code{kcponds$tab} are the following ones : depth, area, O2 (oxygen concentration),
+cond (conductivity), pH, Fe (Fe concentration), secchi (Secchi disk depth), N (NNO concentration),
+TP (total phosphorus concentration), chla (chlorophyll-a concentration), EM (emergent macrophyte cover),
+FM (floating macrophyte cover), SM (submerged macrophyte cover), denMI (total density of macroinvertebrates),
+divMI (diversity macroinvertebrates)
+}
+\source{
+Cottenie, K. (2002) Local and regional processes in a zooplankton metacommunity. PhD, Katholieke Universiteit Leuven, Leuven, Belgium. \cr
+\url{http://www.kuleuven.ac.be/bio/eco/phdkarlcottenie.pdf}
+}
+\examples{
+data(kcponds)
+w <- as.numeric(scalewt(kcponds$tab$N))
+
+if(adegraphicsLoaded()) {
+ if(requireNamespace("sp", quietly = TRUE)) {
+ g1 <- s.label(kcponds$xy, Sp = kcponds$Spatial, pSp.col = "white", nb = kcponds$nb,
+ plab.cex = 0, paxes.asp = "fill", plot = FALSE)
+ g2 <- s.label(kcponds$xy, Sp = kcponds$Spatial, pSp.col = "white", plabels.cex = 0.8,
+ paxes.asp = "fill", plot = FALSE)
+ g3 <- s.value(kcponds$xy, w, psub.text = "Nitrogen concentration", paxe.asp = "fill",
+ plot = FALSE)
+ G <- rbindADEg(g1, g2, g3, plot = TRUE)
+ }
+
+} else {
+ par(mfrow=c(3, 1))
+ area.plot(kcponds$area)
+ s.label(kcponds$xy, add.p = TRUE, cpoi = 2, clab = 0)
+ s.label(kcponds$xy, add.p = TRUE, cpoi = 3, clab = 0)
+ s.label(kcponds$xy, add.p = TRUE, cpoi = 0, clab = 0, neig = kcponds$neig, cneig = 1)
+ area.plot(kcponds$area)
+ s.label(kcponds$xy, add.p = TRUE, clab = 1.5)
+ s.value(kcponds$xy, w, cleg = 2, sub = "Nitrogen concentration", csub = 4,
+ possub = "topright", include = FALSE)
+ par(mfrow = c(1, 1))
+}
+
+\dontrun{
+ par(mfrow = c(3, 1))
+ pca1 <- dudi.pca(kcponds$tab, scan = FALSE, nf = 4)
+ if(requireNamespace("maptools", quietly = TRUE) & requireNamespace("spdep", quietly = TRUE)) {
+ multi1 <- multispati(pca1, spdep::nb2listw(neig2nb(kcponds$neig)), scannf = FALSE, nfposi = 2,
+ nfnega = 1)
+ summary(multi1)
+ }
+ par(mfrow = c(1, 1))
+}
+}
+\keyword{datasets}
diff --git a/man/kdist.Rd b/man/kdist.Rd
new file mode 100644
index 0000000..db8eddc
--- /dev/null
+++ b/man/kdist.Rd
@@ -0,0 +1,87 @@
+\name{kdist}
+\alias{kdist}
+\alias{c.kdist}
+\alias{print.kdist}
+\alias{[.kdist}
+\alias{as.data.frame.kdist}
+\title{the class of objects 'kdist' (K distance matrices)}
+\description{
+An object of class \code{kdist} is a list of distance matrices observed on the same individuals
+}
+\usage{
+kdist(..., epsi = 1e-07, upper = FALSE)
+}
+\arguments{
+ \item{\dots}{ a sequence of objects of the class \code{kdist}. }
+ \item{epsi}{ a tolerance threshold to test if distances are Euclidean (Gower's theorem) using \eqn{\frac{\lambda_n}{\lambda_1}} is larger than -epsi. }
+ \item{upper}{ a logical value indicating whether the upper of a distance matrix is used (TRUE) or not (FALSE). }
+}
+\value{
+ returns an object of class 'kdist' containing a list of semidefinite matrices.
+}
+\details{
+The attributs of a 'kdist' object are:\cr
+\code{names}: the names of the distances\cr
+\code{size}: the number of points between distances are known\cr
+\code{labels}: the labels of points\cr
+\code{euclid}: a logical vector indicating whether each distance of the list is Euclidean or not.\cr
+\code{call}: a call order\cr
+\code{class}: object 'kdist'\cr
+}
+\references{ Gower, J. C. (1966) Some distance properties of latent root and vector methods used in multivariate analysis. \emph{Biometrika}, \bold{53}, 325--338. }
+\author{ Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}}
+\examples{
+# starting from a list of matrices
+data(yanomama)
+lapply(yanomama,class)
+kd1 = kdist(yanomama)
+print(kd1)
+
+# giving the correlations of Mantel's test
+cor(as.data.frame(kd1))
+pairs(as.data.frame(kd1))
+
+# starting from a list of objects 'dist'
+data(friday87)
+fri.w <- ktab.data.frame(friday87$fau, friday87$fau.blo,
+ tabnames = friday87$tab.names)
+fri.kd = lapply(1:10, function(x) dist.binary(fri.w[[x]],2))
+names(fri.kd) = friday87$tab.names
+unlist(lapply(fri.kd,class)) # a list of distances
+fri.kd = kdist(fri.kd)
+fri.kd
+s.corcircle(dudi.pca(as.data.frame(fri.kd), scan = FALSE)$co)
+
+# starting from several distances
+data(ecomor)
+d1 <- dist.binary(ecomor$habitat, 1)
+d2 <- dist.prop(ecomor$forsub, 5)
+d3 <- dist.prop(ecomor$diet, 5)
+d4 <- dist.quant(ecomor$morpho, 3)
+d5 <- dist.taxo(ecomor$taxo)
+ecomor.kd <- kdist(d1, d2, d3, d4, d5)
+names(ecomor.kd) = c("habitat", "forsub", "diet", "morpho", "taxo")
+class(ecomor.kd)
+s.corcircle(dudi.pca(as.data.frame(ecomor.kd), scan = FALSE)$co)
+
+data(bsetal97)
+X <- prep.fuzzy.var(bsetal97$biol, bsetal97$biol.blo)
+w1 <- attr(X, "col.num")
+w2 <- levels(w1)
+w3 <- lapply(w2, function(x) dist.quant(X[,w1==x], method = 1))
+names(w3) <- names(attr(X, "col.blocks"))
+w3 <- kdist(list = w3)
+s.corcircle(dudi.pca(as.data.frame(w3), scan = FALSE)$co)
+
+data(rpjdl)
+w1 = lapply(1:10, function(x) dist.binary(rpjdl$fau, method = x))
+w2 = c("JACCARD", "SOCKAL_MICHENER", "SOCKAL_SNEATH_S4", "ROGERS_TANIMOTO")
+w2 = c(w2, "CZEKANOWSKI", "S9_GOWER_LEGENDRE", "OCHIAI", "SOKAL_SNEATH_S13")
+w2 <- c(w2, "Phi_PEARSON", "S2_GOWER_LEGENDRE")
+names(w1) <- w2
+w3 = kdist(list = w1)
+w4 <- dudi.pca(as.data.frame(w3), scan = FALSE)$co
+w4
+}
+\keyword{multivariate}
diff --git a/man/kdist2ktab.Rd b/man/kdist2ktab.Rd
new file mode 100644
index 0000000..c8bf5c8
--- /dev/null
+++ b/man/kdist2ktab.Rd
@@ -0,0 +1,44 @@
+\name{kdist2ktab}
+\alias{kdist2ktab}
+\title{ Transformation of K distance matrices (object 'kdist') into K Euclidean representations (object 'ktab') }
+\description{
+ The function creates a \code{ktab} object with the Euclidean representations from a \code{kdist} object. Notice that the euclid attribute must be TRUE for all elements.
+}
+\usage{
+kdist2ktab(kd, scale = TRUE, tol = 1e-07)
+}
+\arguments{
+ \item{kd}{ an object of class \code{kdist} }
+ \item{scale}{ a logical value indicating whether the inertia of Euclidean representations are equal to 1 (TRUE) or not (FALSE). }
+ \item{tol}{ a tolerance threshold, an eigenvalue is considered equal to zero if \code{eig$values} > (\code{eig$values[1} * tol) }
+}
+\value{
+returns a list of class \code{ktab} containing for each distance of \code{kd} the data frame of its Euclidean representation
+}
+\author{ Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}}
+\examples{
+data(friday87)
+fri.w <- ktab.data.frame(friday87$fau, friday87$fau.blo, tabnames = friday87$tab.names)
+fri.kd <- lapply(1:10, function(x) dist.binary(fri.w[[x]], 10))
+names(fri.kd) <- substr(friday87$tab.names, 1, 4)
+fri.kd <- kdist(fri.kd)
+fri.ktab <- kdist2ktab(kd = fri.kd)
+fri.sepan <- sepan(fri.ktab)
+plot(fri.sepan)
+
+tapply(fri.sepan$Eig, fri.sepan$TC[,1], sum)
+# the sum of the eigenvalues is constant and equal to 1, for each K tables
+
+fri.statis <- statis(fri.ktab, scan = FALSE, nf = 2)
+round(fri.statis$RV, dig = 2)
+
+fri.mfa <- mfa(fri.ktab, scan = FALSE, nf = 2)
+fri.mcoa <- mcoa(fri.ktab, scan = FALSE, nf = 2)
+
+apply(fri.statis$RV, 1, mean)
+fri.statis$RV.tabw
+plot(apply(fri.statis$RV, 1, mean), fri.statis$RV.tabw)
+plot(fri.statis$RV.tabw, fri.statis$RV.tabw)
+}
+\keyword{multivariate}
diff --git a/man/kdisteuclid.Rd b/man/kdisteuclid.Rd
new file mode 100644
index 0000000..6847445
--- /dev/null
+++ b/man/kdisteuclid.Rd
@@ -0,0 +1,61 @@
+\name{kdisteuclid}
+\alias{kdisteuclid}
+\title{a way to obtain Euclidean distance matrices}
+\description{
+a way to obtain Euclidean distance matrices
+}
+\usage{
+kdisteuclid(obj, method = c("lingoes", "cailliez", "quasi"))
+}
+\arguments{
+ \item{obj}{an object of class \code{kdist}}
+ \item{method}{a method to convert a distance matrix in a Euclidean one}
+}
+\value{
+returns an object of class \code{kdist} with all distances Euclidean.
+}
+\references{
+Gower, J.C. and Legendre, P. (1986) Metric and Euclidean properties of dissimilarity coefficients. \emph{Journal of Classification}, \bold{3}, 5--48.
+
+Cailliez, F. (1983) The analytical solution of the additive constant problem. \emph{Psychometrika}, \bold{48}, 305--310.
+
+Lingoes, J.C. (1971) Somme boundary conditions for a monotone analysis of symmetric matrices. \emph{Psychometrika}, \bold{36}, 195--203.
+
+Legendre, P. and Anderson, M.J. (1999) Distance-based redundancy analysis: testing multispecies responses in multifactorial ecological experiments. \emph{Ecological Monographs}, \bold{69}, 1--24.
+
+Legendre, P., and L. Legendre. (1998) Numerical ecology, 2nd English edition edition. Elsevier Science BV, Amsterdam.
+}
+
+\author{
+Daniel Chessel \cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+
+\note{according to the program DistPCoa of P. Legendre and M.J. Anderson\cr
+\url{http://www.fas.umontreal.ca/BIOL/Casgrain/en/labo/distpcoa.html}
+}
+
+\examples{
+w <- c(0.8, 0.8, 0.377350269, 0.8, 0.377350269, 0.377350269) # see ref.
+w <- kdist(w)
+w1 <- c(kdisteuclid(kdist(w), "lingoes"), kdisteuclid(kdist(w), "cailliez"),
+ kdisteuclid(kdist(w), "quasi"))
+print(w, print = TRUE)
+print(w1, print = TRUE)
+
+data(eurodist)
+par(mfrow = c(1, 3))
+eu1 <- kdist(eurodist) # an object of class 'dist'
+plot(data.frame(unclass(c(eu1, kdisteuclid(eu1, "quasi")))), asp = 1)
+title(main = "Quasi")
+abline(0,1)
+plot(data.frame(unclass(c(eu1, kdisteuclid(eu1, "lingoes")))), asp = 1)
+title(main = "Lingoes")
+abline(0,1)
+plot(data.frame(unclass(c(eu1, kdisteuclid(eu1, "cailliez")))), asp = 1)
+title(main = "Cailliez")
+abline(0,1)
+}
+
+\keyword{multivariate}
+\keyword{utilities}
diff --git a/man/kplot.Rd b/man/kplot.Rd
new file mode 100644
index 0000000..24fae7c
--- /dev/null
+++ b/man/kplot.Rd
@@ -0,0 +1,20 @@
+\name{kplot}
+\alias{kplot}
+\title{Generic Function for Multiple Graphs in a K-tables Analysis}
+\description{
+ Methods for \code{foucart}, \code{mcoa}, \code{mfa}, \code{pta}, \code{sepan}, \code{sepan.coa} and \code{statis}
+}
+\usage{
+kplot(object, ...)
+}
+\arguments{
+ \item{object}{an object used to select a method}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\examples{
+methods(plot)
+methods(scatter)
+methods(kplot)
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/kplot.foucart.Rd b/man/kplot.foucart.Rd
new file mode 100644
index 0000000..123f690
--- /dev/null
+++ b/man/kplot.foucart.Rd
@@ -0,0 +1,35 @@
+\name{kplot.foucart}
+\alias{kplot.foucart}
+\title{Multiple Graphs for the Foucart's Correspondence Analysis}
+\description{
+performs high level plots of a Foucart's Correspondence Analysis,
+using an object of class \code{foucart}.
+}
+\usage{
+\method{kplot}{foucart}(object, xax = 1, yax = 2, mfrow = NULL,
+ which.tab = 1:length(object$blo), clab.r = 1, clab.c = 1.25,
+ csub = 2, possub = "bottomright", \dots)
+}
+\arguments{
+ \item{object}{an object of class \code{foucart} }
+ \item{xax, yax}{the numbers of the x-axis and the y-axis}
+ \item{mfrow}{a vector of the form 'c(nr,nc)', otherwise computed by as special own function \code{n2mfrow}}
+ \item{which.tab}{vector of table numbers for analyzing}
+ \item{clab.r}{a character size for the row labels}
+ \item{clab.c}{a character size for the column labels}
+ \item{csub}{a character size for the sub-titles used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\examples{
+data(bf88)
+fou1 <- foucart(bf88, scann = FALSE, nf = 3)
+
+if(adegraphicsLoaded()) {
+ g <- kplot(fou1, row.plab.cex = 0, psub.cex = 2)
+} else {
+ kplot(fou1, clab.c = 2, clab.r = 0, csub = 3)
+}
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/kplot.mcoa.Rd b/man/kplot.mcoa.Rd
new file mode 100644
index 0000000..16ce58d
--- /dev/null
+++ b/man/kplot.mcoa.Rd
@@ -0,0 +1,42 @@
+\name{kplot.mcoa}
+\alias{kplot.mcoa}
+\title{Multiple Graphs for a Multiple Co-inertia Analysis}
+\description{
+performs high level plots of a Multiple Co-inertia Analysis,
+using an object of class \code{mcoa}.
+}
+\usage{
+\method{kplot}{mcoa}(object, xax = 1, yax = 2, which.tab = 1:nrow(object$cov2),
+ mfrow = NULL, option = c("points", "axis", "columns"),
+ clab = 1, cpoint = 2, csub = 2, possub = "bottomright",\dots)
+}
+\arguments{
+ \item{object}{an object of class \code{mcoa}}
+ \item{xax, yax}{the numbers of the x-axis and the y-axis}
+ \item{which.tab}{a numeric vector containing the numbers of the tables to analyse}
+ \item{mfrow}{a vector of the form 'c(nr,nc)', otherwise computed by as special own function \code{n2mfrow}}
+ \item{option}{a string of characters for the drawing option
+ \describe{
+ \item{"points"}{plot of the projected scattergram onto the co-inertia axes}
+ \item{"axis"}{projections of inertia axes onto the co-inertia axes.}
+ \item{"columns"}{projections of variables onto the synthetic variables planes.}
+ }
+ }
+ \item{clab}{a character size for the labels}
+ \item{cpoint}{a character size for plotting the points, used with \code{par("cex")}*cpoint. If zero, no points are drawn.}
+ \item{csub}{a character size for the sub-titles, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\author{Daniel Chessel }
+\examples{
+data(friday87)
+w1 <- data.frame(scale(friday87$fau, scal = FALSE))
+w2 <- ktab.data.frame(w1, friday87$fau.blo, tabnames = friday87$tab.names)
+mcoa1 <- mcoa(w2, "lambda1", scan = FALSE)
+kplot(mcoa1, option = "axis")
+kplot(mcoa1)
+kplot(mcoa1, option = "columns")
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/kplot.mfa.Rd b/man/kplot.mfa.Rd
new file mode 100644
index 0000000..e25af75
--- /dev/null
+++ b/man/kplot.mfa.Rd
@@ -0,0 +1,37 @@
+\name{kplot.mfa}
+\alias{kplot.mfa}
+\title{Multiple Graphs for a Multiple Factorial Analysis}
+\description{
+performs high level plots of a Multiple Factorial Analysis,
+using an object of class \code{mfa}.
+}
+\usage{
+\method{kplot}{mfa}(object, xax = 1, yax = 2, mfrow = NULL,
+ which.tab = 1:length(object$blo), row.names = FALSE, col.names = TRUE,
+ traject = FALSE, permute.row.col = FALSE,
+ clab = 1, csub = 2, possub = "bottomright", \dots)
+}
+\arguments{
+ \item{object}{an object of class \code{mfa}}
+ \item{xax, yax}{the numbers of the x-axis and the y-axis}
+ \item{mfrow}{a vector of the form 'c(nr,nc'), otherwise computed by a special own function \code{n2mfrow}}
+ \item{which.tab}{vector of the numbers of tables used for the analysis}
+ \item{row.names}{a logical value indicating whether the row labels should be inserted}
+ \item{col.names}{a logical value indicating whether the column labels should be inserted}
+ \item{traject}{a logical value indicating whether the trajectories of the rows should be drawn in a natural order}
+ \item{permute.row.col}{if TRUE, the rows are represented by vectors and columns by points, otherwise it is the opposite}
+ \item{clab}{a character size for the labels}
+ \item{csub}{a character size for the sub-titles, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\author{Daniel Chessel }
+\examples{
+data(friday87)
+w1 <- data.frame(scale(friday87$fau, scal = FALSE))
+w2 <- ktab.data.frame(w1, friday87$fau.blo, tabnames = friday87$tab.names)
+mfa1 <- mfa(w2, scann = FALSE)
+kplot(mfa1)
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/kplot.pta.Rd b/man/kplot.pta.Rd
new file mode 100644
index 0000000..217934d
--- /dev/null
+++ b/man/kplot.pta.Rd
@@ -0,0 +1,47 @@
+\name{kplot.pta}
+\alias{kplot.pta}
+\title{Multiple Graphs for a Partial Triadic Analysis}
+\description{
+performs high level plots of a Partial Triadic Analysis,
+using an object of class \code{pta}.
+}
+\usage{
+\method{kplot}{pta}(object, xax = 1, yax = 2, which.tab = 1:nrow(object$RV),
+ mfrow = NULL, which.graph = 1:4, clab = 1, cpoint = 2, csub = 2,
+ possub = "bottomright", ask = par("ask"), ...)
+}
+\arguments{
+ \item{object}{an object of class \code{pta}}
+ \item{xax, yax}{the numbers of the x-axis and the y-axis}
+ \item{which.tab}{a numeric vector containing the numbers of the tables to analyse}
+ \item{mfrow}{parameter of the array of figures to be drawn, otherwise the graphs associated to a table are drawn on the same row}
+ \item{which.graph}{an option for drawing, an integer between 1 and
+ 4. For each table of which.tab, are drawn :
+ \describe{
+ \item{1}{the projections of the principal axes}
+ \item{2}{the projections of the rows}
+ \item{3}{the projections of the columns}
+ \item{4}{the projections of the principal components onto the
+ planes of the compromise}
+ }
+ }
+ \item{clab}{a character size for the labels}
+ \item{cpoint}{a character size for plotting the points, used with \code{par("cex")}*cpoint. If zero, no points are drawn.}
+ \item{csub}{a character size for the sub-titles, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{ask}{a logical value indicating if the graphs requires several arrays of figures}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\author{Daniel Chessel }
+\examples{
+data(meaudret)
+wit1 <- wca(dudi.pca(meaudret$spe, scan = FALSE, scal = FALSE),
+ meaudret$design$season, scan = FALSE)
+kta1 <- ktab.within(wit1, colnames = rep(c("S1", "S2", "S3", "S4", "S5"), 4))
+kta2 <- t(kta1)
+pta1 <- pta(kta2, scann = FALSE)
+kplot(pta1)
+kplot(pta1, which.graph = 3)
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/kplot.sepan.Rd b/man/kplot.sepan.Rd
new file mode 100644
index 0000000..ee8c3ad
--- /dev/null
+++ b/man/kplot.sepan.Rd
@@ -0,0 +1,74 @@
+\name{kplot.sepan}
+\alias{kplot.sepan}
+\alias{kplotsepan.coa}
+\title{Multiple Graphs for Separated Analyses in a K-tables}
+\description{
+performs high level plots for Separed Analyses in a K-tables,
+using an object of class \code{sepan}.
+}
+\usage{
+\method{kplot}{sepan}(object, xax = 1, yax = 2, which.tab = 1:length(object$blo),
+ mfrow = NULL, permute.row.col = FALSE, clab.row = 1,
+ clab.col = 1.25, traject.row = FALSE, csub = 2,
+ possub = "bottomright", show.eigen.value = TRUE,\dots)
+
+kplotsepan.coa(object, xax = 1, yax = 2, which.tab = 1:length(object$blo),
+ mfrow = NULL, permute.row.col = FALSE, clab.row = 1,
+ clab.col = 1.25, csub = 2, possub = "bottomright",
+ show.eigen.value = TRUE, poseig = c("bottom", "top"), \dots)
+}
+\arguments{
+ \item{object}{an object of class \code{sepan}}
+ \item{xax, yax}{the numbers of the x-axis and the y-axis}
+ \item{which.tab}{a numeric vector containing the numbers of the tables to analyse}
+ \item{mfrow}{parameter for the array of figures to be drawn, otherwise use n2mfrow}
+ \item{permute.row.col}{if TRUE the rows are represented by arrows and the columns by points, if FALSE it is the opposite}
+ \item{clab.row}{a character size for the row labels}
+ \item{clab.col}{a character size for the column labels}
+ \item{traject.row}{a logical value indicating whether the trajectories between rows should be drawn in a natural order}
+ \item{csub}{a character size for the sub-titles, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{show.eigen.value}{a logical value indicating whether the eigenvalues bar plot should be drawn}
+ \item{poseig}{if "top" the eigenvalues bar plot is upside, if "bottom", it is downside}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\details{
+\code{kplot.sepan} superimposes the points for the rows and the arrows for the columns using an
+adapted rescaling such as the \code{scatter.dudi}.\cr
+\code{kplotsepan.coa} superimposes the row coordinates and the column coordinates with the same scale.
+}
+\author{Daniel Chessel }
+\examples{
+data(escopage)
+w1 <- data.frame(scale(escopage$tab))
+w1 <- ktab.data.frame(w1, escopage$blo, tabnames = escopage$tab.names)
+sep1 <- sepan(w1)
+if(adegraphicsLoaded()) {
+ kplot(sep1, posieig = "none")
+} else {
+ kplot(sep1, show = FALSE)
+}
+
+data(friday87)
+w2 <- data.frame(scale(friday87$fau, scal = FALSE))
+w2 <- ktab.data.frame(w2, friday87$fau.blo, tabnames = friday87$tab.names)
+if(adegraphicsLoaded()) {
+ kplot(sepan(w2), row.plabel.cex = 1.25, col.plab.cex = 0)
+} else {
+ kplot(sepan(w2), clab.r = 1.25, clab.c = 0)
+}
+
+data(microsatt)
+w3 <- dudi.coa(data.frame(t(microsatt$tab)), scann = FALSE)
+loci.fac <- factor(rep(microsatt$loci.names, microsatt$loci.eff))
+wit <- wca(w3, loci.fac, scann = FALSE)
+microsatt.ktab <- ktab.within(wit)
+if(adegraphicsLoaded()) {
+ kplotsepan.coa(sepan(microsatt.ktab), posieig = "none", col.plab.cex = 0, row.plab.cex = 1.5)
+} else {
+ kplotsepan.coa(sepan(microsatt.ktab), show = FALSE, clab.c = 0,
+ mfrow = c(3,3), clab.r = 1.5)
+}
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/kplot.statis.Rd b/man/kplot.statis.Rd
new file mode 100644
index 0000000..144d55c
--- /dev/null
+++ b/man/kplot.statis.Rd
@@ -0,0 +1,43 @@
+\name{kplot.statis}
+\alias{kplot.statis}
+\title{Multiple Graphs of a STATIS Analysis}
+\description{
+performs high level plots for a STATIS analysis,
+using an object of class \code{statis}.
+}
+\usage{
+\method{kplot}{statis}(object, xax = 1, yax = 2, mfrow = NULL,
+ which.tab = 1:length(object$tab.names), clab = 1.5, cpoi = 2,
+ traject = FALSE, arrow = TRUE, class = NULL,
+ unique.scale = FALSE, csub = 2, possub = "bottomright",\dots)
+}
+\arguments{
+ \item{object}{an object of class \code{statis}}
+ \item{xax, yax}{the numbers of the x-axis and the y-axis}
+ \item{mfrow}{parameter for the array of figures to be drawn}
+ \item{which.tab}{a numeric vector containing the numbers of the tables to analyse}
+ \item{clab}{a character size for the labels}
+ \item{cpoi}{the size of points}
+ \item{traject}{a logical value indicating whether the trajectories should be drawn in a natural order}
+ \item{arrow}{a logical value indicating whether the column factorial diagrams should be plotted}
+ \item{class}{if not NULL, a factor of length equal to the number of the total columns of the K-tables}
+ \item{unique.scale}{if TRUE, all the arrays of figures have the same scale}
+ \item{csub}{a character size for the labels of the arrays of figures used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\author{Daniel Chessel }
+\examples{
+data(jv73)
+dudi1 <- dudi.pca(jv73$poi, scann = FALSE, scal = FALSE)
+wit1 <- wca(dudi1, jv73$fac.riv, scann = FALSE)
+kta1 <- ktab.within(wit1)
+statis1 <- statis(kta1, scann = FALSE)
+
+if(adegraphicsLoaded()) {
+ g1 <- kplot(statis1, traj = TRUE, arrow = FALSE, plab.cex = 0, psub.cex = 2, ppoi.cex = 2)
+} else {
+ kplot(statis1, traj = TRUE, arrow = FALSE, unique = TRUE, clab = 0, csub = 2, cpoi = 2)
+}}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/krandtest.Rd b/man/krandtest.Rd
new file mode 100644
index 0000000..bd4ffca
--- /dev/null
+++ b/man/krandtest.Rd
@@ -0,0 +1,45 @@
+\name{krandtest}
+\alias{krandtest}
+\alias{plot.krandtest}
+\alias{print.krandtest}
+\alias{as.krandtest}
+\title{Class of the Permutation Tests (in C).}
+\description{
+Plot and print many permutation tests. Objects of class \code{'krandtest'} are lists.
+}
+\usage{
+\method{plot}{krandtest}(x, mfrow = NULL, nclass = 10, main.title = x$names, ...)
+\method{print}{krandtest}(x, ...)
+as.krandtest(sim, obs, alter = "greater", call = match.call(),
+names = colnames(sim), p.adjust.method = "none", output = c("light", "full"))
+}
+\arguments{
+ \item{x}{: an object of class \code{'krandtest'}}
+ \item{mfrow}{: a vector of the form 'c(nr,nc)', otherwise computed by as special own function \code{n2mfrow}}
+ \item{nclass}{a number of intervals for the histogram. Ignored if object output is \code{"light"}}
+ \item{main.title}{: a string of character for the main title}
+ \item{\dots}{: further arguments passed to or from other methods}
+ \item{sim}{a matrix or data.frame of simulated values (repetitions as
+ rows, number of tests as columns}
+ \item{obs}{a numeric vector of observed values for each test}
+ \item{alter}{a vector of character specifying the
+ alternative hypothesis for each test. Each element must be one of
+ "greater" (default), "less" or "two-sided". The length must be equal
+ to the length of the vector obs, values are recycled if shorter.}
+ \item{call}{a call order}
+ \item{names}{a vector of names for tests}
+ \item{p.adjust.method}{a string indicating a method for multiple
+ adjustment, see \code{p.adjust.methods} for possible choices.}
+ \item{output}{a character string specifying if all simulations should be stored (\code{"full"}). This was the default until \code{ade4} 1.7-5. Now, by default (\code{"light"}), only the distribution of simulated values is stored in element \code{plot} as produced by the \code{hist} function.}
+}
+\value{
+\code{plot.krandtest} draws the \emph{p} simulated values histograms and the position of the observed value.
+}
+\author{Daniel Chessel and Stéphane Dray \email{stephane.dray at univ-lyon1.fr} }
+\seealso{\code{\link{randtest}}}
+\examples{
+wkrandtest <- as.krandtest(obs=c(0,1.2,2.4,3.4,5.4,20.4),sim=matrix(rnorm(6*200),200,6))
+wkrandtest
+plot(wkrandtest)
+}
+\keyword{methods}
diff --git a/man/ktab.Rd b/man/ktab.Rd
new file mode 100644
index 0000000..ed280f2
--- /dev/null
+++ b/man/ktab.Rd
@@ -0,0 +1,91 @@
+\name{ktab}
+\alias{ktab}
+\alias{is.ktab}
+\alias{c.ktab}
+\alias{[.ktab}
+\alias{print.ktab}
+\alias{t.ktab}
+\alias{row.names.ktab}
+\alias{row.names<-.ktab}
+\alias{col.names}
+\alias{col.names.ktab}
+\alias{col.names<-}
+\alias{col.names<-.ktab}
+\alias{tab.names}
+\alias{tab.names.ktab}
+\alias{tab.names<-}
+\alias{tab.names<-.ktab}
+\alias{ktab.util.names}
+\alias{ktab.util.addfactor}
+\title{the class of objects 'ktab' (K-tables)}
+\description{
+an object of class \code{ktab} is a list of data frames with the same row.names in common.\cr
+a list of class 'ktab' contains moreover :
+\describe{
+ \item{blo}{: the vector of the numbers of columns for each table}
+ \item{lw}{: the vector of the row weightings in common for all tables}
+ \item{cw}{: the vector of the column weightings}
+ \item{TL}{: a data frame of two components to manage the parameter positions associated with the rows of tables}
+ \item{TC}{: a data frame of two components to manage the parameter positions associated with the columns of tables}
+ \item{T4}{: a data frame of two components to manage the parameter positions of 4 components associated to an array}
+}
+}
+\usage{
+\method{c}{ktab}(...)
+\method{[}{ktab}(x,i,j,k)
+is.ktab(x)
+\method{t}{ktab}(x)
+\method{row.names}{ktab}(x)
+\method{col.names}{ktab}(x)
+tab.names(x)
+col.names(x)
+ktab.util.names(x)
+}
+\arguments{
+ \item{x}{an object of the class \code{ktab}}
+ \item{\dots}{a sequence of objects of the class \code{ktab}}
+ \item{i,j,k}{elements to extract (integer or empty): index of tables (i), rows (j) and columns (k)}
+}
+\details{
+A 'ktab' object can be created with :\cr
+ a list of data frame : \code{\link{ktab.list.df}}\cr
+ a list of \code{dudi} objects : \code{\link{ktab.list.dudi}}\cr
+ a data.frame : \code{\link{ktab.data.frame}}\cr
+ an object \code{within} : \code{\link{ktab.within}}\cr
+ a couple of \code{ktab}s : \code{\link{ktab.match2ktabs}}\cr
+}
+\value{
+\code{c.ktab} returns an object \code{ktab}. It concatenates K-tables with the same rows in common. \cr
+\code{t.ktab} returns an object \code{ktab}. It permutes each data frame into a K-tables. All tables have the same column names and the same column weightings (a data cube). \cr
+\code{"["} returns an object \code{ktab}. It allows to select some arrays in a K-tables. \cr
+\code{is.ktab} returns TRUE if x is a K-tables. \cr
+\code{row.names} returns the vector of the row names common with all the tables of a K-tables and allowes to modifie them.\cr
+\code{col.names} returns the vector of the column names of a K-tables and allowes to modifie them.\cr
+\code{tab.names} returns the vector of the array names of a K-tables and allowes to modifie them.\cr
+\code{ktab.util.names} is a useful function.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\examples{
+data(friday87)
+wfri <- data.frame(scale(friday87$fau, scal = FALSE))
+wfri <- ktab.data.frame(wfri, friday87$fau.blo)
+wfri[2:4, 1:5, 1:3]
+c(wfri[2:4], wfri[5])
+
+data(meaudret)
+wit1 <- withinpca(meaudret$env, meaudret$design$season, scan = FALSE,
+ scal = "partial")
+kta1 <- ktab.within(wit1, colnames = rep(c("S1","S2","S3","S4","S5"), 4))
+kta2 <- t(kta1)
+
+if(adegraphicsLoaded()) {
+ kplot(sepan(kta2), row.plab.cex = 1.5, col.plab.cex = 0.75)
+} else {
+ kplot(sepan(kta2), clab.r = 1.5, clab.c = 0.75)
+}
+}
+\keyword{multivariate}
diff --git a/man/ktab.data.frame.Rd b/man/ktab.data.frame.Rd
new file mode 100644
index 0000000..b701144
--- /dev/null
+++ b/man/ktab.data.frame.Rd
@@ -0,0 +1,39 @@
+\name{ktab.data.frame}
+\alias{ktab.data.frame}
+\title{Creation of K-tables from a data frame}
+\description{
+creates K tables from a data frame.
+}
+\usage{
+ktab.data.frame(df, blocks, rownames = NULL, colnames = NULL,
+ tabnames = NULL, w.row = rep(1, nrow(df)) / nrow(df),
+ w.col = rep(1, ncol(df)))
+}
+\arguments{
+ \item{df}{a data frame}
+ \item{blocks}{an integer vector for which the sum must be the number of variables of df. Its length is the number of arrays of the K-tables}
+ \item{rownames}{the row names of the K-tables (otherwise the row names of df)}
+ \item{colnames}{the column names of the K-tables (otherwise the column names of df)}
+ \item{tabnames}{the names of the arrays of the K-tables (otherwise "Ana1", "Ana2", \dots)}
+ \item{w.row}{a vector of the row weightings}
+ \item{w.col}{a vector of the column weightings}
+}
+\value{
+returns a list of class \code{ktab}. See \code{\link{ktab}}.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(escopage)
+wescopage <- data.frame(scalewt(escopage$tab))
+wescopage <- ktab.data.frame(wescopage, escopage$blo,
+ tabnames = escopage$tab.names)
+plot(sepan(wescopage))
+data(friday87)
+w <- data.frame(scale(friday87$fau, scal = FALSE))
+w <- ktab.data.frame(w, friday87$fau.blo, tabnames = friday87$tab.names)
+kplot(sepan(w))
+}
+\keyword{multivariate}
diff --git a/man/ktab.list.df.Rd b/man/ktab.list.df.Rd
new file mode 100644
index 0000000..4155a37
--- /dev/null
+++ b/man/ktab.list.df.Rd
@@ -0,0 +1,38 @@
+\name{ktab.list.df}
+\alias{ktab.list.df}
+\title{Creating a K-tables from a list of data frames.
+}
+\description{
+creates a list of class \code{ktab} from a list of data frames
+}
+\usage{
+ktab.list.df(obj, rownames = NULL, colnames = NULL, tabnames = NULL,
+ w.row = rep(1, nrow(obj[[1]])), w.col = lapply(obj, function(x)
+ rep(1 / ncol(x), ncol(x))))
+}
+\arguments{
+ \item{obj}{a list of data frame}
+ \item{rownames}{the names of the K-tables rows (otherwise, the row names of the arrays)}
+ \item{colnames}{the names of the K-tables columns (otherwise, the column names of the arrays)}
+ \item{tabnames}{the names of the arrays of the K-tables (otherwise, the names of the obj if they exist, or else "Ana1", "Ana2", \dots)}
+ \item{w.row}{a vector of the row weightings in common with all the arrays}
+ \item{w.col}{a list of the vector of the column weightings for each array}
+}
+\details{
+Each element of the initial list have to possess the same names and row numbers
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\value{
+returns a list of class \code{ktab}. See \code{\link{ktab}}
+}
+\examples{
+data(jv73)
+l0 <- split(jv73$morpho, jv73$fac.riv)
+l0 <- lapply(l0, function(x) data.frame(t(scalewt(x))))
+kta <- ktab.list.df(l0)
+kplot(sepan(kta[c(2, 5, 7, 10)]), perm = TRUE)
+}
+\keyword{multivariate}
diff --git a/man/ktab.list.dudi.Rd b/man/ktab.list.dudi.Rd
new file mode 100644
index 0000000..e28eddd
--- /dev/null
+++ b/man/ktab.list.dudi.Rd
@@ -0,0 +1,53 @@
+\name{ktab.list.dudi}
+\alias{ktab.list.dudi}
+\title{Creation of a K-tables from a list of duality diagrams}
+\description{
+creates a list of class \code{ktab} from a list of duality diagrams.
+}
+\usage{
+ktab.list.dudi(obj, rownames = NULL, colnames = NULL, tabnames = NULL)
+}
+\arguments{
+ \item{obj}{a list of objects of class 'dudi'. Each element of the list must have the same row names for \code{$tab} and even for \code{$lw}}
+ \item{rownames}{the row names of the K-tables (otherwise the row names of the \code{$tab})}
+ \item{colnames}{the column names of the K-tables (otherwise the column names of the \code{$tab})}
+ \item{tabnames}{the names of the arrays of the K-tables (otherwise the names of the \code{obj} if they exist, or else "Ana1", "Ana2", \dots)}
+}
+\value{
+returns a list of class \code{ktab}. See \code{\link{ktab}}
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(euro123)
+pca1 <- dudi.pca(euro123$in78, scale = FALSE, scann = FALSE)
+pca2 <- dudi.pca(euro123$in86, scale = FALSE, scann = FALSE)
+pca3 <- dudi.pca(euro123$in97, scale = FALSE, scann = FALSE)
+ktabeuro <- ktab.list.dudi(list(pca1, pca2, pca3),
+ tabnames = c("1978", "1986", "1997"))
+if(adegraphicsLoaded()) {
+ kplot(sepan(ktabeuro))
+} else {
+ kplot(sepan(ktabeuro), mfr = c(2, 2), clab.c = 1.5)
+}
+
+data(meaudret)
+w1 <- split(meaudret$env,meaudret$design$season)
+ll <- lapply(w1, dudi.pca, scann = FALSE)
+kta <- ktab.list.dudi(ll, rownames <- paste("Site", 1:5, sep = ""))
+if(adegraphicsLoaded()) {
+ kplot(sepan(kta), row.plab.cex = 1.5, col.plab.cex = 0.75)
+} else {
+ kplot(sepan(kta), clab.r = 1.5, clab.c = 0.75)
+}
+
+data(jv73)
+w <- split(jv73$poi, jv73$fac.riv)
+wjv73poi <- lapply(w, dudi.pca, scal = FALSE, scan = FALSE)
+wjv73poi <- lapply(wjv73poi, t)
+wjv73poi <- ktab.list.dudi(wjv73poi)
+kplot(sepan(wjv73poi), permut = TRUE, traj = TRUE)
+}
+\keyword{multivariate}
diff --git a/man/ktab.match2ktabs.Rd b/man/ktab.match2ktabs.Rd
new file mode 100644
index 0000000..56beef5
--- /dev/null
+++ b/man/ktab.match2ktabs.Rd
@@ -0,0 +1,41 @@
+\name{ktab.match2ktabs}
+\alias{ktab.match2ktabs}
+\title{STATIS and Co-Inertia : Analysis of a series of paired ecological tables}
+\description{
+Prepares the analysis of a series of paired ecological tables. Partial Triadic
+Analysis (see \code{\link{pta}}) can be used thereafter to perform the analysis of this k-table.
+}
+\usage{
+ktab.match2ktabs(KTX, KTY)
+}
+\arguments{
+ \item{KTX}{an objet of class \code{ktab}}
+ \item{KTY}{an objet of class \code{ktab}}
+}
+\value{
+a list of class \code{ktab}, subclass \code{kcoinertia}. See \code{\link{ktab}}
+}
+\references{
+Thioulouse J., Simier M. and Chessel D. (2004). Simultaneous analysis of a sequence of paired ecological tables. \emph{Ecology} \bold{85}, 272-283..
+
+Simier, M., Blanc L., Pellegrin F., and Nandris D. (1999). Approche simultanée de K couples de tableaux :
+Application a l'étude des relations pathologie végétale - environnement. \emph{Revue de Statistique Appliquée}, \bold{47}, 31-46.
+}
+\author{Jean Thioulouse \email{Jean.Thioulouse at univ-lyon1.fr}}
+\section{WARNING }{
+IMPORTANT : \code{KTX} and \code{KTY} must have the same k-tables structure, the same number
+of columns, and the same column weights.
+}
+\examples{
+data(meau)
+wit1 <- withinpca(meau$env, meau$design$season, scan = FALSE, scal = "total")
+pcaspe <- dudi.pca(meau$spe, scale = FALSE, scan = FALSE, nf = 2)
+wit2 <- wca(pcaspe, meau$design$season, scan = FALSE, nf = 2)
+kta1 <- ktab.within(wit1, colnames = rep(c("S1","S2","S3","S4","S5","S6"), 4))
+kta2 <- ktab.within(wit2, colnames = rep(c("S1","S2","S3","S4","S5","S6"), 4))
+kcoi <- ktab.match2ktabs(kta1, kta2)
+ptacoi <- pta(kcoi, scan = FALSE, nf = 2)
+plot(ptacoi)
+kplot(ptacoi)
+}
+\keyword{multivariate}
diff --git a/man/ktab.within.Rd b/man/ktab.within.Rd
new file mode 100644
index 0000000..41e84e5
--- /dev/null
+++ b/man/ktab.within.Rd
@@ -0,0 +1,35 @@
+\name{ktab.within}
+\alias{ktab.within}
+\title{Process to go from a Within Analysis to a K-tables}
+\description{
+performs the process to go from a Within Analysis to a K-tables.
+}
+\usage{
+ktab.within(dudiwit, rownames = NULL, colnames = NULL, tabnames = NULL)
+}
+\arguments{
+ \item{dudiwit}{an objet of class \code{within}}
+ \item{rownames}{the row names of the K-tables (otherwise the row names of \code{dudiwit$tab})}
+ \item{colnames}{the column names of the K-tables (otherwise the column names \cr
+ of \code{dudiwit$tab})}
+ \item{tabnames}{the names of the arrays of the K-tables (otherwise the levels of the factor which defines the within-classes)}
+}
+\value{
+a list of class \code{ktab}. See \code{\link{ktab}}
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(bacteria)
+w1 <- data.frame(t(bacteria$espcodon))
+dudi1 <- dudi.coa(w1, scann = FALSE, nf = 4)
+wit1 <- wca(dudi1, bacteria$code, scannf = FALSE)
+kta1 <- ktab.within(wit1)
+plot(statis(kta1, scann = FALSE))
+
+kta2 <- kta1[kta1$blo>3]
+kplot(mfa(kta2, scann = FALSE))
+}
+\keyword{multivariate}
diff --git a/man/lascaux.Rd b/man/lascaux.Rd
new file mode 100644
index 0000000..b8459a9
--- /dev/null
+++ b/man/lascaux.Rd
@@ -0,0 +1,60 @@
+\name{lascaux}
+\alias{lascaux}
+\docType{data}
+\title{Genetic/Environment and types of variables}
+\description{
+This data set gives meristic, genetic and morphological data frame
+for 306 trouts.
+}
+\usage{data(lascaux)}
+\format{
+ \code{lascaux} is a list of 9 components.
+ \describe{
+ \item{riv}{is a factor returning the river where 306 trouts are captured}
+ \item{code}{vector of characters : code of the 306 trouts}
+ \item{sex}{factor sex of the 306 trouts}
+ \item{meris}{data frame 306 trouts - 5 meristic variables}
+ \item{tap}{data frame of the total number of red and black points}
+ \item{gen}{factor of the genetic code of the 306 trouts}
+ \item{morpho}{data frame 306 trouts 37 morphological variables}
+ \item{colo}{data frame 306 trouts 15 variables of coloring}
+ \item{ornem}{data frame 306 trouts 15 factors (ornementation)}
+ }
+}
+\source{
+Lascaux, J.M. (1996)
+\emph{Analyse de la variabilité morphologique de la truite commune (Salmo trutta L.) dans les cours d'eau du bassin pyrénéen méditerranéen}.
+Thèse de doctorat en sciences agronomiques, INP Toulouse.
+}
+\references{
+See a data description at \url{http://pbil.univ-lyon1.fr/R/pdf/pps022.pdf} (in French).
+}
+\examples{
+data(lascaux)
+
+if(adegraphicsLoaded()) {
+ g1 <- s1d.barchart(dudi.pca(lascaux$meris, scan = FALSE)$eig, psub.text = "Meristic",
+ p1d.horizontal = FALSE, plot = FALSE)
+ g2 <- s1d.barchart(dudi.pca(lascaux$colo, scan = FALSE)$eig, psub.text = "Coloration",
+ p1d.horizontal = FALSE, plot = FALSE)
+ g3 <- s1d.barchart(dudi.pca(na.omit(lascaux$morpho), scan = FALSE)$eig,
+ psub.text = "Morphometric", p1d.horizontal = FALSE, plot = FALSE)
+ g4 <- s1d.barchart(dudi.acm(na.omit(lascaux$orne), scan = FALSE)$eig,
+ psub.text = "Ornemental", p1d.horizontal = FALSE, plot = FALSE)
+
+ G <- ADEgS(c(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2,2))
+ barplot(dudi.pca(lascaux$meris, scan = FALSE)$eig)
+ title(main = "Meristic")
+ barplot(dudi.pca(lascaux$colo, scan = FALSE)$eig)
+ title(main = "Coloration")
+ barplot(dudi.pca(na.omit(lascaux$morpho), scan = FALSE)$eig)
+ title(main = "Morphometric")
+ barplot(dudi.acm(na.omit(lascaux$orne), scan = FALSE)$eig)
+ title(main = "Ornemental")
+ par(mfrow = c(1,1))
+}
+}
+\keyword{datasets}
diff --git a/man/lingoes.Rd b/man/lingoes.Rd
new file mode 100644
index 0000000..fcd295d
--- /dev/null
+++ b/man/lingoes.Rd
@@ -0,0 +1,46 @@
+\name{lingoes}
+\alias{lingoes}
+\title{Transformation of a Distance Matrix for becoming Euclidean}
+\description{
+transforms a distance matrix in a Euclidean one.
+}
+\usage{
+lingoes(distmat, print = FALSE, tol = 1e-07, cor.zero = TRUE)
+}
+\arguments{
+ \item{distmat}{an object of class \code{dist}}
+ \item{print}{if TRUE, prints the eigenvalues of the matrix}
+ \item{tol}{a tolerance threshold for zero}
+ \item{cor.zero}{if TRUE, zero distances are not modified}
+}
+\value{
+returns an object of class \code{dist} with a Euclidean distance
+}
+\references{Lingoes, J.C. (1971) Some boundary conditions for a monotone analysis of symmetric matrices.
+\emph{Psychometrika}, \bold{36}, 195--203.
+}
+\details{
+ The function uses the smaller positive constant k which transforms the matrix of \eqn{\sqrt{d_{ij}^2 + 2 \ast k}}{sqrt(dij² + 2*k)} in an Euclidean one
+}
+\author{
+Daniel Chessel \cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\examples{
+data(capitales)
+d0 <- capitales$dist
+is.euclid(d0) # FALSE
+d1 <- lingoes(d0, TRUE)
+# Lingoes constant = 2120982
+is.euclid(d1) # TRUE
+plot(d0, d1)
+x0 <- sort(unclass(d0))
+lines(x0, sqrt(x0^2 + 2 * 2120982), lwd = 3)
+
+is.euclid(sqrt(d0^2 + 2 * 2120981), tol = 1e-10) # FALSE
+is.euclid(sqrt(d0^2 + 2 * 2120982), tol = 1e-10) # FALSE
+is.euclid(sqrt(d0^2 + 2 * 2120983), tol = 1e-10)
+ # TRUE the smaller constant
+}
+\keyword{array}
+\keyword{multivariate}
diff --git a/man/lizards.Rd b/man/lizards.Rd
new file mode 100644
index 0000000..a833f02
--- /dev/null
+++ b/man/lizards.Rd
@@ -0,0 +1,41 @@
+\name{lizards}
+\alias{lizards}
+\docType{data}
+\title{Phylogeny and quantitative traits of lizards}
+\description{
+This data set describes the phylogeny of 18 lizards as reported by Bauwens and Díaz-Uriarte (1997).
+It also gives life-history traits corresponding to these 18 species.
+}
+\usage{data(lizards)}
+\format{
+\code{lizards} is a list containing the 3 following objects :
+\describe{
+ \item{traits}{is a data frame with 18 species and 8 traits.}
+ \item{hprA}{is a character string giving the phylogenetic tree (hypothesized phylogenetic relationships based on immunological distances) in Newick format.}
+ \item{hprB}{is a character string giving the phylogenetic tree (hypothesized phylogenetic relationships based on morphological characteristics) in Newick format.}
+}}
+\details{
+Variables of \code{lizards$traits} are the following ones :
+mean.L (mean length (mm)), matur.L (length at maturity (mm)),
+max.L (maximum length (mm)), hatch.L (hatchling length (mm)),
+hatch.m (hatchling mass (g)), clutch.S (Clutch size),
+age.mat (age at maturity (number of months of activity)),
+clutch.F (clutch frequency).
+}
+\references{
+Bauwens, D., and Díaz-Uriarte, R. (1997) Covariation of life-history traits in lacertid lizards: a comparative study.
+\emph{American Naturalist}, \bold{149}, 91--111.
+
+See a data description at \url{http://pbil.univ-lyon1.fr/R/pdf/pps063.pdf} (in French).
+}
+\examples{
+data(lizards)
+w <- data.frame(scalewt(log(lizards$traits)))
+par(mfrow = c(1,2))
+wphy <- newick2phylog(lizards$hprA)
+table.phylog(w, wphy, csi = 3)
+wphy <- newick2phylog(lizards$hprB)
+table.phylog(w, wphy, csi = 3)
+par(mfrow = c(1,1))
+}
+\keyword{datasets}
diff --git a/man/macaca.Rd b/man/macaca.Rd
new file mode 100644
index 0000000..bb259e1
--- /dev/null
+++ b/man/macaca.Rd
@@ -0,0 +1,41 @@
+\name{macaca}
+\alias{macaca}
+\docType{data}
+\title{Landmarks}
+\description{
+This data set gives the landmarks of a macaca at the ages of 0.9 and 5.77 years.
+}
+\usage{data(macaca)}
+\format{
+ \code{macaca} is a list of 2 components.
+ \describe{
+ \item{xy1}{is a data frame with 72 points and 2 coordinates.}
+ \item{xy2}{is a data frame with 72 points and 2 coordinates.}
+ }
+}
+\source{
+Olshan, A.F., Siegel, A.F. and Swindler, D.R. (1982)
+Robust and least-squares orthogonal mapping: Methods for the study of cephalofacial form and growth.
+\emph{American Journal of Physical Anthropology}, \bold{59}, 131--137.
+}
+\examples{
+data(macaca)
+pro1 <- procuste(macaca$xy1, macaca$xy2, scal = FALSE)
+pro2 <- procuste(macaca$xy1, macaca$xy2)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.match(macaca$xy1, macaca$xy2, plab.cex = 0, plot = FALSE)
+ g2 <- s.match(pro1$tabX, pro1$rotY, plab.cex = 0.7, plot = FALSE)
+ g3 <- s.match(pro1$tabY, pro1$rotX, plab.cex = 0.7, plot = FALSE)
+ g4 <- s.match(pro2$tabY, pro2$rotX, plab.cex = 0.7, plot = FALSE)
+ G <- ADEgS(c(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2,2))
+ s.match(macaca$xy1, macaca$xy2, clab = 0)
+ s.match(pro1$tabX, pro1$rotY, clab = 0.7)
+ s.match(pro1$tabY, pro1$rotX, clab = 0.7)
+ s.match(pro2$tabY, pro2$rotX, clab = 0.7)
+ par(mfrow = c(1,1))
+}}
+\keyword{datasets}
diff --git a/man/macon.Rd b/man/macon.Rd
new file mode 100644
index 0000000..313855b
--- /dev/null
+++ b/man/macon.Rd
@@ -0,0 +1,17 @@
+\name{macon}
+\alias{macon}
+\docType{data}
+\title{Wine Tasting}
+\usage{data(macon)}
+\description{
+The \code{macon} data frame has 8 rows-wines and 25 columns-tasters.
+Each column is a classification of 8 wines (Beaujolais, France).
+}
+\source{
+Foire Nationale des Vins de France, Mâcon, 1985
+}
+\examples{
+data(macon)
+s.corcircle(dudi.pca(macon, scan = FALSE)$co)
+}
+\keyword{datasets}
diff --git a/man/macroloire.Rd b/man/macroloire.Rd
new file mode 100755
index 0000000..45e41cc
--- /dev/null
+++ b/man/macroloire.Rd
@@ -0,0 +1,80 @@
+\name{macroloire}
+\alias{macroloire}
+\docType{data}
+\title{Assemblages of Macroinvertebrates in the Loire River (France)}
+\description{
+A total of 38 sites were surveyed along 800 km of the Loire River yielding 40 species
+of Trichoptera and Coleoptera sampled from riffle habitats. The river was divided
+into three regions according to geology: granitic highlands (Region#1),
+limestone lowlands (Region#2) and granitic lowlands (Region#3). This data set has been
+collected for analyzing changes in macroinvertebrate assemblages
+along the course of a large river. Four criterias are given here: variation in 1/ species composition
+and relative abundance, 2/ taxonomic composition, 3/ Body Sizes, 4/ Feeding habits.
+}
+\usage{data(macroloire)}
+\format{
+ \code{macroloire} is a list of 5 components.
+ \describe{
+ \item{fau}{is a data frame containing the abundance of each species in each station.}
+ \item{traits}{is a data frame describes two traits : the maximal sizes and feeding habits for each species.
+ Each trait is divided into categories. The maximal size achieved by the species
+ is divided into four length categories: <= 5mm ; >5-10mm ; >10-20mm ; >20-40mm.
+ Feeding habits comprise seven categories: engulfers, shredders, scrapers,
+ deposit-feeders, active filter-feeders, passive filter-feeders and piercers, in this order.
+ The affinity of each species to each trait category is quantified using a fuzzy coding approach.
+ A score is assigned to each species for describing its affinity for a given trait category from "0"
+ which indicates no affinity to "3" which indicates high affinity. These affinities are
+ further transformed into percentage per trait per species.}
+ \item{taxo}{is a data frame with species and 3 factors: Genus, Family
+ and Order. It is a data frame of class "taxo": the
+ variables are factors giving nested classifications.}
+ \item{envir}{is a data frame giving for each station, its name (variable "SamplingSite"),
+ its distance from the source (km, variable "Distance"), its altitude (m, variable "Altitude"),
+ its position regarding the dams [1: before the first dam; 2:
+ after the first dam; 3: after the second dam] (variable "Dam"),
+ its position in one of the three regions defined according to
+ geology: granitic highlands, limestone lowlands and granitic
+ lowlands (variable "Morphoregion"), presence of confluence (variable "Confluence")}
+ \item{labels}{is a data frame containing the latin names of the species.}
+ }
+}
+\source{
+ Ivol, J.M., Guinand, B., Richoux, P. and Tachet, H. (1997) Longitudinal changes in
+ Trichoptera and Coleoptera assemblages and environmental conditions in the Loire
+ River (France). \emph{Archiv for Hydrobiologie}, \bold{138}, 525--557.\cr
+
+ Pavoine S. and Doledec S. (2005) The apportionment of quadratic entropy:
+ a useful alternative for partitioning diversity in ecological data.
+ \emph{Environmental and Ecological Statistics}, \bold{12}, 125--138.
+}
+\examples{
+ data(macroloire)
+ apqe.Equi <- apqe(macroloire$fau, , macroloire$morphoregions)
+ apqe.Equi
+ #test.Equi <- randtest.apqe(apqe.Equi, method = "aggregated", 99)
+ #plot(test.Equi)
+
+ \dontrun{
+
+ m.phy <- taxo2phylog(macroloire$taxo)
+ apqe.Tax <- apqe(macroloire$fau, m.phy$Wdist, macroloire$morphoregions)
+ apqe.Tax
+ #test.Tax <- randtest.apqe(apqe.Tax, method = "aggregated", 99)
+ #plot(test.Tax)
+
+ dSize <- sqrt(dist.prop(macroloire$traits[ ,1:4], method = 2))
+ apqe.Size <- apqe(macroloire$fau, dSize, macroloire$morphoregions)
+ apqe.Size
+ #test.Size <- randtest.apqe(apqe.Size, method = "aggregated", 99)
+ #plot(test.Size)
+
+ dFeed <- sqrt(dist.prop(macroloire$traits[ ,-(1:4)], method = 2))
+ apqe.Feed <- apqe(macroloire$fau, dFeed, macroloire$morphoregions)
+ apqe.Feed
+ #test.Feed <- randtest.apqe(apqe.Feed, method = "aggregated", 99)
+ #plot(test.Size)
+
+ }
+
+}
+\keyword{datasets}
diff --git a/man/mafragh.Rd b/man/mafragh.Rd
new file mode 100644
index 0000000..c26b829
--- /dev/null
+++ b/man/mafragh.Rd
@@ -0,0 +1,112 @@
+\name{mafragh}
+\alias{mafragh}
+\docType{data}
+
+\title{Phyto-Ecological Survey}
+
+\description{This data set gives environmental and spatial informations about species and sites.}
+
+\usage{data(mafragh)}
+
+\format{
+ \code{mafragh} is a list of 12 components:
+ \describe{
+ \item{xy}{are the coordinates of 97 sites.}
+ \item{flo}{is a data frame with 97 sites and 56 species.}
+ \item{neig}{is the neighbourhood graph of the 97 sites (an object of class \code{neig}).}
+ \item{env}{is a data frame with 97 sites and 11 environmental variables.}
+ \item{partition}{is a factor classifying the 97 sites in 7 classes.}
+ \item{area}{is a data frame of class \code{area}}
+ \item{tre}{a character providing the phylogeny as a newick object}
+ \item{traits}{a list of data frame. Each data frame provides the value of biological traits for plant species.}
+ \item{nb}{is the neighbourhood graph of the 97 Mafragh sites (an object of class \code{nb}).}
+ \item{Spatial}{is the map of the 97 Mafragh sites (an object of the class \code{SpatialPolygons} of \code{sp}).}
+ \item{spenames}{is a data frame with 56 rows (species) and 2 columns (names).}
+ \item{Spatial.contour}{is the contour of the Magragh map (an object of the class \code{SpatialPolygons} of \code{sp}).}
+}}
+
+\source{
+ de Bélair, Gérard and Bencheikh-Lehocine, Mahmoud (1987) Composition et déterminisme de la végétation d'une
+ plaine côtière marécageuse : La Mafragh (Annaba, Algérie). \emph{Bulletin d'Ecologie}, \bold{18}(4), 393--407.
+
+ Pavoine, S., Vela, E., Gachet, S., de Bélair, G. and Bonsall, M. B. (2011)
+ Linking patterns in phylogeny, traits, abiotic variables and space: a novel approach to linking environmental filtering and plant community assembly.
+ \emph{Journal of Ecology}, \bold{99}, 165--175. doi:10.1111/j.1365-2745.2010.01743.x
+}
+
+\references{See a data description at \url{http://pbil.univ-lyon1.fr/R/pdf/pps053.pdf} (in French).}
+
+\examples{
+data(mafragh)
+coa1 <- dudi.coa(mafragh$flo, scan = FALSE)
+pca1 <- dudi.pca(mafragh$xy, scan = FALSE)
+if(adegraphicsLoaded()) {
+ g1 <- s.label(mafragh$xy, nb = mafragh$nb, psub.text = "Samples & Neighbourhood graph",
+ plot = FALSE)
+ g2 <- s.value(mafragh$xy, coa1$li[, 1], psub.text = "Axis 1 - COA", plot = FALSE)
+ g3 <- s.value(mafragh$xy, pca1$li[, 1], psub.text = "Axis 1 - PCA", plot = FALSE)
+ g4 <- s.class(pca1$li, mafragh$partition, psub.text = "Plane 1-2 - PCA", plot = FALSE)
+ g5 <- s.class(coa1$li, mafragh$partition, psub.text = "Plane 1-2 - COA", plot = FALSE)
+ g6 <- s.class(mafragh$xy, mafragh$partition, chullSize = 1, ellipseSize = 0, starSize = 0,
+ ppoints.cex = 0, plot = FALSE)
+ G <- ADEgS(c(g1, g2, g3, g4, g5, g6), layout = c(3, 2))
+
+} else {
+ par(mfrow = c(3, 2))
+ s.label(mafragh$xy, inc = FALSE, neig = mafragh$neig, sub = "Samples & Neighbourhood graph")
+ s.value(mafragh$xy, coa1$li[, 1], sub = "Axis 1 - COA")
+ s.value(mafragh$xy, pca1$li[, 1], sub = "Axis 1 - PCA")
+ s.class(pca1$li, mafragh$partition, sub = "Plane 1-2 - PCA")
+ s.class(coa1$li, mafragh$partition, sub = "Plane 1-2 - COA")
+ s.chull(mafragh$xy, mafragh$partition, optchull = 1)
+ par(mfrow = c(1, 1))
+}
+
+\dontrun{
+link1 <- area2link(mafragh$area)
+neig1 <- neig(mat01 = 1*(link1 > 0))
+nb1 <- neig2nb(neig1)
+
+if(adegraphicsLoaded()) {
+ if(requireNamespace("sp", quietly = TRUE)) {
+ g7 <- s.label(mafragh$xy, Sp = mafragh$Spatial, pSp.col = "white", plot = FALSE)
+ g8 <- s.label(mafragh$xy, Sp = mafragh$Spatial, pSp.col = "white", nb = nb1, plab.cex = 0,
+ pnb.node.cex = 0, ppoints.cex = 0, plot = FALSE)
+ G <- ADEgS(c(g7, g8), layout = c(2, 1))
+ }
+
+} else {
+ par(mfrow = c(2, 1))
+ area.plot(mafragh$area, center = mafragh$xy, clab = 0.75)
+ area.plot(mafragh$area, center = mafragh$xy, graph = neig1)
+ par(mfrow = c(1, 1))
+}
+
+if(requireNamespace("maptools", quietly = TRUE) & requireNamespace("spdep", quietly = TRUE)) {
+ lw1 <- apply(link1, 1, function(x) x[x > 0])
+ listw1 <- spdep::nb2listw(nb1, lw1)
+ coa1 <- dudi.coa(mafragh$flo, scan = FALSE, nf = 4)
+ ms1 <- multispati(coa1, listw1, scan = FALSE, nfp = 2, nfn = 0)
+ summary(ms1)
+
+ if(adegraphicsLoaded()) {
+ if(requireNamespace("lattice", quietly = TRUE)) {
+ g9 <- s1d.barchart(coa1$eig, p1d.hori = FALSE, plot = FALSE)
+ g10 <- s1d.barchart(ms1$eig, p1d.hori = FALSE, plot = FALSE)
+ g11 <- s.corcircle(ms1$as, plot = FALSE)
+ g12 <- lattice::xyplot(ms1$li[, 1] ~ coa1$li[, 1])
+ G <- ADEgS(list(g9, g10, g11, g12), layout = c(2, 2))
+ }
+
+ } else {
+ par(mfrow = c(2, 2))
+ barplot(coa1$eig)
+ barplot(ms1$eig)
+ s.corcircle(ms1$as)
+ plot(coa1$li[, 1], ms1$li[, 1])
+ par(mfrow = c(1, 1))
+ }
+}
+}}
+
+\keyword{datasets}
\ No newline at end of file
diff --git a/man/mantel.randtest.Rd b/man/mantel.randtest.Rd
new file mode 100644
index 0000000..bb495fc
--- /dev/null
+++ b/man/mantel.randtest.Rd
@@ -0,0 +1,31 @@
+\name{mantel.randtest}
+\alias{mantel.randtest}
+\title{Mantel test (correlation between two distance matrices (in C).)
+}
+\description{
+Performs a Mantel test between two distance matrices.
+}
+\usage{
+mantel.randtest(m1, m2, nrepet = 999, ...)
+}
+\arguments{
+ \item{m1}{an object of class \code{dist}}
+ \item{m2}{an object of class \code{dist}}
+ \item{nrepet}{the number of permutations}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+an object of class \code{randtest} (randomization tests)
+}
+\references{Mantel, N. (1967) The detection of disease clustering and a generalized regression approach. \emph{Cancer Research}, \bold{27}, 209--220.
+}
+\author{Jean Thioulouse \email{Jean.Thioulouse at univ-lyon1.fr}}
+\examples{
+data(yanomama)
+gen <- quasieuclid(as.dist(yanomama$gen))
+geo <- quasieuclid(as.dist(yanomama$geo))
+plot(r1 <- mantel.randtest(geo,gen), main = "Mantel's test")
+r1
+}
+\keyword{array}
+\keyword{nonparametric}
diff --git a/man/mantel.rtest.Rd b/man/mantel.rtest.Rd
new file mode 100644
index 0000000..ecf41e1
--- /dev/null
+++ b/man/mantel.rtest.Rd
@@ -0,0 +1,34 @@
+\name{mantel.rtest}
+\alias{mantel.rtest}
+\title{Mantel test (correlation between two distance matrices (in R).)
+}
+\description{
+Performs a Mantel test between two distance matrices.
+}
+\usage{
+mantel.rtest(m1, m2, nrepet = 99, ...)
+}
+\arguments{
+ \item{m1}{an object of class \code{dist}}
+ \item{m2}{an object of class \code{dist}}
+ \item{nrepet}{the number of permutations}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+an object of class \code{rtest} (randomization tests)
+}
+\references{Mantel, N. (1967) The detection of disease clustering and a generalized regression approach. \emph{Cancer Research}, \bold{27}, 209--220.
+}
+\author{
+Daniel Chessel \cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\examples{
+ data(yanomama)
+ gen <- quasieuclid(as.dist(yanomama$gen))
+ geo <- quasieuclid(as.dist(yanomama$geo))
+ plot(r1 <- mantel.rtest(geo,gen), main = "Mantel's test")
+ r1
+}
+\keyword{array}
+\keyword{nonparametric}
diff --git a/man/maples.Rd b/man/maples.Rd
new file mode 100644
index 0000000..f7d7002
--- /dev/null
+++ b/man/maples.Rd
@@ -0,0 +1,42 @@
+\name{maples}
+\alias{maples}
+\docType{data}
+\title{Phylogeny and quantitative traits of flowers}
+\description{
+This data set describes the phylogeny of 17 flowers as reported by Ackerly and Donoghue (1998). It also gives 31 traits corresponding to these 17 species.
+}
+\usage{data(maples)}
+\format{
+ \code{tithonia} is a list containing the 2 following objects :
+ \describe{
+ \item{tre}{is a character string giving the phylogenetic tree in Newick format.}
+ \item{tab}{is a data frame with 17 species and 31 traits}
+ }
+}
+\references{
+Ackerly, D. D. and Donoghue, M.J. (1998) Leaf size, sappling allometry, and Corner's rules: phylogeny and correlated evolution in Maples (Acer).
+\emph{American Naturalist}, \bold{152}, 767--791.
+}
+\examples{
+data(maples)
+phy <- newick2phylog(maples$tre)
+dom <- maples$tab$Dom
+bif <- maples$tab$Bif
+if (requireNamespace("adephylo", quietly = TRUE) & requireNamespace("ape", quietly = TRUE)) {
+ phylo <- ape::read.tree(text = maples$tre)
+ adephylo::orthogram(dom, tre = phylo)
+ adephylo::orthogram(bif, tre = phylo)
+ par(mfrow = c(1, 2))
+ dotchart.phylog(phy, dom)
+ dotchart.phylog(phy, bif, clabel.nodes = 0.7)
+ par(mfrow = c(1, 1))
+ plot(bif, dom, pch = 20)
+ abline(lm(dom~bif))
+ summary(lm(dom~bif))
+ cor.test(bif, dom)
+ pic.bif <- ape::pic(bif, phylo)
+ pic.dom <- ape::pic(dom, phylo)
+ cor.test(pic.bif, pic.dom)
+}
+}
+\keyword{datasets}
diff --git a/man/mariages.Rd b/man/mariages.Rd
new file mode 100644
index 0000000..913d4a3
--- /dev/null
+++ b/man/mariages.Rd
@@ -0,0 +1,43 @@
+\name{mariages}
+\alias{mariages}
+\docType{data}
+\title{Correspondence Analysis Table}
+\description{
+This array contains the socio-professionnal repartitions of 5850 couples.
+}
+\usage{data(mariages)}
+\format{
+The \code{mariages} data frame has 9 rows and 9 columns.
+The rows represent the wife's socio-professionnal category and the columns the husband's socio-professionnal category (1982).\cr
+
+Codes for rows and columns are identical : agri (Farmers), ouva (Farm workers),
+pat (Company directors (commerce and industry)), sup (Liberal profession, executives and higher intellectual professions),
+moy (Intermediate professions), emp (Other white-collar workers), ouv (Manual workers), serv (Domestic staff),
+aut (other workers).
+}
+\source{
+Vallet, L.A. (1986)
+Activité professionnelle de la femme mariée et détermination de la position sociale de la famille.
+Un test empirique : la France entre 1962 et 1982.
+\emph{Revue Française de Sociologie}, \bold{27}, 656--696.
+}
+\examples{
+data(mariages)
+w <- dudi.coa(mariages, scan = FALSE, nf = 3)
+
+if(adegraphicsLoaded()) {
+ g1 <- scatter(w, met = 1, posi = "bottomleft", plot = FALSE)
+ g2 <- scatter(w, met = 2, posi = "bottomleft", plot = FALSE)
+ g3 <- scatter(w, met = 3, posi = "bottomleft", plot = FALSE)
+ ## g4 <- score(w, 3)
+ G <- ADEgS(list(g1, g2, g3), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2, 2))
+ scatter(w, met = 1, posi = "bottom")
+ scatter(w, met = 2, posi = "bottom")
+ scatter(w, met = 3, posi = "bottom")
+ score(w, 3)
+ par(mfrow = c(1, 1))
+}}
+\keyword{datasets}
diff --git a/man/mbpcaiv.Rd b/man/mbpcaiv.Rd
new file mode 100644
index 0000000..d39cd96
--- /dev/null
+++ b/man/mbpcaiv.Rd
@@ -0,0 +1,70 @@
+\name{mbpcaiv}
+\alias{mbpcaiv}
+
+\title{Multiblock principal component analysis with instrumental variables}
+\description{Function to perform a multiblock redundancy analysis of several explanatory blocks \eqn{(X_1, \dots, X_k)}, defined as an object of class \code{ktab}, to explain a dependent dataset $Y$, defined as an object of class \code{dudi}}
+\usage{
+mbpcaiv(dudiY, ktabX, scale = TRUE, option = c("uniform", "none"), scannf = TRUE, nf = 2)
+}
+
+\arguments{
+ \item{dudiY}{an object of class \code{dudi} containing the dependent variables}
+ \item{ktabX}{an object of class \code{ktab} containing the blocks of
+ explanatory variables}
+\item{scale}{logical value indicating whether the explanatory variables
+ should be standardized}
+\item{option}{an option for the block weighting. If \code{uniform},
+ the block weight is equal to $1/K$ for \eqn{(X_1, \dots, X_K)} and to
+ $1$ for $X$ and $Y$. If \code{none}, the block weight is equal to the
+ block inertia}
+\item{scannf}{logical value indicating whether the eigenvalues bar plot should be displayed}
+\item{nf}{integer indicating the number of kept dimensions}
+}
+
+
+\value{A list containing the following components is returned:
+\item{call}{the matching call}
+\item{tabY}{data frame of dependent variables centered, eventually scaled (if \option{scale=TRUE}) and weighted (if \option{option="uniform"})}
+\item{tabX}{data frame of explanatory variables centered, eventually scaled (if \option{scale=TRUE}) and weighted (if \option{option="uniform"})}
+\item{TL, TC}{data frame useful to manage graphical outputs}
+\item{nf}{numeric value indicating the number of kept dimensions}
+\item{lw}{numeric vector of row weights}
+\item{X.cw}{numeric vector of column weighs for the explanalatory dataset}
+\item{blo}{vector of the numbers of variables in each explanatory dataset}
+\item{rank}{maximum rank of the analysis}
+\item{eig}{numeric vector containing the eigenvalues}
+\item{lX}{matrix of the global components associated with the whole explanatory dataset (scores of the individuals)}
+\item{lY}{matrix of the components associated with the dependent dataset}
+\item{Yc1}{matrix of the variable loadings associated with the dependent dataset}
+\item{Tli}{matrix containing the partial components associated with each explanatory dataset}
+\item{Tl1}{matrix containing the normalized partial components associated with each explanatory dataset}
+\item{Tfa}{matrix containing the partial loadings associated with each explanatory dataset}
+\item{cov2}{squared covariance between lY and Tl1}
+\item{Yco}{matrix of the regression coefficients of the dependent dataset onto the global components}
+\item{faX}{matrix of the regression coefficients of the whole explanatory dataset onto the global components}
+\item{XYcoef}{list of matrices of the regression coefficients of the whole explanatory dataset onto the dependent dataset}
+\item{bip}{block importances for a given dimension}
+\item{bipc}{cumulated block importances for a given number of dimensions}
+\item{vip}{variable importances for a given dimension}
+\item{vipc}{cumulated variable importances for a given number of dimensions}
+}
+\references{Bougeard, S., Qannari, E.M. and Rose, N. (2011) Multiblock Redundancy Analysis: interpretation tools and application in epidemiology. \emph{Journal of Chemometrics}, 23, 1-9}
+\author{Stéphanie Bougeard (\email{stephanie.bougeard at anses.fr}) and Stéphane Dray (\email{stephane.dray at univ-lyon1.fr})}
+
+\seealso{\code{\link{mbpls}}, \code{\link{testdim.multiblock}}, \code{\link{randboot.multiblock}}}
+\examples{
+data(chickenk)
+Mortality <- chickenk[[1]]
+dudiY.chick <- dudi.pca(Mortality, center = TRUE, scale = TRUE, scannf =
+FALSE)
+ktabX.chick <- ktab.list.df(chickenk[2:5])
+resmbpcaiv.chick <- mbpcaiv(dudiY.chick, ktabX.chick, scale = TRUE,
+option = "uniform", scannf = FALSE)
+summary(resmbpcaiv.chick)
+if(adegraphicsLoaded())
+plot(resmbpcaiv.chick)
+}
+
+
+\keyword{multivariate}
+
diff --git a/man/mbpls.Rd b/man/mbpls.Rd
new file mode 100644
index 0000000..737e13e
--- /dev/null
+++ b/man/mbpls.Rd
@@ -0,0 +1,68 @@
+\name{mbpls}
+\alias{mbpls}
+
+\title{Multiblock partial least squares}
+\description{Function to perform a multiblock partial least squares (PLS) of several explanatory blocks \eqn{(X_1, \dots, X_k)} defined as an object of class \code{ktab}, to explain a dependent dataset $Y$ defined as an object of class \code{dudi}}
+\usage{
+mbpls(dudiY, ktabX, scale = TRUE, option = c("uniform", "none"), scannf = TRUE, nf = 2)
+}
+
+\arguments{
+ \item{dudiY}{an object of class \code{dudi} containing the dependent variables}
+ \item{ktabX}{an object of class \code{ktab} containing the blocks of
+ explanatory variables}
+ \item{scale}{logical value indicating whether the explanatory variables
+ should be standardized}
+ \item{option}{an option for the block weighting. If \code{uniform},
+ the block weight is equal to $1/K$ for \eqn{(X_1, \dots, X_K)} and to
+ $1$ for $X$ and $Y$. If \code{none}, the block weight is equal to the block inertia}
+ \item{scannf}{logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{integer indicating the number of kept dimensions}
+}
+
+\value{A list containing the following components is returned:
+\item{call}{the matching call}
+\item{tabY}{data frame of dependent variables centered, eventually scaled (if \option{scale=TRUE}) and weighted (if \option{option="uniform"})}
+\item{tabX}{data frame of explanatory variables centered, eventually scaled (if \option{scale=TRUE}) and weighted (if \option{option="uniform"})}
+\item{TL, TC}{data frame useful to manage graphical outputs}
+\item{nf}{numeric value indicating the number of kept dimensions}
+\item{lw}{numeric vector of row weights}
+\item{X.cw}{numeric vector of column weighs for the explanalatory dataset}
+\item{blo}{vector of the numbers of variables in each explanatory dataset}
+\item{rank}{maximum rank of the analysis}
+\item{eig}{numeric vector containing the eigenvalues}
+\item{lX}{matrix of the global components associated with the whole explanatory dataset (scores of the individuals)}
+\item{lY}{matrix of the components associated with the dependent dataset}
+\item{Yc1}{matrix of the variable loadings associated with the dependent
+ dataset}
+\item{cov2}{squared covariance between lY and TlX}
+\item{Tc1}{matrix containing the partial loadings associated with each
+ explanatory dataset (unit norm)}
+\item{TlX}{matrix containing the partial components associated with each explanatory dataset}
+\item{faX}{matrix of the regression coefficients of the whole explanatory dataset onto the global components}
+\item{XYcoef}{list of matrices of the regression coefficients of the whole explanatory dataset onto the dependent dataset}
+\item{bip}{block importances for a given dimension}
+\item{bipc}{cumulated block importances for a given number of dimensions}
+\item{vip}{variable importances for a given dimension}
+\item{vipc}{cumulated variable importances for a given number of dimensions}
+}
+\references{Bougeard, S., Qannari, E.M., Lupo, C. and Hanafi, M. (2011). From multiblock partial least squares to multiblock redundancy analysis. A continuum approach. \emph{Informatica}, 22(1), 11-26}
+\author{Stéphanie Bougeard (\email{stephanie.bougeard at anses.fr}) and Stéphane Dray (\email{stephane.dray at univ-lyon1.fr})}
+
+\seealso{\code{\link{mbpls}}, \code{\link{testdim.multiblock}},
+ \code{\link{randboot.multiblock}}}
+
+\examples{
+data(chickenk)
+Mortality <- chickenk[[1]]
+dudiY.chick <- dudi.pca(Mortality, center = TRUE, scale = TRUE, scannf =
+FALSE)
+ktabX.chick <- ktab.list.df(chickenk[2:5])
+resmbpls.chick <- mbpls(dudiY.chick, ktabX.chick, scale = TRUE,
+option = "uniform", scannf = FALSE)
+summary(resmbpls.chick)
+if(adegraphicsLoaded())
+plot(resmbpls.chick)
+}
+
+\keyword{multivariate}
diff --git a/man/mcoa.Rd b/man/mcoa.Rd
new file mode 100644
index 0000000..c91c693
--- /dev/null
+++ b/man/mcoa.Rd
@@ -0,0 +1,70 @@
+\name{mcoa}
+\alias{mcoa}
+\alias{print.mcoa}
+\alias{summary.mcoa}
+\alias{plot.mcoa}
+\title{Multiple CO-inertia Analysis}
+\description{
+performs a multiple CO-inertia analysis,
+using an object of class \code{ktab}.
+}
+\usage{
+mcoa(X, option = c("inertia", "lambda1", "uniform", "internal"),
+ scannf = TRUE, nf = 3, tol = 1e-07)
+\method{print}{mcoa}(x, \dots)
+\method{summary}{mcoa}(object, \dots)
+\method{plot}{mcoa}(x, xax = 1, yax = 2, eig.bottom = TRUE, \dots)
+}
+\arguments{
+ \item{X}{an object of class \code{ktab}}
+ \item{option}{a string of characters for the weightings of the arrays
+ options :
+ \describe{
+ \item{"inertia"}{weighting of group k by the inverse of the total inertia of the array k}
+ \item{"lambda1"}{weighting of group k by the inverse of the first eigenvalue of the k analysis}
+ \item{"uniform"}{uniform weighting of groups}
+ \item{"internal"}{weighting included in \code{X$tabw}}
+ }
+ }
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+ \item{tol}{a tolerance threshold, an eigenvalue is considered positive if it is larger than \code{-tol*lambda1} where \code{lambda1} is the largest eigenvalue.}
+ \item{x, object}{an object of class 'mcoa'}
+ \item{\dots}{further arguments passed to or from other methods}
+ \item{xax, yax}{the numbers of the x-axis and the y-axis}
+ \item{eig.bottom}{a logical value indicating whether the eigenvalues bar plot should be added}
+}
+\value{
+mcoa returns a list of class 'mcoa' containing :
+ \item{pseudoeig}{a numeric vector with the all pseudo eigenvalues}
+ \item{call}{the call-up order}
+ \item{nf}{a numeric value indicating the number of kept axes}
+ \item{SynVar}{a data frame with the synthetic scores}
+ \item{axis}{a data frame with the co-inertia axes}
+ \item{Tli}{a data frame with the co-inertia coordinates}
+ \item{Tl1}{a data frame with the co-inertia normed scores}
+ \item{Tax}{a data frame with the inertia axes onto co-inertia axis}
+ \item{Tco}{a data frame with the column coordinates onto synthetic scores}
+ \item{TL}{a data frame with the factors for Tli Tl1}
+ \item{TC}{a data frame with the factors for Tco}
+ \item{T4}{a data frame with the factors for Tax}
+ \item{lambda}{a data frame with the all eigenvalues (computed on the separate analyses)}
+ \item{cov2}{a numeric vector with the all pseudo eigenvalues (synthetic analysis)}
+}
+\references{
+Chessel, D. and Hanafi, M. (1996) Analyses de la co-inertie de K nuages de points, \emph{Revue de Statistique Appliquée}, \bold{44}, 35--60.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(friday87)
+w1 <- data.frame(scale(friday87$fau, scal = FALSE))
+w2 <- ktab.data.frame(w1, friday87$fau.blo, tabnames = friday87$tab.names)
+mcoa1 <- mcoa(w2, "lambda1", scan = FALSE)
+mcoa1
+summary(mcoa1)
+plot(mcoa1)
+}
+\keyword{multivariate}
diff --git a/man/mdpcoa.Rd b/man/mdpcoa.Rd
new file mode 100644
index 0000000..cf86f94
--- /dev/null
+++ b/man/mdpcoa.Rd
@@ -0,0 +1,156 @@
+\name{mdpcoa}
+\alias{mdpcoa}
+\alias{kplotX.mdpcoa}
+\alias{prep.mdpcoa}
+\title{Multiple Double Principal Coordinate Analysis}
+\description{
+The DPCoA analysis (see \code{\link{dpcoa}}) has been developed by Pavoine et al. (2004).
+It has been used in genetics for describing inter-population nucleotide
+diversity. However, this procedure can only be used with one locus. In order to measure
+and describe nucleotide diversity with more than one locus, we developed three versions of
+multiple DPCoA by using three ordination methods: multiple co-inertia analysis, STATIS, and
+multiple factorial analysis.
+ The multiple DPCoA allows the impact of various loci in the
+measurement and description of diversity to be quantified and described. This method is general enough to handle a large variety
+of data sets. It complements existing methods such as the analysis of molecular variance or other
+analyses based on linkage disequilibrium measures, and is very useful to study the impact of various
+loci on the measurement of diversity.
+}
+\usage{
+mdpcoa(msamples, mdistances = NULL, method =
+ c("mcoa", "statis", "mfa"),
+ option = c("inertia", "lambda1", "uniform", "internal"),
+ scannf = TRUE, nf = 3, full = TRUE,
+ nfsep = NULL, tol = 1e-07)
+kplotX.mdpcoa(object, xax = 1, yax = 2, mfrow = NULL,
+ which.tab = 1:length(object$nX), includepop = FALSE,
+ clab = 0.7, cpoi = 0.7, unique.scale = FALSE,
+ csub = 2, possub = "bottomright")
+prep.mdpcoa(dnaobj, pop, model, ...)
+}
+\arguments{
+ \item{msamples}{A list of data frames with the populations as columns, alleles as rows and abundances as
+entries. All the tables should have equal numbers of columns (populations). Each table
+corresponds to a locus;}
+ \item{mdistances}{A list of objects of class 'dist', corresponding to the distances among alleles. The order of
+the loci should be the same in msamples as in mdistances;}
+ \item{method}{One of the three possibilities: "mcoa", "statis", or "mfa". If a vector is given, only its first
+value is considered;}
+ \item{option}{One of the four possibilities for normalizing the population coordinates over the loci:
+"inertia", "lambda1", "uniform", or "internal". These options are used with MCoA and
+MFA only;}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plots should be displayed;}
+ \item{nf}{if scannf is FALSE, an integer indicating the number of kept axes for the multiple analysis;}
+ \item{full}{a logical value indicating whether all the axes should be kept in the separated analyses
+(one analysis, DPCoA, per locus);}
+ \item{nfsep}{if full is FALSE, a vector indicating the number of kept axes for each of the separated
+analyses;}
+ \item{tol}{a tolerance threshold for null eigenvalues (a value less than tol times the first one is
+considered as null);}
+ \item{object}{an object of class 'mdpcoa';}
+ \item{xax}{the number of the x-axis;}
+ \item{yax}{the number of the y-axis;}
+ \item{mfrow}{a vector of the form 'c(nr,nc)', otherwise computed by as special own function 'n2mfrow';}
+ \item{which.tab}{a numeric vector containing the numbers of the loci to analyse;}
+ \item{includepop}{a logical indicating if the populations must be displayed. In that case, the alleles are
+displayed by points and the populations by labels;}
+ \item{clab}{a character size for the labels;}
+ \item{cpoi}{a character size for plotting the points, used with 'par("cex")'*cpoint. If zero, no points are
+drawn;}
+ \item{unique.scale}{if TRUE, all the arrays of figures have the same scale;}
+ \item{csub}{a character size for the labels of the arrays of figures used with 'par("cex")*csub';}
+ \item{possub}{a string of characters indicating the sub-title position
+("topleft", "topright", "bottomleft", "bottomright");}
+ \item{dnaobj}{a list of dna sequences that can be obtained with the function \code{read.dna} of the ape package;}
+ \item{pop}{a factor that gives the name of the population to which each sequence belongs;}
+ \item{model}{a vector giving the model to be applied for the calculations of
+the distances for each locus. One model should be attributed to each
+locus, given that the loci are in alphabetical order. The models can
+take the following values: "raw", "JC69", "K80" (the default), "F81",
+"K81", "F84", "BH87", "T92", "TN93", "GG95", "logdet", or "paralin".
+See the help documentation for the function "dist.dna" of ape for a
+describtion of the models.}
+ \item{\dots}{\code{\dots} further arguments passed to or from other methods}
+}
+\value{
+The functions provide the following results:
+ \item{dist.ktab}{returns an object of class \code{dist};}
+}
+\details{
+An object obtained by the function mdpcoa has two classes. The first one is "mdpcoa" and the
+second is either "mcoa", or "statis", or "mfa", depending on the method chosen.
+Consequently, other functions already available in ade4 for displaying graphical results can be
+used:
+With MCoA,
+- plot.mcoa: this function displays (1) the differences among the populations according
+to each locus and the compromise, (2) the projection of the principal axes of the
+individual analyses onto the synthetic variables,
+(3) the projection of the principal axes of the individual analyses onto the co-inertia
+axes, (4) the squared vectorial covariance
+among the coinertia scores and the synthetic variables;
+- kplot.mcoa: this function divides previous displays (figures 1, 2, or 3 described in
+plot.mcoa) by giving one plot per locus.
+
+With STATIS,
+- plot.statis: this function displays (1) the scores of each locus according to the two
+first eigenvectors of the matrix \emph{Rv}, (2) the scatter diagram of the differences among
+populations according to the compromise, (3) the weight attributed to each locus
+in abscissa and the vectorial covariance among each individual analysis with the
+notations in the main text of the paper) and the compromise analysis in
+ordinates, (4) the covariance between the principal component inertia axes of each
+locus and the axes of the compromise space;
+- kplot.statis: this function displays for each locus the projection of the principal
+axes onto the compromise space.
+
+With MFA,
+- plot.mfa: this function displays (1) the differences among the populations according
+to each locus and the compromise, (2) the projection of the principal axes of the
+individual analyses onto the compromise, (3) the covariance between the principal
+component inertia axes of each locus and the axes of the compromise space, (4) for
+each axis of the compromise, the amount of inertia conserved by the projection of the
+individual analyses onto the common space.
+- kplot.mfa: this function displays for each locus the projection of the principal axes
+and populations onto the compromise space.
+
+
+
+}
+\references{
+ Pavoine, S. and Bailly, X. (2007) New analysis for consistency among markers in the study of genetic diversity:
+ development and application to the description of bacterial diversity. \emph{BMC Evolutionary Biology}, \bold{7}, e156.\cr
+
+ Pavoine, S., Dufour, A.B. and Chessel, D. (2004) From dissimilarities among species to dissimilarities among communities:
+ a double principal coordinate analysis. \emph{Journal of Theoretical Biology}, \bold{228}, 523--537.
+
+}
+\author{Sandrine Pavoine \email{pavoine at mnhn.fr}
+}
+\seealso{
+\code{\link{dpcoa}}
+}
+\examples{
+# The functions used below require the package ape
+data(rhizobium)
+if (requireNamespace("ape", quietly = TRUE)) {
+dat <- prep.mdpcoa(rhizobium[[1]], rhizobium[[2]],
+ model = c("F84", "F84", "F84", "F81"), pairwise.deletion = TRUE)
+sam <- dat$sam
+dis <- dat$dis
+# The distances should be Euclidean.
+# Several transformations exist to render a distance object Euclidean
+# (see functions cailliez, lingoes and quasieuclid in the ade4 package).
+# Here we use the quasieuclid function.
+dis <- lapply(dis, quasieuclid)
+mdpcoa1 <- mdpcoa(sam, dis, scannf = FALSE, nf = 2)
+
+# Reference analysis
+plot(mdpcoa1)
+
+# Differences between the loci
+kplot(mdpcoa1)
+
+# Alleles projected on the population maps.
+kplotX.mdpcoa(mdpcoa1)
+}
+}
+\keyword{multivariate}
diff --git a/man/meau.Rd b/man/meau.Rd
new file mode 100644
index 0000000..9a6f2fd
--- /dev/null
+++ b/man/meau.Rd
@@ -0,0 +1,58 @@
+\name{meau}
+\alias{meau}
+\docType{data}
+\title{Ecological Data : sites-variables, sites-species, where and when}
+\description{
+This data set contains information about sites, environmental variables
+and Ephemeroptera Species.
+}
+\usage{data(meau)}
+\format{
+\code{meau} is a list of 3 components.
+\describe{
+ \item{env}{is a data frame with 24 sites and 10 physicochemical variables.}
+ \item{fau}{is a data frame with 24 sites and 13 Ephemeroptera Species.}
+ \item{design}{is a data frame with 24 sites and 2 factors.
+ \itemize{
+ \item \code{season}: is a factor with 4 levels = seasons.
+ \item \code{site}: is a factor with 6 levels = sites.
+ }
+ }
+ }
+}
+\details{Data set equivalents to \code{\link{meaudret}}, except that one site (6) along the Bourne (a Meaudret affluent) and
+one physico chemical variable - the oxygen concentration were added.
+}
+\source{
+Pegaz-Maucet, D. (1980)
+\emph{Impact d'une perturbation d'origine organique sur la dérive des macro-invertébrés benthiques d'un cours d'eau.
+Comparaison avec le benthos}.
+Thèse de 3ème cycle, Université Lyon 1, 130 p.
+
+Thioulouse, J., Simier, M. and Chessel, D. (2004) Simultaneous analysis of a sequence of paired ecological
+tables. \emph{Ecology}, \bold{85}, 1, 272--283.
+}
+\examples{
+data(meau)
+pca1 <- dudi.pca(meau$env, scan = FALSE, nf = 4)
+pca2 <- bca(pca1, meau$design$season, scan = FALSE, nf = 2)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.class(pca1$li, meau$design$season, psub.text = "Principal Component Analysis",
+ plot = FALSE)
+ g2 <- s.class(pca2$ls, meau$design$season,
+ psub.text = "Between seasons Principal Component Analysis", plot = FALSE)
+ g3 <- s.corcircle(pca1$co, plot = FALSE)
+ g4 <- s.corcircle(pca2$as, plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2, 2))
+ s.class(pca1$li, meau$design$season,
+ sub = "Principal Component Analysis")
+ s.class(pca2$ls, meau$design$season, sub = "Between seasons Principal Component Analysis")
+ s.corcircle(pca1$co)
+ s.corcircle(pca2$as)
+ par(mfrow = c(1, 1))
+}}
+\keyword{datasets}
diff --git a/man/meaudret.Rd b/man/meaudret.Rd
new file mode 100644
index 0000000..d772af0
--- /dev/null
+++ b/man/meaudret.Rd
@@ -0,0 +1,58 @@
+\name{meaudret}
+\alias{meaudret}
+\docType{data}
+\title{Ecological Data : sites-variables, sites-species, where and when}
+\description{
+This data set contains information about sites, environmental variables
+and Ephemeroptera Species.
+}
+\usage{data(meaudret)}
+\format{
+ \code{meaudret} is a list of 4 components.
+\describe{
+ \item{env}{is a data frame with 20 sites and 9 variables.}
+ \item{fau}{is a data frame with 20 sites and 13 Ephemeroptera Species.}
+ \item{design}{is a data frame with 20 sites and 2 factors.
+ \itemize{
+ \item \code{season} is a factor with 4 levels = seasons.
+ \item \code{site} is a factor with 5 levels = sites along the Meaudret river.
+ }
+ }
+ \item{spe.names}{is a character vector containing the names of the 13 species.}
+ }
+}
+\details{Data set equivalents to \code{\link{meau}}: site (6) on the Bourne (a Meaudret affluent) and
+oxygen concentration were removed.
+}
+\source{
+Pegaz-Maucet, D. (1980)
+\emph{Impact d'une perturbation d'origine organique sur la dérive des macro-invertébrés benthiques d'un cours d'eau.
+Comparaison avec le benthos.}
+Thèse de 3ème cycle, Université Lyon 1, 130 p.
+
+Thioulouse, J., Simier, M. and Chessel, D. (2004) Simultaneous analysis of a sequence of paired ecological
+tables. \emph{Ecology}, \bold{85}, 1, 272--283.
+}
+\examples{
+data(meaudret)
+pca1 <- dudi.pca(meaudret$env, scan = FALSE, nf = 4)
+pca2 <- bca(pca1, meaudret$design$season, scan = FALSE, nf = 2)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.class(pca1$li, meaudret$design$season,
+ psub.text = "Principal Component Analysis", plot = FALSE)
+ g2 <- s.class(pca2$ls, meaudret$design$season,
+ psub.text = "Between dates Principal Component Analysis", plot = FALSE)
+ g3 <- s.corcircle(pca1$co, plot = FALSE)
+ g4 <- s.corcircle(pca2$as, plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2, 2))
+ s.class(pca1$li, meaudret$design$season, sub = "Principal Component Analysis")
+ s.class(pca2$ls, meaudret$design$season, sub = "Between dates Principal Component Analysis")
+ s.corcircle(pca1$co)
+ s.corcircle(pca2$as)
+ par(mfrow = c(1, 1))
+}}
+\keyword{datasets}
diff --git a/man/mfa.Rd b/man/mfa.Rd
new file mode 100644
index 0000000..639bdd4
--- /dev/null
+++ b/man/mfa.Rd
@@ -0,0 +1,69 @@
+\name{mfa}
+\alias{mfa}
+\alias{print.mfa}
+\alias{plot.mfa}
+\alias{summary.mfa}
+\title{Multiple Factorial Analysis}
+\description{
+performs a multiple factorial analysis,
+using an object of class \code{ktab}.
+}
+\usage{
+mfa(X, option = c("lambda1", "inertia", "uniform", "internal"),
+ scannf = TRUE, nf = 3)
+\method{plot}{mfa}(x, xax = 1, yax = 2, option.plot = 1:4, \dots)
+\method{print}{mfa}(x, \dots)
+\method{summary}{mfa}(object, \dots)
+}
+\arguments{
+ \item{X}{K-tables, an object of class \code{ktab}}
+ \item{option}{a string of characters for the weighting of arrays
+ options :
+ \describe{
+ \item{\code{lambda1}}{weighting of group k by the inverse of the first eigenvalue of the k analysis}
+ \item{\code{inertia}}{weighting of group k by the inverse of the total inertia of the array k}
+ \item{\code{uniform}}{uniform weighting of groups}
+ \item{\code{internal}}{weighting included in \code{X$tabw}}
+ }
+ }
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+ \item{x, object}{an object of class 'mfa'}
+ \item{xax, yax}{the numbers of the x-axis and the y-axis}
+ \item{option.plot}{an integer between 1 and 4, otherwise the 4 components of the plot are displayed}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+ Returns a list including :
+ \item{tab}{a data frame with the modified array}
+ \item{rank}{a vector of ranks for the analyses}
+ \item{eig}{a numeric vector with the all eigenvalues}
+ \item{li}{a data frame with the coordinates of rows}
+ \item{TL}{a data frame with the factors associated to the rows (indicators of table)}
+ \item{co}{a data frame with the coordinates of columns}
+ \item{TC}{a data frame with the factors associated to the columns (indicators of table)}
+ \item{blo}{a vector indicating the number of variables for each table}
+ \item{lisup}{a data frame with the projections of normalized scores of rows for each table}
+ \item{link}{a data frame containing the projected inertia and the links between the arrays and the reference array}
+}
+\references{Escofier, B. and Pagès, J. (1994) Multiple factor analysis (AFMULT package), \emph{Computational Statistics and Data Analysis}, \bold{18}, 121--140.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(friday87)
+w1 <- data.frame(scale(friday87$fau, scal = FALSE))
+w2 <- ktab.data.frame(w1, friday87$fau.blo,
+ tabnames = friday87$tab.names)
+mfa1 <- mfa(w2, scann = FALSE)
+mfa1
+plot(mfa1)
+
+data(escopage)
+w <- data.frame(scale(escopage$tab))
+w <- ktab.data.frame(w, escopage$blo, tabnames = escopage$tab.names)
+plot(mfa(w, scann = FALSE))
+}
+\keyword{multivariate}
diff --git a/man/microsatt.Rd b/man/microsatt.Rd
new file mode 100644
index 0000000..9a2aef0
--- /dev/null
+++ b/man/microsatt.Rd
@@ -0,0 +1,49 @@
+\name{microsatt}
+\alias{microsatt}
+\docType{data}
+\title{Genetic Relationships between cattle breeds with microsatellites}
+\description{
+This data set gives genetic relationships between cattle breeds with microsatellites.
+}
+\usage{data(microsatt)}
+\format{
+ \code{microsatt} is a list of 4 components.
+ \describe{
+ \item{tab}{contains the allelic frequencies for 18 cattle breeds (Taurine or Zebu,French or African) and 9 microsatellites.}
+ \item{loci.names}{is a vector of the names of loci.}
+ \item{loci.eff}{is a vector of the number of alleles per locus.}
+ \item{alleles.names}{is a vector of the names of alleles.}
+ }
+}
+\source{
+Extract of data prepared by D. Laloë \email{ugendla at dga2.jouy.inra.fr} from data used in:
+
+Moazami-Goudarzi, K., D. Laloë, J. P. Furet, and F. Grosclaude (1997)
+Analysis of genetic relationships between 10 cattle breeds with 17 microsatellites.
+\emph{Animal Genetics}, \bold{28}, 338--345.
+
+Souvenir Zafindrajaona, P.,Zeuh V. ,Moazami-Goudarzi K., Laloë D., Bourzat D., Idriss A., and Grosclaude F. (1999)
+Etude du statut phylogénétique du bovin Kouri du lac Tchad à l'aide de marqueurs moléculaires.
+\emph{Revue d'Elevage et de Médecine Vétérinaire des pays Tropicaux}, \bold{55}, 155--162.
+
+Moazami-Goudarzi, K., Belemsaga D. M. A., Ceriotti G., Laloë D. , Fagbohoun F., Kouagou N. T., Sidibé I., Codjia V., Crimella M. C., Grosclaude F. and Touré S. M. (2001)\cr
+Caractérisation de la race bovine Somba à l'aide de marqueurs moléculaires.
+\emph{Revue d'Elevage et de Médecine Vétérinaire des pays Tropicaux}, \bold{54}, 1--10.
+}
+\references{
+See a data description at \url{http://pbil.univ-lyon1.fr/R/pdf/pps055.pdf} (in French).
+}
+\examples{
+\dontrun{
+data(microsatt)
+fac <- factor(rep(microsatt$loci.names, microsatt$loci.eff))
+w <- dudi.coa(data.frame(t(microsatt$tab)), scann = FALSE)
+wit <- wca(w, fac, scann = FALSE)
+microsatt.ktab <- ktab.within(wit)
+
+plot(sepan(microsatt.ktab)) # 9 separated correspondence analyses
+plot(mcoa(microsatt.ktab, scan = FALSE))
+plot(mfa(microsatt.ktab, scan = FALSE))
+plot(statis(microsatt.ktab, scan = FALSE))
+}}
+\keyword{datasets}
diff --git a/man/mjrochet.Rd b/man/mjrochet.Rd
new file mode 100644
index 0000000..8a65d53
--- /dev/null
+++ b/man/mjrochet.Rd
@@ -0,0 +1,47 @@
+\name{mjrochet}
+\alias{mjrochet}
+\docType{data}
+\title{Phylogeny and quantitative traits of teleos fishes}
+\description{
+This data set describes the phylogeny of 49 teleos fishes as reported by Rochet et al. (2000). It also gives life-history traits corresponding to these 49 species.
+}
+\usage{data(mjrochet)}
+\format{
+\code{mjrochet} is a list containing the 2 following objects :
+\describe{
+ \item{tre}{is a character string giving the phylogenetic tree in Newick format.}
+ \item{tab}{is a data frame with 49 rows and 7 traits.}
+}}
+\details{
+ Variables of \code{mjrochet$tab} are the following ones : tm (age at maturity (years)),
+ lm (length at maturity (cm)), l05 (length at 5 per cent survival (cm)),
+ t05 (time to 5 per cent survival (years)), fb (slope of the log-log fecundity-length relationship),
+ fm (fecundity the year of maturity), egg (volume of eggs (\eqn{mm^{3}}{mm^3})).
+}
+\source{
+Data taken from: \cr
+ Summary of data - Clupeiformes : http://www.ifremer.fr/maerha/clupe.html \cr
+ Summary of data - Argentiniformes : http://www.ifremer.fr/maerha/argentin.html \cr
+ Summary of data - Salmoniformes : http://www.ifremer.fr/maerha/salmon.html \cr
+ Summary of data - Gadiformes : http://www.ifremer.fr/maerha/gadi.html \cr
+ Summary of data - Lophiiformes : http://www.ifremer.fr/maerha/loph.html \cr
+ Summary of data - Atheriniformes : http://www.ifremer.fr/maerha/ather.html \cr
+ Summary of data - Perciformes : http://www.ifremer.fr/maerha/perci.html \cr
+ Summary of data - Pleuronectiformes : http://www.ifremer.fr/maerha/pleuro.html \cr
+ Summary of data - Scorpaeniformes : http://www.ifremer.fr/maerha/scorpa.html \cr
+ Phylogenetic tree : http://www.ifremer.fr/maerha/life_history.html
+}
+\references{
+Rochet, M. J., Cornillon, P-A., Sabatier, R. and Pontier, D. (2000)
+Comparative analysis of phylogenic and fishing effects in life history patterns of teleos fishes.
+\emph{Oïkos}, \bold{91}, 255--270.
+}
+\examples{
+data(mjrochet)
+mjrochet.phy <- newick2phylog(mjrochet$tre)
+tab <- log((mjrochet$tab))
+tab0 <- data.frame(scalewt(tab))
+table.phylog(tab0, mjrochet.phy, csi = 2, clabel.r = 0.75)
+orthogram(tab0[,1], ortho = mjrochet.phy$Bscores)
+}
+\keyword{datasets}
diff --git a/man/mld.Rd b/man/mld.Rd
new file mode 100644
index 0000000..95b4d79
--- /dev/null
+++ b/man/mld.Rd
@@ -0,0 +1,63 @@
+\name{mld}
+\alias{mld}
+\alias{haar2level}
+\title{Multi Level Decomposition of unidimensional data}
+\description{
+The function \code{mld} performs an additive decomposition of the input vector \code{x} onto sub-spaces associated
+to an orthonormal orthobasis. The sub-spaces are defined by levels of the input factor \code{level}.
+The function \code{haar2level} builds the factor \code{level} such that the multi level decomposition corresponds exactly to a multiresolution analysis performed with the haar basis.
+}
+\usage{
+mld(x, orthobas, level, na.action = c("fail", "mean"),
+ plot = TRUE, dfxy = NULL, phylog = NULL, ...)
+haar2level(x)
+}
+\arguments{
+ \item{x}{is a vector or a time serie containing the data to be decomposed. This must be a dyadic length vector (power of 2) for the function \code{haar2level}.}
+ \item{orthobas}{is a data frame containing the vectors of the orthonormal basis.}
+ \item{level}{is a factor which levels define the sub-spaces on which the function \code{mld} performs the additive decomposition.}
+ \item{na.action}{ if 'fail' stops the execution of the current expression when \code{x} contains any missing value. If 'mean' replaces any missing values by mean(\code{x}).}
+ \item{plot}{if TRUE plot \code{x} and the components resulting from the decomposition.}
+ \item{dfxy}{is a data frame with two coordinates.}
+ \item{phylog}{is an object of class \code{phylog}.}
+ \item{\dots}{further arguments passed to or from other methods.}
+}
+\value{
+A data frame with the components resulting from the decomposition.
+}
+\references{
+Mallat, S. G. (1989) A theory for multiresolution signal decomposition: the wavelet representation.
+\emph{IEEE Transactions on Pattern Analysis and Machine Intelligence}, \bold{11}, 7, 674--693.
+
+Percival, D. B. and Walden, A. T. (2000) \emph{Wavelet Methods for Time Series Analysis}, Cambridge University Press.
+}
+\author{Sébastien Ollier \email{sebastien.ollier at u-psud.fr}}
+\seealso{\code{\link{gridrowcol}}, \code{\link{orthobasis}}, \code{\link{orthogram}}, \code{\link[waveslim]{mra}} for multiresolution analysis with various families of wavelets}
+\examples{
+\dontrun{
+# decomposition of a time serie
+data(co2)
+x <- log(co2)
+orthobas <- orthobasis.line(length(x))
+level<-rep("D", 467)
+level[1:3]<-rep("A", 3)
+level[c(77,78,79,81)]<-rep("B", 4)
+level[156]<-"C"
+level<-as.factor(level)
+res <- mld(x, orthobas, level)
+sum(scale(x, scale = FALSE) - apply(res, 1, sum))
+}
+# decomposition of a biological trait on a phylogeny
+data(palm)
+vfruit<-palm$traits$vfruit
+vfruit<-scalewt(vfruit)
+palm.phy<-newick2phylog(palm$tre)
+level <- rep("F", 65)
+level[c(4, 21, 3, 6, 13)] <- LETTERS[1:5]
+level <- as.factor(level)
+res <- mld(as.vector(vfruit), palm.phy$Bscores, level,
+ phylog = palm.phy, clabel.nod = 0.7, f.phylog=0.8,
+ csize = 2, clabel.row = 0.7, clabel.col = 0.7)
+}
+\keyword{ts}
+\keyword{spatial}
diff --git a/man/mollusc.Rd b/man/mollusc.Rd
new file mode 100644
index 0000000..3daf331
--- /dev/null
+++ b/man/mollusc.Rd
@@ -0,0 +1,46 @@
+\name{mollusc}
+\alias{mollusc}
+\docType{data}
+\title{Faunistic Communities and Sampling Experiment}
+\description{
+This data set gives the abundance of 32 mollusk species in 163 samples.
+For each sample, 4 informations are known : the sampling sites, the seasons,
+the sampler types and the time of exposure.
+}
+\usage{data(mollusc)}
+\format{
+ \code{mollusc} is a list of 2 objects.
+ \describe{
+ \item{fau}{is a data frame with 163 samples and 32 mollusk species (abundance).}
+ \item{plan}{contains the 163 samples and 4 variables.}
+ }
+}
+\source{
+ Richardot-Coulet, M., Chessel D. and Bournaud M. (1986)
+ Typological value of the benthos of old beds of a large river. Methodological approach.
+ \emph{Archiv fùr Hydrobiologie}, \bold{107}, 363--383.
+}
+\examples{
+data(mollusc)
+coa1 <- dudi.coa(log(mollusc$fau + 1), scannf = FALSE, nf = 3)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.class(coa1$li, mollusc$plan$site, ellipseSize = 0, starSize = 0, chullSize = 1,
+ xax = 2, yax = 3, plot = FALSE)
+ g2 <- s.class(coa1$li, mollusc$plan$season, ellipseSize = 0, starSize = 0, chullSize = 1,
+ xax = 2, yax = 3, plot = FALSE)
+ g3 <- s.class(coa1$li, mollusc$plan$method, ellipseSize = 0, starSize = 0, chullSize = 1,
+ xax = 2, yax = 3, plot = FALSE)
+ g4 <- s.class(coa1$li, mollusc$plan$duration, ellipseSize = 0, starSize = 0, chullSize = 1,
+ xax = 2, yax = 3, plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2, 2))
+ s.chull(coa1$li, mollusc$plan$site, 2, 3, opt = 1, cpoi = 1)
+ s.chull(coa1$li, mollusc$plan$season, 2, 3, opt = 1, cpoi = 1)
+ s.chull(coa1$li, mollusc$plan$method, 2, 3, opt = 1, cpoi = 1)
+ s.chull(coa1$li, mollusc$plan$duration, 2, 3, opt = 1, cpoi = 1)
+ par(mfrow = c(1, 1))
+}}
+\keyword{datasets}
diff --git a/man/monde84.Rd b/man/monde84.Rd
new file mode 100644
index 0000000..14bf62d
--- /dev/null
+++ b/man/monde84.Rd
@@ -0,0 +1,34 @@
+\name{monde84}
+\alias{monde84}
+\docType{data}
+\title{Global State of the World in 1984}
+\usage{data(monde84)}
+\description{
+The \code{monde84} data frame gives five demographic variables
+for 48 countries in the world.
+}
+\format{
+ This data frame contains the following columns:
+ \enumerate{
+ \item pib: Gross Domestic Product
+ \item croipop: Growth of the population
+ \item morta: Infant Mortality
+ \item anal: Literacy Rate
+ \item scol: Percentage of children in full-time education
+ }
+}
+\source{
+Geze, F. and Coll., eds. (1984)
+\emph{L'état du Monde 1984 : annuaire économique et géopolitique mondial}. La Découverte, Paris.
+}
+\examples{
+data(monde84)
+X <- cbind.data.frame(lpib = log(monde84$pib), monde84$croipop)
+Y <- cbind.data.frame(lmorta = log(monde84$morta),
+ lanal = log(monde84$anal + 1), rscol = sqrt(100 - monde84$scol))
+pcaY <- dudi.pca(Y, scan = FALSE)
+pcaiv1 <- pcaiv(pcaY, X0 <- scale(X), scan = FALSE)
+sum(cor(pcaiv1$l1[,1], Y0 <- scale(Y))^2)
+pcaiv1$eig[1] #the same
+}
+\keyword{datasets}
diff --git a/man/morphosport.Rd b/man/morphosport.Rd
new file mode 100644
index 0000000..02c10e4
--- /dev/null
+++ b/man/morphosport.Rd
@@ -0,0 +1,34 @@
+\name{morphosport}
+\alias{morphosport}
+\docType{data}
+\title{Athletes' Morphology}
+\description{
+This data set gives a morphological description of 153 athletes split in five different sports.
+ }
+\usage{data(morphosport)}
+\format{
+\code{morphosport} is a list of 2 objects.
+ \describe{
+ \item{tab}{is a data frame with 153 athletes and 5 variables.}
+ \item{sport}{is a factor with 6 items}
+ }
+}
+\details{
+Variables of \code{morphosport$tab} are the following ones: dbi (biacromial diameter (cm)),
+tde (height (cm)), tas (distance from the buttocks to the top of the head (cm)),
+lms (length of the upper limbs (cm)), poids (weigth (kg)).\cr
+
+The levels of \code{morphosport$sport} are: athl (athletics), foot (football),
+hand (handball), judo, nata (swimming), voll (volleyball).
+}
+\source{
+Mimouni , N. (1996)
+\emph{Contribution de méthodes biométriques à l'analyse de la morphotypologie des sportifs}.
+Thèse de doctorat. Université Lyon 1.
+}
+\examples{
+data(morphosport)
+plot(discrimin(dudi.pca(morphosport$tab, scan = FALSE),
+ morphosport$sport, scan = FALSE))
+}
+\keyword{datasets}
diff --git a/man/mstree.Rd b/man/mstree.Rd
new file mode 100644
index 0000000..041bf2a
--- /dev/null
+++ b/man/mstree.Rd
@@ -0,0 +1,49 @@
+\name{mstree}
+\alias{mstree}
+\title{Minimal Spanning Tree}
+\description{
+ Minimal Spanning Tree
+}
+\usage{
+mstree(xdist, ngmax = 1)
+}
+\arguments{
+ \item{xdist}{ an object of class \code{dist} containing an observed dissimilarity }
+ \item{ngmax}{ a component number (default=1). Select 1 for getting classical MST. To add n supplementary edges k times: select k+1. }
+}
+\value{
+returns an object of class \code{neig}
+}
+\author{Daniel Chessel}
+\examples{
+data(mafragh)
+maf.coa <- dudi.coa(mafragh$flo, scan = FALSE)
+maf.mst <- ade4::mstree(dist.dudi(maf.coa), 1)
+
+if(adegraphicsLoaded()) {
+ g0 <- s.label(maf.coa$li, plab.cex = 0, ppoints.cex = 2, nb = neig2nb(maf.mst))
+} else {
+ s.label(maf.coa$li, clab = 0, cpoi = 2, neig = maf.mst, cnei = 1)
+}
+
+xy <- data.frame(x = runif(20), y = runif(20))
+
+if(adegraphicsLoaded()) {
+ g1 <- s.label(xy, xlim = c(0, 1), ylim = c(0, 1),
+ nb = neig2nb(ade4::mstree(dist.quant(xy, 1), 1)), plot = FALSE)
+ g2 <- s.label(xy, xlim = c(0, 1), ylim = c(0, 1),
+ nb = neig2nb(ade4::mstree(dist.quant(xy, 1), 2)), plot = FALSE)
+ g3 <- s.label(xy, xlim = c(0, 1), ylim = c(0, 1),
+ nb = neig2nb(ade4::mstree(dist.quant(xy, 1), 3)), plot = FALSE)
+ g4 <- s.label(xy, xlim = c(0, 1), ylim = c(0, 1),
+ nb = neig2nb(ade4::mstree(dist.quant(xy, 1), 4)), plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2, 2))
+ for(k in 1:4) {
+ neig <- mstree(dist.quant(xy, 1), k)
+ s.label(xy, xlim = c(0, 1), ylim = c(0, 1), addax = FALSE, neig = neig)
+ }
+}}
+\keyword{utilities}
diff --git a/man/multiblock.Rd b/man/multiblock.Rd
new file mode 100644
index 0000000..1d92a43
--- /dev/null
+++ b/man/multiblock.Rd
@@ -0,0 +1,27 @@
+\name{multiblock}
+\alias{summary.multiblock}
+\alias{print.multiblock}
+
+\title{Display and summarize multiblock objects}
+\description{Generic methods print and summary for mulitblock objects}
+\usage{
+\method{summary}{multiblock}(object, ...)
+\method{print}{multiblock}(x, ...)
+}
+
+\arguments{
+ \item{object}{an object of class multiblock created by \code{\link{mbpls}}
+ or \code{\link{mbpcaiv}}}
+\item{x}{an object of class multiblock created by \code{\link{mbpls}}
+ or \code{\link{mbpcaiv}}}
+ \item{\dots}{other arguments to be passed to methods}
+}
+
+\author{Stéphanie Bougeard (\email{stephanie.bougeard at anses.fr}) and Stéphane Dray (\email{stephane.dray at univ-lyon1.fr})}
+
+\seealso{
+\code{\link{mbpls}}, \code{\link{mbpcaiv}}
+}
+
+\keyword{multivariate}
+
diff --git a/man/multispati.Rd b/man/multispati.Rd
new file mode 100644
index 0000000..f491630
--- /dev/null
+++ b/man/multispati.Rd
@@ -0,0 +1,181 @@
+\name{multispati}
+\alias{multispati}
+\alias{plot.multispati}
+\alias{summary.multispati}
+\alias{print.multispati}
+\title{Multivariate spatial analysis}
+\description{
+This function ensures a multivariate extension of the univariate method of spatial autocorrelation analysis.
+By accounting for the spatial dependence of data observations and their multivariate covariance simultaneously,
+complex interactions among many variables are analysed. Using a methodological scheme borrowed from duality diagram
+analysis, a strategy for the exploratory analysis of spatial pattern in the multivariate is developped.
+}
+\usage{
+multispati(dudi, listw, scannf = TRUE, nfposi = 2, nfnega = 0)
+\method{plot}{multispati}(x, xax = 1, yax = 2, ...)
+\method{summary}{multispati}(object, ...)
+\method{print}{multispati}(x, ...)
+}
+\arguments{
+ \item{dudi}{an object of class \code{dudi} for the duality diagram analysis}
+ \item{listw}{an object of class \code{listw} for the spatial dependence of data observations}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nfposi}{an integer indicating the number of kept positive axes}
+ \item{nfnega}{an integer indicating the number of kept negative axes}
+ \item{x, object}{an object of class \code{multispati}}
+ \item{xax, yax}{the numbers of the x-axis and the y-axis}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\details{
+This analysis generalizes the Wartenberg's multivariate spatial
+correlation analysis to various duality diagrams created by the
+functions (\code{dudi.pca}, \code{dudi.coa}, \code{dudi.acm}, \code{dudi.mix}...)
+If \emph{dudi} is a duality diagram created by the function \code{dudi.pca}
+and \emph{listw} gives spatial weights created by a row normalized coding scheme,
+the analysis is equivalent to Wartenberg's analysis.
+
+We note X the data frame with the variables, Q the column weights matrix
+and D the row weights matrix associated to the duality diagram \emph{dudi}.
+We note L the neighbouring weights matrix associated to \emph{listw}.
+Then, the \code{'multispati'} analysis gives principal axes v that maximize
+the product of spatial autocorrelation and inertia of row scores :
+\deqn{I(XQv)*\|XQv\|^2 = v^{t}Q^{t}X^{t}DLXQv}{I(XQv)*\|\|XQv\|\|^2 = t(v)t(Q)t(X)DLXQv}
+}
+\value{
+Returns an object of class \code{multispati}, which contains the following elements :
+ \item{eig}{a numeric vector containing the eigenvalues}
+ \item{nfposi}{integer, number of kept axes associated to positive eigenvalues}
+ \item{nfnega}{integer, number of kept axes associated to negative eigenvalues}
+ \item{c1}{principle axes (v), data frame with p rows and (nfposi + nfnega) columns}
+ \item{li}{principal components (XQv), data frame with n rows and (nfposi + nfnega) columns}
+ \item{ls}{lag vector onto the principal axes (LXQv), data frame with n rows and (nfposi + nfnega) columns}
+ \item{as}{principal axes of the dudi analysis (u) onto principal axes of multispati (t(u)Qv), data frame with dudi\$nf rows and (nfposi + nfnega) columns}
+}
+\references{
+Dray, S., Said, S. and Debias, F. (2008) Spatial ordination of
+vegetation data using a generalization of Wartenberg's multivariate
+spatial correlation. \emph{Journal of vegetation science}, \bold{19},
+45--56.
+
+ Grunsky, E. C. and Agterberg, F. P. (1988) Spatial and multivariate analysis of geochemical data from metavolcanic rocks in the Ben Nevis area, Ontario. \emph{Mathematical Geology}, \bold{20}, 825--861.
+
+Switzer, P. and Green, A.A. (1984) Min/max autocorrelation factors for multivariate spatial imagery. Tech. rep. 6, Stanford University.
+
+Thioulouse, J., Chessel, D. and Champely, S. (1995) Multivariate analysis of spatial patterns: a unified approach to local and global structures. \emph{Environmental and Ecological Statistics}, \bold{2}, 1--14.
+
+Wartenberg, D. E. (1985) Multivariate spatial correlation: a method for
+exploratory geographical analysis. \emph{Geographical Analysis},
+\bold{17}, 263--283.
+
+Jombart, T., Devillard, S., Dufour, A.-B. and Pontier, D. A
+spatially explicit multivariate method to disentangle global and local
+patterns of genetic variability. Submitted to \emph{Genetics}.
+}
+\author{Daniel Chessel \cr
+Sebastien Ollier \email{sebastien.ollier at u-psud.fr} \cr
+Thibaut Jombart \email{t.jombart at imperial.ac.uk}
+
+}
+\seealso{\code{\link{dudi}},\code{\link[spdep]{mat2listw}}}
+\examples{
+\dontrun{
+if (requireNamespace("maptools", quietly = TRUE) & requireNamespace("spdep", quietly = TRUE)) {
+ data(mafragh)
+ maf.xy <- mafragh$xy
+ maf.flo <- mafragh$flo
+ maf.listw <- spdep::nb2listw(neig2nb(mafragh$neig))
+ if(adegraphicsLoaded()) {
+ g1 <- s.label(maf.xy, nb = neig2nb(mafragh$neig), plab.cex = 0.75)
+ } else {
+ s.label(maf.xy, neig = mafragh$neig, clab = 0.75)
+ }
+ maf.coa <- dudi.coa(maf.flo,scannf = FALSE)
+ maf.coa.ms <- multispati(maf.coa, maf.listw, scannf = FALSE, nfposi = 2, nfnega = 2)
+ maf.coa.ms
+
+ ### detail eigenvalues components
+ fgraph <- function(obj){
+ # use multispati summary
+ sum.obj <- summary(obj)
+ # compute Imin and Imax
+ L <- spdep::listw2mat(eval(as.list(obj$call)$listw))
+ Imin <- min(eigen(0.5*(L+t(L)))$values)
+ Imax <- max(eigen(0.5*(L+t(L)))$values)
+ I0 <- -1/(nrow(obj$li)-1)
+ # create labels
+ labels <- lapply(1:length(obj$eig),function(i) bquote(lambda[.(i)]))
+ # draw the plot
+ xmax <- eval(as.list(obj$call)$dudi)$eig[1]*1.1
+ par(las=1)
+ var <- sum.obj[,2]
+ moran <- sum.obj[,3]
+ plot(x=var,y=moran,type='n',xlab='Inertia',ylab="Spatial autocorrelation (I)",
+ xlim=c(0,xmax),ylim=c(Imin*1.1,Imax*1.1),yaxt='n')
+ text(x=var,y=moran,do.call(expression,labels))
+ ytick <- c(I0,round(seq(Imin,Imax,le=5),1))
+ ytlab <- as.character(round(seq(Imin,Imax,le=5),1))
+ ytlab <- c(as.character(round(I0,1)),as.character(round(Imin,1)),
+ ytlab[2:4],as.character(round(Imax,1)))
+ axis(side=2,at=ytick,labels=ytlab)
+ rect(0,Imin,xmax,Imax,lty=2)
+ segments(0,I0,xmax,I0,lty=2)
+ abline(v=0)
+ title("Spatial and inertia components of the eigenvalues")
+ }
+ fgraph(maf.coa.ms)
+ ## end eigenvalues details
+
+
+ if(adegraphicsLoaded()) {
+ g2 <- s1d.barchart(maf.coa$eig, p1d.hori = FALSE, plot = FALSE)
+ g3 <- s1d.barchart(maf.coa.ms$eig, p1d.hori = FALSE, plot = FALSE)
+ g4 <- s.corcircle(maf.coa.ms$as, plot = FALSE)
+ G1 <- ADEgS(list(g2, g3, g4), layout = c(1, 3))
+ } else {
+ par(mfrow = c(1, 3))
+ barplot(maf.coa$eig)
+ barplot(maf.coa.ms$eig)
+ s.corcircle(maf.coa.ms$as)
+ par(mfrow = c(1, 1))
+ }
+
+
+ if(adegraphicsLoaded()) {
+ g5 <- s.value(maf.xy, -maf.coa$li[, 1], plot = FALSE)
+ g6 <- s.value(maf.xy, -maf.coa$li[, 2], plot = FALSE)
+ g7 <- s.value(maf.xy, maf.coa.ms$li[, 1], plot = FALSE)
+ g8 <- s.value(maf.xy, maf.coa.ms$li[, 2], plot = FALSE)
+ G2 <- ADEgS(list(g5, g6, g7, g8), layout = c(2, 2))
+ } else {
+ par(mfrow = c(2, 2))
+ s.value(maf.xy, -maf.coa$li[, 1])
+ s.value(maf.xy, -maf.coa$li[, 2])
+ s.value(maf.xy, maf.coa.ms$li[, 1])
+ s.value(maf.xy, maf.coa.ms$li[, 2])
+ par(mfrow = c(1, 1))
+ }
+
+
+ w1 <- -maf.coa$li[, 1:2]
+ w1m <- apply(w1, 2, spdep::lag.listw, x = maf.listw)
+ w1.ms <- maf.coa.ms$li[, 1:2]
+ w1.msm <- apply(w1.ms, 2, spdep::lag.listw, x = maf.listw)
+ if(adegraphicsLoaded()) {
+ g9 <- s.match(w1, w1m, plab.cex = 0.75, plot = FALSE)
+ g10 <- s.match(w1.ms, w1.msm, plab.cex = 0.75, plot = FALSE)
+ G3 <- cbindADEg(g9, g10, plot = TRUE)
+ } else {
+ par(mfrow = c(1,2))
+ s.match(w1, w1m, clab = 0.75)
+ s.match(w1.ms, w1.msm, clab = 0.75)
+ par(mfrow = c(1, 1))
+ }
+
+ maf.pca <- dudi.pca(mafragh$env, scannf = FALSE)
+ multispati.randtest(maf.pca, maf.listw)
+ maf.pca.ms <- multispati(maf.pca, maf.listw, scannf=FALSE)
+ plot(maf.pca.ms)
+}
+}}
+\keyword{multivariate}
+\keyword{spatial}
diff --git a/man/multispati.randtest.Rd b/man/multispati.randtest.Rd
new file mode 100644
index 0000000..4575c1d
--- /dev/null
+++ b/man/multispati.randtest.Rd
@@ -0,0 +1,46 @@
+\name{multispati.randtest}
+\alias{multispati.randtest}
+\title{Multivariate spatial autocorrelation test (in C)}
+\description{
+This function performs a multivariate autocorrelation test.
+}
+\usage{
+multispati.randtest(dudi, listw, nrepet = 999, ...)
+}
+\arguments{
+ \item{dudi}{an object of class \code{dudi} for the duality diagram analysis}
+ \item{listw}{an object of class \code{listw} for the spatial dependence of data observations}
+ \item{nrepet}{the number of permutations}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\details{
+We note X the data frame with the variables, Q the column weights matrix
+and D the row weights matrix associated to the duality diagram \emph{dudi}.
+We note L the neighbouring weights matrix associated to \emph{listw}.
+This function performs a Monte-Carlo Test on the multivariate spatial
+autocorrelation index : \deqn{r = \frac{trace(X^{t}DLXQ)}{trace(X^{t}DXQ)}}{r = trace(t(X)DLXQ) / trace(t(X)DXQ)}
+}
+\value{
+Returns an object of class \code{randtest} (randomization tests).
+}
+\references{
+Smouse, P. E. and Peakall, R. (1999) Spatial autocorrelation analysis of individual multiallele and multilocus genetic structure.
+\emph{Heredity}, \bold{82}, 561--573.
+}
+\author{Daniel Chessel \cr
+Sébastien Ollier \email{sebastien.ollier at u-psud.fr}
+}
+\seealso{\code{\link{dudi}},\code{\link[spdep]{mat2listw}}}
+\examples{
+if (requireNamespace("maptools", quietly = TRUE) & requireNamespace("spdep", quietly = TRUE)) {
+ data(mafragh)
+ maf.listw <- spdep::nb2listw(neig2nb(mafragh$neig))
+ maf.pca <- dudi.pca(mafragh$env, scannf = FALSE)
+ multispati.randtest(maf.pca, maf.listw)
+ maf.pca.ms <- multispati(maf.pca, maf.listw, scannf = FALSE)
+ plot(maf.pca.ms)
+}
+}
+\keyword{multivariate}
+\keyword{spatial}
+\keyword{nonparametric}
diff --git a/man/multispati.rtest.Rd b/man/multispati.rtest.Rd
new file mode 100644
index 0000000..05b1651
--- /dev/null
+++ b/man/multispati.rtest.Rd
@@ -0,0 +1,46 @@
+\name{multispati.rtest}
+\alias{multispati.rtest}
+\title{Multivariate spatial autocorrelation test}
+\description{
+This function performs a multivariate autocorrelation test.
+}
+\usage{
+multispati.rtest(dudi, listw, nrepet = 99, ...)
+}
+\arguments{
+ \item{dudi}{an object of class \code{dudi} for the duality diagram analysis}
+ \item{listw}{an object of class \code{listw} for the spatial dependence of data observations}
+ \item{nrepet}{the number of permutations}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\details{
+We note X the data frame with the variables, Q the column weight matrix
+and D the row weight matrix associated to the duality diagram \emph{dudi}.
+We note L the neighbouring weights matrix associated to \emph{listw}.
+This function performs a Monte-Carlo Test on the multivariate spatial
+autocorrelation index : \deqn{r = \frac{X^{t}DLXQ}{X^{t}DXQ}}{r = t(X)DLXQ / t(X)DXQ}
+}
+\value{
+Returns an object of class \code{randtest} (randomization tests).
+}
+\references{
+Smouse, P. E. and Peakall, R. (1999) Spatial autocorrelation analysis of individual multiallele and multilocus genetic structure.
+\emph{Heredity}, \bold{82}, 561--573.
+}
+\author{Daniel Chessel \cr
+Sébastien Ollier \email{sebastien.ollier at u-psud.fr}
+}
+\seealso{\code{\link{dudi}},\code{\link[spdep]{mat2listw}}}
+\examples{
+if (requireNamespace("maptools", quietly = TRUE) & requireNamespace("spdep", quietly = TRUE)) {
+ data(mafragh)
+ maf.listw <- spdep::nb2listw(neig2nb(mafragh$neig))
+ maf.pca <- dudi.pca(mafragh$env, scannf = FALSE)
+ multispati.rtest(maf.pca, maf.listw)
+ maf.pca.ms <- multispati(maf.pca, maf.listw, scannf = FALSE)
+ plot(maf.pca.ms)
+}
+}
+\keyword{multivariate}
+\keyword{spatial}
+\keyword{nonparametric}
diff --git a/man/neig.Rd b/man/neig.Rd
new file mode 100644
index 0000000..4126ee5
--- /dev/null
+++ b/man/neig.Rd
@@ -0,0 +1,147 @@
+\name{neig}
+\alias{neig}
+\alias{neig.util.GtoL}
+\alias{neig.util.LtoG}
+\alias{print.neig}
+\alias{summary.neig}
+\alias{scores.neig}
+\alias{nb2neig}
+\alias{neig2nb}
+\alias{neig2mat}
+\title{Neighbourhood Graphs}
+\description{
+\code{neig} creates objects of class \code{neig} with : \cr
+ a list of edges\cr
+ a binary square matrix\cr
+ a list of vectors of neighbours\cr
+ an integer (linear and circular graphs)\cr
+ a data frame of polygons (area)\cr
+
+scores.neig returns the eigenvectors of neighbouring,\cr
+orthonormalized scores (null average, unit variance 1/n and null covariances) of maximal autocorrelation.\cr
+
+nb2neig returns an object of class \code{neig} using an object of class \code{nb} in the library 'spdep'
+
+neig2nb returns an object of class \code{nb} using an object of class \code{neig}
+
+neig2mat returns the incidence matrix between edges (1 = neighbour ; 0 = no neighbour)
+
+neig.util.GtoL and neig.util.LtoG are utilities.
+}
+\usage{
+neig(list = NULL, mat01 = NULL, edges = NULL,
+ n.line = NULL, n.circle = NULL, area = NULL)
+
+scores.neig (obj)
+\method{print}{neig}(x, \dots)
+\method{summary}{neig}(object, \dots)
+nb2neig (nb)
+neig2nb (neig)
+neig2mat (neig)
+}
+\arguments{
+\item{list}{a list which each component gives the number of neighbours}
+\item{mat01}{a symmetric square matrix of 0-1 values}
+\item{edges}{a matrix of 2 columns with integer values giving a list of edges}
+\item{n.line}{the number of points for a linear plot}
+\item{n.circle}{the number of points for a circular plot}
+\item{area}{a data frame containing a polygon set (see \link{area.plot})}
+\item{nb}{an object of class 'nb'}
+\item{neig, x, obj, object}{an object of class 'neig'}
+\item{\dots}{further arguments passed to or from other methods}
+}
+\references{
+Thioulouse, J., D. Chessel, and S. Champely. 1995.
+Multivariate analysis of spatial patterns: a unified approach to local and global structures.
+\emph{Environmental and Ecological Statistics}, \bold{2}, 1--14.
+}
+\author{Daniel Chessel }
+\examples{
+if(!adegraphicsLoaded()) {
+
+ if(requireNamespace("deldir", quietly = TRUE)) {
+
+ data(mafragh)
+ par(mfrow = c(2, 1))
+ provi <- deldir::deldir(mafragh$xy)
+ provi.neig <- neig(edges = as.matrix(provi$delsgs[, 5:6]))
+
+ s.label(mafragh$xy, neig = provi.neig, inc = FALSE,
+ addax = FALSE, clab = 0, cnei = 2)
+ dist <- apply(provi.neig, 1, function(x)
+ sqrt(sum((mafragh$xy[x[1], ] - mafragh$xy[x[2], ]) ^ 2)))
+ #hist(dist, nclass = 50)
+ mafragh.neig <- neig(edges = provi.neig[dist < 50, ])
+ s.label(mafragh$xy, neig = mafragh.neig, inc = FALSE,
+ addax = FALSE, clab = 0, cnei = 2)
+ par(mfrow = c(1, 1))
+
+ data(irishdata)
+ irish.neig <- neig(area = irishdata$area)
+ summary(irish.neig)
+ print(irish.neig)
+ s.label(irishdata$xy, neig = irish.neig, cneig = 3,
+ area = irishdata$area, clab = 0.8, inc = FALSE)
+
+ irish.scores <- scores.neig(irish.neig)
+ par(mfrow = c(2, 3))
+ for(i in 1:6)
+ s.value(irishdata$xy, irish.scores[, i], inc = FALSE, grid = FALSE, addax = FALSE,
+ neig = irish.neig, csi = 2, cleg = 0, sub = paste("Eigenvector ",i), csub = 2)
+ par(mfrow = c(1, 1))
+
+ a.neig <- neig(n.circle = 16)
+ a.scores <- scores.neig(a.neig)
+ xy <- cbind.data.frame(cos((1:16) * pi / 8), sin((1:16) * pi / 8))
+ par(mfrow = c(4, 4))
+ for(i in 1:15)
+ s.value(xy, a.scores[, i], neig = a.neig, csi = 3, cleg = 0)
+ par(mfrow = c(1, 1))
+
+ a.neig <- neig(n.line = 28)
+ a.scores <- scores.neig(a.neig)
+ par(mfrow = c(7, 4))
+ par(mar = c(1.1, 2.1, 0.1, 0.1))
+ for(i in 1:27)
+ barplot(a.scores[, i], col = grey(0.8))
+ par(mfrow = c(1, 1))
+ }
+
+ if(requireNamespace("maptools", quietly = TRUE) & requireNamespace("spdep", quietly = TRUE)) {
+ data(columbus, package = "spdep")
+ par(mfrow = c(2, 1))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ plot(col.gal.nb, coords)
+ s.label(data.frame(coords), neig = neig(list = col.gal.nb),
+ inc = FALSE, clab = 0.6, cneig = 1)
+ par(mfrow = c(1, 1))
+
+ data(mafragh)
+ maf.rel <- spdep::relativeneigh(as.matrix(mafragh$xy))
+ maf.rel <- spdep::graph2nb(maf.rel)
+ s.label(mafragh$xy, neig = neig(list = maf.rel), inc = FALSE,
+ clab = 0, addax = FALSE, cne = 1, cpo = 2)
+
+ par(mfrow = c(2, 2))
+ w <- matrix(runif(100), 50, 2)
+ x.gab <- spdep::gabrielneigh(w)
+ x.gab <- spdep::graph2nb(x.gab)
+ s.label(data.frame(w), neig = neig(list = x.gab), inc = FALSE,
+ clab = 0, addax = FALSE, cne = 1, cpo = 2, sub = "relative")
+ x.rel <- spdep::relativeneigh(w)
+ x.rel <- spdep::graph2nb(x.rel)
+ s.label(data.frame(w), neig = neig(list = x.rel), inc = FALSE,
+ clab = 0, addax = FALSE, cne = 1, cpo = 2, sub = "Gabriel")
+ k1 <- spdep::knn2nb(spdep::knearneigh(w))
+ s.label(data.frame(w), neig = neig(list = k1), inc = FALSE,
+ clab = 0, addax = FALSE, cne = 1, cpo = 2, sub = "k nearest neighbours")
+
+ all.linked <- max(unlist(spdep::nbdists(k1, w)))
+ z <- spdep::dnearneigh(w, 0, all.linked)
+ s.label(data.frame(w), neig = neig(list = z), inc = FALSE, clab = 0,
+ addax = FALSE, cne = 1, cpo = 2, sub = "Neighbourhood contiguity by distance")
+ par(mfrow = c(1, 1))
+ }
+
+}}
+\keyword{utilities}
diff --git a/man/newick.eg.Rd b/man/newick.eg.Rd
new file mode 100644
index 0000000..fee5ff2
--- /dev/null
+++ b/man/newick.eg.Rd
@@ -0,0 +1,42 @@
+\name{newick.eg}
+\alias{newick.eg}
+\docType{data}
+\title{Phylogenetic trees in Newick format}
+\description{
+This data set contains various exemples of phylogenetic trees in Newick format.
+}
+\usage{data(newick.eg)}
+\format{
+\code{newick.eg} is a list containing 14 character strings in Newick format.
+}
+\source{
+Trees 1 to 7 were obtained from the URL \cr
+\url{http://evolution.genetics.washington.edu/phylip/newicktree.html}.
+
+Trees 8 and 9 were obtained by Clémentine Carpentier-Gimaret.
+
+Tree 10 was obtained from Treezilla Data Sets .
+
+Trees 11 and 12 are taken from Bauwens and Díaz-Uriarte (1997).
+
+Tree 13 is taken from Cheverud and Dow (1985).
+
+Tree 13 is taken from Martins and Hansen (1997).
+}
+\references{
+Bauwens, D. and Díaz-Uriarte, R. (1997) Covariation of life-history traits in lacertid lizards: a comparative study.
+\emph{American Naturalist}, \bold{149}, 91--111.
+
+Cheverud, J. and Dow, M.M. (1985) An autocorrelation analysis of genetic variation due to lineal fission in social groups of rhesus macaques.
+\emph{American Journal of Physical Anthropology}, \bold{67}, 113--122.
+
+Martins, E. P. and Hansen, T.F. (1997) Phylogenies and the comparative method: a general approach to incorporating phylogenetic information
+into the analysis of interspecific data. \emph{American Naturalist}, \bold{149}, 646--667.
+}
+\examples{
+data(newick.eg)
+newick2phylog(newick.eg[[11]])
+radial.phylog(newick2phylog(newick.eg[[7]]), circ = 1,
+ clabel.l = 0.75)
+}
+\keyword{datasets}
diff --git a/man/newick2phylog.Rd b/man/newick2phylog.Rd
new file mode 100644
index 0000000..8115a7f
--- /dev/null
+++ b/man/newick2phylog.Rd
@@ -0,0 +1,113 @@
+\name{newick2phylog}
+\alias{newick2phylog}
+\alias{hclust2phylog}
+\alias{taxo2phylog}
+\alias{newick2phylog.addtools}
+\title{Create phylogeny}
+\description{
+The first three functions ensure to create object of class \code{phylog} from either a character string in Newick format (\code{newick2phylog}) or an object of class \code{'hclust'} (\code{hclust2phylog}) or a taxonomy (\code{taxo2phylog}).
+The function \code{newick2phylog.addtools} is an internal function called by \code{newick2phylog}, \code{hclust2phylog} and \code{taxo2phylog} when \code{newick2phylog.addtools} = TRUE. It adds some items in \code{'phylog'} objects.
+}
+\usage{
+newick2phylog(x.tre, add.tools = TRUE, call = match.call())
+hclust2phylog(hc, add.tools = TRUE)
+taxo2phylog(taxo, add.tools = FALSE, root="Root", abbrev=TRUE)
+newick2phylog.addtools(res, tol = 1e-07)
+}
+\arguments{
+ \item{x.tre}{a character string corresponding to a phylogenetic tree in Newick format\cr
+ (\url{http://evolution.genetics.washington.edu/phylip/newicktree.html})}
+ \item{add.tools}{if TRUE, executes the function \code{newick2phylog.addtools}}
+ \item{call}{call}
+ \item{hc}{an object of class \code{hclust}}
+ \item{taxo}{an object of class \code{taxo}}
+ \item{res}{an object of class \code{phylog} (an internal argument of the function \code{newick2phylog})}
+ \item{tol}{used in case 3 of \code{method} as a tolerance threshold for null eigenvalues}
+ \item{root}{a character string for the root of the tree}
+ \item{abbrev}{logical : if TRUE levels are abbreviated by column and two characters are added before}
+}
+\value{
+Return object of class \code{phylog}.
+}
+\author{Daniel Chessel \cr
+Sébastien Ollier \email{sebastien.ollier at u-psud.fr}
+}
+\seealso{\code{\link{phylog}}, \code{\link{plot.phylog}}, \code{\link{as.taxo}}}
+\examples{
+
+ w <- "((((,,),,(,)),),(,));"
+ w.phy <- newick2phylog(w)
+ print(w.phy)
+ plot(w.phy)
+
+\dontrun{
+# newick2phylog
+data(newick.eg)
+radial.phylog(newick2phylog(newick.eg[[8]], FALSE), cnode = 1,
+ clabel.l = 0.8)
+
+w <- NULL
+w[1] <- "(,((((((((((((((((,,(,(,))),),(((,(,)),(,)),),(,(,)),(,)),((((("
+w[2] <- ",(,)),),),(,)),((((,((,),((,(,)),))),(,)),(,(,),,((,),(,)),)),("
+w[3] <- "(((((,),),(,(,))),),(,)),(((,),),)))),((,,((,),)),(,)),((,),(,)"
+w[4] <- ")),(((((((((,,),),,),),((,),)),(,),((,),)),),(((((,),),),((,),)"
+w[5] <- "),(((,(,(,(,)))),(,)),(((,),(((((((,),),),,),(,)),(,)),)),((,)"
+w[6] <- ",))))),(,((,),(,)),((,(,)),)))),((((,(,(,))),((,(,)),,((,(,)),)"
+w[7] <- ",)),(((,),),(((,),),))),((,),))),((((((((((,,,,(,)),),((,),)),("
+w[8] <- ",(,))),(((((((((,(,)),(,)),((((,((,),(,(,(,))))),((,),(,(,)))),"
+w[9] <- "),((,),))),(((((((((,(,)),((,),(,))),),),),(((,((,),)),),((,((,"
+w[10] <- "),)),)),(,)),(,(,(,)))),((((,(,)),(,)),(((,),(,)),(,),,(,))),(,"
+w[11] <- "))),(,,,))),((((,),),),(((,(,(,))),((,),)),(,)))),(,)),),(,((,("
+w[12] <- ",)),),(((,),),))),),(((,),),(,),(,(,))),(((,),(,)),((,),(,)))),"
+w[13] <- "(((,),((,),)),(((((,,,,,),(,)),(,)),(,((,),))),))),(,(((((,(((("
+w[14] <- ",(,)),),),)),),((,((,),((,((,),(,))),))),)),((((,),(((,),(,(,))"
+w[15] <- "),)),),)),((,),)))),(((,((,,((,),)),)),),((,),))),((,),(,))),(("
+w[16] <- ",),)),(((((,),((,(,)),(((,(,)),(,(((,),),))),))),(,),,),),),,(,"
+w[17] <- ")),((((,),,),),((,,,),((,),((,),))))),((((((,(,)),,(,)),,(,),(,"
+w[18] <- "),),(((((,(,(,),)),(((,),,),(,))),),),),,,((,),)),),)),(((((,),"
+w[19] <- "(,(,)),),((,((,),),,),)),(((((((,),((((,,,),(,(,))),(((,(,)),),"
+w[20] <- "(,))),)),),),),(,)),),),((,),))),((,),)),(((((((((((,),),(((((("
+w[21] <- ",),),((,),)),(,)),),)),(,)),),((((((,),),(((,),),)),(,)),),(,))"
+w[22] <- ",),),),),(,)),),((,),(,),,,)),(,(,(,)))),),(,)),),);"
+phy1 <- newick2phylog(w,FALSE)
+phy1
+radial.phylog(phy1, clabel.l = 0, circle = 2.2, clea = 0.5,
+ cnod = 0.5)
+data(newick.eg)
+radial.phylog(newick2phylog(newick.eg[[8]], FALSE), cnode = 1,
+ clabel.l = 0.8)
+
+# hclust2phylog
+data(USArrests)
+hc <- hclust(dist(USArrests), "ave")
+par(mfrow = c(1,2))
+plot(hc, hang = -1)
+phy <- hclust2phylog(hc)
+plot(phy, clabel.l = 0.75, clabel.n = 0.6, f = 0.75)
+
+par(mfrow = c(1,1))
+row.names(USArrests)
+names(phy$leaves) #WARNING not the same for two reasons
+row.names(USArrests) <- gsub(" ","_",row.names(USArrests))
+row.names(USArrests)
+names(phy$leaves) #WARNING not the same for one reason
+USArrests <- USArrests[names(phy$leaves),]
+row.names(USArrests)
+names(phy$leaves) #the same
+table.phylog(data.frame(scalewt(USArrests)), phy, csi = 2.5,
+ clabel.r = 0.75, f = 0.7)
+
+#taxo2phylog
+data(taxo.eg)
+tax <- as.taxo(taxo.eg[[1]])
+tax.phy <- taxo2phylog(as.taxo(taxo.eg[[1]]))
+par(mfrow = c(1,2))
+plot(tax.phy, clabel.l = 1.25, clabel.n = 1.25, f = 0.75)
+plot(taxo2phylog(as.taxo(taxo.eg[[1]][sample(15),])),
+ clabel.l = 1.25, clabel.n = 1.25, f = 0.75)
+
+par(mfrow=c(1,1))
+plot(taxo2phylog(as.taxo(taxo.eg[[2]])), clabel.l = 1,
+ clabel.n = 0.75, f = 0.65)
+}}
+\keyword{manip}
diff --git a/man/niche.Rd b/man/niche.Rd
new file mode 100644
index 0000000..cbd9b17
--- /dev/null
+++ b/man/niche.Rd
@@ -0,0 +1,98 @@
+\name{niche}
+\alias{niche}
+\alias{plot.niche}
+\alias{print.niche}
+\alias{niche.param}
+\alias{rtest.niche}
+\title{Method to Analyse a pair of tables : Environmental and Faunistic Data}
+\description{
+performs a special multivariate analysis for ecological data.
+}
+\usage{
+niche(dudiX, Y, scannf = TRUE, nf = 2)
+\method{print}{niche}(x, \dots)
+\method{plot}{niche}(x, xax = 1, yax = 2, \dots)
+niche.param(x)
+\method{rtest}{niche}(xtest,nrepet=99, \dots)
+}
+\arguments{
+ \item{dudiX}{a duality diagram providing from a function \code{dudi.coa}, \code{dudi.pca}, ... using an array sites-variables}
+ \item{Y}{a data frame sites-species according to \code{dudiX$tab} with no columns of zero}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+ \item{x}{an object of class \code{niche}}
+ \item{\dots}{further arguments passed to or from other methods}
+ \item{xax, yax}{the numbers of the x-axis and the y-axis}
+ \item{xtest}{an object of class \code{niche}}
+ \item{nrepet}{the number of permutations for the testing procedure}
+}
+\value{
+Returns a list of the class \code{niche} (sub-class of \code{dudi}) containing :
+ \item{rank}{an integer indicating the rank of the studied matrix}
+ \item{nf}{an integer indicating the number of kept axes}
+ \item{RV}{a numeric value indicating the RV coefficient}
+ \item{eig}{a numeric vector with the all eigenvalues}
+ \item{lw}{a data frame with the row weigths (crossed array)}
+ \item{tab}{a data frame with the crossed array (averaging species/sites)}
+ \item{li}{a data frame with the species coordinates}
+ \item{l1}{a data frame with the species normed scores}
+ \item{co}{a data frame with the variable coordinates}
+ \item{c1}{a data frame with the variable normed scores}
+ \item{ls}{a data frame with the site coordinates}
+ \item{as}{a data frame with the axis upon niche axis}
+}
+\references{
+Dolédec, S., Chessel, D. and Gimaret, C. (2000) Niche separation in community analysis: a new method. \emph{Ecology}, \bold{81}, 2914--1927.
+}
+\author{
+Daniel Chessel\cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}\cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\examples{
+data(doubs)
+dudi1 <- dudi.pca(doubs$env, scale = TRUE, scan = FALSE, nf = 3)
+nic1 <- niche(dudi1, doubs$fish, scann = FALSE)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.traject(dudi1$li, plab.cex = 0, plot = FALSE)
+ g2 <- s.traject(nic1$ls, plab.cex = 0, plot = FALSE)
+ g3 <- s.corcircle(nic1$as, plot = FALSE)
+ g4 <- s.arrow(nic1$c1, plot = FALSE)
+ G1 <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+ glist <- list()
+ for(i in 1:ncol(doubs$fish))
+ glist[[i]] <- s.distri(nic1$ls, dfdistri = doubs$fish[, i], psub.text = names(doubs$fish)[i],
+ plot = FALSE, storeData = TRUE)
+ G2 <- ADEgS(glist, layout = c(5, 6))
+
+ G3 <- s.arrow(nic1$li, plab.cex = 0.7)
+
+} else {
+ par(mfrow = c(2, 2))
+ s.traject(dudi1$li, clab = 0)
+ s.traject(nic1$ls, clab = 0)
+ s.corcircle(nic1$as)
+ s.arrow(nic1$c1)
+
+ par(mfrow = c(5, 6))
+ for (i in 1:27) s.distri(nic1$ls, as.data.frame(doubs$fish[,i]),
+ csub = 2, sub = names(doubs$fish)[i])
+
+ par(mfrow = c(1, 1))
+ s.arrow(nic1$li, clab = 0.7)
+
+}
+
+data(trichometeo)
+pca1 <- dudi.pca(trichometeo$meteo, scan = FALSE)
+nic1 <- niche(pca1, log(trichometeo$fau + 1), scan = FALSE)
+plot(nic1)
+niche.param(nic1)
+rtest(nic1,19)
+
+data(rpjdl)
+plot(niche(dudi.pca(rpjdl$mil, scan = FALSE), rpjdl$fau, scan = FALSE))
+}
+\keyword{multivariate}
diff --git a/man/nipals.Rd b/man/nipals.Rd
new file mode 100644
index 0000000..53d87c5
--- /dev/null
+++ b/man/nipals.Rd
@@ -0,0 +1,101 @@
+\name{nipals}
+\alias{nipals}
+\alias{print.nipals}
+\alias{scatter.nipals}
+
+\title{Non-linear Iterative Partial Least Squares (NIPALS) algorithm}
+\description{
+ This function performs NIPALS algorithm, i.e. a principal component
+ analysis of a data table that can contain missing values.
+}
+\usage{
+nipals(df, nf = 2, rec = FALSE, niter = 100, tol = 1e-09)
+\method{scatter}{nipals}(x, xax = 1, yax = 2, clab.row = 0.75, clab.col
+= 1, posieig = "top", sub = NULL, ...)
+\method{print}{nipals}(x, ...)
+}
+
+\arguments{
+ \item{df}{a data frame that can contain missing values}
+ \item{nf}{an integer, the number of axes to keep}
+ \item{rec}{a logical that specify if the functions must perform the
+ reconstitution of the data using the \code{nf} axes}
+ \item{niter}{an integer, the maximum number of iterations}
+ \item{tol}{a real, the tolerance used in the iterative algorithm}
+ \item{x}{an object of class \code{nipals}}
+ \item{xax}{the column number for the x-axis}
+ \item{yax}{the column number for the y-axis}
+ \item{clab.row}{a character size for the rows}
+ \item{clab.col}{a character size for the columns}
+ \item{posieig}{if "top" the eigenvalues bar plot is upside, if "bottom" it is downside, if "none" no plot}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\details{
+Data are scaled (mean 0 and variance 1) prior to the analysis.
+}
+\value{
+Returns a list of classes \code{nipals}:
+ \item{tab}{the scaled data frame}
+ \item{eig}{the pseudoeigenvalues}
+ \item{rank}{the rank of the analyzed matrice}
+ \item{nf}{the number of factors}
+ \item{c1}{the column normed scores}
+ \item{co}{the column coordinates}
+ \item{li}{the row coordinates}
+ \item{call}{the call function}
+ \item{nb}{the number of iterations for each axis}
+ \item{rec}{a data frame obtained by the reconstitution of the scaled
+ data using the \code{nf} axes}
+
+}
+\references{
+ Wold, H. (1966) Estimation of principal
+ components and related models by iterative least squares. In
+ P. Krishnaiah, editors.\emph{Multivariate
+ Analysis}, Academic Press, 391--420.\cr\cr
+
+ Wold, S., Esbensen, K. and Geladi, P. (1987) Principal component
+ analysis \emph{Chemometrics and Intelligent Laboratory Systems},
+ \bold{2}, 37--52.
+ }
+
+\author{Stéphane Dray \email{stephane.dray at univ-lyon1.fr}}
+\seealso{\code{\link{dudi.pca}}}
+\examples{
+data(doubs)
+## nipals is equivalent to dudi.pca when there are no NA
+acp1 <- dudi.pca(doubs$env, scannf = FALSE, nf = 2)
+nip1 <- nipals(doubs$env)
+
+
+if(adegraphicsLoaded()) {
+ if(requireNamespace("lattice", quietly = TRUE)) {
+ g1 <- s1d.barchart(acp1$eig, psub.text = "dudi.pca", p1d.horizontal = FALSE, plot = FALSE)
+ g2 <- s1d.barchart(nip1$eig, psub.text = "nipals", p1d.horizontal = FALSE, plot = FALSE)
+ g3 <- lattice::xyplot(nip1$c1[, 1] ~ acp1$c1[, 1], main = "col scores", xlab = "dudi.pca",
+ ylab = "nipals")
+ g4 <- lattice::xyplot(nip1$li[, 1] ~ acp1$li[, 1], main = "row scores", xlab = "dudi.pca",
+ ylab = "nipals")
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+ }
+
+} else {
+ par(mfrow = c(2, 2))
+ barplot(acp1$eig, main = "dudi.pca")
+ barplot(nip1$eig, main = "nipals")
+ plot(acp1$c1[, 1], nip1$c1[, 1], main = "col scores", xlab = "dudi.pca", ylab = "nipals")
+ plot(acp1$li[, 1], nip1$li[, 1], main = "row scores", xlab = "dudi.pca", ylab = "nipals")
+}
+
+\dontrun{
+## with NAs:
+doubs$env[1, 1] <- NA
+nip2 <- nipals(doubs$env)
+cor(nip1$li, nip2$li)
+nip1$eig
+nip2$eig
+}}
+
+\keyword{multivariate}
+
diff --git a/man/njplot.Rd b/man/njplot.Rd
new file mode 100644
index 0000000..66bde58
--- /dev/null
+++ b/man/njplot.Rd
@@ -0,0 +1,32 @@
+\name{njplot}
+\alias{njplot}
+\docType{data}
+\title{Phylogeny and trait of bacteria}
+\description{
+This data set describes the phylogeny of 36 bacteria as reported by Perrière and Gouy (1996). It also gives the GC rate corresponding to these 36 species.
+}
+\usage{data(njplot)}
+\format{
+\code{njplot} is a list containing the 2 following objects:
+\describe{
+ \item{tre}{is a character string giving the fission tree in Newick format.}
+ \item{tauxcg}{is a numeric vector that gives the CG rate of the 36
+ species.}
+ }
+}
+\source{
+Data were obtained by Manolo Gouy \email{manolo.gouy at univ-lyon1.fr}
+}
+\references{
+Perrière, G. and Gouy, M. (1996) WWW-Query : an on-line retrieval system for biological sequence banks. \emph{Biochimie}, \bold{78}, 364--369.
+}
+\examples{
+data(njplot)
+njplot.phy <- newick2phylog(njplot$tre)
+par(mfrow = c(2,1))
+tauxcg0 <- njplot$tauxcg - mean(njplot$tauxcg)
+symbols.phylog(njplot.phy, squares = tauxcg0)
+symbols.phylog(njplot.phy, circles = tauxcg0)
+par(mfrow = c(1,1))
+}
+\keyword{datasets}
diff --git a/man/olympic.Rd b/man/olympic.Rd
new file mode 100644
index 0000000..27f6935
--- /dev/null
+++ b/man/olympic.Rd
@@ -0,0 +1,51 @@
+\name{olympic}
+\alias{olympic}
+\docType{data}
+\title{Olympic Decathlon}
+\description{
+This data set gives the performances of 33 men's decathlon at the Olympic Games (1988).
+}
+\usage{data(olympic)}
+\format{
+ \code{olympic} is a list of 2 components.
+ \describe{
+ \item{tab}{is a data frame with 33 rows and 10 columns events of the decathlon: 100 meters (100),
+ long jump (long), shotput (poid), high jump (haut), 400 meters (400), 110-meter hurdles (110),
+ discus throw (disq), pole vault (perc), javelin (jave) and 1500 meters (1500).}
+ \item{score}{is a vector of the final points scores of the competition.}
+ }
+}
+\source{
+Example 357 in: \cr
+Hand, D.J., Daly, F., Lunn, A.D., McConway, K.J. and Ostrowski, E. (1994)
+\emph{A handbook of small data sets}, Chapman & Hall, London. 458 p.
+
+Lunn, A. D. and McNeil, D.R. (1991) \emph{Computer-Interactive Data Analysis}, Wiley, New York
+}
+\examples{
+data(olympic)
+pca1 <- dudi.pca(olympic$tab, scan = FALSE)
+
+if(adegraphicsLoaded()) {
+ if(requireNamespace("lattice", quietly = TRUE)) {
+ g1 <- s1d.barchart(pca1$eig, p1d.hori = FALSE, plot = FALSE)
+ g2 <- s.corcircle(pca1$co, plot = FALSE)
+ g3 <- lattice::xyplot(pca1$l1[, 1] ~ olympic$score, type = c("p", "r"))
+ g41 <- s.label(pca1$l1, plab.cex = 0.5, plot = FALSE)
+ g42 <- s.arrow(2 * pca1$co, plot = FALSE)
+ g4 <- superpose(g41, g42)
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+ }
+
+} else {
+ par(mfrow = c(2, 2))
+ barplot(pca1$eig)
+ s.corcircle(pca1$co)
+ plot(olympic$score, pca1$l1[, 1])
+ abline(lm(pca1$l1[, 1] ~ olympic$score))
+ s.label(pca1$l1, clab = 0.5)
+ s.arrow(2 * pca1$co, add.p = TRUE)
+ par(mfrow = c(1, 1))
+}}
+
+\keyword{datasets}
diff --git a/man/optimEH.Rd b/man/optimEH.Rd
new file mode 100644
index 0000000..ed0f08c
--- /dev/null
+++ b/man/optimEH.Rd
@@ -0,0 +1,51 @@
+\name{optimEH}
+\alias{optimEH}
+\title{Nee and May's optimizing process
+}
+\description{
+performs Nee and May's optimizing scheme. When branch lengths in an ultrametric phylogenetic
+tree are expressed as divergence times, the total sum of branch lengths in that
+tree expresses the amount of evolutionary history. Nee and May's algorithm
+optimizes the amount of evolutionary history preserved if only k species out
+of n were to be saved. The k-1 closest-to-root nodes are selected, which
+defines k clades; one species from each clade is picked. At this last step,
+we decide to select the most original species of each from the k clades.
+
+}
+\usage{
+optimEH(phyl, nbofsp, tol = 1e-8, give.list = TRUE)
+}
+\arguments{
+ \item{phyl}{an object of class phylog}
+ \item{nbofsp}{an integer indicating the number of species saved (k).}
+ \item{tol}{a tolerance threshold for null values (a value less than \code{tol} in absolute terms is considered as NULL). }
+ \item{give.list}{logical value indicating whether a list of optimizing species should be provided. If \code{give.list = TRUE},
+ \code{optimEH} provides the list of the k species which optimize the amount of evolutionary history preserved
+ and are the most original species in their clades. If \code{give.list = FALSE}, \code{optimEH} returns directly the real
+ value giving the amount of evolutionary history preserved.}
+}
+\value{
+Returns a list containing:
+ \item{value}{a real value providing the amount of evolutionary history preserved.}
+ \item{selected.sp}{a data frame containing the list of the k species which optimize the amount of evolutionary history preserved
+ and are the most original species in their clades.}
+}
+\references{
+Nee, S. and May, R.M. (1997) Extinction and the loss of evolutionary history. \emph{Science}
+\bold{278}, 692--694.
+
+Pavoine, S., Ollier, S. and Dufour, A.-B. (2005)
+Is the originality of a species measurable?
+\emph{Ecology Letters}, \bold{8}, 579--586.
+}
+\author{
+Sandrine Pavoine \email{pavoine at mnhn.fr}
+}
+\seealso{\code{\link{randEH}}
+}
+\examples{
+data(carni70)
+carni70.phy <- newick2phylog(carni70$tre)
+optimEH(carni70.phy, nbofsp = 7, give.list = TRUE)
+}
+\keyword{multivariate}
diff --git a/man/oribatid.Rd b/man/oribatid.Rd
new file mode 100644
index 0000000..445dccd
--- /dev/null
+++ b/man/oribatid.Rd
@@ -0,0 +1,54 @@
+\name{oribatid}
+\alias{oribatid}
+\docType{data}
+\title{Oribatid mite}
+\description{
+This data set contains informations about environmental control and spatial structure in ecological communities of Oribatid mites.
+}
+\usage{data(oribatid)}
+\format{
+\code{oribatid} is a list containing the following objects :
+\describe{
+ \item{fau}{: a data frame with 70 rows (sites) and 35 columns (Oribatid species)}
+ \item{envir}{: a data frame with 70 rows (sites) and 5 columns (environmental variables)}
+ \item{xy}{: a data frame that contains spatial coordinates of the 70 sites}
+}}
+\details{
+Variables of \code{oribatid$envir} are the following ones : \cr
+substrate: a factor with seven levels that describes the nature of the substratum\cr
+shrubs: a factor with three levels that describes the absence/presence of shrubs\cr
+topo: a factor with two levels that describes the microtopography\cr
+density: substratum density (\eqn{g.L^{-1}}{g.L^-1})\cr
+water: water content of the substratum (\eqn{g.L^{-1}}{g.L^-1})
+}
+\source{
+Data prepared by P. Legendre \email{Pierre.Legendre at umontreal.ca} and \cr
+D. Borcard \email{borcardd at magellan.umontreal.ca} starting from \cr
+\url{http://www.fas.umontreal.ca/biol/casgrain/fr/labo/oribates.html}\cr
+}
+\references{
+Borcard, D., and Legendre, P. (1994) Environmental control and spatial structure in ecological communities:
+an example using Oribatid mites (\emph{Acari Oribatei}). \emph{Environmental and Ecological Statistics}, \bold{1}, 37--61.
+
+Borcard, D., Legendre, P., and Drapeau, P. (1992) Partialling out the spatial component of ecological variation.
+\emph{Ecology}, \bold{73}, 1045--1055.
+
+See a data description at \url{http://pbil.univ-lyon1.fr/R/pdf/pps039.pdf} (in French).
+}
+\examples{
+data(oribatid)
+ori.xy <- oribatid$xy[, c(2, 1)]
+names(ori.xy) <- c("x","y")
+plot(ori.xy,pch = 20, cex = 2, asp = 1)
+
+if(requireNamespace("deldir", quietly = TRUE) & requireNamespace("spdep", quietly = TRUE)) {
+ plot(deldir::deldir(ori.xy), add = TRUE)
+ if(adegraphicsLoaded()) {
+ s.label(ori.xy, nb = spdep::knn2nb(spdep::knearneigh(as.matrix(ori.xy), 3)), plab.cex = 0)
+ } else {
+ s.label(ori.xy, add.p = TRUE, clab = 0,
+ neig = nb2neig(spdep::knn2nb(spdep::knearneigh(as.matrix(ori.xy), 3))))
+ }
+}
+}
+\keyword{datasets}
diff --git a/man/originality.Rd b/man/originality.Rd
new file mode 100644
index 0000000..423d8a8
--- /dev/null
+++ b/man/originality.Rd
@@ -0,0 +1,57 @@
+\name{originality}
+\alias{originality}
+\title{Originality of a species
+}
+\description{
+computes originality values for species from an ultrametric phylogenetic tree.
+}
+\usage{
+originality(phyl, method = 5)
+}
+\arguments{
+ \item{phyl}{an object of class phylog}
+ \item{method}{a vector containing integers between 1 and 7. }
+}
+\details{
+1 = Vane-Wright et al.'s (1991) node-counting index
+2 = May's (1990) branch-counting index
+3 = Nixon and Wheeler's (1991) unweighted index, based on the sum of units in binary values
+4 = Nixon and Wheeler's (1991) weighted index
+5 = QE-based index
+6 = Isaac et al. (2007) ED index
+7 = Redding et al. (2006) Equal-split index
+}
+\value{
+Returns a data frame with species in rows, and the selected indices of originality in columns.
+Indices are expressed as percentages.
+}
+\references{
+Isaac, N.J.B., Turvey, S.T., Collen, B., Waterman, C. and Baillie, J.E.M. (2007) Mammals on the EDGE:
+conservation priorities based on threat and phylogeny. \emph{PloS ONE}, \bold{2}, e--296.
+
+Redding, D. and Mooers, A. (2006) Incorporating evolutionary measures into conservation prioritization.
+\emph{Conservation Biology}, \bold{20}, 1670--1678.
+
+Pavoine, S., Ollier, S. and Dufour, A.-B. (2005) Is the originality of a species measurable?
+\emph{Ecology Letters}, \bold{8}, 579--586.
+
+Vane-Wright, R.I., Humphries, C.J. and Williams, P.H. (1991). What to protect? Systematics
+and the agony of choice. \emph{Biological Conservation}, \bold{55}, 235--254.
+
+May, R.M. (1990). Taxonomy as destiny. \emph{Nature}, \bold{347}, 129--130.
+
+Nixon, K.C. and Wheeler, Q.D. (1992). Measures of phylogenetic diversity. In: \emph{Extinction and
+Phylogeny} (eds. Novacek, M.J. and Wheeler, Q.D.), 216--234, Columbia University Press, New York.
+}
+\author{
+Sandrine Pavoine \email{pavoine at mnhn.fr}
+}
+\examples{
+data(carni70)
+carni70.phy <- newick2phylog(carni70$tre)
+ori.tab <- originality(carni70.phy, 1:7)
+names(ori.tab)
+dotchart.phylog(carni70.phy, ori.tab, scaling = FALSE, yjoining = 0,
+ ranging = FALSE, cleaves = 0, ceti = 0.5, csub = 0.7, cdot = 0.5)
+}
+\keyword{multivariate}
diff --git a/man/orisaved.Rd b/man/orisaved.Rd
new file mode 100644
index 0000000..99d22ea
--- /dev/null
+++ b/man/orisaved.Rd
@@ -0,0 +1,47 @@
+\name{orisaved}
+\alias{orisaved}
+\title{Maximal or minimal amount of originality saved under optimal conditions
+}
+\description{
+computes the maximal or minimal amount of originality saved over all
+combinations of species optimizing the amount of evolutionary history preserved. The
+originality of a species is measured with the QE-based index.
+}
+\usage{
+orisaved(phyl, rate = 0.1, method = 1)
+}
+\arguments{
+ \item{phyl}{an object of class phylog}
+ \item{rate}{a real value (between 0 and 1) indicating how many species will
+ be saved for each calculation. For example, if the total number of species is 70
+ and 'rate = 0.1' then the calculations will be done at a rate of 10 \% i.e. for 0
+ (= 0 \%), 7 (= 10 \%), 14 (= 20 \%), 21 (= 30 \%), ...,
+ 63 (= 90 \%) and 70(= 100 \%)
+ species saved. If 'rate = 0.5' then the calculations will be done for
+ only 0 (= 0 \%), 35 (= 50 \%) and 70(= 100 \%) species saved.}
+ \item{method}{an integer either 1 or 2 (see details).}
+}
+\details{
+1 = maximum amount of originality saved
+2 = minimum amount of originality saved
+}
+\value{
+Returns a numeric vector.
+}
+\references{
+Pavoine, S., Ollier, S. and Dufour, A.-B. (2005)
+Is the originality of a species measurable?
+\emph{Ecology Letters}, \bold{8}, 579--586.
+}
+\author{
+Sandrine Pavoine \email{pavoine at mnhn.fr}
+}
+\examples{
+data(carni70)
+carni70.phy <- newick2phylog(carni70$tre)
+tmax <- orisaved(carni70.phy, rate = 1 / 70, method = 1)
+tmin <- orisaved(carni70.phy, rate = 1 / 70, method = 2)
+plot(c(0, 1:70), tmax, xlab = "nb of species saved", ylab = "Originality saved", type = "l")
+lines(c(0, 1:70), tmin, lty = 2)
+}
+\keyword{multivariate}
diff --git a/man/orthobasis.Rd b/man/orthobasis.Rd
new file mode 100644
index 0000000..09fada7
--- /dev/null
+++ b/man/orthobasis.Rd
@@ -0,0 +1,148 @@
+\name{orthobasis}
+\alias{orthobasis}
+\alias{orthobasis.neig}
+\alias{orthobasis.line}
+\alias{orthobasis.circ}
+\alias{orthobasis.mat}
+\alias{orthobasis.haar}
+\alias{print.orthobasis}
+\alias{is.orthobasis}
+\alias{summary.orthobasis}
+\alias{plot.orthobasis}
+
+\title{Orthonormal basis for orthonormal transform}
+\description{
+These functions returns object of class \code{'orthobasis'} that
+contains data frame defining an orthonormal basis.
+
+\code{orthobasic.neig} returns the eigen vectors of the matrix N-M where M is the symmetric \emph{n} by \emph{n} matrix of the between-sites neighbouring graph and N is the diagonal matrix of neighbour numbers. \cr
+\code{orthobasis.line} returns the analytical solution for the linear neighbouring graph. \cr
+\code{orthobasic.circ} returns the analytical solution for the circular neighbouring graph. \cr
+\code{orthobsic.mat} returns the eigen vectors of the general link matrix M. \cr
+\code{orthobasis.haar} returns wavelet haar basis.
+}
+\usage{
+orthobasis.neig(neig)
+orthobasis.line(n)
+orthobasis.circ(n)
+orthobasis.mat(mat, cnw=TRUE)
+orthobasis.haar(n)
+\method{print}{orthobasis}(x,..., nr = 6, nc = 4)
+\method{plot}{orthobasis}(x,...)
+\method{summary}{orthobasis}(object,...)
+is.orthobasis(x)
+}
+\arguments{
+ \item{neig}{is an object of class \code{neig}}
+ \item{n}{is an integer that defines length of vectors}
+ \item{mat}{is a \emph{n} by \emph{n} phylogenetic or spatial link matrix}
+ \item{cnw}{if TRUE, the matrix of the neighbouring graph is modified to give Constant Neighbouring Weights}
+ \item{x, object}{is an object of class \code{orthobasis}}
+ \item{nr, nc}{the number of rows and columns to be printed}
+ \item{\dots}{: further arguments passed to or from other methods}
+}
+\value{
+All the functions return an object of class \code{orthobasis} containing a data frame.
+This data frame defines an orthonormal basis with various attributes: \cr
+ \item{names}{names of the vectors}
+ \item{row.names}{row names of the data frame}
+ \item{class}{class}
+ \item{values}{optional associated eigenvalues}
+ \item{weights}{weights for the rows}
+ \item{call}{: call}
+}
+\references{
+Misiti, M., Misiti, Y., Oppenheim, G. and Poggi, J.M. (1993) Analyse de signaux classiques par décomposition en ondelettes.
+\emph{Revue de Statistique Appliquée}, \bold{41}, 5--32.
+
+Cornillon, P.A. (1998) \emph{Prise en compte de proximités en analyse factorielle et comparative}.
+Thèse, Ecole Nationale Supérieure Agronomique, Montpellier.
+}
+\author{Sébastien Ollier \email{sebastien.ollier at u-psud.fr} \cr
+Daniel Chessel
+}
+\note{the function \code{orthobasis.haar} uses function \code{\link[waveslim]{wavelet.filter}} from package waveslim.}
+\seealso{\code{\link{gridrowcol}} that defines an orthobasis for square grid, \code{\link{phylog}} that defines an orthobasis for phylogenetic tree, \code{\link{orthogram}} and \code{\link{mld}}}
+\examples{
+
+# a 2D spatial orthobasis
+w <- gridrowcol(8, 8)
+if(adegraphicsLoaded()) {
+ g1 <- s.value(w$xy, w$orthobasis[, 1:16], pleg.drawKey = FALSE, pgri.text.cex = 0,
+ ylim = c(0, 10), porigin.include = FALSE, paxes.draw = FALSE)
+ g2 <- s1d.barchart(attr(w$orthobasis, "values"), p1d.horizontal = FALSE,
+ labels = names(attr(w$orthobasis, "values")), plabels.cex = 0.7)
+
+} else {
+ par(mfrow = c(4, 4))
+ for(k in 1:16)
+ s.value(w$xy, w$orthobasis[, k], cleg = 0, csi = 2, incl = FALSE,
+ addax = FALSE, sub = k, csub = 4, ylim = c(0, 10), cgri = 0)
+ par(mfrow = c(1, 1))
+ barplot(attr(w$orthobasis, "values"))
+}
+
+
+# Haar 1D orthobasis
+w <- orthobasis.haar(32)
+par(mfrow = c(8, 4))
+par(mar = c(0.1, 0.1, 0.1, 0.1))
+ for (k in 1:31) {
+ plot(w[, k], type = "S", xlab = "", ylab = "", xaxt = "n",
+ yaxt = "n", xaxs = "i", yaxs = "i", ylim = c(-4.5, 4.5))
+ points(w[, k], type = "p", pch = 20, cex = 1.5)
+}
+
+# a 1D orthobasis
+w <- orthobasis.line(n = 33)
+par(mfrow = c(8, 4))
+par(mar = c(0.1, 0.1, 0.1, 0.1))
+ for (k in 1:32) {
+ plot(w[, k], type = "l", xlab = "", ylab = "", xaxt = "n",
+ yaxt = "n", xaxs = "i", yaxs = "i", ylim = c(-1.5, 1.5))
+ points(w[, k], type = "p", pch = 20, cex = 1.5)
+}
+
+if(adegraphicsLoaded()) {
+ s1d.barchart(attr(w, "values"), p1d.horizontal = FALSE, labels = names(attr(w, "values")),
+ plab.cex = 0.7)
+} else {
+ par(mfrow = c(1, 1))
+ barplot(attr(w, "values"))
+}
+
+w <- orthobasis.circ(n = 26)
+#par(mfrow = c(5, 5))
+#par(mar = c(0.1, 0.1, 0.1, 0.1))
+# for (k in 1:25)
+# dotcircle(w[, k], xlim = c(-1.5, 1.5), cleg = 0)
+
+par(mfrow = c(1, 1))
+#barplot(attr(w, "values"))
+
+\dontrun{
+# a spatial orthobasis
+data(mafragh)
+w <- orthobasis.neig(mafragh$neig)
+if(adegraphicsLoaded()) {
+ s.value(mafragh$xy, w[, 1:8], plegend.drawKey = FALSE)
+ s1d.barchart(attr(w, "values"), p1d.horizontal = FALSE)
+} else {
+ par(mfrow = c(4, 2))
+ for(k in 1:8)
+ s.value(mafragh$xy, w[, k], cleg = 0, sub = as.character(k), csub = 3)
+ par(mfrow = c(1, 1))
+ barplot(attr(w, "values"))
+}
+
+# a phylogenetic orthobasis
+data(njplot)
+phy <- newick2phylog(njplot$tre)
+wA <- phy$Ascores
+wW <- phy$Wscores
+table.phylog(phylog = phy, wA, clabel.row = 0, clabel.col = 0.5)
+table.phylog(phylog = phy, wW, clabel.row = 0, clabel.col = 0.5)
+
+}}
+\keyword{spatial}
+\keyword{ts}
diff --git a/man/orthogram.Rd b/man/orthogram.Rd
new file mode 100644
index 0000000..8f43831
--- /dev/null
+++ b/man/orthogram.Rd
@@ -0,0 +1,110 @@
+\name{orthogram}
+\alias{orthogram}
+\alias{orthogram-deprecated}
+\title{Orthonormal decomposition of variance}
+\description{
+ This function is deprecated. See \code{orthogram} in adephylo.
+
+This function performs the orthonormal decomposition of variance of a quantitative variable on an orthonormal basis. It also returns the results of five non parametric tests associated to the variance decomposition.
+It thus provides tools (graphical displays and test) for analysing phylogenetic, spatial and temporal pattern of one quantitative variable.
+}
+\usage{
+orthogram(x, orthobas = NULL, neig = NULL, phylog = NULL,
+ nrepet = 999, posinega = 0, tol = 1e-07, na.action = c("fail",
+ "mean"), cdot = 1.5, cfont.main = 1.5, lwd = 2, nclass,
+ high.scores = 0,alter=c("greater", "less", "two-sided"), ...)
+}
+\arguments{
+ \item{x}{a numeric vector corresponding to the quantitative variable}
+ \item{orthobas}{an object of class \code{'orthobasis'}}
+ \item{neig}{an object of class \code{'neig'}}
+ \item{phylog}{an object of class \code{'phylog'}}
+ \item{nrepet}{an integer giving the number of permutations}
+ \item{posinega}{a parameter for the ratio test. If posinega > 0, the function computes the ratio test.}
+ \item{tol}{a tolerance threshold for orthonormality condition}
+ \item{na.action}{if 'fail' stops the execution of the current expression when \code{z} contains any missing value. If 'mean' replaces any missing values by mean(\code{z})}
+ \item{cdot}{a character size for points on the cumulative decomposition display}
+ \item{cfont.main}{a character size for titles}
+ \item{lwd}{a character size for dash lines}
+ \item{nclass}{a single number giving the number of cells for the histogram}
+ \item{high.scores}{a single number giving the number of vectors to
+ return. If > 0, the function returns labels of vectors that explains
+ the larger part of variance.}
+ \item{alter}{a character string specifying the alternative hypothesis,
+ must be one of "greater" (default), "less" or "two-sided"}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\details{
+The function computes the variance decomposition of a quantitative vector x on an orthonormal basis B. The variable is normalized given the uniform weight to eliminate problem of scales.
+It plots the squared correlations \eqn{R^{2}}{R^2} between x and vectors of B (variance decomposition) and the cumulated squared correlations \eqn{SR^{2}}{SR^2} (cumulative decomposition).
+The function also provides five non parametric tests to test the existence of autocorrelation. The tests derive from the five following statistics :
+\describe{
+ \item{R2Max}{=\eqn{\max(R^{2})}{max(R^2)}. It takes high value when a high part of the variability is explained by one score.}
+ \item{SkR2k}{=\eqn{\sum_{i=1}^{n-1}(iR^{2}_i)}{sum_i^(n-1) i*(R^2)_i}. It compares the part of variance explained by internal nodes to the one explained by end nodes.}
+ \item{Dmax}{=\eqn{\max_{m=1,...,n-1}(\sum_{j=1}^{m}R^{2}_j - \frac{m}{n-1})}{max_(m=1,...,n-1)(sum_(j=1)^m(R^2_j) - (m/n-1))}. It examines the accumulation of variance for a sequence of scores.}
+ \item{SCE}{=\eqn{\sum_{m=1}^{n-1} (\sum_{j=1}^{m}R^{2}_j - \frac{m}{n-1})^{2}}{sum_(m=1)^(n-1)(sum_(j=1)^m(R^2_j) - (m/n-1))^2}. It examines also the accumulation of variance for a sequence of scores.}
+ \item{ratio}{depends of the parameter posinega. If posinega > 0, the
+ statistic ratio exists and equals
+ \eqn{\sum_{i=1}^{posinega}R^{2}_i}{sum_i (R^2)_i with i < posinega
+ + 1}. It compares the part of variance explained by internal
+ nodes to the one explained by end nodes when we can define how
+ many vectors correspond to internal nodes.}
+}
+}
+\value{
+If (high.scores = 0), returns an object of class \code{'krandtest'} (randomization tests) corresponding to the five non parametric tests. \cr \cr
+If (high.scores > 0), returns a list containg :
+ \item{w}{: an object of class \code{'krandtest'} (randomization tests)}
+ \item{scores.order}{: a vector which terms give labels of vectors that explain the larger part of variance}
+}
+\references{
+Ollier, S., Chessel, D. and Couteron, P. (2005) Orthonormal Transform to Decompose the Variance of a Life-History Trait across a Phylogenetic Tree. \emph{Biometrics}, \bold{62}, 471--477.
+}
+\author{Sébastien Ollier \email{sebastien.ollier at u-psud.fr} \cr
+Daniel Chessel
+}
+\seealso{\code{\link{gridrowcol}}, \code{\link{orthobasis}}, \code{\link{mld}}}
+\examples{
+# a phylogenetic example
+data(ungulates)
+ung.phy <- newick2phylog(ungulates$tre)
+FemBodyMass <- log(ungulates$tab[,1])
+NeonatBodyMass <- log((ungulates$tab[,2]+ungulates$tab[,3])/2)
+plot(FemBodyMass,NeonatBodyMass, pch = 20, cex = 2)
+abline(lm(NeonatBodyMass~FemBodyMass))
+z <- residuals(lm(NeonatBodyMass~FemBodyMass))
+dotchart.phylog(ung.phy,val = z, clabel.n = 1,
+ labels.n = ung.phy$Blabels, cle = 1.5, cdot = 2)
+table.phylog(ung.phy$Bscores, ung.phy,clabel.n = 1,
+ labels.n = ung.phy$Blabels)
+orthogram(z, ung.phy$Bscores)
+orthogram(z, phylog=ung.phy) # the same thing
+
+# a spatial example
+data(irishdata)
+neig1 <- neig(mat01 = 1*(irishdata$link > 0))
+sco1 <- scores.neig(neig1)
+z <- scalewt(irishdata$tab$cow)
+orthogram(z, sco1)
+
+# a temporal example
+data(arrival)
+w <- orthobasis.circ(24)
+orthogram(arrival$hours, w)
+par(mfrow = c(1,2))
+dotcircle(arrival$hours)
+dotcircle(w[,2])
+par(mfrow = c(1,1))
+
+data(lynx)
+ortho <- orthobasis.line(114)
+orthogram(lynx,ortho)
+attributes(lynx)$tsp
+par(mfrow = c(2,1))
+par(mar = c(4,4,2,2))
+plot.ts(lynx)
+plot(ts(ortho[,23], start = 1821, end = 1934, freq = 1), ylab = "score 23")
+par(mfrow = c(1,1))
+}
+\keyword{spatial}
+\keyword{ts}
diff --git a/man/ours.Rd b/man/ours.Rd
new file mode 100644
index 0000000..b9d8a37
--- /dev/null
+++ b/man/ours.Rd
@@ -0,0 +1,91 @@
+\name{ours}
+\alias{ours}
+\docType{data}
+\title{A table of Qualitative Variables}
+\usage{data(ours)}
+\description{
+ The \code{ours} (bears) data frame has 38 rows, areas of the "Inventaire National Forestier", and 10 columns.
+}
+\format{
+ This data frame contains the following columns:
+ \enumerate{
+ \item altit: importance of the altitudinal area inhabited by bears,
+ a factor with levels:
+ \itemize{
+ \item \code{1} less than 50\% of the area between 800 and 2000 meters
+ \item \code{2} between 50 and 70\%
+ \item \code{3} more than 70\%}
+
+ \item deniv: importance of the average variation in level by square of 50 km2, a factor with levels:
+ \itemize{
+ \item \code{1} less than 700m
+ \item \code{2} between 700 and 900 m
+ \item \code{3} more than 900 m }
+
+ \item cloiso: partitioning of the massif, a factor with levels:
+ \itemize{
+ \item \code{1} a great valley or a ridge isolates at least a quarter of the massif
+ \item \code{2} less than a quarter of the massif is isolated
+ \item \code{3} the massif has no split}
+
+ \item domain: importance of the national forests on contact with the massif, a factor with levels:
+ \itemize{
+ \item \code{1} less than 400 km2
+ \item \code{2} between 400 and 1000 km2
+ \item \code{3} more than 1000 km2 }
+
+ \item boise: rate of afforestation, a factor with levels:
+ \itemize{
+ \item \code{1} less than 30\%
+ \item \code{2} between 30 and 50\%
+ \item \code{3} more than 50\% }
+
+ \item hetra: importance of plantations and mixed forests, a factor with levels:
+ \itemize{
+ \item \code{1} less than 5\%
+ \item \code{2} between 5 and 10\%
+ \item \code{3} more than 10\% of the massif }
+
+ \item favor: importance of favorable forests, plantations, mixed forests, fir plantations, a factor with levels:
+ \itemize{
+ \item \code{1} less than 5\%
+ \item \code{2} between 5 and 10\%
+ \item \code{3} more than 10\% of the massif }
+
+ \item inexp: importance of unworked forests, a factor with levels:
+ \itemize{
+ \item \code{1} less than 4\%
+ \item \code{2} between 4 and 8\%
+ \item \code{3} more than 8\% of the total area }
+
+ \item citat: presence of the bear before its disappearance, a factor with levels:
+ \itemize{
+ \item \code{1} no quotation since 1840
+ \item \code{2} 1 to 3 quotations before 1900 and none after
+ \item \code{3} 4 quotations before 1900 and none after
+ \item \code{4} at least 4 quotations before 1900 and at least 1 quotation between 1900 and 1940 }
+
+ \item depart: district, a factor with levels:
+ \itemize{
+ \item \code{AHP} Alpes-de-Haute-Provence
+ \item \code{AM} Alpes-Maritimes
+ \item \code{D} Drôme
+ \item \code{HP} Hautes-Alpes
+ \item \code{HS} Haute-Savoie
+ \item \code{I} Isère
+ \item \code{S} Savoie}
+ }
+}
+\source{
+ Erome, G. (1989) \emph{L'ours brun dans les Alpes françaises. Historique de sa disparition}.
+ Centre Ornithologique Rhône-Alpes, Villeurbanne. 120 p.
+}
+\examples{
+data(ours)
+if(adegraphicsLoaded()) {
+ s1d.boxplot(dudi.acm(ours, scan = FALSE)$l1[, 1], ours)
+} else {
+ boxplot(dudi.acm(ours, scan = FALSE))
+}
+}
+\keyword{datasets}
diff --git a/man/palm.Rd b/man/palm.Rd
new file mode 100644
index 0000000..6720e18
--- /dev/null
+++ b/man/palm.Rd
@@ -0,0 +1,44 @@
+\name{palm}
+\alias{palm}
+\docType{data}
+\title{Phylogenetic and quantitative traits of amazonian palm trees}
+\description{
+This data set describes the phylogeny of 66 amazonian palm trees. It also gives 7 traits corresponding to these 66 species.
+}
+\usage{data(palm)}
+\format{
+\code{palm} is a list containing the 2 following objects:
+\describe{
+ \item{tre}{is a character string giving the phylogenetic tree in Newick format.}
+ \item{traits}{is a data frame with 66 species (rows) and 7 traits (columns).}
+} }
+\details{
+Variables of \code{palm$traits} are the following ones: \cr
+rord: specific richness with five ordered levels\cr
+h: height in meter (squared transform)\cr
+dqual: diameter at breast height in centimeter with five levels \code{sout : subterranean}, \code{ d1(0, 5 cm)}, \code{ d2(5, 15 cm)}, \code{ d3(15, 30 cm)} and \code{ d4(30, 100 cm)}\cr
+vfruit: fruit volume in \eqn{mm^{3}}{mm^3} (logged transform)\cr
+vgrain: seed volume in \eqn{mm^{3}}{mm^3} (logged transform)\cr
+aire: spatial distribution area (\eqn{km^{2}}{km^2})\cr
+alti: maximum altitude in meter (logged transform)\cr
+}
+\source{
+This data set was obtained by Clémentine Gimaret-Carpentier.
+}
+\examples{
+\dontrun{
+data(palm)
+palm.phy <- newick2phylog(palm$tre)
+radial.phylog(palm.phy,clabel.l=1.25)
+
+orthogram(palm$traits[,4],palm.phy$Bscores)
+dotchart.phylog(palm.phy,palm$traits[,4], clabel.l = 1,
+ labels.n = palm.phy$Blabels, clabel.n = 0.75)
+w <- cbind.data.frame(palm.phy$Bscores[,c(3,4,6,13,21)],
+ scalewt((palm$traits[,4])))
+names(w)[6] <- names(palm$traits[4])
+table.phylog(w, palm.phy, clabel.r = 0.75, f = 0.5)
+
+gearymoran(palm.phy$Amat, palm$traits[,-c(1,3)])
+}}
+\keyword{datasets}
diff --git a/man/pap.Rd b/man/pap.Rd
new file mode 100644
index 0000000..623696c
--- /dev/null
+++ b/man/pap.Rd
@@ -0,0 +1,30 @@
+\name{pap}
+\alias{pap}
+\docType{data}
+\title{Taxonomy and quantitative traits of carnivora}
+\description{
+This data set describes the taxonomy of 39 carnivora. It also gives life-history traits corresponding to these 39 species.
+}
+\usage{data(pap)}
+\format{
+\code{pap} is a list containing the 2 following objects :
+\describe{
+ \item{taxo}{is a data frame with 39 species and 3 columns.}
+ \item{tab}{is a data frame with 39 species and 4 traits.}
+ }}
+\details{
+Variables of \code{pap$tab} are the following ones : genre (genus with 30 levels),
+famille (family with 6 levels), superfamille (superfamily with 2 levels).\cr
+
+Variables of \code{pap$tab} are Group Size, Body Weight, Brain Weight, Litter Size.
+}
+\source{
+Data taken from the phylogenetic autocorrelation package
+}
+\examples{
+data(pap)
+taxo <- taxo2phylog(as.taxo(pap$taxo))
+table.phylog(as.data.frame(scalewt(pap$tab)), taxo, csi = 2, clabel.nod = 0.6,
+ f.phylog = 0.6)
+}
+\keyword{datasets}
diff --git a/man/pcaiv.Rd b/man/pcaiv.Rd
new file mode 100644
index 0000000..74dc957
--- /dev/null
+++ b/man/pcaiv.Rd
@@ -0,0 +1,147 @@
+\name{pcaiv}
+\alias{pcaiv}
+\alias{plot.pcaiv}
+\alias{print.pcaiv}
+\alias{summary.pcaiv}
+\title{Principal component analysis with respect to instrumental variables}
+\description{
+performs a principal component analysis with respect to instrumental variables.
+}
+\usage{
+pcaiv(dudi, df, scannf = TRUE, nf = 2)
+\method{plot}{pcaiv}(x, xax = 1, yax = 2, \dots)
+\method{print}{pcaiv}(x, \dots)
+\method{summary}{pcaiv}(object, \dots)
+}
+\arguments{
+ \item{dudi}{a duality diagram, object of class \code{dudi}}
+ \item{df}{a data frame with the same rows}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+ \cr
+ \item{x, object}{an object of class \code{pcaiv}}
+ \item{xax}{the column number for the x-axis}
+ \item{yax}{the column number for the y-axis}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+returns an object of class \code{pcaiv}, sub-class of class \code{dudi}
+ \item{tab}{a data frame with the modified array (projected variables)}
+ \item{cw}{a numeric vector with the column weigths (from \code{dudi})}
+ \item{lw}{a numeric vector with the row weigths (from \code{dudi})}
+ \item{eig}{a vector with the all eigenvalues}
+ \item{rank}{an integer indicating the rank of the studied matrix}
+ \item{nf}{an integer indicating the number of kept axes}
+ \item{c1}{a data frame with the Pseudo Principal Axes (PPA)}
+ \item{li}{a data frame \code{dudi$ls} with the predicted values by X}
+ \item{co}{a data frame with the inner products between the CPC and Y}
+ \item{l1}{data frame with the Constraint Principal Components (CPC)}
+ \item{call}{the matched call}
+ \item{X}{a data frame with the explanatory variables}
+ \item{Y}{a data frame with the dependant variables}
+ \item{ls}{a data frame with the projections of lines of \code{dudi$tab} on PPA}
+ \item{param}{a table containing information about contributions of the analyses : absolute (1) and cumulative (2) contributions of the decomposition of inertia of the dudi object, absolute (3) and cumulative (4) variances of the projections, the ration (5) between the cumulative variances of the projections (4) and the cumulative contributions (2), the square coefficient of correlation (6) and the eigenvalues of the pcaiv (7)}
+ \item{as}{a data frame with the Principal axes of \code{dudi$tab} on PPA}
+ \item{fa}{a data frame with the loadings (Constraint Principal Components as linear combinations of X}
+ \item{cor}{a data frame with the correlations between the CPC and X }
+}
+\references{
+Rao, C. R. (1964) The use and interpretation of principal component analysis in applied research. \emph{Sankhya}, \bold{A 26}, 329--359.\cr\cr
+Obadia, J. (1978) L'analyse en composantes explicatives. \emph{Revue de Statistique Appliquee}, \bold{24}, 5--28.\cr\cr
+Lebreton, J. D., Sabatier, R., Banco G. and Bacou A. M. (1991)
+Principal component and correspondence analyses with respect to instrumental variables :
+an overview of their role in studies of structure-activity and species- environment relationships.
+In J. Devillers and W. Karcher, editors. \emph{Applied Multivariate Analysis in SAR and Environmental Studies},
+Kluwer Academic Publishers, 85--114.
+
+Ter Braak, C. J. F. (1986) Canonical correspondence analysis : a new eigenvector technique for multivariate direct gradient analysis. \emph{Ecology}, \bold{67}, 1167--1179.\cr\cr
+Ter Braak, C. J. F. (1987) The analysis of vegetation-environment relationships by canonical correspondence analysis. \emph{Vegetatio}, \bold{69}, 69--77.\cr\cr
+Chessel, D., Lebreton J. D. and Yoccoz N. (1987) Propriétés de l'analyse canonique des correspondances. Une utilisation en hydrobiologie. \emph{Revue de Statistique Appliquée}, \bold{35}, 55--72.\cr\cr
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}\cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\examples{
+# example for the pcaiv
+data(rhone)
+pca1 <- dudi.pca(rhone$tab, scan = FALSE, nf = 3)
+iv1 <- pcaiv(pca1, rhone$disch, scan = FALSE)
+summary(iv1)
+plot(iv1)
+
+# example for the caiv
+data(rpjdl)
+millog <- log(rpjdl$mil + 1)
+coa1 <- dudi.coa(rpjdl$fau, scann = FALSE)
+caiv1 <- pcaiv(coa1, millog, scan = FALSE)
+
+if(adegraphicsLoaded()) {
+ G1 <- plot(caiv1)
+
+ # analysis with c1 - as - li -ls
+ # projections of inertia axes on PCAIV axes
+ G2 <- s.corcircle(caiv1$as)
+
+ # Species positions
+ g31 <- s.label(caiv1$c1, xax = 2, yax = 1, plab.cex = 0.5, xlim = c(-4, 4), plot = FALSE)
+ # Sites positions at the weighted mean of present species
+ g32 <- s.label(caiv1$ls, xax = 2, yax = 1, plab.cex = 0, plot = FALSE)
+ G3 <- superpose(g31, g32, plot = TRUE)
+
+ # Prediction of the positions by regression on environmental variables
+ G4 <- s.match(caiv1$ls, caiv1$li, xax = 2, yax = 1, plab.cex = 0.5)
+
+ # analysis with fa - l1 - co -cor
+ # canonical weights giving unit variance combinations
+ G5 <- s.arrow(caiv1$fa)
+
+ # sites position by environmental variables combinations
+ # position of species by averaging
+ g61 <- s.label(caiv1$l1, xax = 2, yax = 1, plab.cex = 0, ppoi.cex = 1.5, plot = FALSE)
+ g62 <- s.label(caiv1$co, xax = 2, yax = 1, plot = FALSE)
+ G6 <- superpose(g61, g62, plot = TRUE)
+
+ G7 <- s.distri(caiv1$l1, rpjdl$fau, xax = 2, yax = 1, ellipseSize = 0, starSize = 0.33)
+
+ # coherence between weights and correlations
+ g81 <- s.corcircle(caiv1$cor, xax = 2, yax = 1, plot = FALSE)
+ g82 <- s.arrow(caiv1$fa, xax = 2, yax = 1, plot = FALSE)
+ G8 <- cbindADEg(g81, g82, plot = TRUE)
+
+} else {
+ plot(caiv1)
+
+ # analysis with c1 - as - li -ls
+ # projections of inertia axes on PCAIV axes
+ s.corcircle(caiv1$as)
+
+ # Species positions
+ s.label(caiv1$c1, 2, 1, clab = 0.5, xlim = c(-4, 4))
+ # Sites positions at the weighted mean of present species
+ s.label(caiv1$ls, 2, 1, clab = 0, cpoi = 1, add.p = TRUE)
+
+ # Prediction of the positions by regression on environmental variables
+ s.match(caiv1$ls, caiv1$li, 2, 1, clab = 0.5)
+
+ # analysis with fa - l1 - co -cor
+ # canonical weights giving unit variance combinations
+ s.arrow(caiv1$fa)
+
+ # sites position by environmental variables combinations
+ # position of species by averaging
+ s.label(caiv1$l1, 2, 1, clab = 0, cpoi = 1.5)
+ s.label(caiv1$co, 2, 1, add.plot = TRUE)
+
+ s.distri(caiv1$l1, rpjdl$fau, 2, 1, cell = 0, csta = 0.33)
+ s.label(caiv1$co, 2, 1, clab = 0.75, add.plot = TRUE)
+
+ # coherence between weights and correlations
+ par(mfrow = c(1, 2))
+ s.corcircle(caiv1$cor, 2, 1)
+ s.arrow(caiv1$fa, 2, 1)
+ par(mfrow = c(1, 1))
+}
+}
+\keyword{multivariate}
diff --git a/man/pcaivortho.Rd b/man/pcaivortho.Rd
new file mode 100644
index 0000000..07665f8
--- /dev/null
+++ b/man/pcaivortho.Rd
@@ -0,0 +1,87 @@
+\name{pcaivortho}
+\alias{pcaivortho}
+\alias{summary.pcaivortho}
+\title{Principal Component Analysis with respect to orthogonal instrumental variables}
+\description{
+performs a Principal Component Analysis with respect to orthogonal instrumental variables.
+}
+\usage{
+pcaivortho(dudi, df, scannf = TRUE, nf = 2)
+\method{summary}{pcaivortho}(object, \dots)
+}
+\arguments{
+ \item{dudi}{a duality diagram, object of class \code{dudi}}
+ \item{df}{a data frame with the same rows}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+ \item{object}{an object of class \code{pcaiv}}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+an object of class 'pcaivortho' sub-class of class \code{dudi}
+ \item{rank}{an integer indicating the rank of the studied matrix}
+ \item{nf}{an integer indicating the number of kept axes}
+ \item{eig}{a vector with the all eigenvalues}
+ \item{lw}{a numeric vector with the row weigths (from \code{dudi})}
+ \item{cw}{a numeric vector with the column weigths (from \code{dudi})}
+ \item{Y}{a data frame with the dependant variables}
+ \item{X}{a data frame with the explanatory variables}
+ \item{tab}{a data frame with the modified array (projected variables)}
+ \item{c1}{a data frame with the Pseudo Principal Axes (PPA)}
+ \item{as}{a data frame with the Principal axis of \code{dudi$tab} on PAP}
+ \item{ls}{a data frame with the projection of lines of \code{dudi$tab} on PPA}
+ \item{li}{a data frame \code{dudi$ls} with the predicted values by X}
+ \item{l1}{a data frame with the Constraint Principal Components (CPC)}
+ \item{co}{a data frame with the inner product between the CPC and Y}
+ \item{param}{a data frame containing a summary}
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}\cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\references{
+Rao, C. R. (1964) The use and interpretation of principal component analysis in applied research. \emph{Sankhya}, \bold{A 26}, 329--359.\cr\cr
+Sabatier, R., Lebreton J. D. and Chessel D. (1989) Principal component analysis with instrumental variables as a tool for modelling composition data. In R. Coppi and S. Bolasco, editors. \emph{Multiway data analysis}, Elsevier Science Publishers B.V., North-Holland, 341--352
+}
+\examples{
+\dontrun{
+data(avimedi)
+cla <- avimedi$plan$reg:avimedi$plan$str
+# simple ordination
+coa1 <- dudi.coa(avimedi$fau, scan = FALSE, nf = 3)
+# within region
+w1 <- wca(coa1, avimedi$plan$reg, scan = FALSE)
+# no region the same result
+pcaivnonA <- pcaivortho(coa1, avimedi$plan$reg, scan = FALSE)
+summary(pcaivnonA)
+# region + strate
+interAplusB <- pcaiv(coa1, avimedi$plan, scan = FALSE)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.class(coa1$li, cla, psub.text = "Sans contrainte", plot = FALSE)
+ g21 <- s.match(w1$li, w1$ls, plab.cex = 0, psub.text = "Intra Région", plot = FALSE)
+ g22 <- s.class(w1$li, cla, plot = FALSE)
+ g2 <- superpose(g21, g22)
+ g31 <- s.match(pcaivnonA$li, pcaivnonA$ls, plab.cex = 0, psub.tex = "Contrainte Non A",
+ plot = FALSE)
+ g32 <- s.class(pcaivnonA$li, cla, plot = FALSE)
+ g3 <- superpose(g31, g32)
+ g41 <- s.match(interAplusB$li, interAplusB$ls, plab.cex = 0, psub.text = "Contrainte A + B",
+ plot = FALSE)
+ g42 <- s.class(interAplusB$li, cla, plot = FALSE)
+ g4 <- superpose(g41, g42)
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2, 2))
+ s.class(coa1$li, cla, sub = "Sans contrainte")
+ s.match(w1$li, w1$ls, clab = 0, sub = "Intra Région")
+ s.class(w1$li, cla, add.plot = TRUE)
+ s.match(pcaivnonA$li, pcaivnonA$ls, clab = 0, sub = "Contrainte Non A")
+ s.class(pcaivnonA$li, cla, add.plot = TRUE)
+ s.match(interAplusB$li, interAplusB$ls, clab = 0, sub = "Contrainte A + B")
+ s.class(interAplusB$li, cla, add.plot = TRUE)
+ par(mfrow = c(1,1))
+}}}
+\keyword{multivariate}
diff --git a/man/pcoscaled.Rd b/man/pcoscaled.Rd
new file mode 100644
index 0000000..bafca14
--- /dev/null
+++ b/man/pcoscaled.Rd
@@ -0,0 +1,33 @@
+\name{pcoscaled}
+\alias{pcoscaled}
+\title{Simplified Analysis in Principal Coordinates}
+\description{
+performs a simplified analysis in principal coordinates,
+using an object of class \code{dist}.
+}
+\usage{
+pcoscaled(distmat, tol = 1e-07)
+}
+\arguments{
+ \item{distmat}{an object of class \code{dist}}
+ \item{tol}{a tolerance threshold, an eigenvalue is considered as positive if it is larger than \code{-tol*lambda1} where \code{lambda1} is the largest eigenvalue}
+}
+\value{
+returns a data frame containing the Euclidean representation of the distance matrix with a total inertia equal to 1
+}
+\references{Gower, J. C. (1966) Some distance properties of latent root and vector methods used in multivariate analysis. \emph{Biometrika}, \bold{53}, 325--338.
+}
+\author{Daniel Chessel }
+\examples{
+ a <- 1 / sqrt(3) - 0.2
+ w <- matrix(c(0,0.8,0.8,a,0.8,0,0.8,a,
+ 0.8,0.8,0,a,a,a,a,0),4,4)
+ w <- as.dist(w)
+ w <- cailliez(w)
+ w
+ pcoscaled(w)
+ dist(pcoscaled(w)) # w
+ dist(pcoscaled(2 * w)) # the same
+ sum(pcoscaled(w)^2) # unity
+}
+\keyword{array}
diff --git a/man/pcw.Rd b/man/pcw.Rd
new file mode 100644
index 0000000..b74c35e
--- /dev/null
+++ b/man/pcw.Rd
@@ -0,0 +1,51 @@
+\name{pcw}
+\alias{pcw}
+\docType{data}
+\title{Distribution of of tropical trees along the Panama canal}
+\description{
+ Abundance of tropical trees, environmental variables and spatial
+ coordinates for 50 sites. Data are available at
+ \url{http://www.sciencemag.org/content/295/5555/666/suppl/DC1}
+ but plots from Barro Colorado Island were removed.
+}
+\usage{data(pcw)}
+\format{
+ A list with 5 components.
+
+ \describe{
+ \item{spe}{Distribution of the abundances of 778 species in 50 sites}
+ \item{env}{Measurements of environmental variables for the 50 sites}
+ \item{xy}{Spatial coordinates for the sites (decimal degrees)}
+ \item{xy.utm}{Spatial coordinates for the sites (UTM)}
+ \item{map}{Map of the study area stored as a SpatialPolygons object}
+ }
+}
+
+\source{
+ Condit, R., N. Pitman, E. G. Leigh, J. Chave, J. Terborgh,
+ R. B. Foster, P. Núnez, S. Aguilar, R. Valencia, G. Villa,
+ H. C. Muller-Landau, E. Losos, and S. P. Hubbell. (2002) Beta-diversity
+ in tropical forest trees. \emph{Science}, \bold{295}, 666–669.
+
+
+ Pyke, C. R., R. Condit, S. Aguilar, and S. Lao. (2001) Floristic
+ composition across a climatic gradient in a neotropical lowland
+ forest. \emph{Journal of Vegetation Science}, \bold{12}, 553--566.
+}
+\references{
+ Dray, S., R. Pélissier, P. Couteron, M. J. Fortin, P. Legendre,
+ P. R. Peres-Neto, E. Bellier, R. Bivand, F. G. Blanchet, M. De
+ Caceres, A. B. Dufour, E. Heegaard, T. Jombart, F. Munoz, J. Oksanen,
+ J. Thioulouse, and H. H. Wagner. (2012) Community ecology in the age of
+ multivariate multiscale spatial analysis. \emph{Ecological
+ Monographs}, \bold{82}, 257--275.
+}
+\examples{
+if(adegraphicsLoaded()) {
+ data(pcw)
+ if(requireNamespace("spdep", quietly = TRUE)) {
+ nb1 <- spdep::graph2nb(spdep::gabrielneigh(pcw$xy.utm), sym = TRUE)
+ s.label(pcw$xy, nb = nb1, Sp = pcw$map)
+ }
+}}
+\keyword{datasets}
diff --git a/man/perthi02.Rd b/man/perthi02.Rd
new file mode 100644
index 0000000..3e8afbd
--- /dev/null
+++ b/man/perthi02.Rd
@@ -0,0 +1,27 @@
+\name{perthi02}
+\alias{perthi02}
+\docType{data}
+\title{Contingency Table with a partition in Molecular Biology}
+\description{
+This data set gives the amino acids of 904 proteins
+distributed in three classes.
+}
+\usage{data(perthi02)}
+\format{
+ \code{perthi02} is a list of 2 components.
+ \describe{
+ \item{tab}{is a data frame 904 rows (proteins of 201 species) 20 columns (amino acids).}
+ \item{cla}{is a factor of 3 classes of protein}
+ }
+The levels of \code{perthi02$cla} are \code{cyto} (cytoplasmic proteins) \code{memb} (integral membran proteins) \code{peri} (periplasmic proteins)
+}
+\source{
+Perriere, G. and Thioulouse, J. (2002)
+Use of Correspondence Discriminant Analysis to predict the subcellular location of bacterial proteins.
+\emph{Computer Methods and Programs in Biomedicine}, \bold{70}, 2, 99--105.
+}
+\examples{
+data(perthi02)
+plot(discrimin.coa(perthi02$tab, perthi02$cla, scan = FALSE))
+}
+\keyword{datasets}
diff --git a/man/phylog.Rd b/man/phylog.Rd
new file mode 100644
index 0000000..c7fba73
--- /dev/null
+++ b/man/phylog.Rd
@@ -0,0 +1,73 @@
+\name{phylog}
+\alias{phylog}
+\alias{print.phylog}
+\alias{phylog.extract}
+\alias{phylog.permut}
+\title{Phylogeny}
+\description{
+Create and use objects of class \code{phylog}. \cr
+\code{phylog.extract} returns objects of class \code{phylog}. It extracts sub-trees from a tree. \cr
+\code{phylog.permut} returns objects of class \code{phylog}. It creates the different representations compatible with tree topology.
+}
+\usage{
+\method{print}{phylog}(x, ...)
+phylog.extract(phylog, node, distance = TRUE)
+phylog.permut(phylog, list.nodes = NULL, distance = TRUE)
+}
+\arguments{
+ \item{x, phylog}{: an object of class \code{phylog}}
+ \item{\dots}{: further arguments passed to or from other methods}
+ \item{node}{: a string of characters giving a node name. The functions extracts the tree rooted at this node.}
+ \item{distance}{: if TRUE, both functions retain branch lengths. If FALSE, they returns tree with arbitrary branch lengths (each branch length equals one)}
+ \item{list.nodes}{: a list which elements are vectors of string of character corresponding to direct descendants of nodes. This list defines one representation compatible with tree topology among the set of possibilities.}
+}
+\value{
+Returns a list of class \code{phylog} :
+ \item{tre}{: a character string of the phylogenetic tree in Newick format whithout branch length values}
+ \item{leaves}{: a vector which names corresponds to leaves and values gives the distance between leaves and nodes closest to these leaves}
+ \item{nodes}{: a vector which names corresponds to nodes and values gives the distance between nodes and nodes closest to these leaves}
+ \item{parts}{: a list which elements gives the direct descendants of each nodes}
+ \item{paths}{: a list which elements gives the path leading from the root to taxonomic units (leaves and nodes)}
+ \item{droot}{: a vector which names corresponds to taxonomic units and values gives distance between taxonomic units and the root}
+ \item{call}{: call}
+ \item{Wmat}{: a phylogenetic link matrix, generally called the covariance matrix. Matrix values \eqn{Wmat_{ij}}{Wmat_ij} correspond to path length that lead from root to the first common ancestor of the two leaves i and j}
+ \item{Wdist}{: a phylogenetic distance matrix of class \code{'dist'}. Matrix values \eqn{Wdist_{ij}}{Wdist_ij} correspond to \eqn{\sqrt{d_{ij}}} where \eqn{d_{ij}}{d_ij} is the classical distance between two leaves i and j}
+ \item{Wvalues}{: a vector with the eigen values of Wmat}
+ \item{Wscores}{: a data frame with eigen vectors of Wmat. This data frame defines an orthobasis that could be used to calculate the orthonormal decomposition of a biological trait on a tree.}
+ \item{Amat}{: a phylogenetic link matrix stemed from Abouheif's test and defined in Ollier et al. (submited)}
+ \item{Avalues}{: a vector with the eigen values of Amat}
+ \item{Adim}{: number of positive eigen values}
+ \item{Ascores}{: a data frame with eigen vectors of Amat. This data frame defines an orthobasis that could be used to calculate the orthonormal decomposition of a biological trait on a tree.}
+ \item{Aparam}{: a data frame with attributes associated to nodes.}
+ \item{Bindica}{: a data frame giving for some taxonomic units the partition of leaves that is associated to its}
+ \item{Bscores}{: a data frame giving an orthobasis defined by Ollier et al. (submited) that could be used to calculate the orthonormal decomposition of a biological trait on a tree.}
+ \item{Bvalues}{: a vector giving the degree of phylogenetic autocorrelation for each vectors of Bscores (Moran's form calculated with the matrix Wmat)}
+ \item{Blabels}{: a vector giving for each nodes the name of the vector of Bscores that is associated to its}
+}
+\references{
+Ollier, S., Couteron, P. and Chessel, D. (2006)
+Orthonormal transform to decompose the variance of a life-history trait across a phylogenetic tree.
+\emph{Biometrics} Biometrics, \bold{62}, 2, 471--477.
+}
+\author{Daniel Chessel \cr
+Sébastien Ollier \email{sebastien.ollier at u-psud.fr}
+}
+\seealso{\code{\link{newick2phylog}}, \code{\link{plot.phylog}}}
+\examples{
+marthans.tre <- NULL
+marthans.tre[1] <-"((((1:4,2:4)a:5,(3:7,4:7)b:2)c:2,5:11)d:2,"
+marthans.tre[2] <- "((6:5,7:5)e:4,(8:4,9:4)f:5)g:4);"
+marthans.phylog <- newick2phylog(marthans.tre)
+marthans.phylog
+
+if(requireNamespace("ape", quietly = TRUE)) {
+ marthans.phylo <- ape::read.tree(text = marthans.tre)
+ marthans.phylo
+
+ par(mfrow = c(1, 2))
+ plot(marthans.phylog, cnode = 3, f = 0.8, cle = 3)
+ plot(marthans.phylo)
+ par(mfrow = c(1, 1))
+}
+}
+\keyword{manip}
diff --git a/man/piosphere.Rd b/man/piosphere.Rd
new file mode 100644
index 0000000..39ae81a
--- /dev/null
+++ b/man/piosphere.Rd
@@ -0,0 +1,38 @@
+\name{piosphere}
+\alias{piosphere}
+\docType{data}
+\title{
+Plant traits response to grazing
+}
+\description{
+Plant species cover, traits and environmental parameters recorded around
+livestock watering points in different habitats of central Namibian
+farmlands. See the Wesuls et al. (2012) paper for a full description of
+the data set.
+}
+\usage{data(piosphere)}
+\format{
+ \code{piosphere} is a list of 4 components.
+ \describe{
+ \item{veg}{is a data frame containing plant species cover}
+ \item{traits}{is a data frame with plant traits}
+ \item{env}{is a data frame with environmental variables}
+ \item{habitat}{is a factor describing habitat/years for each site}
+ }
+}
+\source{
+Wesuls, D., Oldeland, J. and Dray, S. (2012) Disentangling plant trait
+responses to livestock grazing from spatio-temporal variation: the
+partial RLQ approach. \emph{Journal of Vegetation Science}, \bold{23}, 98--113.
+}
+
+\examples{
+data(piosphere)
+names(piosphere)
+afcL <- dudi.coa(log(piosphere$veg + 1), scannf = FALSE)
+acpR <- dudi.pca(piosphere$env, scannf = FALSE, row.w = afcL$lw)
+acpQ <- dudi.hillsmith(piosphere$traits, scannf = FALSE, row.w = afcL$cw)
+rlq1 <- rlq(acpR, afcL, acpQ, scannf = FALSE)
+plot(rlq1)
+}
+\keyword{datasets}
diff --git a/man/plot.between.Rd b/man/plot.between.Rd
new file mode 100644
index 0000000..5749921
--- /dev/null
+++ b/man/plot.between.Rd
@@ -0,0 +1,64 @@
+\name{between}
+\alias{summary.between}
+\alias{print.between}
+\alias{plot.between}
+\alias{print.betcoi}
+\alias{plot.betcoi}
+\title{Between-Class Analysis}
+\description{
+Outputs and graphical representations of the results of a between-class analysis.}
+\usage{
+\method{plot}{between}(x, xax = 1, yax = 2, \dots)
+\method{print}{between}(x, \dots)
+\method{plot}{betcoi}(x, xax = 1, yax = 2, \dots)
+\method{print}{betcoi}(x, \dots)
+\method{summary}{between}(object, \dots)
+}
+\arguments{
+ \item{x,object}{an object of class \code{between} or \code{betcoi}}
+ \item{xax, yax}{the column index of the x-axis and the y-axis}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+
+\references{
+Dolédec, S. and Chessel, D. (1987) Rythmes saisonniers et composantes stationnelles en milieu aquatique
+I- Description d'un plan d'observations complet par projection de variables. \emph{Acta Oecologica, Oecologia Generalis}, \bold{8}, 3, 403--426.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}\cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\seealso{\code{\link{bca.dudi}}, \code{\link{bca.coinertia}}}
+\examples{
+data(meaudret)
+
+pca1 <- dudi.pca(meaudret$env, scan = FALSE, nf = 4)
+pca2 <- dudi.pca(meaudret$spe, scal = FALSE, scan = FALSE, nf = 4)
+bet1 <- bca(pca1, meaudret$design$site, scan = FALSE, nf = 2)
+bet2 <- bca(pca2, meaudret$design$site, scan = FALSE, nf = 2)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.class(pca1$li, meaudret$design$site, psub.text = "Principal Component Analysis (env)",
+ plot = FALSE)
+ g2 <- s.class(pca2$li, meaudret$design$site, psub.text = "Principal Component Analysis (spe)",
+ plot = FALSE)
+ g3 <- s.class(bet1$ls, meaudret$design$site, psub.text = "Between sites PCA (env)",
+ plot = FALSE)
+ g4 <- s.class(bet2$ls, meaudret$design$site, psub.text = "Between sites PCA (spe)",
+ plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2, 2))
+ s.class(pca1$li, meaudret$design$site, sub = "Principal Component Analysis (env)", csub = 1.75)
+ s.class(pca2$li, meaudret$design$site, sub = "Principal Component Analysis (spe)", csub = 1.75)
+ s.class(bet1$ls, meaudret$design$site, sub = "Between sites PCA (env)", csub = 1.75)
+ s.class(bet2$ls, meaudret$design$site, sub = "Between sites PCA (spe)", csub = 1.75)
+ par(mfrow = c(1,1))
+}
+
+coib <- coinertia(bet1, bet2, scann = FALSE)
+plot(coib)
+}
+\keyword{multivariate}
diff --git a/man/plot.phylog.Rd b/man/plot.phylog.Rd
new file mode 100644
index 0000000..2ba3e23
--- /dev/null
+++ b/man/plot.phylog.Rd
@@ -0,0 +1,123 @@
+\name{plot.phylog}
+\alias{plot.phylog}
+\alias{radial.phylog}
+\alias{enum.phylog}
+\title{Plot phylogenies}
+\description{
+\code{plot.phylog} draws phylogenetic trees as linear dendograms. \cr
+\code{radial.phylog} draws phylogenetic trees as circular dendograms. \cr
+\code{enum.phylog} enumerate all the possible representations for a phylogeny.
+}
+\usage{
+\method{plot}{phylog}(x, y = NULL, f.phylog = 0.5, cleaves = 1, cnodes = 0,
+ labels.leaves = names(x$leaves), clabel.leaves = 1,
+ labels.nodes = names(x$nodes), clabel.nodes = 0, sub = "",
+ csub = 1.25, possub = "bottomleft", draw.box = FALSE, ...)
+radial.phylog(phylog, circle = 1, cleaves = 1, cnodes = 0,
+ labels.leaves = names(phylog$leaves), clabel.leaves = 1,
+ labels.nodes = names(phylog$nodes), clabel.nodes = 0,
+ draw.box = FALSE)
+enum.phylog(phylog, no.over = 1000)
+}
+\arguments{
+ \item{x, phylog}{an object of class \code{phylog}}
+ \item{y}{a vector which values correspond to leaves positions}
+ \item{f.phylog}{a size coefficient for tree size (a parameter to draw the tree in proportion to leaves label)}
+ \item{circle}{a size coefficient for the outer circle}
+ \item{cleaves}{a character size for plotting the points that represent the leaves, used with \code{par("cex")*cleaves}. If zero, no points are drawn}
+ \item{cnodes}{a character size for plotting the points that represent the nodes, used with \code{par("cex")*cnodes}. If zero, no points are drawn}
+ \item{labels.leaves}{a vector of strings of characters for the leaves labels}
+ \item{clabel.leaves}{a character size for the leaves labels, used with \code{par("cex")*clabel.leaves}. If zero, no leaves labels are drawn}
+ \item{labels.nodes}{a vector of strings of characters for the nodes labels}
+ \item{clabel.nodes}{a character size for the nodes labels, used with \code{par("cex")*clabel.nodes}. If zero, no nodes labels are drawn}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{draw.box}{if TRUE draws a box around the current plot with the function \code{box()}}
+ \item{\dots}{further arguments passed to or from other methods}
+ \item{no.over}{a size coefficient for the number of representations}
+}
+\details{
+The vector y is an argument of the function \code{plot.phylog} that ensures to plot one of the possible representations of a phylogeny.
+The vector y is a permutation of the set of leaves \{1,2,\dots,f\} compatible with the phylogeny's topology.
+}
+\value{
+The function \code{enum.phylog} returns a matrix with as many columns as leaves. Each row gives a permutation of the set of leaves \{1,2,\dots,f\} compatible with the phylogeny's topology.
+}
+\author{Daniel Chessel \cr
+Sébastien Ollier \email{sebastien.ollier at u-psud.fr}
+}
+\seealso{\code{\link{phylog}}}
+\examples{
+data(newick.eg)
+par(mfrow = c(3,2))
+for(i in 1:6) plot(newick2phylog(newick.eg[[i]], FALSE),
+ clea = 2, clabel.l = 3, cnod = 2.5)
+par(mfrow = c(1,1))
+
+\dontrun{
+par(mfrow = c(1,2))
+plot(newick2phylog(newick.eg[[11]], FALSE), clea = 1.5,
+ clabel.l = 1.5, clabel.nod = 0.75, f = 0.8)
+plot(newick2phylog(newick.eg[[10]], FALSE), clabel.l = 0,
+ clea = 0, cn = 0, f = 1)
+par(mfrow = c(1,1))
+}
+
+par(mfrow = c(2,2))
+w7 <- newick2phylog("(((((1,2,3)b),(6)c),(4,5)d,7)f);")
+plot(w7,clabel.l = 1.5, clabel.n = 1.5, f = 0.8, cle = 2,
+ cnod = 3, sub = "(((((1,2,3)b),(6)c),(4,5)d,7)f);", csub = 2)
+w <- NULL
+w[1] <- "((((e1:4,e2:4)a:5,(e3:7,e4:7)b:2)c:2,e5:11)d:2,"
+w[2] <- "((e6:5,e7:5)e:4,(e8:4,e9:4)f:5)g:4);"
+plot(newick2phylog(w), f = 0.8, cnod = 2, cleav = 2, clabel.l = 2)
+
+data(taxo.eg)
+w <- taxo2phylog(as.taxo(taxo.eg[[1]]))
+plot(w, clabel.lea = 1.25, clabel.n = 1.25, sub = "Taxonomy",
+ csub = 3, f = 0.8, possub = "topleft")
+
+provi.tre <- "(((a,b,c,d,e)A,(f,g,h)B)C)D;"
+provi.phy <- newick2phylog(provi.tre)
+plot(provi.phy, clabel.l = 2, clabel.n = 2, f = 0.8)
+par(mfrow = c(1,1))
+
+\dontrun{
+par(mfrow = c(3,3))
+for (j in 1:6) radial.phylog(newick2phylog(newick.eg[[j]],
+ FALSE), clabel.l = 2, cnodes = 2)
+radial.phylog(newick2phylog(newick.eg[[7]],FALSE), clabel.l = 2)
+radial.phylog(newick2phylog(newick.eg[[8]],FALSE), clabel.l = 0,
+ circle = 1.8)
+radial.phylog(newick2phylog(newick.eg[[9]],FALSE), clabel.l = 1,
+ clabel.n = 1, cle = 0, cnode = 1)
+par(mfrow = c(1,1))
+
+data(bsetal97)
+bsetal.phy = taxo2phylog(as.taxo(bsetal97$taxo[,1:3]), FALSE)
+radial.phylog(bsetal.phy, cnod = 1, clea = 1, clabel.l = 0.75,
+ draw.box = TRUE, cir = 1.1)
+par(mfrow = c(1,1))
+}
+
+\dontrun{
+# plot all the possible representations of a phylogenetic tree
+a <- "((a,b)A,(c,d,(e,f)B)C)D;"
+wa <- newick2phylog(a)
+wx <- enum.phylog(wa)
+dim(wx)
+
+par(mfrow = c(6,8))
+fun <- function(x) {
+ w <-NULL
+ lapply(x, function(y) w<<-paste(w,as.character(y),sep=""))
+ plot(wa, x, clabel.n = 1.25, f = 0.75, clabel.l = 2,
+ box = FALSE, cle = 1.5, sub = w, csub = 2)
+ invisible()}
+apply(wx,1,fun)
+par(mfrow = c(1,1))
+}
+
+}
+\keyword{hplot}
diff --git a/man/plot.within.Rd b/man/plot.within.Rd
new file mode 100644
index 0000000..23f2b4f
--- /dev/null
+++ b/man/plot.within.Rd
@@ -0,0 +1,60 @@
+\name{within}
+\alias{print.within}
+\alias{summary.within}
+\alias{plot.within}
+\alias{plot.witcoi}
+\alias{print.witcoi}
+\title{Within-Class Analysis}
+\description{
+Outputs and graphical representations of the results of a within-class analysis.
+}
+\usage{
+\method{plot}{within}(x, xax = 1, yax = 2, \dots)
+\method{print}{within}(x, \dots)
+\method{plot}{witcoi}(x, xax = 1, yax = 2, \dots)
+\method{print}{witcoi}(x, \dots)
+\method{summary}{within}(object, \dots)
+}
+\arguments{
+ \item{x,object}{an object of class \code{within} or \code{witcoi}}
+ \item{xax}{the column index for the x-axis}
+ \item{yax}{the column index for the y-axis}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+
+\references{
+Benzécri, J. P. (1983) Analyse de l'inertie intra-classe par l'analyse d'un tableau de correspondances. \emph{Les Cahiers de l'Analyse des données}, \bold{8}, 351--358.\cr\cr
+Dolédec, S. and Chessel, D. (1987) Rythmes saisonniers et composantes stationnelles en milieu aquatique I- Description d'un plan d'observations complet par projection de variables. \emph{Acta Oecologica, Oecologia Generalis}, \bold{8}, 3, 403--426.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}\cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\seealso{\code{\link{wca.dudi}}, \code{\link{wca.coinertia}}}
+\examples{
+data(meaudret)
+pca1 <- dudi.pca(meaudret$env, scan = FALSE, nf = 4)
+wit1 <- wca(pca1, meaudret$design$site, scan = FALSE, nf = 2)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.traject(pca1$li, meaudret$design$site, psub.text = "Principal Component Analysis",
+ plines.lty = 1:length(levels(meaudret$design$site)), plot = FALSE)
+ g2 <- s.traject(wit1$li, meaudret$design$site, psub.text =
+ "Within site Principal Component Analysis",
+ plines.lty = 1:length(levels(meaudret$design$site)), plot = FALSE)
+ g3 <- s.corcircle (wit1$as, plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2, 2))
+ s.traject(pca1$li, meaudret$design$site, sub = "Principal Component Analysis", csub = 1.5)
+ s.traject(wit1$li, meaudret$design$site, sub = "Within site Principal Component Analysis",
+ csub = 1.5)
+ s.corcircle (wit1$as)
+ par(mfrow = c(1, 1))
+}
+
+plot(wit1)
+}
+\keyword{multivariate}
diff --git a/man/presid2002.Rd b/man/presid2002.Rd
new file mode 100644
index 0000000..058b09e
--- /dev/null
+++ b/man/presid2002.Rd
@@ -0,0 +1,72 @@
+\name{presid2002}
+\alias{presid2002}
+\docType{data}
+\title{Results of the French presidential elections of 2002}
+\description{
+ \code{presid2002} is a list of two data frames \code{tour1} and \code{tour2} with 93 rows (93 departments from continental Metropolitan France) and,
+ 4 and 12 variables respectively .
+}
+\usage{data(presid2002)}
+\format{
+ \code{tour1} contains the following arguments:\cr
+ the number of registered voters (\code{inscrits}); the number of abstentions (\code{abstentions});
+ the number of voters (\code{votants}); the number of expressed votes (\code{exprimes}) and,
+ the numbers of votes for each candidate: \code{Megret}, \code{Lepage}, \code{Gluksten}, \code{Bayrou},
+ \code{Chirac}, \code{Le_Pen}, \code{Taubira}, \code{Saint.josse}, \code{Mamere}, \code{Jospin}, \code{Boutin},
+ \code{Hue}, \code{Chevenement}, \code{Madelin}, \code{Besancenot}.\cr\cr
+ \code{tour2} contains the following arguments:\cr
+ the number of registered voters (\code{inscrits}); the number of abstentions (\code{abstentions});
+ the number of voters (\code{votants}); the number of expressed votes (\code{exprimes}) and,
+ the numbers of votes for each candidate: \code{Chirac} and \code{Le_Pen}.
+}
+\source{
+Site of the ministry of the Interior, of the Internal Security and of the local liberties\cr
+\url{http://www.interieur.gouv.fr/Elections/Les-resultats/Presidentielles/elecresult__presidentielle_2002/}
+}
+\seealso{
+This dataset is compatible with \code{elec88} and \code{cnc2003}}
+\examples{
+data(presid2002)
+all((presid2002$tour2$Chirac + presid2002$tour2$Le_Pen) == presid2002$tour2$exprimes)
+
+\dontrun{
+data(elec88)
+data(cnc2003)
+w0 <- ade4:::area.util.class(elec88$area, cnc2003$reg)
+w1 <- scale(elec88$tab$Chirac)
+w2 <- scale(presid2002$tour1$Chirac / presid2002$tour1$exprimes)
+w3 <- scale(elec88$tab$Mitterand)
+w4 <- scale(presid2002$tour2$Chirac / presid2002$tour2$exprimes)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.value(elec88$xy, w1, Sp = elec88$Spatial, pSp.col = "white", pgrid.draw = FALSE,
+ psub.text = "Chirac 1988 T1", plot = FALSE)
+ g2 <- s.value(elec88$xy, w2, Sp = elec88$Spatial, pSp.col = "white", pgrid.draw = FALSE,
+ psub.text = "Chirac 2002 T1", plot = FALSE)
+ g3 <- s.value(elec88$xy, w3, Sp = elec88$Spatial, pSp.col = "white", pgrid.draw = FALSE,
+ psub.text = "Mitterand 1988 T1", plot = FALSE)
+ g4 <- s.value(elec88$xy, w4, Sp = elec88$Spatial, pSp.col = "white", pgrid.draw = FALSE,
+ psub.text = "Chirac 2002 T2", plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2, 2))
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+
+ area.plot(w0)
+ s.value(elec88$xy, w1, add.plot = TRUE)
+ scatterutil.sub("Chirac 1988 T1", csub = 2, "topleft")
+
+ area.plot(w0)
+ s.value(elec88$xy, w2, add.plot = TRUE)
+ scatterutil.sub("Chirac 2002 T1", csub = 2, "topleft")
+
+ area.plot(w0)
+ s.value(elec88$xy, w3, add.plot = TRUE)
+ scatterutil.sub("Mitterand 1988 T1", csub = 2, "topleft")
+
+ area.plot(w0)
+ s.value(elec88$xy, w4, add.plot = TRUE)
+ scatterutil.sub("Chirac 2002 T2", csub = 2, "topleft")
+}}}
+\keyword{datasets}
diff --git a/man/procella.Rd b/man/procella.Rd
new file mode 100644
index 0000000..7b4a4d0
--- /dev/null
+++ b/man/procella.Rd
@@ -0,0 +1,45 @@
+\name{procella}
+\alias{procella}
+\docType{data}
+\title{Phylogeny and quantitative traits of birds}
+\description{
+This data set describes the phylogeny of 19 birds as reported by Bried et al. (2002). It also gives 6 traits corresponding to these 19 species.
+}
+\usage{data(procella)}
+\format{
+\code{procella} is a list containing the 2 following objects:
+\describe{
+ \item{tre}{is a character string giving the phylogenetic tree in Newick format.}
+ \item{traits}{is a data frame with 19 species and 6 traits}
+}}
+\details{
+Variables of \code{procella$traits} are the following ones: \cr
+site.fid: a numeric vector that describes the percentage of site fidelity\cr
+mate.fid: a numeric vector that describes the percentage of mate fidelity\cr
+mass: an integer vector that describes the adult body weight (g)\cr
+ALE: a numeric vector that describes the adult life expectancy (years)\cr
+BF: a numeric vector that describes the breeding frequencies\cr
+col.size: an integer vector that describes the colony size (no nests monitored)
+}
+\references{
+Bried, J., Pontier, D. and Jouventin, P. (2002) Mate fidelity in monogamus birds: a re-examination of the Procellariiformes.
+\emph{Animal Behaviour}, \bold{65}, 235--246.
+
+See a data description at \url{http://pbil.univ-lyon1.fr/R/pdf/pps037.pdf} (in French).
+}
+\examples{
+data(procella)
+pro.phy <- newick2phylog(procella$tre)
+plot(pro.phy,clabel.n = 1, clabel.l = 1)
+wt <- procella$traits
+wt$site.fid[is.na(wt$site.fid)] <- mean(wt$site.fid[!is.na(wt$site.fid)])
+wt$site.fid <- asin(sqrt(wt$site.fid/100))
+wt$ALE[is.na(wt$ALE)] <- mean(wt$ALE[!is.na(wt$ALE)])
+wt$ALE <- sqrt(wt$ALE)
+wt$BF[is.na(wt$BF)] <- mean(wt$BF[!is.na(wt$BF)])
+wt$mass <- log(wt$mass)
+wt <- wt[, -6]
+table.phylog(scalewt(wt), pro.phy, csi = 2)
+gearymoran(pro.phy$Amat,wt,9999)
+}
+\keyword{datasets}
diff --git a/man/procuste.Rd b/man/procuste.Rd
new file mode 100644
index 0000000..8decb10
--- /dev/null
+++ b/man/procuste.Rd
@@ -0,0 +1,105 @@
+\name{procuste}
+\alias{procuste}
+\alias{plot.procuste}
+\alias{print.procuste}
+\alias{randtest.procuste}
+\title{Simple Procruste Rotation between two sets of points}
+\description{
+performs a simple procruste rotation between two sets of points.
+}
+\usage{
+procuste(dfX, dfY, scale = TRUE, nf = 4, tol = 1e-07)
+\method{plot}{procuste}(x, xax = 1, yax = 2, \dots)
+\method{print}{procuste}(x, \dots)
+\method{randtest}{procuste}(xtest, nrepet = 999, \dots)
+}
+\arguments{
+ \item{dfX, dfY}{two data frames with the same rows}
+ \item{scale}{a logical value indicating whether a transformation by the Gower's scaling (1971) should be applied}
+ \item{nf}{an integer indicating the number of kept axes}
+ \item{tol}{a tolerance threshold to test whether the distance matrix is Euclidean : an eigenvalue is considered positive if it is larger than \code{-tol*lambda1} where \code{lambda1} is the largest eigenvalue.}
+ \cr
+ \item{x, xtest}{an objet of class \code{procuste}}
+ \item{xax}{the column number for the x-axis}
+ \item{yax}{the column number for the y-axis}
+ \item{nrepet}{the number of repetitions to perform the randomization test}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+returns a list of the class \code{procuste} with 9 components
+ \item{d}{a numeric vector of the singular values}
+ \item{rank}{an integer indicating the rank of the crossed matrix}
+ \item{nf}{an integer indicating the number of kept axes}
+ \item{tabX}{a data frame with the array X, possibly scaled}
+ \item{tabY}{a data frame with the array Y, possibly scaled}
+ \item{rotX}{a data frame with the result of the rotation from array X to array Y}
+ \item{rotY}{a data frame with the result of the rotation from array Y to array X}
+ \item{loadX}{a data frame with the loadings of array X}
+ \item{loadY}{a data frame with the loadings of array Y}
+ \item{scorX}{a data frame with the scores of array X}
+ \item{scorY}{a data frame with the scores of array Y}
+ \item{call}{a call order of the analysis}
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\references{
+Digby, P. G. N. and Kempton, R. A. (1987) Multivariate Analysis of Ecological Communities. \emph{Population and Community Biology Series}, Chapman and Hall, London.\cr\cr
+Gower, J.C. (1971) Statistical methods of comparing different multivariate analyses of the same data. In \emph{Mathematics in the archaeological and historical sciences}, Hodson, F.R, Kendall, D.G. & Tautu, P. (Eds.) University Press, Edinburgh, 138--149.\cr\cr
+Schönemann, P.H. (1968) On two-sided Procustes problems. \emph{Psychometrika}, \bold{33}, 19--34.\cr\cr
+Torre, F. and Chessel, D. (1994) Co-structure de deux tableaux totalement appariés. \emph{Revue de Statistique Appliquée}, \bold{43}, 109--121.\cr\cr
+Dray, S., Chessel, D. and Thioulouse, J. (2003) Procustean co-inertia analysis for the linking of multivariate datasets. \emph{Ecoscience}, \bold{10}, 1, 110-119.
+}
+\examples{
+data(macaca)
+pro1 <- procuste(macaca$xy1, macaca$xy2, scal = FALSE)
+pro2 <- procuste(macaca$xy1, macaca$xy2)
+if(adegraphicsLoaded()) {
+ g1 <- s.match(pro1$tabX, pro1$rotY, plab.cex = 0.7, plot = FALSE)
+ g2 <- s.match(pro1$tabY, pro1$rotX, plab.cex = 0.7, plot = FALSE)
+ g3 <- s.match(pro2$tabX, pro2$rotY, plab.cex = 0.7, plot = FALSE)
+ g4 <- s.match(pro2$tabY, pro2$rotX, plab.cex = 0.7, plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+} else {
+ par(mfrow = c(2, 2))
+ s.match(pro1$tabX, pro1$rotY, clab = 0.7)
+ s.match(pro1$tabY, pro1$rotX, clab = 0.7)
+ s.match(pro2$tabX, pro2$rotY, clab = 0.7)
+ s.match(pro2$tabY, pro2$rotX, clab = 0.7)
+ par(mfrow = c(1,1))
+}
+
+data(doubs)
+pca1 <- dudi.pca(doubs$env, scal = TRUE, scann = FALSE)
+pca2 <- dudi.pca(doubs$fish, scal = FALSE, scann = FALSE)
+pro3 <- procuste(pca1$tab, pca2$tab, nf = 2)
+if(adegraphicsLoaded()) {
+ g11 <- s.traject(pro3$scorX, plab.cex = 0, plot = FALSE)
+ g12 <- s.label(pro3$scorX, plab.cex = 0.8, plot = FALSE)
+ g1 <- superpose(g11, g12)
+ g21 <- s.traject(pro3$scorY, plab.cex = 0, plot = FALSE)
+ g22 <- s.label(pro3$scorY, plab.cex = 0.8, plot = FALSE)
+ g2 <- superpose(g21, g22)
+ g3 <- s.arrow(pro3$loadX, plab.cex = 0.75, plot = FALSE)
+ g4 <- s.arrow(pro3$loadY, plab.cex = 0.75, plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2, 2))
+ s.traject(pro3$scorX, clab = 0)
+ s.label(pro3$scorX, clab = 0.8, add.p = TRUE)
+ s.traject(pro3$scorY, clab = 0)
+ s.label(pro3$scorY, clab = 0.8, add.p = TRUE)
+ s.arrow(pro3$loadX, clab = 0.75)
+ s.arrow(pro3$loadY, clab = 0.75)
+ par(mfrow = c(1, 1))
+}
+
+plot(pro3)
+randtest(pro3)
+
+data(fruits)
+plot(procuste(scalewt(fruits$jug), scalewt(fruits$var)))
+}
+\keyword{multivariate}
diff --git a/man/procuste.randtest.Rd b/man/procuste.randtest.Rd
new file mode 100644
index 0000000..a94c057
--- /dev/null
+++ b/man/procuste.randtest.Rd
@@ -0,0 +1,34 @@
+\name{procuste.randtest}
+\alias{procuste.randtest}
+\title{
+ Monte-Carlo Test on the sum of the singular values of a procustean rotation (in C).
+}
+\description{
+performs a Monte-Carlo Test on the sum of the singular values of a procustean rotation.
+}
+\usage{
+procuste.randtest(df1, df2, nrepet = 999, ...)
+}
+\arguments{
+ \item{df1}{a data frame}
+ \item{df2}{a data frame}
+ \item{nrepet}{the number of permutations}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+returns a list of class \code{randtest}
+}
+\references{
+Jackson, D.A. (1995) PROTEST: a PROcustean randomization TEST of community environment concordance. \emph{Ecosciences}, \bold{2}, 297--303.
+}
+\author{Jean Thioulouse \email{Jean.Thioulouse at univ-lyon1.fr}}
+\examples{
+data(doubs)
+pca1 <- dudi.pca(doubs$env, scal = TRUE, scann = FALSE)
+pca2 <- dudi.pca(doubs$fish, scal = FALSE, scann = FALSE)
+protest1 <- procuste.randtest(pca1$tab, pca2$tab, 999)
+protest1
+plot(protest1,main="PROTEST")
+}
+\keyword{multivariate}
+\keyword{nonparametric}
diff --git a/man/procuste.rtest.Rd b/man/procuste.rtest.Rd
new file mode 100644
index 0000000..d8ad600
--- /dev/null
+++ b/man/procuste.rtest.Rd
@@ -0,0 +1,38 @@
+\name{procuste.rtest}
+\alias{procuste.rtest}
+\title{
+ Monte-Carlo Test on the sum of the singular values of a procustean rotation (in R).
+}
+\description{
+performs a Monte-Carlo Test on the sum of the singular values of a procustean rotation.
+}
+\usage{
+procuste.rtest(df1, df2, nrepet = 99, ...)
+}
+\arguments{
+ \item{df1}{a data frame}
+ \item{df2}{a data frame}
+ \item{nrepet}{the number of permutations}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+returns a list of class \code{rtest}
+}
+\references{
+Jackson, D.A. (1995) PROTEST: a PROcustean randomization TEST of community environment concordance. \emph{Ecosciences}, \bold{2}, 297--303.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(doubs)
+pca1 <- dudi.pca(doubs$env, scal = TRUE, scann = FALSE)
+pca2 <- dudi.pca(doubs$fish, scal = FALSE, scann = FALSE)
+proc1 <- procuste(pca1$tab, pca2$tab)
+protest1 <- procuste.rtest(pca1$tab, pca2$tab, 999)
+protest1
+plot(protest1)
+}
+\keyword{multivariate}
+\keyword{nonparametric}
diff --git a/man/pta.Rd b/man/pta.Rd
new file mode 100644
index 0000000..d895954
--- /dev/null
+++ b/man/pta.Rd
@@ -0,0 +1,68 @@
+\name{pta}
+\alias{pta}
+\alias{print.pta}
+\alias{plot.pta}
+\title{Partial Triadic Analysis of a K-tables}
+\description{
+performs a partial triadic analysis of a K-tables,
+using an object of class \code{ktab}.
+}
+\usage{
+pta(X, scannf = TRUE, nf = 2)
+\method{plot}{pta}(x, xax = 1, yax = 2, option = 1:4, \dots)
+\method{print}{pta}(x, \dots)
+}
+\arguments{
+ \item{X}{an object of class \code{ktab} where the arrays have 1) the same dimensions 2) the same names for columns 3) the same column weightings}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+
+ \item{x}{an object of class 'pta'}
+ \item{xax, yax}{the numbers of the x-axis and the y-axis}
+ \item{option}{an integer between 1 and 4, otherwise the 4 components of the plot are displayed}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+returns a list of class 'pta', sub-class of 'dudi' containing :
+ \item{RV}{a matrix with the all RV coefficients}
+ \item{RV.eig}{a numeric vector with the all eigenvalues (interstructure)}
+ \item{RV.coo}{a data frame with the scores of the arrays}
+ \item{tab.names}{a vector of characters with the array names}
+ \item{nf}{an integer indicating the number of kept axes}
+ \item{rank}{an integer indicating the rank of the studied matrix}
+ \item{tabw}{a numeric vector with the array weights}
+ \item{cw}{a numeric vector with the column weights}
+ \item{lw}{a numeric vector with the row weights}
+ \item{eig}{a numeric vector with the all eigenvalues (compromis)}
+ \item{cos2}{a numeric vector with the \eqn{\cos^2}{cos²} between compromise and arrays}
+ \item{tab}{a data frame with the modified array}
+ \item{li}{a data frame with the row coordinates}
+ \item{l1}{a data frame with the row normed scores}
+ \item{co}{a data frame with the column coordinates}
+ \item{c1}{a data frame with the column normed scores}
+ \item{Tli}{a data frame with the row coordinates (each table)}
+ \item{Tco}{a data frame with the column coordinates (each table)}
+ \item{Tcomp}{a data frame with the principal components (each table)}
+ \item{Tax}{a data frame with the principal axes (each table)}
+ \item{TL}{a data frame with the factors for Tli}
+ \item{TC}{a data frame with the factors for Tco}
+ \item{T4}{a data frame with the factors for Tax and Tcomp}
+}
+\references{
+Blanc, L., Chessel, D. and Dolédec, S. (1998) Etude de la stabilité temporelle des structures spatiales par Analyse d'une série de tableaux faunistiques totalement appariés. \emph{Bulletin Français de la Pêche et de la Pisciculture}, \bold{348}, 1--21.\cr\cr
+Thioulouse, J., and D. Chessel. 1987. Les analyses multi-tableaux en écologie factorielle. I De la typologie d'état à la typologie de fonctionnement par l'analyse triadique. \emph{Acta Oecologica, Oecologia Generalis}, \bold{8}, 463--480.
+}
+\author{
+Pierre Bady \email{pierre.bady at univ-lyon1.fr}\cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(meaudret)
+wit1 <- withinpca(meaudret$env, meaudret$design$season, scan = FALSE, scal = "partial")
+kta1 <- ktab.within(wit1, colnames = rep(c("S1", "S2", "S3", "S4", "S5"), 4))
+kta2 <- t(kta1)
+pta1 <- pta(kta2, scann = FALSE)
+pta1
+plot(pta1)
+}
+\keyword{multivariate}
diff --git a/man/quasieuclid.Rd b/man/quasieuclid.Rd
new file mode 100644
index 0000000..4928049
--- /dev/null
+++ b/man/quasieuclid.Rd
@@ -0,0 +1,34 @@
+\name{quasieuclid}
+\alias{quasieuclid}
+\title{Transformation of a distance matrice to a Euclidean one}
+\description{
+transforms a distance matrix in a Euclidean one.
+}
+\usage{
+quasieuclid(distmat)
+}
+\arguments{
+ \item{distmat}{an object of class \code{dist}}
+}
+\details{
+ The function creates a distance matrice with the positive eigenvalues of the Euclidean representation. \cr
+ Only for Euclidean distances which are not Euclidean for numeric approximations (for examples, in papers as the following example).
+}
+\value{
+object of class \code{dist} containing a Euclidean distance matrice
+}
+\author{
+Daniel Chessel \cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+\examples{
+data(yanomama)
+geo <- as.dist(yanomama$geo)
+is.euclid(geo) # FALSE
+geo1 <- quasieuclid(geo)
+is.euclid(geo1) # TRUE
+par(mfrow = c(2,2))
+lapply(yanomama, function(x) plot(as.dist(x), quasieuclid(as.dist(x))))
+
+par(mfrow = c(1,1))}
+\keyword{array}
diff --git a/man/randEH.Rd b/man/randEH.Rd
new file mode 100644
index 0000000..1c76a85
--- /dev/null
+++ b/man/randEH.Rd
@@ -0,0 +1,54 @@
+\name{randEH}
+\alias{randEH}
+\title{Nee and May's random process
+}
+\description{
+When branch lengths in an ultrametric phylogenetic tree are expressed as divergence times, the total sum of branch
+lengths in that tree expresses the amount of evolutionary history. The function \code{randEH}
+calculates the amount of evolutionary history preserved when \emph{k} random species out of \emph{n}
+original species are saved.
+}
+\usage{
+randEH(phyl, nbofsp, nbrep = 10)
+}
+\arguments{
+ \item{phyl}{an object of class phylog}
+ \item{nbofsp}{an integer indicating the number of species saved (k).}
+ \item{nbrep}{an integer indicating the number of random sampling.}
+}
+\value{
+Returns a numeric vector
+}
+\references{
+Nee, S. and May, R.M. (1997) Extinction and the loss of evolutionary history. \emph{Science}
+\bold{278}, 692--694.
+
+Pavoine, S., Ollier, S. and Dufour, A.-B. (2005)
+Is the originality of a species measurable?
+\emph{Ecology Letters}, \bold{8}, 579--586.
+}
+\author{
+Sandrine Pavoine \email{pavoine at mnhn.fr}
+}
+\seealso{\code{\link{optimEH}}
+}
+\examples{
+data(carni70)
+carni70.phy <- newick2phylog(carni70$tre)
+mean(randEH(carni70.phy, nbofsp = 7, nbrep = 1000))
+
+\dontrun{
+# the folowing instructions can last about 2 minutes.
+data(carni70)
+carni70.phy <- newick2phylog(carni70$tre)
+percent <- c(0,0.04,0.07,seq(0.1,1,by=0.1))
+pres <- round(percent*70)
+topt <- sapply(pres, function(i) optimEH(carni70.phy, nbofsp = i, give = FALSE))
+topt <- topt / EH(carni70.phy)
+tsam <- sapply(pres, function(i) mean(randEH(carni70.phy, nbofsp = i, nbrep = 1000)))
+tsam <- tsam / EH(carni70.phy)
+plot(pres, topt, xlab = "nb of species saved", ylab = "Evolutionary history saved", type = "l")
+lines(pres, tsam)
+}
+}
+\keyword{multivariate}
diff --git a/man/randboot.Rd b/man/randboot.Rd
new file mode 100644
index 0000000..ce5138e
--- /dev/null
+++ b/man/randboot.Rd
@@ -0,0 +1,51 @@
+\name{randboot}
+\alias{as.krandboot}
+\alias{print.krandboot}
+\alias{as.randboot}
+\alias{print.randboot}
+\alias{randboot}
+\title{Bootstrap simulations}
+\description{Functions and classes to manage outputs of bootstrap
+ simulations for one (class \code{randboot}) or several (class \code{krandboot}) statistics}
+\usage{
+as.krandboot(obs, boot, quantiles = c(0.025, 0.975), names =
+colnames(boot), call = match.call())
+\method{print}{krandboot}(x, ...)
+as.randboot(obs, boot, quantiles = c(0.025, 0.975), call = match.call())
+\method{print}{randboot}(x, ...)
+randboot(object, ...)
+}
+
+\arguments{
+ \item{obs}{a value (class \code{randboot}) or a vector (class
+ \code{krandboot}) with observed statistics}
+ \item{boot}{a vector (class \code{randboot}) or a matrix (class
+ \code{krandboot}) with the bootstrap values of the statistics}
+ \item{quantiles}{a vector indicating the lower and upper quantiles to compute}
+ \item{names}{a vector of names for the statistics}
+ \item{call}{the matching call}
+ \item{x}{an object of class \code{randboot} or \code{krandboot}}
+ \item{object}{an object on which bootstrap should be perform}
+ \item{\dots}{other arguments to be passed to methods}
+}
+
+\value{an object of class \code{randboot} or \code{krandboot}}
+
+\references{Carpenter, J. \& Bithell, J. (2000) Bootstrap confidence
+ intervals: when, which, what? A practical guide for medical
+ statisticians.\emph{Statistics in medicine}, 19, 1141-1164}
+
+\author{Stéphane Dray (\email{stephane.dray at univ-lyon1.fr})}
+
+\seealso{\code{\link{randboot.multiblock}}}
+\examples{
+## an example corresponding to 10 statistics and 100 repetitions
+bt <- as.krandboot(obs = rnorm(10), boot = matrix(rnorm(1000), nrow = 100))
+bt
+if(adegraphicsLoaded())
+plot(bt)
+
+}
+
+\keyword{htest}
+
diff --git a/man/randboot.multiblock.Rd b/man/randboot.multiblock.Rd
new file mode 100644
index 0000000..8afb6f1
--- /dev/null
+++ b/man/randboot.multiblock.Rd
@@ -0,0 +1,41 @@
+\name{randboot.multiblock}
+\alias{randboot.multiblock}
+\title{Bootstraped simulations for multiblock methods}
+\description{Function to perform bootstraped simulations for multiblock
+ principal component analysis with instrumental variables or multiblock
+ partial least squares, in order to get confidence intervals for some parameters, \emph{i.e.}, regression coefficients, variable and block importances}
+\usage{
+\method{randboot}{multiblock}(object, nrepet = 199, optdim, ...)
+}
+
+\arguments{
+ \item{object}{an object of class multiblock created by \code{\link{mbpls}}
+ or \code{\link{mbpcaiv}}}
+ \item{nrepet}{integer indicating the number of repetitions}
+ \item{optdim}{integer indicating the optimal number of dimensions, \emph{i.e.}, the optimal number of global components to be introduced in the model}
+ \item{\dots}{other arguments to be passed to methods}
+}
+
+\value{A list containing objects of class \code{krandboot}}
+
+\references{Carpenter, J. and Bithell, J. (2000) Bootstrap confidence intervals: when, which, what? A practical guide for medical statisticians.\emph{Statistics in medicine}, 19, 1141-1164}
+\author{Stéphanie Bougeard (\email{stephanie.bougeard at anses.fr}) and Stéphane Dray (\email{stephane.dray at univ-lyon1.fr})}
+
+\seealso{\code{\link{mbpcaiv}}, \code{\link{mbpls}},
+ \code{\link{testdim.multiblock}}, \code{\link{as.krandboot}}}
+\examples{
+data(chickenk)
+Mortality <- chickenk[[1]]
+dudiY.chick <- dudi.pca(Mortality, center = TRUE, scale = TRUE, scannf =
+FALSE)
+ktabX.chick <- ktab.list.df(chickenk[2:5])
+resmbpcaiv.chick <- mbpcaiv(dudiY.chick, ktabX.chick, scale = TRUE,
+option = "uniform", scannf = FALSE, nf = 4)
+## nrepet should be higher for a real analysis
+test <- randboot(resmbpcaiv.chick, optdim = 4, nrepet = 10)
+test
+if(adegraphicsLoaded())
+plot(test$bipc)
+}
+
+\keyword{multivariate}
diff --git a/man/randtest.Rd b/man/randtest.Rd
new file mode 100644
index 0000000..60fbc36
--- /dev/null
+++ b/man/randtest.Rd
@@ -0,0 +1,59 @@
+\name{randtest}
+\alias{randtest}
+\alias{as.randtest}
+\alias{plot.randtest}
+\alias{print.randtest}
+\title{Class of the Permutation Tests (in C).}
+\description{
+randtest is a generic function. It proposes methods for the following objects \code{between}, \code{discrimin}, \code{coinertia} \code{\dots}\cr
+}
+\usage{
+ randtest(xtest, \dots)
+ \method{plot}{randtest}(x, nclass = 10, coeff = 1, \dots)
+ as.randtest (sim, obs,alter=c("greater", "less", "two-sided"),
+ output = c("light", "full"), call = match.call())
+ \method{print}{randtest}(x, \dots)
+}
+\arguments{
+\item{xtest}{an object used to select a method}
+\item{x}{an object of class \code{randtest}}
+\item{\dots}{\code{\dots} further arguments passed to or from other methods; in \code{plot.randtest} to \code{hist}}
+\item{output}{a character string specifying if all simulations should be stored (\code{"full"}). This was the default until \code{ade4} 1.7-5. Now, by default (\code{"light"}), only the distribution of simulated values is stored in element \code{plot} as produced by the \code{hist} function.}
+\item{nclass}{a number of intervals for the histogram. Ignored if object output is \code{"light"}}
+\item{coeff}{to fit the magnitude of the graph. Ignored if object output is \code{"light"}}
+\item{sim}{a numeric vector of simulated values}
+\item{obs}{a numeric vector of an observed value}
+\item{alter}{a character string specifying the alternative hypothesis,
+ must be one of "greater" (default), "less" or "two-sided"}
+\item{call}{a call order}
+}
+\value{
+\code{as.randtest} returns a list of class \code{randtest}\cr
+\code{plot.randtest} draws the simulated values histograms and the position of the observed value\cr
+}
+\details{
+If the alternative hypothesis is "greater", a p-value is estimated as:
+(number of random values equal to or greater than the observed one +
+1)/(number of permutations + 1). The null hypothesis is rejected if the
+p-value is less than the significance level. If the alternative
+hypothesis is "less", a p-value is estimated as: (number of random
+values equal to or less than the observed one + 1)/(number of
+permutations + 1). Again, the null hypothesis is rejected if the p-value
+is less than the significance level. Lastly, if the alternative
+hypothesis is "two-sided", the estimation of the p-value is equivalent
+to the one used for "greater" except that random and observed values are
+firstly centered (using the average of random values) and secondly
+transformed to their absolute values. Note that this is only suitable
+for symmetric random distribution.
+}
+\seealso{\link{mantel.randtest}, \link{procuste.randtest}, \link{rtest}}
+\examples{
+par(mfrow = c(2,2))
+for (x0 in c(2.4,3.4,5.4,20.4)) {
+ l0 <- as.randtest(sim = rnorm(200), obs = x0)
+ print(l0)
+ plot(l0,main=paste("p.value = ", round(l0$pvalue, dig = 5)))
+}
+par(mfrow = c(1,1))
+}
+\keyword{methods}
diff --git a/man/randtest.amova.Rd b/man/randtest.amova.Rd
new file mode 100644
index 0000000..0635312
--- /dev/null
+++ b/man/randtest.amova.Rd
@@ -0,0 +1,34 @@
+\name{randtest.amova}
+\alias{randtest.amova}
+\title{
+Permutation tests on an analysis of molecular variance (in C).}
+\description{
+Tests the components of covariance with permutation processes described by Excoffier et al. (1992).
+}
+\usage{
+\method{randtest}{amova}(xtest, nrepet = 99, \dots)
+}
+\arguments{
+ \item{xtest}{an object of class \code{amova}}
+ \item{nrepet}{the number of permutations}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+returns an object of class \code{krandtest} or \code{randtest}
+}
+\references{
+ Excoffier, L., Smouse, P.E. and Quattro, J.M. (1992) Analysis of molecular variance inferred from
+ metric distances among DNA haplotypes: application to human mitochondrial DNA restriction data.
+ \emph{Genetics}, \bold{131}, 479--491.
+}
+\author{Sandrine Pavoine \email{pavoine at mnhn.fr}
+}
+\examples{
+data(humDNAm)
+amovahum <- amova(humDNAm$samples, sqrt(humDNAm$distances), humDNAm$structures)
+amovahum
+randtesthum <- randtest(amovahum, 49)
+plot(randtesthum)
+}
+\keyword{multivariate}
+\keyword{nonparametric}
diff --git a/man/randtest.between.Rd b/man/randtest.between.Rd
new file mode 100644
index 0000000..65a3bfd
--- /dev/null
+++ b/man/randtest.between.Rd
@@ -0,0 +1,31 @@
+\name{randtest.between}
+\alias{randtest.between}
+\title{Monte-Carlo Test on the between-groups inertia percentage (in C).
+}
+\description{
+Performs a Monte-Carlo test on the between-groups inertia percentage.
+}
+\usage{
+\method{randtest}{between}(xtest, nrepet = 999, \dots)
+}
+\arguments{
+ \item{xtest}{an object of class \code{between}}
+ \item{nrepet}{the number of permutations}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+a list of the class \code{randtest}
+}
+\references{
+Romesburg, H. C. (1985) Exploring, confirming and randomization tests. \emph{Computers and Geosciences}, \bold{11}, 19--37.
+}
+\author{Jean Thioulouse \email{Jean.Thioulouse at univ-lyon1.fr}}
+\examples{
+data(meaudret)
+pca1 <- dudi.pca(meaudret$env, scan = FALSE, nf = 3)
+rand1 <- randtest(bca(pca1, meaudret$design$season, scan = FALSE), 99)
+rand1
+plot(rand1, main = "Monte-Carlo test")
+}
+\keyword{multivariate}
+\keyword{nonparametric}
diff --git a/man/randtest.coinertia.Rd b/man/randtest.coinertia.Rd
new file mode 100644
index 0000000..081174c
--- /dev/null
+++ b/man/randtest.coinertia.Rd
@@ -0,0 +1,47 @@
+\name{randtest.coinertia}
+\alias{randtest.coinertia}
+\title{Monte-Carlo test on a Co-inertia analysis (in C).}
+\description{
+Performs a Monte-Carlo test on a Co-inertia analysis.
+}
+\usage{
+\method{randtest}{coinertia}(xtest, nrepet = 999, fixed=0, \dots)
+}
+\arguments{
+ \item{xtest}{an object of class \code{coinertia}}
+ \item{nrepet}{the number of permutations}
+ \item{fixed}{when non uniform row weights are used in the coinertia analysis,
+this parameter must be the number of the table that should be kept fixed in the permutations}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+a list of the class \code{randtest}
+}
+\references{
+Dolédec, S. and Chessel, D. (1994) Co-inertia analysis: an alternative method for
+studying species-environment relationships. \emph{Freshwater Biology}, \bold{31}, 277--294.
+}
+\author{Jean Thioulouse \email{Jean.Thioulouse at univ-lyon1.fr} modified by Stéphane Dray \email{stephane.dray at univ-lyon1.fr}}
+\note{A testing procedure based on the total coinertia of the analysis
+ is available by the function \code{randtest.coinertia}. The function
+ allows to deal with various analyses for the two tables. The test is
+ based on random permutations of the rows of the two tables. If the row
+ weights are not uniform, mean and variances are recomputed for each
+ permutation (PCA); for MCA, tables are recentred and column weights are recomputed. If weights are computed using the data contained in one
+ table (e.g. COA), you must fix this table and permute only the rows of
+ the other table. The case of decentred PCA (PCA where centers are
+ entered by the user) is not yet implemented. If you want to use the
+ testing procedure for this case, you must firstly center the table and then perform a
+ non-centered PCA on the modified table. The case where one table is
+ treated by hill-smith analysis (mix of quantitative and qualitative
+ variables) will be soon implemented.}
+
+\examples{
+data(doubs)
+dudi1 <- dudi.pca(doubs$env, scale = TRUE, scan = FALSE, nf = 3)
+dudi2 <- dudi.pca(doubs$fish, scale = FALSE, scan = FALSE, nf = 2)
+coin1 <- coinertia(dudi1,dudi2, scan = FALSE, nf = 2)
+plot(randtest(coin1))
+ }
+\keyword{multivariate}
+\keyword{nonparametric}
diff --git a/man/randtest.discrimin.Rd b/man/randtest.discrimin.Rd
new file mode 100644
index 0000000..24fa71d
--- /dev/null
+++ b/man/randtest.discrimin.Rd
@@ -0,0 +1,41 @@
+\name{randtest.discrimin}
+\alias{randtest.discrimin}
+\title{
+Monte-Carlo Test on a Discriminant Analysis (in C).}
+\description{
+Test of the sum of a discriminant analysis eigenvalues (divided by the rank). Non parametric version of the Pillai's test. It authorizes any weighting.
+}
+\usage{
+\method{randtest}{discrimin}(xtest, nrepet = 999, \dots)
+}
+\arguments{
+ \item{xtest}{an object of class \code{discrimin}}
+ \item{nrepet}{the number of permutations}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+returns a list of class \code{randtest}
+}
+\author{Jean Thioulouse \email{Jean.Thioulouse at univ-lyon1.fr}
+}
+\examples{
+data(meaudret)
+pca1 <- dudi.pca(meaudret$env, scan = FALSE, nf = 3)
+rand1 <- randtest(discrimin(pca1, meaudret$design$season, scan = FALSE), 99)
+rand1
+#Monte-Carlo test
+#Observation: 0.3035
+#Call: as.randtest(sim = sim, obs = obs)
+#Based on 999 replicates
+#Simulated p-value: 0.001
+plot(rand1, main = "Monte-Carlo test")
+summary.manova(manova(as.matrix(meaudret$env)~meaudret$design$season), "Pillai")
+# Df Pillai approx F num Df den Df Pr(>F)
+# meaudret$design$season 3 2.73 11.30 27 30 1.6e-09 ***
+# Residuals 16
+# ---
+# Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1
+# 2.731/9 = 0.3034
+}
+\keyword{multivariate}
+\keyword{nonparametric}
diff --git a/man/randtest.dpcoa.Rd b/man/randtest.dpcoa.Rd
new file mode 100644
index 0000000..1dc57c4
--- /dev/null
+++ b/man/randtest.dpcoa.Rd
@@ -0,0 +1,45 @@
+\name{randtest.dpcoa}
+\alias{randtest.dpcoa}
+\title{
+Permutation test for double principal coordinate analysis (DPCoA)
+}
+\description{
+\code{randtest.dpcoa} calculates the ratio of beta to gamma diversity associated with DPCoA and compares the observed value to values obtained by permuting data.
+}
+
+\usage{
+\method{randtest}{dpcoa}(xtest, model = c("1p","1s"), nrep = 99,
+alter = c("greater", "less", "two-sided"), ...)
+}
+\arguments{
+ \item{xtest}{an object of class \code{dpcoa}}
+ \item{model}{either "1p", "1s", or the name of a function, (see details)}
+ \item{nrep}{the number of permutations to perform, the default is 99}
+ \item{alter}{a character string specifying the alternative hypothesis, must be one of "greater" (default), "less" or "two-sided"}
+ \item{\dots}{further arguments passed to or from other methods}
+ }
+\details{
+Model 1p permutes the names of the columns of the abundance matrix.
+Model 1s permutes the abundances of the categories (columns of the abundance matrix, usually species) within collections (rows of the abundance matrix, usually communities). Only the categories with positive abundances are permuted.
+The null models were introduced in Hardy (2008).
+
+Other null model can be used by entering the name of a function. For example, loading the \code{picante} package of R, if \code{model=randomizeMatrix}, then the permutations will follow function \code{randomizeMatrix} available in picante. Any function can be used provided it returns an abundance matrix of similar size as the observed abundance matrix. Parameters of the chosen function can be added to \code{randtest.dpcoa}. For example, using parameter \code{null.model} of \code{randomiz [...]
+\code{randtest.dpcoa(xtest, model = randomizeMatrix, null.model = "trialswap")}
+}
+\value{
+an object of class \code{randtest}
+}
+\references{
+Hardy, O. (2008) Testing the spatial phylogenetic structure of local communities: statistical performances of different null models and test statistics on a locally neutral community. \emph{Journal of Ecology}, \bold{96}, 914--926
+}
+\author{
+Sandrine Pavoine \email{pavoine at mnhn.fr}
+}
+\seealso{
+\code{\link{dpcoa}}
+}
+\examples{
+data(humDNAm)
+dpcoahum <- dpcoa(data.frame(t(humDNAm$samples)), sqrt(humDNAm$distances), scan = FALSE, nf = 2)
+randtest(dpcoahum)
+}
diff --git a/man/randtest.pcaiv.Rd b/man/randtest.pcaiv.Rd
new file mode 100644
index 0000000..e1628f2
--- /dev/null
+++ b/man/randtest.pcaiv.Rd
@@ -0,0 +1,37 @@
+\name{randtest.pcaiv}
+\alias{randtest.pcaiv}
+\alias{randtest.pcaivortho}
+\title{Monte-Carlo Test on the percentage of explained (i.e.
+ constrained) inertia}
+\description{
+Performs a Monte-Carlo test on on the percentage of explained (i.e.
+ constrained) inertia. The statistic is the ratio of the inertia (sum
+ of eigenvalues) of the
+ constrained analysis divided by the inertia of the unconstrained analysis.
+}
+\usage{
+\method{randtest}{pcaiv}(xtest, nrepet = 99, ...)
+\method{randtest}{pcaivortho}(xtest, nrepet = 99, ...)
+}
+
+\arguments{
+ \item{xtest}{an object of class \code{pcaiv}, \code{pcaivortho} or \code{caiv}}
+ \item{nrepet}{the number of permutations}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+
+\value{
+ a list of the class \code{randtest}
+}
+\author{Stéphane Dray \email{stephane.dray at univ-lyon1.fr}, original code
+ by Raphaël Pélissier}
+\examples{
+data(rpjdl)
+millog <- log(rpjdl$mil + 1)
+coa1 <- dudi.coa(rpjdl$fau, scann = FALSE)
+caiv1 <- pcaiv(coa1, millog, scan = FALSE)
+randtest(caiv1)
+}
+
+\keyword{multivariate}
+\keyword{nonparametric}
diff --git a/man/randxval.Rd b/man/randxval.Rd
new file mode 100644
index 0000000..f76f9b5
--- /dev/null
+++ b/man/randxval.Rd
@@ -0,0 +1,54 @@
+\name{randxval}
+\alias{randxval}
+\alias{krandxval}
+\alias{as.krandxval}
+\alias{print.krandxval}
+\alias{as.randxval}
+\alias{print.randxval}
+
+\title{Two-fold cross-validation}
+\description{Functions and classes to manage outputs of two-fold
+ cross-validation for one (class \code{randxval}) or several (class
+ \code{krandxval}) statistics}
+\usage{
+as.krandxval(RMSEc, RMSEv, quantiles = c(0.25, 0.75), names =
+colnames(RMSEc), call = match.call())
+\method{print}{krandxval}(x, ...)
+as.randxval(RMSEc, RMSEv, quantiles = c(0.25, 0.75), call =
+match.call())
+\method{print}{randxval}(x, ...)
+}
+
+\arguments{
+ \item{RMSEc}{a vector (class \code{randxval}) or a matrix (class
+ \code{krandxval}) with the root-mean-square error of calibration
+ (statistics as columns and repetions as rows)}
+ \item{RMSEv}{a vector (class \code{randxval}) or a matrix (class
+ \code{krandxval}) with the root-mean-square error of validation
+ (statistics as columns and repetions as rows)}
+ \item{quantiles}{a vector indicating the lower and upper quantiles to compute}
+ \item{names}{a vector of names for the statistics}
+ \item{call}{the matching call}
+ \item{x}{an object of class \code{randxval} or \code{krandxval}}
+ \item{\dots}{other arguments to be passed to methods}
+}
+
+\value{an object of class \code{randxval} or \code{krandxval}}
+
+\references{Stone M. (1974) Cross-validatory choice and assessment of
+ statistical predictions. \emph{Journal of the Royal Statistical
+ Society}, 36, 111-147}
+\author{Stéphane Dray (\email{stephane.dray at univ-lyon1.fr})}
+
+\seealso{\code{\link{testdim.multiblock}}}
+\examples{
+## an example corresponding to 10 statistics and 100 repetitions
+cv <- as.krandxval(RMSEc = matrix(rnorm(1000), nrow = 100), RMSEv =
+matrix(rnorm(1000, mean = 1), nrow = 100))
+cv
+if(adegraphicsLoaded())
+plot(cv)
+
+}
+
+\keyword{htest}
diff --git a/man/rankrock.Rd b/man/rankrock.Rd
new file mode 100644
index 0000000..9bd8b02
--- /dev/null
+++ b/man/rankrock.Rd
@@ -0,0 +1,22 @@
+\name{rankrock}
+\alias{rankrock}
+\docType{data}
+\title{Ordination Table}
+\description{
+This data set gives the classification in order of preference of 10 music groups by 51 students.
+}
+\usage{data(rankrock)}
+\format{
+A data frame with 10 rows and 51 columns.\cr
+Each column contains the rank (1 for the favorite, \dots, 10 for the less appreciated)\cr
+attributed to the group by a student.
+}
+\examples{
+data(rankrock)
+dudi1 <- dudi.pca(rankrock, scannf = FALSE, nf = 3)
+if(adegraphicsLoaded()) {
+ g <- scatter(dudi1, row.plab.cex = 1.5)
+} else {
+ scatter(dudi1, clab.r = 1.5)
+}}
+\keyword{datasets}
diff --git a/man/reconst.Rd b/man/reconst.Rd
new file mode 100644
index 0000000..afc8c27
--- /dev/null
+++ b/man/reconst.Rd
@@ -0,0 +1,58 @@
+\name{reconst}
+\alias{reconst}
+\alias{reconst.pca}
+\alias{reconst.coa}
+\title{Reconstitution of Data from a Duality Diagram}
+\description{
+Generic Function for the reconstitution of data from
+a principal component analysis or
+a correspondence analysis
+}
+\usage{
+reconst (dudi, ...)
+\method{reconst}{pca}(dudi, nf = 1, ...)
+\method{reconst}{coa}(dudi, nf = 1, ...)
+}
+\arguments{
+ \item{dudi}{an object of class \code{dudi} used to select a method: pca or coa}
+ \item{nf}{an integer indicating the number of kept axes for the reconstitution}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+returns a data frame containing the reconstituted data
+}
+\references{Gabriel, K.R. (1978) Least-squares approximation of matrices by additive and multiplicative models. \emph{Journal of the Royal Statistical Society}, B , \bold{40}, 186--196.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(rhone)
+dd1 <- dudi.pca(rhone$tab, nf = 2, scann = FALSE)
+rh1 <- reconst(dd1, 1)
+rh2 <- reconst(dd1, 2)
+par(mfrow = c(4,4))
+par(mar = c(2.6,2.6,1.1,1.1))
+for (i in 1:15) {
+ plot(rhone$date, rhone$tab[,i])
+ lines(rhone$date, rh1[,i], lty = 2)
+ lines(rhone$date, rh2[,i], lty = 1)
+ ade4:::scatterutil.sub(names(rhone$tab)[i], 2, "topright")}
+
+data(chats)
+chatsw <- data.frame(t(chats))
+chatscoa <- dudi.coa(chatsw, scann = FALSE)
+model0 <- reconst(chatscoa, 0)
+round(model0,3)
+round(chisq.test(chatsw)$expected,3)
+chisq.test(chatsw)$statistic
+sum(((chatsw-model0)^2)/model0)
+effectif <- sum(chatsw)
+sum(chatscoa$eig)*effectif
+model1 <- reconst(chatscoa, 1)
+round(model1, 3)
+sum(((chatsw-model1)^2)/model0)
+sum(chatscoa$eig[-1])*effectif
+}
+\keyword{multivariate}
diff --git a/man/rhizobium.Rd b/man/rhizobium.Rd
new file mode 100644
index 0000000..e4dc166
--- /dev/null
+++ b/man/rhizobium.Rd
@@ -0,0 +1,78 @@
+\name{rhizobium}
+\alias{rhizobium}
+\docType{data}
+\title{Genetic structure of two nitrogen fixing bacteria influenced
+by geographical isolation and host specialization}
+\description{
+The data set concerns fixing bacteria belonging to the genus Sinorhizobium
+(Rhizobiaceae) associated with the plant genus Medicago
+(Fabaceae). It is a combination of two data sets fully available online from GenBank and
+published in two recent papers (see reference below). The complete sampling
+procedure is described in the Additional file 3 of the reference below. We delineated six populations
+according to geographical origin (France: F, Tunisia Hadjeb:
+TH, Tunisia Enfidha: TE), the host plant (\emph{M. truncatula}
+or similar symbiotic specificity: T, M. laciniata: L), and the
+taxonomical status of bacteria (S. meliloti: mlt, S. medicae:
+mdc). Each population will be called hereafter according
+to the three above criteria, e.g. THLmlt is the population
+sampled in Tunisia at Hadjeb from M. laciniata nodules
+which include S. meliloti isolates. S. medicae interacts with
+M. truncatula while S. meliloti interacts with both M. laciniata
+(S. meliloti bv. medicaginis) and M. truncatula (S.
+meliloti bv. meliloti). The numbers of individuals
+are respectively 46 for FTmdc, 43 for FTmlt, 20 for TETmdc,
+24 for TETmlt, 20 for TELmlt, 42 for THTmlt and 20
+for THLmlt.
+
+Four different intergenic spacers (IGS), IGSNOD,
+IGSEXO, IGSGAB, and IGSRKP, distributed on the different
+replication units of the model strain 1021 of S.
+meliloti bv. meliloti had been sequenced to
+characterize each bacterial isolate (DNA extraction and
+sequencing procedures are described in an additional file).
+It is noteworthy that the IGSNOD
+marker is located within the nod gene cluster and that specific
+alleles at these loci determine the ability of S. meliloti
+strains to interact with either M. laciniata or M. truncatula.
+}
+\usage{data(rhizobium)}
+\format{
+ \code{rhizobium} is a list of 2 components.
+\itemize{
+ \item dnaobj: list of dna lists. Each dna list corresponds to a locus. For a given locus, the dna list provides the
+ dna sequences The ith sequences of all loci corresponds to the ith individual of the data set.
+ \item pop: The list of the populations which each individual sequence belongs to.
+}}
+\source{
+ Pavoine, S. and Bailly, X. (2007) New analysis for consistency among markers in the study of genetic diversity:
+ development and application to the description of bacterial diversity. \emph{BMC Evolutionary Biology}, \bold{7}, e156.
+}
+\examples{
+
+# The functions used below require the package ape
+data(rhizobium)
+if(requireNamespace("ape", quietly = TRUE)) {
+dat <- prep.mdpcoa(rhizobium[[1]], rhizobium[[2]],
+ model = c("F84", "F84", "F84", "F81"),
+ pairwise.deletion = TRUE)
+sam <- dat$sam
+dis <- dat$dis
+# The distances should be Euclidean.
+# Several transformations exist to render a distance object Euclidean
+# (see functions cailliez, lingoes and quasieuclid in the ade4 package).
+# Here we use the quasieuclid function.
+dis <- lapply(dis, quasieuclid)
+mdpcoa1 <- mdpcoa(sam, dis, scann = FALSE, nf = 2)
+
+# Reference analysis
+plot(mdpcoa1)
+
+# Differences between the loci
+kplot(mdpcoa1)
+
+# Alleles projected on the population maps.
+kplotX.mdpcoa(mdpcoa1)
+}
+
+}
+\keyword{datasets}
diff --git a/man/rhone.Rd b/man/rhone.Rd
new file mode 100644
index 0000000..e1f490a
--- /dev/null
+++ b/man/rhone.Rd
@@ -0,0 +1,38 @@
+\name{rhone}
+\alias{rhone}
+\docType{data}
+\title{Physico-Chemistry Data}
+\description{
+This data set gives for 39 water samples a physico-chemical description
+with the number of sample date and the flows of three tributaries.
+}
+\usage{data(rhone)}
+\format{
+ \code{rhone} is a list of 3 components.
+\describe{
+ \item{tab}{is a data frame with 39 water samples and 15 physico-chemical variables.}
+ \item{date}{is a vector of the sample date (in days).}
+ \item{disch}{is a data frame with 39 water samples and the flows of the three tributaries.}
+ }
+}
+\source{
+Carrel, G., Barthelemy, D., Auda, Y. and Chessel, D. (1986)
+Approche graphique de l'analyse en composantes principales normée : utilisation en hydrobiologie.
+\emph{Acta Oecologica, Oecologia Generalis}, \bold{7}, 189--203.
+}
+\examples{
+data(rhone)
+pca1 <- dudi.pca(rhone$tab, nf = 2, scann = FALSE)
+rh1 <- reconst(pca1, 1)
+rh2 <- reconst(pca1, 2)
+par(mfrow = c(4,4))
+par(mar = c(2.6,2.6,1.1,1.1))
+for (i in 1:15) {
+ plot(rhone$date, rhone$tab[,i])
+ lines(rhone$date, rh1[,i], lwd = 2)
+ lines(rhone$date, rh2[,i])
+ ade4:::scatterutil.sub(names(rhone$tab)[i], 2, "topright")
+}
+par(mfrow = c(1,1))
+}
+\keyword{datasets}
diff --git a/man/rlq.Rd b/man/rlq.Rd
new file mode 100644
index 0000000..f476faa
--- /dev/null
+++ b/man/rlq.Rd
@@ -0,0 +1,104 @@
+\name{rlq}
+\alias{rlq}
+\alias{print.rlq}
+\alias{plot.rlq}
+\alias{summary.rlq}
+\alias{randtest.rlq}
+\title{RLQ analysis }
+\description{
+RLQ analysis performs a double inertia analysis of two arrays (R and Q) with a link expressed by a contingency table (L).
+The rows of L correspond to the rows of R and the columns of L correspond to the rows of Q.
+}
+\usage{
+rlq(dudiR, dudiL, dudiQ, scannf = TRUE, nf = 2)
+\method{print}{rlq}(x, ...)
+\method{plot}{rlq}(x, xax = 1, yax = 2, ...)
+\method{summary}{rlq}(object, ...)
+\method{randtest}{rlq}(xtest,nrepet = 999, modeltype = 6,...)
+}
+
+\arguments{
+ \item{dudiR}{ a duality diagram providing from one of the functions dudi.hillsmith, dudi.pca, \dots }
+ \item{dudiL}{ a duality diagram of the function dudi.coa }
+ \item{dudiQ}{ a duality diagram providing from one of the functions dudi.hillsmith, dudi.pca, \dots }
+ \item{scannf}{ a logical value indicating whether the eigenvalues bar plot should be displayed }
+ \item{nf}{ if scannf FALSE, an integer indicating the number of kept axes }
+ \item{x}{ an rlq object }
+ \item{xax}{the column number for the x-axis}
+ \item{yax}{the column number for the y-axis}
+ \item{object}{ an rlq object }
+ \item{xtest}{ an rlq object }
+ \item{nrepet}{ the number of permutations }
+ \item{modeltype}{the model used to permute data(2: permute rows of R,
+ 4: permute rows of Q, 5: permute both, 6: sequential approach, see
+ ter Braak et al. 2012)}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+ Returns a list of class 'dudi', sub-class 'rlq' containing:
+ \item{call}{call}
+ \item{rank}{rank}
+ \item{nf}{a numeric value indicating the number of kept axes}
+ \item{RV}{a numeric value, the RV coefficient}
+ \item{eig}{a numeric vector with all the eigenvalues}
+ \item{lw}{a numeric vector with the rows weigths (crossed array)}
+ \item{cw}{a numeric vector with the columns weigths (crossed array)}
+ \item{tab}{a crossed array (CA)}
+ \item{li}{R col = CA row: coordinates}
+ \item{l1}{R col = CA row: normed scores}
+ \item{co}{Q col = CA column: coordinates}
+ \item{c1}{Q col = CA column: normed scores}
+ \item{lR}{the row coordinates (R)}
+ \item{mR}{the normed row scores (R)}
+ \item{lQ}{the row coordinates (Q)}
+ \item{mQ}{the normed row scores (Q)}
+ \item{aR}{the axis onto co-inertia axis (R)}
+ \item{aQ}{the axis onto co-inertia axis (Q)}
+}
+\references{
+Doledec, S., Chessel, D., ter Braak, C.J.F. and Champely, S. (1996)
+Matching species traits to environmental variables: a new three-table ordination method. \emph{Environmental and Ecological Statistics},
+\bold{3}, 143--166.
+
+Dray, S., Pettorelli, N., Chessel, D. (2002) Matching data sets from two different spatial samplings.
+\emph{Journal of Vegetation Science}, \bold{13}, 867--874.
+
+Dray, S. and Legendre, P. (2008)
+Testing the species traits-environment relationships: the fourth-corner
+problem revisited. \emph{Ecology},
+\bold{89}, 3400--3412.
+
+ter Braak, C., Cormont, A., Dray, S. (2012) Improved testing of species
+traits-environment relationships in the fourth corner problem.
+\emph{Ecology}, \bold{93}, 1525--1526.
+
+}
+\author{Stéphane Dray \email{stephane.dray at univ-lyon1.fr}}
+
+\section{WARNING }{
+IMPORTANT : row weights for \code{dudiR} and \code{dudiQ} must be taken from \code{dudiL}.
+}
+\note{A testing procedure based on the total coinertia of the RLQ
+ analysis is available by the function \code{randtest.rlq}. The
+ function allows to deal with various analyses for tables R and Q. Means and variances are recomputed for each
+ permutation (PCA); for MCA, tables are recentred and column weights are recomputed.The
+ case of decentred PCA (PCA where centers are entered by the user) for
+ R or Q is not yet implemented. If you want to use the testing
+ procedure for this case, you must firstly center the table and then perform a non-centered PCA on the modified table.}
+\seealso{ \code{\link{coinertia}}, \code{\link{fourthcorner}}}
+\examples{
+ data(aviurba)
+ coa1 <- dudi.coa(aviurba$fau, scannf = FALSE, nf = 2)
+ dudimil <- dudi.hillsmith(aviurba$mil, scannf = FALSE, nf = 2, row.w = coa1$lw)
+ duditrait <- dudi.hillsmith(aviurba$traits, scannf = FALSE, nf = 2, row.w = coa1$cw)
+ rlq1 <- rlq(dudimil, coa1, duditrait, scannf = FALSE, nf = 2)
+ plot(rlq1)
+ summary(rlq1)
+ randtest(rlq1)
+ fourthcorner.rlq(rlq1,type="Q.axes")
+ fourthcorner.rlq(rlq1,type="R.axes")
+
+}
+\keyword{ multivariate }
+\keyword{ spatial }
+
diff --git a/man/rpjdl.Rd b/man/rpjdl.Rd
new file mode 100644
index 0000000..9151d5d
--- /dev/null
+++ b/man/rpjdl.Rd
@@ -0,0 +1,53 @@
+\name{rpjdl}
+\alias{rpjdl}
+\docType{data}
+\title{Avifauna and Vegetation}
+\description{
+This data set gives the abundance of 51 species and 8 environmental variables
+in 182 sites.
+}
+\usage{data(rpjdl)}
+\format{
+ \code{rpjdl} is a list of 5 components.
+ \describe{
+ \item{fau}{is the faunistic array of 182 sites (rows) and 51 species (columns).}
+ \item{mil}{is the array of environmental variables : 182 sites and 8 variables.}
+ \item{frlab}{is a vector of the names of species in French.}
+ \item{lalab}{is a vector of the names of species in Latin.}
+ \item{lab}{is a vector of the simplified labels of species.}
+ }
+}
+\source{
+Prodon, R. and Lebreton, J.D. (1981)
+Breeding avifauna of a Mediterranean succession : the holm oak and cork oak series in the eastern Pyrénées.
+1 : Analysis and modelling of the structure gradient.
+\emph{Oïkos}, \bold{37}, 21--38.
+
+Lebreton, J. D., Chessel D., Prodon R. and Yoccoz N. (1988)
+L'analyse des relations espèces-milieu par l'analyse canonique des correspondances.
+I. Variables de milieu quantitatives.
+\emph{Acta Oecologica, Oecologia Generalis}, \bold{9}, 53--67.
+}
+\references{
+See a data description at \url{http://pbil.univ-lyon1.fr/R/pdf/pps048.pdf} (in French).
+}
+\examples{
+\dontrun{
+data(rpjdl)
+coa1 <- dudi.coa(rpjdl$fau, scann = FALSE)
+pca1 <- dudi.pca(rpjdl$fau, scal = FALSE, scann = FALSE)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.distri(coa1$l1, rpjdl$fau, xax = 2, yax = 1, starSize = 0.3,
+ ellipseSize = 0, plab.cex = 0)
+ g2 <- s.distri(pca1$l1, rpjdl$fau, xax = 2, yax = 1, starSize = 0.3,
+ ellipseSize = 0, plab.cex = 0)
+} else {
+ s.distri(coa1$l1, rpjdl$fau, 2, 1, cstar = 0.3, cell = 0)
+ s.distri(pca1$l1, rpjdl$fau, 2, 1, cstar = 0.3, cell = 0)
+}
+
+caiv1 <- pcaiv(coa1, rpjdl$mil, scan = FALSE)
+plot(caiv1)
+}}
+\keyword{datasets}
diff --git a/man/rtest.Rd b/man/rtest.Rd
new file mode 100644
index 0000000..485adf9
--- /dev/null
+++ b/man/rtest.Rd
@@ -0,0 +1,28 @@
+\name{rtest}
+\alias{rtest}
+\title{Class of the Permutation Tests (in R).}
+\description{
+rtest is a generic function. It proposes methods for the following objects \code{between}, \code{discrimin}, \code{procuste} \code{\dots}\cr
+}
+\usage{
+ rtest(xtest, \dots)
+}
+\arguments{
+\item{xtest}{an object used to select a method}
+\item{\dots}{further arguments passed to or from other methods; in \code{plot.randtest} to \code{hist}}
+}
+\value{
+\code{rtest} returns an object of class \code{randtest}
+}
+\seealso{\code{\link{RV.rtest}}, \code{\link{mantel.rtest}}, \code{\link{procuste.rtest}}, \code{\link{randtest}}}
+\author{Daniel Chessel }
+\examples{
+par(mfrow = c(2, 2))
+for (x0 in c(2.4, 3.4, 5.4, 20.4)) {
+ l0 <- as.randtest(sim = rnorm(200), obs = x0)
+ print(l0)
+ plot(l0, main = paste("p.value = ", round(l0$pvalue, dig = 5)))
+}
+par(mfrow = c(1, 1))
+}
+\keyword{methods}
diff --git a/man/rtest.between.Rd b/man/rtest.between.Rd
new file mode 100644
index 0000000..75cd208
--- /dev/null
+++ b/man/rtest.between.Rd
@@ -0,0 +1,31 @@
+\name{rtest.between}
+\alias{rtest.between}
+\title{Monte-Carlo Test on the between-groups inertia percentage (in R).
+}
+\description{
+Performs a Monte-Carlo test on the between-groups inertia percentage.
+}
+\usage{
+\method{rtest}{between}(xtest, nrepet = 99, \dots)
+}
+\arguments{
+ \item{xtest}{an object of class \code{between}}
+ \item{nrepet}{the number of permutations}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+a list of the class \code{rtest}
+}
+\author{Daniel Chessel }
+\references{
+Romesburg, H. C. (1985) Exploring, confirming and randomization tests. \emph{Computers and Geosciences}, \bold{11}, 19--37.
+}
+\examples{
+data(meaudret)
+pca1 <- dudi.pca(meaudret$env, scan = FALSE, nf = 3)
+rand1 <- rtest(bca(pca1, meaudret$design$season, scan = FALSE), 99)
+rand1
+plot(rand1, main = "Monte-Carlo test")
+}
+\keyword{multivariate}
+\keyword{nonparametric}
diff --git a/man/rtest.discrimin.Rd b/man/rtest.discrimin.Rd
new file mode 100644
index 0000000..9722c85
--- /dev/null
+++ b/man/rtest.discrimin.Rd
@@ -0,0 +1,41 @@
+\name{rtest.discrimin}
+\alias{rtest.discrimin}
+\title{
+Monte-Carlo Test on a Discriminant Analysis (in R).
+}
+\description{
+Test of the sum of a discriminant analysis eigenvalues (divided by the rank). Non parametric version of the Pillai's test. It authorizes any weighting.
+}
+\usage{
+\method{rtest}{discrimin}(xtest, nrepet = 99, \dots)
+}
+\arguments{
+ \item{xtest}{an object of class \code{discrimin}}
+ \item{nrepet}{the number of permutations}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+returns a list of class \code{rtest}
+}
+\author{Daniel Chessel }
+\examples{
+data(meaudret)
+pca1 <- dudi.pca(meaudret$env, scan = FALSE, nf = 3)
+rand1 <- rtest(discrimin(pca1, meaudret$design$season, scan = FALSE), 99)
+rand1
+#Monte-Carlo test
+#Observation: 0.3035
+#Call: as.rtest(sim = sim, obs = obs)
+#Based on 999 replicates
+#Simulated p-value: 0.001
+plot(rand1, main = "Monte-Carlo test")
+summary.manova(manova(as.matrix(meaudret$env)~meaudret$design$season), "Pillai")
+# Df Pillai approx F num Df den Df Pr(>F)
+# meaudret$design$season 3 2.73 11.30 27 30 1.6e-09 ***
+# Residuals 16
+# ---
+# Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1
+# 2.731/9 = 0.3034
+}
+\keyword{multivariate}
+\keyword{nonparametric}
diff --git a/man/s.arrow.Rd b/man/s.arrow.Rd
new file mode 100644
index 0000000..8aec962
--- /dev/null
+++ b/man/s.arrow.Rd
@@ -0,0 +1,46 @@
+\name{s.arrow}
+\alias{s.arrow}
+\title{Plot of the factorial maps for the projection of a vector basis}
+\description{
+performs the scatter diagrams of the projection of a vector basis.
+}
+\usage{
+s.arrow(dfxy, xax = 1, yax = 2, label = row.names(dfxy),
+ clabel = 1, pch = 20, cpoint = 0, boxes = TRUE, edge = TRUE, origin = c(0,0),
+ xlim = NULL, ylim = NULL, grid = TRUE, addaxes = TRUE, cgrid = 1,
+ sub = "", csub = 1.25, possub = "bottomleft", pixmap = NULL,
+ contour = NULL, area = NULL, add.plot = FALSE)
+}
+\arguments{
+ \item{dfxy}{a data frame containing the two columns for the axes}
+ \item{xax}{the column number of x in \code{dfxy}}
+ \item{yax}{the column number of y in \code{dfxy}}
+ \item{label}{a vector of strings of characters for the point labels}
+ \item{clabel}{if not NULL, a character size for the labels used with par("cex")*\code{clabel}}
+ \item{pch}{if \code{cpoint} > 0, an integer specifying the symbol or the single character to be used in plotting points}
+ \item{cpoint}{a character size for plotting the points, used with par("cex")*\code{cpoint}. If zero, no points are drawn.}
+ \item{boxes}{if TRUE, labels are framed}
+ \item{edge}{a logical value indicating whether the arrows should be plotted}
+ \item{origin}{the fixed point in the graph space, by default c(0,0) the origin of axes. The arrows begin at \code{cent}.}
+ \item{xlim}{the ranges to be encompassed by the x-axis, if NULL they are computed}
+ \item{ylim}{the ranges to be encompassed by the y-axis, if NULL they are computed}
+ \item{grid}{a logical value indicating whether a grid in the background of the plot should be drawn}
+ \item{addaxes}{a logical value indicating whether the axes should be plotted}
+ \item{cgrid}{a character size, parameter used with \code{par("cex")*cgrid}, to indicate the mesh of the grid}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the legend position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{pixmap}{an object 'pixmap' displayed in the map background}
+ \item{contour}{a data frame with 4 columns to plot the contour of the map : each row gives a segment (x1,y1,x2,y2)}
+ \item{area}{a data frame of class 'area' to plot a set of surface units in contour}
+ \item{add.plot}{if TRUE uses the current graphics window}
+}
+\value{
+The matched call.
+}
+\author{Daniel Chessel }
+\examples{
+s.arrow(cbind.data.frame(runif(55,-2,3), runif(55,-3,2)))
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/s.chull.Rd b/man/s.chull.Rd
new file mode 100644
index 0000000..05b74ad
--- /dev/null
+++ b/man/s.chull.Rd
@@ -0,0 +1,56 @@
+\name{s.chull}
+\alias{s.chull}
+\title{Plot of the factorial maps with polygons of contour by level of a factor}
+\description{
+performs the scatter diagrams with polygons of contour by level of a factor.
+}
+\usage{
+s.chull(dfxy, fac, xax = 1, yax = 2,
+ optchull = c(0.25, 0.5, 0.75, 1), label = levels(fac), clabel = 1,
+ cpoint = 0, col = rep(1, length(levels(fac))), xlim = NULL, ylim = NULL,
+ grid = TRUE, addaxes = TRUE, origin = c(0,0), include.origin = TRUE,
+ sub = "", csub = 1, possub = "bottomleft", cgrid = 1, pixmap = NULL,
+ contour = NULL, area = NULL, add.plot = FALSE)
+}
+\arguments{
+ \item{dfxy}{a data frame containing the two columns for the axes}
+ \item{fac}{a factor partioning the rows of the data frame in classes}
+ \item{xax}{the column number of x in \code{dfxy}}
+ \item{yax}{the column number of y in \code{dfxy}}
+ \item{optchull}{the number of convex hulls and their interval}
+ \item{label}{a vector of strings of characters for the point labels}
+ \item{clabel}{if not NULL, a character size for the labels, used with \code{par("cex")*clabel}}
+ \item{cpoint}{a character size for plotting the points, used with \code{par("cex")*cpoint}. If zero, no points are drawn}
+ \item{col}{a vector of colors used to draw each class in a different color}
+ \item{xlim}{the ranges to be encompassed by the x axis, if NULL, they are computed}
+ \item{ylim}{the ranges to be encompassed by the y axis, if NULL they are computed}
+ \item{grid}{a logical value indicating whether a grid in the background of the plot should be drawn}
+ \item{addaxes}{a logical value indicating whether the axes should be plotted}
+ \item{origin}{the fixed point in the graph space, for example c(0,0) the origin axes}
+ \item{include.origin}{a logical value indicating whether the point "origin" should be belonged to the graph space}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{cgrid}{a character size, parameter used with par("cex")* \code{cgrid} to indicate the mesh of the grid}
+ \item{pixmap}{an object 'pixmap' displayed in the map background}
+ \item{contour}{a data frame with 4 columns to plot the contour of the map : each row gives a segment (x1,y1,x2,y2)}
+ \item{area}{a data frame of class 'area' to plot a set of surface units in contour}
+ \item{add.plot}{if TRUE uses the current graphics window}
+}
+\value{
+The matched call.
+}
+\author{Daniel Chessel}
+\examples{
+xy <- cbind.data.frame(x = runif(200,-1,1), y = runif(200,-1,1))
+posi <- factor(xy$x > 0) : factor(xy$y > 0)
+coul <- c("black", "red", "green", "blue")
+
+if(adegraphicsLoaded()) {
+ s.class(xy, posi, ppoi.cex = 1.5, chullSize = c(0.25, 0.5, 0.75, 1), ellipseSize = 0,
+ starSize = 0, ppoly = list(col = "white", border = coul))
+} else {
+ s.chull(xy, posi, cpoi = 1.5, col = coul)
+}}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/s.class.Rd b/man/s.class.Rd
new file mode 100644
index 0000000..47c79e3
--- /dev/null
+++ b/man/s.class.Rd
@@ -0,0 +1,85 @@
+\name{s.class}
+\alias{s.class}
+\title{Plot of factorial maps with representation of point classes}
+\description{
+performs the scatter diagrams with representation of point classes.
+}
+\usage{
+s.class(dfxy, fac, wt = rep(1, length(fac)), xax = 1,
+ yax = 2, cstar = 1, cellipse = 1.5, axesell = TRUE,
+ label = levels(fac), clabel = 1, cpoint = 1, pch = 20,
+ col = rep(1, length(levels(fac))), xlim = NULL, ylim = NULL,
+ grid = TRUE, addaxes = TRUE, origin = c(0,0),
+ include.origin = TRUE, sub = "", csub = 1, possub = "bottomleft",
+ cgrid = 1, pixmap = NULL, contour = NULL, area = NULL, add.plot = FALSE)
+}
+\arguments{
+ \item{dfxy}{a data frame containing the two columns for the axes}
+ \item{fac}{a factor partitioning the rows of the data frame in classes}
+ \item{wt}{a vector of the point weightings of the data frame used for computing the means (star centers) and the ellipses of dispersion}
+ \item{xax}{the column number of x in \code{dfxy}}
+ \item{yax}{the column number of y in \code{dfxy}}
+ \item{cstar}{a number between 0 and 1 which defines the length of the star size}
+ \item{cellipse}{a positive coefficient for the inertia ellipse size}
+ \item{axesell}{a logical value indicating whether the ellipse axes should be drawn}
+ \item{label}{a vector of strings of characters for the point labels}
+ \item{clabel}{if not NULL, a character size for the labels, used with \code{par("cex")*clabel}}
+ \item{cpoint}{a character size for plotting the points, used with \code{par("cex")*cpoint}. If zero, no points are drawn}
+ \item{pch}{if \code{cpoint} > 0, an integer specifying the symbol or the single character to be used in plotting points}
+ \item{col}{a vector of colors used to draw each class in a different color}
+ \item{xlim}{the ranges to be encompassed by the x, if NULL they are computed}
+ \item{ylim}{the ranges to be encompassed by the y, if NULL they are computed}
+ \item{grid}{a logical value indicating whether a grid in the background of the plot should be drawn}
+ \item{addaxes}{a logical value indicating whether the axes should be plotted}
+ \item{origin}{the fixed point in the graph space, for example c(0,0) the origin axes}
+ \item{include.origin}{a logical value indicating whether the point "origin" should be belonged to the graph space}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{cgrid}{a character size, parameter used with par("cex")* \code{cgrid} to indicate the mesh of the grid}
+ \item{pixmap}{an object 'pixmap' displayed in the map background}
+ \item{contour}{a data frame with 4 columns to plot the contour of the map : each row gives a segment (x1,y1,x2,y2)}
+ \item{area}{a data frame of class 'area' to plot a set of surface units in contour}
+ \item{add.plot}{if TRUE uses the current graphics window}
+}
+\value{
+The matched call.
+}
+\author{Daniel Chessel}
+\examples{
+if(!adegraphicsLoaded()) {
+ xy <- cbind.data.frame(x = runif(200, -1, 1), y = runif(200, -1, 1))
+ posi <- factor(xy$x > 0) : factor(xy$y > 0)
+ coul <- c("black", "red", "green", "blue")
+ par(mfrow = c(2, 2))
+ s.class(xy, posi, cpoi = 2)
+ s.class(xy, posi, cell = 0, cstar = 0.5)
+ s.class(xy, posi, cell = 2, axesell = FALSE, csta = 0, col = coul)
+ s.chull(xy, posi, cpoi = 1)
+ par(mfrow = c(1, 1))
+
+ \dontrun{
+ data(banque)
+ dudi1 <- dudi.acm(banque, scannf = FALSE)
+ coul = rainbow(length(levels(banque[, 20])))
+ par(mfrow = c(2, 2))
+ s.label(dudi1$li, sub = "Factorial map from ACM", csub = 1.5,
+ possub = "topleft")
+ s.class(dudi1$li, banque[, 20], sub = names(banque)[20],
+ possub = "bottomright", cell = 0, cstar = 0.5, cgrid = 0, csub = 1.5)
+ s.class(dudi1$li, banque[, 20], csta = 0, cell = 2, cgrid = 0,
+ clab = 1.5)
+ s.class(dudi1$li, banque[, 20], sub = names(banque)[20],
+ possub = "topright", cgrid = 0, col = coul)
+ par(mfrow = c(1, 1))
+
+ par(mfrow = n2mfrow(ncol(banque)))
+ for(i in 1:(ncol(banque)))
+ s.class(dudi1$li, banque[, i], clab = 1.5, sub = names(banque)[i],
+ csub = 2, possub = "topleft", cgrid = 0, csta = 0, cpoi = 0)
+ s.label(dudi1$li, clab = 0, sub = "Common background")
+ par(mfrow = c(1, 1))
+}
+}}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/s.corcircle.Rd b/man/s.corcircle.Rd
new file mode 100644
index 0000000..f0ff9b7
--- /dev/null
+++ b/man/s.corcircle.Rd
@@ -0,0 +1,45 @@
+\name{s.corcircle}
+\alias{s.corcircle}
+\title{Plot of the factorial maps of a correlation circle}
+\description{
+performs the scatter diagram of a correlation circle.
+}
+\usage{
+s.corcircle(dfxy, xax = 1, yax = 2, label = row.names(df),
+ clabel = 1, grid = TRUE, sub = "", csub = 1, possub = "bottomleft",
+ cgrid = 0, fullcircle = TRUE, box = FALSE, add.plot = FALSE)
+}
+\arguments{
+ \item{dfxy}{a data frame with two coordinates }
+ \item{xax}{the column number for the x-axis}
+ \item{yax}{the column number for the y-axis}
+ \item{label}{a vector of strings of characters for the point labels}
+ \item{clabel}{if not NULL, a character size for the labels, used with \code{par("cex")*clabel}}
+ \item{grid}{a logical value indicating whether a grid in the background of the plot should be drawn}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{cgrid}{a character size, parameter used with par("cex")*\code{cgrid} to indicate the mesh of the grid}
+ \item{fullcircle}{a logical value indicating whether the complete circle sould be drawn}
+ \item{box}{a logical value indcating whether a box should be drawn}
+ \item{add.plot}{if TRUE uses the current graphics window}
+}
+\value{
+The matched call.
+}
+\author{Daniel Chessel}
+\examples{
+if(!adegraphicsLoaded()) {
+ data (olympic)
+ dudi1 <- dudi.pca(olympic$tab, scan = FALSE) # a normed PCA
+ par(mfrow = c(2, 2))
+ s.corcircle(dudi1$co, lab = names(olympic$tab))
+ s.corcircle(dudi1$co, cgrid = 0, full = FALSE, clab = 0.8)
+ s.corcircle(dudi1$co, lab = as.character(1:11), cgrid = 2,
+ full = FALSE, sub = "Correlation circle", csub = 2.5,
+ possub = "bottomleft", box = TRUE)
+ s.arrow(dudi1$co, clab = 1)
+ par(mfrow = c(1, 1))
+}}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/s.distri.Rd b/man/s.distri.Rd
new file mode 100644
index 0000000..5d87f21
--- /dev/null
+++ b/man/s.distri.Rd
@@ -0,0 +1,72 @@
+\name{s.distri}
+\alias{s.distri}
+\title{Plot of a frequency distribution}
+\description{
+performs the scatter diagram of a frequency distribution.
+}
+\usage{
+s.distri(dfxy, dfdistri, xax = 1, yax = 2, cstar = 1,
+ cellipse = 1.5, axesell = TRUE, label = names(dfdistri),
+ clabel = 0, cpoint = 1, pch = 20, xlim = NULL, ylim = NULL,
+ grid = TRUE, addaxes = TRUE, origin = c(0,0),
+ include.origin = TRUE, sub = "", csub = 1, possub = "bottomleft",
+ cgrid = 1, pixmap = NULL, contour = NULL, area = NULL, add.plot = FALSE)
+}
+\arguments{
+ \item{dfxy}{a data frame containing two columns for the axes}
+ \item{dfdistri}{a data frame containing the mass distributions in columns}
+ \item{xax}{the column number for the x-axis}
+ \item{yax}{the column number for the y-axis}
+ \item{cstar}{a number between 0 and 1 which defines the length of the star size}
+ \item{cellipse}{a positive coefficient for the inertia ellipse size}
+ \item{axesell}{a logical value indicating whether the ellipse axes should be drawn}
+ \item{label}{a vector of strings of characters for the distribution centers labels}
+ \item{clabel}{if not NULL, a character size for the labels, used with \code{par("cex")*clabel}}
+ \item{cpoint}{a character size for plotting the points, used with \code{par("cex")*cpoint}. If zero, no points are drawn}
+ \item{pch}{if \code{cpoint} > 0, an integer specifying the symbol or the single character to be used in plotting points}
+ \item{xlim}{the ranges to be encompassed by the x, if NULL they are computed}
+ \item{ylim}{the ranges to be encompassed by the y, if NULL they are computed}
+ \item{grid}{a logical value indicating whether a grid in the background of the plot should be drawn}
+ \item{addaxes}{a logical value indicating whether the axes should be plotted}
+ \item{origin}{the fixed point in the graph space, for example c(0,0) the origin axes}
+ \item{include.origin}{a logical value indicating whether the point "origin" should be belonged to the graph space}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{cgrid}{a character size, parameter used with par("cex")* \code{cgrid} to indicate the mesh of the grid}
+ \item{pixmap}{an object 'pixmap' displayed in the map background}
+ \item{contour}{a data frame with 4 columns to plot the contour of the map : each row gives a segment (x1,y1,x2,y2)}
+ \item{area}{a data frame of class 'area' to plot a set of surface units in contour}
+ \item{add.plot}{if TRUE uses the current graphics window}
+}
+\value{
+The matched call.
+}
+\author{Daniel Chessel}
+\examples{
+if(!adegraphicsLoaded()) {
+ xy <- cbind.data.frame(x = runif(200, -1, 1), y = runif(200, -1, 1))
+ distri <- data.frame(w1 = rpois(200, xy$x * (xy$x > 0)))
+ s.value(xy, distri$w1, cpoi = 1)
+ s.distri(xy, distri, add.p = TRUE)
+
+ w1 <- as.numeric((xy$x> 0) & (xy$y > 0))
+ w2 <- ((xy$x > 0) & (xy$y < 0)) * (1 - xy$y) * xy$x
+ w3 <- ((xy$x < 0) & (xy$y > 0)) * (1 - xy$x) * xy$y
+ w4 <- ((xy$x < 0) & (xy$y < 0)) * xy$y * xy$x
+
+ distri <- data.frame(a = w1 / sum(w1), b = w2 / sum(w2),
+ c = w3 / sum(w3), d = w4 / sum(w4))
+ s.value(xy, unlist(apply(distri, 1, sum)), cleg = 0, csi = 0.75)
+ s.distri(xy, distri, clab = 2, add.p = TRUE)
+
+ data(rpjdl)
+ xy <- dudi.coa(rpjdl$fau, scan = FALSE)$li
+ par(mfrow = c(3, 4))
+ for (i in c(1, 5, 8, 20, 21, 23, 26, 33, 36, 44, 47, 49)) {
+ s.distri(xy, rpjdl$fau[, i], cell = 1.5, sub = rpjdl$frlab[i],
+ csub = 2, cgrid = 1.5)}
+ par(mfrow = c(1, 1))
+}}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/s.hist.Rd b/man/s.hist.Rd
new file mode 100644
index 0000000..0d519fa
--- /dev/null
+++ b/man/s.hist.Rd
@@ -0,0 +1,33 @@
+\name{s.hist}
+\alias{s.hist}
+\title{Display of a scatterplot and its two marginal histograms}
+\description{
+ performs a scatterplot and the two marginal histograms of each axis.
+}
+\usage{
+s.hist(dfxy, xax = 1, yax = 2, cgrid = 1, cbreaks = 2, adjust = 1, ...)
+}
+\arguments{
+ \item{dfxy}{a data frame with two coordinates }
+ \item{xax}{column for the x axis }
+ \item{yax}{column for the y axis }
+ \item{cgrid}{a character size, parameter used with \code{par("cex")*cgrid} to indicate the mesh of the grid }
+ \item{cbreaks}{a parameter used to define the numbers of cells for the histograms. By default,
+ two cells are defined for each interval of the grid displayed in \code{s.label}. With an increase of the integer \code{cbreaks},
+ the number of cells increases as well.}
+ \item{adjust}{a parameter passed to \code{density} to display a kernel density estimation}
+ \item{\dots}{further arguments passed from the \code{s.label} for the scatter plot}
+}
+\value{
+The matched call.
+}
+\author{Daniel Chessel }
+\examples{
+data(rpjdl)
+coa1 <- dudi.coa(rpjdl$fau, scannf = FALSE, nf = 4)
+s.hist(coa1$li)
+s.hist(coa1$li, cgrid = 2, cbr = 3, adj = 0.5, clab = 0)
+s.hist(coa1$co, cgrid = 2, cbr = 3, adj = 0.5, clab = 0)
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/s.image.Rd b/man/s.image.Rd
new file mode 100644
index 0000000..23614f0
--- /dev/null
+++ b/man/s.image.Rd
@@ -0,0 +1,80 @@
+\name{s.image}
+\alias{s.image}
+\title{ Graph of a variable using image and contour }
+\description{
+ performs a scatterplot
+}
+\usage{
+s.image(dfxy, z, xax = 1, yax = 2, span = 0.5, xlim = NULL, ylim = NULL,
+ kgrid = 2, scale = TRUE, grid = FALSE, addaxes = FALSE, cgrid = 0,
+ include.origin = FALSE, origin = c(0, 0), sub = "", csub = 1,
+ possub = "topleft", neig = NULL, cneig = 1, image.plot = TRUE,
+ contour.plot = TRUE, pixmap = NULL, contour = NULL, area = NULL,
+ add.plot = FALSE)
+}
+\arguments{
+ \item{dfxy}{ a data frame containing the two columns for the axes }
+ \item{z}{ a vector of values on the \code{dfxy} rows }
+ \item{xax}{ the column number of x in \code{dfxy} }
+ \item{yax}{ the column number of y in \code{dfxy} }
+ \item{span}{ the parameter alpha which controls the degree of smoothing }
+ \item{xlim}{ the ranges to be encompassed by the x-axis, if NULL they are computed }
+ \item{ylim}{ the ranges to be encompassed by the y-axis, if NULL they are computed }
+ \item{kgrid}{ a number of points used to locally estimate the level line through the nodes of the grid,
+ used by \code{kgrid*sqrt(length(z))} }
+ \item{scale}{ if TRUE, data are centered and reduced }
+ \item{grid}{ if TRUE, the background grid is traced }
+ \item{addaxes}{ a logical value indicating whether the axes should be plotted }
+ \item{cgrid}{ a character size, parameter used with par("cex")* \code{cgrid} to indicate the mesh of the grid }
+ \item{include.origin}{ a logical value indicating whether the point "origin" should be belonged to the graph space }
+ \item{origin}{ the fixed point in the graph space, for example c(0,0) the origin axes }
+ \item{sub}{ a string of characters to be inserted as legend }
+ \item{csub}{ a character size for the legend, used with \code{par("cex")*csub} }
+ \item{possub}{ a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright") }
+ \item{neig}{ an object of class \code{neig} }
+ \item{cneig}{ a size for the neighbouring graph lines used with \code{par("lwd")*cneig} }
+ \item{image.plot}{ if TRUE, the image is traced }
+ \item{contour.plot}{ if TRUE, the contour lines are plotted }
+ \item{pixmap}{ an object 'pixmap' displayed in the map background }
+ \item{contour}{ a data frame with 4 columns to plot the contour of the map : each row gives a segment (x1,y1,x2,y2) }
+ \item{area}{ a data frame of class 'area' to plot a set of surface units in contour }
+ \item{add.plot}{ if TRUE uses the current graphics window }
+}
+\value{
+The matched call.
+}
+\author{Daniel Chessel}
+\examples{
+if(!adegraphicsLoaded()) {
+ if(requireNamespace("splancs", quietly = TRUE)) {
+ wxy <- data.frame(expand.grid(-3:3, -3:3))
+ names(wxy) <- c("x", "y")
+ z <- (1 / sqrt(2)) * exp(-(wxy$x ^ 2 + wxy$y ^ 2) / 2)
+ par(mfrow = c(2, 2))
+ s.value(wxy, z)
+ s.image(wxy, z)
+ s.image(wxy, z, kgrid = 5)
+ s.image(wxy, z, kgrid = 15)
+ par(mfrow = c(1, 1))
+ }
+
+ \dontrun{
+ data(t3012)
+ if(requireNamespace("splancs", quietly = TRUE)) {
+ par(mfrow = c(3, 4))
+ for(k in 1:12)
+ s.image(t3012$xy, scalewt(t3012$temp[, k]), kgrid = 3)
+ par(mfrow = c(1, 1))
+ }
+
+ data(elec88)
+ if(requireNamespace("splancs", quietly = TRUE)) {
+ par(mfrow = c(3,4))
+ for(k in 1:12)
+ s.image(t3012$xy, scalewt(t3012$temp[, k]), kgrid = 3, sub = names(t3012$temp)[k],
+ csub = 3, area = elec88$area)
+ par(mfrow = c(1, 1))
+ }
+ }
+}}
+\keyword{hplot}
diff --git a/man/s.kde2d.Rd b/man/s.kde2d.Rd
new file mode 100644
index 0000000..029a58b
--- /dev/null
+++ b/man/s.kde2d.Rd
@@ -0,0 +1,68 @@
+\name{s.kde2d}
+\alias{s.kde2d}
+\title{ Scatter Plot with Kernel Density Estimate }
+\description{
+ performs a scatter of points without labels by a kernel Density Estimation in One or Two Dimensions
+}
+\usage{
+s.kde2d(dfxy, xax = 1, yax = 2, pch = 20, cpoint = 1, neig = NULL, cneig = 2,
+ xlim = NULL, ylim = NULL, grid = TRUE, addaxes = TRUE, cgrid = 1,
+ include.origin = TRUE, origin = c(0, 0), sub = "", csub = 1.25,
+ possub = "bottomleft", pixmap = NULL, contour = NULL,
+ area = NULL, add.plot = FALSE)
+}
+\arguments{
+ \item{dfxy}{ a data frame with at least two coordinates }
+ \item{xax}{ the column number for the x-axis }
+ \item{yax}{ the column number for the y-axis}
+ \item{pch}{ if \code{cpoint} > 0, an integer specifying the symbol or the
+ single character to be used in plotting points }
+ \item{cpoint}{ a character size for plotting the points, used with
+ \code{par("cex")*cpoint}. If zero, no points are drawn }
+ \item{neig}{ a neighbouring graph }
+ \item{cneig}{ a size for the neighbouring graph lines used with
+ par("lwd")*\code{cneig} }
+ \item{xlim}{ the ranges to be encompassed by the x axis, if NULL, they are
+ computed }
+ \item{ylim}{ the ranges to be encompassed by the y axis, if NULL, they are
+ computed }
+ \item{grid}{ a logical value indicating whether a grid in the background
+ of the plot should be drawn }
+ \item{addaxes}{ a logical value indicating whether the axes should be plotted }
+ \item{cgrid}{ a character size, parameter used with par("cex")* 'cgrid' to
+ indicate the mesh of the grid }
+ \item{include.origin}{ a logical value indicating whether the point "origin"
+ should be belonged to the graph space }
+ \item{origin}{ the fixed point in the graph space, for example c(0,0) the
+ origin axes }
+ \item{sub}{ a string of characters to be inserted as legend }
+ \item{csub}{ a character size for the legend, used with \code{par("cex")*csub} }
+ \item{possub}{ a string of characters indicating the sub-title position
+ ("topleft", "topright", "bottomleft", "bottomright") }
+ \item{pixmap}{ an object \code{pixmap} displayed in the map background }
+ \item{contour}{ a data frame with 4 columns to plot the contour of the map :
+ each row gives a segment (x1,y1,x2,y2) }
+ \item{area}{ a data frame of class 'area' to plot a set of surface units
+ in contour }
+ \item{add.plot}{ if TRUE uses the current graphics window }
+}
+\value{
+The matched call.
+}
+\author{ Daniel Chessel
+}
+\examples{
+# To recognize groups of points
+if(!adegraphicsLoaded()) {
+ data(casitas)
+ casitas.fuz <- fuzzygenet(casitas)
+ casitas.pop <- as.factor(rep(c("dome", "cast", "musc", "casi"), c(24, 11, 9, 30)))
+ casitas.pca <- dudi.pca(casitas.fuz, scannf = FALSE, scale = FALSE)
+ if(requireNamespace("MASS", quietly = TRUE)) {
+ s.kde2d(casitas.pca$li)
+ s.class(casitas.pca$li, casitas.pop, cell = 0, add.p = TRUE)
+ }
+}
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/s.label.Rd b/man/s.label.Rd
new file mode 100644
index 0000000..6a63729
--- /dev/null
+++ b/man/s.label.Rd
@@ -0,0 +1,73 @@
+\name{s.label}
+\alias{s.label}
+\title{Scatter Plot}
+\description{
+performs the scatter diagrams with labels.
+}
+\usage{
+s.label(dfxy, xax = 1, yax = 2, label = row.names(dfxy),
+ clabel = 1, pch = 20, cpoint = if (clabel == 0) 1 else 0, boxes = TRUE,
+ neig = NULL, cneig = 2, xlim = NULL, ylim = NULL, grid = TRUE,
+ addaxes = TRUE, cgrid = 1, include.origin = TRUE, origin = c(0,0),
+ sub = "", csub = 1.25, possub = "bottomleft", pixmap = NULL,
+ contour = NULL, area = NULL, add.plot = FALSE)
+}
+\arguments{
+ \item{dfxy}{a data frame with at least two coordinates}
+ \item{xax}{the column number for the x-axis}
+ \item{yax}{the column number for the y-axis}
+ \item{label}{a vector of strings of characters for the point labels}
+ \item{clabel}{if not NULL, a character size for the labels, used with \code{par("cex")*clabel}}
+ \item{pch}{if \code{cpoint} > 0, an integer specifying the symbol or the single character to be used in plotting points}
+ \item{cpoint}{a character size for plotting the points, used with \code{par("cex")*cpoint}. If zero, no points are drawn}
+ \item{boxes}{if TRUE, labels are framed}
+ \item{neig}{a neighbouring graph}
+ \item{cneig}{a size for the neighbouring graph lines used with par("lwd")*\code{cneig}}
+ \item{xlim}{the ranges to be encompassed by the x axis, if NULL, they are computed}
+ \item{ylim}{the ranges to be encompassed by the y axis, if NULL, they are computed}
+ \item{grid}{a logical value indicating whether a grid in the background of the plot should be drawn}
+ \item{addaxes}{a logical value indicating whether the axes should be plotted}
+ \item{cgrid}{a character size, parameter used with par("cex")* \code{cgrid} to indicate the mesh of the grid}
+ \item{include.origin}{a logical value indicating whether the point "origin" should be belonged to the graph space}
+ \item{origin}{the fixed point in the graph space, for example c(0,0) the origin axes}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{pixmap}{an object 'pixmap' displayed in the map background}
+ \item{contour}{a data frame with 4 columns to plot the contour of the map : each row gives a segment (x1,y1,x2,y2)}
+ \item{area}{a data frame of class 'area' to plot a set of surface units in contour}
+ \item{add.plot}{if TRUE uses the current graphics window}
+}
+\value{
+The matched call.
+}
+\author{Daniel Chessel}
+\examples{
+if(!adegraphicsLoaded()) {
+ layout(matrix(c(1, 2, 3, 2), 2, 2))
+ data(atlas)
+ s.label(atlas$xy, lab = atlas$names.district,
+ area = atlas$area, inc = FALSE, addax = FALSE)
+ data(mafragh)
+ s.label(mafragh$xy, inc = FALSE, neig = mafragh$neig, addax = FALSE)
+ data(irishdata)
+ s.label(irishdata$xy, inc = FALSE, contour = irishdata$contour,
+ addax = FALSE)
+
+ par(mfrow = c(2, 2))
+ cha <- ls()
+ s.label(cbind.data.frame(runif(length(cha)),
+ runif(length(cha))), lab = cha)
+ x <- runif(50, -2, 2)
+ y <- runif(50, -2, 2)
+ z <- x^2 + y^2
+ s.label(data.frame(x, y), lab = as.character(z < 1))
+ s.label(data.frame(x, y), clab = 0, cpoi = 1, add.plot = TRUE)
+ symbols(0, 0, circles = 1, add = TRUE, inch = FALSE)
+ s.label(cbind.data.frame(runif(100, 0, 10), runif(100, 5, 12)),
+ incl = FALSE, clab = 0)
+ s.label(cbind.data.frame(runif(100, -3, 12),
+ runif(100, 2, 10)), cl = 0, cp = 2, include = FALSE)
+}}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/s.logo.Rd b/man/s.logo.Rd
new file mode 100644
index 0000000..2c74fcd
--- /dev/null
+++ b/man/s.logo.Rd
@@ -0,0 +1,65 @@
+\name{s.logo}
+\alias{s.logo}
+\alias{scatterutil.logo}
+\title{Representation of an object in a graph by a picture}
+\description{
+performs the scatter diagrams using pictures to represent the points
+}
+\usage{
+s.logo(dfxy, listlogo, klogo=NULL, clogo=1, rectlogo=TRUE,
+ xax = 1, yax = 2, neig = NULL, cneig = 1, xlim = NULL, ylim = NULL,
+ grid = TRUE, addaxes = TRUE, cgrid = 1, include.origin = TRUE,
+ origin = c(0, 0), sub = "", csub = 1.25, possub = "bottomleft",
+ pixmap = NULL, contour = NULL, area = NULL, add.plot = FALSE)
+}
+\arguments{
+ \item{dfxy}{a data frame with at least two coordinates}
+ \item{listlogo}{a list of pixmap pictures}
+ \item{klogo}{a numeric vector giving the order in which pictures of listlogo are used; if NULL, the order is the same than the rows of dfxy}
+ \item{clogo}{a numeric vector giving the size factor applied to each picture}
+ \item{rectlogo}{a logical to decide whether a rectangle should be drawn around the picture (TRUE) or not (FALSE)}
+ \item{xax}{the column number for the x-axis}
+ \item{yax}{the column number for the y-axis}
+ \item{neig}{a neighbouring graph}
+ \item{cneig}{a size for the neighbouring graph lines used with par("lwd")*\code{cneig}}
+ \item{xlim}{the ranges to be encompassed by the x axis, if NULL, they are computed}
+ \item{ylim}{the ranges to be encompassed by the y axis, if NULL, they are computed}
+ \item{grid}{a logical value indicating whether a grid in the background of the plot should be drawn}
+ \item{addaxes}{a logical value indicating whether the axes should be plotted}
+ \item{cgrid}{a character size, parameter used with par("cex")* \code{cgrid} to indicate the mesh of the grid}
+ \item{include.origin}{a logical value indicating whether the point "origin" should be belonged to the graph space}
+ \item{origin}{the fixed point in the graph space, for example c(0,0) the origin axes}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{pixmap}{an object 'pixmap' displayed in the map background}
+ \item{contour}{a data frame with 4 columns to plot the contour of the map : each row gives a segment (x1,y1,x2,y2)}
+ \item{area}{a data frame of class 'area' to plot a set of surface units in contour}
+ \item{add.plot}{if TRUE uses the current graphics window}
+}
+\value{
+The matched call.
+}
+\author{Daniel Chessel and Thibaut Jombart \email{t.jombart at imperial.ac.uk}}
+\examples{
+if(requireNamespace("pixmap", quietly = TRUE) & requireNamespace("sp", quietly = TRUE)) {
+ if(!adegraphicsLoaded()) {
+ data(ggtortoises)
+ a1 <- ggtortoises$area
+ area.plot(a1)
+ rect(min(a1$x), min(a1$y), max(a1$x), max(a1$y), col = "lightblue")
+ invisible(lapply(split(a1, a1$id), function(x) polygon(x[, -1],col = "white")))
+ s.label(ggtortoises$misc, grid = FALSE, include.ori = FALSE, addaxes = FALSE, add.p = TRUE)
+ listico <- ggtortoises$ico[as.character(ggtortoises$pop$carap)]
+ s.logo(ggtortoises$pop, listico, add.p = TRUE)
+
+ } else {
+ data(capitales, package = "ade4")
+ # 'capitales' data doesn't work with ade4 anymore
+ g3 <- s.logo(capitales$xy[sort(rownames(capitales$xy)), ], capitales$logo,
+ Sp = capitales$Spatial, pbackground.col = "lightblue", pSp.col = "white",
+ pgrid.draw = FALSE)
+ }
+}}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/s.match.Rd b/man/s.match.Rd
new file mode 100644
index 0000000..ae5d45b
--- /dev/null
+++ b/man/s.match.Rd
@@ -0,0 +1,58 @@
+\name{s.match}
+\alias{s.match}
+\title{Plot of Paired Coordinates}
+\description{
+performs the scatter diagram for a paired coordinates.
+}
+\usage{
+s.match(df1xy, df2xy, xax = 1, yax = 2, pch = 20, cpoint = 1,
+ label = row.names(df1xy), clabel=1, edge = TRUE, xlim = NULL,
+ ylim = NULL, grid = TRUE, addaxes = TRUE, cgrid = 1,
+ include.origin = TRUE, origin = c(0,0), sub = "", csub = 1.25,
+ possub = "bottomleft", pixmap = NULL, contour = NULL, area = NULL,
+ add.plot = FALSE)
+}
+\arguments{
+ \item{df1xy}{a data frame containing two columns from the first system}
+ \item{df2xy}{a data frame containing two columns from teh second system}
+ \item{xax}{the column number for the x-axis of both the two systems}
+ \item{yax}{the column number for the y-axis of both the two systems}
+ \item{pch}{if \code{cpoint} > 0, an integer specifying the symbol or the single character to be used in plotting points}
+ \item{cpoint}{a character size for plotting the points, used with \code{par("cex")*cpoint}. If zero, no points are drawn }
+ \item{label}{a vector of strings of characters for the couple labels}
+ \item{clabel}{if not NULL, a character size for the labels, used with \code{par("cex")*clabel} }
+ \item{edge}{If TRUE the arrows are plotted, otherwise only the segments are drawn}
+ \item{xlim}{the ranges to be encompassed by the x axis, if NULL they are computed}
+ \item{ylim}{the ranges to be encompassed by the y axis, if NULL they are computed}
+ \item{grid}{a logical value indicating whether a grid in the background of the plot should be drawn}
+ \item{addaxes}{a logical value indicating whether the axes should be plotted}
+ \item{cgrid}{a character size, parameter used with par("cex")* \code{cgrid} to indicate the mesh of the grid}
+ \item{include.origin}{a logical value indicating whether the point "origin" should be belonged to the graph space}
+ \item{origin}{the fixed point in the graph space, for example c(0,0) the origin axes}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{pixmap}{aan object \code{pixmap} displayed in the map background}
+ \item{contour}{a data frame with 4 columns to plot the contour of the map : each row gives a segment (x1,y1,x2,y2)}
+ \item{area}{a data frame of class 'area' to plot a set of surface units in contour}
+ \item{add.plot}{if TRUE uses the current graphics window}
+}
+\value{
+The matched call.
+}
+\author{Daniel Chessel}
+\examples{
+if(!adegraphicsLoaded()) {
+ X <- data.frame(x = runif(50, -1, 2), y = runif(50, -1, 2))
+ Y <- X + rnorm(100, sd = 0.3)
+ par(mfrow = c(2, 2))
+ s.match(X, Y)
+ s.match(X, Y, edge = FALSE, clab = 0)
+ s.match(X, Y, edge = FALSE, clab = 0)
+ s.label(X, clab = 1, add.plot = TRUE)
+ s.label(Y, clab = 0.75, add.plot = TRUE)
+ s.match(Y, X, clab = 0)
+ par(mfrow = c(1, 1))
+}}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/s.match.class.Rd b/man/s.match.class.Rd
new file mode 100644
index 0000000..0a24588
--- /dev/null
+++ b/man/s.match.class.Rd
@@ -0,0 +1,97 @@
+\name{s.match.class}
+\alias{s.match.class}
+\title{Scatterplot of two sets of coordinates and a partionning into classes}
+\description{
+Performs a graphical representation of two sets of coordinates
+(different colors and symbols) and a partitionning into classes
+}
+\usage{
+s.match.class(df1xy, df2xy, fac, wt = rep(1/nrow(df1xy), nrow(df1xy)),
+xax = 1, yax = 2, pch1 = 16, pch2 = 15, col1 = rep("lightgrey",
+nlevels(fac)), col2 = rep("darkgrey", nlevels(fac)), cpoint = 1, label =
+levels(fac), clabel = 1, cstar = 1, cellipse = 0, axesell = TRUE, xlim =
+NULL, ylim = NULL, grid = TRUE, addaxes = TRUE, cgrid = 1,
+include.origin = TRUE, origin = c(0, 0), sub = "", csub = 1.25, possub =
+"bottomleft", pixmap = NULL, contour = NULL, area = NULL, add.plot = FALSE)
+}
+
+\arguments{
+ \item{df1xy}{a dataframe with the first system of coordinates}
+ \item{df2xy}{a dataframe with the secocnd system of coordinates}
+ \item{fac}{a factor partitioning the rows of the data frame in classes}
+ \item{wt}{a vector of weights}
+ \item{xax}{a number indicating which column should be plotted on the x-axis}
+ \item{yax}{a number indicating which column should be plotted on the x-axis}
+ \item{pch1}{if \code{cpoint} > 0, an integer specifying the symbol or the single character to be used for plotting points}
+ \item{pch2}{if \code{cpoint} > 0, an integer specifying the symbol or the single character to be used for plotting points}
+ \item{col1}{a color for symbols}
+ \item{col2}{a color for symbols}
+ \item{cpoint}{a character size for plotting the points, used with \code{par("cex")*cpoint}. If zero, no points are drawn}
+ \item{label}{a vector of strings of characters for the couple labels}
+ \item{clabel}{if not NULL, a character size for the labels, used with \code{par("cex")*clabel}}
+ \item{cstar}{a number between 0 and 1 which defines the length of the star size}
+ \item{cellipse}{a positive coefficient for the inertia ellipse size}
+ \item{axesell}{a logical value indicating whether the ellipse axes should be drawn}
+ \item{xlim}{the ranges to be encompassed by the x axis, if NULL they are computed}
+ \item{ylim}{the ranges to be encompassed by the y axis, if NULL they are computed}
+ \item{grid}{a logical value indicating whether a grid in the background of the plot should be drawn}
+ \item{addaxes}{a logical value indicating whether the axes should be plotted}
+ \item{cgrid}{a character size, parameter used with par("cex")* \code{cgrid} to indicate the mesh of the grid}
+ \item{include.origin}{a logical value indicating whether the point "origin" should belong to the graph space}
+ \item{origin}{a fixed point in the graph space, for example c(0,0) for
+ the origin of axes}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{pixmap}{a \code{pixmap} object}
+ \item{contour}{a dataframe with 4 columns to plot the contour of the map : each row gives a segment (x1,y1,x2,y2)}
+ \item{area}{a dataframe of class 'area' to plot an areal map}
+ \item{add.plot}{if TRUE, add the plot to the current graphic device}
+}
+
+\value{
+The matched call.
+}
+
+\author{
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+
+\seealso{
+\code{\link{s.class}}, \code{\link{s.match}}
+}
+\examples{
+xy <- data.frame(matrix(rnorm(100), 50, 2))
+xy[, 1] <- xy[, 1] + rep(seq(0, 12, by = 3), rep(10, 5))
+xy[, 2] <- xy[, 2] + rep(seq(0, 12, by = 3), rep(10, 5))
+fac <- gl(5, 10)
+xy2 <- xy + matrix(rnorm(100), 50, 2) + 1
+
+if(adegraphicsLoaded()) {
+ mat <- rbind(xy, xy2)
+ minmat <- apply(mat, 2, min)
+ maxmat <- apply(mat, 2, max)
+ lag <- 0.1 * abs(minmat - maxmat)
+ xli <- c(minmat[1] - lag[1], maxmat[1] + lag[1])
+ yli <- c(minmat[2] - lag[2], maxmat[2] + lag[2])
+
+ g1 <- s.class(xy, fac, ellipseSize = 0, col = rep("grey45", nlevels(fac)), xlim = xli,
+ ylim = yli, plabels.cex = 0, plot = FALSE)
+ g2 <- s.class(xy2, fac, ellipseSize = 0, col = rep("grey75", nlevels(fac)), xlim = xli,
+ ylim = yli, plabels.cex = 0, plot = FALSE)
+ g3 <- s.match(g1 at stats$means, g2 at stats$means, xlim = xli, ylim = yli, plines.lwd = 2,
+ psub.text = "xy -> xy2", plot = FALSE)
+
+ g4 <- do.call("superpose", list(g1, g2))
+ g4 at Call <- call("superpose", g1 at Call, g2 at Call)
+ g4 <- do.call("superpose", list(g4, g3))
+ g4 at Call <- call("superpose", g4 at Call, g3 at Call)
+ g4
+
+} else {
+ s.match.class(xy, xy2, fac)
+}
+}
+\keyword{multivariate}
+\keyword{hplot}
+
diff --git a/man/s.multinom.Rd b/man/s.multinom.Rd
new file mode 100644
index 0000000..813cba6
--- /dev/null
+++ b/man/s.multinom.Rd
@@ -0,0 +1,77 @@
+\name{s.multinom}
+\alias{s.multinom}
+\title{Graph of frequency profiles (useful for instance in genetic)}
+\description{
+The main purpose of this function is to draw categories using scores and profiles by their gravity center.
+Confidence intervals of the average position (issued from a multinomial distribution) can be superimposed.
+}
+\usage{
+s.multinom(dfxy, dfrowprof, translate = FALSE, xax = 1, yax = 2,
+ labelcat = row.names(dfxy), clabelcat = 1, cpointcat = if (clabelcat == 0) 2 else 0,
+ labelrowprof = row.names(dfrowprof), clabelrowprof = 0.75,
+ cpointrowprof = if (clabelrowprof == 0) 2 else 0, pchrowprof = 20,
+ coulrowprof = grey(0.8), proba = 0.95, n.sample = apply(dfrowprof, 1, sum),
+ axesell = TRUE, ...)
+}
+
+\arguments{
+ \item{dfxy}{\code{dfxy} is a data frame containing at least two numerical variables.
+ The rows of \code{dfxy} are categories such as 1,2 and 3 in the triangular plot.}
+ \item{dfrowprof}{\code{dfrowprof} is a data frame whose the columns are the rows of \code{dfxy}.
+ The rows of \code{dfxy} are profiles or frequency distributions on the categories.
+ The column number of \code{dfrowprof} must be equal to the row number of \code{dfxy}.
+ \code{row.names(dfxy)} and \code{names(dfrowprof)} must be identical. }
+ \item{translate}{a logical value indicating whether the plot should be translated(TRUE) or not.
+ The origin becomes the gravity center weighted by profiles. }
+ \item{xax}{the column number of \code{dfxy} for the x-axis }
+ \item{yax}{the column number of \code{dfxy} for the y-axis }
+ \item{labelcat}{a vector of strings of characters for the labels of categories }
+ \item{clabelcat}{an integer specifying the character size for the labels of categories,
+ used with \code{par("cex")*clabelcat} }
+ \item{cpointcat}{an integer specifying the character size for the points showing the categories,
+ used with \code{par("cex")*cpointcat} }
+ \item{labelrowprof}{a vector of strings of characters for the labels of profiles (rows of \code{dfrowprof}) }
+ \item{clabelrowprof}{an integer specifying the character size for the labels of profiles
+ used with par("cex")*clabelrowprof}
+ \item{cpointrowprof}{an integer specifying the character size for the points representative
+ of the profiles used with par("cex")*cpointrowprof }
+ \item{pchrowprof}{either an integer specifying a symbol or a single character to be used for the profile labels }
+ \item{coulrowprof}{a vector of colors used for ellipses, possibly recycled}
+ \item{proba}{a value lying between 0.500 and 0.999 to draw a confidence interval }
+ \item{n.sample}{a vector containing the sample size, possibly recycled. Used \code{n.sample = 0} if the profiles
+ are not issued from a multinomial distribution and that confidence intervals have no sense. }
+ \item{axesell}{a logical value indicating whether the ellipse axes should be drawn}
+ \item{\dots}{further arguments passed from the \code{s.label} for the initial scatter plot. }
+}
+
+\value{
+ Returns in a hidden way a list of three components :
+ \item{tra}{a vector with two values giving the done original translation. }
+ \item{ell}{a matrix, with 5 columns and for rows the number of profiles, giving the means,
+ the variances and the covariance of the profile for the used
+ numerical codes (column of \code{dfxy})}
+ \item{call}{the matched call}
+}
+\author{Daniel Chessel
+}
+\examples{
+par(mfrow = c(2,2))
+par(mar = c(0.1,0.1,0.1,0.1))
+proba <- matrix(c(0.49,0.47,0.04,0.4,0.3,0.3,0.05,0.05,0.9,0.05,0.7,0.25), ncol = 3, byrow = TRUE)
+proba.df <- as.data.frame (proba)
+names(proba.df) <- c("A","B","C") ; row.names(proba.df) <- c("P1","P2","P3","P4")
+w.proba <- triangle.plot(proba.df, clab = 2, show = FALSE)
+box()
+
+w.tri = data.frame(x = c(-sqrt(1/2),sqrt(1/2),0), y = c(-1/sqrt(6),-1/sqrt(6),2/sqrt(6)))
+L3 <- c("A","B","C")
+row.names(w.tri) <- L3
+s.multinom(w.tri, proba.df, n.sample = 0, coulrowprof = "black", clabelrowprof = 1.5)
+s.multinom(w.tri, proba.df, n.sample = 30, coul = palette()[5])
+s.multinom(w.tri, proba.df, n.sample = 60, coul = palette()[6], add.p = TRUE)
+s.multinom(w.tri, proba.df, n.sample = 120, coul = grey(0.8), add.p = TRUE)
+
+print(s.multinom(w.tri, proba.df[-3,], n.sample = 0, translate = TRUE)$tra)
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/s.traject.Rd b/man/s.traject.Rd
new file mode 100644
index 0000000..54219a0
--- /dev/null
+++ b/man/s.traject.Rd
@@ -0,0 +1,58 @@
+\name{s.traject}
+\alias{s.traject}
+\title{Trajectory Plot}
+\description{
+performs the scatter diagram with trajectories.
+}
+\usage{
+s.traject(dfxy, fac = factor(rep(1, nrow(dfxy))),
+ ord = (1:length(fac)), xax = 1, yax = 2, label = levels(fac),
+ clabel = 1, cpoint = 1, pch = 20, xlim = NULL, ylim = NULL,
+ grid = TRUE, addaxes = TRUE, edge = TRUE, origin = c(0,0),
+ include.origin = TRUE, sub = "", csub = 1, possub = "bottomleft",
+ cgrid = 1, pixmap = NULL, contour = NULL, area = NULL, add.plot = FALSE)
+}
+\arguments{
+ \item{dfxy}{a data frame containing two columns for the axes}
+ \item{fac}{a factor partioning the rows of the data frame in classes}
+ \item{ord}{a vector of length equal to fac. The trajectory is drawn in an ascending order of the ord values}
+ \item{xax}{the column number for the x-axis}
+ \item{yax}{the column number for the y-axis}
+ \item{label}{a vector of strings of characters for the point labels}
+ \item{clabel}{if not NULL, a character size for the labels, used with \code{par("cex")*clabel}}
+ \item{cpoint}{a character size for plotting the points, used with \code{par("cex")*cpoint}. If zero, no points are drawn}
+ \item{pch}{if \code{cpoint} > 0, an integer specifying the symbol or the single character to be used in plotting points}
+ \item{xlim}{the ranges to be encompassed by the x, if NULL they are computed}
+ \item{ylim}{the ranges to be encompassed by the y, if NULL they are computed}
+ \item{grid}{a logical value indicating whether a grid in the background of the plot should be drawn}
+ \item{addaxes}{a logical value indicating whether the axes should be plotted}
+ \item{edge}{if TRUE the arrows are plotted, otherwhise only the segments}
+ \item{origin}{the fixed point in the graph space, for example c(0,0) the origin axes}
+ \item{include.origin}{a logical value indicating whether the point "origin" should be belonged to the graph space}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{cgrid}{a character size, parameter used with \code{par("cex")*cgrid} to indicate the mesh of the grid}
+ \item{pixmap}{aan object 'pixmap' displayed in the map background}
+ \item{contour}{a data frame with 4 columns to plot the contour of the map : each row gives a segment (x1,y1,x2,y2)}
+ \item{area}{a data frame of class 'area' to plot a set of surface units in contour}
+ \item{add.plot}{if TRUE uses the current graphics window}
+}
+\value{
+The matched call.
+}
+\author{Daniel Chessel}
+\examples{
+if(!adegraphicsLoaded()) {
+ rw <- function(a) {
+ x <- 0
+ for(i in 1:49) x <- c(x, x[length(x)] + runif(1, -1, 1))
+ x
+ }
+ y <- unlist(lapply(1:5, rw))
+ x <- unlist(lapply(1:5, rw))
+ z <- gl(5, 50)
+ s.traject(data.frame(x, y), z, edge = FALSE)
+}}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/s.value.Rd b/man/s.value.Rd
new file mode 100644
index 0000000..102165d
--- /dev/null
+++ b/man/s.value.Rd
@@ -0,0 +1,73 @@
+\name{s.value}
+\alias{s.value}
+\title{Representation of a value in a graph}
+\description{
+performs the scatter diagram with the representation of a value for a variable
+}
+\usage{
+s.value(dfxy, z, xax = 1, yax = 2, method = c("squaresize", "greylevel"),
+ zmax=NULL, csize = 1, cpoint = 0, pch = 20, clegend = 0.75, neig = NULL,
+ cneig = 1, xlim = NULL, ylim = NULL, grid = TRUE, addaxes = TRUE,
+ cgrid = 0.75, include.origin = TRUE, origin = c(0,0), sub = "",
+ csub = 1, possub = "topleft", pixmap = NULL, contour = NULL,
+ area = NULL, add.plot = FALSE)
+}
+\arguments{
+ \item{dfxy}{a data frame with two coordinates}
+ \item{z}{a vector of the values corresponding to the rows of \code{dfxy}}
+ \item{xax}{column for the x axis}
+ \item{yax}{column for the y axis}
+ \item{method}{a string of characters \cr
+ "squaresize" gives black squares for positive values and white for negative values with a proportional area equal to the absolute value. \cr
+ "greylevel" gives squares of equal size with a grey level proportional to the value. By default the first choice}
+ \item{zmax}{a numeric value, equal by default to max(abs(z)), can be used to impose a common scale of the size of the squares to several drawings in the same device}
+ \item{csize}{a size coefficient for symbols}
+ \item{cpoint}{a character size for plotting the points, used with \code{par("cex")*cpoint}. If zero, no points are drawn}
+ \item{pch}{if \code{cpoint} > 0, an integer specifying the symbol or the single character to be used in plotting points}
+ \item{clegend}{a character size for the legend used by \code{par("cex")*clegend}}
+ \item{neig}{a neighbouring graph}
+ \item{cneig}{a size for the neighbouring graph lines used with \code{par("lwd")*cneig}}
+ \item{xlim}{the ranges to be encompassed by the x, if NULL they are computed}
+ \item{ylim}{the ranges to be encompassed by the y, if NULL they are computed}
+ \item{grid}{a logical value indicating whether a grid in the background of the plot should be drawn}
+ \item{addaxes}{a logical value indicating whether the axes should be plotted}
+ \item{cgrid}{a character size, parameter used with \code{par("cex")*cgrid} to indicate the mesh of the grid}
+ \item{include.origin}{a logical value indicating whether the point "origin" should be belonged to the graph space}
+ \item{origin}{the fixed point in the graph space, for example c(0,0) the origin axes}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{pixmap}{an object 'pixmap' displayed in the map background}
+ \item{contour}{a data frame with 4 columns to plot the contour of the map : each row gives a segment (x1,y1,x2,y2)}
+ \item{area}{a data frame of class 'area' to plot a set of surface units in contour}
+ \item{add.plot}{if TRUE uses the current graphics window}
+}
+\value{
+The matched call.
+}
+\author{Daniel Chessel}
+\examples{
+if(!adegraphicsLoaded()) {
+ xy <- cbind.data.frame(x = runif(500), y = runif(500))
+ z <- rnorm(500)
+ s.value(xy, z)
+
+ s.value(xy, z, method = "greylevel")
+
+ data(rpjdl)
+ fau.coa <- dudi.coa(rpjdl$fau, scan = FALSE, nf = 3)
+ s.value(fau.coa$li, fau.coa$li[,3], csi = 0.75, cleg = 0.75)
+
+ data(irishdata)
+ par(mfrow = c(3, 4))
+ irq0 <- data.frame(scale(irishdata$tab, scale = TRUE))
+ for (i in 1:12) {
+ z <- irq0[, i]
+ nam <- names(irq0)[i]
+ s.value(irishdata$xy, z, area = irishdata$area, csi = 3,
+ csub = 2, sub = nam, cleg = 1.5, cgrid = 0, inc = FALSE,
+ xlim = c(16, 205), ylim = c(-50, 268), adda = FALSE, grid = FALSE)
+ }
+}}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/santacatalina.Rd b/man/santacatalina.Rd
new file mode 100644
index 0000000..e907d3f
--- /dev/null
+++ b/man/santacatalina.Rd
@@ -0,0 +1,36 @@
+\name{santacatalina}
+\alias{santacatalina}
+\docType{data}
+\title{Indirect Ordination}
+\description{
+This data set gives the densities per hectare of 11 species of trees
+for 10 transects of topographic moisture values (mean of several stations per class).
+}
+\usage{data(santacatalina)}
+\format{
+a data frame with 11 rows and 10 columns
+}
+\source{
+Gauch, H. G. J., Chase, G. B. and Whittaker R. H. (1974)
+Ordination of vegetation samples by Gaussian species distributions.
+\emph{Ecology}, \bold{55}, 1382--1390.
+}
+\examples{
+data(santacatalina)
+coa1 <- dudi.coa(log(santacatalina + 1), scan = FALSE) # 2 factors
+
+if(adegraphicsLoaded()) {
+ g1 <- table.value(log(santacatalina + 1), plot = FALSE)
+ g2 <- table.value(log(santacatalina + 1)[, sample(10)], plot = FALSE)
+ g3 <- table.value(log(santacatalina + 1)[order(coa1$li[, 1]), order(coa1$co[, 1])], plot = FALSE)
+ g4 <- scatter(coa1, posi = "bottomright", plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+} else {
+ par(mfrow = c(2, 2))
+ table.value(log(santacatalina + 1))
+ table.value(log(santacatalina + 1)[, sample(10)])
+ table.value(log(santacatalina + 1)[order(coa1$li[, 1]), order(coa1$co[, 1])])
+ scatter(coa1, posi = "bottomright")
+ par(mfrow = c(1, 1))
+}}
+\keyword{datasets}
diff --git a/man/sarcelles.Rd b/man/sarcelles.Rd
new file mode 100644
index 0000000..c915247
--- /dev/null
+++ b/man/sarcelles.Rd
@@ -0,0 +1,41 @@
+\name{sarcelles}
+\alias{sarcelles}
+\docType{data}
+\title{Array of Recapture of Rings}
+\description{
+The data frame \code{sarcelles$tab} contains the number of the winter teals (\emph{Anas C. Crecca})
+for which the ring was retrieved in the area \emph{i} during the month \emph{j} (\emph{n}=3049).
+}
+\usage{data(sarcelles)}
+\format{
+ \code{sarcelles} is a list of 4 components.
+ \describe{
+ \item{tab}{is a data frame with 14 rows-areas and 12 columns-months.}
+ \item{xy}{is a data frame with the 2 spatial coordinates of the 14 region centers.}
+ \item{neig}{is the neighbouring graph between areas, object of the class \code{neig}.}
+ \item{col.names}{is a vector containing the month items}
+ }
+}
+\source{
+ Lebreton, J.D. (1973)
+ Etude des déplacements saisonniers des Sarcelles d'hiver,
+ Anas c. crecca L., hivernant en Camargue à l'aide de l'analyse factorielle des correspondances.
+ \emph{Compte rendu hebdomadaire des séances de l'Académie des sciences}, Paris, D, III, \bold{277}, 2417--2420.
+}
+\examples{
+\dontrun{
+if(!adegraphicsLoaded()) {
+ # depends of pixmap
+ if(requireNamespace("pixmap", quietly = TRUE)) {
+ bkgnd.pnm <- pixmap::read.pnm(system.file("pictures/sarcelles.pnm", package = "ade4"))
+ data(sarcelles)
+ par(mfrow = c(4, 3))
+ for(i in 1:12) {
+ s.distri(sarcelles$xy, sarcelles$tab[, i], pixmap = bkgnd.pnm,
+ sub = sarcelles$col.names[i], clab = 0, csub = 2)
+ s.value(sarcelles$xy, sarcelles$tab[, i], add.plot = TRUE, cleg = 0)
+ }
+ par(mfrow = c(1, 1))
+ }
+}}}
+\keyword{datasets}
diff --git a/man/scalewt.Rd b/man/scalewt.Rd
new file mode 100644
index 0000000..b894cac
--- /dev/null
+++ b/man/scalewt.Rd
@@ -0,0 +1,57 @@
+\name{scalewt}
+\alias{covwt}
+\alias{varwt}
+\alias{scalewt}
+\alias{meanfacwt}
+\alias{varfacwt}
+\alias{covfacwt}
+\alias{scalefacwt}
+\title{Compute or scale data using (weighted) means, variances and
+ covariances (possibly for the levels of a factor)}
+\description{
+These utility functions compute (weighted) means, variances and covariances for
+ dataframe partitioned by a factor. The scale transforms a numeric matrix in a centred and scaled matrix for any weighting.
+}
+\usage{
+covwt(x, wt, na.rm = FALSE)
+varwt(x, wt, na.rm = FALSE)
+scalewt(df, wt = rep(1/nrow(df), nrow(df)), center = TRUE, scale = TRUE)
+meanfacwt(df, fac = NULL, wt = rep(1/nrow(df), nrow(df)), drop = FALSE)
+varfacwt(df, fac = NULL, wt = rep(1/nrow(df), nrow(df)), drop = FALSE)
+covfacwt(df, fac = NULL, wt = rep(1/nrow(df), nrow(df)), drop = FALSE)
+scalefacwt(df, fac = NULL, wt = rep(1/nrow(df), nrow(df)), scale = TRUE, drop = FALSE)
+
+}
+\arguments{
+ \item{x}{a numeric vector (\code{varwt}) or a matrix (\code{covwt})
+ containg the data.}
+ \item{na.rm}{a logical value indicating whether NA values should be stripped before the computation proceeds.}
+ \item{df}{a matrix or a dataframe containing the data.}
+ \item{fac}{a factor partitioning the data.}
+ \item{wt}{a numeric vector of weights.}
+ \item{drop}{a logical value indicating whether unused levels should be kept.}
+ \item{scale}{a logical value indicating whether data should be scaled or not.}
+ \item{center}{a logical value indicating whether data should be centered or not.}
+}
+
+\details{
+Functions returns biased estimates of variances and covariances
+(i.e. divided by n and not n-1)
+}
+\value{
+For \code{varwt}, the weighted variance. For \code{covwt},
+the matrix of weighted co-variances. For \code{scalewt}, the scaled
+dataframe. For other function a list (if \code{fac} is not null) of dataframes with approriate values
+}
+
+\author{Stéphane Dray \email{stephane.dray at univ-lyon1.fr}}
+\examples{
+data(meau)
+w <- rowSums(meau$spe)
+varwt(meau$env, w)
+varfacwt(meau$env, wt = w)
+varfacwt(meau$env, wt = w, fac = meau$design$season)
+covfacwt(meau$env, wt = w, fac = meau$design$season)
+scalewt(meau$env, wt = w)
+}
+\keyword{utilities}
diff --git a/man/scatter.Rd b/man/scatter.Rd
new file mode 100644
index 0000000..ad6bb8e
--- /dev/null
+++ b/man/scatter.Rd
@@ -0,0 +1,45 @@
+\name{scatter}
+\alias{scatter}
+\alias{biplot.dudi}
+\alias{screeplot.dudi}
+\title{Graphical representation of the outputs of a multivariate analysis}
+\description{
+\code{scatter} is a generic function that has methods for the classes
+\code{coa}, \code{dudi}, \code{fca}, \code{acm} and \code{pco}.
+It plots the outputs of a multivariate analysis by representing
+simultaneously the rows and the colums of the original table
+(biplot). The function \code{biplot} returns exactly the same
+representation. \cr
+The function \code{screeplot} represents the amount of inertia (usually
+variance) associated to each dimension.
+}
+\usage{
+scatter(x, \dots)
+\method{biplot}{dudi}(x, \dots)
+\method{screeplot}{dudi}(x, npcs = length(x$eig), type = c("barplot", "lines"),
+ main = deparse(substitute(x)), col = c(rep("black", x$nf),
+rep("grey", npcs - x$nf)), \dots)
+}
+\arguments{
+ \item{x}{an object of the class \code{dudi} containing the outputs of
+ a multivariate analysis}
+ \item{npcs}{the number of components to be plotted}
+ \item{type}{the type of plot}
+ \item{main}{the title of the plot}
+ \item{col}{a vector of colors}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\seealso{\code{\link{s.arrow}}, \code{\link{s.chull}}, \code{\link{s.class}},
+\code{\link{s.corcircle}}, \code{\link{s.distri}}, \code{\link{s.label}},
+\code{\link{s.match}}, \code{\link{s.traject}}, \code{\link{s.value}}, \code{\link{add.scatter}}
+}
+\author{Daniel Chessel \cr
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}}
+\examples{
+data(rpjdl)
+rpjdl.coa <- dudi.coa(rpjdl$fau, scannf = FALSE, nf = 4)
+screeplot(rpjdl.coa)
+biplot(rpjdl.coa)
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/scatter.acm.Rd b/man/scatter.acm.Rd
new file mode 100644
index 0000000..60a9ffd
--- /dev/null
+++ b/man/scatter.acm.Rd
@@ -0,0 +1,31 @@
+\name{scatter.acm}
+\alias{scatter.acm}
+\title{Plot of the factorial maps in a Multiple Correspondence Analysis}
+\description{
+performs the scatter diagrams of a Multiple Correspondence Analysis.
+}
+\usage{
+\method{scatter}{acm}(x, xax = 1, yax = 2, mfrow=NULL, csub = 2, possub = "topleft", ...)
+}
+\arguments{
+ \item{x}{an object of class \code{acm}}
+ \item{xax}{the column number for the x-axis}
+ \item{yax}{the column number for the y-axis}
+ \item{mfrow}{a vector of the form "c(nr,nc)", if NULL (the default) is
+ computed by \code{n2mfrow}}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the legend position ("topleft",
+ "topright", "bottomleft", "bottomright") in a array of figures}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\author{Daniel Chessel}
+\examples{
+data(lascaux)
+if(adegraphicsLoaded()) {
+ plot(dudi.acm(lascaux$ornem, sca = FALSE))
+} else {
+ scatter(dudi.acm(lascaux$ornem, sca = FALSE), csub = 3)
+}
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/scatter.coa.Rd b/man/scatter.coa.Rd
new file mode 100644
index 0000000..4f35c74
--- /dev/null
+++ b/man/scatter.coa.Rd
@@ -0,0 +1,48 @@
+\name{scatter.coa}
+\alias{scatter.coa}
+\title{Plot of the factorial maps for a correspondence analysis}
+\description{
+performs the scatter diagrams of a correspondence analysis.
+}
+\usage{
+\method{scatter}{coa}(x, xax = 1, yax = 2, method = 1:3, clab.row = 0.75,
+ clab.col = 1.25, posieig = "top", sub = NULL, csub = 2, \dots)
+}
+\arguments{
+ \item{x}{an object of class \code{coa}}
+ \item{xax}{the column number for the x-axis}
+ \item{yax}{the column number for the y-axis}
+ \item{method}{an integer between 1 and 3 \cr
+ 1 Rows and columns with the coordinates of lambda variance\cr
+ 2 Columns variance 1 and rows by averaging\cr
+ 3 Rows variance 1 and columns by averaging}
+ \item{clab.row}{a character size for the rows}
+ \item{clab.col}{a character size for the columns}
+ \item{posieig}{if "top" the eigenvalues bar plot is upside,vif "bottom" it is downside, if "none" no plot}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\references{Oksanen, J. (1987) Problems of joint display of species and site scores in correspondence analysis. \emph{Vegetatio}, \bold{72}, 51--57.
+}
+\author{Daniel Chessel}
+\examples{
+data(housetasks)
+w <- dudi.coa(housetasks, scan = FALSE)
+if(adegraphicsLoaded()) {
+ g1 <- scatter(w, method = 1, psub.text = "1 / Standard", posieig = "none", plot = FALSE)
+ g2 <- scatter(w, method = 2, psub.text = "2 / Columns -> averaging -> Rows",
+ posieig = "none", plot = FALSE)
+ g3 <- scatter(w, method = 3, psub.text = "3 / Rows -> averaging -> Columns ",
+ posieig = "none", plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2, 2))
+ scatter(w, method = 1, sub = "1 / Standard", posieig = "none")
+ scatter(w, method = 2, sub = "2 / Columns -> averaging -> Rows", posieig = "none")
+ scatter(w, method = 3, sub = "3 / Rows -> averaging -> Columns ", posieig = "none")
+ par(mfrow = c(1, 1))
+}}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/scatter.dudi.Rd b/man/scatter.dudi.Rd
new file mode 100644
index 0000000..4485ee0
--- /dev/null
+++ b/man/scatter.dudi.Rd
@@ -0,0 +1,43 @@
+\name{scatter.dudi}
+\alias{scatter.dudi}
+\title{Plot of the Factorial Maps}
+\description{
+performs the scatter diagrams of objects of class \code{dudi}.
+}
+\usage{
+\method{scatter}{dudi}(x, xax = 1, yax = 2, clab.row = 0.75, clab.col = 1,
+ permute = FALSE, posieig = "top", sub = NULL, \dots)
+}
+\arguments{
+ \item{x}{an object of class \code{dudi}}
+ \item{xax}{the column number for the x-axis}
+ \item{yax}{the column number for the y-axis}
+ \item{clab.row}{a character size for the rows}
+ \item{clab.col}{a character size for the columns}
+ \item{permute}{if FALSE, the rows are plotted by points and the columns by arrows. If TRUE it is the opposite.}
+ \item{posieig}{if "top" the eigenvalues bar plot is upside, if "bottom" it is downside, if "none" no plot}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\details{
+\code{scatter.dudi} is a factorial map of individuals and the projection of the vectors of the canonical basis multiplied by a constante of rescaling. In the eigenvalues bar plot,the used axes for the plot are in black, the other kept axes in grey and the other in white.
+
+The \code{permute} argument can be used to choose between the distance biplot (default) and the correlation biplot (permute = TRUE).
+
+}
+\author{Daniel Chessel}
+\examples{
+data(deug)
+scatter(dd1 <- dudi.pca(deug$tab, scannf = FALSE, nf = 4),
+ posieig = "bottomright")
+
+data(rhone)
+dd1 <- dudi.pca(rhone$tab, nf = 4, scann = FALSE)
+if(adegraphicsLoaded()) {
+ scatter(dd1, row.psub.text = "Principal component analysis")
+} else {
+ scatter(dd1, sub = "Principal component analysis")
+}
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/scatter.fca.Rd b/man/scatter.fca.Rd
new file mode 100644
index 0000000..df996c3
--- /dev/null
+++ b/man/scatter.fca.Rd
@@ -0,0 +1,40 @@
+\name{scatter.fca}
+\alias{scatter.fca}
+\title{Plot of the factorial maps for a fuzzy correspondence analysis}
+\description{
+performs the scatter diagrams of a fuzzy correspondence analysis.
+}
+\usage{
+\method{scatter}{fca}(x, xax = 1, yax = 2, clab.moda = 1, labels = names(x$tab),
+ sub = NULL, csub = 2, \dots)
+}
+\arguments{
+ \item{x}{an object of class \code{fca}}
+ \item{xax}{the column number for the x-axis}
+ \item{yax}{the column number for the y-axis}
+ \item{clab.moda}{the character size to write the modalities}
+ \item{labels}{a vector of strings of characters for the labels of the modalities}
+ \item{sub}{a vector of strings of characters to be inserted as legend in each figure}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\author{Daniel Chessel
+}
+\references{
+Chevenet, F., Dolédec, S. and Chessel, D. (1994)
+A fuzzy coding approach for the analysis of long-term ecological data. \emph{Freshwater Biology}, \bold{31}, 295--309.
+}
+\examples{
+data(coleo)
+coleo.fuzzy <- prep.fuzzy.var(coleo$tab, coleo$col.blocks)
+fca1 <- dudi.fca(coleo.fuzzy, sca = FALSE, nf = 3)
+
+if(adegraphicsLoaded()) {
+ plot(fca1)
+} else {
+ scatter(fca1, labels = coleo$moda.names, clab.moda = 1.5,
+ sub = names(coleo$col.blocks), csub = 3)
+}
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/scatterutil.Rd b/man/scatterutil.Rd
new file mode 100644
index 0000000..0d11b89
--- /dev/null
+++ b/man/scatterutil.Rd
@@ -0,0 +1,94 @@
+\name{scatterutil}
+\alias{scatterutil}
+\alias{scatterutil.base}
+\alias{scatterutil.sco}
+\alias{scatterutil.chull}
+\alias{scatterutil.eigen}
+\alias{scatterutil.ellipse}
+\alias{scatterutil.eti.circ}
+\alias{scatterutil.eti}
+\alias{scatterutil.grid}
+\alias{scatterutil.legend.bw.square}
+\alias{scatterutil.legend.square.grey}
+\alias{scatterutil.legendgris}
+\alias{scatterutil.scaling}
+\alias{scatterutil.star}
+\alias{scatterutil.sub}
+\alias{scatterutil.convrot90}
+\title{Graphical utility functions}
+\description{
+These are utilities used in graphical functions.
+}
+
+\details{
+ The functions scatter use some utilities functions :
+ \describe{
+ \item{scatterutil.base}{defines the layer of the plot for all
+ scatters}
+ \item{scatterutil.sco}{defines the layer of the plot for sco functions}
+ \item{scatterutil.chull}{plots the polygons of the external contour}
+ \item{scatterutil.eigen}{plots the eigenvalues bar plot}
+ \item{scatterutil.ellipse}{plots an inertia ellipse for a weighting distribution}
+ \item{scatterutil.eti.circ}{puts labels on a correlation circle}
+ \item{scatterutil.eti}{puts labels centred on the points}
+ \item{scatterutil.grid}{plots a grid and adds a legend}
+ \item{scatterutil.legend.bw.square}{puts a legend of values by square size}
+ \item{scatterutil.legend.square.grey}{puts a legend by squares and grey levels}
+ \item{scatterutil.legendgris}{adds a legend of grey levels for the areas}
+ \item{scatterutil.scaling}{to fit a plot on a background bipmap}
+ \item{scatterutil.star}{plots a star for a weighting distribution}
+ \item{scatterutil.sub}{adds a string of characters in sub-title of a
+ graph}
+ \item{scatterutil.convrot90}{is used to rotate labels}
+ }
+}
+\seealso{\code{\link{s.arrow}}, \code{\link{s.chull}}, \code{\link{s.class}},
+\code{\link{s.corcircle}}, \code{\link{s.distri}}, \code{\link{s.label}},
+\code{\link{s.match}}, \code{\link{s.traject}}, \code{\link{s.value}}, \code{\link{add.scatter}}
+}
+\author{Daniel Chessel, Stéphane Dray \email{stephane.dray at univ-lyon1.fr}}
+\examples{
+par(mfrow = c(3,3))
+plot.new()
+ade4:::scatterutil.legendgris(1:20, 4, 1.6)
+
+plot.new()
+ade4:::scatterutil.sub("lkn5555555555lkn", csub = 2, possub = "bottomleft")
+ade4:::scatterutil.sub("lkn5555555555lkn", csub = 1, possub = "topleft")
+ade4:::scatterutil.sub("jdjjl", csub = 3, possub = "topright")
+ade4:::scatterutil.sub("**", csub = 2, possub = "bottomright")
+
+x <- c(0.5,0.2,-0.5,-0.2) ; y <- c(0.2,0.5,-0.2,-0.5)
+eti <- c("toto", "kjbk", "gdgiglgl", "sdfg")
+plot(x, y, xlim = c(-1,1), ylim = c(-1,1))
+ade4:::scatterutil.eti.circ(x, y, eti, 2.5)
+abline(0, 1, lty = 2) ; abline(0, -1, lty = 2)
+
+x <- c(0.5,0.2,-0.5,-0.2) ; y <- c(0.2,0.5,-0.2,-0.5)
+eti <- c("toto", "kjbk", "gdgiglgl", "sdfg")
+plot(x, y, xlim = c(-1,1), ylim = c(-1,1))
+ade4:::scatterutil.eti(x, y, eti, 1.5)
+
+plot(runif(10,-3,5), runif(10,-1,1), asp = 1)
+ade4:::scatterutil.grid(2)
+abline(h = 0, v = 0, lwd = 3)
+
+x <- runif(10,0,1) ; y <- rnorm(10) ; z <- rep(1,10)
+plot(x,y) ; ade4:::scatterutil.star(x, y, z, 0.5)
+plot(x,y) ; ade4:::scatterutil.star(x, y, z, 1)
+
+x <- c(runif(10,0,0.5), runif(10,0.5,1))
+y <- runif(20)
+plot(x, y, asp = 1) # asp=1 is essential to have perpendicular axes
+ade4:::scatterutil.ellipse(x, y, rep(c(1,0), c(10,10)), cell = 1.5, ax = TRUE)
+ade4:::scatterutil.ellipse(x, y, rep(c(0,1), c(10,10)), cell = 1.5, ax = TRUE)
+
+x <- c(runif(100,0,0.75), runif(100,0.25,1))
+y <- c(runif(100,0,0.75), runif(100,0.25,1))
+z <- factor(rep(c(1,2), c(100,100)))
+plot(x, y, pch = rep(c(1,20), c(100,100)))
+ade4:::scatterutil.chull(x, y, z, opt = c(0.25,0.50,0.75,1))
+par(mfrow = c(1,1))
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/sco.boxplot.Rd b/man/sco.boxplot.Rd
new file mode 100644
index 0000000..80f73be
--- /dev/null
+++ b/man/sco.boxplot.Rd
@@ -0,0 +1,45 @@
+\name{sco.boxplot}
+\alias{sco.boxplot}
+\title{Representation of the link between a variable and a set of qualitative variables}
+\description{
+represents the link between a variable and a set of qualitative variables.
+}
+\usage{
+sco.boxplot(score, df, labels = names(df), clabel = 1, xlim = NULL,
+ grid = TRUE, cgrid = 0.75, include.origin = TRUE, origin = 0,
+ sub = NULL, csub = 1)
+}
+\arguments{
+ \item{score}{a numeric vector}
+ \item{df}{a data frame with only factors}
+ \item{labels}{a vector of strings of characters for the labels of variables}
+ \item{clabel}{if not NULL, a character size for the labels, used with \code{par("cex")*clabel}}
+ \item{xlim}{the ranges to be encompassed by the x axis, if NULL they are computed}
+ \item{grid}{a logical value indicating whether the scale vertical lines should be drawn}
+ \item{cgrid}{a character size, parameter used with \code{par("cex")*cgrid} to indicate the mesh of the scale}
+ \item{include.origin}{a logical value indicating whether the point "origin" should be belonged to the graph space}
+ \item{origin}{the fixed point in the graph space, for example 0 the origin axis}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+}
+\author{
+Daniel Chessel
+}
+\examples{
+w1 <- rnorm(100,-1)
+w2 <- rnorm(100)
+w3 <- rnorm(100,1)
+f1 <- gl(3,100)
+f2 <- gl(30,10)
+sco.boxplot(c(w1,w2,w3), data.frame(f1,f2))
+
+data(banque)
+banque.acm <- dudi.acm(banque, scan = FALSE, nf = 4)
+par(mfrow = c(1,3))
+sco.boxplot(banque.acm$l1[,1], banque[,1:7], clab = 1.8)
+sco.boxplot(banque.acm$l1[,1], banque[,8:14], clab = 1.8)
+sco.boxplot(banque.acm$l1[,1], banque[,15:21], clab = 1.8)
+par(mfrow = c(1,1))
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/sco.class.Rd b/man/sco.class.Rd
new file mode 100644
index 0000000..a597d80
--- /dev/null
+++ b/man/sco.class.Rd
@@ -0,0 +1,53 @@
+\name{sco.class}
+\alias{sco.class}
+\title{1D plot of a numeric score and a factor with labels}
+\description{
+Draws evenly spaced labels, each label linked to the corresponding
+values of the levels of a factor.
+}
+\usage{
+sco.class(score, fac, label = levels(fac), clabel = 1, horizontal = TRUE,
+ reverse = FALSE, pos.lab = 0.5, pch = 20, cpoint = 1, boxes = TRUE,
+ col = rep(1, length(levels(fac))), lim = NULL, grid = TRUE,
+ cgrid = 1, include.origin = TRUE, origin = c(0, 0), sub = "",
+ csub = 1.25, possub = "bottomleft")
+}
+\arguments{
+ \item{score}{a numeric vector}
+ \item{fac}{a factor}
+ \item{label}{labels for the levels of the factor}
+ \item{clabel}{a character size for the labels, used with
+ \code{par("cex")*clabel}}
+ \item{horizontal}{logical. If TRUE, the plot is horizontal}
+ \item{reverse}{logical. If horizontal = TRUE and reverse=TRUE, the
+ plot is at the bottom, if reverse = FALSE, the plot is at the top. If
+ horizontal = FALSE, the plot is at the right (TRUE) or at the left
+ (FALSE).}
+ \item{pos.lab}{a values between 0 and 1 to manage the position of the
+ labels.}
+ \item{pch}{an integer specifying the symbol or the single character to be used in plotting points}
+ \item{cpoint}{a character size for plotting the points, used with \code{par("cex")*cpoint}. If zero, no points are drawn}
+ \item{boxes}{if TRUE, labels are framed}
+ \item{col}{a vector of colors used to draw each class in a different color}
+ \item{lim}{the range for the x axis or y axis (if horizontal = FALSE), if NULL, they are computed}
+ \item{grid}{a logical value indicating whether a grid in the background of the plot should be drawn}
+ \item{cgrid}{a character size, parameter used with par("cex")* \code{cgrid} to indicate the mesh of the grid}
+ \item{include.origin}{a logical value indicating whether the point "origin" should belong to the plot}
+ \item{origin}{the fixed point in the graph space, for example c(0,0) the origin axes}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+}
+\value{
+The matched call.
+}
+\author{Stéphane Dray \email{stephane.dray at univ-lyon1.fr}}
+\examples{
+data(meau)
+envpca <- dudi.pca(meau$env, scannf=FALSE)
+par(mfrow=c(2,1))
+sco.class(envpca$li[,1],meau$design$season, col = 1:6)
+sco.class(envpca$li[,1],meau$design$season, col = 1:4, reverse = TRUE)
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/sco.distri.Rd b/man/sco.distri.Rd
new file mode 100644
index 0000000..90fdb86
--- /dev/null
+++ b/man/sco.distri.Rd
@@ -0,0 +1,67 @@
+\name{sco.distri}
+\alias{sco.distri}
+\title{Representation by mean- standard deviation of a set of weight distributions on a numeric score}
+\description{
+represents the mean- standard deviation of a set of weight distributions on a numeric score.
+}
+\usage{
+sco.distri(score, df, y.rank = TRUE, csize = 1, labels = names(df),
+ clabel = 1, xlim = NULL, grid = TRUE, cgrid = 0.75,
+ include.origin = TRUE, origin = 0, sub = NULL, csub = 1)
+}
+\arguments{
+ \item{score}{a numeric vector}
+ \item{df}{a data frame with only positive or null values}
+ \item{y.rank}{a logical value indicating whether the means should be classified in ascending order}
+ \item{csize}{an integer indicating the size segment}
+ \item{labels}{a vector of strings of characters for the labels of the variables}
+ \item{clabel}{if not NULL, a character size for the labels, used with \code{par("cex")*clabel}}
+ \item{xlim}{the ranges to be encompassed by the x axis, if NULL they are computed}
+ \item{grid}{a logical value indicating whether the scale vertical lines should be drawn}
+ \item{cgrid}{a character size, parameter used with \code{par("cex")*cgrid} to indicate the mesh of the scale}
+ \item{include.origin}{a logical value indicating whether the point "origin" should be belonged to the graph space}
+ \item{origin}{the fixed point in the graph space, for example c(0,0) the origin axes}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+}
+\value{
+returns an invisible data.frame with means and variances
+}
+\author{Daniel Chessel}
+\examples{
+if(!adegraphicsLoaded()) {
+ w <- seq(-1, 1, le = 200)
+ distri <- data.frame(lapply(1:50,
+ function(x) sample((200:1)) * ((w >= (- x / 50)) & (w <= x / 50))))
+ names(distri) <- paste("w", 1:50, sep = "")
+ par(mfrow = c(1, 2))
+ sco.distri(w, distri, csi = 1.5)
+ sco.distri(w, distri, y.rank = FALSE, csi = 1.5)
+ par(mfrow = c(1, 1))
+
+ data(rpjdl)
+ coa2 <- dudi.coa(rpjdl$fau, FALSE)
+ sco.distri(coa2$li[, 1], rpjdl$fau, lab = rpjdl$frlab, clab = 0.8)
+
+ data(doubs)
+ par(mfrow = c(2, 2))
+ poi.coa <- dudi.coa(doubs$fish, scann = FALSE)
+ sco.distri(poi.coa$l1[, 1], doubs$fish)
+ poi.nsc <- dudi.nsc(doubs$fish, scann = FALSE)
+ sco.distri(poi.nsc$l1[, 1], doubs$fish)
+ s.label(poi.coa$l1)
+ s.label(poi.nsc$l1)
+
+ data(rpjdl)
+ fau.coa <- dudi.coa(rpjdl$fau, scann = FALSE)
+ sco.distri(fau.coa$l1[,1], rpjdl$fau)
+ fau.nsc <- dudi.nsc(rpjdl$fau, scann = FALSE)
+ sco.distri(fau.nsc$l1[,1], rpjdl$fau)
+ s.label(fau.coa$l1)
+ s.label(fau.nsc$l1)
+
+ par(mfrow = c(1, 1))
+}
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/sco.gauss.Rd b/man/sco.gauss.Rd
new file mode 100644
index 0000000..0a371aa
--- /dev/null
+++ b/man/sco.gauss.Rd
@@ -0,0 +1,52 @@
+\name{sco.gauss}
+\alias{sco.gauss}
+\title{Relationships between one score and qualitative variables}
+\description{
+Draws Gauss curves with the same mean and variance as the scores of indivivuals belonging to categories of several qualitative variables.
+}
+\usage{
+sco.gauss(score, df, xlim = NULL, steps = 200, ymax = NULL, sub =
+names(df), csub = 1.25, possub = "topleft", legen =TRUE, label = row.names(df),
+clabel = 1, grid = TRUE, cgrid = 1, include.origin = TRUE, origin = c(0, 0))
+}
+\arguments{
+ \item{score}{a numeric vector}
+ \item{df}{a dataframe containing only factors, number of rows equal to the length of the score vector}
+ \item{xlim}{starting point and end point for drawing the Gauss curves}
+ \item{steps}{number of segments for drawing the Gauss curves}
+ \item{ymax}{max ordinate for all Gauss curves. If NULL, ymax is
+ computed and different for each factor}
+ \item{sub}{vector of strings of characters for the lables of qualitative variables}
+ \item{csub}{character size for the legend}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{legen}{if TRUE, the first graphic of the series displays the score with evenly spaced labels (see \code{sco.label})}
+ \item{label}{labels for the score}
+ \item{clabel}{a character size for the labels, used with
+ \code{par("cex")*clabel}}
+ \item{grid}{a logical value indicating whether a grid in the background of the plot should be drawn}
+ \item{cgrid}{a character size, parameter used with par("cex")*\code{cgrid} to indicate the mesh of the grid}
+ \item{include.origin}{a logical value indicating whether the point "origin" should belong to the plot}
+ \item{origin}{the fixed point in the graph space, for example c(0,0) the origin axes}
+
+}
+\details{
+Takes one vector containing quantitative values (score) and one dataframe containing only factors
+that give categories to wich the quantitative values belong. Computes the mean and variance
+of the values in each category of each factor, and draws a Gauss curve with
+the same mean and variance for each category of each factor.
+Can optionaly set the start and end point of the curves and the number of
+segments. The max ordinate (ymax) can also be set arbitrarily to set a common
+max for all factors (else the max is different for each factor).
+}
+\value{
+The matched call.
+}
+\author{Jean Thioulouse, Stéphane Dray \email{stephane.dray at univ-lyon1.fr}}
+\examples{
+data(meau)
+envpca <- dudi.pca(meau$env, scannf=FALSE)
+dffac <- cbind.data.frame(meau$design$season, meau$design$site)
+sco.gauss(envpca$li[,1], dffac, clabel = 2, csub = 2)
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/sco.label.Rd b/man/sco.label.Rd
new file mode 100644
index 0000000..5f7716e
--- /dev/null
+++ b/man/sco.label.Rd
@@ -0,0 +1,48 @@
+\name{sco.label}
+\alias{sco.label}
+\title{1D plot of a numeric score with labels}
+\description{
+Draws evenly spaced labels, each label linked to the corresponding value of a numeric score.
+}
+\usage{
+sco.label(score, label = names(score), clabel = 1, horizontal = TRUE,
+reverse = FALSE, pos.lab = 0.5, pch = 20, cpoint = 1, boxes = TRUE, lim
+= NULL, grid = TRUE, cgrid = 1, include.origin = TRUE, origin = c(0, 0),
+sub = "", csub = 1.25, possub = "bottomleft")
+}
+\arguments{
+ \item{score}{a numeric vector}
+ \item{label}{labels for the score}
+ \item{clabel}{a character size for the labels, used with
+ \code{par("cex")*clabel}}
+ \item{horizontal}{logical. If TRUE, the plot is horizontal}
+ \item{reverse}{logical. If horizontal = TRUE and reverse=TRUE, the
+ plot is at the bottom, if reverse = FALSE, the plot is at the top. If
+ horizontal = FALSE, the plot is at the right (TRUE) or at the left
+ (FALSE).}
+ \item{pos.lab}{a values between 0 and 1 to manage the position of the labels.}
+ \item{pch}{an integer specifying the symbol or the single character to be used in plotting points}
+ \item{cpoint}{a character size for plotting the points, used with \code{par("cex")*cpoint}. If zero, no points are drawn}
+ \item{boxes}{if TRUE, labels are framed}
+ \item{lim}{the range for the x axis or y axis (if horizontal = FALSE), if NULL, they are computed}
+ \item{grid}{a logical value indicating whether a grid in the background of the plot should be drawn}
+ \item{cgrid}{a character size, parameter used with par("cex")* \code{cgrid} to indicate the mesh of the grid}
+ \item{include.origin}{a logical value indicating whether the point "origin" should belong to the plot}
+ \item{origin}{the fixed point in the graph space, for example c(0,0) the origin axes}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+}
+\value{
+The matched call.
+}
+\author{Stéphane Dray \email{stephane.dray at univ-lyon1.fr}, Jean Thioulouse}
+\examples{
+data(meau)
+envpca <- dudi.pca(meau$env, scannf=FALSE)
+par(mfrow=c(2,1))
+sco.label(envpca$l1[,1], row.names(envpca$l1), lim=c(-1,3.5))
+sco.label(envpca$co[,1], row.names(envpca$co), reverse = TRUE, lim=c(-1,3.5))
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/sco.match.Rd b/man/sco.match.Rd
new file mode 100644
index 0000000..65685dd
--- /dev/null
+++ b/man/sco.match.Rd
@@ -0,0 +1,49 @@
+\name{sco.match}
+\alias{sco.match}
+\title{1D plot of a pair of numeric scores with labels}
+\description{
+Draws evenly spaced labels, each label linked to the corresponding values of two numeric score.
+}
+\usage{
+sco.match(score1, score2, label = names(score1), clabel = 1,
+ horizontal = TRUE, reverse = FALSE, pos.lab = 0.5, wmatch = 3,
+ pch = 20, cpoint = 1, boxes = TRUE, lim = NULL, grid = TRUE,
+ cgrid = 1, include.origin = TRUE, origin = c(0, 0), sub = "",
+ csub = 1.25, possub = "bottomleft")
+}
+\arguments{
+ \item{score1}{a numeric vector}
+ \item{score2}{a numeric vector}
+ \item{label}{labels for the score}
+ \item{clabel}{a character size for the labels, used with
+ \code{par("cex")*clabel}}
+ \item{horizontal}{logical. If TRUE, the plot is horizontal}
+ \item{reverse}{logical. If horizontal = TRUE and reverse=TRUE, the
+ plot is at the bottom, if reverse = FALSE, the plot is at the top. If
+ horizontal = FALSE, the plot is at the right (TRUE) or at the left
+ (FALSE).}
+ \item{pos.lab}{a values between 0 and 1 to manage the position of the
+ labels.}
+ \item{wmatch}{a numeric values to specify the width of the matching
+ region in the plot. The width is equal to wmatch * the height of character}
+ \item{pch}{an integer specifying the symbol or the single character to be used in plotting points}
+ \item{cpoint}{a character size for plotting the points, used with \code{par("cex")*cpoint}. If zero, no points are drawn}
+ \item{boxes}{if TRUE, labels are framed}
+ \item{lim}{the range for the x axis or y axis (if horizontal = FALSE), if NULL, they are computed}
+ \item{grid}{a logical value indicating whether a grid in the background of the plot should be drawn}
+ \item{cgrid}{a character size, parameter used with par("cex")* \code{cgrid} to indicate the mesh of the grid}
+ \item{include.origin}{a logical value indicating whether the point "origin" should belong to the plot}
+ \item{origin}{the fixed point in the graph space, for example c(0,0) the origin axes}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+}
+\value{
+The matched call.
+}
+\author{Stéphane Dray \email{stephane.dray at univ-lyon1.fr}}
+\examples{
+sco.match(-5:5,2*(-5:5))
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/sco.quant.Rd b/man/sco.quant.Rd
new file mode 100644
index 0000000..f4a6e2f
--- /dev/null
+++ b/man/sco.quant.Rd
@@ -0,0 +1,30 @@
+\name{sco.quant}
+\alias{sco.quant}
+\title{Graph to Analyse the Relation between a Score and Quantitative Variables}
+\description{
+represents the graphs to analyse the relation between a score and quantitative variables.
+}
+\usage{
+sco.quant (score, df, fac = NULL, clabel = 1, abline = FALSE,
+ sub = names(df), csub = 2, possub = "topleft")
+}
+\arguments{
+ \item{score}{a numeric vector}
+ \item{df}{a data frame which rows equal to the score length}
+ \item{fac}{a factor with the same length than the score}
+ \item{clabel}{character size for the class labels (if any) used with \code{par("cex")*clabel}}
+ \item{abline}{a logical value indicating whether a regression line should be added}
+ \item{sub}{a vector of strings of characters for the labels of variables}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+}
+\author{Daniel Chessel }
+\examples{
+w <- runif(100, -5, 10)
+fw <- cut (w, 5)
+levels(fw) <- LETTERS[1:5]
+wX <- data.frame(matrix(w + rnorm(900, sd = (1:900) / 100), 100, 9))
+sco.quant(w, wX, fac = fw, abline = TRUE, clab = 2, csub = 3)
+}
+\keyword{hplot}
+\keyword{multivariate}
diff --git a/man/score.Rd b/man/score.Rd
new file mode 100644
index 0000000..cbfb820
--- /dev/null
+++ b/man/score.Rd
@@ -0,0 +1,39 @@
+\name{score}
+\alias{score}
+\alias{scoreutil.base}
+\title{Graphs for One Dimension}
+\description{
+ score is a generic function. It proposes methods for the objects 'coa', 'acm', 'mix', 'pca'.}
+\usage{
+score(x, ...)
+scoreutil.base(y, xlim, grid, cgrid, include.origin, origin, sub, csub)
+}
+\arguments{
+ \item{x}{an object used to select a method}
+ \item{\dots}{further arguments passed to or from other methods}
+ \item{y}{a numeric vector}
+ \item{xlim}{the ranges to be encompassed by the x axis, if NULL they are computed}
+ \item{grid}{a logical value indicating whether the scale vertical lines should be drawn}
+ \item{cgrid}{a character size, parameter used with \code{par("cex")*cgrid} to indicate the mesh of the scale}
+ \item{include.origin}{a logical value indicating whether the point "origin" should be belonged to the graph space}
+ \item{origin}{the fixed point in the graph space, for example 0 the origin axis}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+}
+\details{
+ \code{scoreutil.base} is a utility function - not for the user - to define the bottom of the layout of all \code{score}.
+}
+\seealso{\code{\link{sco.boxplot}}, \code{\link{sco.distri}}, \code{\link{sco.quant}}
+}
+\author{Daniel Chessel }
+\examples{
+\dontrun{
+par(mar = c(1, 1, 1, 1))
+ade4:::scoreutil.base (runif(20, 3, 7), xlim = NULL, grid = TRUE, cgrid = 0.8,
+ include.origin = TRUE, origin = 0, sub = "Uniform", csub = 1)}
+# returns the value of the user coordinate of the low line.
+# The user window id defined with c(0,1) in ordinate.
+# box()
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/score.acm.Rd b/man/score.acm.Rd
new file mode 100644
index 0000000..49b2abc
--- /dev/null
+++ b/man/score.acm.Rd
@@ -0,0 +1,28 @@
+\name{score.acm}
+\alias{score.acm}
+\title{Graphs to study one factor in a Multiple Correspondence Analysis}
+\description{
+performs the canonical graph of a Multiple Correspondence Analysis.
+}
+\usage{
+\method{score}{acm}(x, xax = 1, which.var = NULL, mfrow = NULL,
+ sub = names(oritab), csub = 2, possub = "topleft", \dots)
+}
+\arguments{
+ \item{x}{an object of class \code{acm}}
+ \item{xax}{the column number for the used axis}
+ \item{which.var}{the numbers of the kept columns for the analysis, otherwise all columns}
+ \item{mfrow}{a vector of the form "c(nr,nc)", otherwise computed by a special own function \code{n2mfrow}}
+ \item{sub}{a vector of strings of characters to be inserted as sub-titles, otherwise the variable names of the initial array}
+ \item{csub}{a character size for the sub-titles}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\author{Daniel Chessel}
+\examples{
+data(banque)
+banque.acm <- dudi.acm(banque, scann = FALSE, nf = 3)
+score(banque.acm, which = which(banque.acm$cr[, 1] > 0.2))
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/score.coa.Rd b/man/score.coa.Rd
new file mode 100644
index 0000000..a928d38
--- /dev/null
+++ b/man/score.coa.Rd
@@ -0,0 +1,62 @@
+\name{score.coa}
+\alias{score.coa}
+\alias{reciprocal.coa}
+\title{Reciprocal scaling after a correspondence analysis}
+\description{
+performs the canonical graph of a correspondence analysis.
+}
+\usage{
+\method{score}{coa}(x, xax = 1, dotchart = FALSE, clab.r = 1, clab.c = 1,
+ csub = 1, cpoi = 1.5, cet = 1.5, ...)
+reciprocal.coa(x)
+}
+\arguments{
+ \item{x}{an object of class \code{coa}}
+ \item{xax}{the column number for the used axis}
+ \item{dotchart}{if TRUE the graph gives a "dual scaling", if FALSE a "reciprocal scaling"}
+ \item{clab.r}{a character size for row labels}
+ \item{clab.c}{a character size for column labels}
+ \item{csub}{a character size for the sub-titles, used with \code{par("cex")*csub}}
+ \item{cpoi}{a character size for the points}
+ \item{cet}{a coefficient for the size of segments in standard deviation}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{return a data.frame with the scores, weights and factors of
+ correspondences (non zero cells)}
+\details{
+In a "reciprocal scaling", the reference score is a numeric code centred and normalized of the non zero cells of the array which both maximizes the variance of means by row and by column. The bars are drawn with half the length of this standard deviation.
+}
+\references{Thioulouse, J. and Chessel D. (1992) A method for reciprocal scaling of species tolerance and sample diversity. \emph{Ecology}, \bold{73}, 670--680.
+}
+\author{Daniel Chessel }
+\examples{
+layout(matrix(c(1,1,2,3), 2, 2), resp = FALSE)
+data(aviurba)
+dd1 <- dudi.coa(aviurba$fau, scan = FALSE)
+score(dd1, clab.r = 0, clab.c = 0.75)
+recscal <- reciprocal.coa(dd1)
+head(recscal)
+abline(v = 1, lty = 2, lwd = 3)
+sco.distri(dd1$l1[,1], aviurba$fau)
+sco.distri(dd1$c1[,1], data.frame(t(aviurba$fau)))
+
+# 1 reciprocal scaling correspondence score -> species amplitude + sample diversity
+# 2 sample score -> averaging -> species amplitude
+# 3 species score -> averaging -> sample diversity
+
+layout(matrix(c(1,1,2,3), 2, 2), resp = FALSE)
+data(rpjdl)
+rpjdl1 <- dudi.coa(rpjdl$fau, scan = FALSE)
+score(rpjdl1, clab.r = 0, clab.c = 0.75)
+if (requireNamespace("MASS", quietly = TRUE)) {
+ data(MASS::caith)
+ score(dudi.coa(MASS::caith, scan = FALSE), clab.r = 1.5, clab.c = 1.5, cpoi = 3)
+ data(housetasks)
+ score(dudi.coa(housetasks, scan = FALSE), clab.r = 1.25, clab.c = 1.25,
+ csub = 0, cpoi = 3)
+}
+par(mfrow = c(1,1))
+score(rpjdl1, dotchart = TRUE, clab.r = 0)
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/score.mix.Rd b/man/score.mix.Rd
new file mode 100644
index 0000000..69a8d33
--- /dev/null
+++ b/man/score.mix.Rd
@@ -0,0 +1,26 @@
+\name{score.mix}
+\alias{score.mix}
+\title{Graphs to Analyse a factor in a Mixed Analysis}
+\description{
+performs the canonical graph of a mixed analysis.
+}
+\usage{
+\method{score}{mix}(x, xax = 1, csub = 2, mfrow = NULL, which.var = NULL, \dots)
+}
+\arguments{
+ \item{x}{an object of class \code{mix}}
+ \item{xax}{the column number for the used axis}
+ \item{csub}{a character size for the sub-titles, used with \code{par("cex")*csub}}
+ \item{mfrow}{a vector of the form "c(nr,nc)", otherwise computed by a special own function \code{n2mfrow}}
+ \item{which.var}{the numbers of the kept columns for the analysis, otherwise all columns }
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\author{Daniel Chessel }
+\examples{
+data(lascaux)
+w <- cbind.data.frame(lascaux$colo, lascaux$ornem)
+dd <- dudi.mix(w, scan = FALSE, nf = 4, add = TRUE)
+score(dd, which = which(dd$cr[,1] > 0.3))
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/score.pca.Rd b/man/score.pca.Rd
new file mode 100644
index 0000000..cfc5d5f
--- /dev/null
+++ b/man/score.pca.Rd
@@ -0,0 +1,32 @@
+\name{score.pca}
+\alias{score.pca}
+\title{Graphs to Analyse a factor in PCA}
+\description{
+performs the canonical graph of a Principal Component Analysis.
+}
+\usage{
+\method{score}{pca}(x, xax = 1, which.var = NULL, mfrow = NULL, csub = 2,
+ sub = names(x$tab), abline = TRUE, \dots)
+}
+\arguments{
+ \item{x}{an object of class \code{pca}}
+ \item{xax}{the column number for the used axis}
+ \item{which.var}{the numbers of the kept columns for the analysis, otherwise all columns}
+ \item{mfrow}{a vector of the form "c(nr,nc)", otherwise computed by a special own function \code{n2mfrow}}
+ \item{csub}{a character size for sub-titles, used with \code{par("cex")*csub}}
+ \item{sub}{a vector of string of characters to be inserted as sub-titles, otherwise the names of the variables}
+ \item{abline}{a logical value indicating whether a regression line should be added}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\author{Daniel Chessel }
+\examples{
+data(deug)
+dd1 <- dudi.pca(deug$tab, scan = FALSE)
+score(dd1)
+
+# The correlations are :
+dd1$co[,1]
+# [1] 0.7925 0.6532 0.7410 0.5287 0.5539 0.7416 0.3336 0.2755 0.4172
+}
+\keyword{multivariate}
+\keyword{hplot}
diff --git a/man/seconde.Rd b/man/seconde.Rd
new file mode 100644
index 0000000..407a70e
--- /dev/null
+++ b/man/seconde.Rd
@@ -0,0 +1,31 @@
+\name{seconde}
+\alias{seconde}
+\docType{data}
+\title{Students and Subjects}
+\description{
+The \code{seconde} data frame gives the marks of 22 students for 8 subjects.
+}
+\usage{data(seconde)}
+\format{
+ This data frame (22,8) contains the following columns:
+- HGEO: History and Geography
+- FRAN: French literature
+- PHYS: Physics
+- MATH: Mathematics
+- BIOL: Biology
+- ECON: Economy
+- ANGL: English language
+- ESPA: Spanish language
+ }
+\source{
+Personal communication
+}
+\examples{
+data(seconde)
+if(adegraphicsLoaded()) {
+ scatter(dudi.pca(seconde, scan = FALSE), row.plab.cex = 1, col.plab.cex = 1.5)
+} else {
+ scatter(dudi.pca(seconde, scan = FALSE), clab.r = 1, clab.c = 1.5)
+}
+}
+\keyword{datasets}
diff --git a/man/sepan.Rd b/man/sepan.Rd
new file mode 100644
index 0000000..5061a20
--- /dev/null
+++ b/man/sepan.Rd
@@ -0,0 +1,55 @@
+\name{sepan}
+\alias{sepan}
+\alias{plot.sepan}
+\alias{print.sepan}
+\alias{summary.sepan}
+\title{Separated Analyses in a K-tables}
+\description{
+performs K separated multivariate analyses of an object of class \code{ktab}
+containing K tables.
+}
+\usage{
+sepan(X, nf = 2)
+\method{plot}{sepan}(x, mfrow = NULL, csub = 2, \dots)
+\method{summary}{sepan}(object, \dots)
+\method{print}{sepan}(x, \dots)
+}
+\arguments{
+ \item{X}{an object of class \code{ktab}}
+ \item{nf}{an integer indicating the number of kept axes for each separated analysis}
+ \item{x, object}{an object of class 'sepan'}
+ \item{mfrow}{a vector of the form "c(nr,nc)", otherwise computed by a special own function \code{n2mfrow}}
+ \item{csub}{a character size for the sub-titles, used with \code{par("cex")*csub}}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+returns a list of class 'sepan' containing :
+ \item{call}{a call order}
+ \item{tab.names}{a vector of characters with the names of tables}
+ \item{blo}{a numeric vector with the numbers of columns for each table}
+ \item{rank}{a numeric vector with the rank of the studied matrix for each table}
+ \item{Eig}{a numeric vector with all the eigenvalues}
+ \item{Li}{a data frame with the row coordinates}
+ \item{L1}{a data frame with the row normed scores}
+ \item{Co}{a data frame with the column coordinates}
+ \item{C1}{a data frame with the column normed coordinates}
+ \item{TL}{a data frame with the factors for Li L1}
+ \item{TC}{a data frame with the factors for Co C1}
+}
+\details{
+The function plot on a \code{sepan} object allows to compare inertias and structures between arrays.
+In black, the eigenvalues of kept axes in the object 'sepan'.
+}
+\author{
+Daniel Chessel
+}
+\examples{
+data(escopage)
+w <- data.frame(scale(escopage$tab))
+w <- ktab.data.frame(w, escopage$blo, tabnames = escopage$tab.names)
+sep1 <- sepan(w)
+sep1
+summary(sep1)
+plot(sep1)
+}
+\keyword{multivariate}
diff --git a/man/skulls.Rd b/man/skulls.Rd
new file mode 100644
index 0000000..1747750
--- /dev/null
+++ b/man/skulls.Rd
@@ -0,0 +1,40 @@
+\name{skulls}
+\alias{skulls}
+\docType{data}
+\title{Morphometric Evolution}
+\description{
+This data set gives four anthropometric measures of 150 Egyptean
+skulls belonging to five different historical periods.
+}
+\usage{data(skulls)}
+\format{
+The \code{skulls} data frame has 150 rows (egyptean skulls) and 4 columns (anthropometric measures).
+The four variables are the maximum breadth (V1), the basibregmatic height (V2), the basialveolar length (V3)
+and the nasal height (V4). All measurements were taken in millimeters.
+}
+\details{
+The measurements are made on 5 groups and 30 Egyptian skulls. The groups are defined as follows :\cr
+1 - the early predynastic period (circa 4000 BC)\cr
+2 - the late predynastic period (circa 3300 BC)\cr
+3 - the 12th and 13th dynasties (circa 1850 BC)\cr
+4 - the Ptolemiac period (circa 200 BC)\cr
+5 - the Roman period (circa 150 BC)\cr
+}
+\source{
+Thompson, A. and Randall-Maciver, R. (1905) \emph{Ancient races of the Thebaid}, Oxford University Press.
+}
+\references{
+Manly, B.F. (1994) \emph{Multivariate Statistical Methods. A primer},
+Second edition. Chapman & Hall, London. 1--215.\cr
+The example is treated pp. 6, 13, 51, 64, 72, 107, 112 and 117.
+}
+\examples{
+data(skulls)
+pca1 <- dudi.pca(skulls, scan = FALSE)
+fac <- gl(5, 30)
+levels(fac) <- c("-4000", "-3300", "-1850", "-200", "+150")
+dis.skulls <- discrimin(pca1, fac, scan = FALSE)
+if(!adegraphicsLoaded())
+ plot(dis.skulls, 1, 1)
+}
+\keyword{datasets}
diff --git a/man/statico.Rd b/man/statico.Rd
new file mode 100644
index 0000000..96a722d
--- /dev/null
+++ b/man/statico.Rd
@@ -0,0 +1,45 @@
+\name{statico}
+\alias{statico}
+\title{STATIS and Co-Inertia : Analysis of a series of paired ecological tables}
+\description{
+Does the analysis of a series of pairs of ecological tables. This function uses
+Partial Triadic Analysis (\link{pta}) and \link{ktab.match2ktabs}
+to do the computations.
+}
+\usage{
+statico(KTX, KTY, scannf = TRUE)
+}
+\arguments{
+ \item{KTX}{an objet of class ktab}
+ \item{KTY}{an objet of class ktab}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+}
+\details{
+This function takes 2 ktabs and crosses each pair of tables of these ktabs with the function \link{ktab.match2ktabs}. It then does a partial triadic analysis on this new ktab with \link{pta}.
+}
+\value{
+a list of class ktab, subclass kcoinertia. See \link{ktab}
+}
+\references{
+Thioulouse J. (2011). Simultaneous analysis of a sequence of paired ecological tables: a comparison of several methods. \emph{Annals of Applied Statistics}, \bold{5}, 2300-2325.
+Thioulouse J., Simier M. and Chessel D. (2004). Simultaneous analysis of a sequence of paired ecological tables. \emph{Ecology} \bold{85}, 272-283.
+Simier, M., Blanc L., Pellegrin F., and Nandris D. (1999). Approche simultanée de K couples de tableaux :
+Application a l'étude des relations pathologie végétale - environnement. \emph{Revue de Statistique Appliquée}, \bold{47}, 31-46.
+}
+\author{Jean Thioulouse \email{jean.thioulouse at univ-lyon1.fr}}
+\section{WARNING }{
+IMPORTANT : KTX and KTY must have the same k-tables structure, the same number
+of columns, and the same column weights.
+}
+\examples{
+data(meau)
+wit1 <- withinpca(meau$env, meau$design$season, scan = FALSE, scal = "total")
+spepca <- dudi.pca(meau$spe, scale = FALSE, scan = FALSE, nf = 2)
+wit2 <- wca(spepca, meau$design$season, scan = FALSE, nf = 2)
+kta1 <- ktab.within(wit1, colnames = rep(c("S1","S2","S3","S4","S5","S6"), 4))
+kta2 <- ktab.within(wit2, colnames = rep(c("S1","S2","S3","S4","S5","S6"), 4))
+statico1 <- statico(kta1, kta2, scan = FALSE)
+plot(statico1)
+kplot(statico1)
+}
+\keyword{multivariate}
diff --git a/man/statico.krandtest.Rd b/man/statico.krandtest.Rd
new file mode 100644
index 0000000..8f0a044
--- /dev/null
+++ b/man/statico.krandtest.Rd
@@ -0,0 +1,41 @@
+\name{statico.krandtest}
+\alias{statico.krandtest}
+\title{Monte-Carlo test on a Statico analysis (in C).}
+\description{
+Performs the series of Monte-Carlo coinertia tests of a Statico analysis (one for each couple of tables).
+}
+\usage{
+statico.krandtest(KTX, KTY, nrepet = 999, ...)
+}
+\arguments{
+ \item{KTX}{an objet of class ktab containing the environmental data}
+ \item{KTY}{an objet of class ktab containing the species data}
+ \item{nrepet}{the number of permutations}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\details{
+This function takes 2 ktabs and does a coinertia analysis with \link{coinertia} on each pair of tables. It then uses the \link{randtest} function to do a permutation test on each of these coinertia analyses.
+}
+\value{
+krandtest, a list of randtest objects. See \link{krandtest}
+}
+\references{
+Thioulouse J. (2011). Simultaneous analysis of a sequence of paired ecological tables: a comparison of several methods. \emph{Annals of Applied Statistics}, \bold{5}, 2300-2325.
+}
+\author{Jean Thioulouse \email{jean.thioulouse at univ-lyon1.fr}}
+\section{WARNING }{
+IMPORTANT : KTX and KTY must have the same k-tables structure, the same number
+of columns, and the same column weights.
+}
+\examples{
+data(meau)
+wit1 <- withinpca(meau$env, meau$design$season, scan = FALSE, scal = "total")
+spepca <- dudi.pca(meau$spe, scale = FALSE, scan = FALSE, nf = 2)
+wit2 <- wca(spepca, meau$design$season, scan = FALSE, nf = 2)
+kta1 <- ktab.within(wit1, colnames = rep(c("S1","S2","S3","S4","S5","S6"), 4))
+kta2 <- ktab.within(wit2, colnames = rep(c("S1","S2","S3","S4","S5","S6"), 4))
+statico1 <- statico(kta1, kta2, scan = FALSE)
+kr1 <- statico.krandtest(kta1, kta2)
+plot(kr1)
+}
+\keyword{multivariate}
diff --git a/man/statis.Rd b/man/statis.Rd
new file mode 100644
index 0000000..62d2fd2
--- /dev/null
+++ b/man/statis.Rd
@@ -0,0 +1,71 @@
+\name{statis}
+\alias{statis}
+\alias{print.statis}
+\alias{plot.statis}
+\title{STATIS, a method for analysing K-tables}
+\description{
+performs a STATIS analysis of a \code{ktab} object.
+}
+\usage{
+statis(X, scannf = TRUE, nf = 3, tol = 1e-07)
+\method{plot}{statis}(x, xax = 1, yax = 2, option = 1:4, \dots)
+\method{print}{statis}(x, \dots)
+}
+\arguments{
+ \item{X}{an object of class 'ktab'}
+ \item{scannf}{a logical value indicating whether the number of kept axes for the compromise should be asked}
+ \item{nf}{if \code{scannf} FALSE, an integer indicating the number of kept axes for the compromise}
+ \item{tol}{a tolerance threshold to test whether the distance matrix is Euclidean : an eigenvalue is considered positive if it is larger than \code{-tol*lambda1} where \code{lambda1} is the largest eigenvalue}
+ \item{x}{an object of class 'statis'}
+ \item{xax, yax}{the numbers of the x-axis and the y-axis}
+ \item{option}{an integer between 1 and 4, otherwise the 4 components of the plot are dispayed}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+\code{statis} returns a list of class 'statis' containing :
+ \item{RV}{a matrix with the all RV coefficients}
+ \item{RV.eig}{a numeric vector with all the eigenvalues}
+ \item{RV.coo}{a data frame with the array scores}
+ \item{tab.names}{a vector of characters with the names of the arrays}
+ \item{RV.tabw}{a numeric vector with the array weigths}
+ \item{C.nf}{an integer indicating the number of kept axes}
+ \item{C.rank}{an integer indicating the rank of the analysis}
+ \item{C.li}{a data frame with the row coordinates}
+ \item{C.Co}{a data frame with the column coordinates}
+ \item{C.T4}{a data frame with the principal vectors (for each table)}
+ \item{TL}{a data frame with the factors (not used)}
+ \item{TC}{a data frame with the factors for Co}
+ \item{T4}{a data frame with the factors for T4}
+}
+\references{
+Lavit, C. (1988) \emph{Analyse conjointe de tableaux quantitatifs}, Masson, Paris.\cr\cr
+Lavit, C., Escoufier, Y., Sabatier, R. and Traissac, P. (1994) The ACT (Statis method). \emph{Computational Statistics and Data Analysis}, \bold{18}, 97--119.
+}
+\author{
+Daniel Chessel
+}
+\examples{
+data(jv73)
+kta1 <- ktab.within(withinpca(jv73$morpho, jv73$fac.riv, scann = FALSE))
+statis1 <- statis(kta1, scann = FALSE)
+plot(statis1)
+
+dudi1 <- dudi.pca(jv73$poi, scann = FALSE, scal = FALSE)
+wit1 <- wca(dudi1, jv73$fac.riv, scann = FALSE)
+kta3 <- ktab.within(wit1)
+data(jv73)
+statis3 <- statis(kta3, scann = FALSE)
+plot(statis3)
+
+if(adegraphicsLoaded()) {
+ s.arrow(statis3$C.li, pgrid.text.cex = 0)
+ kplot(statis3, traj = TRUE, arrow = FALSE, plab.cex = 0, psub.cex = 3, ppoi.cex = 3)
+} else {
+ s.arrow(statis3$C.li, cgrid = 0)
+ kplot(statis3, traj = TRUE, arrow = FALSE, unique = TRUE,
+ clab = 0, csub = 3, cpoi = 3)
+}
+
+statis3
+}
+\keyword{multivariate}
diff --git a/man/steppe.Rd b/man/steppe.Rd
new file mode 100644
index 0000000..b490595
--- /dev/null
+++ b/man/steppe.Rd
@@ -0,0 +1,35 @@
+\name{steppe}
+\alias{steppe}
+\docType{data}
+\title{Transect in the Vegetation}
+\description{
+This data set gives the presence-absence of 37 species on 515 sites.
+}
+\usage{data(steppe)}
+\format{
+ \code{steppe} is a list of 2 components.
+ \describe{
+ \item{tab}{is a data frame with 512 rows (sites) and 37 variables (species) in presence-absence.}
+ \item{esp.names}{is a vector of the species names.}
+ }
+}
+\source{
+Estève, J. (1978) Les méthodes d'ordination : éléments pour une discussion.
+in J. M. Legay and R. Tomassone, editors.
+\emph{Biométrie et Ecologie}, Société Française de Biométrie, Paris, 223--250.
+}
+\examples{
+par(mfrow = c(3,1))
+data(steppe)
+w1 <- col(as.matrix(steppe$tab[,1:15]))
+w1 <- as.numeric(w1[steppe$tab[,1:15] > 0])
+w2 <- row(as.matrix(steppe$tab[,1:15]))
+w2 <- as.numeric(w2[steppe$tab[,1:15] > 0])
+plot(w2, w1, pch = 20)
+plot(dudi.pca(steppe$tab, scan = FALSE, scale = FALSE)$li[,1],
+ pch = 20, ylab = "PCA", xlab = "", type = "b")
+plot(dudi.coa(steppe$tab, scan = FALSE)$li[,1], pch = 20,
+ ylab = "COA", xlab = "", type = "b")
+par(mfrow = c(1,1))
+}
+\keyword{datasets}
diff --git a/man/supcol.Rd b/man/supcol.Rd
new file mode 100644
index 0000000..0738776
--- /dev/null
+++ b/man/supcol.Rd
@@ -0,0 +1,49 @@
+\name{supcol}
+\alias{supcol}
+\alias{supcol.coa}
+\alias{supcol.dudi}
+\title{Projections of Supplementary Columns}
+\description{
+performs projections of supplementary columns.
+}
+\usage{
+supcol(x, \dots)
+\method{supcol}{dudi}(x, Xsup, \dots)
+\method{supcol}{coa}(x, Xsup, \dots)
+}
+\arguments{
+ \item{x}{an object used to select a method}
+ \item{Xsup}{an array with the supplementary columns (\code{Xsup} and \code{x$tab} have the same row number)}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\details{
+If \code{supcol.dudi} is used, the column vectors of \code{Xsup} are projected without prior modification onto the principal components of dudi with the scalar product associated to the row weightings of dudi.
+}
+\value{A list of two components:
+ \item{\code{tabsup}}{data frame containing the array with the supplementary columns transformed or not}
+ \item{\code{cosup}}{data frame containing the coordinates of the supplementary projections}
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(rpjdl)
+rpjdl.coa <- dudi.coa(rpjdl$fau, scan = FALSE, nf = 4)
+rpjdl.coa$co[1:3, ]
+supcol(rpjdl.coa, rpjdl$fau[, 1:3])$cosup #the same
+
+data(doubs)
+dudi1 <- dudi.pca(doubs$fish, scal = FALSE, scan = FALSE)
+if(adegraphicsLoaded()) {
+ g1 <- s.arrow(dudi1$co, plot = FALSE)
+ g2 <- s.arrow(supcol(dudi1, data.frame(scalewt(doubs$env)))$cosup, plab.cex = 2, plot = FALSE)
+ G <- superpose(g1, g2, plot = TRUE)
+
+} else {
+ s.arrow(dudi1$co)
+ s.arrow(supcol(dudi1, data.frame(scalewt(doubs$env)))$cosup, add.p = TRUE, clab = 2)
+ symbols(0, 0, circles = 1, inches = FALSE, add = TRUE)
+}
+}
+\keyword{multivariate}
diff --git a/man/supdist.Rd b/man/supdist.Rd
new file mode 100644
index 0000000..67275d1
--- /dev/null
+++ b/man/supdist.Rd
@@ -0,0 +1,86 @@
+\name{supdist}
+\alias{supdist}
+\title{
+Projection of additional items in a PCO analysis
+}
+
+\description{
+This function takes the grand distance matrix between all items (Active +
+Supplementary). It computes the PCO of the distance matrix between Active items,
+and projects the distance matrix of Supplementary items in this PCO.
+}
+
+\usage{supdist(d, fsup, tol = 1e-07)}
+
+\arguments{
+ \item{d}{Grand distance matrix between all (Active + Supplementary) items}
+ \item{fsup}{A factor with two levels giving the Active (level `A') or
+ Supplementary (level `S') status for each item in the distance matrix.}
+ \item{tol}{Numeric tolerance used to evaluate zero eigenvalues}
+}
+
+\value{
+ \item{coordSup}{Coordinates of Supplementary items projected in the PCO of Active items}
+ \item{coordAct}{Coordinates of Active item}
+ \item{coordTot}{Coordinates of Active plus Supplementary items}
+}
+
+\references{
+Computations based on the Methods section of the following paper:
+Pele J, Abdi H, Moreau M, Thybert D, Chabbert M (2011) Multidimensional Scaling
+Reveals the Main Evolutionary Pathways of Class A G-Protein-Coupled Receptors.
+PLoS ONE 6(4): e19094. \url{https://doi.org/10.1371/journal.pone.0019094}
+}
+
+\author{Jean Thioulouse}
+
+\seealso{\code{\link{dudi.pco}}, \code{\link{suprow}}}
+
+\examples{
+data(meau)
+## Case 1: Supplementary items = subset of Active items
+## Supplementary coordinates should be equal to Active coordinates
+## PCO of active items (meau dataset has 6 sites and 10 variables)
+envpca1 <- dudi.pca(meau$env, scannf = FALSE)
+dAct <- dist(envpca1$tab)
+pco1 <- dudi.pco(dAct, scannf = FALSE)
+## Projection of rows 19:24 (winter season for the 6 sites)
+## Supplementary items must be normalized
+f1 <- function(w) (w - envpca1$cent) / envpca1$norm
+envSup <- t(apply(meau$env[19:24, ], 1, f1))
+envTot <- rbind.data.frame(envpca1$tab, envSup)
+dTot <- dist(envTot)
+fSA1 <- as.factor(rep(c("A", "S"), c(24, 6)))
+cSup1 <- supdist(dTot, fSA1)
+## Comparison (coordinates should be equal)
+cSup1$coordSup[, 1:2]
+pco1$li[19:24, ]
+
+data(meaudret)
+## Case 2: Supplementary items = new items
+## PCO of active items (meaudret dataset has only 5 sites and 9 variables)
+envpca2 <- dudi.pca(meaudret$env, scannf = FALSE)
+dAct <- dist(envpca2$tab)
+pco2 <- dudi.pco(dAct, scannf = FALSE)
+## Projection of site 6 (four seasons, without Oxyg variable)
+## Supplementary items must be normalized
+f1 <- function(w) (w - envpca2$cent) / envpca2$norm
+envSup <- t(apply(meau$env[seq(6, 24, 6), -5], 1, f1))
+envTot <- rbind.data.frame(envpca2$tab, envSup)
+dTot <- dist(envTot)
+fSA2 <- as.factor(rep(c("A", "S"), c(20, 4)))
+cSup2 <- supdist(dTot, fSA2)
+## Supplementary items vs. real items
+if(!adegraphicsLoaded()) {
+ par(mfrow = c(1, 2))
+ s.label(pco1$li)
+ s.label(rbind.data.frame(pco2$li, cSup2$coordSup[, 1:2]))
+} else {
+ gl1 <- s.label(pco1$li, plabels.optim = TRUE)
+ gl2 <- s.label(rbind.data.frame(pco2$li, cSup2$coordSup[, 1:2]),
+ plabels.optim = TRUE)
+ ADEgS(list(gl1, gl2))
+}
+}
+
+\keyword{multivariate}
\ No newline at end of file
diff --git a/man/suprow.Rd b/man/suprow.Rd
new file mode 100644
index 0000000..b95d101
--- /dev/null
+++ b/man/suprow.Rd
@@ -0,0 +1,80 @@
+\name{suprow}
+\alias{suprow}
+\alias{suprow.coa}
+\alias{suprow.pca}
+\alias{suprow.dudi}
+\alias{predict.dudi}
+\alias{suprow.acm}
+\alias{suprow.mix}
+\title{Projections of Supplementary Rows}
+\description{
+This function performs a projection of supplementary rows (i.e. supplementary individuals).
+}
+\usage{
+\method{suprow}{coa}(x, Xsup, \dots)
+\method{suprow}{dudi}(x, Xsup, \dots)
+\method{predict}{dudi}(object, newdata, \dots)
+\method{suprow}{pca}(x, Xsup, \dots)
+\method{suprow}{acm}(x, Xsup, \dots)
+\method{suprow}{mix}(x, Xsup, \dots)
+}
+\arguments{
+ \item{x, object}{an object of class \code{dudi}}
+ \item{Xsup, newdata}{an array with the supplementary rows}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\details{
+If \code{suprow.dudi} is used, the column vectors of Xsup are projected without prior modifications onto the principal components of dudi with the scalar product associated to the row weightings of dudi.
+}
+\value{
+\code{predict} returns a data frame containing the coordinates of the supplementary rows. \code{suprow} returns a list with the transformed table \code{Xsup} in \code{tabsup} and the coordinates of the supplementary rows in \code{lisup}.
+}
+\references{
+Gower, J. C. (1967) Multivariate analysis and multivariate geometry. \emph{The statistician}, \bold{17}, 13--28.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(euro123)
+par(mfrow = c(2, 2))
+w <- euro123[[2]]
+dudi1 <- dudi.pca(w, scal = FALSE, scan = FALSE)
+
+if(adegraphicsLoaded()) {
+ g11 <- s.arrow(dudi1$c1, psub.text = "Classical", psub.posi = "bottomright", plot = FALSE)
+ g12 <- s.label(suprow(dudi1, w)$tabsup, plab.cex = 0.75, plot = FALSE)
+ g1 <- superpose(g11, g12)
+
+ g21 <- s.arrow(dudi1$c1, psub.text = "Without centring", psub.posi = "bottomright", plot = FALSE)
+ g22 <- s.label(suprow(dudi1, w)$tabsup, plab.cex = 0.75, plot = FALSE)
+ g2 <- superpose(g21, g22)
+
+ g3 <- triangle.label(w, plab.cex = 0.75, label = row.names(w), adjust = FALSE, plot = FALSE)
+ g4 <- triangle.label(w, plab.cex = 0.75, label = row.names(w), adjust = TRUE, plot = FALSE)
+
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ s.arrow(dudi1$c1, sub = "Classical", possub = "bottomright", csub = 2.5)
+ s.label(suprow(dudi1, w), add.plot = TRUE, clab = 0.75)
+
+ s.arrow(dudi1$c1, sub = "Without centring", possub = "bottomright", csub = 2.5)
+ s.label(suprow(dudi1, w), clab = 0.75, add.plot = TRUE)
+
+ triangle.plot(w, clab = 0.75, label = row.names(w), scal = FALSE)
+ triangle.plot(w, clab = 0.75, label = row.names(w), scal = TRUE)
+}
+
+data(rpjdl)
+rpjdl.coa <- dudi.coa(rpjdl$fau, scann = FALSE, nf = 4)
+rpjdl.coa$li[1:3, ]
+suprow(rpjdl.coa,rpjdl$fau[1:3, ])$lisup #the same
+
+data(deug)
+deug.dudi <- dudi.pca(df = deug$tab, center = deug$cent, scale = FALSE, scannf = FALSE)
+suprow(deug.dudi, deug$tab[1:3, ])$lisup #the supplementary individuals are centered
+deug.dudi$li[1:3, ] # the same
+}
+\keyword{multivariate}
diff --git a/man/symbols.phylog.Rd b/man/symbols.phylog.Rd
new file mode 100644
index 0000000..f9f39a0
--- /dev/null
+++ b/man/symbols.phylog.Rd
@@ -0,0 +1,41 @@
+\name{symbols.phylog}
+\alias{symbols.phylog}
+\title{Representation of a quantitative variable in front of a phylogenetic tree}
+\description{
+\code{symbols.phylog} draws the phylogenetic tree and represents the values of
+ the variable by symbols (squares or circles) which size is proportional to value.
+ White symbols correspond to values which are below the mean, and black symbols
+ correspond to values which are over.
+}
+\usage{
+symbols.phylog(phylog, circles, squares, csize = 1, clegend = 1,
+ sub = "", csub = 1, possub = "topleft")
+}
+\arguments{
+ \item{phylog}{ an object of class \code{phylog}}
+ \item{circles}{ a vector giving the radii of the circles}
+ \item{squares}{ a vector giving the length of the sides of the squares}
+ \item{csize}{ a size coefficient for symbols}
+ \item{clegend}{ a character size for the legend used by \code{par("cex")*clegend}}
+ \item{sub}{ a string of characters to be inserted as legend}
+ \item{csub}{ a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{ a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+}
+\author{
+Daniel Chessel \cr
+Sébastien Ollier \email{sebastien.ollier at u-psud.fr}
+}
+\seealso{\code{\link{table.phylog}} and \code{\link{dotchart.phylog}} for many variables}
+\examples{
+data(mjrochet)
+mjrochet.phy <- newick2phylog(mjrochet$tre)
+tab0 <- data.frame(scalewt(log(mjrochet$tab)))
+par(mfrow=c(3,2))
+for (j in 1:6) {
+ w <- tab0[,j]
+ symbols.phylog(phylog = mjrochet.phy, w, csi = 1.5, cleg = 1.5,
+ sub = names(tab0)[j], csub = 3)
+}
+par(mfrow=c(1,1))
+}
+\keyword{hplot}
diff --git a/man/syndicats.Rd b/man/syndicats.Rd
new file mode 100644
index 0000000..074dd96
--- /dev/null
+++ b/man/syndicats.Rd
@@ -0,0 +1,26 @@
+\name{syndicats}
+\alias{syndicats}
+\docType{data}
+\title{Two Questions asked on a Sample of 1000 Respondents}
+\description{
+This data set is extracted from an opinion poll (period 1970-1980) on 1000 respondents.
+}
+\usage{data(syndicats)}
+\format{
+The \code{syndicats} data frame has 5 rows and 4 columns.\cr
+"Which politic family are you agreeing about?" has 5 response items :
+\code{extgauche} (extreme left) \code{left} \code{center} \code{right} and \code{extdroite} (extreme right)\cr
+"What do you think of the trade importance?" has 4 response items :
+\code{trop} (too important) \code{adequate} \code{insufficient} \code{nesaispas} (no opinion)
+}
+\source{
+ unknown
+}
+\examples{
+data(syndicats)
+par(mfrow = c(1,2))
+dudi1 <- dudi.coa(syndicats, scan = FALSE)
+score (dudi1, 1, TRUE)
+score (dudi1, 1, FALSE)
+}
+\keyword{datasets}
diff --git a/man/t3012.Rd b/man/t3012.Rd
new file mode 100644
index 0000000..80e9087
--- /dev/null
+++ b/man/t3012.Rd
@@ -0,0 +1,34 @@
+\name{t3012}
+\alias{t3012}
+\docType{data}
+\title{Average temperatures of 30 French cities}
+\description{
+ This data set gives the average temperatures of 30 French cities during 12 months.
+}
+\usage{data(t3012)}
+\format{
+ \code{t3012} is a list of 3 objects:
+\describe{
+ \item{xy}{is a data frame with 30 rows (cities) and 2 coordinates (x,y).}
+ \item{temp}{is a data frame with 30 rows (cities) and 12 columns (months). Each column contains the average temperature in tenth of degree Celsius. }
+ \item{contour}{is a data frame with 4 columns (x1,y1,x2,y2) for the contour display of France.}
+}}
+\source{
+Besse, P. (1979)
+\emph{Etude descriptive d'un processus; approximation, interpolation}.
+ Thèse de troisième cycle, Université Paul Sabatier, Toulouse.
+}
+\examples{
+data(t3012)
+data(elec88)
+
+if(adegraphicsLoaded()) {
+ if(requireNamespace("sp", quietly = TRUE)) {
+ s.arrow(t3012$xy, pori.ori = as.numeric(t3012$xy["Paris", ]), Sp = t3012$Spatial,
+ pSp.col = "white", pgrid.draw = FALSE)
+ }
+} else {
+ area.plot(elec88$area)
+ s.arrow(t3012$xy, ori = as.numeric(t3012$xy["Paris", ]), add.p = TRUE)
+}}
+\keyword{datasets}
diff --git a/man/table.cont.Rd b/man/table.cont.Rd
new file mode 100644
index 0000000..3fc37e0
--- /dev/null
+++ b/man/table.cont.Rd
@@ -0,0 +1,54 @@
+\name{table.cont}
+\alias{table.cont}
+\title{Plot of Contingency Tables}
+\description{
+presents a graph for viewing contingency tables.
+}
+\usage{
+table.cont(df, x = 1:ncol(df), y = 1:nrow(df),
+ row.labels = row.names(df), col.labels = names(df),
+ clabel.row = 1, clabel.col = 1, abmean.x = FALSE, abline.x = FALSE,
+ abmean.y = FALSE, abline.y = FALSE, csize = 1, clegend = 0, grid = TRUE)
+}
+\arguments{
+ \item{df}{a data frame with only positive or null values}
+ \item{x}{a vector of values to position the columns}
+ \item{y}{a vector of values to position the rows}
+ \item{row.labels}{a character vector for the row labels}
+ \item{col.labels}{a character vetor for the column labels}
+ \item{clabel.row}{a character size for the row labels}
+ \item{clabel.col}{a character size for the column labels}
+ \item{abmean.x}{a logical value indicating whether the column conditional means should be drawn}
+ \item{abline.x}{a logical value indicating whether the regression line of y onto x should be plotted}
+ \item{abmean.y}{a logical value indicating whether the row conditional means should be drawn}
+ \item{abline.y}{a logical value indicating whether the regression line of x onto y should be plotted}
+ \item{csize}{a coefficient for the square size of the values}
+ \item{clegend}{if not NULL, a character size for the legend used with \code{par("cex")*clegend}}
+ \item{grid}{a logical value indicating whether a grid in the background of the plot should be drawn}
+}
+\author{
+Daniel Chessel
+}
+\examples{
+data(chats)
+chatsw <- data.frame(t(chats))
+chatscoa <- dudi.coa(chatsw, scann = FALSE)
+par(mfrow = c(2,2))
+table.cont(chatsw, abmean.x = TRUE, csi = 2, abline.x = TRUE,
+ clabel.r = 1.5, clabel.c = 1.5)
+table.cont(chatsw, abmean.y = TRUE, csi = 2, abline.y = TRUE,
+ clabel.r = 1.5, clabel.c = 1.5)
+table.cont(chatsw, x = chatscoa$c1[,1], y = chatscoa$l1[,1],
+ abmean.x = TRUE, csi = 2, abline.x = TRUE, clabel.r = 1.5, clabel.c = 1.5)
+table.cont(chatsw, x = chatscoa$c1[,1], y = chatscoa$l1[,1],
+ abmean.y = TRUE, csi = 2, abline.y = TRUE, clabel.r = 1.5, clabel.c = 1.5)
+par(mfrow = c(1,1))
+
+\dontrun{
+data(rpjdl)
+w <- data.frame(t(rpjdl$fau))
+wcoa <- dudi.coa(w, scann = FALSE)
+table.cont(w, abmean.y = TRUE, x = wcoa$c1[,1], y = rank(wcoa$l1[,1]),
+ csi = 0.2, clabel.c = 0, row.labels = rpjdl$lalab, clabel.r = 0.75)
+}}
+\keyword{hplot}
diff --git a/man/table.dist.Rd b/man/table.dist.Rd
new file mode 100644
index 0000000..2de76f8
--- /dev/null
+++ b/man/table.dist.Rd
@@ -0,0 +1,26 @@
+\name{table.dist}
+\alias{table.dist}
+\title{Graph Display for Distance Matrices}
+\description{
+presents a graph for viewing distance matrices.
+}
+\usage{
+table.dist(d, x = 1:(attr(d, "Size")), labels = as.character(x),
+ clabel = 1, csize = 1, grid = TRUE)
+}
+\arguments{
+ \item{d}{an object of class \code{dist}}
+ \item{x}{a vector of the row and column positions}
+ \item{labels}{a vector of strings of characters for the labels}
+ \item{clabel}{a character size for the labels}
+ \item{csize}{a coefficient for the circle size}
+ \item{grid}{a logical value indicating whether a grid in the background of the plot should be drawn}
+}
+\author{
+Daniel Chessel
+}
+\examples{
+data(eurodist)
+table.dist(eurodist, labels = attr(eurodist, "Labels"))
+}
+\keyword{hplot}
diff --git a/man/table.paint.Rd b/man/table.paint.Rd
new file mode 100644
index 0000000..3c57fd2
--- /dev/null
+++ b/man/table.paint.Rd
@@ -0,0 +1,43 @@
+\name{table.paint}
+\alias{table.paint}
+\title{Plot of the arrays by grey levels}
+\description{
+presents a graph for viewing the numbers of a table by grey levels.
+}
+\usage{
+table.paint(df, x = 1:ncol(df), y = nrow(df):1,
+ row.labels = row.names(df), col.labels = names(df),
+ clabel.row = 1, clabel.col = 1, csize = 1, clegend = 1)
+}
+\arguments{
+ \item{df}{a data frame}
+ \item{x}{a vector of values to position the columns, used only for the ordered values}
+ \item{y}{a vector of values to position the rows, used only for the ordered values}
+ \item{row.labels}{a character vector for the row labels}
+ \item{col.labels}{a character vector for the column labels}
+ \item{clabel.row}{a character size for the row labels}
+ \item{clabel.col}{a character size for the column labels}
+ \item{csize}{if 'clegend' not NULL, a coefficient for the legend size}
+ \item{clegend}{a character size for the legend, otherwise no legend}
+}
+\author{
+Daniel Chessel
+}
+\examples{
+data(rpjdl)
+X <- data.frame(t(rpjdl$fau))
+Y <- data.frame(t(rpjdl$mil))
+layout(matrix(c(1,2,2,2,1,2,2,2,1,2,2,2,1,2,2,2), 4, 4))
+coa1 <- dudi.coa(X, scan = FALSE)
+x <- rank(coa1$co[,1])
+y <- rank(coa1$li[,1])
+table.paint(Y, x = x, y = 1:8, clabel.c = 0, cleg = 0)
+abline(v = 114.9, lwd = 3, col = "red")
+abline(v = 66.4, lwd = 3, col = "red")
+table.paint(X, x = x, y = y, clabel.c = 0, cleg = 0,
+ row.lab = paste(" ", row.names(X), sep = ""))
+abline(v = 114.9, lwd = 3, col = "red")
+abline(v = 66.4, lwd = 3, col = "red")
+par(mfrow = c(1, 1))
+}
+\keyword{hplot}
diff --git a/man/table.phylog.Rd b/man/table.phylog.Rd
new file mode 100644
index 0000000..537834d
--- /dev/null
+++ b/man/table.phylog.Rd
@@ -0,0 +1,48 @@
+\name{table.phylog}
+\alias{table.phylog}
+\title{Plot arrays in front of a phylogenetic tree}
+\description{
+This function gives a graphical display for viewing the numbers of a table by square sizes in front of the corresponding phylogenetic tree.
+}
+\usage{
+table.phylog(df, phylog, x = 1:ncol(df), f.phylog = 0.5,
+ labels.row = gsub("[_]", " ", row.names(df)), clabel.row = 1,
+ labels.col = names(df), clabel.col = 1,
+ labels.nod = names(phylog$nodes), clabel.nod = 0, cleaves = 1,
+ cnodes = 1, csize = 1, grid = TRUE, clegend = 0.75)
+}
+\arguments{
+ \item{df}{: a data frame or a matrix}
+ \item{phylog}{: an object of class \code{'phylog'}}
+ \item{x}{: a vector of values to position the columns}
+ \item{f.phylog}{: a size coefficient for tree size (a parameter to draw the tree in proportion to leaves labels)}
+ \item{labels.row}{: a vector of strings of characters for row labels}
+ \item{clabel.row}{: a character size for the leaves labels, used with \code{par("cex")*clabel.row}. If zero, no row labels are drawn}
+ \item{labels.col}{: a vector of strings of characters for columns labels}
+ \item{clabel.col}{: a character size for the leaves labels, used with \code{par("cex")*clabel.col}. If zero, no column labels are drawn}
+ \item{labels.nod}{: a vector of strings of characters for the nodes labels}
+ \item{clabel.nod}{: a character size for the nodes labels, used with \code{par("cex")*clabel.nodes}. If zero, no nodes labels are drawn}
+ \item{cleaves}{: a character size for plotting the points that represent the leaves, used with \code{par("cex")*cleaves}. If zero, no points are drawn}
+ \item{cnodes}{: a character size for plotting the points that represent the nodes, used with \code{par("cex")*cnodes}. If zero, no points are drawn}
+ \item{csize}{: a size coefficient for symbols}
+ \item{grid}{: a logical value indicating whether the grid should be plotted}
+ \item{clegend}{: a character size for the legend (if 0, no legend)}
+}
+\author{Daniel Chessel \cr
+Sébastien Ollier \email{sebastien.ollier at u-psud.fr}
+}
+\details{The function verifies that \code{sort(row.names(df))==sort(names(phylog$leaves))}.
+If \code{df} is a matrix the function uses \code{as.data.frame(df)}. }
+
+\seealso{\code{\link{symbols.phylog}} for one variable}
+\examples{
+\dontrun{
+data(newick.eg)
+w.phy <- newick2phylog(newick.eg[[9]])
+w.tab <- data.frame(matrix(rnorm(620), 31, 20))
+row.names(w.tab) <- sort(names(w.phy$leaves))
+table.phylog(w.tab, w.phy, csi = 1.5, f = 0.5,
+ clabel.n = 0.75, clabel.c = 0.5)
+}
+}
+\keyword{hplot}
diff --git a/man/table.value.Rd b/man/table.value.Rd
new file mode 100644
index 0000000..eb272d3
--- /dev/null
+++ b/man/table.value.Rd
@@ -0,0 +1,42 @@
+\name{table.value}
+\alias{table.value}
+\alias{table.prepare}
+\title{Plot of the Arrays}
+\description{
+presents a graph for viewing the numbers of a table by square sizes.
+}
+\usage{
+table.value(df, x = 1:ncol(df), y = nrow(df):1,
+ row.labels = row.names(df), col.labels = names(df), clabel.row = 1,
+ clabel.col = 1, csize = 1, clegend = 1, grid = TRUE)
+}
+\arguments{
+ \item{df}{a data frame}
+ \item{x}{a vector of values to position the columns}
+ \item{y}{a vector of values to position the rows}
+ \item{row.labels}{a character vector for the row labels}
+ \item{col.labels}{a character vector for the column labels}
+ \item{clabel.row}{a character size for the row labels}
+ \item{clabel.col}{a character size for the column labels}
+ \item{csize}{a coefficient for the square size of the values}
+ \item{clegend}{a character size for the legend (if 0, no legend)}
+ \item{grid}{a logical value indicating whether the grid should be plotted}
+}
+\author{
+Daniel Chessel
+}
+\examples{
+if(!adegraphicsLoaded()) {
+ data(olympic)
+ w <- olympic$tab
+ w <- data.frame(scale(w))
+ wpca <- dudi.pca(w, scann = FALSE)
+ par(mfrow = c(1, 3))
+ table.value(w, csi = 2, clabel.r = 2, clabel.c = 2)
+ table.value(w, y = rank(wpca$li[, 1]), x = rank(wpca$co[, 1]), csi = 2,
+ clabel.r = 2, clabel.c = 2)
+ table.value(w, y = wpca$li[, 1], x = wpca$co[, 1], csi = 2,
+ clabel.r = 2, clabel.c = 2)
+ par(mfrow = c(1, 1))
+}}
+\keyword{hplot}
diff --git a/man/tarentaise.Rd b/man/tarentaise.Rd
new file mode 100644
index 0000000..ad5c523
--- /dev/null
+++ b/man/tarentaise.Rd
@@ -0,0 +1,50 @@
+\name{tarentaise}
+\alias{tarentaise}
+\docType{data}
+\title{Mountain Avifauna}
+\description{
+This data set gives informations between sites, species, environmental and biolgoical variables.
+}
+\usage{data(tarentaise)}
+\format{
+ \code{tarentaise} is a list of 5 components.
+ \describe{
+ \item{ecol}{is a data frame with 376 sites and 98 bird species.}
+ \item{frnames}{is a vector of the 98 French names of the species.}
+ \item{alti}{is a vector giving the altitude of the 376 sites in m.}
+ \item{envir}{is a data frame with 14 environmental variables.}
+ \item{traits}{is a data frame with 29 biological variables of the 98 species.}
+ }
+}
+\details{
+The attribute \code{col.blocks} of the data frame \code{tarentaise$traits} indicates it is composed of 6 units of variables.
+}
+\source{
+Original data from Hubert Tournier, University of Savoie and Philippe Lebreton, University of Lyon 1.
+}
+\references{
+Lebreton, P., Tournier H. and Lebreton J. D. (1976)
+Etude de l'avifaune du Parc National de la Vanoise
+VI Recherches d'ordre quantitatif sur les Oiseaux forestiers de Vanoise.
+\emph{Travaux Scientifiques du parc National de la vanoise}, \bold{7}, 163--243.
+
+Lebreton, Ph. and Martinot, J.P. (1998)
+Oiseaux de Vanoise. Guide de l'ornithologue en montagne.
+\emph{Libris}, Grenoble. 1--240.
+
+Lebreton, Ph., Lebrun, Ph., Martinot, J.P., Miquet, A. and Tournier, H. (1999)
+Approche écologique de l'avifaune de la Vanoise.
+\emph{Travaux scientifiques du Parc national de la Vanoise}, \bold{21}, 7--304.
+
+See a data description at \url{http://pbil.univ-lyon1.fr/R/pdf/pps038.pdf} (in French).
+}
+\examples{
+data(tarentaise)
+coa1 <- dudi.coa(tarentaise$ecol, sca = FALSE, nf = 2)
+s.class(coa1$li, tarentaise$envir$alti, wt = coa1$lw)
+\dontrun{
+acm1 <- dudi.acm(tarentaise$envir, sca = FALSE, nf = 2)
+s.class(acm1$li, tarentaise$envir$alti)
+}
+}
+\keyword{datasets}
diff --git a/man/taxo.eg.Rd b/man/taxo.eg.Rd
new file mode 100644
index 0000000..53a5953
--- /dev/null
+++ b/man/taxo.eg.Rd
@@ -0,0 +1,39 @@
+\name{taxo.eg}
+\alias{taxo.eg}
+\docType{data}
+\title{Examples of taxonomy}
+\description{
+This data sets contains two taxonomies.
+}
+\usage{data(taxo.eg)}
+\format{
+\code{taxo.eg} is a list containing the 2 following objects:
+\describe{
+ \item{taxo.eg[[1]]}{is a data frame with 15 species and 3 columns.}
+ \item{taxo.eg[[2]]}{is a data frame with 40 species and 2 columns.}
+ }}
+ \details{
+ Variables of the first data frame are : genre (a factor genre with 8 levels),
+ famille (a factor familiy with 5 levels) and ordre (a factor order with 2 levels).\cr
+
+Variables of the second data frame are : gen(a factor genre with 29 levels),
+fam (a factor family with 19 levels).
+}
+\examples{
+data(taxo.eg)
+taxo.eg[[1]]
+as.taxo(taxo.eg[[1]])
+class(taxo.eg[[1]])
+class(as.taxo(taxo.eg[[1]]))
+
+tax.phy <- taxo2phylog(as.taxo(taxo.eg[[1]]), add.tools = TRUE)
+plot(tax.phy,clabel.l=1)
+
+par(mfrow = c(1,2))
+table.phylog(tax.phy$Bindica,tax.phy)
+table.phylog(tax.phy$Bscores,tax.phy)
+par(mfrow = c(1,1))
+
+radial.phylog(taxo2phylog(as.taxo(taxo.eg[[2]])))
+}
+\keyword{datasets}
diff --git a/man/testdim.Rd b/man/testdim.Rd
new file mode 100644
index 0000000..b408a8b
--- /dev/null
+++ b/man/testdim.Rd
@@ -0,0 +1,52 @@
+\name{testdim}
+\alias{testdim}
+\alias{testdim.pca}
+\title{ Function to perform a test of dimensionality}
+\description{
+This functions allow to test for the number of axes in multivariate analysis. The
+procedure \code{testdim.pca} implements a method for principal component analysis on
+correlation matrix. The procedure is based on the computation of the RV coefficient.
+}
+\usage{
+testdim(object, ...)
+\method{testdim}{pca}(object, nrepet = 99, nbax = object$rank, alpha = 0.05, ...)
+}
+
+\arguments{
+ \item{object}{ an object corresponding to an analysis (e.g. duality diagram, an object of class \code{dudi})}
+ \item{nrepet}{ the number of repetitions for the permutation procedure}
+ \item{nbax}{ the number of axes to be tested, by default all axes}
+ \item{alpha}{ the significance level}
+ \item{\dots}{ other arguments}
+
+}
+
+\value{
+ An object of the class \code{krandtest}. It contains also:
+ \item{nb}{The estimated number of axes to keep}
+ \item{nb.cor}{The number of axes to keep estimated using a sequential Bonferroni
+ procedure}
+}
+\references{
+ Dray, S. (2008) On the number of principal components: A test of
+ dimensionality based on measurements of similarity between
+ matrices. \emph{Computational Statistics and Data Analysis}, \bold{Volume 52}, 2228--2237. doi:10.1016/j.csda.2007.07.015
+}
+\author{Stéphane Dray \email{stephane.dray at univ-lyon1.fr}}
+\seealso{\code{\link{dudi.pca}}, \code{\link{RV.rtest}},\code{\link{testdim.multiblock}}}
+\examples{
+tab <- data.frame(matrix(rnorm(200),20,10))
+pca1 <- dudi.pca(tab,scannf=FALSE)
+test1 <- testdim(pca1)
+test1
+test1$nb
+test1$nb.cor
+data(doubs)
+pca2 <- dudi.pca(doubs$env,scannf=FALSE)
+test2 <- testdim(pca2)
+test2
+test2$nb
+test2$nb.cor
+}
+\keyword{ multivariate }
+
diff --git a/man/testdim.multiblock.Rd b/man/testdim.multiblock.Rd
new file mode 100644
index 0000000..778be61
--- /dev/null
+++ b/man/testdim.multiblock.Rd
@@ -0,0 +1,45 @@
+\name{testdim.multiblock}
+\alias{testdim.multiblock}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Selection of the number of dimension by two-fold cross-validation for multiblock methods}
+\description{Function to perform a two-fold cross-validation to select the optimal number of dimensions of multiblock methods, \emph{i.e.}, multiblock principal component analysis with instrumental Variables or multiblock partial least squares}
+\usage{
+\method{testdim}{multiblock}(object, nrepet = 100, quantiles = c(0.25, 0.75), ...)
+}
+
+\arguments{
+ \item{object}{an object of class multiblock created by \code{\link{mbpls}}
+ or \code{\link{mbpcaiv}}}
+ \item{nrepet}{integer indicating the number of repetitions}
+ \item{quantiles}{a vector indicating the lower and upper quantiles to compute}
+ \item{\dots}{other arguments to be passed to methods}
+}
+
+\value{An object of class \code{krandxval}}
+
+\references{Stone M. (1974) Cross-validatory choice and assessment of
+ statistical predictions. \emph{Journal of the Royal Statistical
+ Society}, 36, 111-147}
+
+\author{Stéphanie Bougeard (\email{stephanie.bougeard at anses.fr}) and Stéphane Dray (\email{stephane.dray at univ-lyon1.fr})}
+
+\seealso{\code{\link{mbpcaiv}}, \code{\link{mbpls}},
+ \code{\link{randboot.multiblock}}, \code{\link{as.krandxval}}}
+
+\examples{
+data(chickenk)
+Mortality <- chickenk[[1]]
+dudiY.chick <- dudi.pca(Mortality, center = TRUE, scale = TRUE, scannf =
+FALSE)
+ktabX.chick <- ktab.list.df(chickenk[2:5])
+resmbpcaiv.chick <- mbpcaiv(dudiY.chick, ktabX.chick, scale = TRUE,
+option = "uniform", scannf = FALSE)
+## nrepet should be higher for a real analysis
+test <- testdim(resmbpcaiv.chick, nrepet = 10)
+test
+if(adegraphicsLoaded())
+plot(test)
+
+}
+
+\keyword{multivariate}
diff --git a/man/tintoodiel.Rd b/man/tintoodiel.Rd
new file mode 100644
index 0000000..ed11a60
--- /dev/null
+++ b/man/tintoodiel.Rd
@@ -0,0 +1,41 @@
+\name{tintoodiel}
+\alias{tintoodiel}
+\docType{data}
+\title{Tinto and Odiel estuary geochemistry}
+\description{
+This data set contains informations about geochemical characteristics of heavy metal pollution in surface sediments of the Tinto and Odiel river estuary (south-western Spain).
+}
+\usage{data(tintoodiel)}
+\format{
+\code{tintoodiel} is a list containing the following objects :
+\describe{
+ \item{xy}{: a data frame that contains spatial coordinates of the 52 sites}
+ \item{tab}{: a data frame with 12 columns (concentration of heavy metals) and 52 rows (sites)}
+ \item{neig}{: an object of class \code{neig}}
+}}
+\source{
+Borrego, J., Morales, J.A., de la Torre, M.L. and Grande, J.A. (2002) Geochemical characteristics of heavy metal pollution in surface sediments of the Tinto and Odiel river estuary (south-western Spain). \emph{Environmental Geology}, \bold{41}, 785--796.
+}
+\examples{
+data(tintoodiel)
+if(!adegraphicsLoaded()) {
+ \dontrun{
+ if(requireNamespace("pixmap", quietly = TRUE)) {
+ estuary.pnm <- pixmap::read.pnm(system.file("pictures/tintoodiel.pnm", package = "ade4"))
+ s.label(tintoodiel$xy, pixmap = estuary.pnm, neig = tintoodiel$neig,
+ clab = 0, cpoi = 2, cneig = 3, addax = FALSE, cgrid = 0, grid = FALSE)
+ }}
+
+ estuary.pca <- dudi.pca(tintoodiel$tab, scan = FALSE, nf = 4)
+
+ if(requireNamespace("maptools", quietly = TRUE) & requireNamespace("spdep", quietly = TRUE)) {
+ estuary.listw <- spdep::nb2listw(neig2nb(tintoodiel$neig))
+ estuary.pca.ms <- multispati(estuary.pca, estuary.listw, scan = FALSE, nfposi = 3, nfnega = 2)
+ summary(estuary.pca.ms)
+ par(mfrow = c(1, 2))
+ barplot(estuary.pca$eig)
+ barplot(estuary.pca.ms$eig)
+ par(mfrow = c(1, 1))
+}}}
+
+\keyword{datasets}
diff --git a/man/tithonia.Rd b/man/tithonia.Rd
new file mode 100644
index 0000000..df43d54
--- /dev/null
+++ b/man/tithonia.Rd
@@ -0,0 +1,44 @@
+\name{tithonia}
+\alias{tithonia}
+\docType{data}
+\title{Phylogeny and quantitative traits of flowers}
+\description{
+This data set describes the phylogeny of 11 flowers as reported by Morales (2000). It also gives morphologic and demographic traits corresponding to these 11 species.
+}
+\usage{data(tithonia)}
+\format{
+\code{tithonia} is a list containing the 2 following objects :
+\describe{
+ \item{tre}{is a character string giving the phylogenetic tree in Newick format.}
+ \item{tab}{is a data frame with 11 species and 14 traits (6 morphologic traits and 8 demographic).}
+}}
+\details{
+Variables of \code{tithonia$tab} are the following ones : \cr
+morho1: is a numeric vector that describes the seed size (mm)\cr
+morho2: is a numeric vector that describes the flower size (mm)\cr
+morho3: is a numeric vector that describes the female leaf size (cm)\cr
+morho4: is a numeric vector that describes the head size (mm)\cr
+morho5: is a integer vector that describes the number of flowers per head \cr
+morho6: is a integer vector that describes the number of seeds per head \cr
+demo7: is a numeric vector that describes the seedling height (cm)\cr
+demo8: is a numeric vector that describes the growth rate (cm/day)\cr
+demo9: is a numeric vector that describes the germination time\cr
+demo10: is a numeric vector that describes the establishment (per cent)\cr
+demo11: is a numeric vector that describes the viability (per cent)\cr
+demo12: is a numeric vector that describes the germination (per cent)\cr
+demo13: is a integer vector that describes the resource allocation\cr
+demo14: is a numeric vector that describes the adult height (m)\cr
+}
+\source{
+Data were obtained from Morales, E. (2000) Estimating phylogenetic inertia in Tithonia (Asteraceae) :
+a comparative approach. \emph{Evolution}, \bold{54}, 2, 475--484.
+}
+\examples{
+data(tithonia)
+phy <- newick2phylog(tithonia$tre)
+tab <- log(tithonia$tab + 1)
+table.phylog(scalewt(tab), phy)
+gearymoran(phy$Wmat, tab)
+gearymoran(phy$Amat, tab)
+}
+\keyword{datasets}
diff --git a/man/tortues.Rd b/man/tortues.Rd
new file mode 100644
index 0000000..123596a
--- /dev/null
+++ b/man/tortues.Rd
@@ -0,0 +1,29 @@
+\name{tortues}
+\alias{tortues}
+\docType{data}
+\title{Morphological Study of the Painted Turtle}
+\description{
+This data set gives a morphological description (4 characters) of 48 turtles.
+}
+\usage{data(tortues)}
+\format{
+a data frame with 48 rows and 4 columns (length (mm), maximum width(mm), height (mm), gender).
+}
+\source{
+Jolicoeur, P. and Mosimann, J. E. (1960)
+Size and shape variation in the painted turtle. A principal component analysis.
+\emph{Growth}, \bold{24}, 339--354.
+}
+\examples{
+data(tortues)
+xyz <- as.matrix(tortues[, 1:3])
+ref <- -svd(xyz)$u[, 1]
+pch0 <- c(1, 20)[as.numeric(tortues$sexe)]
+plot(ref, xyz[, 1], ylim = c(40, 180), pch = pch0)
+abline(lm(xyz[, 1] ~ -1 + ref))
+points(ref,xyz[, 2], pch = pch0)
+abline(lm(xyz[, 2] ~ -1 + ref))
+points(ref,xyz[, 3], pch = pch0)
+abline(lm(xyz[, 3] ~ -1 + ref))
+}
+\keyword{datasets}
diff --git a/man/toxicity.Rd b/man/toxicity.Rd
new file mode 100644
index 0000000..d871b07
--- /dev/null
+++ b/man/toxicity.Rd
@@ -0,0 +1,35 @@
+\name{toxicity}
+\alias{toxicity}
+\docType{data}
+\title{Homogeneous Table}
+\description{
+This data set gives the toxicity of 7 molecules on 17 targets
+ expressed in -log(mol/liter)
+}
+\usage{data(toxicity)}
+\format{
+\code{toxicity} is a list of 3 components.
+ \describe{
+ \item{tab}{is a data frame with 7 columns and 17 rows}
+ \item{species}{is a vector of the names of the species in the 17 targets}
+ \item{chemicals}{is a vector of the names of the 7 molecules}
+ }
+}
+\source{
+Devillers, J., Thioulouse, J. and Karcher W. (1993)
+Chemometrical Evaluation of Multispecies-Multichemical Data by Means
+of Graphical Techniques Combined with Multivariate Analyses.
+\emph{Ecotoxicology and Environnemental Safety}, \bold{26}, 333--345.
+}
+\examples{
+data(toxicity)
+if(adegraphicsLoaded()) {
+ table.image(toxicity$tab, labelsy = toxicity$species, labelsx = toxicity$chemicals, nclass = 7,
+ ptable.margin = list(b = 5, l = 25, t = 25, r = 5), ptable.y.pos = "left", pgrid.draw = TRUE)
+ table.value(toxicity$tab, labelsy = toxicity$species, labelsx = toxicity$chemicals,
+ ptable.margin = list(b = 5, l = 5, t = 25, r = 26))
+} else {
+ table.paint(toxicity$tab, row.lab = toxicity$species, col.lab = toxicity$chemicals)
+ table.value(toxicity$tab, row.lab = toxicity$species, col.lab = toxicity$chemicals)
+}}
+\keyword{datasets}
diff --git a/man/triangle.class.Rd b/man/triangle.class.Rd
new file mode 100644
index 0000000..164269a
--- /dev/null
+++ b/man/triangle.class.Rd
@@ -0,0 +1,59 @@
+\name{triangle.class}
+\alias{triangle.class}
+\title{ Triangular Representation and Groups of points }
+\description{
+ Function to plot triangular data (i.e. dataframe with 3 columns of
+ positive or null values) and a partition \cr
+}
+\usage{
+triangle.class(ta, fac, col = rep(1, length(levels(fac))),
+ wt = rep(1, length(fac)), cstar = 1, cellipse = 0, axesell = TRUE,
+ label = levels(fac), clabel = 1, cpoint = 1, pch = 20, draw.line = TRUE,
+ addaxes = FALSE, addmean = FALSE, labeltriangle = TRUE, sub = "", csub = 1,
+ possub = "bottomright", show.position = TRUE, scale = TRUE, min3 = NULL,
+ max3 = NULL)
+}
+\arguments{
+ \item{ta}{ a data frame with 3 columns of null or positive numbers }
+ \item{fac}{ a factor of length the row number of \code{ta} }
+ \item{col}{ a vector of color for showing the groups }
+ \item{wt}{ a vector of row weighting for the computation of the gravity centers by class }
+ \item{cstar}{ a character size for plotting the stars between 0 (no stars) and 1 (complete star) for a line linking a point to the gravity center of its belonging class. }
+ \item{cellipse}{ a positive coefficient for the inertia ellipse size }
+ \item{axesell}{ a logical value indicating whether the ellipse axes should be drawn }
+ \item{label}{ a vector of strings of characters for the labels of gravity centers }
+ \item{clabel}{ if not NULL, a character size for the labels, used with \code{par("cex")*clabel} }
+ \item{cpoint}{ a character size for plotting the points, used with \code{par("cex")*cpoint}. If zero, no points are drawn }
+ \item{pch}{ if \code{cpoint} > 0, an integer specifying the symbol or the single character to be used in plotting points }
+ \item{draw.line}{ a logical value indicating whether the triangular lines should be drawn }
+ \item{addaxes}{ a logical value indicating whether the axes should be plotted }
+ \item{addmean}{ a logical value indicating whether the mean point should be plotted }
+ \item{labeltriangle}{ a logical value indicating whether the varliable labels of \code{ta} should be drawn on the triangular sides }
+ \item{sub}{ a string of characters for the graph title }
+ \item{csub}{ a character size for plotting the graph title }
+ \item{possub}{ a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright") }
+ \item{show.position}{ a logical value indicating whether the sub-triangle containing the data should be put back in the total triangle }
+ \item{scale}{a logical value for the graph representation : the total triangle (FALSE) or the sub-triangle (TRUE) }
+ \item{min3}{ if not NULL, a vector with 3 numbers between 0 and 1 }
+ \item{max3}{ if not NULL, a vector with 3 numbers between 0 and 1. Let notice that \code{min3}+\code{max3} must equal c(1,1,1) }
+}
+\author{ Daniel Chessel}
+\examples{
+if(!adegraphicsLoaded()) {
+ data(euro123)
+ par(mfrow = c(2, 2))
+ x <- rbind.data.frame(euro123$in78, euro123$in86, euro123$in97)
+ triangle.plot(x)
+ triangle.class(x, as.factor(rep("G", 36)), csta = 0.5, cell = 1)
+ triangle.class(x, euro123$plan$an)
+ triangle.class(x, euro123$plan$pays)
+ triangle.class(x, euro123$plan$an, cell = 1, axesell = TRUE)
+ triangle.class(x, euro123$plan$an, cell = 0, csta = 0,
+ col = c("red", "green", "blue"), axesell = TRUE, clab = 2, cpoi = 2)
+ triangle.class(x, euro123$plan$an, cell = 2, csta = 0.5,
+ axesell = TRUE, clab = 1.5)
+ triangle.class(x, euro123$plan$an, cell = 0, csta = 1, scale = FALSE,
+ draw.line = FALSE, show.posi = FALSE)
+ par(mfrow = c(2, 2))
+}}
+\keyword{ hplot }
diff --git a/man/triangle.plot.Rd b/man/triangle.plot.Rd
new file mode 100644
index 0000000..51702a8
--- /dev/null
+++ b/man/triangle.plot.Rd
@@ -0,0 +1,76 @@
+\name{triangle.plot}
+\alias{triangle.plot}
+\alias{triangle.biplot}
+\alias{triangle.param}
+\alias{triangle.posipoint}
+\alias{add.position.triangle}
+\title{Triangular Plotting}
+\description{
+ Graphs for a dataframe with 3 columns of positive or null values\cr
+ \code{triangle.plot} is a scatterplot\cr
+ \code{triangle.biplot} is a paired scatterplots\cr
+ \code{triangle.posipoint}, \code{triangle.param}, \code{add.position.triangle} are utilitaries functions.
+}
+\usage{
+triangle.plot(ta, label = as.character(1:nrow(ta)), clabel = 0,
+ cpoint = 1, draw.line = TRUE, addaxes = FALSE, addmean = FALSE,
+ labeltriangle = TRUE, sub = "", csub = 0, possub = "topright",
+ show.position = TRUE, scale = TRUE, min3 = NULL, max3 = NULL,
+ box = FALSE)
+triangle.biplot (ta1, ta2, label = as.character(1:nrow(ta1)),
+ draw.line = TRUE, show.position = TRUE, scale = TRUE)
+}
+\arguments{
+ \item{ta, ta1, ta2,}{data frame with three columns, will be transformed in \bold{percentages} by rows}
+ \item{label}{a vector of strings of characters for the point labels}
+ \item{clabel}{if not NULL, a character size for the labels, used with \code{par("cex")*clabel}}
+ \item{cpoint}{a character size for plotting the points, used with \code{par("cex")*cpoint}. If zero, no points are drawn}
+ \item{draw.line}{a logical value indicating whether the lines into the triangle should be drawn}
+ \item{addaxes}{a logical value indicating whether the principal axes should be drawn}
+ \item{addmean}{a logical value indicating whether the mean should be plotted}
+ \item{labeltriangle}{a logical value indicating whether the variable names should be wrote}
+ \item{sub}{a string of characters to be inserted as legend}
+ \item{csub}{a character size for the legend, used with \code{par("cex")*csub}}
+ \item{possub}{a string of characters indicating the sub-title position ("topleft", "topright", "bottomleft", "bottomright")}
+ \item{show.position}{a logical value indicating whether the used triangle should be shown in the complete one}
+ \item{scale}{a logical value indicating whether the smaller equilateral triangle containing the plot should be used}
+ \item{min3}{If scale is FALSE, a vector of three values for the minima e.g. c(0.1,0.1,0.1) can be used}
+ \item{max3}{If scale is FALSE a vector of three values for the maxima e.g. c(0.9,0.9,0.9) can be used}
+ \item{box}{a logical value indicating whether a box around the current plot should be drawn}
+}
+\value{
+\code{triangle.plot} returns an invisible matrix containing the coordinates used for the plot. The graph can be supplemented in various ways.
+}
+\author{
+Daniel Chessel
+}
+\examples{
+data(euro123)
+tot <- rbind.data.frame(euro123$in78, euro123$in86, euro123$in97)
+row.names(tot) <- paste(row.names(euro123$in78), rep(c(1, 2, 3), rep(12, 3)), sep = "")
+triangle.plot(tot, label = row.names(tot), clab = 1)
+
+par(mfrow = c(2, 2))
+triangle.plot(euro123$in78, clab = 0, cpoi = 2, addmean = TRUE, show = FALSE)
+triangle.plot(euro123$in86, label = row.names(euro123$in78), clab = 0.8)
+triangle.biplot(euro123$in78, euro123$in86)
+triangle.plot(rbind.data.frame(euro123$in78, euro123$in86), clab = 1,
+ addaxes = TRUE, sub = "Principal axis", csub = 2, possub = "topright")
+
+triangle.plot(euro123[[1]], min3 = c(0, 0.2, 0.3), max3 = c(0.5, 0.7, 0.8),
+ clab = 1, label = row.names(euro123[[1]]), addax = TRUE)
+triangle.plot(euro123[[2]], min3 = c(0, 0.2, 0.3), max3 = c(0.5, 0.7, 0.8),
+ clab = 1, label = row.names(euro123[[1]]), addax = TRUE)
+triangle.plot(euro123[[3]], min3 = c(0, 0.2, 0.3), max3 = c(0.5, 0.7, 0.8),
+ clab = 1, label = row.names(euro123[[1]]), addax = TRUE)
+triangle.plot(rbind.data.frame(euro123[[1]], euro123[[2]], euro123[[3]]))
+
+par(mfrow = c(1, 1))
+wtriangleplot <- cbind.data.frame(a = runif(100), b = runif(100), c = runif(100, 4, 5))
+wtriangleplot <- triangle.plot(wtriangleplot)
+points(wtriangleplot, col = "blue", cex = 2)
+wtriangleplot <- colMeans(wtriangleplot)
+points(wtriangleplot[1], wtriangleplot[2], pch = 20, cex = 3, col = "red")
+rm(wtriangleplot)
+}
+\keyword{hplot}
diff --git a/man/trichometeo.Rd b/man/trichometeo.Rd
new file mode 100644
index 0000000..2073070
--- /dev/null
+++ b/man/trichometeo.Rd
@@ -0,0 +1,44 @@
+\name{trichometeo}
+\alias{trichometeo}
+\docType{data}
+\title{Pair of Ecological Data}
+\description{
+This data set gives for trappong nights informations about
+species and meteorological variables.
+}
+\usage{data(trichometeo)}
+\format{
+\code{trichometeo} is a list of 3 components.
+\describe{
+ \item{fau}{is a data frame with 49 rows (trapping nights) and 17 species.}
+ \item{meteo}{is a data frame with 49 rows and 11 meteorological variables.}
+ \item{cla}{is a factor of 12 levels for the definition of the consecutive night groups}
+ }
+}
+\source{
+Data from P. Usseglio-Polatera
+}
+\references{
+Usseglio-Polatera, P. and Auda, Y. (1987)
+Influence des facteurs météorologiques sur les résultats de piégeage lumineux.
+\emph{Annales de Limnologie}, \bold{23}, 65--79. (code des espèces p. 76)
+
+See a data description at \url{http://pbil.univ-lyon1.fr/R/pdf/pps034.pdf} (in French).
+}
+\examples{
+data(trichometeo)
+faulog <- log(trichometeo$fau + 1)
+pca1 <- dudi.pca(trichometeo$meteo, scan = FALSE)
+niche1 <- niche(pca1, faulog, scan = FALSE)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.distri(niche1$ls, faulog, plab.cex = 0.6, ellipseSize = 0, starSize = 0.3, plot = FALSE)
+ g2 <- s.arrow(7 * niche1$c1, plab.cex = 1, plot = FALSE)
+ G <- superpose(g1, g2, plot = TRUE)
+
+} else {
+ s.label(niche1$ls, clab = 0)
+ s.distri(niche1$ls, faulog, clab = 0.6, add.p = TRUE, cell = 0, csta = 0.3)
+ s.arrow(7 * niche1$c1, clab = 1, add.p = TRUE)
+}}
+\keyword{datasets}
diff --git a/man/ungulates.Rd b/man/ungulates.Rd
new file mode 100644
index 0000000..e8ff432
--- /dev/null
+++ b/man/ungulates.Rd
@@ -0,0 +1,45 @@
+\name{ungulates}
+\alias{ungulates}
+\docType{data}
+\title{Phylogeny and quantitative traits of ungulates.}
+\description{
+This data set describes the phylogeny of 18 ungulates as reported by Pélabon et al. (1995). It also gives 4 traits corresponding to these 18 species.
+}
+\usage{data(ungulates)}
+\format{
+\code{fission} is a list containing the 2 following objects :
+\describe{
+ \item{tre}{is a character string giving the phylogenetic tree in Newick format.}
+ \item{tab}{is a data frame with 18 species and 4 traits}
+}}
+\details{
+Variables of \code{ungulates$tab} are the following ones : \cr
+afbw: is a numeric vector that describes the adult female body weight (g) \cr
+mnw: is a numeric vector that describes the male neonatal weight (g) \cr
+fnw: is a numeric vector that describes the female neonatal weight (g) \cr
+ls: is a numeric vector that describes the litter size \cr
+}
+\source{
+Data were obtained from Pélabon, C., Gaillard, J.M., Loison, A. and Portier, A. (1995)
+Is sex-biased maternal care limited by total maternal expenditure in polygynous ungulates?
+\emph{Behavioral Ecology and Sociobiology}, \bold{37}, 311--319.
+}
+\examples{
+data(ungulates)
+ung.phy <- newick2phylog(ungulates$tre)
+plot(ung.phy,clabel.l=1.25,clabel.n=0.75)
+ung.x <- log(ungulates$tab[,1])
+ung.y <- log((ungulates$tab[,2]+ungulates$tab[,3])/2)
+names(ung.x) <- names(ung.phy$leaves)
+names(ung.y) <- names(ung.x)
+plot(ung.x,ung.y)
+abline(lm(ung.y~ung.x))
+symbols.phylog(ung.phy,ung.x-mean(ung.x))
+dotchart.phylog(ung.phy,ung.x,cle=1.5,cno=1.5,cdot=1)
+orthogram(ung.x,ung.phy$Bscores,nrep=9999)
+ung.z <- residuals(lm(ung.y~ung.x))
+names(ung.z) <- names(ung.phy$leaves)
+dotchart.phylog(ung.phy,ung.z,cle=1.5,cno=1.5,cdot=1,ceti=0.75)
+orthogram(ung.z,ung.phy$Bscores,nrep=9999)
+}
+\keyword{datasets}
diff --git a/man/uniquewt.df.Rd b/man/uniquewt.df.Rd
new file mode 100644
index 0000000..bbf57f9
--- /dev/null
+++ b/man/uniquewt.df.Rd
@@ -0,0 +1,32 @@
+\name{uniquewt.df}
+\alias{uniquewt.df}
+\title{Elimination of Duplicated Rows in a Array}
+\description{
+An utility function to eliminate the duplicated rows in a array.
+}
+\usage{
+uniquewt.df(x)
+}
+\arguments{
+ \item{x}{a data frame which contains duplicated rows}
+}
+\value{
+The function returns a \code{y} which contains once each duplicated row of \code{x}.\cr
+\code{y} is an attribut 'factor' which gives the number of the row of \code{y} in which each row of \code{x} is found\cr
+\code{y} is an attribut 'length.class' which gives the number of duplicates in \code{x} with an attribut of each row of \code{y} with an attribut
+}
+\author{Daniel Chessel }
+\examples{
+data(ecomor)
+forsub.r <- uniquewt.df(ecomor$forsub)
+attr(forsub.r, "factor")
+forsub.r[1,]
+ecomor$forsub[126,] #idem
+
+dudi.pca(ecomor$forsub, scale = FALSE, scann = FALSE)$eig
+# [1] 0.36845 0.24340 0.15855 0.09052 0.07970 0.04490
+w1 <- attr(forsub.r, "len.class") / sum(attr(forsub.r,"len.class"))
+dudi.pca(forsub.r, row.w = w1, scale = FALSE, scann = FALSE)$eig
+# [1] 0.36845 0.24340 0.15855 0.09052 0.07970 0.04490
+}
+\keyword{utilities}
diff --git a/man/variance.phylog.Rd b/man/variance.phylog.Rd
new file mode 100644
index 0000000..b7c5ac4
--- /dev/null
+++ b/man/variance.phylog.Rd
@@ -0,0 +1,48 @@
+\name{variance.phylog}
+\alias{variance.phylog}
+\title{The phylogenetic ANOVA}
+\description{
+This function performs the variance analysis of a trait on eigenvectors associated to a phylogenetic tree.
+}
+\usage{
+variance.phylog(phylog, z, bynames = TRUE,
+ na.action = c("fail", "mean"))
+}
+\arguments{
+ \item{phylog}{: an object of class \code{phylog}}
+ \item{z}{: a numeric vector of the values corresponding to the variable}
+ \item{bynames}{: if TRUE checks if \code{z} labels are the same as \code{phylog} leaves label, possibly in a different order. If FALSE the check is not made and \code{z} labels must be in the same order than \code{phylog} leaves label}
+ \item{na.action}{: if 'fail' stops the execution of the current expression when \code{z} contains any missing value. If 'mean' replaces any missing values by mean(\code{z})}
+}
+\details{
+\code{phylog$Amat} defines a set of orthonormal vectors associated the each nodes of the phylogenetic tree. \cr
+\code{phylog$Adim} defines the dimension of the subspace \bold{A} defined by
+the first \code{phylog$Adim} vectors of \code{phylog$Amat} that corresponds to phylogenetic inertia. \cr
+\code{variance.phylog} performs the linear regression of \code{z} on \bold{A}.
+}
+\value{
+Returns a list containing
+ \item{lm}{: an object of class \code{lm} that corresponds to the linear regression of \code{z} on \bold{A}.}
+ \item{anova}{: an object of class \code{anova} that corresponds to the anova of the precedent model.}
+ \item{smry}{: an object of class \code{anova} that is a summary of the precedent object.}
+}
+\references{
+Grafen, A. (1989) The phylogenetic regression. \emph{Philosophical Transactions of the Royal Society London B}, \bold{326}, 119--156.
+
+Diniz-Filho, J. A. F., Sant'Ana, C.E.R. and Bini, L.M. (1998) An eigenvector method for estimating phylogenetic inertia. \emph{Evolution}, \bold{52}, 1247--1262.
+}
+\author{Sébastien Ollier \email{sebastien.ollier at u-psud.fr} \cr
+Daniel Chessel
+}
+\seealso{\code{\link{phylog}}, \code{\link{lm}}}
+\examples{
+data(njplot)
+njplot.phy <- newick2phylog(njplot$tre)
+variance.phylog(njplot.phy,njplot$tauxcg)
+par(mfrow = c(1,2))
+table.phylog(njplot.phy$Ascores, njplot.phy, clabel.row = 0,
+ clabel.col = 0.1, clabel.nod = 0.6, csize = 1)
+dotchart.phylog(njplot.phy, njplot$tauxcg, clabel.nodes = 0.6)
+orthogram(njplot$tauxcg, njplot.phy$Ascores)
+}
+\keyword{models}
diff --git a/man/varipart.Rd b/man/varipart.Rd
new file mode 100644
index 0000000..b813cf0
--- /dev/null
+++ b/man/varipart.Rd
@@ -0,0 +1,77 @@
+\name{varipart}
+\alias{varipart}
+\title{Partition of the variation of a response multivariate table by 2 explanatory tables}
+\usage{
+varipart(dudiY, X, W, nrepet = 999, type = c("simulated", "parametric"), ...)
+}
+\arguments{
+\item{dudiY}{an object of class dudi. Usually a principal component analysis or
+correspondence analysis on a response table Y.}
+
+\item{X, W}{dataframes or matrices of explanatory (co)variables (numeric and/or factor
+variables).}
+
+\item{nrepet}{an integer indicating the number of permutations
+.}
+
+\item{type}{a character specifying the algorithm which should be used to adjust R-squared.}
+
+\item{\dots}{further arguments passed to \code{as.krandtest}}
+}
+
+\value{
+It returns an object of class \code{varipart}. It is a \code{list} with:
+
+\describe{
+\item{\code{test}}{the significance test of fractions [ab], [bc], and [abc] based on randomization procedure. An object of class \code{krandtest}}
+
+\item{\code{R2}}{unadjusted estimations of fractions [a], [b], [c], and [d]}
+
+\item{\code{R2.adj}}{adjusted estimations of fractions [a], [b], [c], and [d]}
+
+\item{\code{call}}{the matched call}
+}
+}
+\description{
+The function partitions the variation of a response table (usually community data) with respect to two
+explanatory tables. The function performs the variation partitioning based on
+redundancy analysis (RDA, if \code{dudiY} is obtained by \code{dudi.pca}) or canonical correspondance analysis (CCA, if \code{dudiY} is obtained by \code{dudi.coa})
+and computes
+unadjusted and adjusted R-squared.
+The significance of R-squared are evaluated by a randomization procedure
+where the rows of the explanatory tables are permuted.
+}
+\details{
+Two types of algorithm are provided to adjust R-squared. The "simulated" procedure
+estimates the unadjusted R-squared expected under the null hypothesis H0 and uses it to adjust the
+observed R-squared as follows: R2.adj = 1 - (1 - R2) / (1 - E(R2|H0)) with R2.adj the
+adjusted R-squared and R2 the unadjusted R-squared.
+The "parametric" procedure performs the Ezequiel's adjustement on the unadjusted R-squared as:
+R2.adj = 1 - (1 - R2) / (1 - p / (n - 1)) where n is the number of sites, and p the number of
+predictors.
+}
+\examples{
+
+data(mafragh)
+
+# PCA on response table Y
+Y <- mafragh$flo
+dudiY <- dudi.pca(Y, scannf = FALSE, scale = FALSE)
+
+# Variation partitioning based on RDA
+vprda <- varipart(dudiY, mafragh$env, mafragh$xy, type = "parametric")
+vprda
+}
+\references{
+Borcard, D., P. Legendre, and P. Drapeau. 1992. Partialling out the spatial component
+of ecological variation. Ecology 73:1045.
+
+Peres-Neto, P. R., P. Legendre, S. Dray, and D. Borcard. 2006. Variation partitioning of
+species data matrices: estimation and comparison of fractions. Ecology 87:2614–2625.
+}
+\seealso{
+\code{\link{pcaiv}}
+}
+\author{
+Stephane Dray \email{stephane.dray at univ-lyon1.fr} and Sylvie Clappe \email{sylvie.clappe at univ-lyon1.fr}
+}
diff --git a/man/vegtf.Rd b/man/vegtf.Rd
new file mode 100644
index 0000000..d3b1cc0
--- /dev/null
+++ b/man/vegtf.Rd
@@ -0,0 +1,48 @@
+\name{vegtf}
+\alias{vegtf}
+\docType{data}
+\title{Vegetation in Trois-Fontaines}
+\description{
+ This data set contains abundance values (Braun-Blanquet scale) of 80 plant
+ species for 337 sites. Data have been collected by Sonia Said and
+ Francois Debias.
+}
+\usage{data(vegtf)}
+\format{
+\code{vegtf} is a list containing the following objects :
+\describe{
+ \item{veg}{is a data.frame with the abundance values of 80 species (columns)
+ in 337 sites (rows).}
+ \item{xy}{is a data.frame with the spatial coordinates of the sites.}
+ \item{area}{is data.frame (area) which define the boundaries of the study
+ site.}
+ \item{nb}{is a neighborhood object (class nb defined in package spdep)}
+}}
+\source{
+ Dray, S., Said, S. and Debias, F. (2008) Spatial ordination of vegetation data using a generalization of Wartenberg's multivariate spatial correlation. \emph{Journal of vegetation science}, \bold{19}, 45--56.
+}
+
+\examples{
+if(requireNamespace("spdep", quietly = TRUE)) {
+ data(vegtf)
+ coa1 <- dudi.coa(vegtf$veg, scannf = FALSE)
+ ms.coa1 <- multispati(coa1, listw = spdep::nb2listw(vegtf$nb), nfposi = 2,
+ nfnega = 0, scannf = FALSE)
+ summary(ms.coa1)
+ plot(ms.coa1)
+
+ if(adegraphicsLoaded()) {
+ g1 <- s.value(vegtf$xy, coa1$li[, 1], Sp = vegtf$Spatial, pSp.col = "white", plot = FALSE)
+ g2 <- s.value(vegtf$xy, ms.coa1$li[, 1], Sp = vegtf$Spatial, pSp.col = "white", plot = FALSE)
+ g3 <- s.label(coa1$c1, plot = FALSE)
+ g4 <- s.label(ms.coa1$c1, plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+ } else {
+ par(mfrow = c(2, 2))
+ s.value(vegtf$xy, coa1$li[, 1], area = vegtf$area, include.origin = FALSE)
+ s.value(vegtf$xy, ms.coa1$li[, 1], area = vegtf$area, include.origin = FALSE)
+ s.label(coa1$c1)
+ s.label(ms.coa1$c1)
+ }
+}}
+\keyword{datasets}
diff --git a/man/veuvage.Rd b/man/veuvage.Rd
new file mode 100644
index 0000000..9a9346c
--- /dev/null
+++ b/man/veuvage.Rd
@@ -0,0 +1,32 @@
+\name{veuvage}
+\alias{veuvage}
+\docType{data}
+\title{Example for Centring in PCA}
+\description{
+The data come from the INSEE (National Institute of Statistics and Economical Studies).
+It is an array of widower percentages in relation with the age and the socioprofessional category.
+}
+\usage{data(veuvage)}
+\format{
+ \code{veuvage} is a list of 2 components.
+\describe{
+ \item{tab}{is a data frame with 37 rows (widowers) 6 columns (socio-professional categories)}
+ \item{age}{is a vector of the ages of the 37 widowers. }
+ }
+}
+\details{
+The columns contain the socioprofessional categories:\cr
+1- Farmers, 2- Craftsmen, 3- Executives and higher intellectual professions,\cr
+4- Intermediate Professions, 5- Others white-collar workers and 6- Manual workers.\cr
+}
+\source{
+unknown
+}
+\examples{
+data(veuvage)
+par(mfrow = c(3,2))
+for (j in 1:6) plot(veuvage$age, veuvage$tab[,j],
+ xlab = "age", ylab = "pourcentage de veufs",
+ type = "b", main = names(veuvage$tab)[j])
+}
+\keyword{datasets}
diff --git a/man/wca.rlq.Rd b/man/wca.rlq.Rd
new file mode 100644
index 0000000..b20938b
--- /dev/null
+++ b/man/wca.rlq.Rd
@@ -0,0 +1,62 @@
+\name{wca.rlq}
+\alias{wca.rlq}
+\alias{plot.witrlq}
+\alias{print.witrlq}
+
+\title{
+Within-Class RLQ analysis
+}
+\description{
+Performs a particular RLQ analysis where a partition of sites (rows of
+R) is taken into account. The within-class RLQ analysis search for
+linear combinations of traits and environmental variables of maximal covariance.
+}
+\usage{
+\method{wca}{rlq}(x, fac, scannf = TRUE, nf = 2, ...)
+\method{plot}{witrlq}(x, xax = 1, yax = 2, ...)
+\method{print}{witrlq}(x, ...)
+}
+
+\arguments{
+ \item{x}{an object of class rlq (created by the \code{rlq} function)
+ for the \code{wca.rlq} function. An object of class \code{witrlq} for
+ the \code{print} and \code{plot} functions}
+ \item{fac}{a factor partitioning the rows of R}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+ \item{xax}{the column number for the x-axis}
+ \item{yax}{the column number for the y-axis}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+
+\value{
+ The \code{wca.rlq} function returns an object of class 'betrlq'
+ (sub-class of 'dudi'). See the outputs of the \code{print} function
+ for more details.
+}
+\references{
+Wesuls, D., Oldeland, J. and Dray, S. (2012) Disentangling plant trait
+responses to livestock grazing from spatio-temporal variation: the
+partial RLQ approach. \emph{Journal of Vegetation Science}, \bold{23}, 98--113.
+}
+\author{
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr}
+}
+
+\seealso{
+ \code{\link{rlq}}, \code{\link{wca}}, \code{\link{wca.rlq}}
+}
+\examples{
+data(piosphere)
+afcL <- dudi.coa(log(piosphere$veg + 1), scannf = FALSE)
+acpR <- dudi.pca(piosphere$env, scannf = FALSE, row.w = afcL$lw)
+acpQ <- dudi.hillsmith(piosphere$traits, scannf = FALSE, row.w = afcL$cw)
+rlq1 <- rlq(acpR, afcL, acpQ, scannf = FALSE)
+
+wrlq1 <- wca(rlq1, fac = piosphere$habitat, scannf = FALSE)
+wrlq1
+plot(wrlq1)
+}
+
+\keyword{multivariate}
+
diff --git a/man/westafrica.Rd b/man/westafrica.Rd
new file mode 100644
index 0000000..11b663a
--- /dev/null
+++ b/man/westafrica.Rd
@@ -0,0 +1,103 @@
+\name{westafrica}
+\alias{westafrica}
+\docType{data}
+\title{Freshwater fish zoogeography in west Africa}
+\description{
+This data set contains informations about faunal similarities between river basins in West africa.
+}
+\usage{data(westafrica)}
+\format{
+\code{westafrica} is a list containing the following objects :
+\describe{
+ \item{tab}{: a data frame with absence/presence of 268 species (rows) at 33 embouchures (columns)}
+ \item{spe.names}{: a vector of string of characters with the name of species}
+ \item{spe.binames}{: a data frame with the genus and species (columns) of the 256 species (rows)}
+ \item{riv.names}{: a vector of string of characters with the name of rivers}
+ \item{atlantic}{: a data frame with the coordinates of a polygon that represents the limits of atlantic (see example)}
+ \item{riv.xy}{: a data frame with the coordinates of embouchures}
+ \item{lines}{: a data frame with the coordinates of lines to complete the representation (see example)}
+ \item{cadre}{: a data frame with the coordinates of points used to make the representation (see example)}
+}}
+\source{
+Data provided by B. Hugueny \email{hugueny at mnhn.fr}.
+
+Paugy, D., Traoré, K. and Diouf, P.F. (1994) Faune ichtyologique des eaux douces d'Afrique de l'Ouest.
+In \emph{Diversité biologique des poissons des eaux douces et saumâtres d'Afrique. Synthèses géographiques},
+Teugels, G.G., Guégan, J.F. and Albaret, J.J. (Editors). Annales du Musée Royal de l'Afrique Centrale,
+Zoologie, \bold{275}, Tervuren, Belgique, 35--66.
+
+Hugueny, B. (1989) \emph{Biogéographie et structure des peuplements de Poissons d'eau douce de l'Afrique de l'ouest :
+approches quantitatives}. Thèse de doctorat, Université Paris 7.
+}
+\references{
+Hugueny, B., and Lévêque, C. (1994) Freshwater fish zoogeography in west Africa:
+faunal similarities between river basins. \emph{Environmental Biology of Fishes}, \bold{39}, 365--380.
+}
+\examples{
+data(westafrica)
+
+if(!adegraphicsLoaded()) {
+ s.label(westafrica$cadre, xlim = c(30, 500), ylim = c(50, 290),
+ cpoi = 0, clab = 0, grid = FALSE, addax = 0)
+ old.par <- par(no.readonly = TRUE)
+ par(mar = c(0.1, 0.1, 0.1, 0.1))
+ rect(30, 0, 500, 290)
+ polygon(westafrica$atlantic, col = "lightblue")
+ points(westafrica$riv.xy, pch = 20, cex = 1.5)
+ apply(westafrica$lines, 1, function(x) segments(x[1], x[2], x[3], x[4], lwd = 1))
+ apply(westafrica$riv.xy,1, function(x) segments(x[1], x[2], x[3], x[4], lwd = 1))
+ text(c(175, 260, 460, 420), c(275, 200, 250, 100), c("Senegal", "Niger", "Niger", "Volta"))
+ par(srt = 270)
+ text(westafrica$riv.xy$x2, westafrica$riv.xy$y2-10, westafrica$riv.names, adj = 0, cex = 0.75)
+ par(old.par)
+ rm(old.par)
+}
+
+# multivariate analysis
+afri.w <- data.frame(t(westafrica$tab))
+afri.dist <- dist.binary(afri.w,1)
+afri.pco <- dudi.pco(afri.dist, scannf = FALSE, nf = 3)
+if(adegraphicsLoaded()) {
+ G1 <- s1d.barchart(afri.pco$li[, 1:3], p1d.horizontal = FALSE, plabels.cex = 0)
+} else {
+ par(mfrow = c(3, 1))
+ barplot(afri.pco$li[, 1])
+ barplot(afri.pco$li[, 2])
+ barplot(afri.pco$li[, 3])
+}
+
+if(requireNamespace("spdep", quietly = TRUE)) {
+ # multivariate spatial analysis
+ afri.neig <- neig(n.line = 33)
+ afri.nb <- neig2nb(afri.neig)
+ afri.listw <- spdep::nb2listw(afri.nb)
+ afri.ms <- multispati(afri.pco, afri.listw, scannf = FALSE, nfposi = 6, nfnega = 0)
+
+ if(adegraphicsLoaded()) {
+ G2 <- s1d.barchart(afri.ms$li[, 1:3], p1d.horizontal = FALSE, plabels.cex = 0)
+
+ g31 <- s.label(afri.ms$li, plabels.cex = 0.75, ppoints.cex = 0, nb = afri.nb, plot = FALSE)
+ g32 <- s.value(afri.ms$li, afri.ms$li[, 3], plot = FALSE)
+ g33 <- s.value(afri.ms$li, afri.ms$li[, 4], plot = FALSE)
+ g34 <- s.value(afri.ms$li, afri.ms$li[, 5], plot = FALSE)
+ G3 <- ADEgS(list(g31, g32, g33, g34), layout = c(2, 2))
+
+ } else {
+ par(mfrow = c(3, 1))
+ barplot(afri.ms$li[, 1])
+ barplot(afri.ms$li[, 2])
+ barplot(afri.ms$li[, 3])
+
+ par(mfrow = c(2, 2))
+ s.label(afri.ms$li, clab = 0.75, cpoi = 0, neig = afri.neig, cneig = 1.5)
+ s.value(afri.ms$li, afri.ms$li[, 3])
+ s.value(afri.ms$li, afri.ms$li[, 4])
+ s.value(afri.ms$li, afri.ms$li[, 5])
+ }
+ summary(afri.ms)
+}
+
+par(mfrow = c(1, 1))
+plot(hclust(afri.dist, "ward.D"), h = -0.2)
+}
+\keyword{datasets}
diff --git a/man/within.Rd b/man/within.Rd
new file mode 100644
index 0000000..5f4043e
--- /dev/null
+++ b/man/within.Rd
@@ -0,0 +1,85 @@
+\name{wca}
+\alias{within}
+\alias{wca}
+\alias{wca.dudi}
+\title{Within-Class Analysis}
+\description{
+Performs a particular case of an Orthogonal Principal Component Analysis with
+respect to Instrumental Variables (orthopcaiv), in which there is only a
+single factor as covariable.
+}
+\usage{
+within(dudi, fac, scannf = TRUE, nf = 2)
+\method{wca}{dudi}(x, fac, scannf = TRUE, nf = 2, \dots)
+}
+\arguments{
+ \item{dudi}{a duality diagram, object of class \code{\link{dudi}}
+ obtained from the functions \code{dudi.coa}, \code{dudi.pca},...}
+ \item{x}{a duality diagram, object of class \code{\link{dudi}} from
+ one of the functions \code{dudi.coa}, \code{dudi.pca},...}
+ \item{fac}{a factor partitioning the rows of \code{dudi$tab} in
+ classes}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\value{
+Returns a list of the sub-class \code{within} in the class \code{dudi}
+ \item{tab}{a data frame containing the transformed data (substraction
+ of the class mean)}
+ \item{call}{the matching call}
+ \item{nf}{number of kept axes}
+ \item{rank}{the rank of the analysis}
+ \item{ratio}{percentage of within-class inertia}
+ \item{eig}{a numeric vector containing the eigenvalues}
+ \item{lw}{a numeric vector of row weigths}
+ \item{cw}{a numeric vector of column weigths}
+ \item{tabw}{a numeric vector of class weigths}
+ \item{fac}{the factor defining the classes}
+
+ \item{li}{data frame row coordinates}
+ \item{l1}{data frame row normed scores}
+ \item{co}{data frame column coordinates}
+ \item{c1}{data frame column normed scores}
+ \item{ls}{data frame supplementary row coordinates}
+ \item{as}{data frame inertia axis onto within axis}
+}
+\references{
+Benzécri, J. P. (1983) Analyse de l'inertie intra-classe par l'analyse d'un tableau de correspondances. \emph{Les Cahiers de l'Analyse des données}, \bold{8}, 351--358.\cr\cr
+Dolédec, S. and Chessel, D. (1987) Rythmes saisonniers et composantes stationnelles en milieu aquatique I- Description d'un plan d'observations complet par projection de variables. \emph{Acta Oecologica, Oecologia Generalis}, \bold{8}, 3, 403--426.
+}
+
+\note{
+To avoid conflict names with the \code{base:::within} function, the
+function \code{within} is now deprecated and will be removed. Use the
+generic \code{wca} function instead.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(meaudret)
+pca1 <- dudi.pca(meaudret$env, scan = FALSE, nf = 4)
+wit1 <- wca(pca1, meaudret$design$site, scan = FALSE, nf = 2)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.traject(pca1$li, meaudret$design$site, psub.text = "Principal Component Analysis",
+ plines.lty = 1:nlevels(meaudret$design$site), psub.cex = 1.5, plot = FALSE)
+ g2 <- s.traject(wit1$li, meaudret$design$site,
+ psub.text = "Within site Principal Component Analysis",
+ plines.lty = 1:nlevels(meaudret$design$site), psub.cex = 1.5, plot = FALSE)
+ g3 <- s.corcircle (wit1$as, plot = FALSE)
+ G <- ADEgS(list(g1, g2, g3), layout = c(2, 2))
+
+} else {
+ par(mfrow = c(2, 2))
+ s.traject(pca1$li, meaudret$design$site, sub = "Principal Component Analysis", csub = 1.5)
+ s.traject(wit1$li, meaudret$design$site, sub = "Within site Principal Component Analysis",
+ csub = 1.5)
+ s.corcircle (wit1$as)
+ par(mfrow = c(1,1))
+}
+plot(wit1)
+}
+\keyword{multivariate}
diff --git a/man/withincoinertia.Rd b/man/withincoinertia.Rd
new file mode 100644
index 0000000..661f9fe
--- /dev/null
+++ b/man/withincoinertia.Rd
@@ -0,0 +1,65 @@
+\name{withincoinertia}
+\alias{withincoinertia}
+\alias{wca.coinertia}
+\title{Within-class coinertia analysis}
+\description{
+Performs a within-class analysis after a coinertia analysis
+}
+\usage{
+withincoinertia(obj, fac, scannf = TRUE, nf = 2)
+\method{wca}{coinertia}(x, fac, scannf = TRUE, nf = 2, \dots)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{obj}{a coinertia analysis (object of class \link{coinertia})
+ obtained by the function \link{coinertia}}
+ \item{x}{a coinertia analysis (object of class \link{coinertia})
+ obtained by the function \link{coinertia}}
+ \item{fac}{a factor partitioning the rows in classes}
+ \item{scannf}{a logical value indicating whether the eigenvalues barplot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+ \item{\dots}{further arguments passed to or from other methods}
+}
+\details{
+ This analysis is equivalent to do a within-class analysis on each
+ initial dudi, and a coinertia analysis on the two within
+ analyses. This function returns additional outputs for the interpretation.
+}
+\value{
+ An object of the class \code{witcoi}. Outputs are described by the
+ \code{print} function
+}
+\references{
+Franquet E., Doledec S., and Chessel D. (1995) Using multivariate analyses for separating spatial and temporal effects within species-environment relationships. \emph{Hydrobiologia}, \bold{300}, 425--431.
+}
+
+\note{
+To avoid conflict names with the \code{base:::within} function, the
+function \code{within} is now deprecated and will be removed. To be
+consistent, the \code{withincoinertia} function is also deprecated and
+is replaced by the method \code{wca.coinertia} of the generic \code{wca} function.
+}
+
+\author{
+Stéphane Dray \email{stephane.dray at univ-lyon1.fr} and Jean Thioulouse \email{jean.thioulouse at univ-lyon1.fr}
+}
+\seealso{\code{\link{coinertia}}, \code{\link{within}}
+}
+\examples{
+data(meaudret)
+pca1 <- dudi.pca(meaudret$env, scan = FALSE, nf = 4)
+pca2 <- dudi.pca(meaudret$spe, scal = FALSE, scan = FALSE, nf = 4)
+
+wit1 <- wca(pca1, meaudret$design$site, scan = FALSE, nf = 2)
+wit2 <- wca(pca2, meaudret$design$site, scan = FALSE, nf = 2)
+coiw <- coinertia(wit1, wit2, scannf = FALSE)
+
+coi <- coinertia(pca1, pca2, scannf = FALSE, nf = 3)
+coi.w <- wca(coi, meaudret$design$site, scannf = FALSE)
+## coiw and coi.w are equivalent
+
+plot(coi.w)
+}
+
+\keyword{multivariate}
+
diff --git a/man/withinpca.Rd b/man/withinpca.Rd
new file mode 100644
index 0000000..6caef42
--- /dev/null
+++ b/man/withinpca.Rd
@@ -0,0 +1,50 @@
+\name{withinpca}
+\alias{withinpca}
+\title{Normed within principal component analysis}
+\description{
+Performs a normed within Principal Component Analysis.
+}
+\usage{
+withinpca(df, fac, scaling = c("partial", "total"),
+ scannf = TRUE, nf = 2)
+}
+\arguments{
+ \item{df}{a data frame with quantitative variables}
+ \item{fac}{a factor partitioning the rows of df in classes}
+ \item{scaling}{a string of characters as a scaling option : \cr
+ if "partial", the sub-table corresponding to each class is centred and normed.\cr
+ If "total", the sub-table corresponding to each class is centred and the total table is then normed.}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+}
+
+\details{
+This functions implements the 'Bouroche' standardization. In a first
+step, the original variables are standardized (centred and normed). Then, a second
+transformation is applied according to the value of the \code{scaling}
+argument. For "partial", variables are standardized in each sub-table
+(corresponding to each level of the factor). Hence, variables have null
+mean and unit variance in each sub-table. For "total", variables are
+centred in each sub-table and then normed globally. Hence, variables
+have a null mean in each sub-table and a global variance equal to one.
+}
+\value{
+returns a list of the sub-class \code{within} of class \code{dudi}. See \code{\link{within}}
+}
+\references{Bouroche, J. M. (1975) \emph{Analyse des données ternaires: la double analyse en composantes principales}.
+ Thèse de 3ème cycle, Université de Paris VI.
+}
+\author{
+Daniel Chessel \cr
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+}
+\examples{
+data(meaudret)
+wit1 <- withinpca(meaudret$env, meaudret$design$season, scannf = FALSE, scaling = "partial")
+kta1 <- ktab.within(wit1, colnames = rep(c("S1", "S2", "S3", "S4", "S5"), 4))
+unclass(kta1)
+
+# See pta
+plot(wit1)
+}
+\keyword{multivariate}
diff --git a/man/witwit.coa.Rd b/man/witwit.coa.Rd
new file mode 100644
index 0000000..b428975
--- /dev/null
+++ b/man/witwit.coa.Rd
@@ -0,0 +1,67 @@
+\name{witwit.coa}
+\alias{witwit.coa}
+\alias{summary.witwit}
+\alias{witwitsepan}
+\title{Internal Correspondence Analysis}
+\description{
+\code{witwit.coa} performs an Internal Correspondence Analysis.
+\code{witwitsepan} gives the computation and the barplot of the eigenvalues
+for each separated analysis in an Internal Correspondence Analysis.
+}
+\usage{
+witwit.coa(dudi, row.blocks, col.blocks, scannf = TRUE, nf = 2)
+\method{summary}{witwit}(object, \dots)
+witwitsepan(ww, mfrow = NULL, csub = 2, plot = TRUE)
+}
+\arguments{
+ \item{dudi}{an object of class \code{coa} }
+ \item{row.blocks}{a numeric vector indicating the row numbers for each block of rows}
+ \item{col.blocks}{a numeric vector indicating the column numbers for each block of columns}
+ \item{scannf}{a logical value indicating whether the eigenvalues bar plot should be displayed}
+ \item{nf}{if scannf FALSE, an integer indicating the number of kept axes}
+ \cr
+ \item{object}{an object of class \code{witwit}}
+ \item{\dots}{further arguments passed to or from other methods}
+ \cr
+ \item{ww}{an object of class \code{witwit}}
+ \item{mfrow}{a vector of the form "c(nr,nc)", otherwise computed by a special own function 'n2mfrow'}
+ \item{csub}{a character size for the sub-titles, used with \code{par("cex")*csub}}
+ \item{plot}{if FALSE, numeric results are returned}
+}
+\value{
+returns a list of class \code{witwit}, \code{coa} and \code{dudi} (see \link{as.dudi}) containing
+ \item{rbvar}{a data frame with the within variances of the rows of the factorial coordinates}
+ \item{lbw}{a data frame with the marginal weighting of the row classes}
+ \item{cvar}{a data frame with the within variances of the columns of the factorial coordinates}
+ \item{cbw}{a data frame with the marginal weighting of the column classes}
+}
+\references{
+Cazes, P., Chessel, D. and Dolédec, S. (1988) L'analyse des correspondances internes d'un tableau partitionné :
+son usage en hydrobiologie. \emph{Revue de Statistique Appliquée}, \bold{36}, 39--54.
+}
+\author{
+Daniel Chessel
+Anne-Béatrice Dufour \email{anne-beatrice.dufour at univ-lyon1.fr}
+Correction by Campo Elías PARDO \email{cepardot at cable.net.co}
+}
+\examples{
+data(ardeche)
+coa1 <- dudi.coa(ardeche$tab, scann = FALSE, nf = 4)
+ww <- witwit.coa(coa1, ardeche$row.blocks, ardeche$col.blocks, scann = FALSE)
+ww
+summary(ww)
+
+if(adegraphicsLoaded()) {
+ g1 <- s.class(ww$co, ardeche$sta.fac, plab.cex = 1.5, ellipseSi = 0, paxes.draw = FALSE,
+ plot = FALSE)
+ g2 <- s.label(ww$co, plab.cex = 0.75, plot = FALSE)
+ G <- superpose(g1, g2, plot = TRUE)
+
+} else {
+ s.class(ww$co, ardeche$sta.fac, clab = 1.5, cell = 0, axesell = FALSE)
+ s.label(ww$co, add.p = TRUE, clab = 0.75)
+}
+
+witwitsepan(ww, c(4, 6))
+}
+\keyword{multivariate}
diff --git a/man/woangers.Rd b/man/woangers.Rd
new file mode 100644
index 0000000..477dfd3
--- /dev/null
+++ b/man/woangers.Rd
@@ -0,0 +1,98 @@
+\name{woangers}
+\alias{woangers}
+\docType{data}
+\title{Plant assemblages in woodlands of the conurbation of Angers (France)}
+\description{
+This data set gives the presence of plant species in relevés of woodlands in the conurbation of Angers; and their biological traits.
+}
+\usage{data(woangers)}
+\format{
+ \code{woangers} is a list of 2 components.
+\enumerate{
+ \item flo: is a data frame that contains the presence/absence of species in each sample site. In the
+codes for the sample sites (first column of the data frame), the first three letters provide the
+code of the woodland and the numbers represent the 5 quadrats sampled in each site.
+Codes for the woodlands are based on either their local name when they have one or on
+the name of the nearest locality.
+
+ \item traits: is a data frame that contains the values of the 13 functional traits considered in the paper.
+One trait can be encoded by several columns.
+The codes are as follows:
+\itemize{
+\item Column 1: Species names;
+\item Column 2: \code{li}, nominal variable that indicates the presence (y) or absence (n) of
+ligneous structures;
+\item Column 3: \code{pr}, nominal variable that indicates the presence (y) or absence (n) of
+prickly structures;
+\item Column 4: \code{fo}, circular variable that indicates the month when the flowering period
+starts (from 1 January to 9 September);
+\item Column 5: \code{he}, ordinal variable that indicates the maximum height of the leaf
+canopy;
+\item Column 6: \code{ae}, ordinal variable that indicates the degree of aerial vegetative
+multiplication;
+\item Column 7: \code{un}, ordinal variable that indicates the degree of underground vegetative
+multiplication;
+\item Column 8: \code{lp}, nominal variable that represents the leaf position by 3 levels (\code{ros} =
+rosette, \code{semiros} = semi-rosette and \code{leafy} = leafy stem);
+\item Column 9: \code{le}, nominal variable that represents the mode of leaf persistence by 5
+levels (\code{seasaes} = seasonal aestival, \code{seashib} = seasonal hibernal, \code{seasver} =
+seasonal vernal, \code{everalw} = always evergreen, \code{everparti} = partially evergreen);
+\item Columns 10, 11 and 12: fuzzy variable that describes the modes of pollination with 3
+levels (\code{auto} = autopollination, \code{insects} = pollination by insects, \code{wind} =
+pollination by wind); this fuzzy variable is expressed as proportions, i.e. for each
+row, the sum of the three columns equals 1;
+\item Columns 13, 14 and 15: fuzzy variable that describes the life cycle with 3 levels
+(annual, monocarpic and polycarpic); this fuzzy variable is expressed as
+proportions, i.e. for each row, the sum of the three column equals 1;
+\item Columns 16 to 20: fuzzy variable that describes the modes of dispersion with 5 levels
+(\code{elaio} = dispersion by ants, \code{endozoo} = injection by animals, \code{epizoo} =
+external transport by animals, \code{wind} = transport by wind, \code{unsp} = unspecialized
+transport); this fuzzy variable is expressed as proportions, i.e. for each row, the
+sum of the three columns equals 1;
+\item Column 21: \code{lo}, quantitative variable that provides the seed bank longevity index;
+\item Column 22: \code{lf}, quantitative variable that provides the length of the flowering
+period.
+}
+}
+}
+\source{
+Pavoine, S., Vallet, J., Dufour, A.-B., Gachet, S. and Daniel, H. (2009)
+On the challenge of treating various types of variables:
+Application for improving the measurement of functional diversity. \emph{Oikos}, \bold{118}, 391--402.
+}
+\examples{
+# Loading the data
+data(woangers)
+
+# Preparating of the traits
+traits <- woangers$traits
+# Nominal variables 'li', 'pr', 'lp' and 'le'
+# (see table 1 in the main text for the codes of the variables)
+tabN <- traits[, c(1:2, 7, 8)]
+# Circular variable 'fo'
+tabC <- traits[3]
+tabCp <- prep.circular(tabC, 1, 12)
+# The levels of the variable lie between 1 (January) and 12 (December).
+# Ordinal variables 'he', 'ae' and 'un'
+tabO <- traits[, 4:6]
+# Fuzzy variables 'mp', 'pe' and 'di'
+tabF <- traits[, 9:19]
+tabFp <- prep.fuzzy(tabF, c(3, 3, 5), labels = c("mp", "pe", "di"))
+# 'mp' has 3 levels, 'pe' has 3 levels and 'di' has 5 levels.
+# Quantitative variables 'lo' and 'lf'
+tabQ <- traits[, 20:21]
+
+# Combining the traits
+ktab1 <- ktab.list.df(list(tabN, tabCp, tabO, tabFp, tabQ))
+\dontrun{
+# Calculating the distances for all traits combined
+distrait <- dist.ktab(ktab1, c("N", "C", "O", "F", "Q"))
+is.euclid(distrait)
+
+# Calculating the contribution of each trait in the combined distances
+contrib <- kdist.cor(ktab1, type = c("N", "C", "O", "F", "Q"))
+contrib
+dotchart(sort(contrib$glocor), labels = rownames(contrib$glocor)[order(contrib$glocor[, 1])])
+}
+}
+\keyword{datasets}
diff --git a/man/worksurv.Rd b/man/worksurv.Rd
new file mode 100644
index 0000000..b73d031
--- /dev/null
+++ b/man/worksurv.Rd
@@ -0,0 +1,85 @@
+\name{worksurv}
+\alias{worksurv}
+\docType{data}
+\title{French Worker Survey (1970)}
+\description{
+The \code{worksurv} data frame gives 319 response items and 4 questions
+providing from a French Worker Survey.
+}
+\usage{data(worksurv)}
+\format{
+ This data frame contains the following columns:
+ \enumerate{
+ \item pro: Professional elections. In professional elections in your firm, would you rather vote for a list supported by?
+ \itemize{
+ \item \code{CGT}
+ \item \code{CFDT}
+ \item \code{FO}
+ \item \code{CFTC}
+ \item \code{Auton} Autonomous
+ \item \code{Abst}
+ \item \code{Nonaffi} Not affiliated
+ \item \code{NR} No response}
+
+ \item una: Union affiliation. At the present time, are you affiliated to a Union, and in the affirmative, which one?
+ \itemize{
+ \item \code{CGT}
+ \item \code{CFDT}
+ \item \code{FO}
+ \item \code{CFTC}
+ \item \code{Auton} Autonomous
+ \item \code{CGC}
+ \item \code{Notaffi} Not affiliated
+ \item \code{NR} No response}
+
+ \item pre: Presidential election. On the last presidential election
+ (1969), can you tell me the candidate for whom you havevoted?
+ \itemize{
+ \item \code{Duclos}
+ \item \code{Deferre}
+ \item \code{Krivine}
+ \item \code{Rocard}
+ \item \code{Poher}
+ \item \code{Ducatel}
+ \item \code{Pompidou}
+ \item \code{NRAbs} No response, abstention}
+
+ \item pol: political sympathy. Which political party do you feel closest to, as a rule?
+ \itemize{
+ \item \code{Communist} (PCF)
+ \item \code{Socialist} (SFIO+PSU+FGDS)
+ \item \code{Left} (Party of workers,\dots)
+ \item \code{Center} MRP+RAD.
+ \item \code{RI}
+ \item \code{Right} INDEP.+CNI
+ \item \code{Gaullist} UNR
+ \item \code{NR} No response}
+
+ }
+}
+\details{
+The data frame \code{worksurv} has the attribute 'counts' giving the number of responses for each item.
+}
+\source{
+Rouanet, H. and Le Roux, B. (1993)
+\emph{Analyse des données multidimensionnelles}. Dunod, Paris.
+}
+\references{
+Le Roux, B. and Rouanet, H. (1997)
+Interpreting axes in multiple correspondence analysis: method of the contributions of points and deviation.
+Pages 197-220 in B. J. and M. Greenacre, editors.
+\emph{Visualization of categorical data}, Acamedic Press, London.
+}
+\examples{
+data(worksurv)
+acm1 <- dudi.acm(worksurv, row.w = attr(worksurv, "counts"), scan = FALSE)
+
+if(adegraphicsLoaded()) {
+ s.class(acm1$li, worksurv)
+} else {
+ par(mfrow = c(2, 2))
+ apply(worksurv, 2, function(x) s.class(acm1$li, factor(x), attr(worksurv, 'counts')))
+ par(mfrow = c(1, 1))
+}
+}
+\keyword{datasets}
diff --git a/man/yanomama.Rd b/man/yanomama.Rd
new file mode 100644
index 0000000..2379302
--- /dev/null
+++ b/man/yanomama.Rd
@@ -0,0 +1,42 @@
+\name{yanomama}
+\alias{yanomama}
+\docType{data}
+\title{Distance Matrices}
+\description{
+This data set gives 3 matrices about geographical, genetic and anthropometric distances.
+}
+\usage{data(yanomama)}
+\format{
+ \code{yanomama} is a list of 3 components:
+\describe{
+ \item{geo}{is a matrix of 19-19 geographical distances}
+ \item{gen}{is a matrix of 19-19 SFA (genetic) distances}
+ \item{ant}{is a matrix of 19-19 anthropometric distances}
+ }
+}
+\source{
+Spielman, R.S. (1973)
+Differences among Yanomama Indian villages: do the patterns of allele frequencies, anthropometrics and map locations correspond?
+\emph{American Journal of Physical Anthropology}, \bold{39}, 461--480.
+}
+\references{
+Table 7.2 Distance matrices for 19 villages of Yanomama Indians.
+All distances are as given by Spielman (1973), multiplied by 100 for convenience in:
+Manly, B.F.J. (1991)
+\emph{Randomization and Monte Carlo methods in biology}
+Chapman and Hall, London, 1--281.
+}
+\examples{
+ data(yanomama)
+ gen <- quasieuclid(as.dist(yanomama$gen)) # depends of mva
+ ant <- quasieuclid(as.dist(yanomama$ant)) # depends of mva
+ par(mfrow = c(2,2))
+ plot(gen, ant)
+ t1 <- mantel.randtest(gen, ant, 99);
+ plot(t1, main = "gen-ant-mantel") ; print(t1)
+ t1 <- procuste.rtest(pcoscaled(gen), pcoscaled(ant), 99)
+ plot(t1, main = "gen-ant-procuste") ; print(t1)
+ t1 <- RV.rtest(pcoscaled(gen), pcoscaled(ant), 99)
+ plot(t1, main = "gen-ant-RV") ; print(t1)
+}
+\keyword{datasets}
diff --git a/man/zealand.Rd b/man/zealand.Rd
new file mode 100644
index 0000000..53e921a
--- /dev/null
+++ b/man/zealand.Rd
@@ -0,0 +1,52 @@
+\name{zealand}
+\alias{zealand}
+\docType{data}
+\title{Road distances in New-Zealand}
+\description{
+ This data set gives the road distances between 13 towns
+ in New-Zealand.
+}
+\usage{data(zealand)}
+\format{
+ \code{zealand} is a list of 3 components:
+\describe{
+ \item{road}{is a data frame with 13 rows (New Zealand towns) and 13 columns (New Zealand towns)
+ containing the road distances between these towns.}
+ \item{xy}{is a data frame containing the coordinates of the 13 towns. }
+ \item{neig}{is a object of class 'neig', a neighbour graph to visualize the map shape.}
+}}
+\source{
+ Manly, B.F. (1994) \emph{ Multivariate Statistical Methods. A primer.}, Second edition, Chapman and Hall, London, 1--215, page 172.
+}
+\examples{
+data(zealand)
+d0 <- as.dist(as.matrix(zealand$road))
+d1 <- cailliez (d0)
+d2 <- lingoes(d0)
+
+if(adegraphicsLoaded()) {
+ G1 <- s.label(zealand$xy, lab = as.character(1:13), nb = zealand$nb)
+
+ g1 <- s.label(cmdscale(dist(zealand$xy)), lab = as.character(1:13), nb = zealand$nb,
+ psub.text = "Distance canonique", plot = FALSE)
+ g2 <- s.label(cmdscale(d0), lab = as.character(1:13), nb = zealand$nb,
+ psub.text = "Distance routiere", plot = FALSE)
+ g3 <- s.label(cmdscale(d1), lab = as.character(1:13), nb = zealand$nb,
+ psub.text = "Distance routiere / Cailliez", plot = FALSE)
+ g4 <- s.label(cmdscale(d2), lab = as.character(1:13), nb = zealand$nb,
+ psub.text = "Distance routiere / Lingoes", plot = FALSE)
+ G2 <- ADEgS(list(g1, g2, g3, g4), layout = c(2, 2))
+
+} else {
+ s.label(zealand$xy, lab = as.character(1:13), neig = zealand$neig)
+ par(mfrow = c(2, 2))
+ s.label(cmdscale(dist(zealand$xy)), lab = as.character(1:13),
+ neig = zealand$neig, sub = "Distance canonique", csub = 2)
+ s.label(cmdscale(d0), lab = as.character(1:13), neig = zealand$neig,
+ sub = "Distance routiere", csub = 2)
+ s.label(cmdscale(d1), lab = as.character(1:13), neig = zealand$neig,
+ sub = "Distance routiere / Cailliez", csub = 2)
+ s.label(cmdscale(d2), lab = as.character(1:13), neig = zealand$neig,
+ sub = "Distance routiere / Lingoes", csub = 2)
+}}
+\keyword{datasets}
diff --git a/src/Makevars b/src/Makevars
new file mode 100755
index 0000000..c0c23fa
--- /dev/null
+++ b/src/Makevars
@@ -0,0 +1,2 @@
+ PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS)
+
diff --git a/src/adesub.c b/src/adesub.c
new file mode 100644
index 0000000..93d03aa
--- /dev/null
+++ b/src/adesub.c
@@ -0,0 +1,1443 @@
+#include <math.h>
+#include <time.h>
+#include <string.h>
+#include <stdlib.h>
+#include "adesub.h"
+
+/***********************************************************************/
+double traceXtdLXq (double **X, double **L, double *d, double *q)
+/* Produit matriciel XtDLXQ avec LX comme lag.matrix */
+{
+ /* Declarations de variables C locales */
+ int j, i, lig, col;
+ double **auxi, **A, trace;
+
+
+
+ /* Allocation memoire pour les variables C locales */
+ lig = X[0][0];
+ col = X[1][0];
+ taballoc(&auxi, lig, col);
+ taballoc(&A, col, col);
+
+
+ /* Calcul de LX */
+ prodmatABC(L, X, auxi);
+
+ /* Calcul de DLX */
+ for (i=1;i<=lig;i++) {
+ for (j=1;j<=col;j++) {
+ auxi[i][j] = auxi[i][j] * d[i];
+ }
+ }
+
+ /* Calcul de XtDLX */
+ prodmatAtBC(X,auxi,A);
+
+ /* Calcul de trace(XtDLXQ) */
+ trace=0;
+ for (i=1;i<=col;i++) {
+ trace = trace + A[i][i] * q[i];
+ }
+
+ /* Liberation des reservations locales */
+ freetab (auxi);
+ freetab (A);
+ return(trace);
+}
+
+/***********************************************************************/
+void tabintalloc (int ***tab, int l1, int c1)
+/*--------------------------------------------------
+ * Allocation de memoire dynamique pour un tableau
+ * d'entiers (l1, c1)
+ --------------------------------------------------*/
+{
+ int i, j;
+
+ *tab = (int **) calloc(l1+1, sizeof(int *));
+
+ if ( *tab != NULL) {
+ for (i=0;i<=l1;i++) {
+
+ *(*tab+i)=(int *) calloc(c1+1, sizeof(int));
+ if ( *(*tab+i) == NULL ) {
+ for (j=0;j<i;j++) {
+ free(*(*tab+j));
+ }
+ return;
+ }
+ }
+ } else return;
+ **(*tab) = l1;
+ **(*tab+1) = c1;
+ for (i=1;i<=l1;i++) {
+ for (j=1;j<=c1;j++) {
+ (*tab)[i][j] = 0;
+ }
+ }
+}
+
+/***********************************************************************/
+void freeinttab (int **tab)
+/*--------------------------------------------------
+ * Allocation de memoire dynamique pour un tableau
+ --------------------------------------------------*/
+{
+ int i, n;
+
+ n = *(*(tab));
+
+ for (i=0;i<=n;i++) {
+ free((char *) *(tab+i) );
+ }
+
+ free((char *) tab);
+}
+
+
+/*********************/
+int dtodelta (double **data, double *pl)
+{
+ /* la matrice de distances d2ij dans data est associee aux poids pl
+ Elle est transformee par aij - ai. -a.j + a..
+ aij = -d2ij/2);*/
+
+ int lig, i, j;
+ double *moy, a0, moytot;
+
+ lig=data[0][0];
+ vecalloc(&moy, lig);
+
+ for (i=1; i<=lig; i++) {
+ for (j=1; j<=lig; j++) data[i][j] = 0.0 - data[i][j] * data[i][j] / 2.0;
+ }
+
+ for (i=1; i<=lig; i++) {
+ a0=0;
+ for (j=1; j<=lig; j++) a0 = a0 + pl[j]*data[i][j];
+ moy[i] = a0;
+ }
+ moytot=0;
+ for (i=1; i<=lig; i++) {
+ moytot = moytot+pl[i]*moy[i];
+ }
+ for (i=1; i<=lig; i++) {
+ for (j=1; j<=lig; j++) data[i][j] = data[i][j] - moy[i] - moy[j] + moytot;
+ }
+ freevec (moy);
+ return 1;
+}
+/***************************/
+void initvec (double *v1, double r)
+/*--------------------------------------------------
+ * Initialisation des elements d'un vecteur
+ --------------------------------------------------*/
+{
+ int i, c1;
+
+ c1 = v1[0];
+ for (i=1;i<=c1;i++) {
+ v1[i] = r;
+ }
+}
+/**************************/
+double alea (void)
+{
+ double w;
+ GetRNGstate();
+ w = unif_rand();
+ PutRNGstate();
+ return (w);
+}
+/*************************/
+void aleapermutmat (double **a)
+{
+ /* permute au hasard les lignes du tableau a
+ Manly p. 42 le tableau est modifie */
+ int lig, i,j, col, n, k;
+ double z;
+
+ lig = a[0][0];
+ col = a[1][0];
+ for (i=1; i<=lig-1; i++) {
+ j=lig-i+1;
+ k = (int) (j*alea ()+1);
+ /*k = (int) (j*genrand()+1);*/
+ if (k>j) k=j;
+ for (n=1; n<=col; n++) {
+ z = a[j][n];
+ a[j][n]=a[k][n];
+ a[k][n] = z;
+ }
+ }
+}
+/*************************/
+void aleapermutvec (double *a)
+{
+ /* permute au hasard les elements du vecteur a
+ Manly p. 42 Le vecteur est modifie
+ from Knuth 1981 p. 139*/
+ int lig, i,j, k;
+ double z;
+
+ lig = a[0];
+ for (i=1; i<=lig-1; i++) {
+ j=lig-i+1;
+ k = (int) (j*alea()+1);
+ /*k = (int) (j*genrand()+1);*/
+ if (k>j) k=j;
+ z = a[j];
+ a[j]=a[k];
+ a[k] = z;
+ }
+}
+/***********************************************************************/
+void DiagobgComp (int n0, double **w, double *d, int *rang)
+/*--------------------------------------------------
+ * Diagonalisation
+ * T. FOUCART Analyse factorielle de tableaux multiples,
+ * Masson, Paris 1984,185p., p. 62. D'après VPROP et TRIDI,
+ * de LEBART et coll.
+ --------------------------------------------------*/
+{
+ double *s, epsilon;
+ double a, b, c, x, xp, q, bp, ab, ep, h, t, u , v;
+ double dble;
+ int ni, i, i2, j, k, jk, ijk, ij, l, ix, m, m1, isnou;
+
+ vecalloc(&s, n0);
+ a = 0.000000001;
+ epsilon = 0.0000001;
+ ni = 100;
+ if (n0 == 1) {
+ d[1] = w[1][1];
+ w[1][1] = 1.0;
+ *rang = 1;
+ freevec (s);
+ return;
+ }
+
+ for (i2=2;i2<=n0;i2++) {
+
+ b=0.0;
+ c=0.0;
+ i=n0-i2+2;
+ k=i-1;
+ if (k < 2) goto Et1;
+ for (l=1;l<=k;l++) {
+ c = c + fabs((double) w[i][l]);
+ }
+ if (c != 0.0) goto Et2;
+
+ Et1: s[i] = w[i][k];
+ goto Etc;
+
+ Et2: for (l=1;l<=k;l++) {
+ x = w[i][l] / c;
+ w[i][l] = x;
+ b = b + x * x;
+ }
+ xp = w[i][k];
+ ix = 1;
+ if (xp < 0.0) ix = -1;
+
+ /* q = -sqrt(b) * ix; */
+ dble = b;
+ dble = -sqrt(dble);
+ q = dble * ix;
+
+ s[i] = c * q;
+ b = b - xp * q;
+ w[i][k] = xp - q;
+ xp = 0;
+ for (m=1;m<=k;m++) {
+ w[m][i] = w[i][m] / b / c;
+ q = 0;
+ for (l=1;l<=m;l++) {
+ q = q + w[m][l] * w[i][l];
+ }
+ m1 = m + 1;
+ if (k < m1) goto Et3;
+ for (l=m1;l<=k;l++) {
+ q = q + w[l][m] * w[i][l];
+ }
+
+ Et3: s[m] = q / b;
+ xp = xp + s[m] * w[i][m];
+ }
+ bp = xp * 0.5 / b;
+ for (m=1;m<=k;m++) {
+ xp = w[i][m];
+ q = s[m] - bp * xp;
+ s[m] = q;
+ for (l=1;l<=m;l++) {
+ w[m][l] = w[m][l] - xp * s[l] - q * w[i][l];
+ }
+ }
+ for (l=1;l<=k;l++) {
+ w[i][l] = c * w[i][l];
+ }
+
+ Etc: d[i] = b;
+ } /* for (i2=2;i2<n0;i2++) */
+
+ s[1] = 0.0;
+ d[1] = 0.0;
+
+ for (i=1;i<=n0;i++) {
+
+ k = i - 1;
+ if (d[i] == 0.0) goto Et4;
+ for (m=1;m<=k;m++) {
+ q = 0.0;
+ for (l=1;l<=k;l++) {
+ q = q + w[i][l] * w[l][m];
+ }
+ for (l=1;l<=k;l++) {
+ w[l][m] = w[l][m] - q * w[l][i];
+ }
+ }
+
+ Et4: d[i] = w[i][i];
+ w[i][i] = 1.0;
+ if (k < 1) goto Et5;
+ for (m=1;m<=k;m++) {
+ w[i][m] = 0.0;
+ w[m][i] = 0.0;
+ }
+
+ Et5:;
+ }
+
+ for (i=2;i<=n0;i++) {
+ s[i-1] = s[i];
+ }
+ s[n0] = 0.0;
+
+ for (k=1;k<=n0;k++) {
+
+ m = 0;
+
+ Et6: for (j=k;j<=n0;j++) {
+ if (j == n0) goto Et7;
+ ab = fabs((double) s[j]);
+ ep = a * (fabs((double) d[j]) + fabs((double) d[j+1]));
+ if (ab < ep) goto Et7;
+ }
+
+ Et7: isnou = 1;
+ h = d[k];
+ if (j == k) goto Eta;
+ if (m < ni) goto Etd;
+
+ /*err_message("Error: can't compute matrix eigenvalues");*/
+
+ Etd: m = m + 1;
+ q = (d[k+1]-h) * 0.5 / s[k];
+
+ /* t = sqrt(q * q + 1.0); */
+ dble = q * q + 1.0;
+ dble = sqrt(dble);
+ t = dble;
+
+ if (q < 0.0) isnou = -1;
+ q = d[j] - h + s[k] / (q + t * isnou);
+ u = 1.0;
+ v = 1.0;
+ h = 0.0;
+ jk = j-k;
+ for (ijk=1;ijk<=jk;ijk++) {
+ i = j - ijk;
+ xp = u * s[i];
+ b = v * s[i];
+ if (fabs((double) xp) < fabs((double) q)) goto Et8;
+ u = xp / q;
+
+ /* t = sqrt(u * u + 1); */
+ dble = u * u + 1.0;
+ dble = sqrt(dble);
+ t = dble;
+
+ s[i+1] = q * t;
+ v = 1 / t;
+ u = u * v;
+ goto Et9;
+
+ Et8: v = q / xp;
+
+ /* t = sqrt(1 + v * v); */
+ dble = 1.0 + v * v;
+ dble = sqrt(dble);
+ t = dble;
+
+ s[i+1] = t * xp;
+ u = 1 / t;
+ v = v * u;
+
+ Et9:
+ q = d[i+1] - h;
+ t = (d[i] - q) * u + 2.0 * v * b;
+ h = u * t;
+ d[i+1] = q + h;
+ q = v * t - b;
+ for (l=1;l<=n0;l++) {
+ xp = w[l][i+1];
+ w[l][i+1] = u * w[l][i] + v * xp;
+ w[l][i] = v * w[l][i] - u * xp;
+ }
+ }
+ d[k] = d[k] - h;
+ s[k] = q;
+ s[j] = 0.0;
+
+ goto Et6;
+
+ Eta:;
+ } /* for (k=1;k<=n0;k++) */
+
+ for (ij=2;ij<=n0;ij++) {
+
+ i = ij - 1;
+ l = i;
+ h = d[i];
+ for (m=ij;m<=n0;m++) {
+ if (d[m] >= h) {
+ l = m;
+ h = d[m];
+ }
+ }
+ if (l == i) {
+ goto Etb;
+ } else {
+ d[l] = d[i];
+ d[i] = h;
+ }
+ for (m=1;m<=n0;m++) {
+ h = w[m][i];
+ w[m][i] = w[m][l];
+ w[m][l] = h;
+ }
+
+ Etb:;
+ } /* for (ij=2;ij<=n0;ij++) */
+
+ *rang = 0;
+ for (i=1;i<=n0;i++) {
+ if (d[i] / d[1] < epsilon) d[i] = 0.0;
+ if (d[i] != 0.0) *rang = *rang + 1;
+ }
+ freevec(s);
+} /* DiagoCompbg */
+/***********************************************************************/
+void freeintvec (int *vec)
+/*--------------------------------------------------
+ * liberation de memoire pour un vecteur
+ --------------------------------------------------*/
+{
+
+ free((char *) vec);
+
+}
+/***********************************************************************/
+void freetab (double **tab)
+/*--------------------------------------------------
+ * Allocation de memoire dynamique pour un tableau (l1, c1)
+ --------------------------------------------------*/
+{
+ int i, n;
+
+ n = *(*(tab));
+ for (i=0;i<=n;i++) {
+ free((char *) *(tab+i) );
+ }
+ free((char *) tab);
+}
+/***********************************************************************/
+void freevec (double *vec)
+/*--------------------------------------------------
+ * liberation de memoire pour un vecteur
+ --------------------------------------------------*/
+{
+ free((char *) vec);
+}
+/***********************************************************************/
+void getpermutation (int *numero, int repet)
+/*----------------------
+ * affectation d'une permutation aleatoire des n premiers entiers
+ * dans dans un vecteur d'entiers de dimension n
+ * vecintalloc prealable exige
+ * *numero est un vecteur d'entier
+ * repet est un entier qui peut prendre une valeur arbitraire
+ * utilise dans le germe du generateur de nb pseudo-aleatoires
+ * si on l'incremente dans des appels repetes (e.g. simulation) garantit
+ * que deux appels donnent deux resultats distincts (seed=clock+repet)
+ ------------------------*/
+{
+ int i, n;
+ int *alea;
+
+ n=numero[0];
+ vecintalloc (&alea,n);
+
+ /*-------------
+ * numerotation dans numero
+ -----------*/
+ for (i=1;i<=n;i++) {
+ numero[i]=i;
+ }
+
+ /*-------------
+ * affectation de nombres aleatoires dans alea
+ ----------------*/
+ GetRNGstate();
+ for (i=1;i<=n;i++) {
+ alea[i]= (int) (unif_rand() * RAND_MAX);
+ }
+ PutRNGstate();
+ trirapideint (alea , numero, 1, n);
+ freeintvec (alea);
+}
+/***********************************************************************/
+void matcentrage (double **A, double *poili, int typ)
+{
+ /* Modification of the original table for different analyses.
+ typ=1 no modification (PCA on original variable)
+ typ=2 ACM (matmodifcm)
+ typ=3 normed and centred PCA (matmodifcn)
+ typ=4 centred PCA (matmodifcp)
+ typ=5 normed and non-centred PCA (matmodifcs)
+ typ=6 COA (matmodiffc)
+ typ=7 FCA (matmodiffc)
+ typ=8 Hill-smith (use matcentagehi in this case)
+ */
+ if (typ == 1) {
+ return;
+ } else if (typ == 2) {
+ matmodifcm (A, poili);
+ return;
+ } else if (typ == 3) {
+ matmodifcn (A, poili);
+ return;
+ } else if (typ == 4) {
+ matmodifcp (A, poili);
+ return;
+ } else if (typ == 5) {
+ matmodifcs (A, poili);
+ return;
+ } else if (typ == 6) {
+ matmodiffc (A, poili);
+ return;
+ } else if (typ == 7) {
+ matmodifcm (A, poili);
+ return;
+ }
+}
+
+/***********************************************************************/
+void matcentragehi (double **tab, double *poili, int *index, int *assign)
+{
+ /*centrage d'un tableau de hill smith
+ tab tableau avec quantitatives et qualitatives disjonctifs complets
+ poili vecteur poids lignes
+ index indique si chaque variables est quanti (1) ou quali (2)
+ assign vecteur entier qui donne l'index de la variable pour chaque colonne
+ */
+
+ int l1,c1,i,j,nquant=0,nqual=0,jqual=1,jquant=1;
+ double **tabqual, **tabquant;
+ l1 = tab[0][0];
+ c1 = tab[1][0];
+ for(j=1;j<=c1;j++){
+ if(index[assign[j]]==2){
+ nqual=nqual+1;
+ }
+ else if (index[assign[j]]==1){
+ nquant=nquant+1;
+ }
+ }
+
+ taballoc(&tabqual,l1,nqual);
+ taballoc(&tabquant,l1,nquant);
+
+ for (j=1;j<=c1;j++){
+ if (index[assign[j]]==2) {
+ for (i=1; i<=l1;i++) {
+ tabqual[i][jqual]=tab[i][j];
+
+ }
+ jqual=jqual+1;
+ } else if (index[assign[j]]==1){
+ for (i=1; i<=l1;i++) {
+ tabquant[i][jquant]=tab[i][j];
+
+ }
+ jquant=jquant+1;
+ }
+ }
+
+
+ matmodifcm (tabqual, poili);
+ matmodifcn (tabquant, poili);
+ jqual=1;
+ jquant=1;
+
+ for (j=1;j<=c1;j++) {
+ if (index[assign[j]]==2) {
+ for (i=1;i<=l1;i++) {
+ tab[i][j] = tabqual[i][jqual];
+ }
+ jqual=jqual+1;
+ }
+ else if (index[assign[j]]==1) {
+ for (i=1;i<=l1;i++) {
+ tab[i][j] = tabquant[i][jquant];
+ }
+ jquant=jquant+1;
+ }
+ }
+ freetab(tabqual);
+ freetab(tabquant);
+ return;
+}
+
+/***********************************************************************/
+void matmodifcm (double **tab, double *poili)
+/*--------------------------------------------------
+ * tab est un tableau n lignes, m colonnes
+ * disjonctif complet
+ * poili est un vecteur n composantes
+ * la procedure retourne tab centre par colonne
+ * pour la ponderation poili (somme=1)
+ * centrage type correspondances multiples
+ --------------------------------------------------*/
+{
+ double poid;
+ int i, j, l1, m1;
+ double *poimoda;
+ double x, z;
+
+ l1 = tab[0][0];
+ m1 = tab[1][0];
+ vecalloc(&poimoda, m1);
+
+
+ for (i=1;i<=l1;i++) {
+ poid = poili[i];
+ for (j=1;j<=m1;j++) {
+ poimoda[j] = poimoda[j] + tab[i][j] * poid;
+ }
+ }
+
+ for (j=1;j<=m1;j++) {
+ x = poimoda[j];
+ if (x==0) {
+ for (i=1;i<=l1;i++) tab[i][j] = 0;
+ } else {
+
+ for (i=1;i<=l1;i++) {
+ z = tab[i][j]/x - 1.0;
+ tab[i][j] = z;
+ }
+ }
+ }
+ freevec (poimoda);
+}
+/***********************************************************************/
+void matmodifcn (double **tab, double *poili)
+/*--------------------------------------------------
+ * tab est un tableau n lignes, p colonnes
+ * poili est un vecteur n composantes
+ * la procedure retourne tab norme par colonne
+ * pour la ponderation poili (somme=1)
+ --------------------------------------------------*/
+{
+ double poid, x, z, y, v2;
+ int i, j, l1, c1;
+ double *moy, *var;
+
+ l1 = tab[0][0];
+ c1 = tab[1][0];
+
+ vecalloc(&moy, c1);
+ vecalloc(&var, c1);
+
+
+ /*--------------------------------------------------
+ * calcul du tableau centre/norme
+ --------------------------------------------------*/
+
+ for (i=1;i<=l1;i++) {
+ poid = poili[i];
+ for (j=1;j<=c1;j++) {
+ moy[j] = moy[j] + tab[i][j] * poid;
+ }
+ }
+
+ for (i=1;i<=l1;i++) {
+ poid=poili[i];
+ for (j=1;j<=c1;j++) {
+ x = tab[i][j] - moy[j];
+ var[j] = var[j] + poid * x * x;
+ }
+ }
+
+ for (j=1;j<=c1;j++) {
+ v2 = var[j];
+ if (v2<=0) v2 = 1;
+ v2 = sqrt(v2);
+ var[j] = v2;
+ }
+
+ for (i=1;i<=c1;i++) {
+ x = moy[i];
+ y = var[i];
+ for (j=1;j<=l1;j++) {
+ z = tab[j][i] - x;
+ z = z / y;
+ tab[j][i] = z;
+ }
+ }
+
+ freevec(moy);
+ freevec(var);
+
+}
+/***********************************************************************/
+void matmodifcs (double **tab, double *poili)
+/*--------------------------------------------------
+ * tab est un tableau n lignes, p colonnes
+ * poili est un vecteur n composantes
+ * la procedure retourne tab standardise par colonne
+ * pour la ponderation poili (somme=1)
+ --------------------------------------------------*/
+{
+ double poid, x, z, y, v2;
+ int i, j, l1, c1;
+ double *var;
+
+ l1 = tab[0][0];
+ c1 = tab[1][0];
+
+ vecalloc(&var, c1);
+
+
+ /*--------------------------------------------------
+ * calcul du tableau standardise
+ --------------------------------------------------*/
+
+ for (i=1;i<=l1;i++) {
+ poid=poili[i];
+ for (j=1;j<=c1;j++) {
+ x = tab[i][j];
+ var[j] = var[j] + poid * x * x;
+ }
+ }
+
+ for (j=1;j<=c1;j++) {
+ v2 = var[j];
+ if (v2<=0) v2 = 1;
+ v2 = sqrt(v2);
+ var[j] = v2;
+ }
+
+ for (i=1;i<=c1;i++) {
+ y = var[i];
+ for (j=1;j<=l1;j++) {
+ z = tab[j][i];
+ z = z / y;
+ tab[j][i] = z;
+ }
+ }
+ freevec(var);
+}
+/***********************************************************************/
+void matmodifcp (double **tab, double *poili)
+/*--------------------------------------------------
+ * tab est un tableau n lignes, p colonnes
+ * poili est un vecteur n composantes
+ * la procedure retourne tab centre par colonne
+ * pour la ponderation poili (somme=1)
+ --------------------------------------------------*/
+{
+ double poid;
+ int i, j, l1, c1;
+ double *moy, x, z;
+
+ l1 = tab[0][0];
+ c1 = tab[1][0];
+ vecalloc(&moy, c1);
+
+
+ /*--------------------------------------------------
+ * calcul du tableau centre
+ --------------------------------------------------*/
+
+ for (i=1;i<=l1;i++) {
+ poid = poili[i];
+ for (j=1;j<=c1;j++) {
+ moy[j] = moy[j] + tab[i][j] * poid;
+ }
+ }
+
+
+ for (i=1;i<=c1;i++) {
+ x = moy[i];
+ for (j=1;j<=l1;j++) {
+ z = tab[j][i] - x;
+ tab[j][i] = z;
+ }
+ }
+ freevec(moy);
+}
+/***********************************************************************/
+void matmodiffc (double **tab, double *poili)
+/*--------------------------------------------------
+ * tab est un tableau n lignes, m colonnes
+ * de nombres positifs ou nuls
+ * poili est un vecteur n composantes
+ * la procedure retourne tab centre doublement
+ * pour la ponderation poili (somme=1)
+ * centrage type correspondances simples
+ --------------------------------------------------*/
+{
+ double poid;
+ int i, j, l1, m1;
+ double *poimoda;
+ double x, z;
+
+ l1 = tab[0][0];
+ m1 = tab[1][0];
+ vecalloc(&poimoda, m1);
+
+
+ for (i=1;i<=l1;i++) {
+ x = 0;
+ for (j=1;j<=m1;j++) {
+ x = x + tab[i][j];
+ }
+ if (x!=0) {
+ for (j=1;j<=m1;j++) {
+ tab[i][j] = tab[i][j]/x;
+ }
+ }
+ }
+
+ for (i=1;i<=l1;i++) {
+ poid = poili[i];
+ for (j=1;j<=m1;j++) {
+ poimoda[j] = poimoda[j] + tab[i][j] * poid;
+ }
+ }
+
+ for (j=1;j<=m1;j++) {
+ x = poimoda[j];
+ if (x==0) {
+ /*err_message("column has a nul weight (matmodiffc)");*/
+ }
+
+ for (i=1;i<=l1;i++) {
+ z = tab[i][j]/x - 1.0;
+ tab[i][j] = z;
+ }
+ }
+ freevec (poimoda);
+}
+/***********************************************************************/
+void matpermut (double **A, int *num, double **B)
+{
+ /*---------------------------------------
+ * A est une matrice n-p
+ * B est une matrice n-p
+ * num est une permutation aleatoire des n premiers entiers
+ * B contient en sortie les lignes de A permutees
+ * ---------------------------------------*/
+
+ int lig, col,lig1, col1, lig2, i, j, k;
+
+ lig = A[0][0];
+ col = A[1][0];
+ lig1 = B[0][0];
+ col1 = B[1][0];
+ lig2 = num[0];
+
+
+ if ( (lig!=lig1) || (col!=col1) || (lig!=lig2) ) {
+ return;
+ }
+
+ for (i=1; i<=lig; i++) {
+ k=num[i];
+ for (j=1; j<=col; j++) {
+ B[i][j] = A[k][j];
+ }
+ }
+}
+/***********************************************************************/
+void prodmatABC (double **a, double **b, double **c)
+/*--------------------------------------------------
+ * Produit matriciel AB
+ --------------------------------------------------*/
+{
+ int j, k, i, lig, col, col2;
+ double s;
+
+ lig = a[0][0];
+ col = a[1][0];
+
+ col2 = b[1][0];
+
+ for (i=1;i<=lig;i++) {
+ for (k=1;k<=col2;k++) {
+ s = 0;
+ for (j=1;j<=col;j++) {
+ s = s + a[i][j] * b[j][k];
+ }
+ c[i][k] = s;
+ }
+ }
+}
+
+/***********************************************************************/
+void prodmatAdBC (double **a, double *d, double **b, double **c)
+/*--------------------------------------------------
+ * Produit matriciel AdB (d is a diagonal matrix stored in a vector)
+ --------------------------------------------------*/
+{
+ int j, k, i, lig, col, col2;
+ double s;
+
+ lig = a[0][0];
+ col = a[1][0];
+
+ col2 = b[1][0];
+
+ for (i=1;i<=lig;i++) {
+ for (k=1;k<=col2;k++) {
+ s = 0;
+ for (j=1;j<=col;j++) {
+ s = s + a[i][j] * d[j] * b[j][k];
+ }
+ c[i][k] = s;
+ }
+ }
+}
+
+/***********************************************************************/
+void prodmatAtAB (double **a, double **b)
+/*--------------------------------------------------
+ * Produit matriciel AtA
+ --------------------------------------------------*/
+{
+ int j, k, i, lig, col;
+ double s;
+
+ lig = a[0][0];
+ col = a[1][0];
+
+ for (j=1;j<=col;j++) {
+ for (k=j;k<=col;k++) {
+ s = 0;
+ for (i=1;i<=lig;i++) {
+ s = s + a[i][k] * a[i][j];
+ }
+ b[j][k] = s;
+ b[k][j] = s;
+ }
+ }
+}
+/***********************************************************************/
+void prodmatAtBC (double **a, double **b, double **c)
+/*--------------------------------------------------
+ * Produit matriciel AtB
+ --------------------------------------------------*/
+{
+ int j, k, i, lig, col, col2;
+ double s;
+
+ lig = a[0][0];
+ col = a[1][0];
+
+ col2 = b[1][0];
+
+ for (j=1;j<=col;j++) {
+ for (k=1;k<=col2;k++) {
+ s = 0;
+ for (i=1;i<=lig;i++) {
+ s = s + a[i][j] * b[i][k];
+ }
+ c[j][k] = s;
+ }
+ }
+}
+/***********************************************************************/
+double maxvec (double *vec)
+/*--------------------------------------------------
+ * calcul le max d'un vecteur
+ --------------------------------------------------*/
+{
+ int i, len;
+ double x;
+
+ x = vec[1];
+ len = vec[0];
+ for (i=1;i<=len;i++) {
+ if (vec[i] > x) x = vec[i];
+ }
+ return(x);
+}
+/***********************************************************************/
+void prodmatAAtB (double **a, double **b)
+/*--------------------------------------------------
+ * Produit matriciel B = AAt
+ --------------------------------------------------*/
+{
+ int j, k, i, lig, col;
+ double s;
+
+ lig = a[0][0];
+ col = a[1][0];
+
+ for (j=1;j<=lig;j++) {
+ for (k=j;k<=lig;k++) {
+ s = 0;
+ for (i=1;i<=col;i++) {
+ s = s + a[j][i] * a[k][i];
+ }
+ b[j][k] = s;
+ b[k][j] = s;
+ }
+ }
+}
+/***********************************************************************/
+void prodmatAtBrandomC (double **a, double **b, double **c, int*permut)
+/*--------------------------------------------------
+ * Produit matriciel AtB
+ * les lignes de B sont permutees par la permutation permut
+ --------------------------------------------------*/
+{
+ int j, k, i, i0, lig, col, col2;
+ double s;
+
+ lig = a[0][0];
+ col = a[1][0];
+
+ col2 = b[1][0];
+
+ for (j=1;j<=col;j++) {
+ for (k=1;k<=col2;k++) {
+ s = 0;
+ for (i=1;i<=lig;i++) {
+ i0 = permut[i];
+ s = s + a[i][j] * b[i0][k];
+ }
+ c[j][k] = s;
+ }
+ }
+}
+/***********************************************************************/
+void sqrvec (double *v1)
+/*--------------------------------------------------
+ * Racine carree des elements d'un vecteur
+ --------------------------------------------------*/
+{
+ int i, c1;
+ double v2;
+
+ c1 = v1[0];
+
+ for (i=1;i<=c1;i++) {
+ v2 = v1[i];
+ /* if (v2 < 0.0) err_message("Error: Square root of negative number (sqrvec)");*/
+ v2 = sqrt(v2);
+ v1[i] = v2;
+ }
+}
+/***********************************************************************/
+void taballoc (double ***tab, int l1, int c1)
+/*--------------------------------------------------
+ * Allocation de memoire dynamique pour un tableau (l1, c1)
+ --------------------------------------------------*/
+{
+ int i, j;
+
+ if ( (*tab = (double **) calloc(l1+1, sizeof(double *))) != 0) {
+ for (i=0;i<=l1;i++) {
+ if ( (*(*tab+i)=(double *) calloc(c1+1, sizeof(double))) == 0 ) {
+ return;
+ for (j=0;j<i;j++) {
+ free(*(*tab+j));
+ }
+ }
+ }
+ }
+
+ **(*tab) = l1;
+ **(*tab+1) = c1;
+}
+/***********************************************************************/
+void trild (double *x , int *num, int gauche, int droite)
+/*--------------------------------------------------
+ * Tri d'un tableau de double avec conservation du rang
+ * dans un tableau entier.
+ --------------------------------------------------*/
+{
+ int j, dernier, milieu;
+ double t;
+
+
+ if ( (droite-gauche)<=0) return;
+ milieu = (gauche+droite)/2;
+ trildswap (x, gauche, milieu);
+
+ trildintswap (num, gauche, milieu);
+ t=x[gauche];
+ dernier=gauche;
+ for (j = gauche+1; j<=droite; j++) {
+ if (x[j] > t) {
+ dernier = dernier + 1;
+ trildswap (x, dernier, j);
+ trildintswap (num, dernier, j);
+ }
+ }
+ trildswap (x, gauche, dernier);
+ trildintswap (num, gauche, dernier);
+ trild (x, num, gauche, dernier-1);
+ trild (x, num, dernier+1, droite);
+}
+/**************************/
+void trildintswap (int *v, int i, int j)
+{
+ int provi;
+
+ provi=v[i];
+ v[i]=v[j];
+ v[j]=provi;
+}
+/***********************************************************************/
+void trildswap (double *v, int i, int j)
+/*--------------------------------------------------
+ * Echange les valeurs de deux double
+ --------------------------------------------------*/
+{
+ double provi;
+
+ provi=v[i];
+ v[i]=v[j];
+ v[j]=provi;
+}
+
+/***********************************************************************/
+void trirap (double *x , int *num)
+/*--------------------------------------------------
+ * Tri d'un tableau de double par ordre croissant
+ * avec conservation du rang dans un tableau entier.
+ --------------------------------------------------*/
+{
+ int i, n, *num2, gauche, droite;
+ double *x2;
+
+ n = x[0];
+ gauche = 1;
+ droite = n;
+ vecalloc(&x2, n);
+ vecintalloc(&num2, n);
+ for (i=1;i<=n;i++) num[i] = i;
+ trild(x, num, gauche, droite);
+ for (i=1;i<=n;i++) {
+ x2[i] = x[n - i + 1];
+ num2[i] = num[n - i + 1];
+ }
+ for (i=1;i<=n;i++) {
+ x[i] = x2[i];
+ num[i] = num2[i];
+ }
+ freevec(x2);
+ freeintvec(num2);
+}
+/***********************************************************************/
+void trirapideint (int *x , int *num, int gauche, int droite)
+{
+ int j, dernier, milieu, t;
+
+ if ( (droite-gauche)<=0) return;
+
+ milieu = (gauche+droite)/2;
+ trirapideintswap (x, gauche, milieu);
+ trirapideintswap (num, gauche, milieu);
+
+ t=x[gauche];
+ dernier=gauche;
+ for (j = gauche+1; j<=droite; j++) {
+ if (x[j] < t) {
+ dernier = dernier + 1;
+ trirapideintswap (x, dernier, j);
+ trirapideintswap (num, dernier, j);
+ }
+ }
+ trirapideintswap (x, gauche, dernier);
+ trirapideintswap (num, gauche, dernier);
+
+ trirapideint (x, num, gauche, dernier-1);
+ trirapideint (x, num, dernier+1, droite);
+
+}
+/***********************************************************************/
+void trirapideintswap (int *v, int i, int j)
+{
+ int provi;
+
+ provi=v[i];
+ v[i]=v[j];
+ v[j]=provi;
+}
+/***********************************************************************/
+void vecalloc (double **vec, int n)
+/*--------------------------------------------------
+ * Allocation de memoire pour un vecteur de longueur n
+ --------------------------------------------------*/
+{
+ if ( (*vec = (double *) calloc(n+1, sizeof(double))) != 0) {
+ **vec = n;
+ return;
+ } else {
+ return;
+ }
+}
+/***********************************************************************/
+void vecintalloc (int **vec, int n)
+/*--------------------------------------------------
+ * Allocation de memoire pour un vecteur d'entiers de longueur n
+ --------------------------------------------------*/
+{
+ if ( (*vec = (int *) calloc(n+1, sizeof(int))) != NULL) {
+ **vec = n;
+ return;
+ } else {
+ return;
+ }
+}
+
+
+
+/***********************************************************************/
+void vecpermut (double *A, int *num, double *B)
+{
+ /*---------------------------------------
+ * A est un vecteur n elements
+ * B est une vecteur n elements
+ * num est une permutation aleatoire des n premiers entiers
+ * B contient en sortie les elements de A permutees
+ * ---------------------------------------*/
+
+ int lig, lig1, lig2, i, k;
+
+ lig = A[0];
+ lig1 = B[0];
+ lig2 = num[0];
+
+
+ if ( (lig!=lig1) || (lig!=lig2) ) {
+ /*err_message ("Illegal parameters (vecpermut)");
+ closelisting();*/
+ }
+
+ for (i=1; i<=lig; i++) {
+ k=num[i];
+ B[i] = A[k];
+ }
+}
+
+
+/***********************************************************************/
+
+/*=====================================================================*/
+/* MODELES DE PERMUTATION */
+/*=====================================================================*/
+
+
+void permutmodel1(double **X1,double **X1permute,int *ligL,int *colL)
+{
+
+ /* permute each column independently */
+
+ /* Declaration des variables locales */
+ double *a;
+ int i,j,k,ligL1,colL1;
+ ligL1=*ligL;
+ colL1=*colL;
+
+ /* Allocation memoire pour les variables C locales */
+ vecalloc(&a, ligL1);
+
+ /* Permutation de la matrice */
+ for(j=1;j<=colL1;j++)
+ {
+ for(i=1;i<=ligL1;i++)
+ {
+ a[i]=X1[i][j];
+
+ }
+
+ aleapermutvec (a);
+
+ /* Construction de la matrice X1permute*/
+ for(k=1;k<=ligL1;k++)
+ {
+ X1permute[k][j]=a[k];
+
+ }
+
+ }
+
+ freevec(a);
+}
+
+
+void permutmodel3(double **X1,double **X1permute,int *ligL,int *colL)
+{
+ /*****************************************************************/
+ /* Fonction qui permute selon le model 3 de la methode du 4e coin*/
+ /*****************************************************************/
+ /* permutation a l"interieur de chaque ligne (site) independamement */
+ /* Declaration des variables locales */
+ double *a;
+ int i,j,k,ligL1,colL1;
+ ligL1=*ligL;
+ colL1=*colL;
+ /* Allocation memoire pour les variables C locales */
+ vecalloc(&a, colL1);
+
+ /* Permutation de la matrice */
+ for(i=1;i<=ligL1;i++)
+ {
+ for(j=1;j<=colL1;j++)
+ {
+ a[j]=X1[i][j];
+ }
+ aleapermutvec (a);
+
+ /* Construction de la matrice contenant les vecteurs permutees */
+ for (k=1; k<=colL1; k++)
+ {
+ X1permute[i][k]=a[k];
+ }
+ }
+ freevec(a);
+}
+
+
+/*=====================================================================*/
+
+void permutmodel4(double **X1, double **X1permute, int *ligL, int *colL)
+{
+ /*****************************************************************/
+ /* Fonction qui permute selon le model 4 de la methode du 4e coin*/
+ /*****************************************************************/
+ /* permute des colonnes */
+
+ /* Declaration des variables locales */
+ int i,j,ligL1,colL1;
+ ligL1=*ligL;
+ colL1=*colL;
+ double **X1transposee;
+ taballoc(&X1transposee,colL1,ligL1);
+
+ /* Transposee de X1 */
+
+ for (i=1; i<=ligL1; i++)
+ {
+ for (j=1; j<=colL1; j++)
+ {
+ X1transposee[j][i]=X1[i][j];
+ }
+ }
+
+ aleapermutmat (X1transposee);
+
+
+ //Retransposons la matrice
+
+ for (j=1; j<=colL1; j++)
+ {
+ for (i=1; i<=ligL1; i++)
+ {
+ X1permute[i][j]=X1transposee[j][i];
+ }
+ }
+ freetab(X1transposee);
+}
+
+/*=====================================================================*/
+
+void permutmodel2(double **X1, double **X1permute, int *ligL, int *colL)
+{
+ /*****************************************************************/
+ /* Fonction qui permute selon le model 2 de la methode du 4e coin*/
+ /*****************************************************************/
+ /* permute des lignes */
+ int i,j,ligL1,colL1;
+ ligL1=*ligL;
+ colL1=*colL;
+
+ for (j=1; j<=colL1; j++)
+ {
+ for (i=1; i<=ligL1; i++)
+ {
+ X1permute[i][j]=X1[i][j];
+ }
+ }
+
+ aleapermutmat (X1permute);
+}
+
+/*=====================================================================*/
+
+void permutmodel5(double **X1, double **X1permute, int *ligL, int *colL)
+{
+ /*****************************************************************/
+ /* Fonction qui permute selon le model 5 (new)*/
+ /*****************************************************************/
+ /* permute des lignes puis des colonnes*/
+
+ int i,j,ligL1,colL1;
+ double **X1transposee;
+ ligL1=*ligL;
+ colL1=*colL;
+
+ taballoc(&X1transposee,colL1,ligL1);
+ for (j=1; j<=colL1; j++)
+ {
+ for (i=1; i<=ligL1; i++)
+ {
+ X1permute[i][j]=X1[i][j];
+ }
+ }
+
+ aleapermutmat (X1permute); /* perm lignes */
+
+ /* Transposee de X1permute */
+
+ for (i=1; i<=ligL1; i++)
+ {
+ for (j=1; j<=colL1; j++)
+ {
+ X1transposee[j][i]=X1permute[i][j];
+ }
+ }
+
+ aleapermutmat (X1transposee); /* perm colonnes */
+
+
+ //Retransposons la matrice
+
+ for (j=1; j<=colL1; j++)
+ {
+ for (i=1; i<=ligL1; i++)
+ {
+ X1permute[i][j]=X1transposee[j][i];
+ }
+ }
+ freetab(X1transposee);
+
+}
diff --git a/src/adesub.h b/src/adesub.h
new file mode 100644
index 0000000..a9ab73e
--- /dev/null
+++ b/src/adesub.h
@@ -0,0 +1,53 @@
+#include <math.h>
+#include <time.h>
+#include <string.h>
+#include <stdlib.h>
+#include <R.h>
+
+int dtodelta (double **data, double *pl);
+void initvec (double *v1, double r);
+double alea (void);
+void aleapermutvec (double *a);
+void aleapermutmat (double **a);
+void aleapermutmat (double **a);
+void aleapermutvec (double *a);
+void DiagobgComp (int n0, double **w, double *d, int *rang);
+void freeinttab (int **tab);
+void freeintvec (int *vec);
+void freetab (double **tab);
+void freevec (double *vec);
+void getpermutation (int *numero, int repet);
+void matcentrage (double **A, double *poili, int typ);
+void matcentragehi (double **tab, double *poili, int *index, int *assign);
+void matmodifcm (double **tab, double *poili);
+void matmodifcn (double **tab, double *poili);
+void matmodifcp (double **tab, double *poili);
+void matmodifcs (double **tab, double *poili);
+void matmodiffc (double **tab, double *poili);
+void matpermut (double **A, int *num, double **B);
+double maxvec (double *vec);
+void prodmatAAtB (double **a, double **b);
+void prodmatABC (double **a, double **b, double **c);
+void prodmatAdBC (double **a, double *d, double **b, double **c);
+void prodmatAtAB (double **a, double **b);
+void prodmatAtBC (double **a, double **b, double **c);
+void prodmatAtBrandomC (double **a, double **b, double **c, int*permut);
+double traceXtdLXq (double **X, double **L, double *d, double *q);
+void sqrvec (double *v1);
+void taballoc (double ***tab, int l1, int c1);
+void tabintalloc (int ***tab, int l1, int c1);
+void trild (double *x , int *num, int gauche, int droite);
+void trildintswap (int *v, int i, int j);
+void trildswap (double *v, int i, int j);
+void trirap (double *x , int *num);
+void trirapideint (int *x , int *num, int gauche, int droite);
+void trirapideintswap (int *v, int i, int j);
+void vecalloc (double **vec, int n);
+void vecintalloc (int **vec, int n);
+void vecpermut (double *A, int *num, double *B);
+void permutmodel1(double **X1,double **X1permute,int *ligL,int *colL);
+void permutmodel2(double **X1,double **X1permute,int *ligL,int *colL);
+void permutmodel3(double **X1,double **X1permute,int *ligL,int *colL);
+void permutmodel4(double **X1,double **X1permute,int *ligL,int *colL);
+void permutmodel5(double **X1,double **X1permute,int *ligL,int *colL);
+
diff --git a/src/divsub.c b/src/divsub.c
new file mode 100644
index 0000000..fe2b730
--- /dev/null
+++ b/src/divsub.c
@@ -0,0 +1,735 @@
+#include <math.h>
+#include <time.h>
+#include <string.h>
+#include <stdlib.h>
+#include "adesub.h"
+#include "divsub.h"
+
+/***************************************************************/
+void popweighting(int **b, int *som, double *res)
+/*--------------------------------------------------
+* Calcule les poids des samples muij
+* b est le tableau samples
+* som est la somme des termes de b
+* res est le vecteur ou on doit mettre les poids
+* les poids sont en frequences
+--------------------------------------------------*/
+{
+
+ int i, j, lig, col;
+
+ lig = b[0][0];
+ col = b[1][0];
+
+ for(j = 1; j <= col; j++){
+ res[j] = 0;
+ for(i = 1; i <= lig; i++){
+ res[j] = (double) b[i][j] / (double) som[0] + res[j];
+ }
+ }
+
+}
+
+/***************************************************************/
+void popsum(int **b, int *res)
+/*--------------------------------------------------
+* Calcule les effectifs des samples
+* b est le tableau samples
+* res est le vecteur ou on doit mettre les effectifs
+--------------------------------------------------*/
+{
+
+ int i, j, lig, col;
+
+ lig = b[0][0];
+ col = b[1][0];
+
+ for(j = 1; j <= col; j++){
+ res[j] = 0;
+ for(i = 1; i <= lig; i++){
+ res[j] = (double) b[i][j] + res[j] ;
+ }
+ }
+
+}
+
+/***************************************************************/
+void newsamples(int **b, int *vstru, int **res)
+/*--------------------------------------------------
+* Recalcule la matrice samples pour un niveau hi�rarchique sup�rieur
+* b est le tableau samples et c est le tableau structures
+--------------------------------------------------*/
+{
+
+ int i, j, interm, col, lig;
+
+ col = b[1][0];
+ lig = b[0][0];
+
+ for(i = 1; i <= lig; i++){
+ for(j = 1; j <= col; j++){
+ interm = vstru[j];
+ res[i][interm] = res[i][interm] + (double) b[i][j];
+ }
+ }
+
+}
+
+/***************************************************************/
+void alphadiv(double **a, int **b, int *som, double *res)
+/*--------------------------------------------------
+* Calcule les diversites au sein de chaque sample ou niveau hierarchique superieur
+* a est le tableau distance et b est le tableau samples,
+* som est la somme de tous les termes de b,
+* res contiendra les diversites
+--------------------------------------------------*/
+{
+
+ double **transi, **transib, *respoids, **bmod;
+
+ /* bmod va contenir le tableau b mais avec les frequences pour chaque colonne
+ * ie la somme des termes de chaque colonne vaut 1*/
+
+ int i, j, cola, colb, ligb;
+
+ colb = b[1][0];
+ cola = a[1][0];
+ ligb = b[0][0];
+
+ taballoc(&transi, colb, cola);
+ taballoc(&transib, colb, colb);
+ taballoc(&bmod, ligb, colb);
+ vecalloc(&respoids, colb);
+
+ popweighting(b, som, respoids);
+
+ for(i = 1; i <= ligb; i++){
+ for(j = 1; j <= colb; j++){
+ bmod[i][j] = (double) b[i][j] / respoids[j] / (double) som[0];
+ }
+ }
+
+ prodmatAtBC(bmod, a, transi);
+ prodmatABC(transi, bmod, transib);
+
+ for(j = 1; j <= colb; j++) {
+ res[j] = transib[j][j];
+ }
+
+ /* la diversite est dans la diagonale de transib */
+
+ freetab(transi);
+ freetab(transib);
+ freetab(bmod);
+ freevec(respoids);
+
+}
+
+/***************************************************************/
+void sums(double **a, int **b, int **c, int *som, double *sst, int *prindicstr, double *res)
+/*--------------------------------------------------
+* Calcule les sommes des carres des ecarts
+* les resultats sont donnes de alpha moyen a total
+--------------------------------------------------*/
+{
+
+ double *resdiva, *respoids, *lesgammas, somdesres;
+ int i, j, l, seuil, colb, ligb, **newb, *stru, newcolb, colc, lenres;
+
+ colb = b[1][0];
+ ligb = b[0][0];
+ colc = c[1][0];
+ lenres = res[0];
+
+
+ vecalloc(&resdiva, colb);
+ vecalloc(&respoids, colb);
+ vecintalloc(&stru, colb);
+ vecalloc(&lesgammas, colc);
+
+ /* stru va contenir une des colonnes de la matrice c
+ * resdiva va contenir un vecteur de diversite intra a un des niveau hierarchique */
+
+ for(i = 1; i <= colb; i++){
+ stru[i] = c[i][1];
+ }
+
+ newcolb = maxvecint(stru);
+
+ tabintalloc(&newb, ligb, newcolb);
+ alphadiv(a, b, som, resdiva);
+ popweighting(b, som, respoids);
+
+ res[1] = 0;
+ for(i = 1; i <= colb; i++){
+ res[1] = resdiva[i] * respoids[i] * (double) som[0] + res[1];
+ }
+
+ if(prindicstr[0] != 0){
+
+ for(j = 1; j <= colc; j++){
+ for(i = 1; i <= ligb; i++){
+ for(l = 1; l <= newcolb;l++){
+ newb[i][l] = 0;
+ }
+ }
+
+ /* il faut reinitialiser la matrice newb */
+
+ for(i = 1; i <= colb; i++){
+ stru[i] = c[i][j];
+ }
+
+ newsamples(b, stru, newb);
+ newb[1][0] = maxvecint(stru);
+ alphadiv(a, newb, som, resdiva);
+ popweighting(newb, som, respoids);
+
+ lesgammas[j] = 0;
+
+ seuil = newb[1][0];
+ for(i = 1; i <= seuil; i++){
+ lesgammas[j] = resdiva[i] * respoids[i] * (double) som[0] + lesgammas[j];
+ }
+ }
+
+ for(i = 1; i <= colc; i++){
+ somdesres = 0;
+ for(j = 1; j <= i; j++){
+ somdesres = somdesres + res[j];
+ }
+ res[i + 1] = lesgammas[i] - somdesres;
+ }
+
+ }
+
+
+ seuil = lenres - 1;
+ if(prindicstr[0] != 0){
+ res[seuil] = sst[0] * (double) som[0] - lesgammas[colc];
+ }
+ else{
+ res[seuil] = sst[0] * (double) som[0] - res [1];
+ }
+
+ res[lenres] = sst[0] * (double) som[0];
+
+ freevec(resdiva);
+ freevec(respoids);
+ freeintvec(stru);
+ freevec(lesgammas);
+ freeinttab(newb);
+
+
+}
+
+/***************************************************************/
+int maxvecint (int *vec)
+/*--------------------------------------------------
+* calcul le max d'un vecteur d'entier
+--------------------------------------------------*/
+{
+ int i, len, x;
+
+ x = vec[1];
+ len = vec[0];
+ for (i = 1; i <= len; i++) {
+ if (vec[i] > x) x = vec[i];
+ }
+ return(x);
+}
+
+/***************************************************************/
+void means(double *pss, double *pdf, double *res)
+/*--------------------------------------------------
+* Calcule les carres moyen
+* les resultats sont donnes de alpha moyen a total
+* pss contient les sommes des carres
+* pdf contient les degres de liberte
+--------------------------------------------------*/
+{
+ int i, lenpss;
+
+ lenpss = pss[0];
+ for(i = 1; i <= lenpss; i++){
+ res[i] = pss[i] / pdf[i];
+ }
+
+}
+
+/***************************************************************/
+void nvalues(int **b, int **c, int *som, double *pdf, int *prindicstr, double *res)
+/*--------------------------------------------------
+* Calcule les valeurs n qui permettent de calculer les sigmas
+* b contient le tableau samples
+* c contient le tableau structures
+* som contient la somme totale des elements de samples
+* pdf contient les degres de liberte
+--------------------------------------------------*/
+{
+ double *np, *nd, interm, *prres, *ddlutil, *ddlutilt;
+ int i, j, k, l, m, colb, colc, ligb, lenpdf, lennp, lennd, lenddlutil, lenddlutild, collessoms, *ddlutild, *prddlutild, *repstrp, *repstrd, *ressoms, **lessoms, *numsamples, *repnumsam, *nbind, *nbindtemp, newcolb, intermint, **newb, *stru;
+
+ /* sumsamples va contenir les numeros des samples 1 2 etc
+ * repnumsam contient le numero du sample auquel appartient chaque occurence
+ * lessoms contient en ligne les individus ou occurences et en colonne les groupes
+ * en entree il contient les effectifs du groupe auquel appartient une occurence */
+
+ colb = b[1][0];
+ colc = c[1][0];
+ ligb = b[0][0];
+ lenpdf = pdf[0];
+ lenddlutil = lenpdf - 2;
+
+ if(prindicstr[0] != 0){
+ collessoms = colc + 2;
+ }
+ else{
+ collessoms = 2;
+ }
+
+ lennp = collessoms - 1;
+
+ vecintalloc(&nbindtemp, colb);
+ vecintalloc(&nbind, som[0]);
+ vecintalloc(&ressoms, colb);
+ tabintalloc(&lessoms, som[0], collessoms);
+ vecintalloc(&numsamples, colb);
+ vecintalloc(&repnumsam, som[0]);
+ vecintalloc(&repstrp, colb);
+ vecintalloc(&repstrd, som[0]);
+ vecalloc(&np, lennp);
+ vecalloc(&ddlutil, lenddlutil);
+ vecalloc(&prres, lennp);
+ vecintalloc(&stru, colb);
+
+ for(i = 1; i <= colb; i++){
+ numsamples[i] = i;
+ }
+
+ for(i = 1; i <= colb; i++){
+ stru[i] = c[i][1];
+ }
+
+ newcolb = maxvecint(stru);
+ tabintalloc(&newb, ligb, newcolb);
+
+ if(prindicstr[0] != 0){
+ lennd = 0;
+ for(i = 1; i <= colc; i++){
+ lennd = lennd + i;
+ }
+ lenddlutild = 0;
+ k = colc + 1;
+ for(i = 1; i <= k; i++){
+ lenddlutild = lenddlutild + i;
+ }
+ }
+ else{
+ lennd = 1;
+ lenddlutild = 1;
+ }
+
+ vecalloc(&nd, lennd);
+ vecintalloc(&ddlutild, lenddlutild);
+ vecalloc(&ddlutilt, lenddlutild);
+ vecintalloc(&prddlutild, lennp);
+
+ popsum(b, nbindtemp);
+ repintvec(numsamples, nbindtemp, repnumsam);
+ repintvec(nbindtemp, nbindtemp, nbind);
+
+ for(i = 1; i <= som[0]; i++){
+ lessoms[i][1] = som[0];
+ lessoms[i][collessoms] = nbind[i];
+ }
+
+ k = lenpdf - 1;
+ for(i = 2; i <= k; i++){
+ ddlutil[i - 1] = pdf[i];
+ }
+
+ if(prindicstr[0] != 0){
+ for(j = 1; j <= colc; j++){
+ for(i = 1; i <= ligb; i++){
+ for(l = 1; l <= newcolb; l++){
+ newb[i][l] = 0;
+ }
+ }
+
+ /* il faut reinitialiser la matrice newb */
+
+ for(i = 1; i <= colb; i++){
+ stru[i] = c[i][j];
+ }
+
+ newsamples(b, stru, newb);
+ intermint = maxvecint(stru);
+ newb[1][0] = intermint;
+ ressoms[0] = intermint;
+ popsum(newb, ressoms);
+
+ for(i = 1; i <= colb; i++){
+ k = stru[i];
+ repstrp[i] = ressoms[k];
+ }
+
+ repintvec(repstrp, nbindtemp, repstrd);
+
+ for(i = 1; i <= som[0]; i++){
+ lessoms[i][collessoms - j] = repstrd[i];
+ }
+ }
+ }
+
+ for(j = 2; j <= collessoms; j++){
+ interm = 0;
+ for(i = 1; i <= som[0]; i++){
+ interm = (double) lessoms[i][j] / (double) lessoms[i][j - 1] + interm;
+ }
+ np[j - 1] = (double) som[0] - interm;
+ }
+
+
+ if(prindicstr[0] != 0){
+ k = 0;
+ for(i = 1; i <= lennp; i++){
+ k = k + i;
+ prres[i] = k;
+ res[k] = np[lennp - i + 1];
+ }
+ }
+
+ else{
+ for(i = 1; i <= lennp; i++){
+ res[i] = np[i];
+ }
+ }
+
+ if(prindicstr[0] != 0){
+
+ l = 1;
+ for(i = 2; i <= colc + 1; i++){
+ interm = i + 1;
+ for(j = interm; j <= collessoms; j++){
+ nd[l] = 0;
+ for(k = 1; k <= som[0]; k++){
+ interm = 1 / (double) lessoms[k][i - 1];
+ interm = 1 / (double) lessoms[k][i] - interm;
+ nd[l] = (double) lessoms[k][j] * interm + nd[l];
+ }
+ l = l + 1;
+ }
+ }
+
+ interm = 0;
+ k = colc + 1;
+ for(i = 1; i <= k; i++){
+ interm = interm + i;
+ prres[i] = interm;
+ }
+
+ interm = 1;
+ for(i = 1; i <= colc; i++){
+ j = prres[i] + 1;
+ k = prres[i + 1] - 1;
+ for(l = j; l <= k; l++){
+ m = lennd - interm + 1;
+ res[l] = nd[m];
+ interm = interm + 1;
+ }
+ }
+
+ for(i = 1; i <= colc + 1; i++){
+ prddlutild[i] = i;
+ }
+
+ repintvec(prddlutild, prddlutild, ddlutild);
+
+ for(i = 1; i <= lenddlutild; i++){
+ k= ddlutild[i];
+ ddlutilt[i] = ddlutil[k];
+ res[i] = res[i] / ddlutilt[i];
+ }
+
+ }
+
+ else{
+ res[1] = np[1] / ddlutil[1];
+ }
+
+ freeintvec(nbindtemp);
+ freeintvec(nbind);
+ freeintvec(ressoms);
+ freeinttab(lessoms);
+ freeintvec(numsamples);
+ freeintvec(repnumsam);
+ freeintvec(repstrp);
+ freeintvec(repstrd);
+ freevec(np);
+ freevec(ddlutil);
+ freevec(prres);
+ freeintvec(stru);
+ freeinttab(newb);
+ freevec(nd);
+ freeintvec(ddlutild);
+ freevec(ddlutilt);
+ freeintvec(prddlutild);
+
+}
+
+/***************************************************************/
+void repintvec(int *vecp, int *vecd, int *res)
+/*--------------------------------------------------
+* correspond a la fonction rep de R avec un vecteur en deuxieme partie
+* res doit avoir la longueur de la somme des termes de vecd
+--------------------------------------------------*/
+{
+
+ int i, j, k, lenvecp, indic, seuil;
+
+ lenvecp = vecp[0];
+ k = 0;
+ for(i = 1; i <= lenvecp; i++){
+ seuil = vecd[i];
+ for(j = 1; j <= seuil; j++){
+ indic = k + j;
+ res[indic] = vecp[i];
+ }
+ k = k + seuil;
+ }
+
+}
+
+/***************************************************************/
+void repdvecint(int *vecp, int nbd, int *res)
+/*--------------------------------------------------
+* correspond a la fonction rep de R avec un nombre en deuxieme partie
+* res doit avoir la longueur de nbd multiplier par la longueur de vecp
+* sans compter la case 0
+--------------------------------------------------*/
+{
+
+ int i, j, k, lenvecp, indic;
+
+ lenvecp = vecp[0];
+ k = 0;
+ for(i = 1; i <= nbd; i++){
+ for(j = 1; j <= lenvecp; j++){
+ indic = k + j;
+ res[indic] = vecp[j];
+ }
+ k = k + lenvecp;
+ }
+
+}
+
+/***************************************************************/
+void sigmas(double *pms, double *pn, double *res)
+/*--------------------------------------------------
+* calcule les variances ou covariances de l'amova
+* pms contient les carres moyens
+* pn contient les valeurs n
+--------------------------------------------------*/
+{
+ double si;
+ int i, j, k, lenpms, lenindex, *index;
+
+ lenpms = pms[0];
+ lenindex = lenpms - 1;
+
+ vecintalloc(&index, lenindex);
+
+ res[1] = pms[1];
+ res[2] = pms[2] / pn[1] - res[1] / pn[1];
+
+ if(lenpms >= 3){
+ k = 2;
+ for(i = 3; i <= lenpms - 1; i++){
+ si = 0;
+ for(j = 2; j <= i-1; j++){
+ si = pn[k] * res[j] + si;
+ k = k + 1;
+ }
+ res[i] = pms[i] - res[1] - si;
+ res[i] = res[i] / pn[k];
+ k = k + 1;
+ }
+ }
+
+ for(i = 1; i <= lenpms - 1; i++){
+ res[lenpms] = res[lenpms] + res[i];
+ }
+
+ freeintvec(index);
+
+}
+/***************************************************************/
+void getinttable(int *vp, int *vd, int **res)
+/*--------------------------------------------------
+* calcule une table a partir de deux facteurs ie des deux vecteurs dont les termes vont de 1 � n
+* les niveaux de vp seront mis en lignes (haplotypes)
+* les niveaux de vd seront mis en colonnes (samples)
+--------------------------------------------------*/
+{
+
+ /* attention pour generaliser la fonction, il faudra surement modifier �a
+ * pour que les niveaux soient dans le m�me ordre qu'au d�but*/
+
+ int i, j, k, lig, nivvp, nivvd;
+
+ lig = vp[0];
+ nivvp = maxvecint(vp);
+ nivvd = maxvecint(vd);
+
+ for(i = 1; i <= nivvp; i++){
+ for(j = 1; j <= nivvd; j++){
+ res[i][j] = 0;
+ for(k = 1; k <= lig; k++){
+ if(vp[k] == i && vd[k] == j){
+ res[i][j] = res[i][j] + 1;
+ }
+ }
+ }
+ }
+
+}
+
+/***************************************************************/
+void unduplicint(int *vecp, int *res)
+/*--------------------------------------------------
+*
+--------------------------------------------------*/
+{
+
+ int i, j, k, lenvecp, compteur;
+ lenvecp = vecp[0];
+
+ k = 1;
+ res[1] = vecp[1];
+ for(i = 2; i <= lenvecp; i++){
+ compteur = 0;
+ for(j = 1; j <= k; j++){
+ if(vecp[i] != res[j]){
+ compteur = compteur + 1;
+ }
+ }
+ if(compteur == k){
+ res[k + 1] = vecp[i];
+ k = k + 1;
+ }
+ }
+ res[0] = k;
+
+}
+
+/***************************************************************/
+void vpintunduplicvdint(int *vecp, int *vecd, int *res)
+/*--------------------------------------------------
+* on prend les termes de vecp tels que vecd ne soit pas dupliqu�
+* cela correspond � vecp[!duplicated(vecd)]
+--------------------------------------------------*/
+{
+
+ int i, j, k, lenvecp, compteur, *resinterm;
+
+ lenvecp = vecp[0];
+ vecintalloc (&resinterm, lenvecp);
+
+ k = 1;
+ resinterm[1] = vecd[1];
+ res[1] = vecp[1];
+ for(i = 1; i <= lenvecp; i++){
+ compteur = 0;
+ for(j = 1; j <= k; j++){
+ if(vecd[i] != resinterm[j]){
+ compteur = compteur + 1;
+ }
+ if(compteur == k){
+ resinterm[k + 1] = vecd[i];
+ res[k + 1] = vecp[i];
+ k = k + 1;
+ }
+ }
+ }
+
+ res[0] = k;
+
+ freeintvec(resinterm);
+
+}
+
+/***************************************************************/
+void changeintlevels(int *vecp, int *res)
+/*--------------------------------------------------
+* on va num�roter les levels de vecp de 1 � n
+--------------------------------------------------*/
+{
+
+ int i, j, k, l, lenvecp, lenundup, *unduplicvecp;
+
+ vecintalloc (&unduplicvecp, vecp[0]);
+
+ lenvecp = vecp[0];
+ unduplicint(vecp, unduplicvecp);
+ lenundup = unduplicvecp[0];
+
+ for(i = 1; i <= lenvecp; i++){
+ for(j = 1; j <= lenundup; j++){
+ k = vecp[i];
+ l = unduplicvecp[j];
+ if(k == l){
+ res[i] = j;
+
+ }
+ }
+ }
+
+ freeintvec(unduplicvecp);
+
+}
+
+/***************************************************************/
+void getneworder(int *vecp, int *res)
+/*--------------------------------------------------
+* donne les ordres pour un facteur ie avec des num�ros de 1 � n
+--------------------------------------------------*/
+{
+
+ int i, k, lenvecp;
+ lenvecp = vecp[0];
+
+ for(i = 1; i <= lenvecp; i++){
+ k = vecp[i];
+ res[k] = i;
+ }
+
+}
+
+/***************************************************************/
+void vecintpermut (int *A, int *num, int *B)
+{
+/*---------------------------------------
+* A est un vecteur n elements
+* B est une vecteur n elements
+* num est une permutation al�atoire des n premiers entiers
+* B contient en sortie les elements de A permut�es
+* ---------------------------------------*/
+
+ int lig, lig1, lig2, i, k;
+
+ lig = A[0];
+ lig1 = B[0];
+ lig2 = num[0];
+
+
+ if ( (lig!=lig1) || (lig!=lig2) ) {
+ /*err_message ("Illegal parameters (vecpermut)");
+ closelisting();*/
+ }
+
+ for (i=1; i<=lig; i++) {
+ k=num[i];
+ B[i] = A[k];
+ }
+}
diff --git a/src/divsub.h b/src/divsub.h
new file mode 100644
index 0000000..bcf5a9f
--- /dev/null
+++ b/src/divsub.h
@@ -0,0 +1,23 @@
+#include <math.h>
+#include <time.h>
+#include <string.h>
+#include <stdlib.h>
+#include "adesub.h"
+
+void popweighting(int **b, int *som, double *res);
+void popsum(int **b, int *res);
+void newsamples(int **b, int *vstru, int **res);
+void alphadiv(double **a, int **b, int *som, double *res);
+void sums(double **a, int **b, int **c, int *som, double *sst, int *prindicstr, double *res);
+int maxvecint (int *vec);
+void means(double *psse, double *pdf, double *res);
+void nvalues(int **b, int **c, int *som, double *pdf, int *prindicstr, double *res);
+void repintvec(int *vecp, int *vecd, int *res);
+void repdvecint(int *vecp, int nbd, int *res);
+void sigmas(double *pms, double *pn, double *res);
+void getinttable(int *vp, int *vd, int **res);
+void unduplicint(int *vecp, int *res);
+void vpintunduplicvdint(int *vecp, int *vecd, int *res);
+void changeintlevels(int *vecp, int *res);
+void getneworder(int *vecp, int *res);
+void vecintpermut (int *A, int *num, int *B);
diff --git a/src/fourthcorner.c b/src/fourthcorner.c
new file mode 100755
index 0000000..21da8bf
--- /dev/null
+++ b/src/fourthcorner.c
@@ -0,0 +1,2171 @@
+#include <math.h>
+#include <time.h>
+#include <string.h>
+#include <stdlib.h>
+#include <R.h>
+#include "adesub.h"
+
+/*=============================================================*/
+double calculcorr (double **L, double *varx, double *vary);
+void vecstandar (double *tab, double *poili, double n);
+void calculkhi2 (double **obs, double *res);
+double calculkhi2surn (double **obs);
+double calculF (double **XL, double **XQual, double *XQuant, double *D);
+double calculcorratio (double **XL, double **XQual, double *XQuant);
+void quatriemecoin (double *tabR, double *tabL, double *tabQ,
+ int *ncolR, int *nvarR, int *nlL, int *ncL,
+ int *ncolQ, int *nvarQ,int *nrepet,
+ int *modeltype,
+ double *tabD, double *tabD2,
+ double *tabG,
+ int *RtypR,int *RtypQ, int *RassignR, int *RassignQ);
+void quatriemecoin2 (double *tabR, double *tabL,
+ double *tabQ , int *ncolR, int *nvarR, int *nlL,
+ int *ncL, int *ncolQ, int *nvarQ,int *nrepet, int *modeltype,
+ double *tabG, double *trRLQ,
+ int *RtypR,int *RtypQ, int *RassignR, int *RassignQ);
+void quatriemecoinRLQ (double *tabR, double *tabL, double *tabQ,
+ int *ncolR, int *nvarR, int *nlL, int *ncL,
+ int *ncolQ, int *nvarQ,
+ int *nrepet, int *modeltype,
+ double *tabD, double *tabD2, double *tabG,
+ int *nrowD, int *ncolD, int *nrowG, int *ncolG,
+ int *RtypR, int *RtypQ, int *RassignR, int *RassignQ,
+ double *c1, double *l1, int *typeTest, int *naxes, int *typAnalRr, int *typAnalQr,
+ double *pcRr, double *pcQr);
+
+/*=============================================================*/
+
+void quatriemecoin (double *tabR, double *tabL, double *tabQ,
+ int *ncolR, int *nvarR, int *nlL, int *ncL,
+ int *ncolQ, int *nvarQ,int *nrepet,
+ int *modeltype,
+ double *tabD, double *tabD2,
+ double *tabG,
+ int *RtypR,int *RtypQ, int *RassignR, int *RassignQ)
+
+{
+ /* Calcul quatrieme coin */
+ /* couplage quantitative/quantitative OU qualitative/quantitative OU qualitative/qualitative */
+
+ /* resutlats dans tabD statistique pour chaque cellule (homogeneite ds le cas quanti/quali)*/
+ /* resutlats dans tabD2 statistique pour chaque cellule (r ds le cas quanti/quali)*/
+ /* tabG resutlats globaux (Chi2 pour quali/quali) observes */
+ /* typR et typQ vecteur avec le type de chaque variable (1=quant, 2=qual) longueur nvarR et nvarQ */
+ /* assignR et assignQ vecteur avec le numero de variable pour chaque colonne de R et Q longueur ncolR et ncolQ */
+
+ /* le tableau est transpose par rapport a l'article original mais
+ on garde la typologie des modeles par rapport a espece/site et non ligne colonne
+ Par exemple,
+ model 1 permute dans les espece independament (lignes dans l'article original), donc dans chaque colonne ici... */
+
+ /* Declarations de variables C locales */
+ double **XR,**XL,**XQ,**XD,**LtR, **XG, **XD2;
+ double **XLpermute, **contingxy;
+ double *varx, *vary, **tabx,**taby,resF=0, *reschi2G, *indica;
+ int i,j,k,l,lL,cL,cQ,cR,vR,vQ, *nvR, *nvQ, *assignR, *assignQ, *typR, *typQ,dimx=0,dimy=0,npermut;
+
+ /* Allocation memoire pour les variables C locales */
+ cR = *ncolR;
+ cQ = *ncolQ;
+ vR = *nvarR;
+ vQ = *nvarQ;
+ cL = *ncL;
+ lL = *nlL;
+
+ taballoc (&XR, lL, cR);
+ taballoc (&XL, lL, cL);
+ taballoc (&XLpermute, lL, cL);
+ taballoc (&XQ, cL, cQ);
+
+ taballoc (&XD, *nrepet + 1, cQ * cR);
+ taballoc (&XG, *nrepet + 1, vQ * vR);
+ taballoc (&XD2, *nrepet + 1, cQ * cR);
+
+ vecintalloc (&nvR, vR);
+ vecintalloc (&nvQ, vQ);
+ vecintalloc (&typR, vR);
+ vecintalloc (&typQ, vQ);
+ vecintalloc (&assignR, cR);
+ vecintalloc (&assignQ, cQ);
+
+ /* Passage des objets R en C */
+ k = 0;
+ for (i=1; i<=lL; i++) {
+ for (j=1; j<=cL; j++) {
+ XL[i][j] = tabL[k];
+ k = k + 1;
+ }
+ }
+
+ k = 0;
+ for (i=1; i<=lL; i++) {
+ for (j=1; j<=cR; j++) {
+ XR[i][j] = tabR[k];
+ k = k + 1;
+ }
+ }
+
+ k = 0;
+ for (i=1; i<=cL; i++) {
+ for (j=1; j<=cQ; j++) {
+ XQ[i][j] = tabQ[k];
+ k = k + 1;
+ }
+ }
+
+ for (i=1; i<=cR; i++) { assignR[i]=RassignR[i-1]; }
+ for (i=1; i<=cQ; i++) { assignQ[i]=RassignQ[i-1]; }
+ for (i=1; i<=vR; i++) { typR[i]=RtypR[i-1]; }
+ for (i=1; i<=vQ; i++) { typQ[i]=RtypQ[i-1]; }
+
+
+ /* Numero de colonne auquel commence une variable */
+
+ nvR[1]=1;
+ nvQ[1]=1;
+ for (i=2;i<=cR;i++) {
+ if (assignR[i]!=assignR[i-1]){nvR[assignR[i]]=i;}
+ }
+
+ for (i=2;i<=cQ;i++) {
+ if (assignQ[i]!=assignQ[i-1]){nvQ[assignQ[i]]=i;}
+ }
+
+ /*-----------------------------------*/
+ /* ---- calculs valeurs observes ----*/
+ /*-----------------------------------*/
+
+ for (i=1;i<=vQ;i++){
+ for (j=1;j<=vR;j++){
+
+ /* quantitatif et quantitatif */
+ /*-----------------------------*/
+ if ((typQ[i]==1)&(typR[j]==1)) {
+ vecalloc (&varx, lL); /*variable de R*/
+ for (k=1;k<=lL;k++){
+ varx[k]=XR[k][(nvR[j])]; /*on remplit vary avec la variable j de R*/
+ }
+ vecalloc (&vary, cL); /*variable de Q*/
+ for (l=1;l<=cL;l++){
+ vary[l]=XQ[l][(nvQ[i])]; /*on remplit vary avec la variable i de Q*/
+ }
+
+ XG[1][(i - 1) * vR + j]=calculcorr(XL,varx,vary);
+ XD[1][(nvQ[i] - 1) * cR + (nvR[j])]= XG[1][(i - 1) * vR + j];
+ XD2[1][(nvQ[i] - 1) * cR + (nvR[j])]= XG[1][(i - 1) * vR + j];
+ freevec(varx);
+ freevec(vary);
+ }
+
+ /* qualitatif et qualitatif */
+ /*---------------------------*/
+ if ((typQ[i]==2)&(typR[j]==2)) {
+ if (j==vR) {dimx=cR-nvR[j]+1;}
+ else {dimx=nvR[j+1]-nvR[j];}
+ if (i==vQ) {dimy=cQ-nvQ[i]+1;}
+ else {dimy=nvQ[i+1]-nvQ[i];}
+
+ taballoc (&tabx, lL,dimx); /*variable de R*/
+ for (k=1;k<=dimx;k++){
+ for (l=1;l<=lL;l++){
+ tabx[l][k]=XR[l][(nvR[j])+k-1]; /*on remplit tabx avec la variable j de R*/
+
+ }
+ }
+ taballoc (&taby, cL,dimy); /*variable de Q*/
+ for (k=1;k<=dimy;k++){
+ for (l=1;l<=cL;l++){
+ taby[l][k]=XQ[l][(nvQ[i])+k-1]; /*on remplit taby avec la variable i de Q*/
+
+ }
+ }
+
+ /* Construction du tableau de contingence */
+ /* produit D=QtLtR */
+ taballoc(&contingxy,dimy,dimx);
+ taballoc (&LtR, cL, dimx );
+ prodmatAtBC(XL,tabx,LtR);
+ prodmatAtBC(taby,LtR,contingxy);
+
+ vecalloc(&reschi2G,2);
+ calculkhi2(contingxy,reschi2G); /*calcul du G*/
+ XG[1][(i - 1) * vR + j]= reschi2G[1];
+ /* XG2[i][j]= reschi2G[2]; */
+ for (k=1;k<=dimx;k++){
+ for (l=1;l<=dimy;l++){
+ /*on remplit D et D2 avec les valeurs observes*/
+ XD[1][(nvQ[i] + l-1 - 1) * cR + (nvR[j] + k-1)]=contingxy[l][k];
+ XD2[1][(nvQ[i] + l-1 - 1) * cR + (nvR[j] + k-1)]=contingxy[l][k];
+ }
+ }
+
+ freetab(tabx);
+ freetab(taby);
+ freetab(contingxy);
+ freetab(LtR);
+ freevec(reschi2G);
+ }
+
+ /* Q quantitatif et R qualitatif */
+ /*--------------------------------*/
+ if ((typQ[i]==1)&(typR[j]==2)) {
+ if (j==vR) {dimx=cR-nvR[j]+1;}
+ else {dimx=nvR[j+1]-nvR[j];}
+
+ taballoc (&tabx, lL,dimx); /*variable de R*/
+ for (k=1;k<=dimx;k++){
+ for (l=1;l<=lL;l++){
+ tabx[l][k]=XR[l][(nvR[j])+k-1]; /*on remplit tabx avec la variable j qualitative de R*/
+
+ }
+ }
+ vecalloc (&vary, cL);
+ for (l=1;l<=cL;l++){
+ vary[l]=XQ[l][(nvQ[i])]; /*on remplit vary avec la variable i de Q*/
+ }
+
+ taballoc (&LtR, cL, lL ); /* on transpose L*/
+ for (l=1;l<=lL;l++){
+ for (k=1;k<=cL;k++){
+ LtR[k][l]=XL[l][k];
+
+ }
+ }
+
+ /* Calcul de D et du pseudo F */
+ vecalloc (&varx, dimx); /*va contenir les valeurs d. une par modalite*/
+ resF=calculF(LtR, tabx, vary, varx);
+
+ XG[1][(i - 1) * vR + j]= resF;
+ for (k=1;k<=dimx;k++){
+ XD[1][(nvQ[i] -1) * cR + nvR[j] + k-1]=varx[k]; /*on remplit D avec les valeurs observes*/
+ }
+
+ vecalloc(&indica,lL);
+ for (k=1;k<=dimx;k++){
+ for (l=1;l<=lL;l++){
+ indica[l]=tabx[l][k];
+ }
+ /*on remplit D2 avec les valeurs observes*/
+ XD2[1][(nvQ[i] - 1) * cR + nvR[j] + k-1]=calculcorr(XL,indica,vary);
+
+ }
+
+
+ freevec(indica);
+ freetab(tabx);
+ freevec(vary);
+ freevec(varx);
+ freetab(LtR);
+ }
+ /* R quantitatif et Q qualitatif */
+ /*--------------------------------*/
+ if ((typQ[i]==2)&(typR[j]==1)) {
+ if (i==vQ) {dimy=cQ-nvQ[i]+1;}
+ else {dimy=nvQ[i+1]-nvQ[i];}
+
+ taballoc (&taby, cL,dimy); /*variable de Q*/
+ for (k=1;k<=dimy;k++){
+ for (l=1;l<=cL;l++){
+ taby[l][k]=XQ[l][(nvQ[i])+k-1]; /*on remplit taby avec la variable i qualitative de Q*/
+
+ }
+ }
+ vecalloc (&varx, lL);
+ for (l=1;l<=lL;l++){
+ varx[l]=XR[l][(nvR[j])]; /*on remplit vary avec la variable j de R*/
+ }
+
+
+ /* Calcul de D et du pseudo F */
+ vecalloc (&vary, dimy); /*va contenir les valeurs d. une par modalite*/
+ resF=calculF(XL, taby, varx, vary);
+
+ XG[1][(i - 1) * vR + j]= resF;
+ for (k=1;k<=dimy;k++){
+ XD[1][(nvQ[i] + k-1 -1) * cR + nvR[j]]=vary[k]; /*on remplit D avec les valeurs observes*/
+
+ }
+
+ vecalloc(&indica,cL);
+ for (k=1;k<=dimy;k++){
+ for (l=1;l<=cL;l++){
+ indica[l]=taby[l][k];
+ }
+ XD2[1][(nvQ[i] +k-1 -1) *cR + nvR[j]]=calculcorr(XL,varx,indica); /*on remplit D avec les valeurs observes*/
+
+ }
+
+ freevec(indica);
+ freetab(taby);
+ freevec(vary);
+ freevec(varx);
+ }
+
+
+
+
+
+ } /* fin boucle sur les colonnes*/
+
+ } /* fin boucle sur les lignes*/
+
+
+
+ /*----------------------------------------*/
+ /*----------------------------------------*/
+ /* ---- DEBUT PERMUTATIONS ----*/
+ /*----------------------------------------*/
+ /*----------------------------------------*/
+
+
+ for (npermut=1; npermut<=*nrepet;npermut++) /* Boucle permutation*/
+ {
+
+ /* modele de permutation 1*/
+ if(*modeltype==1)
+ {
+ permutmodel1(XL,XLpermute,&lL,&cL);
+ }
+
+ /* modele de permutation 2*/
+ if(*modeltype==2)
+ {
+ permutmodel2(XL,XLpermute,&lL,&cL);
+ }
+
+ /* modele de permutation 3*/
+ if(*modeltype==3)
+ {
+ permutmodel3(XL,XLpermute,&lL,&cL);
+ }
+
+ /* modele de permutation 4*/
+ if(*modeltype==4)
+ {
+ permutmodel4(XL,XLpermute,&lL,&cL);
+ }
+
+ /* modele de permutation 5*/
+ if(*modeltype==5)
+ {
+ permutmodel5(XL,XLpermute,&lL,&cL);
+ }
+
+ /* Calcul des statistiques pour la permutation k*/
+
+ /*----------------------------------------*/
+ /* ---- calculs des valeurs permutees ----*/
+ /*----------------------------------------*/
+
+ for (i=1;i<=vQ;i++){
+ for (j=1;j<=vR;j++){
+
+ /* quantitatif et quantitatif */
+ /*-----------------------------*/
+ if ((typQ[i]==1)&(typR[j]==1)) {
+ vecalloc (&varx, lL); /*variable de R*/
+ for (k=1;k<=lL;k++){
+ varx[k]=XR[k][(nvR[j])]; /*on remplit vary avec la variable j de R*/
+ }
+ vecalloc (&vary, cL); /*variable de Q*/
+ for (l=1;l<=cL;l++){
+ vary[l]=XQ[l][(nvQ[i])]; /*on remplit vary avec la variable i de Q*/
+ }
+
+ XG[npermut + 1][(i - 1) * vR + j]=calculcorr(XLpermute,varx,vary);
+ XD[npermut + 1][(nvQ[i] - 1) * cR + (nvR[j])]= XG[npermut + 1][(i - 1) * vR + j];
+ XD2[npermut + 1][(nvQ[i] - 1) * cR + (nvR[j])]= XG[npermut + 1][(i - 1) * vR + j];
+ freevec(varx);
+ freevec(vary);
+
+ }
+
+ /* qualitatif et qualitatif */
+ /*---------------------------*/
+ if ((typQ[i]==2)&(typR[j]==2)) {
+ if (j==vR) {dimx=cR-nvR[j]+1;}
+ else {dimx=nvR[j+1]-nvR[j];}
+ if (i==vQ) {dimy=cQ-nvQ[i]+1;}
+ else {dimy=nvQ[i+1]-nvQ[i];}
+
+ taballoc (&tabx, lL,dimx); /*variable de R*/
+ for (k=1;k<=dimx;k++){
+ for (l=1;l<=lL;l++){
+ tabx[l][k]=XR[l][(nvR[j])+k-1]; /*on remplit tabx avec la variable j de R*/
+
+ }
+ }
+ taballoc (&taby, cL,dimy); /*variable de Q*/
+ for (k=1;k<=dimy;k++){
+ for (l=1;l<=cL;l++){
+ taby[l][k]=XQ[l][(nvQ[i])+k-1]; /*on remplit taby avec la variable i de Q*/
+
+ }
+ }
+
+ /* Construction du tableau de contingence */
+ /* produit D=QtLtR */
+ taballoc(&contingxy,dimy,dimx);
+ taballoc (&LtR, cL, dimx );
+ prodmatAtBC(XLpermute,tabx,LtR);
+ prodmatAtBC(taby,LtR,contingxy);
+ vecalloc(&reschi2G,2);
+
+ calculkhi2(contingxy,reschi2G); /*calcul du G*/
+ XG[npermut + 1][(i - 1) * vR + j]=reschi2G[1];
+ /* XG2sim[i][j]=reschi2G[2]; */
+ for (k=1;k<=dimx;k++){
+ for (l=1;l<=dimy;l++){
+ /*on remplit D avec les valeurs observes*/
+ XD[npermut + 1][(nvQ[i] + l-1 - 1) * cR + (nvR[j] + k-1)]=contingxy[l][k];
+ XD2[npermut + 1][(nvQ[i] + l-1 - 1) * cR + (nvR[j] + k-1)]=contingxy[l][k];
+
+ }
+ }
+ freevec(reschi2G);
+ freetab(tabx);
+ freetab(taby);
+ freetab(contingxy);
+ freetab(LtR);
+ }
+
+ /* Q quantitatif et R qualitatif */
+ /*--------------------------------*/
+ if ((typQ[i]==1)&(typR[j]==2)) {
+ if (j==vR) {dimx=cR-nvR[j]+1;}
+ else {dimx=nvR[j+1]-nvR[j];}
+
+ taballoc (&tabx, lL,dimx); /*variable de R*/
+ for (k=1;k<=dimx;k++){
+ for (l=1;l<=lL;l++){
+ tabx[l][k]=XR[l][(nvR[j])+k-1]; /*on remplit tabx avec la variable j qualitative de R*/
+
+ }
+ }
+ vecalloc (&vary, cL);
+ for (l=1;l<=cL;l++){
+ vary[l]=XQ[l][(nvQ[i])]; /*on remplit vary avec la variable i de Q*/
+ }
+
+ taballoc (&LtR, cL, lL ); /* on transpose L*/
+ for (l=1;l<=lL;l++){
+ for (k=1;k<=cL;k++){
+ LtR[k][l]=XLpermute[l][k];
+
+ }
+ }
+
+ /* Calcul de D et du pseudo F */
+ vecalloc (&varx, dimx); /*va contenir les valeurs d. une par modalite*/
+ resF=calculF(LtR, tabx, vary, varx);
+
+ XG[npermut + 1][(i - 1) * vR + j]= resF;
+ for (k=1;k<=dimx;k++){
+ XD[npermut + 1][(nvQ[i] -1) * cR + nvR[j] + k-1]=varx[k]; /*on remplit D avec les valeurs observes*/
+ }
+ vecalloc(&indica,lL);
+ for (k=1;k<=dimx;k++){
+ for (l=1;l<=lL;l++){
+ indica[l]=tabx[l][k];
+ }
+ /*on remplit D avec les valeurs observes*/
+ XD2[npermut + 1][(nvQ[i] - 1) * cR + nvR[j] + k-1]=calculcorr(XLpermute,indica,vary);
+ }
+
+
+ freevec(indica);
+ freetab(tabx);
+ freevec(vary);
+ freevec(varx);
+ freetab(LtR);
+ }
+ /* Q qualitatif et R quantitatif */
+ /*--------------------------------*/
+ if ((typQ[i]==2)&(typR[j]==1)) {
+ if (i==vQ) {dimy=cQ-nvQ[i]+1;}
+ else {dimy=nvQ[i+1]-nvQ[i];}
+
+ taballoc (&taby, cL,dimy); /*variable de Q*/
+ for (k=1;k<=dimy;k++){
+ for (l=1;l<=cL;l++){
+ taby[l][k]=XQ[l][(nvQ[i])+k-1]; /*on remplit taby avec la variable i qualitative de Q*/
+
+ }
+ }
+ vecalloc (&varx, lL);
+ for (l=1;l<=lL;l++){
+ varx[l]=XR[l][(nvR[j])]; /*on remplit varx avec la variable j de R*/
+ }
+
+
+ /* Calcul de D et du pseudo F */
+ vecalloc (&vary, dimy); /*va contenir les valeurs d. une par modalite*/
+ resF=calculF(XLpermute, taby, varx, vary);
+
+ XG[npermut + 1][(i - 1) * vR + j]= resF;
+ for (k=1;k<=dimy;k++){
+ /*on remplit D avec les valeurs observes*/
+ XD[npermut + 1][(nvQ[i] + k-1 -1) * cR + nvR[j]]=vary[k];
+
+ }
+ vecalloc(&indica,cL);
+ for (k=1;k<=dimy;k++){
+ for (l=1;l<=cL;l++){
+ indica[l]=taby[l][k];
+ }
+ /*on remplit D avec les valeurs observes*/
+ XD2[npermut + 1][(nvQ[i] +k-1 -1) *cR + nvR[j]]=calculcorr(XLpermute,varx,indica);
+ }
+
+
+ freevec(indica);
+ freetab(taby);
+ freevec(vary);
+ freevec(varx);
+ }
+
+
+
+
+
+
+
+
+ } /* fin boucle sur les colonnes*/
+
+ } /* fin boucle sur les lignes*/
+
+ } /* fin boucle permutation . npermut incremente*/
+
+
+
+
+ /* On renvoie les valeurs dans R*/
+
+ k = 0;
+ for (npermut = 1; npermut <= (*nrepet) + 1; npermut++)
+ {
+ for (j=1; j<= cQ * cR; j++)
+ {
+ tabD[k]= XD[npermut][j]; /* D observe */
+ tabD2[k]= XD2[npermut][j]; /* D observe */
+ k = k + 1;
+ }
+ }
+
+ k = 0;
+ for (npermut = 1; npermut <= (*nrepet) + 1; npermut++)
+ {
+ for (j=1; j<= vQ * vR ; j++)
+ {
+ tabG[k]= XG[npermut][j]; /* G observe */
+ k = k + 1;
+ }
+ }
+
+
+
+
+
+
+
+ freetab(XR);
+ freetab(XL);
+ freetab(XQ);
+ freetab(XLpermute);
+
+ freetab(XD);
+ freetab(XG);
+ freetab(XD2);
+
+ freeintvec (nvR);
+ freeintvec (nvQ);
+ freeintvec (typR);
+ freeintvec (typQ);
+ freeintvec (assignR);
+ freeintvec (assignQ);
+
+}
+
+
+/*=============================================================*/
+/*==================================================================*/
+
+void quatriemecoin2 (double *tabR, double *tabL,
+ double *tabQ , int *ncolR, int *nvarR, int *nlL,
+ int *ncL, int *ncolQ, int *nvarQ,int *nrepet, int *modeltype,
+ double *tabG, double *trRLQ,
+ int *RtypR,int *RtypQ, int *RassignR, int *RassignQ)
+
+{
+ /* Calcul quatrieme coin de type rlq (r2, rapport de correlation ou chi2/n */
+ /* couplage quantitative/quantitative OU qualitative/quantitative OU qualitative/qualitative */
+
+
+ /* tabG resutlats globaux (Chi2/n pour quali/quali) observes */
+
+ /* typR et typQ vecteur avec le type de chaque variable (1=quant, 2=qual) longueur nvarR et nvarQ */
+ /* assignR et assignQ vecteur avec le numero de variable pour chaque colonne de R et Q longueur ncolR et ncolQ */
+
+ /* le tableau est transpose par rapport a l'article original mais
+ on garde la typologie des modeles par rapport a espece/site et non ligne colonne
+ Par exemple,
+ model 1 permute dans les espece independament (lignes dans l'article original), donc dans chaque colonne ici... */
+
+ /* Declarations de variables C locales */
+ double **XR,**XL,**XQ,**LtR, **XG;
+ double **XLpermute,**contingxy;
+ double *varx, *vary, **tabx,**taby;
+ int i,j,k,l,lL,cL,cQ,cR,vR,vQ, *nvR, *nvQ, *assignR, *assignQ, *typR, *typQ,dimx=0,dimy=0,npermut;
+
+
+ /* Allocation memoire pour les variables C locales */
+ cR = *ncolR;
+ cQ = *ncolQ;
+ vR = *nvarR;
+ vQ = *nvarQ;
+ cL = *ncL;
+ lL = *nlL;
+
+ taballoc (&XR, lL, cR);
+ taballoc (&XL, lL, cL);
+ taballoc (&XLpermute, lL, cL);
+ taballoc (&XQ, cL, cQ);
+ taballoc (&XG, *nrepet + 1, vQ * vR);
+
+ vecintalloc (&nvR, vR);
+ vecintalloc (&nvQ, vQ);
+ vecintalloc (&typR, vR);
+ vecintalloc (&typQ, vQ);
+ vecintalloc (&assignR, cR);
+ vecintalloc (&assignQ, cQ);
+
+ /* Passage des objets R en C */
+ k = 0;
+ for (i=1; i<=lL; i++) {
+ for (j=1; j<=cL; j++) {
+ XL[i][j] = tabL[k];
+ k = k + 1;
+ }
+ }
+
+ k = 0;
+ for (i=1; i<=lL; i++) {
+ for (j=1; j<=cR; j++) {
+ XR[i][j] = tabR[k];
+ k = k + 1;
+ }
+ }
+
+ k = 0;
+ for (i=1; i<=cL; i++) {
+ for (j=1; j<=cQ; j++) {
+ XQ[i][j] = tabQ[k];
+ k = k + 1;
+ }
+ }
+
+ for (i=1; i<=cR; i++) { assignR[i]=RassignR[i-1]; }
+ for (i=1; i<=cQ; i++) { assignQ[i]=RassignQ[i-1]; }
+ for (i=1; i<=vR; i++) { typR[i]=RtypR[i-1]; }
+ for (i=1; i<=vQ; i++) { typQ[i]=RtypQ[i-1]; }
+
+
+ /* Numero de colonne auquel commence une variable */
+
+ nvR[1]=1;
+ nvQ[1]=1;
+ for (i=2;i<=cR;i++) {
+ if (assignR[i]!=assignR[i-1]){nvR[assignR[i]]=i;}
+ }
+
+ for (i=2;i<=cQ;i++) {
+ if (assignQ[i]!=assignQ[i-1]){nvQ[assignQ[i]]=i;}
+ }
+
+ /*-----------------------------------*/
+ /* ---- calculs valeurs observes ----*/
+ /*-----------------------------------*/
+
+ for (i=1;i<=vQ;i++){
+ for (j=1;j<=vR;j++){
+
+ /* quantitatif et quantitatif */
+ /*-----------------------------*/
+ if ((typQ[i]==1)&(typR[j]==1)) {
+ vecalloc (&varx, lL); /*variable de R*/
+ for (k=1;k<=lL;k++){
+ varx[k]=XR[k][(nvR[j])]; /*on remplit vary avec la variable j de R*/
+ }
+ vecalloc (&vary, cL); /*variable de Q*/
+ for (l=1;l<=cL;l++){
+ vary[l]=XQ[l][(nvQ[i])]; /*on remplit vary avec la variable i de Q*/
+ }
+
+ XG[1][(i - 1) * vR + j]=pow(calculcorr(XL,varx,vary),2);
+ freevec(varx);
+ freevec(vary);
+ }
+
+ /* qualitatif et qualitatif */
+ /*---------------------------*/
+ if ((typQ[i]==2)&(typR[j]==2)) {
+ if (j==vR) {dimx=cR-nvR[j]+1;}
+ else {dimx=nvR[j+1]-nvR[j];}
+ if (i==vQ) {dimy=cQ-nvQ[i]+1;}
+ else {dimy=nvQ[i+1]-nvQ[i];}
+
+ taballoc (&tabx, lL,dimx); /*variable de R*/
+ for (k=1;k<=dimx;k++){
+ for (l=1;l<=lL;l++){
+ tabx[l][k]=XR[l][(nvR[j])+k-1]; /*on remplit tabx avec la variable j de R*/
+
+ }
+ }
+ taballoc (&taby, cL,dimy); /*variable de Q*/
+ for (k=1;k<=dimy;k++){
+ for (l=1;l<=cL;l++){
+ taby[l][k]=XQ[l][(nvQ[i])+k-1]; /*on remplit taby avec la variable i de Q*/
+
+ }
+ }
+
+ /* Construction du tableau de contingence */
+ /* produit D=QtLtR */
+ taballoc(&contingxy,dimy,dimx);
+ taballoc (&LtR, cL, dimx );
+ prodmatAtBC(XL,tabx,LtR);
+ prodmatAtBC(taby,LtR,contingxy);
+
+ XG[1][(i - 1) * vR + j]= calculkhi2surn(contingxy);
+
+ freetab(tabx);
+ freetab(taby);
+ freetab(contingxy);
+ freetab(LtR);
+ }
+
+ /* Q quantitatif et R qualitatif */
+ /*--------------------------------*/
+ if ((typQ[i]==1)&(typR[j]==2)) {
+ if (j==vR) {dimx=cR-nvR[j]+1;}
+ else {dimx=nvR[j+1]-nvR[j];}
+
+ taballoc (&tabx, lL,dimx); /*variable de R*/
+ for (k=1;k<=dimx;k++){
+ for (l=1;l<=lL;l++){
+ tabx[l][k]=XR[l][(nvR[j])+k-1]; /*on remplit tabx avec la variable j qualitative de R*/
+
+ }
+ }
+ vecalloc (&vary, cL);
+ for (l=1;l<=cL;l++){
+ vary[l]=XQ[l][(nvQ[i])]; /*on remplit vary avec la variable i de Q*/
+ }
+
+ taballoc (&LtR, cL, lL ); /* on transpose L*/
+ for (l=1;l<=lL;l++){
+ for (k=1;k<=cL;k++){
+ LtR[k][l]=XL[l][k];
+
+ }
+ }
+
+ /* Calcul du rapport de correlation*/
+ XG[1][(i - 1) * vR + j]= calculcorratio(LtR, tabx, vary);
+
+ freetab(tabx);
+ freevec(vary);
+ freetab(LtR);
+ }
+ /* R quantitatif et Q qualitatif */
+ /*--------------------------------*/
+ if ((typQ[i]==2)&(typR[j]==1)) {
+ if (i==vQ) {dimy=cQ-nvQ[i]+1;}
+ else {dimy=nvQ[i+1]-nvQ[i];}
+
+ taballoc (&taby, cL,dimy); /*variable de Q*/
+ for (k=1;k<=dimy;k++){
+ for (l=1;l<=cL;l++){
+ taby[l][k]=XQ[l][(nvQ[i])+k-1]; /*on remplit taby avec la variable i qualitative de Q*/
+
+ }
+ }
+ vecalloc (&varx, lL);
+ for (l=1;l<=lL;l++){
+ varx[l]=XR[l][(nvR[j])]; /*on remplit vary avec la variable j de R*/
+ }
+
+
+ /* Calcul du rapport de correlation */
+
+ XG[1][(i - 1) * vR + j]= calculcorratio(XL, taby, varx);
+
+ freetab(taby);
+ freevec(varx);
+ }
+
+
+
+ trRLQ[0]=trRLQ[0] + XG[1][(i - 1) * vR + j];
+
+ } /* fin boucle sur les colonnes*/
+
+ } /* fin boucle sur les lignes*/
+
+
+
+
+ /*----------------------------------------*/
+ /*----------------------------------------*/
+ /* ---- DEBUT PERMUTATIONS ----*/
+ /*----------------------------------------*/
+ /*----------------------------------------*/
+
+
+ for (npermut=1; npermut<=*nrepet;npermut++) /* Boucle permutation*/
+ {
+ /* modele de permutation 1*/
+ if(*modeltype==1)
+ {
+ permutmodel1(XL,XLpermute,&lL,&cL);
+ }
+
+ /* modele de permutation 2*/
+ if(*modeltype==2)
+ {
+ permutmodel2(XL,XLpermute,&lL,&cL);
+ }
+
+ /* modele de permutation 3*/
+ if(*modeltype==3)
+ {
+ permutmodel3(XL,XLpermute,&lL,&cL);
+ }
+
+ /* modele de permutation 4*/
+ if(*modeltype==4)
+ {
+ permutmodel4(XL,XLpermute,&lL,&cL);
+ }
+
+ /* modele de permutation 5*/
+ if(*modeltype==5)
+ {
+ permutmodel5(XL,XLpermute,&lL,&cL);
+ }
+
+ /* Calcul des statistiques pour la permutation k*/
+
+ /*----------------------------------------*/
+ /* ---- calculs des valeurs permutees ----*/
+ /*----------------------------------------*/
+
+ for (i=1;i<=vQ;i++){
+ for (j=1;j<=vR;j++){
+
+ /* quantitatif et quantitatif */
+ /*-----------------------------*/
+ if ((typQ[i]==1)&(typR[j]==1)) {
+ vecalloc (&varx, lL); /*variable de R*/
+ for (k=1;k<=lL;k++){
+ varx[k]=XR[k][(nvR[j])]; /*on remplit vary avec la variable j de R*/
+ }
+ vecalloc (&vary, cL); /*variable de Q*/
+ for (l=1;l<=cL;l++){
+ vary[l]=XQ[l][(nvQ[i])]; /*on remplit vary avec la variable i de Q*/
+ }
+
+ XG[npermut + 1][(i - 1) * vR + j]=pow(calculcorr(XLpermute,varx,vary),2);
+
+ freevec(varx);
+ freevec(vary);
+
+ }
+
+ /* qualitatif et qualitatif */
+ /*---------------------------*/
+ if ((typQ[i]==2)&(typR[j]==2)) {
+ if (j==vR) {dimx=cR-nvR[j]+1;}
+ else {dimx=nvR[j+1]-nvR[j];}
+ if (i==vQ) {dimy=cQ-nvQ[i]+1;}
+ else {dimy=nvQ[i+1]-nvQ[i];}
+
+ taballoc (&tabx, lL,dimx); /*variable de R*/
+ for (k=1;k<=dimx;k++){
+ for (l=1;l<=lL;l++){
+ tabx[l][k]=XR[l][(nvR[j])+k-1]; /*on remplit tabx avec la variable j de R*/
+
+ }
+ }
+ taballoc (&taby, cL,dimy); /*variable de Q*/
+ for (k=1;k<=dimy;k++){
+ for (l=1;l<=cL;l++){
+ taby[l][k]=XQ[l][(nvQ[i])+k-1]; /*on remplit taby avec la variable i de Q*/
+
+ }
+ }
+
+ /* Construction du tableau de contingence */
+ /* produit D=QtLtR */
+ taballoc(&contingxy,dimy,dimx);
+ taballoc (&LtR, cL, dimx );
+ prodmatAtBC(XLpermute,tabx,LtR);
+ prodmatAtBC(taby,LtR,contingxy);
+
+ XG[npermut + 1][(i - 1) * vR + j]=calculkhi2surn(contingxy); /*calcul du chi/n*/
+
+
+ freetab(tabx);
+ freetab(taby);
+ freetab(contingxy);
+ freetab(LtR);
+ }
+
+ /* Q quantitatif et R qualitatif */
+ /*--------------------------------*/
+ if ((typQ[i]==1)&(typR[j]==2)) {
+ if (j==vR) {dimx=cR-nvR[j]+1;}
+ else {dimx=nvR[j+1]-nvR[j];}
+
+ taballoc (&tabx, lL,dimx); /*variable de R*/
+ for (k=1;k<=dimx;k++){
+ for (l=1;l<=lL;l++){
+ tabx[l][k]=XR[l][(nvR[j])+k-1]; /*on remplit tabx avec la variable j qualitative de R*/
+
+ }
+ }
+ vecalloc (&vary, cL);
+ for (l=1;l<=cL;l++){
+ vary[l]=XQ[l][(nvQ[i])]; /*on remplit vary avec la variable i de Q*/
+ }
+
+ taballoc (&LtR, cL, lL ); /* on transpose L*/
+ for (l=1;l<=lL;l++){
+ for (k=1;k<=cL;k++){
+ LtR[k][l]=XLpermute[l][k];
+
+ }
+ }
+
+ /* Calcul de D et du pseudo F */
+
+ XG[npermut + 1][(i - 1) * vR + j]= calculcorratio(LtR, tabx, vary);
+
+ freetab(tabx);
+ freevec(vary);
+
+ freetab(LtR);
+ }
+ /* Q qualitatif et R quantitatif */
+ /*--------------------------------*/
+ if ((typQ[i]==2)&(typR[j]==1)) {
+ if (i==vQ) {dimy=cQ-nvQ[i]+1;}
+ else {dimy=nvQ[i+1]-nvQ[i];}
+
+ taballoc (&taby, cL,dimy); /*variable de Q*/
+ for (k=1;k<=dimy;k++){
+ for (l=1;l<=cL;l++){
+ taby[l][k]=XQ[l][(nvQ[i])+k-1]; /*on remplit taby avec la variable i qualitative de Q*/
+
+ }
+ }
+ vecalloc (&varx, lL);
+ for (l=1;l<=lL;l++){
+ varx[l]=XR[l][(nvR[j])]; /*on remplit varx avec la variable j de R*/
+ }
+
+
+ /* Calcul de D et du pseudo F */
+ XG[npermut + 1][(i - 1) * vR + j]= calculcorratio(XLpermute, taby, varx);
+
+
+ freetab(taby);
+ freevec(varx);
+ }
+
+
+
+ trRLQ[npermut] = trRLQ[npermut] + XG[npermut + 1][(i - 1) * vR + j];
+
+
+ } /* fin boucle sur les colonnes*/
+
+ } /* fin boucle sur les lignes*/
+ } /* fin boucle permutation . npermut incremente*/
+
+
+ /* On renvoie les valeurs dans R*/
+
+ k = 0;
+ for (npermut = 1; npermut <= (*nrepet) + 1; npermut++)
+ {
+ for (j=1; j<= vQ * vR ; j++)
+ {
+ tabG[k]= XG[npermut][j]; /* G observe */
+ k = k + 1;
+ }
+ }
+
+ freetab(XR);
+ freetab(XL);
+ freetab(XQ);
+ freetab(XLpermute);
+ freetab(XG);
+
+ freeintvec (nvR);
+ freeintvec (nvQ);
+ freeintvec (typR);
+ freeintvec (typQ);
+ freeintvec (assignR);
+ freeintvec (assignQ);
+
+
+}
+/*=============================================================*/
+void quatriemecoinRLQ (double *tabR, double *tabL, double *tabQ,
+ int *ncolR, int *nvarR, int *nlL, int *ncL,
+ int *ncolQ, int *nvarQ,
+ int *nrepet, int *modeltype,
+ double *tabD, double *tabD2, double *tabG,
+ int *nrowD, int *ncolD, int *nrowG, int *ncolG,
+ int *RtypR, int *RtypQ, int *RassignR, int *RassignQ,
+ double *c1, double *l1, int *typeTest, int *naxes, int *typAnalRr, int *typAnalQr,
+ double *pcRr, double *pcQr)
+
+{
+
+ /* Calcul quatrieme coin sur analyse RLQ*/
+ /* couplage quantitative/quantitative OU qualitative/quantitative */
+
+ /* resultats dans tabD statistique pour chaque cellule (homogeneite ds le cas quanti/quali)*/
+ /* resultats dans tabD2 statistique pour chaque cellule (r ds le cas quanti/quali)*/
+ /* tabG resutlats globaux observes */
+ /* typR et typQ vecteur avec le type de chaque variable (1=quant, 2=qual) longueur nvarR et nvarQ */
+ /* assignR et assignQ vecteur avec le numero de variable pour chaque colonne de R et Q longueur ncolR et ncolQ */
+
+ /* le tableau est transpose par rapport a l'article original mais
+ on garde la typologie des modeles par rapport a espece/site et non ligne colonne
+ Par exemple,
+ model 1 permute dans les espece independament (lignes dans l'article original), donc dans chaque colonne ici... */
+
+ /* Declarations de variables C locales */
+ double **XR,**XL,**XQ,**XD, **XD2, **XG, **LtR;
+ double **XLpermute;
+ double *varx, *vary, **tabx,**taby,resF=0, *indica;
+ int i,j,k,l,lL,cL,cQ,cR,vR,vQ, *nvR, *nvQ, *assignR, *assignQ, *typR, *typQ,dimx=0,dimy=0,npermut;
+ int typAnalR, typAnalQ;
+ double **tabc1, **tabl1, **axesR, **axesQ, *pcR, *pcQ, **initR, **initQ, Ntot=0.0, *pcL, *plL;
+
+
+ /* Allocation memoire pour les variables C locales */
+
+ cR = *ncolR;
+ cQ = *ncolQ;
+ vR = *nvarR;
+ vQ = *nvarQ;
+ cL = *ncL;
+ lL = *nlL;
+
+ typAnalR = *typAnalRr;
+ typAnalQ = *typAnalQr;
+
+ vecalloc (&pcR, cR);
+ vecalloc (&pcQ, cQ);
+ vecalloc (&pcL, cL);
+ vecalloc (&plL, lL);
+
+ if ((*typeTest==1) || (*typeTest==2)) {
+ /*axes or R.axes
+ R. axes measures the link between table R and axes (axesQ)*/
+ taballoc (&tabc1, cQ, *naxes);
+ taballoc (&axesQ, cL, *naxes);
+ }
+
+ if ((*typeTest==1) || (*typeTest==3)) {
+ /*axes or Q.axes*/
+ taballoc (&tabl1, cR, *naxes);
+ taballoc (&axesR, lL, *naxes);
+
+ }
+
+
+ taballoc (&initR, lL, cR);
+ taballoc (&initQ, cL, cQ);
+
+ taballoc (&XR, lL, cR);
+ taballoc (&XL, lL, cL);
+ taballoc (&XLpermute, lL, cL);
+ taballoc (&XQ, cL, cQ);
+
+
+ taballoc (&XD, *nrepet + 1, (*nrowD) * (*ncolD));
+ taballoc (&XG, *nrepet + 1, (*nrowG) * (*ncolG));
+ taballoc (&XD2, *nrepet + 1, (*nrowD) * (*ncolD));
+
+
+ vecintalloc (&nvR, vR);
+ vecintalloc (&nvQ, vQ);
+ vecintalloc (&typR, vR);
+ vecintalloc (&typQ, vQ);
+ vecintalloc (&assignR, cR);
+ vecintalloc (&assignQ, cQ);
+
+ /* Passage des objets R en C */
+ k = 0;
+ for (i=1; i<=lL; i++) {
+ for (j=1; j<=cL; j++) {
+ XL[i][j] = tabL[k];
+ Ntot = Ntot + tabL[k];
+ k = k + 1;
+ }
+ }
+
+ k = 0;
+ for (i=1; i<=lL; i++) {
+ for (j=1; j<=cR; j++) {
+ XR[i][j] = tabR[k];
+ initR[i][j] = tabR[k];
+ k = k + 1;
+ }
+ }
+
+ k = 0;
+ for (i=1; i<=cL; i++) {
+ for (j=1; j<=cQ; j++) {
+ XQ[i][j] = tabQ[k];
+ initQ[i][j] = tabQ[k];
+ k = k + 1;
+ }
+ }
+
+
+
+ if ((*typeTest==1) || (*typeTest==2)) {
+ /*axes or R.axes*/
+ k = 0;
+ for (i=1; i<=cQ; i++) {
+ for (j=1; j<= *naxes; j++) {
+ tabc1[i][j] = c1[k];
+ k = k + 1;
+ }
+ }
+
+ }
+
+ if ((*typeTest==1) || (*typeTest==3)) {
+ /*axes or Q.axes*/
+ k = 0;
+ for (i=1; i<=cR; i++) {
+ for (j=1; j<= *naxes; j++) {
+ tabl1[i][j] = l1[k];
+ k = k + 1;
+ }
+ }
+
+ }
+
+
+ /* Compute row and column weights*/
+
+ for (i=1; i<=lL; i++) {
+ for (j=1; j<=cL; j++) {
+ pcL[j]=pcL[j] + XL[i][j] / Ntot;
+ plL[i]=plL[i] + XL[i][j] / Ntot;
+
+ }
+ }
+
+
+
+ for (i=1; i<=cR; i++) { assignR[i]=RassignR[i-1]; }
+ for (i=1; i<=cQ; i++) { assignQ[i]=RassignQ[i-1]; }
+ for (i=1; i<=vR; i++) { typR[i]=RtypR[i-1]; }
+ for (i=1; i<=vQ; i++) { typQ[i]=RtypQ[i-1]; }
+
+ for (i=1; i<=cR; i++) {
+ pcR[i] = pcRr[i-1];
+ }
+ for (i=1; i<=cQ; i++) {
+ pcQ[i] = pcQr[i-1];
+ }
+
+ /* Numero de colonne auquel commence une variable */
+
+ nvR[1]=1;
+ nvQ[1]=1;
+ for (i=2;i<=cR;i++) {
+ if (assignR[i]!=assignR[i-1]){nvR[assignR[i]]=i;}
+ }
+
+ for (i=2;i<=cQ;i++) {
+ if (assignQ[i]!=assignQ[i-1]){nvQ[assignQ[i]]=i;}
+ }
+
+ /*-----------------------------------*/
+ /* ---- calculs valeurs observes ----*/
+ /*-----------------------------------*/
+
+ if ((*typeTest==1) || (*typeTest==2)) {
+ /*axes or R.axes
+ compute lQ= Q * Dq * c1 (axesQ linear combination of traits) */
+ if (typAnalQ == 8) {
+ matcentragehi(XQ,pcL,typQ,assignQ);
+ }
+ else {
+ matcentrage (XQ, pcL, typAnalQ);
+ }
+
+ prodmatAdBC(XQ,pcQ, tabc1,axesQ);
+
+ }
+
+ if ((*typeTest==1) || (*typeTest==3)) {
+ /*axes or Q.axes*/
+ if (typAnalR == 8) {
+ matcentragehi(XR,plL,typR,assignR);
+ }
+ else {matcentrage (XR, plL, typAnalR);
+ }
+
+ prodmatAdBC(XR,pcR, tabl1,axesR);
+
+ }
+
+ if (*typeTest==1){
+ vecalloc (&vary, cL); /* Q axes*/
+ vecalloc (&varx, lL); /* R axes*/
+ /* axes and axes */
+ for (i=1;i<= *naxes;i++){
+ for (j=1;j<= *naxes;j++){
+
+ for (k=1;k<=lL;k++){
+ varx[k]=axesR[k][j]; /* fill 'varx' the j-th linear combination of R variables*/
+ }
+ for (l=1;l<=cL;l++){
+ vary[l]=axesQ[l][i]; /*fill 'vary' the i-th linear combination of Q variables */
+ }
+ XG[1][(i-1) * (*ncolG) +j]=calculcorr(XL,varx,vary);
+ XD[1][(i-1) * (*ncolD) +j]=XG[1][(i-1) * (*ncolG) +j];
+ XD2[1][(i-1) * (*ncolD) +j]=XG[1][(i-1) * (*ncolG) +j];
+ }
+ }
+ freevec(varx);
+ freevec(vary);
+ }
+
+ if (*typeTest==2){
+ /* R.axes*/
+ vecalloc (&vary, cL); /* Q axis */
+ for (i=1;i<= *naxes;i++){
+ for (l=1;l<=cL;l++){
+ vary[l]=axesQ[l][i]; /* fill 'vary' the i-th linear combination of Q variables */
+ }
+
+ for (j=1;j<= vR;j++){
+ /* R quantitative */
+ if (typR[j]==1) {
+ vecalloc (&varx, lL);
+ for (k=1;k<=lL;k++){
+ varx[k]=XR[k][(nvR[j])]; /* remplit varx avec la variable de R*/
+ }
+ XG[1][(i-1) * (*ncolG) + j]=calculcorr(XL,varx,vary);
+ XD[1][(i-1) * (*ncolD) + (nvR[j])]=XG[1][(i-1) * (*ncolG) +j];
+ XD2[1][(i-1) * (*ncolD) + (nvR[j])]=XG[1][(i-1) * (*ncolG) +j];
+ freevec(varx);
+ }
+
+ /* R qualitative */
+ if (typR[j]==2) {
+ if (j==vR) {dimx=cR-nvR[j]+1;}
+ else {dimx=nvR[j+1]-nvR[j];}
+
+ taballoc (&tabx, lL,dimx); /*variable de R*/
+ for (k=1;k<=dimx;k++){
+ for (l=1;l<=lL;l++){
+ tabx[l][k]=XR[l][(nvR[j])+k-1]; /*on remplit tabx avec la variable j qualitative de R*/
+
+ }
+ }
+
+ taballoc (&LtR, cL, lL ); /* on transpose L*/
+ for (l=1;l<=lL;l++){
+ for (k=1;k<=cL;k++){
+ LtR[k][l]=XL[l][k];
+
+ }
+ }
+
+ /* Calcul de D et du pseudo F */
+ vecalloc (&varx, dimx); /*va contenir les valeurs d. une par modalite*/
+
+ resF=calculF(LtR, tabx, vary, varx);
+
+ XG[1][(i-1) * (*ncolG) +j]= resF;
+ for (k=1;k<=dimx;k++){
+ XD[1][(i-1) * (*ncolD) + (nvR[j]) + k-1]=varx[k]; /*on remplit D avec les valeurs observes*/
+ }
+
+ vecalloc(&indica,lL);
+ for (k=1;k<=dimx;k++){
+ for (l=1;l<=lL;l++){
+ indica[l]=tabx[l][k];
+ }
+ XD2[1][(i-1) * (*ncolD) + (nvR[j]) + k-1]=calculcorr(XL,indica,vary); /*on remplit D avec les valeurs observes*/
+
+ }
+
+
+ freevec(indica);
+ freetab(tabx);
+ freevec(varx);
+
+ freetab(LtR);
+
+ }
+ }
+ }
+ freevec(vary);
+ }
+
+ if (*typeTest==3){
+ /* Q.axes*/
+ for (j=1;j<= *naxes;j++){
+ vecalloc (&varx, lL); /*R axis*/
+ for (l=1;l<=lL;l++){
+ varx[l]=axesR[l][j]; /* fill 'varx' the j-th linear combination of R variables */
+ }
+
+ for (i=1;i<= vQ;i++){
+ /* Q quantitative */
+ if (typQ[i]==1) {
+ vecalloc (&vary, cL);
+ for (k=1;k<=cL;k++){
+ vary[k]=XQ[k][(nvQ[i])]; /* remplit vary avec la variable de Q*/
+ }
+ XG[1][(i-1) * (*ncolG) + j]=calculcorr(XL,varx,vary);
+ XD[1][(nvQ[i]-1) * (*ncolD) + j]=XG[1][(i-1) * (*ncolG) + j];
+ XD2[1][(nvQ[i]-1) * (*ncolD) + j]=XG[1][(i-1) * (*ncolG) + j];
+ freevec(vary);
+ }
+
+ /* Q qualitative */
+ if (typQ[i]==2) {
+ if (i==vQ) {dimy=cQ-nvQ[i]+1;}
+ else {dimy=nvQ[i+1]-nvQ[i];}
+
+ taballoc (&taby, cL,dimy); /*variable de Q*/
+ for (k=1;k<=dimy;k++){
+ for (l=1;l<=cL;l++){
+ taby[l][k]=XQ[l][(nvQ[i])+k-1]; /*on remplit taby avec la variable i qualitative de Q*/
+
+ }
+ }
+
+
+ /* Calcul de D et du pseudo F */
+ vecalloc (&vary, dimy); /*va contenir les valeurs d. une par modalite*/
+
+ resF=calculF(XL, taby, varx, vary);
+
+
+ XG[1][(i-1) * (*ncolG) + j]= resF;
+ for (k=1;k<=dimy;k++){
+ XD[1][(nvQ[i]-1+ k-1) * (*ncolD) + j ]=vary[k]; /*on remplit D avec les valeurs observes*/
+ }
+
+ vecalloc(&indica,cL);
+ for (k=1;k<=dimy;k++){
+ for (l=1;l<=cL;l++){
+ indica[l]=taby[l][k];
+ }
+ XD2[1][(nvQ[i]-1+ k-1) * (*ncolD) + j ]=calculcorr(XL,varx,indica); /*on remplit D avec les valeurs observes*/
+
+ }
+
+
+ freevec(indica);
+ freetab(taby);
+ freevec(vary);
+
+
+ }
+ }
+ }
+ freevec(varx);
+ }
+
+
+
+ /*----------------------------------------*/
+ /*----------------------------------------*/
+ /* ---- DEBUT PERMUTATIONS ----*/
+ /*----------------------------------------*/
+ /*----------------------------------------*/
+
+
+ for (npermut=1; npermut<=*nrepet;npermut++) /* Boucle permutation*/
+ {
+
+
+ /* modele de permutation 2*/
+ if(*modeltype==2)
+ {
+ permutmodel2(XL,XLpermute,&lL,&cL);
+ }
+
+
+ /* modele de permutation 4*/
+ if(*modeltype==4)
+ {
+ permutmodel4(XL,XLpermute,&lL,&cL);
+ }
+
+ /* modele de permutation 5*/
+ if(*modeltype==5)
+ {
+ permutmodel5(XL,XLpermute,&lL,&cL);
+ }
+
+ /* Calcul des statistiques pour la permutation k*/
+
+ /*----------------------------------------*/
+ /* ---- calculs des valeurs permutees ----*/
+ /*----------------------------------------*/
+
+ /* Get the original tables */
+ for (i=1; i<=cL; i++) {
+ for (j=1; j<=cQ; j++) {
+ XQ[i][j] = initQ[i][j];
+ }
+ }
+
+ for (i=1; i<=lL; i++) {
+ for (j=1; j<=cR; j++) {
+ XR[i][j] = initR[i][j];
+ }
+ }
+
+ /* Re-compute row and column weights*/
+ for (i=1; i<=lL; i++) {plL[i]=0;}
+ for (j=1; j<=cL; j++) {pcL[j]=0;}
+
+
+ for (i=1; i<=lL; i++) {
+ for (j=1; j<=cL; j++) {
+ pcL[j]=pcL[j] + XLpermute[i][j] / Ntot;
+ plL[i]=plL[i] + XLpermute[i][j] / Ntot;
+
+ }
+ }
+
+
+ if ((*typeTest==1) || (*typeTest==2)) {
+ /*axes or R.axes */
+
+ if((*modeltype==4) || (*modeltype==5)) {
+ /* modeltype=4 permute Q (i.e. column of L) */
+ if (typAnalQ == 8) {
+ /* on recalcule le poids colonne pour les qualitatives*/
+ for(j=1;j<=cQ;j++){
+ if(typQ[assignQ[j]]==2){
+ pcQ[j]=0;
+ }
+ }
+ for(i=1;i<=cL;i++){
+ for(j=1;j<=cQ;j++){
+ if(typQ[assignQ[j]]==2){
+ pcQ[j]=pcQ[j]+XQ[i][j]*pcL[i];
+ }
+ }
+ }
+
+ matcentragehi(XQ,pcL,typQ,assignQ);
+
+ }
+ else {
+ /* on recalcule le poids colonne pour les qualitatives pour une acm*/
+ if (typAnalQ == 2) {
+ for(j=1;j<=cQ;j++){
+ pcQ[j]=0;
+ }
+ for(i=1;i<=cL;i++){
+ for(j=1;j<=cQ;j++){
+ pcQ[j]=pcQ[j]+XQ[i][j]*pcL[i];
+ }
+ }
+ for(j=1;j<=cQ;j++){
+ pcQ[j]=pcQ[j]/(cQ);
+ }
+ }
+
+
+ matcentrage (XQ, pcL, typAnalQ);
+
+
+ }
+ }
+
+ prodmatAdBC(XQ,pcQ, tabc1,axesQ);
+
+ }
+
+ if ((*typeTest==1) || (*typeTest==3)) {
+ /*axes or Q.axes*/
+ /* compute new weights and recenter columns of R and Q */
+ if((*modeltype==2) || (*modeltype==5)) {
+ /* modeltype=2 permute R (i.e. row of L) */
+ if (typAnalR == 8) {
+ for(j=1;j<=cR;j++){
+ if(typR[assignR[j]]==2){
+ pcR[j]=0;
+ }
+ }
+ for(i=1;i<=lL;i++){
+ for(j=1;j<=cR;j++){
+ if(typR[assignR[j]]==2){
+ pcR[j]=pcR[j]+XR[i][j]*plL[i];
+ }
+ }
+ }
+ matcentragehi(XR,plL,typR,assignR);
+ /* on recalcule le poids colonne pour les qualitatives */
+ }
+ else {
+ /* on recalcule le poids colonne pour les qualitatives pour une acm*/
+ if (typAnalR == 2) {
+ for(j=1;j<=cR;j++){
+ pcR[j]=0;
+ }
+ for(i=1;i<=lL;i++){
+ for(j=1;j<=cR;j++){
+ pcR[j]=pcR[j]+XR[i][j]*plL[i];
+ }
+ }
+ for(j=1;j<=cR;j++){
+ pcR[j]=pcR[j]/(cR);
+ }
+
+
+ }
+
+ matcentrage (XR, plL, typAnalR);
+
+
+ }
+ }
+
+ prodmatAdBC(XR,pcR, tabl1,axesR);
+
+ }
+
+ if (*typeTest==1){
+ vecalloc (&vary, cL); /* Q axes*/
+ vecalloc (&varx, lL); /* R axes*/
+ /* axes and axes */
+ for (i=1;i<= *naxes;i++){
+ for (j=1;j<= *naxes;j++){
+
+ for (k=1;k<=lL;k++){
+ varx[k]=axesR[k][j]; /* fill 'varx' the j-th linear combination of R variables*/
+ }
+ for (l=1;l<=cL;l++){
+ vary[l]=axesQ[l][i]; /*fill 'vary' the i-th linear combination of Q variables */
+ }
+ XG[npermut+1][(i-1) * (*ncolG) +j]=calculcorr(XLpermute,varx,vary);
+ XD[npermut+1][(i-1) * (*ncolD) +j]=XG[npermut+1][(i-1) * (*ncolG) +j];
+ XD2[npermut+1][(i-1) * (*ncolD) +j]=XG[npermut+1][(i-1) * (*ncolG) +j];
+
+
+ }
+ }
+ freevec(varx);
+ freevec(vary);
+ }
+
+ if (*typeTest==2){
+ /* R.axes*/
+ vecalloc (&vary, cL); /* Q axis */
+ for (i=1;i<= *naxes;i++){
+ for (l=1;l<=cL;l++){
+ vary[l]=axesQ[l][i]; /* fill 'vary' the i-th linear combination of Q variables */
+ }
+
+ for (j=1;j<= vR;j++){
+ /* R quantitative */
+ if (typR[j]==1) {
+ vecalloc (&varx, lL);
+ for (k=1;k<=lL;k++){
+ varx[k]=XR[k][(nvR[j])]; /* remplit varx avec la variable de R*/
+ }
+ XG[npermut+1][(i-1) * (*ncolG) + j]=calculcorr(XLpermute,varx,vary);
+ XD[npermut+1][(i-1) * (*ncolD) + (nvR[j])]=XG[npermut+1][(i-1) * (*ncolG) +j];
+ XD2[npermut+1][(i-1) * (*ncolD) + (nvR[j])]=XG[npermut+1][(i-1) * (*ncolG) +j];
+ freevec(varx);
+ }
+
+ /* R qualitative */
+ if (typR[j]==2) {
+ if (j==vR) {dimx=cR-nvR[j]+1;}
+ else {dimx=nvR[j+1]-nvR[j];}
+
+ taballoc (&tabx, lL,dimx); /*variable de R*/
+ for (k=1;k<=dimx;k++){
+ for (l=1;l<=lL;l++){
+ tabx[l][k]=XR[l][(nvR[j])+k-1]; /*on remplit tabx avec la variable j qualitative de R*/
+
+ }
+ }
+
+ taballoc (&LtR, cL, lL ); /* on transpose L*/
+ for (l=1;l<=lL;l++){
+ for (k=1;k<=cL;k++){
+ LtR[k][l]=XLpermute[l][k];
+
+ }
+ }
+
+ /* Calcul de D et du pseudo F */
+ vecalloc (&varx, dimx); /*va contenir les valeurs d. une par modalite*/
+
+ resF=calculF(LtR, tabx, vary, varx);
+
+ XG[npermut+1][(i-1) * (*ncolG) +j]=resF;
+ for (k=1;k<=dimx;k++){
+ XD[npermut+1][(i-1) * (*ncolD) + (nvR[j]) + k-1]=varx[k];
+ }
+
+ vecalloc(&indica,lL);
+ for (k=1;k<=dimx;k++){
+ for (l=1;l<=lL;l++){
+ indica[l]=tabx[l][k];
+ }
+ XD2[npermut+1][(i-1) * (*ncolD) + (nvR[j]) + k-1]=calculcorr(XLpermute,indica,vary);
+
+ }
+
+
+ freevec(indica);
+ freetab(tabx);
+ freevec(varx);
+
+ freetab(LtR);
+
+ }
+ }
+ }
+ freevec(vary);
+ }
+
+ if (*typeTest==3){
+ /* Q.axes*/
+ for (j=1;j<= *naxes;j++){
+ vecalloc (&varx, lL); /*R axis*/
+ for (l=1;l<=lL;l++){
+ varx[l]=axesR[l][j]; /* fill 'varx' the j-th linear combination of R variables */
+ }
+
+ for (i=1;i<= vQ;i++){
+ /* Q quantitative */
+ if (typQ[i]==1) {
+ vecalloc (&vary, cL);
+ for (k=1;k<=cL;k++){
+ vary[k]=XQ[k][(nvQ[i])]; /* remplit vary avec la variable de Q*/
+ }
+ XG[npermut+1][(i-1) * (*ncolG) + j]=calculcorr(XLpermute,varx,vary);
+ XD[npermut+1][(nvQ[i]-1) * (*ncolD) + j]=XG[npermut+1][(i-1) * (*ncolG) + j];
+ XD2[npermut+1][(nvQ[i]-1) * (*ncolD) + j]=XG[npermut+1][(i-1) * (*ncolG) + j];
+ freevec(vary);
+ }
+
+ /* Q qualitative */
+ if (typQ[i]==2) {
+ if (i==vQ) {dimy=cQ-nvQ[i]+1;}
+ else {dimy=nvQ[i+1]-nvQ[i];}
+
+ taballoc (&taby, cL,dimy); /*variable de Q*/
+ for (k=1;k<=dimy;k++){
+ for (l=1;l<=cL;l++){
+ taby[l][k]=XQ[l][(nvQ[i])+k-1]; /*on remplit taby avec la variable i qualitative de Q*/
+
+ }
+ }
+
+
+ /* Calcul de D et du pseudo F */
+ vecalloc (&vary, dimy); /*va contenir les valeurs d. une par modalite*/
+
+ resF=calculF(XLpermute, taby, varx, vary);
+
+ XG[npermut+1][(i-1) * (*ncolG) + j]= resF;
+ for (k=1;k<=dimy;k++){
+ XD[npermut+1][(nvQ[i]-1+ k-1) * (*ncolD) + j ]=vary[k];
+ }
+
+ vecalloc(&indica,cL);
+ for (k=1;k<=dimy;k++){
+ for (l=1;l<=cL;l++){
+ indica[l]=taby[l][k];
+ }
+ XD2[npermut+1][(nvQ[i]-1+ k-1) * (*ncolD) + j ]=calculcorr(XLpermute,varx,indica);
+
+ }
+
+
+ freevec(indica);
+ freetab(taby);
+ freevec(vary);
+
+
+ }
+ }
+ }
+ freevec(varx);
+ }
+
+
+
+
+ } /* fin boucle permutation . npermut incremente*/
+
+ /* On renvoie les valeurs dans R*/
+
+ k = 0;
+ for (npermut = 1; npermut <= (*nrepet) + 1; npermut++)
+ {
+ for (j=1; j<=(*nrowD) * (*ncolD); j++)
+ {
+ tabD[k]= XD[npermut][j]; /* D observe */
+ tabD2[k]= XD2[npermut][j]; /* D observe */
+ k = k + 1;
+ }
+ }
+
+ k = 0;
+ for (npermut = 1; npermut <= (*nrepet) + 1; npermut++)
+ {
+ for (j=1; j<=(*ncolG) * (*nrowG); j++)
+ {
+ tabG[k]= XG[npermut][j]; /* G observe */
+ k = k + 1;
+ }
+ }
+
+
+ freetab(XR);
+ freetab(XL);
+ freetab(XQ);
+ freetab(XLpermute);
+
+ freetab(XD);
+ freetab(XG);
+ freetab(XD2);
+
+ freeintvec (nvR);
+ freeintvec (nvQ);
+ freeintvec (typR);
+ freeintvec (typQ);
+ freeintvec (assignR);
+ freeintvec (assignQ);
+
+
+ freevec (pcR);
+ freevec (pcQ);
+ freevec (pcL);
+ freevec (plL);
+
+ freetab(initR);
+ freetab(initQ);
+
+
+ if ((*typeTest==1) || (*typeTest==2)) {
+ /*axes or R.axes
+ R. axes measures the link between table R and axes (axesQ)*/
+ freetab(tabc1);
+ freetab(axesQ);
+ }
+
+ if ((*typeTest==1) || (*typeTest==3)) {
+ /*axes or Q.axes*/
+ freetab(tabl1);
+ freetab(axesR);
+
+ }
+
+
+}
+
+/*==================================================================*/
+/*==================== Utilities =====================*/
+/*==================================================================*/
+
+void calculkhi2 (double **obs, double *res){
+ /* calcul le chi2 et G pour une table de contingence */
+ /* les deux statistiques sont mises dans res. nl et nc sont nb de lignes et de colonnes */
+ /* res1 contient chi2 et res2 contient G */
+
+
+ double **theo,tot=0;
+ double *rowsum,*colsum,res1,res2;
+ int i,j,nl,nc;
+
+ nl=obs[0][0];
+ nc = obs[1][0];
+ taballoc (&theo, nl, nc);
+ vecalloc (&rowsum,nl);
+ vecalloc (&colsum,nc);
+
+
+
+ /* calcul des totaux*/
+ for (i=1; i<=nl; i++) {
+ for (j=1; j<=nc; j++) {
+ rowsum[i] = rowsum[i]+obs[i][j];
+ colsum[j] = colsum[j]+obs[i][j];
+ tot=tot+obs[i][j];
+ }
+ }
+ /* calcul des effectis theoriques*/
+ for (i=1; i<=nl; i++) {
+ for (j=1; j<=nc; j++) {
+ theo[i][j] = rowsum[i]*colsum[j]/tot;
+ }
+ }
+
+ /* calcul des statistiques*/
+ res1=0;
+ res2=0;
+
+ for (i=1; i<=nl; i++) {
+ for (j=1; j<=nc; j++) {
+ res1 = res1+pow(theo[i][j]-obs[i][j],2)/theo[i][j]; /* chi2*/
+ if (obs[i][j]>0)
+ res2= res2+2*obs[i][j]*log(obs[i][j]/theo[i][j]); /* G */
+ }
+ }
+
+ freevec(rowsum);
+ freevec(colsum);
+ freetab(theo);
+ res[1]=res1;
+ res[2]=res2;
+
+}
+
+
+/*==================================================================*/
+double calculkhi2surn (double **obs){
+ /* calcul le chi2 sur n pour une table de contingence */
+ /* nl et nc sont nb de lignes et de colonnes */
+
+
+ double **theo,tot=0;
+ double *rowsum,*colsum,res1;
+ int i,j,nl,nc;
+
+ nl=obs[0][0];
+ nc = obs[1][0];
+ taballoc (&theo, nl, nc);
+ vecalloc (&rowsum,nl);
+ vecalloc (&colsum,nc);
+
+
+
+ /* calcul des totaux*/
+ for (i=1; i<=nl; i++) {
+ for (j=1; j<=nc; j++) {
+ rowsum[i] = rowsum[i]+obs[i][j];
+ colsum[j] = colsum[j]+obs[i][j];
+ tot=tot+obs[i][j];
+ }
+ }
+ /* calcul des effectis theoriques*/
+ for (i=1; i<=nl; i++) {
+ for (j=1; j<=nc; j++) {
+ theo[i][j] = rowsum[i]*colsum[j]/tot;
+ }
+ }
+
+ /* calcul des statistiques*/
+ res1=0;
+
+ for (i=1; i<=nl; i++) {
+ for (j=1; j<=nc; j++) {
+ res1 = res1+pow(theo[i][j]-obs[i][j],2)/theo[i][j]; /* chi2*/
+ }
+ }
+
+ freevec(rowsum);
+ freevec(colsum);
+ freetab(theo);
+ res1=res1/tot;
+ return(res1);
+
+}
+
+
+/*==================================================================*/
+void vecstandar (double *tab, double *poili, double n)
+/*--------------------------------------------------
+ * tab est un vecteur
+ * poili est un vecteur n composantes avec somme par ligne (somme total dans n)
+ * la procedure retourne tab norme par colonne
+ * pour la ponderation poili variance en 1/n
+ --------------------------------------------------*/
+{
+ double poid, z, v2,x;
+ int i, l1;
+ double moy=0, var=0;
+
+ l1 = tab[0];
+
+
+
+
+ /*--------------------------------------------------
+ * calcul du tableau centre/norme
+ --------------------------------------------------*/
+
+ for (i=1;i<=l1;i++) {
+ poid = poili[i];
+ moy = moy + tab[i] * (poid/n);
+ }
+
+ for (i=1;i<=l1;i++) {
+ poid=poili[i];
+ x = tab[i] - moy;
+ var = var + (poid/n) * x * x;
+ }
+
+
+ v2 = var;
+ if (v2<=0) v2 = 1;
+ v2 = sqrt(v2);
+ var = v2;
+
+
+ for (i=1;i<=l1;i++) {
+ z = (tab[i] - moy)/var;
+ tab[i] = z;
+ }
+
+}
+
+/*=============================================================*/
+
+double calculcorr (double **XL, double *varx, double *vary){
+ /* calcul la correlation entre varx (n) et vary (p) avec le lien exprime par L (n,p) */
+ int i,j,l1,c1;
+ double sumL=0, *poiR, *poiQ, *Ly, res=0;
+ l1 = XL[0][0];
+ c1 = XL[1][0];
+ vecalloc (&poiR, l1);
+ vecalloc (&poiQ, c1);
+ vecalloc (&Ly, l1);
+
+ /* normalisation des deux vecteurs avec poids provenant de L*/
+
+ for (i=1; i<=l1; i++) {
+ for (j=1; j<=c1; j++) {
+ poiR[i] = poiR[i]+XL[i][j];
+ poiQ[j] = poiQ[j]+XL[i][j];
+ sumL=sumL+XL[i][j];
+ }
+ }
+
+ vecstandar(varx, poiR, sumL);
+ vecstandar(vary, poiQ, sumL);
+
+ /* calcul de D*/
+ for (i=1; i<=l1; i++) {
+ for (j=1; j<=c1; j++) {
+ Ly[i]=Ly[i]+XL[i][j]*vary[j];
+ }
+ }
+ for (i=1; i<=l1; i++) {res=res+(Ly[i]*varx[i]);}
+
+ res=res/sumL;
+ freevec(poiR);
+ freevec(poiQ);
+ freevec(Ly);
+ return(res);
+
+}
+
+
+/*=========================================================================*/
+double calculF(double **XL, double **XQual, double *XQuant, double *D){
+
+ /* Fonction qui prend une variable quantitative (n) et une
+ qualitative (p) et une table de contingence L (n p) qui calcul la
+ valeur de D et la valeur d'un pseudo F (var inter/var intra) */
+
+ /* If the permutation is not valid for the class i, D[i] = -999.
+ If the complete permutation is not valid F=-999*/
+
+
+ /* Calcul de la valeur de d et F pour ces deux variables */
+
+ double *SY,*SY2,SX=0, SX2=0,*compt,tot=0,F;
+ int lL,cL, i, j, nclass,*classvec,kk=0;
+ double ScIntra, ScTotal,temp;
+
+ lL = XL[0][0];
+ cL = XL[1][0];
+ nclass = XQual[1][0];
+ /* Allocation locale */
+
+ vecalloc (&compt,nclass);
+ vecalloc(&SY,nclass);
+ vecalloc(&SY2,nclass);
+ vecintalloc(&classvec,cL);
+
+ /* compt contient le nombre d'individus par classe et classvec le numero de classe de chaque individu*/
+ for (i=1; i<=cL; i++)
+ {
+ for (j=1; j<=nclass; j++){
+ if (XQual[i][j]==1){
+ classvec[i]=j;
+
+ }
+
+ }
+ }
+
+ /* Calcul des statistiques*/
+
+ for (i=1; i<=lL; i++) // Pour chaque ligne de XL
+ {
+ for (j=1; j<=cL; j++) // Pour chaque colone de XL
+ {
+ if(XL[i][j]>0)// Si XL' n'est pas nul
+ {
+ compt[classvec[j]]=compt[classvec[j]]+XL[i][j];/*nb d'individu par classe*/
+ tot=tot+XL[i][j]; /*nb total d'individu*/
+ SX=SX+XL[i][j]*XQuant[i]; /* somme des x */
+ SX2=SX2+XL[i][j]*XQuant[i]*XQuant[i]; /* somme des x^2 */
+ SY[classvec[j]]=SY[classvec[j]]+XL[i][j]*XQuant[i];
+ SY2[classvec[j]]=SY2[classvec[j]]+XL[i][j]*XQuant[i]*XQuant[i];
+
+ }
+ }
+ }
+
+
+ ScTotal=SX2-(SX*SX)/tot;
+ /* Calcul de ScIntra */
+ ScIntra=0; //initialisation
+
+ for (i=1;i<=nclass; i++)
+ {
+ if(compt[i]>1)
+ {
+ temp=SY2[i]-(SY[i]*SY[i])/(double)compt[i];
+ D[i]=temp/ScTotal;
+ ScIntra=ScIntra+temp;
+ kk=kk+1;
+
+ }
+ else { D[i]=-999;}
+
+ }
+
+
+ if (kk<=1)
+ {F=-999;}
+ else
+ {F=((ScTotal-ScIntra)/(double)(kk-1))/(ScIntra/(double)(tot-kk));}
+
+ freevec(SY);
+ freevec(SY2);
+ freevec(compt);
+ freeintvec(classvec);
+ return(F);
+}
+
+
+/*=========================================================================*/
+double calculcorratio(double **XL, double **XQual, double *XQuant){
+
+ /* Fonction qui prend une variable quantitative (n) et une
+ qualitative (p) et une table de contingence L (n p) qui calcul la
+ valeur du rapport de correlation (SS inter/SS total) */
+
+
+ /* Calcul de la valeur de d et F pour ces deux variables */
+
+ double *SY,*SY2,SX=0, SX2=0,*compt,tot=0,F;
+ int lL,cL, i, j, nclass,*classvec,kk=0;
+ double ScIntra, ScTotal,temp;
+
+ lL = XL[0][0];
+ cL = XL[1][0];
+ nclass = XQual[1][0];
+ /* Allocation locale */
+
+ vecalloc (&compt,nclass);
+ vecalloc(&SY,nclass);
+ vecalloc(&SY2,nclass);
+ vecintalloc(&classvec,cL);
+
+ /* compt contient le nombre d'individus par classe et classvec le numero de classe de chaque individu*/
+ for (i=1; i<=cL; i++)
+ {
+ for (j=1; j<=nclass; j++){
+ if (XQual[i][j]==1){
+ classvec[i]=j;
+
+ }
+
+ }
+ }
+
+ /* Calcul des statistiques*/
+
+ for (i=1; i<=lL; i++) // Pour chaque ligne de XL
+ {
+ for (j=1; j<=cL; j++) // Pour chaque colone de XL
+ {
+ if(XL[i][j]>0)// Si XL' n'est pas nul
+ {
+ compt[classvec[j]]=compt[classvec[j]]+XL[i][j];/*nb d'individu par classe*/
+ tot=tot+XL[i][j]; /*nb total d'individu*/
+ SX=SX+XL[i][j]*XQuant[i]; /* somme des x */
+ SX2=SX2+XL[i][j]*XQuant[i]*XQuant[i]; /* somme des x^2 */
+ SY[classvec[j]]=SY[classvec[j]]+XL[i][j]*XQuant[i];
+ SY2[classvec[j]]=SY2[classvec[j]]+XL[i][j]*XQuant[i]*XQuant[i];
+
+ }
+ }
+ }
+
+
+ ScTotal=SX2-(SX*SX)/tot;
+ /* Calcul de ScIntra */
+ ScIntra=0; //initialisation
+
+ for (i=1;i<=nclass; i++)
+ {
+ if(compt[i]>1)
+ {
+ temp=SY2[i]-(SY[i]*SY[i])/(double)compt[i];
+ ScIntra=ScIntra+temp;
+ kk=kk+1;
+ }
+
+ }
+
+
+ if (kk<=1)
+ {F=-999;}
+ else
+ {F=((ScTotal-ScIntra)/(ScTotal));}
+
+ freevec(SY);
+ freevec(SY2);
+ freevec(compt);
+ freeintvec(classvec);
+ return(F);
+}
diff --git a/src/init.c b/src/init.c
new file mode 100644
index 0000000..d8f1ca4
--- /dev/null
+++ b/src/init.c
@@ -0,0 +1,52 @@
+#include <R.h>
+#include <Rinternals.h>
+#include <stdlib.h> // for NULL
+#include <R_ext/Rdynload.h>
+
+/* .C calls */
+extern void gearymoran(void *, void *, void *, void *, void *, void *, void *);
+extern void MSTgraph(void *, void *, void *, void *);
+extern void quatriemecoin(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void quatriemecoin2(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void quatriemecoinRLQ(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void testamova(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void testdimRVpca(void *, void *, void *, void *, void *, void *, void *, void *);
+extern void testdiscrimin(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void testdistRV(void *, void *, void *, void *, void *);
+extern void testertrace(void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void testertracenu(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void testertracenubis(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void testertracerlq(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void testinter(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+extern void testmantel(void *, void *, void *, void *, void *);
+extern void testmultispati(void *, void *, void *, void *, void *, void *, void *, void *);
+extern void testprocuste(void *, void *, void *, void *, void *, void *, void *);
+extern void VarianceDecompInOrthoBasis(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
+
+static const R_CMethodDef CEntries[] = {
+ {"gearymoran", (DL_FUNC) &gearymoran, 7},
+ {"MSTgraph", (DL_FUNC) &MSTgraph, 4},
+ {"quatriemecoin", (DL_FUNC) &quatriemecoin, 18},
+ {"quatriemecoin2", (DL_FUNC) &quatriemecoin2, 17},
+ {"quatriemecoinRLQ", (DL_FUNC) &quatriemecoinRLQ, 30},
+ {"testamova", (DL_FUNC) &testamova, 15},
+ {"testdimRVpca", (DL_FUNC) &testdimRVpca, 8},
+ {"testdiscrimin", (DL_FUNC) &testdiscrimin, 10},
+ {"testdistRV", (DL_FUNC) &testdistRV, 5},
+ {"testertrace", (DL_FUNC) &testertrace, 9},
+ {"testertracenu", (DL_FUNC) &testertracenu, 14},
+ {"testertracenubis", (DL_FUNC) &testertracenubis, 15},
+ {"testertracerlq", (DL_FUNC) &testertracerlq, 22},
+ {"testinter", (DL_FUNC) &testinter, 12},
+ {"testmantel", (DL_FUNC) &testmantel, 5},
+ {"testmultispati", (DL_FUNC) &testmultispati, 8},
+ {"testprocuste", (DL_FUNC) &testprocuste, 7},
+ {"VarianceDecompInOrthoBasis", (DL_FUNC) &VarianceDecompInOrthoBasis, 12},
+ {NULL, NULL, 0}
+};
+
+void R_init_ade4(DllInfo *dll)
+{
+ R_registerRoutines(dll, CEntries, NULL, NULL, NULL);
+ R_useDynamicSymbols(dll, FALSE);
+}
diff --git a/src/phylog.c b/src/phylog.c
new file mode 100644
index 0000000..175c653
--- /dev/null
+++ b/src/phylog.c
@@ -0,0 +1,291 @@
+#include <math.h>
+#include <time.h>
+#include <string.h>
+#include <stdlib.h>
+#include "adesub.h"
+
+void gearymoran (int *param, double *data, double *bilis,
+ double *obs, double *result, double *obstot, double *restot);
+
+void VarianceDecompInOrthoBasis (int *param, double *z, double *matvp,
+ double *phylogram, double *phylo95,double *sig025, double *sig975,
+ double *test1, double *test2, double*test3, double *test4, double *test5);
+
+
+ void gearymoran (int *param, double *data, double *bilis,
+ double *obs, double *result, double *obstot, double *restot)
+{
+ /* Declarations des variables C locales */
+ int nobs, nvar, nrepet, i, j, k, krepet, kvar ;
+ int *numero;
+ double provi;
+ double *poili;
+ double **mat, **tab, **tabperm;
+
+
+ /* Allocation memoire pour les variables C locales */
+ nobs = param[0];
+ nvar = param [1];
+ nrepet = param [2];
+ vecalloc(&poili,nobs);
+ taballoc(&mat,nobs,nobs);
+ taballoc(&tab,nobs,nvar);
+ taballoc(&tabperm,nobs,nvar);
+ vecintalloc (&numero, nobs);
+
+ /* D�finitions des variables C locales */
+ k = 0;
+ for (i=1; i<=nvar; i++) {
+ for (j=1; j<=nobs; j++) {
+ tab[j][i] = data[k] ;
+ k = k+1 ;
+ }
+ }
+
+ k = 0;
+ provi = 0;
+ for (j=1; j<=nobs; j++) {
+ for (i=1; i<=nobs; i++) {
+ mat[i][j] = bilis[k] ;
+ provi = provi + bilis[k];
+ k = k+1 ;
+ }
+ }
+ for (j=1; j<=nobs; j++) {
+ for (i=1; i<=nobs; i++) {
+ mat[i][j] = mat[i][j]/provi ;
+ }
+ }
+ /* mat contient une distribution de fr�quence bivari�e */
+ for (j=1; j<=nobs; j++) {
+ provi = 0;
+ for (i=1; i<=nobs; i++) {
+ provi = provi + mat[i][j] ;
+ }
+ poili[j] = provi;
+ }
+ /* poili contient la distribution marginale
+ le test sera du type xtPx avec x centr� norm� pour la pond�ration
+ marginale et A = QtFQ soit la matrice des pij-pi.p.j */
+ matmodifcn(tab,poili);
+ /* le tableau est normalis� pour la pond�ration marginale de la forme*/
+ for (j=1; j<=nobs; j++) {
+ for (i=1; i<=nobs; i++) {
+ mat[i][j] = mat[i][j] -poili[i]*poili[j] ;
+ }
+ }
+ for (kvar=1; kvar<=nvar; kvar++) {
+ provi = 0;
+ for (j=1; j<=nobs; j++) {
+ for (i=1; i<=nobs; i++) {
+ provi = provi + tab[i][kvar]*tab[j][kvar]*mat[i][j] ;
+ }
+ }
+ obs[kvar-1] = provi;
+ }
+ k=0;
+ /* les r�sultats se suivent par simulation */
+ for (krepet=1; krepet<=nrepet; krepet++) {
+ getpermutation (numero, krepet);
+ matpermut (tab, numero, tabperm);
+ matmodifcn (tabperm,poili);
+ for (kvar=1; kvar<=nvar; kvar++) {
+ provi = 0;
+ for (j=1; j<=nobs; j++) {
+ for (i=1; i<=nobs; i++) {
+ provi = provi + tabperm[i][kvar]*tabperm[j][kvar]*mat[i][j] ;
+ }
+ }
+ result[k] = provi;
+ k = k+1;
+ }
+ }
+
+ /* lib�ration m�moire locale */
+ freevec(poili);
+ freetab(mat);
+ freeintvec(numero);
+ freetab(tab);
+ freetab(tabperm);
+}
+
+
+ void VarianceDecompInOrthoBasis (int *param, double *z, double *matvp,
+ double *phylogram, double *phylo95,double *sig025, double *sig975,
+ double *R2Max, double *SkR2k, double*Dmax, double *SCE, double *ratio)
+{
+
+ /* param contient 4 entiers : nobs le nombre de points, npro le nombre de vecteurs
+ nrepet le nombre de permutations, posinega la nombre de vecteurs de la classe posi
+ qui est nul si cette notion n'existe pas. Exemple : la base Bscores d'une phylog�nie a posinega = 0
+ mais la base Ascores a posinega � prendre dans Adim
+ z est un vecteur � nobs composantes de norme 1
+ pour la pond�ration uniforme. matvp est une matrice nobsxnpro contenant en
+ colonnes des vecteurs orthonorm�s pour la pond�ration uniforme. En g�n�
+ La proc�dure placera
+ dans phylogram les R2 de la d�composition de z dans la base matvp
+ dans phylo95 les quantiles 0.95 des R2
+ dans sig025 les quantiles 0.025 des R2 cumul�s
+ dans sig975 les quantiles 0.975 des R2 cumul�s
+
+ Ecrit � l'origine pour les phylog�nies
+ peut servir pour une base de vecteurs propres de voisinage */
+
+
+ /* Declarations des variables C locales */
+ int nobs, npro, nrepet, i, j, k, n1, n2, n3, n4;
+ int irepet, posinega, *numero, *vecrepet;
+ double **vecpro, *zperm, *znorm;
+ double *locphylogram, *modelnul;
+ double a1, provi, **simul, *copivec, *copicol;
+
+ /* Allocation memoire pour les variables C locales */
+ nobs = param[0];
+ npro = param [1];
+ nrepet = param [2];
+ posinega = param[3];
+ vecalloc (&znorm, nobs);
+ vecalloc (&zperm, nobs);
+ vecalloc (&copivec, npro);
+ vecalloc (&copicol, nrepet);
+ taballoc (&vecpro, nobs, npro);
+ taballoc (&simul, nrepet, npro);
+ vecalloc (&locphylogram, npro);
+ vecalloc (&modelnul, npro);
+ vecintalloc (&numero, nobs);
+ vecintalloc (&vecrepet, nrepet);
+
+ /* D�finitions des variables C locales */
+ for (i = 1 ; i<= nobs; i++) znorm[i] = z[i-1];
+ for (i = 1 ; i<= npro; i++) modelnul[i] = (double) i/ (double) npro;
+ k = 0;
+ for (j=1; j<=npro; j++) {
+ for (i=1; i<=nobs; i++) {
+ vecpro[i][j] = matvp[k] ;
+ k = k+1 ;
+ }
+ }
+
+ /* calcul du phylogramme observ� */
+ for (j = 1; j<= npro; j++) {
+ provi = 0;
+ for (i=1; i<=nobs; i++) provi = provi + vecpro[i][j]*znorm[i];
+ provi = provi*provi/nobs/nobs;
+ locphylogram[j] = provi;
+ }
+ for (i =1 ; i<= npro ; i++) phylogram[i-1] = locphylogram[i];
+ /* calcul des simulations
+ Chaque ligne de simul est un phylogramme apr�s permutation des donn�es */
+
+ for (irepet=1; irepet<=nrepet; irepet++) {
+ getpermutation (numero, irepet);
+ vecpermut (znorm, numero, zperm);
+ provi = 0;
+ for (j = 1; j<= npro; j++) {
+ provi = 0;
+ for (i=1; i<=nobs; i++) provi = provi + vecpro[i][j]*zperm[i];
+ provi = provi*provi/nobs/nobs;
+ simul[irepet][j] = provi;
+ }
+ }
+ /* calcul du test sur le max du phylogramme */
+ for (irepet=1; irepet<=nrepet; irepet++) {
+ for (j=1; j<=npro; j++) copivec[j] = simul[irepet][j];
+ R2Max[irepet] = maxvec(copivec);
+ provi=0;
+ for (j=1; j<=npro; j++) provi = provi + j*simul[irepet][j];
+ SkR2k[irepet] =provi;
+ if (posinega>0) {
+ provi=0;
+ for (j=1; j<posinega; j++) provi = provi + simul[irepet][j];
+ ratio[irepet] = provi;
+ }
+
+ }
+ R2Max[0] = maxvec(locphylogram);
+ provi=0;
+ for (j=1; j<=npro; j++) provi = provi + j*locphylogram[j];
+ SkR2k[0] =provi;
+ if (posinega>0) {
+ provi=0;
+ for (j=1; j<posinega; j++) provi = provi + locphylogram[j];
+ ratio[0] = provi;
+ }
+ /* quantiles 95 du sup */
+ n1 = (int) floor (nrepet*0.95);
+ n2 = (int) ceil (nrepet*0.95);
+ for (i =1; i<=npro; i++) {
+ for (irepet = 1; irepet<= nrepet; irepet++) {
+ copicol[irepet] = simul [irepet][i];
+ }
+ trirap (copicol, vecrepet);
+ phylo95[i-1] = 0.5*(copicol[n1]+copicol[n2]);
+ }
+
+
+ for (irepet=1; irepet<=nrepet; irepet++) {
+ provi = 0;
+ for (j=1; j<=npro; j++) {
+ provi = provi + simul[irepet][j];
+ copivec[j] = provi;
+ }
+ for (j=1; j<=npro; j++) simul[irepet][j] = copivec[j];
+ }
+ n1 = (int) floor (nrepet*0.025);
+ n2 = (int) ceil (nrepet*0.025);
+ n3 = (int) floor (nrepet*0.975);
+ n4 = (int) ceil (nrepet*0.975);
+ /* quantiles 2.5 du cumul */
+ for (i =1; i<=npro; i++) {
+ for (irepet = 1; irepet<= nrepet; irepet++) {
+ copicol[irepet] = simul [irepet][i];
+ }
+ trirap (copicol, vecrepet);
+ sig025[i-1] = 0.5*(copicol[n1]+copicol[n2]);
+ sig975[i-1] = 0.5*(copicol[n3]+copicol[n4]);
+ }
+
+ provi = 0;
+ for (j=1; j<=npro; j++) {
+ a1 = modelnul[j];
+ provi = provi + locphylogram[j];
+ locphylogram[j] = provi-a1;
+ for (irepet = 1; irepet<= nrepet; irepet++) {
+ simul [irepet][j] = simul [irepet][j]-a1;
+ }
+ }
+ /* simul contient maintenant les cumul�s simul�s en �carts */
+ /* locphylogram contient maintenant les cumul�s observ�s en �cart*/
+ /* Dmax */
+ for (j=1; j<=npro; j++) {
+ for (irepet=1; irepet<=nrepet; irepet++) {
+ for (j=1; j<=npro; j++) copivec[j] = simul[irepet][j];
+ Dmax[irepet] = maxvec(copivec);
+ provi=0;
+ for (j=1; j<=npro; j++) provi = provi + copivec[j]* copivec[j];
+ SCE[irepet] =provi;
+ }
+ }
+ Dmax[0] = maxvec (locphylogram);
+ provi=0;
+ for (j=1; j<=npro; j++) provi = provi +locphylogram[j]*locphylogram[j];
+ SCE[0] =provi;
+
+
+
+
+
+ /* retour */
+
+ freevec (znorm);
+ freevec (modelnul);
+ freevec(copivec);
+ freevec(copicol);
+ freevec (zperm);
+ freetab (vecpro);
+ freetab (simul);
+ freevec (locphylogram);
+ freeintvec (numero);
+ freeintvec (vecrepet);
+ }
+
diff --git a/src/testamova.c b/src/testamova.c
new file mode 100644
index 0000000..fc1f0ff
--- /dev/null
+++ b/src/testamova.c
@@ -0,0 +1,432 @@
+#include <math.h>
+#include <time.h>
+#include <string.h>
+#include <stdlib.h>
+#include "adesub.h"
+#include "divsub.h"
+
+void testamova(double *distab, int *l1, int *c1, int *samtab, int *l2, int *c2,int *strtab, int *l3, int *c3, int *indicstr, int *nbhapl, int *npermut, double *divtotal, double *df, double *result);
+void permut(double **a, int **b, int **c, int *som, int increm, double *sst, int *prindicstr, double *prdf, double *res);
+/*****************************************************************/
+
+void testamova(double *distab, int *l1, int *c1,
+ int *samtab, int *l2, int *c2,
+ int *strtab, int *l3, int *c3,
+ int *indicstr,
+ int *nbhapl,
+ int *npermut,
+ double *divtotal,
+ double *df,
+ double *result)
+{
+/* Declarations de variables C locales */
+
+ double **ditab, *vdf, *vsigma, *vtest;
+ int i, j, k, lenvtest, lenvdf, seuil, **satab, **sttab;
+
+/* Allocation memoire pour les variables C locales */
+
+ taballoc(&ditab, *l1, *c1);
+ tabintalloc(&satab, *l2, *c2);
+ tabintalloc(&sttab, *l3, *c3);
+
+
+ if(indicstr[0] != 0){
+ lenvdf = *c3 + 3;
+ lenvtest = lenvdf - 1;
+ }
+ else{
+ lenvdf = 3;
+ lenvtest = 1;
+ }
+
+ vecalloc(&vdf, lenvdf);
+ vecalloc(&vsigma, lenvdf);
+ vecalloc(&vtest, lenvtest);
+
+
+/* On recopie les objets R dans les variables C locales */
+
+ k = 0;
+ for (i = 1; i <= *l1; i++) {
+ for (j = 1; j <= *c1; j++) {
+ ditab[i][j] = distab[k];
+ k = k + 1;
+ }
+ }
+
+ k = 0;
+ for (i = 1; i <= *l2; i++) {
+ for (j = 1; j <= *c2; j++) {
+ satab[i][j] = samtab[k];
+ k = k + 1;
+ }
+ }
+
+
+ k = 0;
+ for (i = 1; i <= *l3; i++) {
+ for (j = 1; j <= *c3; j++) {
+ sttab[i][j] = strtab[k];
+ k = k + 1;
+ }
+ }
+
+ k=0;
+ for (i = 1; i <= lenvdf; i++) {
+ vdf[i] = df[k];
+ k = k + 1;
+ }
+
+
+/* Calculs */
+
+ seuil = 0;
+ k = 0;
+ for(i = 1; i <= npermut[0]; i++){
+ seuil = seuil + 1;
+ permut(ditab, satab, sttab, nbhapl, seuil, divtotal, indicstr, vdf, vtest);
+ for(j = 1; j <= lenvtest; j++){
+ result[j - 1 + k] = vtest[j];
+ }
+ k = k + lenvtest;
+ }
+
+ /* les resultats des tests vont etre renvoyes sous la forme d un vecteur.
+ * Ce vecteur sera transforme en plusieurs object MonteCarlo dans la fonction .R */
+
+ freetab(ditab);
+ freeinttab(satab);
+ freeinttab(sttab);
+ freevec(vdf);
+ freevec(vsigma);
+ freevec(vtest);
+
+}
+
+/***************************************************************/
+void permut(double **a, int **b, int **c, int *som, int increm, double *sst, int *prindicstr, double *prdf, double *res)
+/*--------------------------------------------------
+* realise les permutations
+* a est le tableau distances
+* b est le tableau samples
+* c est le tableau structure
+* som contient la somme des termes de samples
+* increm va servir dans la fonction getpermutation pour determiner des nombres aleatoires
+* sst est la diversit� totale (qui est constante)
+* prindicstr indique la presence d un "vrai" tableau structures
+* prdf contient les degres de liberte
+--------------------------------------------------*/
+{
+
+ int i, j, k, l, m, n, ligb, colb, colc, colderoule, lenprss, lenprn, lennumhapld, *xd, *newxd, **deroule, **newderoule, **newderouled, *xp , *newxp, *unduplicxp, *unduplicxdprxp, *newunduplicxdprxp, *pralea, compt, lignewderoule, nbniveaux, **csim, *dersamples, *numhaplp, *numhapld, *numhaplt, *numsamples, *ressoms, *repnumsam, *numhaplsim, **bsim, *newh, *news, *newsd, *newst, *newg, *newgd, *numgroup, *numgroud;
+ double *prss, *prms, *prn, *prsigma;
+
+ /* dersamples contient samples deroule comme dans asvector samples*/
+
+ ligb = b[0][0];
+ colb = b[1][0];
+ lennumhapld = colb * ligb;
+ colc = c[1][0];
+
+ vecintalloc(&numhaplp, ligb);
+ vecintalloc(&numhapld, lennumhapld);
+ vecintalloc(&dersamples, lennumhapld);
+ vecintalloc(&numhaplt, som[0]);
+ vecintalloc(&numhaplsim, som[0]);
+ vecintalloc(&numsamples, colb);
+ vecintalloc(&repnumsam, som[0]);
+ vecintalloc(&ressoms, colb);
+ vecintalloc(&pralea, som[0]);
+ tabintalloc(&bsim, ligb, colb);
+ tabintalloc(&csim, colb, colc);
+ vecintalloc(&numgroup, colb);
+ vecintalloc(&numgroud, som[0]);
+ vecintalloc(&xp, som[0]);
+ vecintalloc(&newxp, som[0]);
+ vecintalloc(&xd, som[0]);
+ vecintalloc(&newxd, som[0]);
+ vecintalloc(&unduplicxp, som[0]);
+ vecintalloc(&unduplicxdprxp, som[0]);
+ vecintalloc(&newunduplicxdprxp, som[0]);
+ vecintalloc(&newh, som[0]);
+ vecintalloc(&news, som[0]);
+ vecintalloc(&newsd, som[0]);
+ vecintalloc(&newst, som[0]);
+ vecintalloc(&newg, som[0]);
+ vecintalloc(&newgd, som[0]);
+
+ if(prindicstr[0] != 0){
+ colderoule = 2 + colc + 1;
+ }
+ else{
+ colderoule = 2;
+ }
+ tabintalloc(&deroule, som[0], colderoule);
+ tabintalloc(&newderoule, som[0], colderoule);
+ tabintalloc(&newderouled, som[0], colderoule);
+
+ if(prindicstr[0] != 0){
+ lenprss = colc + 3;
+ k = 0;
+ j = colc + 1;
+ for(i = 1; i <= j; i++){
+ k = k + i;
+ }
+ lenprn = k;
+ }
+ else{
+ lenprss = 3;
+ lenprn = 1;
+ }
+
+ vecalloc(&prss, lenprss);
+ vecalloc(&prms, lenprss);
+ vecalloc(&prn, lenprn);
+ vecalloc(&prsigma, lenprss);
+
+
+ for(i = 1; i <= ligb; i++){
+ numhaplp[i] = i;
+ }
+
+ repdvecint(numhaplp, colb, numhapld);
+
+ k = 0;
+ for(j = 1; j <= colb; j++){
+ for(i = 1; i <= ligb; i++){
+ dersamples[k + i] = b[i][j];
+ }
+ k = k + ligb;
+ }
+
+ repintvec(numhapld, dersamples, numhaplt);
+
+ for(i = 1; i <= colb; i++){
+ numsamples[i] = i;
+ }
+
+ popsum(b, ressoms);
+ repintvec(numsamples, ressoms, repnumsam);
+ getpermutation(pralea, increm);
+ vecintpermut(numhaplt, pralea, numhaplsim);
+ getinttable(numhaplsim, repnumsam, bsim);
+
+ sums(a, bsim, c, som, sst, prindicstr, prss);
+ means(prss, prdf, prms);
+ nvalues(bsim, c, som, prdf, prindicstr, prn);
+ sigmas(prms, prn, prsigma);
+ res[1] = prsigma[1];
+
+ if(prindicstr[0] != 0){
+
+ for(i = 1; i <= som[0]; i++){
+ deroule[i][1] = numhaplt[i];
+ deroule[i][2] = repnumsam[i];
+ }
+
+ for(j = 1; j <= colc; j++){
+ for(i = 1; i <= colb; i++){
+ numgroup[i] = c[i][j];
+ }
+ repintvec(numgroup, ressoms, numgroud);
+ for(i = 1; i <= som[0]; i++){
+ deroule[i][2 + j] = numgroud[i];
+ }
+ }
+
+ for(i = 1; i <= som[0]; i++){
+ deroule[i][colderoule] = 1;
+ }
+
+ /* le tableau deroule contient en ligne les individus et en colonne:
+ * 1ere colonne: le numero de l'haplotype de chaque individu
+ * 2eme colonne: le numero de l'echantillon auquel appartient chaque individu
+ * eventuellement, 3eme colonne: le numero du groupe auquel appartient chaque individu (premier groupement)
+ * (ie premiere colonne de structures)
+ * eventuellement, 4eme colonne: le numero du groupe auquel appartient chaque individu (deuxieme groupement)
+ * (ie deuxieme colonne de structures)
+ * ...
+ * derniere colonne: un vecteur de 1 */
+
+
+ for(i = 2; i <= colderoule - 1; i++){
+
+ if(i != colderoule - 1){
+ for(k = 1; k <= colb; k++){
+ numgroup[k] = c[k][i - 1];
+ }
+ nbniveaux = maxvecint(numgroup);
+ }
+ else{
+ nbniveaux = 1;
+ }
+
+ compt = 0;
+ for(k = 1; k <= nbniveaux; k++){
+
+ m = 1;
+ for(j = 1; j <= som[0]; j++){
+ if(deroule[j][i + 1] == k){
+ for(l = 1; l <= colderoule; l++){
+ newderoule[m][l] = deroule[j][l];
+ }
+ m = m + 1;
+ }
+ }
+
+ /* newderoule contient le tableau deroule restreint aux individus du groupe k
+ * pour le groupement i + 1 */
+
+ for(j = 1; j <= m - 1; j++){
+ xp[j] = newderoule[j][i];
+ }
+ xp[0] = m - 1;
+
+ /* xp contient le numero du groupe, pour le groupement i, de chaque individu
+ * appartenant au groupe k pour le groupement i + 1.
+ * Nous allons permuter les goupes de niveau i au sein des groupes de niveau i + 1 */
+
+ unduplicint(xp, unduplicxp);
+
+ /* unduplicxp contient les numeros des groupes pour le groupement i auquels appartiennent
+ * les individus du groupe k pour le groupement i + 1.*/
+
+ lignewderoule = m - 1;
+
+ if(unduplicxp[0] == 1){
+ for(j = 1; j <= lignewderoule; j++){
+ for(l = 1; l <= colderoule; l++){
+ newderouled[j + compt][l] = newderoule[j][l];
+ }
+ }
+ }
+
+ else{
+
+ if(i == 2){
+ pralea[0] = m - 1;
+ getpermutation(pralea, increm);
+
+ for(j = 1; j <= lignewderoule; j++){
+ newderouled[j + compt][1] = newderoule[j][1];
+ m = pralea[j];
+ newderouled[j + compt][2] = newderoule[m][2];
+ for(l = 3; l <= colderoule; l++){
+ newderouled[j + compt][l] = newderoule[j][l];
+ }
+ }
+ }
+
+ else{
+
+ for(j = 1; j <= m - 1; j++){
+ xd[j] = newderoule[j][i-1];
+ }
+ xd[0] = m - 1;
+
+ changeintlevels(xd, newxd);
+ vpintunduplicvdint(xp, newxd, unduplicxdprxp);
+
+ lignewderoule = m - 1;
+ pralea[0] = unduplicxdprxp[0];
+ getpermutation(pralea, increm);
+ vecintpermut(unduplicxdprxp, pralea, newunduplicxdprxp);
+
+ for(j = 1; j <= m-1; j++){
+ l = newxd[j];
+ newxp[j] = newunduplicxdprxp[l];
+ }
+
+ for(j = 1; j <= lignewderoule; j++){
+ for(l = 1; l <= i - 1; l++){
+ newderouled[j + compt][l] = newderoule[j][l];
+ }
+ newderouled[j + compt][i] = newxp[j];
+ for(l = i + 1; l <= colderoule; l++){
+ newderouled[j + compt][l] = newderoule[j][l];
+ }
+ }
+ }
+ }
+ compt = compt + lignewderoule;
+
+ }
+
+ /* Les permutations terminees, on reconstruit les tableaux. */
+
+ for(j = 1; j <= som[0]; j++){
+ newh[j] = newderouled[j][1];
+ news[j] = newderouled[j][2];
+ }
+
+ getinttable(newh, news, bsim);
+
+ /* Le tableau samples (b) est reconstruit. */
+
+ for(j = 3; j <= colderoule - 1; j++){
+ for(l = 1; l <= som[0]; l++){
+ newg[l] = newderouled[l][j];
+ }
+ vpintunduplicvdint(newg, news, newgd);
+ unduplicint(news, newsd);
+ newst[0] = newsd[0];
+ getneworder(newsd, newst);
+ for(l = 1; l <= colb; l++){
+ n = newst[l];
+ csim[l][j - 2] = newgd[n];
+ }
+ }
+
+ /* Le tableau structures (c) est reconstruit.
+ * Il reste a calculer la valueur simulee de sigma: */
+
+ sums(a, bsim, csim, som, sst, prindicstr, prss);
+ means(prss, prdf, prms);
+ nvalues(bsim, csim, som, prdf, prindicstr, prn);
+ sigmas(prms, prn, prsigma);
+
+ res[i] = prsigma[i];
+
+ }
+ }
+
+ else {
+ res[1] = prsigma[2];
+ }
+
+ freeintvec(numhaplp);
+ freeintvec(numhapld);
+ freeintvec(dersamples);
+ freeintvec(numhaplt);
+ freeintvec(numhaplsim);
+ freeintvec(numsamples);
+ freeintvec(repnumsam);
+ freeintvec(ressoms);
+ freeintvec(pralea);
+ freeinttab(bsim);
+ freeinttab(csim);
+ freeintvec(numgroup);
+ freeintvec(numgroud);
+ freeintvec(xp);
+ freeintvec(newxp);
+ freeintvec(xd);
+ freeintvec(newxd);
+ freeintvec(unduplicxp);
+ freeintvec(unduplicxdprxp);
+ freeintvec(newunduplicxdprxp);
+ freeintvec(newh);
+ freeintvec(news);
+ freeintvec(newsd);
+ freeintvec(newst);
+ freeintvec(newg);
+ freeintvec(newgd);
+ freeinttab(deroule);
+ freeinttab(newderoule);
+ freeinttab(newderouled);
+ freevec(prss);
+ freevec(prms);
+ freevec(prn);
+ freevec(prsigma);
+
+}
diff --git a/src/testdim.c b/src/testdim.c
new file mode 100755
index 0000000..c113f81
--- /dev/null
+++ b/src/testdim.c
@@ -0,0 +1,297 @@
+#include <R.h>
+#include <stddef.h>
+#include <math.h>
+#include <time.h>
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include <assert.h>
+#include <Rmath.h>
+#include <R_ext/RS.h>
+#include <R_ext/Utils.h>
+#include <R_ext/Linpack.h>
+#include <R_ext/Lapack.h>
+#include "adesub.h"
+
+
+/* Test of Dimensionality (Dray, CSDA, 2007) */
+
+
+int svd(double **X, double **vecU, double **vecVt, double *vecD);
+int svdd(double **X,double *vecD);
+void recX(double **Xi, double **XU, double **XVt, double *D, int i);
+double denum(double *vec, int i, int ncol);
+void testdimRVpca (int *ok, double *tabXR, int *nrow, int *ncol, int *nrepet, int *nbaxtest, double *sim1, double *obs1);
+
+
+
+
+
+
+/*================================================================= */
+void testdimRVpca (int *ok, double *tabXR, int *nrow, int *ncol, int *nrepet, int *nbaxtest, double *sim1, double *obs1) {
+ /* RV */
+ /* one test for each axis (RVDIM2) */
+ double **X, **result1, **XU, **XV, *D, **Xperm;
+ double **Xi, **Riperm, **Ri, *Dperm;
+ int nr,nc,nb,i,j,k,rankX, toto;
+ nr = *nrow;
+ nc = *ncol;
+ nb = nc;
+ if(nr<nb) nb=nr;
+ taballoc (&X, nr, nc);
+ taballoc (&Xperm, nr, nc);
+ taballoc (&XU, nr, nb);
+ taballoc (&XV, nc, nb);
+ vecalloc (&D,nb);
+ taballoc (&Xi, nr, nc);
+ taballoc (&Riperm, nr, nc);
+ taballoc (&Ri, nr, nc);
+ vecalloc (&Dperm,nb);
+
+ /* From R to C */
+ k = 0;
+ for (i=1; i<=nr; i++) {
+ for (j=1; j<=nc; j++) {
+ X[i][j] = tabXR[k];
+ Ri[i][j] = X[i][j];
+ Xi[i][j] =0;
+ k = k + 1;
+ }
+ }
+ rankX=svd(X,XU,XV,D);
+ if(rankX < 0) ok[0] = -1;
+ if(*nbaxtest>rankX) nbaxtest[0]=rankX;
+ taballoc (&result1, *nrepet, *nbaxtest);
+
+
+
+ for(i=1;i<=*nbaxtest;i++) {
+ recX(Xi,XU,XV,D,i);
+ obs1[i-1]=pow(D[i],2)/denum(D,i,rankX); /*RV*/
+
+ for(k=1;k<=*nrepet;k++){
+ for(j=1;j<=nb;j++) Dperm[j]=0;
+ permutmodel1(Ri,Riperm,&nr,&nc);
+ toto=svdd(Riperm,Dperm);
+ if(toto < 0) ok[0] = -1;
+ result1[k][i]=pow(Dperm[1],2)/denum(Dperm,1,toto);
+
+ }
+ for(j=1;j<=nr;j++){
+ for(k=1;k<=nc;k++){
+ Ri[j][k]=Ri[j][k]-Xi[j][k];
+ }
+ }
+
+
+ }
+
+ /* return values to R */
+
+ k = 0;
+ for (i=1; i<=*nrepet; i++)
+ {
+ for (j=1; j<=*nbaxtest; j++)
+ {
+ sim1[k]= result1[i][j];
+ k = k + 1;
+ }
+ }
+
+ freetab(X);
+ freetab(Xperm);
+ freetab(XU);
+ freetab(XV);
+ freevec(D);
+ freetab(result1);
+ freetab(Xi);
+ freetab(Riperm);
+ freetab(Ri);
+ freevec(Dperm);
+
+}
+
+
+/*================================================================= */
+/* renvoie ui*di*t(vi) dans Xi*/
+void recX(double **Xi, double **XU, double **XV, double *D, int i){
+ int k,j,nr,nc;
+ nr=(int)Xi[0][0];
+ nc=(int)Xi[1][0];
+ for(k=1;k<=nr;k++){
+ for(j=1;j<=nc;j++){
+ Xi[k][j]=D[i]* XU[k][i]* XV[j][i];
+ }
+ }
+}
+
+/*================================================================= */
+/* svd d'une matrice , renvoie le rang de X, U, D et t(V) */
+/*DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
+ $ WORK, LWORK, INFO ) */
+int svd(double **X, double **vecU, double **vecVt, double *vecD)
+{
+ int i,j, k,error,nr,nc,lwork,nbax,rankX,ldvt;
+ char jobu='S',jobvt='A';
+ double *A,*U, *D, *V;
+ double work1,*work;
+
+ nr=(int)X[0][0];
+ nc=(int)X[1][0];
+ nbax=nc;
+ ldvt=nc;
+
+ if (nr<nc) {
+ nbax=nr;
+ jobu='A';
+ jobvt='S';
+ ldvt=nbax;
+
+
+ }
+
+ A = (double *)calloc((size_t)nr*nc, sizeof(double));/*doubleArray(size*size);*/
+ D = (double *)calloc((size_t)nbax, sizeof(double));/*doubleArray(nbax*1);*/
+ U = (double *)calloc((size_t)nr*nbax, sizeof(double));
+ V = (double *)calloc((size_t)nbax*nc, sizeof(double));
+
+
+
+
+ lwork=-1;
+ for (i = 0, j = 1; j <= nc; j++) {
+ for (k = 1; k <= nr; k++) {
+ A[i] = X[k][j];
+ i++;
+ }
+ }
+ F77_CALL(dgesvd)(&jobu, &jobvt,&nr, &nc,A, &nr, D,U,&nr,V,&ldvt,&work1, &lwork,&error);
+
+ lwork=(int)floor(work1);
+ if (work1-lwork>0.5) lwork++;
+ work=(double *)calloc((size_t)lwork,sizeof(double));
+ /* actual call */
+ F77_NAME(dgesvd)(&jobu, &jobvt,&nr, &nc,A, &nr, D,U,&nr,V,&ldvt,work, &lwork,&error);
+ free(work);
+
+ if (error) {
+ Rprintf("error in svd: %d\n", error);
+ return(-1);
+ }
+ i = 0;
+ rankX=0;
+ for ( j = 1; j <= nbax; j++) {
+ for (k = 1; k <= nr; k++) {
+ vecU[k][j] = U[i];
+ i++;
+ }
+ vecD[j]=D[j-1];
+
+ if (D[j-1]/D[0]>0.00000000001) rankX=rankX+1;
+ }
+
+ i = 0;
+ for (k = 1; k <= nc; k++) {
+ for ( j = 1; j <= nbax; j++){
+
+ vecVt[k][j] = V[i];
+ i++;
+ }
+ }
+
+ free(A);
+ free(D);
+ free(U);
+ free(V);
+ return(rankX);
+
+}
+
+
+
+/* ============================= */
+
+
+/*================================================================= */
+/* svd d'une matrice , renvoie le rang de X et D */
+/*DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
+ $ WORK, LWORK, INFO )
+ renvoie seulement les valeurs singulieres, pas les vecteurs -> plus rapide */
+int svdd(double **X, double *vecD)
+{
+ int i,j, k,error,nr,nc,lwork,nbax,rankX,ldvt;
+ char jobu='N',jobvt='N';
+ double *A,*U,*D,*V;
+ double work1,*work;
+
+ nr=(int)X[0][0];
+ nc=(int)X[1][0];
+ nbax=nc;
+ ldvt=nc;
+ if (nr<nc) {
+ nbax=nr;
+ ldvt=nbax;
+
+ }
+
+
+ A = (double *)calloc((size_t)nr*nc, sizeof(double));/*doubleArray(size*size);*/
+ D = (double *)calloc((size_t)nbax, sizeof(double));/*doubleArray(nbax*1);*/
+ /* double *U = (double *)calloc((size_t)nr*nbax, sizeof(double));
+ double *V = (double *)calloc((size_t)nbax*nc, sizeof(double));*/
+ U = (double *)calloc((size_t)nbax, sizeof(double));
+ V = (double *)calloc((size_t)nbax, sizeof(double));
+
+
+
+ lwork=-1;
+ for (i = 0, j = 1; j <= nc; j++) {
+ for (k = 1; k <= nr; k++) {
+ A[i] = X[k][j];
+ i++;
+ }
+ }
+ F77_CALL(dgesvd)(&jobu, &jobvt,&nr, &nc,A, &nr, D,U,&nr,V,&ldvt,&work1, &lwork,&error);
+
+ lwork=(int)floor(work1);
+ if (work1-lwork>0.5) lwork++;
+ work=(double *)calloc((size_t)lwork,sizeof(double));
+ /* actual call */
+ F77_NAME(dgesvd)(&jobu, &jobvt,&nr, &nc,A, &nr, D,U,&nr,V,&ldvt,work, &lwork,&error);
+ free(work);
+
+ if (error) {
+ Rprintf("error in svd: %d\n", error);
+ return(-1);
+ }
+
+ rankX=0;
+ for ( j = 1; j <= nbax; j++) {
+ vecD[j]=D[j-1];
+
+ if (D[j-1]/D[0]>0.00000000001) rankX=rankX+1;
+ }
+
+
+ free(A);
+ free(D);
+ free(U);
+ free(V);
+ return(rankX);
+
+}
+
+
+
+/* ============================= */
+
+double denum(double *vec, int i, int ncol){
+ int j;
+ double tot=0;
+ for(j=i;j<=ncol;j++){
+ tot=tot+pow(vec[j],4);
+ }
+ tot=sqrt(tot);
+ return(tot);
+}
diff --git a/src/testrlq.c b/src/testrlq.c
new file mode 100644
index 0000000..4121254
--- /dev/null
+++ b/src/testrlq.c
@@ -0,0 +1,321 @@
+#include <math.h>
+#include <time.h>
+#include <string.h>
+#include <stdlib.h>
+#include "adesub.h"
+#include <R.h>
+
+void testertracerlq ( int *npermut,
+ double *pcRr, int *npcR,
+ double *pcQr, int *npcQ,
+ double *plLr, int *nplL,
+ double *pcLr, int *npcL,
+ double *tabRr,
+ double *tabQr,
+ double *tabLr,
+ int *assignRr, int *assignQr,
+ int *indexRr, int *nindexR,
+ int *indexQr, int *nindexQ,
+ int *typQr,
+ int *typRr,
+ double *inersimul,
+ int *modeltype);
+
+
+
+
+void testertracerlq ( int *npermut,
+ double *pcRr, int *npcR,
+ double *pcQr, int *npcQ,
+ double *plLr, int *nplL,
+ double *pcLr, int *npcL,
+ double *tabRr,
+ double *tabQr,
+ double *tabLr,
+ int *assignRr, int *assignQr,
+ int *indexRr, int *nindexR,
+ int *indexQr, int *nindexQ,
+ int *typQr,
+ int *typRr,
+ double *inersimul,
+ int* modeltype)
+
+
+
+
+{
+ /* Declarations des variables C locales */
+
+ double **XR, **XQ, **XL,**initR, **initQ, *pcR, *pcQ, *plL,*pcL, **ta,**provi;
+ int i, j, k, lL,cL, cR, cQ;
+ double inertot, s1, inersim, a1;
+ int *numero1, *numero2,*assignR,*assignQ, *indexR, *indexQ;
+ int typR, typQ;
+
+ /* On recopie les objets R dans les variables C locales */
+
+ lL = *nplL;
+ cL = *npcL;
+ cQ = *npcQ;
+ cR = *npcR;
+ typR = *typRr;
+ typQ = *typQr;
+
+ /* Allocation memoire pour les variables C locales */
+
+ vecalloc (&pcR, cR);
+ vecalloc (&pcQ, cQ);
+ vecalloc (&plL, lL);
+ vecalloc (&pcL, cL);
+ vecintalloc (&numero1, lL);
+ vecintalloc (&numero2, cL);
+ taballoc (&XR, lL, cR);
+ taballoc (&XQ, cL, cQ);
+ taballoc (&initR, lL, cR);
+ taballoc (&initQ, cL, cQ);
+ taballoc (&XL, lL, cL);
+ taballoc (&ta, cR, cQ);
+ taballoc (&provi,cR,cL);
+ /* if typ == 8 (i.e. HillSmith Analysis)*/
+ if (typR == 8) {
+ vecintalloc(&assignR,cR);
+ for (i=1; i<=cR; i++) {
+ assignR[i] = assignRr[i-1];
+ }
+ vecintalloc(&indexR,*nindexR);
+ for (i=1; i<=*nindexR; i++) {
+ indexR[i] = indexRr[i-1];
+ }
+ }
+ if (typQ == 8) {
+ vecintalloc(&assignQ,cQ);
+ for (i=1; i<=cQ; i++) {
+ assignQ[i] = assignQr[i-1];
+ }
+ vecintalloc(&indexQ,*nindexQ);
+ for (i=1; i<=*nindexQ; i++) {
+ indexQ[i] = indexQr[i-1];
+ }
+
+ }
+
+ /* On recopie les objets R dans les variables C locales */
+
+ k = 0;
+ for (i=1; i<=lL; i++) {
+ for (j=1; j<=cR; j++) {
+ initR[i][j] = tabRr[k];
+ XR[i][j] = tabRr[k];
+ k = k + 1;
+ }
+ }
+ k = 0;
+ for (i=1; i<=cL; i++) {
+ for (j=1; j<=cQ; j++) {
+ initQ[i][j] = tabQr[k];
+ XQ[i][j] = tabQr[k];
+ k = k + 1;
+ }
+ }
+ k = 0;
+ for (i=1; i<=lL; i++) {
+ for (j=1; j<=cL; j++) {
+ XL[i][j] = tabLr[k];
+ k = k + 1;
+ }
+ }
+
+ for (i=1; i<=cR; i++) {
+ pcR[i] = pcRr[i-1];
+ }
+ for (i=1; i<=cQ; i++) {
+ pcQ[i] = pcQr[i-1];
+ }
+ for (i=1; i<=cL; i++) {
+ pcL[i] = pcLr[i-1];
+ }
+ for (i=1; i<=lL; i++) {
+ plL[i] = plLr[i-1];
+ }
+
+ /* Calculs */
+
+
+ for (i=1; i<=lL;i++) {
+ for (j=1;j<=cL;j++) {
+ XL[i][j]=XL[i][j]*plL[i]*pcL[j];
+ }
+ }
+ if (typR == 8) {
+ matcentragehi(XR,plL,indexR,assignR);
+ }
+ else {matcentrage (XR, plL, typR);
+ }
+
+ if (typQ == 8) {
+ matcentragehi(XQ,pcL,indexQ,assignQ);
+ }
+ else {matcentrage (XQ, pcL, typQ);
+ }
+
+ prodmatAtBC (XR, XL, provi);
+ prodmatABC (provi,XQ, ta);
+
+ inertot = 0;
+ for (i=1;i<=cR;i++) {
+ a1 = pcR[i];
+ for (j=1;j<=cQ;j++) {
+ s1 = ta[i][j];
+ inertot = inertot + s1 * s1 * a1 * pcQ[j];
+ }
+ }
+ inersimul[0] = inertot;
+ k = 0;
+
+
+
+
+ /* Permutation */
+
+ for (k=1; k<=*npermut; k++) {
+ if((*modeltype==2) || (*modeltype==5)) {
+ /* modeltype=2 permute R (i.e. row of L) */
+ getpermutation (numero1,k);
+ matpermut (initR, numero1, XR);
+
+ }
+ if((*modeltype==4) || (*modeltype==5)) {
+ /* modeltype=4 permute Q (i.e. column of L) */
+ getpermutation (numero2,2*k);
+ matpermut (initQ, numero2, XQ);
+ }
+
+
+ if((*modeltype==2) || (*modeltype==5)) {
+ /* modeltype=2 permute R (i.e. row of L) */
+ if (typR == 8) {
+ for(j=1;j<=cR;j++){
+ if(indexR[assignR[j]]==2){
+ pcR[j]=0;
+ }
+ }
+ for(i=1;i<=lL;i++){
+ for(j=1;j<=cR;j++){
+ if(indexR[assignR[j]]==2){
+ pcR[j]=pcR[j]+XR[i][j]*plL[i];
+ }
+ }
+ }
+ matcentragehi(XR,plL,indexR,assignR);
+ /* on recalcule le poids colonne pour les qualitatives */
+ }
+ else {
+ /* on recalcule le poids colonne pour les qualitatives pour une acm*/
+ if (typR == 2) {
+ for(j=1;j<=cR;j++){
+ pcR[j]=0;
+ }
+ for(i=1;i<=lL;i++){
+ for(j=1;j<=cR;j++){
+ pcR[j]=pcR[j]+XR[i][j]*plL[i];
+ }
+ }
+ for(j=1;j<=cR;j++){
+ pcR[j]=pcR[j]/(*nindexR);
+ }
+
+
+ }
+
+ matcentrage (XR, plL, typR);
+
+
+ }
+ }
+
+ if((*modeltype==4) || (*modeltype==5)) {
+ /* modeltype=4 permute Q (i.e. column of L) */
+ if (typQ == 8) {
+ /* on recalcule le poids colonne pour les qualitatives*/
+ for(j=1;j<=cQ;j++){
+ if(indexQ[assignQ[j]]==2){
+ pcQ[j]=0;
+ }
+ }
+ for(i=1;i<=cL;i++){
+ for(j=1;j<=cQ;j++){
+ if(indexQ[assignQ[j]]==2){
+ pcQ[j]=pcQ[j]+XQ[i][j]*pcL[i];
+ }
+ }
+ }
+
+ matcentragehi(XQ,pcL,indexQ,assignQ);
+
+ }
+ else {
+ /* on recalcule le poids colonne pour les qualitatives pour une acm*/
+ if (typQ == 2) {
+ for(j=1;j<=cQ;j++){
+ pcQ[j]=0;
+ }
+ for(i=1;i<=cL;i++){
+ for(j=1;j<=cQ;j++){
+ pcQ[j]=pcQ[j]+XQ[i][j]*pcL[i];
+ }
+ }
+ for(j=1;j<=cQ;j++){
+ pcQ[j]=pcQ[j]/(*nindexQ);
+ }
+ }
+
+
+ matcentrage (XQ, pcL, typQ);
+
+
+ }
+ }
+ prodmatAtBC (XR, XL, provi);
+ prodmatABC (provi,XQ, ta);
+
+
+ inersim = 0;
+ for (i=1;i<=cR;i++) {
+ a1 = pcR[i];
+ for (j=1;j<=cQ;j++) {
+ s1 = ta[i][j];
+ inersim = inersim + s1 * s1 * a1 * pcQ[j];
+ }
+ }
+ inersimul[k]=inersim;
+ }
+
+
+
+ freeintvec(numero1);
+ freeintvec(numero2);
+
+
+ if (typR == 8) {
+ freeintvec(assignR);
+ freeintvec(indexR);
+ }
+ if (typQ == 8) {
+ freeintvec(assignQ);
+ freeintvec(indexQ);
+ }
+ freetab(XR);
+ freetab(initR);
+ freetab(XL);
+ freetab(ta);
+ freetab(provi);
+ freetab(XQ);
+ freetab(initQ);
+ freevec(plL);
+ freevec(pcL);
+ freevec(pcQ);
+ freevec(pcR);
+
+} /*********************************/
+
+
diff --git a/src/tests.c b/src/tests.c
new file mode 100644
index 0000000..1dfadb6
--- /dev/null
+++ b/src/tests.c
@@ -0,0 +1,1179 @@
+#include <math.h>
+#include <time.h>
+#include <string.h>
+#include <stdlib.h>
+#include "adesub.h"
+
+double betweenvar (double **tab, double *pl, double *indica);
+double inerbetween (double *pl, double *pc, int moda, double *indica, double **tab);
+void testdiscrimin(int *npermut,double *rank,double *pl1,int *npl,double *indica1,int *nindica,double *tab1, int *il1, int *ic1,double *inersim);
+void testertrace (int *npermut,double *pc1r, double *pc2r, double *tab1r, int *l1r, int *c1r,double *tab2r, int *c2r,double *inersimul);
+void testertracenu (int *npermut,double *pc1r, double *pc2r, double *plr, double *tab1r, int *l1r, int *c1r,double *tab2r, int *c2r,double *tabinit1r,double *tabinit2r, int *typ1r, int *typ2r,double *inersimul);
+void testertracenubis ( int *npermut,double *pc1r, double *pc2r, double *plr, double *tab1r, int *l1r, int *c1r,double *tab2r, int *c2r,double *tabinit1r,double *tabinit2r, int *typ1r, int *typ2r, int *ntabr,double *inersimul);
+void testinter( int *npermut,double *pl1,int *npl,double *pc1,int *npc,int *moda1,double *indica1,int *nindica,double *tab1, int *l1, int *c1,double *inersim);
+void testmantel(int *npermut1,int *lig1,double *init11,double *init21,double *inersim);
+void testprocuste(int *npermut1,int *lig1,int *c11,int *c21,double *init11,double *init21,double *inersim);
+void testmultispati (int *npermut, int *lig1, int *col1, double *tab, double *mat, double *lw, double *cw, double *inersim) ;
+void testdistRV(int *npermut1,int *lig1,double *init11,double *init21,double *RV);
+void MSTgraph (double *distances, int *nlig, int *ngmax, double *voisi);
+
+/**************************/
+void MSTgraph (double *distances, int *nlig, int *ngmax, double *voisi)
+{
+ int N, NITP, KP, i, k, j, lig;
+ double **DM, **voisiloc, *UI, CST, D, UK;
+ double a0;
+ int **MST, *JI, *NIT, IMST, NI, numg, numgmax;
+ double borne = 1.0e20;
+
+ lig = N = *nlig;
+ numgmax=*ngmax;
+
+ taballoc (&DM, N, N);
+ taballoc (&voisiloc, N, N);
+ tabintalloc (&MST, 2, N);
+ vecalloc (&UI, N);
+ vecintalloc (&JI, N);
+ vecintalloc (&NIT, N);
+
+ k = 0;
+ for (i=1; i<=lig; i++) {
+ for (j=1; j<=lig; j++) {
+ DM[i][j] = distances[k];
+ k = k + 1;
+ }
+ }
+ for (i=1; i<=N; i++) DM[i][i] = borne;
+
+ for (numg=1; numg<=numgmax; numg++) {
+ /* Algorithm 422, Kevin & Whitney Comm. ACM 15, 273, 1972 */
+ CST = 0.;
+ NITP = N -1;
+ KP = N;
+ IMST = 0;
+ for (i=1; i<=NITP; i++) {
+ NIT[i] = i;
+ UI[i] = DM [i][KP];
+ JI[i] = KP;
+ }
+ while (NITP > 0) {
+ for (i=1; i<=NITP; i++) {
+ NI = NIT[i];
+ D = DM[NI][KP];
+ if (UI[i]>D) {
+ UI[i] = D;
+ JI[i] = KP;
+ }
+ }
+ UK = UI[1];
+ for (i=1; i<=NITP; i++) {
+ if (UI[i]<=UK) {
+ UK = UI[i];
+ k = i;
+ }
+ }
+ IMST = IMST + 1;
+ MST[1][IMST] = NIT[k];
+ MST[2][IMST] = JI[k];
+ CST = CST + UK;
+ KP = NIT[k];
+
+ UI[k]=UI[NITP];
+ NIT[k] = NIT[NITP];
+ JI[k]=JI[NITP];
+ NITP = NITP - 1;
+ }
+ for (i=1; i<=IMST; i++) {
+ voisiloc [MST[1][i]] [MST[2][i]] = numg;
+ voisiloc [MST[2][i]] [MST[1][i]] = numg;
+ DM [MST[1][i]] [MST[2][i]] = borne;
+ DM [MST[2][i]] [MST[1][i]] = borne;
+ }
+ }
+ for (i=1; i<=lig; i++) {
+ for (j=1; j<=lig; j++) {
+ a0 = voisiloc [i][j];
+ if ( (a0>0) && (a0<=numgmax) ){
+ voisiloc [i][j] = 1;
+ } else voisiloc [i][j] = 0;
+ }
+ }
+
+ k = 0;
+ for (i=1; i<=lig; i++) {
+ for (j=1; j<=lig; j++) {
+ voisi[k]=voisiloc[i][j];
+ k = k + 1;
+ }
+ }
+
+ freetab (DM);
+ freetab (voisiloc);
+ freeinttab (MST);
+ freevec (UI);
+ freeintvec (JI);
+ freeintvec (NIT);
+}
+
+/*********************************************/
+void testdistRV(int *npermut1,int *lig1,double *init11,double *init21,double *RV)
+{
+ /* Declarations de variables C locales */
+
+ int i, j, k, lig, i0, j0, npermut, *numero, isel;
+ double **m1, **m2, *pl;
+ double trace, trace0, car1, car2, a0;
+
+ /* Allocation memoire pour les variables C locales */
+
+ npermut = *npermut1;
+ lig = *lig1;
+
+ taballoc(&m1, lig, lig);
+ taballoc(&m2, lig, lig);
+ vecintalloc (&numero, lig);
+ vecalloc (&pl, lig);
+
+ /* On recopie les objets R dans les variables C locales */
+
+ k = 0;
+ for (i=1; i<=lig; i++) {
+ for (j=1; j<=lig; j++) {
+ m1[i][j] = init11[k];
+ k = k + 1;
+ }
+ }
+
+ k = 0;
+ for (i=1; i<=lig; i++) {
+ for (j=1; j<=lig; j++) {
+ m2[i][j] = init21[k];
+ k = k + 1;
+ }
+ }
+
+ /* m1 et m2 sont des matrices de distances simples */
+ initvec(pl, 1.0/(double)lig);
+ dtodelta (m1, pl);
+ dtodelta (m2,pl);
+ car1 = 0;
+ trace=0;
+ car2 = 0;
+ for (i=1; i<=lig; i++) {
+ for (j=1; j<=lig; j++) {
+ car1 = car1 + m1[i][j]*m1[i][j];
+ trace = trace + m1[i][j]*m2[i][j];
+ car2 = car2 + m2[i][j]*m2[i][j];
+ }
+ }
+ car1 = sqrt ( (double) car1);
+ car2 = sqrt ( (double) car2);
+ a0 = trace/car1/car2;
+ if (a0<-1) a0 = -1;
+ if (a0>1) a0 = 1;
+ RV[0] = a0;
+ for (isel=1; isel<=npermut; isel++) {
+ getpermutation (numero, isel);
+ trace0=0;
+ for (i=1; i<=lig; i++) {
+ i0 = numero[i];
+ for (j=1; j<=lig; j++) {
+ j0 = numero[j];
+ trace0 = trace0 + m1[i][j]*m2[i0][j0];
+ }
+ }
+ a0 = trace0/car1/car2;
+ if (a0<-1) a0 = -1;
+ if (a0>1) a0 = 1;
+ RV[isel] = a0;
+ }
+ freevec(pl);
+ freeintvec(numero);
+ freetab (m1);
+ freetab (m2);
+}
+
+/*********************************************/
+/* On commence par une première version ou l'on importe la liste listw sous forme matricielle.
+ On pourrait suivre la logique de Bivand qui est plus judicieuse, surtout quand les matrices
+ L on beaucoup de 0. Il travaille avec des listes et calcul le produit L%*%X par la fonction
+ lagw.c. */
+
+void testmultispati (int *npermut, int *lig1, int *col1, double *tab, double *mat, double *lw, double *cw, double *inersim)
+{
+ /* Declarations de variables C locales */
+
+ int i, j, k, lig, col, nper, *numero;
+ double **X, **L, **Xperm;
+ double *d, *q, *dperm;
+
+ /* Allocation memoire pour les variables C locales */
+
+ nper = *npermut;
+ lig = *lig1;
+ col= *col1;
+
+
+
+ taballoc(&X, lig, col);
+ taballoc(&L, lig, lig);
+ taballoc(&Xperm, lig, col);
+ vecintalloc (&numero, lig);
+ vecalloc(&dperm, lig);
+ vecalloc(&d, lig);
+ vecalloc(&q, col);
+
+ /* On recopie les objets R dans les variables C locales */
+
+ k = 0;
+ for (j=1; j<=col; j++) {
+ for (i=1; i<=lig; i++) {
+ X[i][j] = tab[k];
+ k = k + 1;
+ }
+ }
+
+ k = 0;
+ for (i=1; i<=lig; i++) {
+ for (j=1; j<=lig; j++) {
+ L[j][i] = mat[k];
+ k = k + 1;
+ }
+ }
+
+ k=0;
+ for (i=1; i<=lig; i++) {
+ d[i]=lw[k];
+ k = k + 1;
+ }
+
+ k=0;
+ for (i=1; i<=col; i++) {
+ q[i]=cw[k];
+ k = k + 1;
+ }
+
+ /* On calcul la valeur observée */
+ inersim[0]=traceXtdLXq(X, L, d, q);
+
+ /* On calcul les valeurs pour chaque simulation */
+
+ for (j=1; j<=nper; j++) {
+ getpermutation(numero, j);
+ matpermut(X, numero ,Xperm);
+ vecpermut(d, numero, dperm);
+ inersim[j]=traceXtdLXq(Xperm, L, dperm, q);
+ }
+
+
+ /* Libération des réservations locales */
+
+ freetab(X);
+ freetab(L);
+ freetab(Xperm);
+ freeintvec(numero);
+ freevec(dperm);
+ freevec(d);
+ freevec(q);
+}
+
+/*********************************************/
+void testmantel(int *npermut1,
+ int *lig1,
+ double *init11,
+ double *init21,
+
+ double *inersim)
+{
+ /* Declarations de variables C locales */
+
+ int i, j, k, lig, i0, j0, npermut, *numero, isel;
+ double **m1, **m2;
+ double trace, trace0, moy1, moy2, car1, car2, a0;
+
+ /* Allocation memoire pour les variables C locales */
+
+ npermut = *npermut1;
+ lig = *lig1;
+
+ taballoc(&m1, lig, lig);
+ taballoc(&m2, lig, lig);
+ vecintalloc (&numero, lig);
+
+ /* On recopie les objets R dans les variables C locales */
+
+ k = 0;
+ for (i=1; i<=lig; i++) {
+ for (j=1; j<=lig; j++) {
+ m1[i][j] = init11[k];
+ k = k + 1;
+ }
+ }
+
+ k = 0;
+ for (i=1; i<=lig; i++) {
+ for (j=1; j<=lig; j++) {
+ m2[i][j] = init21[k];
+ k = k + 1;
+ }
+ }
+
+ trace=0;
+ moy1 = 0; moy2=0; car1 = 0; car2 = 0;
+ for (i=1; i<=lig; i++) {
+ for (j=1; j<=lig; j++) {
+ trace = trace + m1[i][j]*m2[i][j];
+ if (j>i) {
+ moy1 = moy1 + m1[i][j];
+ moy2 = moy2 + m2[i][j];
+ car1 = car1 + m1[i][j]*m1[i][j];
+ car2 = car2 + m2[i][j]*m2[i][j];
+ }
+ }
+ }
+ trace = trace/2;
+ a0 = trace - moy1*moy2*2/lig/(lig-1);
+ a0 = a0/ sqrt ( (double) (car1 - moy1*moy1*2/lig/(lig-1)) );
+ a0 = a0/ sqrt ( (double) (car2 - moy2*moy2*2/lig/(lig-1)) );
+ trace = a0;
+
+ inersim[0] = a0;
+
+ for (isel=1; isel<=npermut; isel++) {
+ getpermutation (numero, isel);
+ trace0=0;
+ for (i=1; i<=lig; i++) {
+ i0 = numero[i];
+ for (j=1; j<=lig; j++) {
+ j0 = numero[j];
+ trace0 = trace0 + m1[i][j]*m2[i0][j0];
+ }
+ }
+ trace0 = trace0/2;
+ a0 = trace0 - moy1*moy2*2/lig/(lig-1);
+ a0 = a0/ sqrt ( (double) (car1 - moy1*moy1*2/lig/(lig-1)) );
+ a0 = a0/ sqrt ( (double) (car2 - moy2*moy2*2/lig/(lig-1)) );
+ inersim[isel] = a0;
+ }
+
+ freetab(m1);
+ freetab(m2);
+ freeintvec(numero);
+}
+
+/*********************************************/
+void testprocuste( int *npermut1,
+ int *lig1,
+ int *c11,
+ int *c21,
+ double *init11,
+ double *init21,
+
+ double *inersim)
+{
+ /* Declarations de variables C locales */
+
+ int i, j, k, lig, c1, c2, npermut, rang, *numero;
+ double **tabperm, **init1, **init2, tinit, tsim;
+ double **cov, **w, *valpro, *tvecsim;
+
+ /* Allocation memoire pour les variables C locales */
+
+ npermut = *npermut1;
+ lig = *lig1;
+ c1 = *c11;
+ c2 = *c21;
+
+ /*
+ if (c1<=c2) {
+ taballoc(&tabperm, lig, c1);
+ taballoc(&init1, lig, c1);
+ taballoc(&init2, lig, c2);
+ } else {
+ taballoc(&tabperm, lig, c2);
+ taballoc(&init1, lig, c2);
+ taballoc(&init2, lig, c1);
+
+ res=c1;
+ c1=c2;
+ c2=res;
+ }
+ */
+ taballoc(&tabperm, lig, c1);
+ taballoc(&init1, lig, c1);
+ taballoc(&init2, lig, c2);
+
+ taballoc(&cov, c1, c2);
+ taballoc(&w, c1, c1);
+ vecalloc(&valpro,c1);
+ vecintalloc (&numero, lig);
+ vecalloc(&tvecsim, npermut);
+
+ /* On recopie les objets R dans les variables C locales */
+
+ k = 0;
+ for (i=1; i<=lig; i++) {
+ for (j=1; j<=c1; j++) {
+ init1[i][j] = init11[k];
+ k = k + 1;
+ }
+ }
+
+ k = 0;
+ for (i=1; i<=lig; i++) {
+ for (j=1; j<=c2; j++) {
+ init2[i][j] = init21[k];
+ k = k + 1;
+ }
+ }
+
+ /* Calculs */
+
+ tinit = 0;
+ prodmatAtBC (init1, init2, cov);
+ prodmatAAtB (cov,w);
+ DiagobgComp(c1, w, valpro, &rang);
+ for (i=1;i<=rang;i++) {
+ tinit=tinit+sqrt(valpro[i]);
+ }
+
+ for (k=1; k<=npermut; k++) {
+
+ getpermutation (numero,k);
+ matpermut (init1, numero, tabperm);
+
+ prodmatAtBC (tabperm, init2, cov);
+ prodmatAAtB (cov,w);
+ DiagobgComp(c1, w, valpro, &rang);
+ tsim=0;
+ for (i=1;i<=rang;i++) {
+ tsim=tsim+sqrt(valpro[i]);
+ }
+ tvecsim[k] = tsim;
+ }
+
+ inersim[0] = tinit;
+
+ for (k=1; k<=npermut; k++) {
+ inersim[k] = tvecsim[k];
+ }
+
+ freetab(tabperm);
+ freetab(cov);
+ freetab(init1);
+ freetab(init2);
+ freetab(w);
+ freevec(tvecsim);
+ freevec(valpro);
+ freeintvec(numero);
+}
+
+/*********************************************/
+void testdiscrimin( int *npermut,
+ double *rank,
+ double *pl1,
+ int *npl,
+ double *indica1,
+ int *nindica,
+ double *tab1, int *il1, int *ic1,
+ double *inersim)
+{
+ /* Declarations de variables C locales */
+
+ int l1, c1;
+
+ double **tab, **tabp, *pl, *plp, *indica, rang;
+ int i, j, k, *numero;
+
+ /* Allocation memoire pour les variables C locales */
+
+ l1 = *il1;
+ c1 = *ic1;
+ rang = *rank;
+
+ vecalloc (&pl, *npl);
+ vecalloc (&plp, *npl);
+ vecalloc (&indica, *nindica);
+ taballoc (&tab, l1, c1);
+ taballoc (&tabp, l1, c1);
+ vecintalloc(&numero, l1);
+
+ /* On recopie les objets R dans les variables C locales */
+
+ k = 0;
+ for (i=1; i<=l1; i++) {
+ for (j=1; j<=c1; j++) {
+ tab[i][j] = tab1[k];
+ k = k + 1;
+ }
+ }
+ for (i=1; i<=*npl; i++) {
+ pl[i] = pl1[i-1];
+ }
+ for (i=1; i<=*nindica; i++) {
+ indica[i] = indica1[i-1];
+ }
+
+ /* Calculs
+ inertie initiale est stockee dans le premier element du vecteur
+ des simulations */
+
+ inersim[0] = betweenvar(tab, pl, indica)/rang;
+
+ for (k=1; k<=*npermut; k++) {
+ getpermutation (numero, k);
+ matpermut (tab, numero, tabp);
+ vecpermut (pl, numero, plp);
+ inersim[k] = betweenvar (tabp, plp, indica)/rang;
+ }
+
+ freevec (pl);
+ freevec (plp);
+ freevec (indica);
+ freetab (tab);
+ freetab (tabp);
+ freeintvec (numero);
+}
+
+/*********************************************/
+double betweenvar (double **tab, double *pl, double *indica)
+{
+ double *m, s, bvar, *indicaw;
+ int i, j, l1, c1, ncla, icla;
+
+ l1 = tab[0][0];
+ c1 = tab[1][0];
+
+ ncla = indica[1];
+ for (i=1;i<=l1;i++) {
+ if (indica[i] > ncla) ncla = indica[i];
+ }
+
+ vecalloc(&m, ncla);
+ vecalloc(&indicaw, ncla);
+
+ bvar = 0;
+ for (j=1;j<=c1;j++) {
+
+ for (i=1;i<=ncla;i++) {
+ m[i] = 0;
+ indicaw[i] = 0;
+ }
+
+ for (i=1;i<=l1;i++) {
+ icla = indica[i];
+ indicaw[icla] = indicaw[icla] + pl[i];
+ m[icla] = m[icla] + tab[i][j] * pl[i];
+ }
+
+ s = 0;
+ for (i=1;i<=ncla;i++) {
+ s = s + m[i] * m[i] / indicaw[i];
+ }
+
+ bvar = bvar + s;
+ }
+
+ freevec(m);
+ freevec(indicaw);
+
+ return (bvar);
+}
+
+/************************************/
+void testinter( int *npermut,
+ double *pl1,
+ int *npl,
+ double *pc1,
+ int *npc,
+ int *moda1,
+ double *indica1,
+ int *nindica,
+ double *tab1, int *l1, int *c1,
+ double *inersim)
+{
+ /* Declarations de variables C locales */
+
+ double **tab, **tabp, *pl, *plp, *pc, *indica;
+ int moda, i, j, k;
+ int *numero;
+
+ /* Allocation memoire pour les variables C locales */
+
+ moda = *moda1;
+ vecalloc (&pl, *npl);
+ vecalloc (&plp, *npl);
+ vecalloc (&pc, *npc);
+ vecalloc (&indica, *nindica);
+ taballoc (&tab, *l1, *c1);
+ taballoc (&tabp, *l1, *c1);
+ vecintalloc(&numero, *l1);
+
+ /* On recopie les objets R dans les variables C locales */
+
+ k = 0;
+ for (i=1; i<=*l1; i++) {
+ for (j=1; j<=*c1; j++) {
+ tab[i][j] = tab1[k];
+ k = k + 1;
+ }
+ }
+ for (i=1; i<=*npl; i++) {
+ pl[i] = pl1[i-1];
+ }
+ for (i=1; i<=*npc; i++) {
+ pc[i] = pc1[i-1];
+ }
+ for (i=1; i<=*nindica; i++) {
+ indica[i] = indica1[i-1];
+ }
+
+ /* Calculs
+ inertie initiale est stockee dans le premier element du vecteur
+ des simulations */
+
+ inersim[0] = inerbetween (pl, pc, moda, indica, tab);
+
+ for (k=1; k<=*npermut; k++) {
+ getpermutation (numero,k);
+ matpermut (tab, numero, tabp);
+ vecpermut (pl, numero, plp);
+ inersim[k] = inerbetween (plp, pc, moda, indica, tabp);
+ }
+
+ freetab(tab);
+ freetab(tabp);
+ freevec(pl);
+ freevec(plp);
+ freevec(pc);
+ freevec(indica);
+ freeintvec(numero);
+}
+
+/************************************/
+double inerbetween (double *pl, double *pc, int moda, double *indica, double **tab)
+{
+ int i, j, k, l1, rang;
+ double poi, inerb, a0, a1, s1;
+ double **moy;
+ double *pcla;
+
+ l1 = tab[0][0];
+ rang = tab[1][0];
+ taballoc (&moy, moda, rang);
+ vecalloc (&pcla, moda);
+
+ for (i=1;i<=l1;i++) {
+ k = (int) indica[i];
+ poi = pl[i];
+ pcla[k]=pcla[k]+poi;
+ }
+
+
+ for (i=1;i<=l1;i++) {
+ k = (int) indica[i];
+ poi = pl[i];
+ for (j=1;j<=rang;j++) {
+ moy[k][j] = moy[k][j] + tab[i][j]*poi;
+ }
+ }
+
+ for (k=1;k<=moda;k++) {
+ a0 = pcla[k];
+ for (j=1;j<=rang;j++) {
+ moy[k][j] = moy[k][j]/a0;
+ }
+ }
+
+ inerb = 0;
+ for (i=1;i<=moda;i++) {
+ a1 = pcla[i];
+ for (j=1;j<=rang;j++) {
+ s1 = moy[i][j];
+ inerb = inerb + s1 * s1 *a1 * pc[j];
+ }
+ }
+ freetab (moy);
+ freevec (pcla);
+ return inerb;
+
+}
+
+/*****************/
+void testertrace ( int *npermut,
+ double *pc1r,
+ double *pc2r,
+ double *tab1r, int *l1r, int *c1r,
+ double *tab2r, int *c2r,
+ double *inersimul)
+{
+
+ /* Declarations des variables C locales */
+
+ double **X1, **X2, *pc1, *pc2, **cov;
+ int i, j, k, l1, c1, c2;
+ double poi, inertot, s1, inersim;
+ int *numero;
+
+ /* On recopie les objets R dans les variables C locales */
+
+ l1 = *l1r;
+ c1 = *c1r;
+ c2 = *c2r;
+
+ /* Allocation memoire pour les variables C locales */
+
+ vecalloc (&pc1, c1);
+ vecalloc (&pc2, c2);
+ vecintalloc(&numero, l1);
+ taballoc (&X1, l1, c1);
+ taballoc (&X2, l1, c2);
+ taballoc(&cov, c2, c1);
+
+ /* On recopie les objets R dans les variables C locales */
+
+ k = 0;
+ for (i=1; i<=l1; i++) {
+ for (j=1; j<=c1; j++) {
+ X1[i][j] = tab1r[k];
+ k = k + 1;
+ }
+ }
+ k = 0;
+ for (i=1; i<=l1; i++) {
+ for (j=1; j<=c2; j++) {
+ X2[i][j] = tab2r[k];
+ k = k + 1;
+ }
+ }
+ for (i=1; i<=c1; i++) {
+ pc1[i] = pc1r[i-1];
+ }
+ for (i=1; i<=c2; i++) {
+ pc2[i] = pc2r[i-1];
+ }
+
+ /* Calculs */
+
+ for (j=1;j<=c1;j++) {
+ poi = sqrt(pc1[j]);
+ for (i=1; i<=l1;i++) {
+ X1[i][j]=X1[i][j]*poi;
+ }
+ }
+ for (j=1;j<=c2;j++) {
+ poi = sqrt(pc2[j]);
+ for (i=1; i<=l1;i++) {
+ X2[i][j]=X2[i][j]*poi;
+ }
+ }
+
+ prodmatAtBC (X2, X1, cov);
+
+ inertot = 0;
+ for (i=1;i<=c2;i++) {
+ for (j=1;j<=c1;j++) {
+ s1 = cov[i][j];
+ inertot = inertot + s1 * s1;
+ }
+ }
+ inertot = inertot / l1 / l1;
+ inersimul[0] = inertot;
+
+ for (k=1; k<=*npermut; k++) {
+ getpermutation (numero,k);
+ prodmatAtBrandomC (X2, X1, cov, numero);
+
+ inersim = 0;
+ for (i=1;i<=c2;i++) {
+ for (j=1;j<=c1;j++) {
+ s1 = cov[i][j];
+ inersim = inersim + s1 * s1;
+ }
+ }
+ inersimul[k] = inersim / l1 / l1;
+ }
+
+ freevec (pc1);
+ freevec (pc2);
+ freeintvec (numero);
+ freetab (X1);
+ freetab (X2);
+ freetab (cov);
+}
+
+/*****************/
+void testertracenu ( int *npermut,
+ double *pc1r,
+ double *pc2r,
+ double *plr,
+ double *tab1r, int *l1r, int *c1r,
+ double *tab2r, int *c2r,
+ double *tabinit1r,
+ double *tabinit2r,
+ int *typ1r,
+ int *typ2r,
+ double *inersimul)
+{
+ /* Declarations des variables C locales */
+
+ double **X1, **X2, **init1, **init2, *pc1, *pc2, *pl, **cov;
+ int i, j, k, l1, c1, c2;
+ double poi, inertot, s1, inersim, a1;
+ int *numero1, *numero2;
+ int typ1,typ2;
+
+ /* On recopie les objets R dans les variables C locales */
+
+ l1 = *l1r;
+ c1 = *c1r;
+ c2 = *c2r;
+
+ typ1 = *typ1r;
+ typ2 = *typ2r;
+
+ /* Allocation memoire pour les variables C locales */
+
+ vecalloc (&pc1, c1);
+ vecalloc (&pc2, c2);
+ vecalloc (&pl, l1);
+ vecintalloc (&numero1, l1);
+ vecintalloc (&numero2, l1);
+ taballoc (&X1, l1, c1);
+ taballoc (&X2, l1, c2);
+ taballoc (&init1, l1, c1);
+ taballoc (&init2, l1, c2);
+ taballoc (&cov, c2, c1);
+
+ /* On recopie les objets R dans les variables C locales */
+
+ k = 0;
+ for (i=1; i<=l1; i++) {
+ for (j=1; j<=c1; j++) {
+ init1[i][j] = tab1r[k];
+ k = k + 1;
+ }
+ }
+ k = 0;
+ for (i=1; i<=l1; i++) {
+ for (j=1; j<=c2; j++) {
+ init2[i][j] = tab2r[k];
+ k = k + 1;
+ }
+ }
+ for (i=1; i<=c1; i++) {
+ pc1[i] = pc1r[i-1];
+ }
+ for (i=1; i<=c2; i++) {
+ pc2[i] = pc2r[i-1];
+ }
+ for (i=1; i<=l1; i++) {
+ pl[i] = plr[i-1];
+ }
+
+ /* Calculs */
+
+ inertot = 0;
+ for (i=1; i<=l1;i++) {
+ poi = pl[i];
+ for (j=1;j<=c1;j++) {
+ init1[i][j]=init1[i][j]*poi;
+ }
+ }
+
+ prodmatAtBC (init2, init1, cov);
+
+ for (i=1;i<=c2;i++) {
+ a1 = pc2[i];
+ for (j=1;j<=c1;j++) {
+ s1 = cov[i][j];
+ inertot = inertot + s1 * s1 * a1 * pc1[j];
+ }
+ }
+
+ inersimul[0] = inertot;
+
+ k = 0;
+ for (i=1; i<=l1; i++) {
+ for (j=1; j<=c1; j++) {
+ init1[i][j] = tabinit1r[k];
+ k = k + 1;
+ }
+ }
+ k = 0;
+ for (i=1; i<=l1; i++) {
+ for (j=1; j<=c2; j++) {
+ init2[i][j] = tabinit2r[k];
+ k = k + 1;
+ }
+ }
+
+ for (k=1; k<=*npermut; k++) {
+
+ getpermutation (numero1,k);
+ getpermutation (numero2,2*k);
+
+ matpermut (init1, numero1, X1);
+ matpermut (init2, numero2, X2);
+
+ /* calcul de poids colonnes dans le cas d'une acm*/
+
+ if (typ1 == 2) {
+ for(j=1;j<=c1;j++){
+ pc1[j]=0;
+ }
+ for(i=1;i<=l1;i++){
+ for(j=1;j<=c1;j++){
+ pc1[j]=pc1[j]+X1[i][j]*pl[i];
+ }
+ }
+
+ }
+
+ if (typ2 == 2) {
+ for(j=1;j<=c2;j++){
+ pc2[j]=0;
+ }
+ for(i=1;i<=l1;i++){
+ for(j=1;j<=c2;j++){
+ pc2[j]=pc2[j]+X2[i][j]*pl[i];
+ }
+ }
+
+
+ }
+
+
+ matcentrage (X1, pl, typ1);
+ matcentrage (X2, pl, typ2);
+
+ for (i=1; i<=l1;i++) {
+ poi = pl[i];
+ for (j=1;j<=c1;j++) {
+ X1[i][j]=X1[i][j]*poi;
+ }
+ }
+
+ prodmatAtBC (X2, X1, cov);
+
+ inersim = 0;
+ for (i=1;i<=c2;i++) {
+ a1 = pc2[i];
+ for (j=1;j<=c1;j++) {
+ s1 = cov[i][j];
+ inersim = inersim + s1 * s1 * a1 * pc1[j];
+ }
+ }
+ inersimul[k] = inersim;
+ }
+ freevec (pc1);
+ freevec (pc2);
+ freevec (pl);
+ freeintvec (numero1);
+ freeintvec (numero2);
+ freetab (X1);
+ freetab (X2);
+ freetab (init1);
+ freetab (init2);
+ freetab (cov);
+}
+
+
+/*****************/
+void testertracenubis ( int *npermut,
+ double *pc1r,
+ double *pc2r,
+ double *plr,
+ double *tab1r, int *l1r, int *c1r,
+ double *tab2r, int *c2r,
+ double *tabinit1r,
+ double *tabinit2r,
+ int *typ1r,
+ int *typ2r,
+ int *ntabr,
+ double *inersimul)
+
+{
+ /* Declarations des variables C locales */
+
+ double **X1, **X2, **init1, **init2, *pc1, *pc2, *pl, **cov;
+ int i, j, k, l1, c1, c2;
+ double poi, inertot, s1, inersim, a1;
+ int *numero1, *numero2, ntab;
+ int typ1, typ2;
+
+ /* On recopie les objets R dans les variables C locales */
+
+ l1 = *l1r;
+ c1 = *c1r;
+ c2 = *c2r;
+ ntab = *ntabr;
+ typ1 = *typ1r;
+ typ2 = *typ2r;
+
+
+ /* Allocation memoire pour les variables C locales */
+
+ vecalloc (&pc1, c1);
+ vecalloc (&pc2, c2);
+ vecalloc (&pl, l1);
+ vecintalloc (&numero1, l1);
+ vecintalloc (&numero2, l1);
+ taballoc (&X1, l1, c1);
+ taballoc (&X2, l1, c2);
+ taballoc (&init1, l1, c1);
+ taballoc (&init2, l1, c2);
+ taballoc (&cov, c2, c1);
+
+ /* On recopie les objets R dans les variables C locales */
+
+ k = 0;
+ for (i=1; i<=l1; i++) {
+ for (j=1; j<=c1; j++) {
+ init1[i][j] = tab1r[k];
+ k = k + 1;
+ }
+ }
+ k = 0;
+ for (i=1; i<=l1; i++) {
+ for (j=1; j<=c2; j++) {
+ init2[i][j] = tab2r[k];
+ k = k + 1;
+ }
+ }
+ for (i=1; i<=c1; i++) {
+ pc1[i] = pc1r[i-1];
+ }
+ for (i=1; i<=c2; i++) {
+ pc2[i] = pc2r[i-1];
+ }
+ for (i=1; i<=l1; i++) {
+ pl[i] = plr[i-1];
+ }
+
+ inertot = 0;
+ for (i=1; i<=l1;i++) {
+ poi = pl[i];
+ for (j=1;j<=c1;j++) {
+ init1[i][j]=init1[i][j]*poi;
+ }
+ }
+
+ prodmatAtBC (init2, init1, cov);
+
+ for (i=1;i<=c2;i++) {
+ a1 = pc2[i];
+ for (j=1;j<=c1;j++) {
+ s1 = cov[i][j];
+ inertot = inertot + s1 * s1 * a1 * pc1[j];
+ }
+ }
+
+ inersimul[0] = inertot;
+
+ k = 0;
+ for (i=1; i<=l1; i++) {
+ for (j=1; j<=c1; j++) {
+ X1[i][j] = tab1r[k];
+ k = k + 1;
+ }
+ }
+ for (i=1; i<=l1;i++) {
+ poi = pl[i];
+ for (j=1;j<=c1;j++) {
+ X1[i][j]=X1[i][j]*poi;
+ }
+ }
+
+ k = 0;
+ for (i=1; i<=l1; i++) {
+ for (j=1; j<=c2; j++) {
+ X2[i][j] = tab2r[k];
+ k = k + 1;
+ }
+ }
+ for (i=1; i<=l1;i++) {
+ poi = pl[i];
+ for (j=1;j<=c2;j++) {
+ X2[i][j]=X2[i][j]*poi;
+ }
+ }
+
+ if (ntab == 1) {
+ k = 0;
+ for (i=1; i<=l1; i++) {
+ for (j=1; j<=c2; j++) {
+ init2[i][j] = tabinit2r[k];
+ k = k + 1;
+ }
+ }
+ } else {
+ k = 0;
+ for (i=1; i<=l1; i++) {
+ for (j=1; j<=c1; j++) {
+ init1[i][j] = tabinit1r[k];
+ k = k + 1;
+ }
+ }
+ }
+
+ for (k=1; k<=*npermut; k++) {
+
+ if (ntab == 1) {
+ getpermutation (numero2,k);
+ matpermut (init2, numero2, X2);
+ /* Recompute column weights for an acm*/
+ if (typ2 == 2) {
+ for(j=1;j<=c2;j++){
+ pc2[j]=0;
+ }
+ for(i=1;i<=l1;i++){
+ for(j=1;j<=c2;j++){
+ pc2[j]=pc2[j]+X2[i][j]*pl[i];
+ }
+ }
+
+ }
+
+ matcentrage (X2, pl, typ2);
+ } else {
+ getpermutation (numero1,k);
+ matpermut (init1, numero1, X1);
+ /* poids colonne recalculé si acm*/
+ if (typ1 == 2) {
+ for(j=1;j<=c1;j++){
+ pc1[j]=0;
+ }
+ for(i=1;i<=l1;i++){
+ for(j=1;j<=c1;j++){
+ pc1[j]=pc1[j]+X1[i][j]*pl[i];
+ }
+ }
+
+ }
+ matcentrage (X1, pl, typ1);
+ }
+
+ prodmatAtBC (X2, X1, cov);
+
+ inersim = 0;
+ for (i=1;i<=c2;i++) {
+ a1 = pc2[i];
+ for (j=1;j<=c1;j++) {
+ s1 = cov[i][j];
+ inersim = inersim + s1 * s1 * a1 * pc1[j];
+ }
+ }
+ inersimul[k] = inersim;
+ }
+ freevec (pc1);
+ freevec (pc2);
+ freevec (pl);
+ freeintvec (numero1);
+ freeintvec (numero2);
+ freetab (X1);
+ freetab (X2);
+ freetab (init1);
+ freetab (init2);
+ freetab (cov);
+}
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-med/r-cran-ade4.git
More information about the debian-med-commit
mailing list