diff -Nru ade4-1.7-13/ChangeLog ade4-1.7-16/ChangeLog --- ade4-1.7-13/ChangeLog 2018-08-30 15:35:10.000000000 +0000 +++ ade4-1.7-16/ChangeLog 2020-10-28 09:03:20.000000000 +0000 @@ -1,3 +1,144 @@ +2020-10-28 Aurélie Siberchicot + + * DESCRIPTION: ---------- release of ade4 1.7-16 ---------- + +2020-10-28 Aurélie Siberchicot + + * man/loocv.bca.Rd: Correct typo + +2020-10-27 Aurélie Siberchicot + + * man/loocv.bca.Rd, man/loocv.discrimin.Rd, man/loocv.dudi.Rd, + man/pcw.Rd, man/varipart.Rd: Correct typos + +2020-10-20 Aurélie Siberchicot + + * DESCRIPTION, man/arrival.Rd, man/casitas.Rd, man/kcponds.Rd, + man/mbpcaiv.Rd, man/mbpls.Rd, man/multiblock.Rd, man/pcw.Rd, + man/presid2002.Rd, man/randboot.multiblock.Rd, + man/testdim.multiblock.Rd: Update some URL in rd files + +2020-10-19 Jean Thioulouse + + * man/loocv.discrimin.Rd: Update loocv.discrimin.Rd use generic loocv instead of loocv.discrimin in first exemple + (skulls) + +2020-10-19 Stéphane Dray + + * DESCRIPTION, NAMESPACE, R/loocv.R, man/loocv.bca.Rd, + man/loocv.discrimin.Rd, man/loocv.dudi.Rd: Add a new generic method + "loocv" These new functions allows to perform leave one-out cross-validation + for several simple dudi, between and discrimin classes + +2020-09-28 Aurélie Siberchicot + + * R/suprow.R: Update a warning in 'suprow.dudi' + +2020-06-24 Aurélie Siberchicot + + * inst/CITATION: Update the CITATION file + +2020-06-18 Aurélie Siberchicot + + * DESCRIPTION: Remove date + +2020-06-18 Aurélie Siberchicot + + * man/apis108.Rd: Update URL + +2020-04-23 Stéphane Dray + + * : commit 9991a008cd8276469ed5987dfebc7bab48241ac1 Author: + Stéphane Dray Date: Thu Apr 23 + 17:21:53 2020 +0200 + +2020-02-13 Stéphane Dray + + * ChangeLog: ---------- release of ade4 1.7-15 ---------- + +2020-02-13 Stéphane Dray + + * DESCRIPTION: ---------- release of ade4 1.7-15 ---------- + +2020-02-10 Stéphane Dray + + * DESCRIPTION, man/cailliez.Rd, man/kdisteuclid.Rd, man/oribatid.Rd: + Remove some broken URL + +2020-02-03 Stéphane Dray + + * DESCRIPTION: ---------- release of ade4 1.7-14 ---------- + +2020-02-03 Stéphane Dray + + * DESCRIPTION: Packages sp and pixmap are now in 'Imports'as they + defined S4 classes used in some data sets. Mail by B. Ripley + +2019-10-14 Aurélie Siberchicot + + * NAMESPACE, R/suprowpta.R, man/suprowpta.Rd: New function + 'suprowpta' + +2019-09-24 Aurélie Siberchicot + + * man/randtest.Rd: Trunk a line in a help file + +2019-09-20 Aurélie Siberchicot + + * R/krandtest.R, man/krandtest.Rd, man/randtest.Rd: Udpate and + uniformize the help pages of 'krandtest' and 'randtest' + +2019-09-19 Aurélie Siberchicot + + * NAMESPACE, R/krandtest.R, man/krandtest.Rd: Add [ and [[ methods + for krandtest + +2019-08-07 Stéphane Dray + + * R/dist.binary.R, R/dist.ktab.R, man/kdist.Rd: Correct a typo: + "Sockal" is now "Sokal" (Comment by P. Legendre) + +2019-05-17 Aurélie Siberchicot + + * man/apis108.Rd, man/casitas.Rd, man/chevaine.Rd, man/hdpg.Rd: + Simplify the examples of the datasets 'apis108', 'casitas', + 'chevaine' and 'hdpg' (no longer use deprecated genetic functions) + +2019-05-17 Aurélie Siberchicot + + * man/s.kde2d.Rd: Update the example used with 's.kde2d' + +2019-04-11 Aurélie Siberchicot + + * NAMESPACE, R/ade4-deprecated.R, R/dist.genet.R, R/fuzzygenet.R, + R/genet.R, man/ade4-deprecated.Rd, man/dist.genet.Rd, + man/fuzzygenet.Rd, man/genet.Rd: The functions 'dist.genet', + 'fuzzygenet', 'char2genet', 'count2genet' and 'freq2genet' are + removed + +2019-04-10 Aurélie Siberchicot + + * NAMESPACE, R/EH.R, R/ade4-deprecated.R, R/optimEH.R, + R/orisaved.R, R/randEH.R, man/EH.Rd, man/ade4-deprecated.Rd, + man/optimEH.Rd, man/orisaved.Rd, man/randEH.Rd: The functions 'EH', + 'randEH', 'optimEH' and 'orisaved' are removed + +2019-04-10 Aurélie Siberchicot + + * R/multispati.R, man/multispati.Rd: The 'print.multispati', + 'plot.multispati' and 'summary.multispati' methods are now + deprecated + +2018-10-18 Aurélie Siberchicot + + * R/dist.ktab.R: Correct a bug in 'dist.ktab', 'ldist.ktab' and + 'kdist.cor' + + +2018-09-03 Aurélie Siberchicot + + * man/bacteria.Rd: Add url in the help page of 'bacteria' data + 2018-08-30 Aurélie Siberchicot * DESCRIPTION: ---------- release of ade4 1.7-13 ---------- diff -Nru ade4-1.7-13/debian/changelog ade4-1.7-16/debian/changelog --- ade4-1.7-13/debian/changelog 2021-01-15 00:29:17.000000000 +0000 +++ ade4-1.7-16/debian/changelog 2020-11-01 05:35:03.000000000 +0000 @@ -1,15 +1,15 @@ -ade4 (1.7-13-1cran1ppabionic0) bionic; urgency=medium +ade4 (1.7-16-1cran1.1804.0) bionic; urgency=medium - * Compilation for Ubuntu 18.04.1 LTS + * Compilation for Ubuntu 18.04.5 LTS * Build for c2d4u for R 3.5.0 - -- Michael Rutter Sun, 02 Sep 2018 13:24:14 +0000 + -- Michael Rutter Sun, 01 Nov 2020 05:35:03 +0000 -ade4 (1.7-13-1cran1) testing; urgency=low +ade4 (1.7-16-1cran1) testing; urgency=low * cran2deb svn: 362M with DB version 1. - -- cran2deb4ubuntu Sat, 01 Sep 2018 15:15:12 -0400 + -- cran2deb4ubuntu Sat, 31 Oct 2020 10:30:28 -0400 ade4 (1.7-8-1cran1) testing; urgency=low @@ -61,6 +61,20 @@ -- cran2deb4ubuntu Sun, 19 Apr 2015 09:38:06 -0400 +ade4 (1.7-15-1cran1) testing; urgency=low + + * cran2deb svn: 362M with DB version 1. + + -- cran2deb4ubuntu Sat, 15 Feb 2020 09:46:41 -0500 + + +ade4 (1.7-13-1cran1) testing; urgency=low + + * cran2deb svn: 362M with DB version 1. + + -- cran2deb4ubuntu Sat, 01 Sep 2018 15:15:22 -0400 + + ade4 (1.7-11-1cran1) testing; urgency=low * cran2deb svn: 362M with DB version 1. diff -Nru ade4-1.7-13/debian/compat ade4-1.7-16/debian/compat --- ade4-1.7-13/debian/compat 2021-01-15 00:29:17.000000000 +0000 +++ ade4-1.7-16/debian/compat 2020-10-31 14:30:28.000000000 +0000 @@ -1 +1 @@ -7 \ No newline at end of file +9 \ No newline at end of file diff -Nru ade4-1.7-13/debian/control ade4-1.7-16/debian/control --- ade4-1.7-13/debian/control 2021-01-15 00:29:17.000000000 +0000 +++ ade4-1.7-16/debian/control 2020-10-31 14:30:28.000000000 +0000 @@ -2,15 +2,16 @@ Section: gnu-r Priority: optional Maintainer: cran2deb4ubuntu -Build-Depends: r-base-dev, r-cran-mass, xvfb, xauth, xfonts-base, - r-base-core, debhelper (>> 4.1.0), cdbs -Standards-Version: 3.9.1 -Homepage: http://pbil.univ-lyon1.fr/ADE-4, Mailing list: - http://listes.univ-lyon1.fr/wws/info/adelist +Build-Depends: r-base-dev, r-cran-mass, r-cran-pixmap, r-cran-sp, + r-cran-progress, xvfb, xauth, xfonts-base, r-base-core, debhelper (>> + 4.1.0), cdbs +Standards-Version: 4.1.4 +Homepage: http://pbil.univ-lyon1.fr/ADE-4/ Package: r-cran-ade4 Architecture: any -Depends: r-base-core, r-cran-mass, ${shlibs:Depends} +Depends: r-base-core, r-cran-mass, r-cran-pixmap, r-cran-sp, + r-cran-progress, ${shlibs:Depends} Description: GNU R package "Analysis of Ecological Data: Exploratory and Euclidean Methods in Environmental Sciences" . diff -Nru ade4-1.7-13/debian/copyright ade4-1.7-16/debian/copyright --- ade4-1.7-13/debian/copyright 2021-01-15 00:29:17.000000000 +0000 +++ ade4-1.7-16/debian/copyright 2020-10-31 14:30:28.000000000 +0000 @@ -2,7 +2,7 @@ automatically using cran2deb4ubuntu by cran2deb4ubuntu . -The original GNU R package is Copyright (C) 2018 Stéphane Dray +The original GNU R package is Copyright (C) 2020 Stéphane Dray , Anne-Béatrice Dufour , and Jean Thioulouse , with contributions from Thibaut diff -Nru ade4-1.7-13/debian/source/format ade4-1.7-16/debian/source/format --- ade4-1.7-13/debian/source/format 1970-01-01 00:00:00.000000000 +0000 +++ ade4-1.7-16/debian/source/format 2020-10-31 14:30:28.000000000 +0000 @@ -0,0 +1 @@ +3.0 (quilt) \ No newline at end of file diff -Nru ade4-1.7-13/DESCRIPTION ade4-1.7-16/DESCRIPTION --- ade4-1.7-13/DESCRIPTION 2018-08-31 16:50:17.000000000 +0000 +++ ade4-1.7-16/DESCRIPTION 2020-10-28 11:10:02.000000000 +0000 @@ -1,21 +1,20 @@ Package: ade4 -Version: 1.7-13 -Date: 2018-08-30 +Version: 1.7-16 Title: Analysis of Ecological Data: Exploratory and Euclidean Methods in Environmental Sciences Author: Stéphane Dray , Anne-Béatrice Dufour , and Jean Thioulouse , with contributions from Thibaut Jombart, Sandrine Pavoine, Jean R. Lobry, Sébastien Ollier, Daniel Borcard, Pierre Legendre, Stéphanie Bougeard and Aurélie Siberchicot. Based on earlier work by Daniel Chessel. Maintainer: Aurélie Siberchicot Depends: R (>= 2.10) -Imports: graphics, grDevices, methods, stats, utils, MASS +Imports: graphics, grDevices, methods, stats, utils, MASS, pixmap, sp, + progress Suggests: ade4TkGUI, adegraphics, adephylo, ape, CircStats, deldir, - lattice, pixmap, sp, spdep, splancs, waveslim + lattice, 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) . License: GPL (>= 2) -URL: http://pbil.univ-lyon1.fr/ADE-4, Mailing list: - http://listes.univ-lyon1.fr/wws/info/adelist +URL: http://pbil.univ-lyon1.fr/ADE-4/ BugReports: https://github.com/sdray/ade4/issues Encoding: UTF-8 NeedsCompilation: yes -Packaged: 2018-08-30 15:37:01 UTC; aurelie +Packaged: 2020-10-28 09:07:53 UTC; siberchicot Repository: CRAN -Date/Publication: 2018-08-31 16:50:17 UTC +Date/Publication: 2020-10-28 11:10:02 UTC diff -Nru ade4-1.7-13/inst/CITATION ade4-1.7-16/inst/CITATION --- ade4-1.7-13/inst/CITATION 2018-08-30 15:22:16.000000000 +0000 +++ ade4-1.7-16/inst/CITATION 2020-10-16 11:22:21.000000000 +0000 @@ -1,9 +1,7 @@ bibentry(bibtype = "Article", title = "The {ade4} Package: Implementing the Duality Diagram for Ecologists", - author = c(person(given = "St\\'ephane", - family = "Dray"), - person(given = "Anne--B\\'eatrice", - family = "Dufour")), + author = c(person(given = "St\\'ephane", family = "Dray"), + person(given = "Anne--B\\'eatrice", family = "Dufour")), journal = "Journal of Statistical Software", year = "2007", volume = "22", @@ -16,12 +14,8 @@ bibentry(bibtype = "Article", title = "Supervised Multiblock Analysis in {R} with the {ade4} Package", - author = c(person(given = "St\\'ephanie", - family = "Bougeard", - email = "stephanie.bougeard@anses.fr"), - person(given = "St\\'ephane", - family = "Dray", - email = "stephane.dray@univ-lyon1.fr")), + author = c(person(given = "St\\'ephanie", family = "Bougeard", email = "stephanie.bougeard@anses.fr"), + person(given = "St\\'ephane", family = "Dray", email = "stephane.dray@univ-lyon1.fr")), journal = "Journal of Statistical Software", year = "2018", volume = "86", @@ -32,12 +26,9 @@ bibentry(bibtype = "Article", title = "The {ade4} Package -- {I}: One-Table Methods", - author = c(person(given = "Daniel", - family = "Chessel"), - person(given = "Anne-B\\'eatrice", - family = "Dufour"), - person(given = "Jean", - family = "Thioulouse")), + author = c(person(given = "Daniel", family = "Chessel"), + person(given = "Anne-B\\'eatrice", family = "Dufour"), + person(given = "Jean", family = "Thioulouse")), journal = "R News", year = "2004", volume = "4", @@ -48,12 +39,9 @@ bibentry(bibtype = "Article", title = "The {ade4} Package -- {II}: Two-Table and {K}-Table Methods", - author = c(person(given = "St\\'ephane", - family = "Dray"), - person(given = "Anne-B\\'eatrice", - family = "Dufour"), - person(given = "Daniel", - family = "Chessel")), + author = c(person(given = "St\\'ephane", family = "Dray"), + person(given = "Anne-B\\'eatrice", family = "Dufour"), + person(given = "Daniel", family = "Chessel")), journal = "R News", year = "2007", volume = "7", @@ -61,3 +49,16 @@ pages = "47--52", url = "https://cran.r-project.org/doc/Rnews/" ) + +bibentry(bibtype = "Book", + title = "Multivariate Analysis of Ecological Data with {ade4}", + author = c(person(given = "Jean", family = "Thioulouse"), + person(given = "St\\'ephane", family = "Dray"), + person(given = "Anne--B\\'eatrice", family = "Dufour"), + person(given = "Aur\\'elie", family = "Siberchicot"), + person(given = "Thibaut", family = "Jombart"), + person(given = "Sandrine", family = "Pavoine")), + year = "2018", + publisher = "Springer", + doi = "10.1007/978-1-4939-8850-1" +) \ No newline at end of file diff -Nru ade4-1.7-13/man/ade4-deprecated.Rd ade4-1.7-16/man/ade4-deprecated.Rd --- ade4-1.7-13/man/ade4-deprecated.Rd 2017-10-19 06:56:42.000000000 +0000 +++ ade4-1.7-16/man/ade4-deprecated.Rd 2020-10-16 11:22:21.000000000 +0000 @@ -8,7 +8,16 @@ - \code{between}: replaced by \code{bca} \cr - \code{betweencoinertia}: replaced by \code{bca.coinertia} \cr + - \code{char2genet}: replaced by \code{df2genind} and \code{genind2genpop} in the \code{adegenet} package \cr + - \code{count2genet}: replaced by \code{df2genind} and \code{genind2genpop} in the \code{adegenet} package \cr + - \code{dist.genet}: replaced by \code{dist.genpop} in the \code{adegenet} package \cr + - \code{EH}: replaced by \code{EH} in the \code{adiv} package \cr + - \code{freq2genet}: replaced by \code{df2genind} and \code{genind2genpop} in the \code{adegenet} package \cr + - \code{fuzzygenet}: replaced by \code{df2genind} in the \code{adegenet} package \cr + - \code{optimEH}: replaced by \code{optimEH} in the \code{adiv} package \cr + - \code{orisaved}: replaced by \code{orisaved} in the \code{adiv} package \cr - \code{orthogram}: replaced by \code{orthogram} in the \code{adephylo} package \cr + - \code{randEH}: replaced by \code{randEH} in the \code{adiv} package \cr - \code{within}: replaced by \code{wca} \cr - \code{withincoinertia}: replaced by \code{wca.coinertia} \cr } diff -Nru ade4-1.7-13/man/apis108.Rd ade4-1.7-16/man/apis108.Rd --- ade4-1.7-13/man/apis108.Rd 2015-10-14 11:19:58.000000000 +0000 +++ ade4-1.7-16/man/apis108.Rd 2020-10-16 11:22:21.000000000 +0000 @@ -11,15 +11,14 @@ Nimba, Celinda, Pretoria, Chalkidiki, Forli, Valenciennes, Umea and Seville). } \source{ -\url{http://www.montpellier.inra.fr/URLB/apis/libanfreq.pdf}\cr +\url{http://www1.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) +str(apis108) +names(apis108) } \keyword{datasets} diff -Nru ade4-1.7-13/man/arrival.Rd ade4-1.7-16/man/arrival.Rd --- ade4-1.7-13/man/arrival.Rd 2017-04-20 09:34:04.000000000 +0000 +++ ade4-1.7-16/man/arrival.Rd 2020-10-20 11:48:48.000000000 +0000 @@ -13,7 +13,7 @@ \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@kovcomp.com} starting from \url{http://www.kovcomp.com/oriana/index.html}. +Data taken from the Oriana software developped by Warren L. Kovach \email{sales@kovcomp.com} starting from \url{https://www.kovcomp.co.uk/oriana/index.html}. } \references{ Fisher, N. I. (1993) \emph{Statistical Analysis of Circular Data}. Cambridge University Press. diff -Nru ade4-1.7-13/man/bacteria.Rd ade4-1.7-16/man/bacteria.Rd --- ade4-1.7-13/man/bacteria.Rd 2018-08-30 15:29:12.000000000 +0000 +++ ade4-1.7-16/man/bacteria.Rd 2020-10-16 11:22:21.000000000 +0000 @@ -16,7 +16,7 @@ } } \source{ -Data prepared by J. Lobry \email{Jean.Lobry@univ-lyon1.fr} +Data prepared by J. Lobry \email{Jean.Lobry@univ-lyon1.fr} starting from \url{https://www.jcvi.org/}. } \examples{ data(bacteria) diff -Nru ade4-1.7-13/man/cailliez.Rd ade4-1.7-16/man/cailliez.Rd --- ade4-1.7-13/man/cailliez.Rd 2016-11-28 08:50:20.000000000 +0000 +++ ade4-1.7-16/man/cailliez.Rd 2020-10-16 11:22:21.000000000 +0000 @@ -24,8 +24,6 @@ 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 diff -Nru ade4-1.7-13/man/casitas.Rd ade4-1.7-16/man/casitas.Rd --- ade4-1.7-13/man/casitas.Rd 2017-02-16 08:58:41.000000000 +0000 +++ ade4-1.7-16/man/casitas.Rd 2020-10-20 11:43:44.000000000 +0000 @@ -20,7 +20,7 @@ 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/} +\url{https://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 @@ -28,10 +28,7 @@ } \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) +str(casitas) +names(casitas) } \keyword{datasets} diff -Nru ade4-1.7-13/man/chevaine.Rd ade4-1.7-16/man/chevaine.Rd --- ade4-1.7-13/man/chevaine.Rd 2015-10-14 11:19:58.000000000 +0000 +++ ade4-1.7-16/man/chevaine.Rd 2020-10-16 11:22:21.000000000 +0000 @@ -22,40 +22,7 @@ } \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) -} +names(chevaine) +str(chevaine) } \keyword{datasets} diff -Nru ade4-1.7-13/man/dist.genet.Rd ade4-1.7-16/man/dist.genet.Rd --- ade4-1.7-13/man/dist.genet.Rd 2017-11-02 14:18:34.000000000 +0000 +++ ade4-1.7-16/man/dist.genet.Rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,99 +0,0 @@ -\name{dist.genet} -\alias{dist.genet} -\title{ Genetic distances from gene frequencies } -\description{ - This function is deprecated. See the \code{dist.genpop} function in the package \code{adegenet}. - - 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@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 -Nru ade4-1.7-13/man/EH.Rd ade4-1.7-16/man/EH.Rd --- ade4-1.7-13/man/EH.Rd 2017-10-19 11:30:03.000000000 +0000 +++ ade4-1.7-16/man/EH.Rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -\name{EH} -\alias{EH} -\title{Amount of Evolutionary History -} -\description{ -This function is deprecated. See the function \code{EH} in the package \code{adiv}. - -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@mnhn.fr} -} -\examples{ -data(carni70) -carni70.phy <- newick2phylog(carni70$tre) -EH(carni70.phy) -EH(carni70.phy, select = 1:15) # Felidae -} -\keyword{multivariate} diff -Nru ade4-1.7-13/man/fuzzygenet.Rd ade4-1.7-16/man/fuzzygenet.Rd --- ade4-1.7-13/man/fuzzygenet.Rd 2017-11-02 14:18:48.000000000 +0000 +++ ade4-1.7-16/man/fuzzygenet.Rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,48 +0,0 @@ -\name{fuzzygenet} -\alias{fuzzygenet} -\title{ Reading a table of genetic data (diploid individuals) } -\description{ - This function is deprecated. See the \code{df2genind} function in the package \code{adegenet}. - - 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 -Nru ade4-1.7-13/man/genet.Rd ade4-1.7-16/man/genet.Rd --- ade4-1.7-13/man/genet.Rd 2017-11-02 14:20:22.000000000 +0000 +++ ade4-1.7-16/man/genet.Rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,78 +0,0 @@ -\name{genet} -\alias{genet} -\alias{char2genet} -\alias{count2genet} -\alias{freq2genet} -\title{A class of data: tables of populations and alleles} -\description{ -These functions are deprecated. See the \code{df2genind} and \code{genind2genpop} functions in the package \code{adegenet}. - -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 -Nru ade4-1.7-13/man/hdpg.Rd ade4-1.7-16/man/hdpg.Rd --- ade4-1.7-13/man/hdpg.Rd 2015-10-14 11:19:58.000000000 +0000 +++ ade4-1.7-16/man/hdpg.Rd 2020-10-16 11:22:21.000000000 +0000 @@ -56,19 +56,8 @@ \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) -}} +data(hdpg) +names(hdpg) +str(hdpg) } \keyword{datasets} diff -Nru ade4-1.7-13/man/kcponds.Rd ade4-1.7-16/man/kcponds.Rd --- ade4-1.7-13/man/kcponds.Rd 2017-11-03 13:01:24.000000000 +0000 +++ ade4-1.7-16/man/kcponds.Rd 2020-10-20 11:51:18.000000000 +0000 @@ -32,7 +32,7 @@ \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} + \url{https://bio.kuleuven.be/eco/phdkarlcottenie.pdf} } \examples{ diff -Nru ade4-1.7-13/man/kdisteuclid.Rd ade4-1.7-16/man/kdisteuclid.Rd --- ade4-1.7-13/man/kdisteuclid.Rd 2016-11-28 08:50:18.000000000 +0000 +++ ade4-1.7-16/man/kdisteuclid.Rd 2020-10-16 11:22:21.000000000 +0000 @@ -31,9 +31,6 @@ Stéphane Dray \email{stephane.dray@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. diff -Nru ade4-1.7-13/man/kdist.Rd ade4-1.7-16/man/kdist.Rd --- ade4-1.7-13/man/kdist.Rd 2016-11-28 09:00:53.000000000 +0000 +++ ade4-1.7-16/man/kdist.Rd 2020-10-16 11:22:21.000000000 +0000 @@ -76,7 +76,7 @@ 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("JACCARD", "SOKAL_MICHENER", "SOKAL_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 diff -Nru ade4-1.7-13/man/krandtest.Rd ade4-1.7-16/man/krandtest.Rd --- ade4-1.7-13/man/krandtest.Rd 2017-02-14 17:02:38.000000000 +0000 +++ ade4-1.7-16/man/krandtest.Rd 2020-10-16 11:22:21.000000000 +0000 @@ -3,43 +3,60 @@ \alias{plot.krandtest} \alias{print.krandtest} \alias{as.krandtest} +\alias{[.krandtest} +\alias{[[.krandtest} + \title{Class of the Permutation Tests (in C).} + \description{ -Plot and print many permutation tests. Objects of class \code{'krandtest'} are lists. +Plot, print and extract permutation tests. Objects of class \code{'krandtest'} are lists. } + \usage{ +as.krandtest(sim, obs, alter = "greater", call = match.call(), + names = colnames(sim), p.adjust.method = "none", output = c("light", "full")) + \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")) +\method{[}{krandtest}(x, i) +\method{[[}{krandtest}(x, i) } + \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.} +\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.} +\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{i}{numeric indices specifying elements to extract} } + \value{ \code{plot.krandtest} draws the \emph{p} simulated values histograms and the position of the observed value. +\code{[.krandtest} returns a \code{krandtest} object and +\code{[[.krandtest} returns a \code{randtest} object. } + \author{Daniel Chessel and Stéphane Dray \email{stephane.dray@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 <- 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) +wkrandtest[c(1, 4, 6)] +wkrandtest[[1]] } + \keyword{methods} diff -Nru ade4-1.7-13/man/loocv.bca.Rd ade4-1.7-16/man/loocv.bca.Rd --- ade4-1.7-13/man/loocv.bca.Rd 1970-01-01 00:00:00.000000000 +0000 +++ ade4-1.7-16/man/loocv.bca.Rd 2020-10-28 08:00:29.000000000 +0000 @@ -0,0 +1,77 @@ +\name{loocv.between} +\alias{loocv.between} +\title{ +Leave-one-out cross-validation for a \code{bca} +} +\description{ +Leave-one-out cross-validation to test the existence of spurious groups in \code{bca} in the case p (number of variables) > n (number of samples). +} +\usage{ +\method{loocv}{between}(x, progress = FALSE, \dots) +} +\arguments{ + \item{x}{ +the dudi of the \code{bca} on which cross-validation should be done +} + \item{progress}{ +logical to display a progress bar during computations (see the \code{progress} package) +} + \item{\dots}{further arguments passed to or from other methods} +} +\details{ +This function returns a list containing the cross-validated coordinates of the rows (the rows of the original analysis, not the rows of the \code{bca}). The analysis on which the \code{bca} was computed is redone after removing each row of the data table, one at a time. A \code{bca} is done on this new analysis and the coordinates of the missing row are computed by projection as supplementary element in the corresponding \code{bca}. This is mostly useful in the case p >> n (many variables and few samples), where \code{bca} graphs can show spurious groups (see Refs.) +} +\value{ +{A list with the cross-validated row coordinates \code{XValCoord}, the Predicted Residual Error Sum (\code{PRESS}, for each row and \code{PRESSTot}, its sum for each \code{bca} axis), the Root Mean Square Error (\code{RMSE}) and the IQR-standardized RMSE (\code{RMSEIQR}) for each \code{bca} axis. +} +} +\references{ +Cardini A, O'Higgins P, Rohlf J. Seeing Distinct Groups Where There are None: Spurious Patterns from Between-Group PCA. Evolutionary Biology (2019) 46:303-316 + +Cardini A, Polly D. Cross-validated Between Group PCA Scatterplots: A Solution to Spurious Group Separation? Evolutionary Biology (2020) https://doi.org/10.1007/s11692-020-09494-x + +Bookstein F. Pathologies of Between-Groups Principal Components Analysis in Geometric Morphometrics. Evolutionary Biology (2019) 46:271-302 +} +\author{ +Jean Thioulouse +} +\seealso{ +\link{loocv.dudi} +} +\examples{ +# Data = meaudret +data(meaudret) +pca1 <- dudi.pca(meaudret$env, scannf = FALSE, nf = 3) +bca1 <- bca(pca1, meaudret$design$site, scannf = FALSE, nf = 3) +pst1 <- paste0("Meaudret BGA randtest: p=", +randtest(bca1)$pvalue, " ratio=", round(bca1$ratio, 2)) + +if(adegraphicsLoaded()){ + sc1 <- s.class(bca1$ls, meaudret$design$site, col = TRUE, + psub.text = pst1, ellipseSize=0, chullSize=1, plot = FALSE) + xbca1 <- loocv(bca1, progress = TRUE) + sc2 <- s.class(xbca1$XValCoord, meaudret$design$site, + col = TRUE, psub.text = "Meaudret cross-validation", + ellipseSize=0, chullSize=1, plot = FALSE) + ADEgS(list(sc1, sc2)) +} +\dontrun{ +# Data = rnorm() +set.seed(9) +fac1 <- as.factor(rep(1:3, each = 10)) +tab <- as.data.frame(matrix(rnorm(10800), nrow = 30)) +pca2 <- dudi.pca(tab, scannf = FALSE) +bca2 <- bca(pca2, fac1, scannf = FALSE) +pst2 <- paste0("rnorm spurious groups: p=", +randtest(bca2)$pvalue, " ratio=", round(bca2$ratio, 2)) +sc3 <- s.class(bca2$ls, fac1, col = TRUE, +psub.text = pst2, ellipseSize=0, chullSize=1, +xlim = c(-8, 8), ylim = c(-8, 8), plot = FALSE) +xbca2 <- loocv(bca2, progress = TRUE) +sc4 <- s.class(xbca2$XValCoord, fac1, col = TRUE, +psub.text = "rnorm cross-validation", ellipseSize=0, +chullSize=1, xlim = c(-8, 8), ylim = c(-8, 8), plot = FALSE) +ADEgS(list(sc3, sc4))}} + +\keyword{dplot} +\keyword{multivariate} diff -Nru ade4-1.7-13/man/loocv.discrimin.Rd ade4-1.7-16/man/loocv.discrimin.Rd --- ade4-1.7-13/man/loocv.discrimin.Rd 1970-01-01 00:00:00.000000000 +0000 +++ ade4-1.7-16/man/loocv.discrimin.Rd 2020-10-27 15:47:22.000000000 +0000 @@ -0,0 +1,89 @@ +\name{loocv.discrimin} +\alias{loocv.discrimin} +\title{ +Leave-one-out cross-validation for a \code{discrimin} analysis +} +\description{ +Leave-one-out cross-validation to test the existence of groups in a \code{discrimin} analysis. +} +\usage{ +\method{loocv}{discrimin}(x, progress = FALSE, \dots) +} +\arguments{ + \item{x}{ +the \code{discrimin} analysis on which cross-validation should be done +} + \item{progress}{ +logical to display a progress bar during computations (see the \code{progress} package) +} + \item{\dots}{further arguments passed to or from other methods} +} +\details{ +This function returns a list containing the cross-validated coordinates of the rows. The analysis on which the \code{discrimin} was computed is redone after removing each row of the data table, one at a time. A \code{discrimin} analysis is done on this new analysis and the coordinates of the missing row are computed by projection as supplementary element in the new \code{discrimin} analysis. This can be useful to check that the groups evidenced by the \code{discrimin} analysis are supported. +} +\value{ +{A list with the cross-validated row coordinates \code{XValCoord}, the Predicted Residual Error Sum (\code{PRESS}, for each row and \code{PRESSTot}, its sum for each \code{discrimin} axis), the Root Mean Square Error (\code{RMSE}) and the IQR-standardized RMSE (\code{RMSEIQR}) for each \code{discrimin} axis. +} +} +\author{ +Jean Thioulouse +} +\seealso{ +\link{loocv.dudi} +\link{loocv.between} +} +\examples{ +\dontrun{ +# Data = skulls +data(skulls) +pcaskul <- dudi.pca(skulls, scan = FALSE) +facskul <- gl(5,30) +diskul <- discrimin(pcaskul, facskul, scan = FALSE) +xdiskul <- loocv(diskul, progress = TRUE) +pst1 <- paste0("Skulls discrimin randtest: p=", round(randtest(diskul)$pvalue, 4)) +pst2 <- paste0("Skulls cross-validation: Ax1= ", round(xdiskul$RMSEIQR[1],2), +" Ax2= ", round(xdiskul$RMSEIQR[2],2)) +if (adegraphicsLoaded()) { + sc1 <- s.class(diskul$li, facskul, col = TRUE, psub.text = pst1, ellipseSize=0, + chullSize=1, plot = FALSE) + sc2 <- s.class(xdiskul$XValCoord, facskul, col = TRUE, psub.text = pst2, + ellipseSize=0, chullSize=1, plot = FALSE) + ADEgS(list(sc1, sc2), layout=c(2,2)) +} else { + par(mfrow=c(2,2)) + s.class(diskul$li, facskul, sub = pst1) + s.class(xdiskul$XValCoord, facskul, sub = pst2) +} +data(chazeb) +pcacz <- dudi.pca(chazeb$tab, scan = FALSE) +discz <- discrimin(pcacz, chazeb$cla, scan = FALSE) +xdiscz <- loocv(discz, progress = TRUE) +pst1 <- paste0("Chazeb discrimin randtest: p=", round(randtest(discz)$pvalue, 4)) +pst2 <- paste0("Chazeb cross-validation: Axis 1= ", round(xdiscz$RMSEIQR[1],2)) +if (adegraphicsLoaded()) { + tabi <- cbind(discz$li, pcacz$tab) + gr1 <- s.class(tabi, xax=1, yax=2:7, chazeb$cla, col = TRUE, plot = FALSE) + for (i in 1:6) gr1[[i]] <- update(gr1[[i]], psub.text = names(tabi)[i+1], + plot = FALSE) + pos1 <- gr1@positions + pos1[,1] <- c(0, .3333, .6667, 0, .3333, .6667) + pos1[,2] <- c(.6667, .6667, .6667, .3333, .3333, .3333) + pos1[,3] <- c(.3333, .6667, 1, .3333, .6667, 1) + pos1[,4] <- c(1, 1, 1, .6667, .6667, .6667) + gr1@positions <- pos1 + sc1 <- s1d.gauss(discz$li, chazeb$cla, col = TRUE, psub.text = pst1, + plot = FALSE) + sc2 <- s1d.gauss(xdiscz$XValCoord, chazeb$cla, col = TRUE, psub.text = pst2, + plot = FALSE) + ADEgS(list(gr1[[1]], gr1[[2]], gr1[[3]], gr1[[4]], gr1[[5]], gr1[[6]], sc1, sc2)) +} else { + plot(discz) + sco.gauss(discz$li[,1], as.data.frame(chazeb$cla), sub = pst1, + legen = FALSE) + sco.gauss(xdiscz$XValCoord[,1], as.data.frame(chazeb$cla), sub = pst2, + legen = FALSE) +} +}} + +\keyword{dplot} +\keyword{multivariate} diff -Nru ade4-1.7-13/man/loocv.dudi.Rd ade4-1.7-16/man/loocv.dudi.Rd --- ade4-1.7-13/man/loocv.dudi.Rd 1970-01-01 00:00:00.000000000 +0000 +++ ade4-1.7-16/man/loocv.dudi.Rd 2020-10-27 16:09:24.000000000 +0000 @@ -0,0 +1,42 @@ +\name{loocv.dudi} +\alias{loocv.dudi} +\alias{loocv} +\title{ +Leave-one-out cross-validation for a \code{dudi} +} +\description{ +Leave-one-out cross-validation to check the dispersion of row coordinates in a \code{dudi}. +} +\usage{ +\method{loocv}{dudi}(x, progress = FALSE, \dots) +} +\arguments{ + \item{x}{ +the dudi of the \code{bca} on which cross-validation should be done +} + \item{progress}{ +logical to display a progress bar during computations (see the \code{progress} package) +} + \item{\dots}{further arguments passed to or from other methods} +} +\details{ +This function returns a list with two elements: \code{$XValCoord} and \code{$lsFac}, the cross-validated row coordinates and a factor to plot them. The analysis is redone after removing each row of the data table, one at a time. The coordinates of the missing row are computed by projection as supplementary element in the \code{dudi} space. This can be used to check the dispersion of the coordinates of one point and it's sensitivity to outliers. +} +\value{ +{a list with two elements: \code{$XValCoord} and \code{$lsFac} containing the cross-validated row coordinates and the factor to plot them using the \code{s.class} (see example).} +} +\author{ +Jean Thioulouse +} +\seealso{ +\link{suprow} +} +\examples{ +data(meaudret) +envpca <- dudi.pca(meaudret$env, scannf = FALSE, nf = 3) +xvpca <- loocv(envpca) +s.match(envpca$li, xvpca$XValCoord) +} + +\keyword{dplot} +\keyword{multivariate} diff -Nru ade4-1.7-13/man/mbpcaiv.Rd ade4-1.7-16/man/mbpcaiv.Rd --- ade4-1.7-13/man/mbpcaiv.Rd 2018-08-30 06:55:42.000000000 +0000 +++ ade4-1.7-16/man/mbpcaiv.Rd 2020-10-20 11:42:51.000000000 +0000 @@ -51,7 +51,7 @@ \references{Bougeard, S., Qannari, E.M. and Rose, N. (2011) Multiblock Redundancy Analysis: interpretation tools and application in epidemiology. \emph{Journal of Chemometrics}, \bold{23}, 1-9 -Bougeard, S. and Dray S. (2018) Supervised Multiblock Analysis in R with the ade4 Package. \emph{Journal of Statistical Software}, \bold{86} (1), 1-17. \url{http://doi.org/10.18637/jss.v086.i01} +Bougeard, S. and Dray S. (2018) Supervised Multiblock Analysis in R with the ade4 Package. \emph{Journal of Statistical Software}, \bold{86} (1), 1-17. \url{https://doi.org/10.18637/jss.v086.i01} } \author{Stéphanie Bougeard (\email{stephanie.bougeard@anses.fr}) and Stéphane Dray (\email{stephane.dray@univ-lyon1.fr})} diff -Nru ade4-1.7-13/man/mbpls.Rd ade4-1.7-16/man/mbpls.Rd --- ade4-1.7-13/man/mbpls.Rd 2018-08-30 06:55:42.000000000 +0000 +++ ade4-1.7-16/man/mbpls.Rd 2020-10-20 11:43:07.000000000 +0000 @@ -48,7 +48,7 @@ } \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 -Bougeard, S. and Dray S. (2018) Supervised Multiblock Analysis in R with the ade4 Package. \emph{Journal of Statistical Software}, \bold{86} (1), 1-17. \url{http://doi.org/10.18637/jss.v086.i01}} +Bougeard, S. and Dray S. (2018) Supervised Multiblock Analysis in R with the ade4 Package. \emph{Journal of Statistical Software}, \bold{86} (1), 1-17. \url{https://doi.org/10.18637/jss.v086.i01}} \author{Stéphanie Bougeard (\email{stephanie.bougeard@anses.fr}) and Stéphane Dray (\email{stephane.dray@univ-lyon1.fr})} diff -Nru ade4-1.7-13/man/multiblock.Rd ade4-1.7-16/man/multiblock.Rd --- ade4-1.7-13/man/multiblock.Rd 2018-08-30 06:55:42.000000000 +0000 +++ ade4-1.7-16/man/multiblock.Rd 2020-10-20 11:43:16.000000000 +0000 @@ -17,7 +17,7 @@ \item{\dots}{other arguments to be passed to methods} } -\references{Bougeard, S. and Dray S. (2018) Supervised Multiblock Analysis in R with the ade4 Package. \emph{Journal of Statistical Software}, \bold{86} (1), 1-17. \url{http://doi.org/10.18637/jss.v086.i01}} +\references{Bougeard, S. and Dray S. (2018) Supervised Multiblock Analysis in R with the ade4 Package. \emph{Journal of Statistical Software}, \bold{86} (1), 1-17. \url{https://doi.org/10.18637/jss.v086.i01}} \author{Stéphanie Bougeard (\email{stephanie.bougeard@anses.fr}) and Stéphane Dray (\email{stephane.dray@univ-lyon1.fr})} diff -Nru ade4-1.7-13/man/multispati.Rd ade4-1.7-16/man/multispati.Rd --- ade4-1.7-13/man/multispati.Rd 2017-11-03 13:01:24.000000000 +0000 +++ ade4-1.7-16/man/multispati.Rd 2020-10-16 11:22:21.000000000 +0000 @@ -5,7 +5,7 @@ \alias{print.multispati} \title{Multivariate spatial analysis} \description{ -This function is deprecated. See the function \code{multispati} in the package \code{adespatial}. +These functions are deprecated. See the function \code{multispati} and the methods \code{plot.multispati}, \code{summary.multispati} and \code{print.multispati} in the package \code{adespatial}. 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, diff -Nru ade4-1.7-13/man/optimEH.Rd ade4-1.7-16/man/optimEH.Rd --- ade4-1.7-13/man/optimEH.Rd 2017-11-02 12:18:50.000000000 +0000 +++ ade4-1.7-16/man/optimEH.Rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,53 +0,0 @@ -\name{optimEH} -\alias{optimEH} -\title{Nee and May's optimizing process -} -\description{ -This function is deprecated. See the function \code{optimEH} in the package \code{adiv}. - -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@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 -Nru ade4-1.7-13/man/oribatid.Rd ade4-1.7-16/man/oribatid.Rd --- ade4-1.7-13/man/oribatid.Rd 2017-01-18 10:02:19.000000000 +0000 +++ ade4-1.7-16/man/oribatid.Rd 2020-10-16 11:22:21.000000000 +0000 @@ -22,9 +22,7 @@ water: water content of the substratum (\eqn{g.L^{-1}}{g.L^-1}) } \source{ -Data prepared by P. Legendre \email{Pierre.Legendre@umontreal.ca} and \cr -D. Borcard \email{borcardd@magellan.umontreal.ca} starting from \cr -\url{http://www.fas.umontreal.ca/biol/casgrain/fr/labo/oribates.html}\cr +Data prepared by P. Legendre \email{Pierre.Legendre@umontreal.ca} and D. Borcard \email{borcardd@magellan.umontreal.ca} } \references{ Borcard, D., and Legendre, P. (1994) Environmental control and spatial structure in ecological communities: diff -Nru ade4-1.7-13/man/orisaved.Rd ade4-1.7-16/man/orisaved.Rd --- ade4-1.7-13/man/orisaved.Rd 2017-11-02 12:19:56.000000000 +0000 +++ ade4-1.7-16/man/orisaved.Rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,49 +0,0 @@ -\name{orisaved} -\alias{orisaved} -\title{Maximal or minimal amount of originality saved under optimal conditions -} -\description{ -This function is deprecated. See the function \code{orisaved} in the package \code{adiv}. - -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@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 -Nru ade4-1.7-13/man/pcw.Rd ade4-1.7-16/man/pcw.Rd --- ade4-1.7-13/man/pcw.Rd 2017-01-23 16:08:36.000000000 +0000 +++ ade4-1.7-16/man/pcw.Rd 2020-10-27 14:58:21.000000000 +0000 @@ -5,7 +5,7 @@ \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} + \url{https://science.sciencemag.org/content/suppl/2002/01/24/295.5555.666.DC1} but plots from Barro Colorado Island were removed. } \usage{data(pcw)} @@ -25,7 +25,7 @@ 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. + in tropical forest trees. \emph{Science}, \bold{295}, 666-669. Pyke, C. R., R. Condit, S. Aguilar, and S. Lao. (2001) Floristic diff -Nru ade4-1.7-13/man/presid2002.Rd ade4-1.7-16/man/presid2002.Rd --- ade4-1.7-13/man/presid2002.Rd 2017-01-18 10:24:16.000000000 +0000 +++ ade4-1.7-16/man/presid2002.Rd 2020-10-20 11:44:55.000000000 +0000 @@ -21,7 +21,7 @@ } \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/} +\url{https://www.interieur.gouv.fr/Elections/Les-resultats/Presidentielles/elecresult__presidentielle_2002/} } \seealso{ This dataset is compatible with \code{elec88} and \code{cnc2003}} diff -Nru ade4-1.7-13/man/randboot.multiblock.Rd ade4-1.7-16/man/randboot.multiblock.Rd --- ade4-1.7-13/man/randboot.multiblock.Rd 2018-08-30 06:55:42.000000000 +0000 +++ ade4-1.7-16/man/randboot.multiblock.Rd 2020-10-20 11:43:22.000000000 +0000 @@ -20,7 +20,7 @@ \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. -Bougeard, S. and Dray S. (2018) Supervised Multiblock Analysis in R with the ade4 Package. \emph{Journal of Statistical Software}, \bold{86} (1), 1-17. \url{http://doi.org/10.18637/jss.v086.i01}} +Bougeard, S. and Dray S. (2018) Supervised Multiblock Analysis in R with the ade4 Package. \emph{Journal of Statistical Software}, \bold{86} (1), 1-17. \url{https://doi.org/10.18637/jss.v086.i01}} \author{Stéphanie Bougeard (\email{stephanie.bougeard@anses.fr}) and Stéphane Dray (\email{stephane.dray@univ-lyon1.fr})} \seealso{\code{\link{mbpcaiv}}, \code{\link{mbpls}}, diff -Nru ade4-1.7-13/man/randEH.Rd ade4-1.7-16/man/randEH.Rd --- ade4-1.7-13/man/randEH.Rd 2017-11-02 12:19:25.000000000 +0000 +++ ade4-1.7-16/man/randEH.Rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -\name{randEH} -\alias{randEH} -\title{Nee and May's random process -} -\description{ -This function is deprecated. See the function \code{randEH} in the package \code{adiv}. - -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@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 -Nru ade4-1.7-13/man/randtest.dpcoa.Rd ade4-1.7-16/man/randtest.dpcoa.Rd --- ade4-1.7-13/man/randtest.dpcoa.Rd 2015-11-26 09:42:57.000000000 +0000 +++ ade4-1.7-16/man/randtest.dpcoa.Rd 2020-10-16 11:22:21.000000000 +0000 @@ -8,13 +8,13 @@ } \usage{ -\method{randtest}{dpcoa}(xtest, model = c("1p","1s"), nrep = 99, +\method{randtest}{dpcoa}(xtest, model = c("1p","1s"), nrepet = 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{nrepet}{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} } diff -Nru ade4-1.7-13/man/randtest.Rd ade4-1.7-16/man/randtest.Rd --- ade4-1.7-13/man/randtest.Rd 2018-01-05 09:59:01.000000000 +0000 +++ ade4-1.7-16/man/randtest.Rd 2020-10-16 11:22:21.000000000 +0000 @@ -3,58 +3,60 @@ \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 + +\description{\code{randtest} is a generic function. It proposes methods for the following objects \code{between}, \code{discrimin}, \code{coinertia} \code{\dots} } + \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(), subclass = NULL) - \method{print}{randtest}(x, \dots) +randtest(xtest, \dots) +as.randtest(sim, obs, alter = c("greater", "less", "two-sided"), + output = c("light", "full"), call = match.call(), subclass = NULL) + +\method{plot}{randtest}(x, nclass = 10, coeff = 1, \dots) +\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{\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{alter}{a character string specifying the alternative hypothesis, must be one of "greater" (default), "less" or "two-sided"} \item{call}{a call order} \item{subclass}{a character vector indicating the subclasses associated to the returned object} } + \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 +\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. } + \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 +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))) + 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 -Nru ade4-1.7-13/man/s.kde2d.Rd ade4-1.7-16/man/s.kde2d.Rd --- ade4-1.7-13/man/s.kde2d.Rd 2017-01-18 08:54:53.000000000 +0000 +++ ade4-1.7-16/man/s.kde2d.Rd 2020-10-16 11:22:21.000000000 +0000 @@ -54,14 +54,9 @@ \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) - } + data(rpjdl) + coa1 <- dudi.coa(rpjdl$fau, scannf = FALSE, nf = 3) + s.kde2d(coa1$li) } } \keyword{multivariate} diff -Nru ade4-1.7-13/man/suprow.pta.Rd ade4-1.7-16/man/suprow.pta.Rd --- ade4-1.7-13/man/suprow.pta.Rd 1970-01-01 00:00:00.000000000 +0000 +++ ade4-1.7-16/man/suprow.pta.Rd 2020-10-16 11:22:21.000000000 +0000 @@ -0,0 +1,91 @@ +\name{suprow.pta} +\alias{suprow.pta} +\title{ +Projections of Supplementary Rows for a Partial Triadic Analysis of K-tables +} +\description{ +This function performs a projection of supplementary rows (i.e. supplementary individuals) for a Partial Triadic Analysis (\code{pta}) of K-tables. +Computations are valid ONLY if the \code{pta} has been done on a K-Tables obtained by the \code{withinpca} function, followed by calls to the \code{ktab.within} and \code{t} functions. +} +\usage{ +\method{suprow}{pta}(x, Xsup, facSup, \dots) +} +\arguments{ + \item{x}{an object of class \code{pta}} + \item{Xsup}{a table with the supplementary rows} + \item{facSup}{a factor partitioning the rows of \code{Xsup}} + \item{\dots}{further arguments passed to or from other methods} +} +\details{ +This function computes the coordinates of the supplementary rows for a K-tables. +The table of supplementary rows is standardized according to the 'Bouroche' standardization used in the Within Analysis of the original \code{pta}. +In a first step, the table of supplementary rows is standardized (centred and normed) with the mean and variance of the original table of active individuals (i.e. the K-tables used in \code{pta}). Then, according to the \code{withinpca} procedure, a second transformation is applied. + +For "partial", supplementary rows are standardized in each sub-table (corresponding to each level of the factor) by the mean and variance of each corresponding sub-sample in the table of active individuals. Hence, supplementary rows have null mean and unit variance in each sub-table. + +For "total", supplementary rows are centred in each sub-table with the mean of each coresponding sub-sample in the table of active individuals and then normed with the global variance ot the table of active individuals. Hence, supplementary rows have a null mean in each sub-table and a global variance equal to one. +} +\value{ +Returns a list with the transformed table \code{Xsup} in \code{tabsup} and the coordinates of the supplementary rows in \code{lisup}. +} +\author{ +Benjamin Alric \email{benjamin.alric@irstea.fr} \cr +Jean Thioulouse \email{jean.thioulouse@univ-lyon1.fr} +} +\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. +} +\examples{ +data(meau) +# Active rows +actenv <- meau$env[meau$design$site != "S6", -c(5)] +actfac <- meau$design$season[meau$design$site != "S6"] +# Suplementary rows +supenv <- meau$env[meau$design$site == "S6", -c(5)] +supfac <- meau$design$season[meau$design$site == "S6"] +# Total = active + suplementary rows +totenv <- meau$env[, -c(5)] +totfac <- meau$design$season +# PTA with 6 sampling sites +wittot <- withinpca(df = totenv, fac = totfac, scannf = FALSE, scaling = "partial") +kta1tot <- ktab.within(wittot, colnames = rep(c("S1", "S2", "S3", "S4", "S5", "S6"), 4)) +kta2tot <- t(kta1tot) +pta1tot <- pta(kta2tot, scann = FALSE) +# PTA with 5 sampling sites and site 6 added as supplementary element +wit1 <- withinpca(df = actenv, fac = actfac, scannf = FALSE, scaling = "partial") +kta1 <- ktab.within(wit1, colnames = rep(c("S1", "S2", "S3", "S4", "S5"), 4)) +kta2 <- t(kta1) +pta1 <- pta(kta2, scann = FALSE) +supenv.pta <- suprow(x = pta1, Xsup = supenv, facSup = supfac) +if (adegraphicsLoaded()) { +# g1t = active + suplementary rows + g1t <- s.label(pta1tot$Tli, labels = rownames(totenv), + plabels = list(box = list(draw = FALSE), optim = TRUE), xlim = c(-6, 5), ylim = c(-5, 5), + psub = list(text="Total", position="topleft"), plot = FALSE) +# g1 = Active rows + g1 <- s.label(pta1$Tli, labels = rownames(actenv), + plabels = list(box = list(draw = FALSE), optim =TRUE), xlim = c(-6, 5), ylim = c(-5, 5), + psub = list(text="Active", position="topleft"), pgrid = list(text=list(cex = 0)), + plot = FALSE) +# g2 = Supplementary rows + g2 <- s.label(supenv.pta$lisup, plabels = list(box = list(draw = FALSE), optim = TRUE), + ppoints = list(col = "red"), psub = list(text="Supplementary", position="topright"), + pgrid = list(text=list(cex = 0)), plot = FALSE) +# g3 = superposition of active and suplementary rows + g3 <- g1 + g2 +# Comparison of the total analysis and the analysis with supplementary rows + ADEgS(list(g1t,g3)) +} else { + par(mfrow=c(2,2)) +# g1t = active + suplementary rows + g1t <- s.label(pta1tot$Tli, label = rownames(totenv), xlim = c(-6, 5), ylim = c(-5, 5), + sub="Total") +# g1 = Active rows + g1 <- s.label(pta1$Tli, label = rownames(actenv), clabel = 1, xlim = c(-6, 5), + ylim = c(-5, 5), sub="Active+Supplementary") +# g2 = Supplementary rows + g2 <- s.label(supenv.pta$lisup, clabel = 1.5, xlim = c(-6, 5), ylim = c(-5, 5), + add.plot = TRUE) +} +} +\keyword{multivariate} \ No newline at end of file diff -Nru ade4-1.7-13/man/testdim.multiblock.Rd ade4-1.7-16/man/testdim.multiblock.Rd --- ade4-1.7-13/man/testdim.multiblock.Rd 2018-08-30 06:55:42.000000000 +0000 +++ ade4-1.7-16/man/testdim.multiblock.Rd 2020-10-20 11:43:31.000000000 +0000 @@ -19,7 +19,7 @@ \references{Stone M. (1974) Cross-validatory choice and assessment of statistical predictions. \emph{Journal of the Royal Statistical Society}, \bold{36}, 111-147. -Bougeard, S. and Dray S. (2018) Supervised Multiblock Analysis in R with the ade4 Package. \emph{Journal of Statistical Software}, \bold{86} (1), 1-17. \url{http://doi.org/10.18637/jss.v086.i01} +Bougeard, S. and Dray S. (2018) Supervised Multiblock Analysis in R with the ade4 Package. \emph{Journal of Statistical Software}, \bold{86} (1), 1-17. \url{https://doi.org/10.18637/jss.v086.i01} } \author{Stéphanie Bougeard (\email{stephanie.bougeard@anses.fr}) and Stéphane Dray (\email{stephane.dray@univ-lyon1.fr})} diff -Nru ade4-1.7-13/man/varipart.Rd ade4-1.7-16/man/varipart.Rd --- ade4-1.7-13/man/varipart.Rd 2018-08-06 07:00:26.000000000 +0000 +++ ade4-1.7-16/man/varipart.Rd 2020-10-27 14:58:27.000000000 +0000 @@ -79,7 +79,7 @@ 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. +species data matrices: estimation and comparison of fractions. Ecology 87:2614-2625. } \seealso{ \code{\link{pcaiv}} diff -Nru ade4-1.7-13/MD5 ade4-1.7-16/MD5 --- ade4-1.7-13/MD5 2018-08-31 16:50:17.000000000 +0000 +++ ade4-1.7-16/MD5 2020-10-28 11:10:02.000000000 +0000 @@ -1,12 +1,11 @@ -9ca1496d86c29d9ed99107c49c091191 *ChangeLog -6d2ac182092008c3f59e5c8e08e2d58e *DESCRIPTION -f152c2e8b41afe686c5072b0d7441d03 *NAMESPACE -27c4d6507dd47eb51eb6f0943fc084a9 *R/EH.R +e41712f3cba15fb5b1864af1455f95df *ChangeLog +7f70186f7b99904f5727964e09453186 *DESCRIPTION +6a3247f02dfb32994d7c1bfdea2c45ad *NAMESPACE 6b677d2c1862d14d17ab0760f9760dcc *R/PI2newick.R 6997af57a25d43dc445092f3e845f2f1 *R/RV.rtest.R 8d43bff953af1f5d49b5e0fb16930a34 *R/RVdist.randtest.R 1fdb71cdc0f09024023a31cca767b3fa *R/add.scatter.R -a91cdb30c3c14314b52e267dad20ffe8 *R/ade4-deprecated.R +0e734d91e2532e26077a357142983255 *R/ade4-deprecated.R 37c6a7f3ff5716e26988e23536784027 *R/amova.R 502c2b9fe7384a6d6d943775d23fcdde *R/apqe.R 7c7f969bf79e951b76459a2698dea1d4 *R/area.plot.R @@ -25,10 +24,9 @@ 9adbb2fcae2d3358747b872c126dc2d5 *R/disc.R 762df1c0044c90877cac71e453700e9d *R/discrimin.R 217c5464655177b2f2e3bedee5bc41c9 *R/discrimin.coa.R -4f5a9560442fa3b5c60ada9e99ba9ab6 *R/dist.binary.R +e73d7b2f41ad8eeec62d4798d22cb2ca *R/dist.binary.R 6a6eb7ef3a48d06ff13a5d16037cd2d0 *R/dist.dudi.R -a9cd762f2d15f9f760cd0a21cef037f0 *R/dist.genet.R -c480be1a9a83c30518dac71f9a98d1a1 *R/dist.ktab.R +ad03f97042424cb32369bbc2e1ec7777 *R/dist.ktab.R cd4d8a3837676bb9d15f841a71514603 *R/dist.neig.R 73f5fd3c1ff02495564a1ee5956a8d9f *R/dist.prop.R ed17c38210a61edefa8d99ce1660b4ce *R/dist.quant.R @@ -51,9 +49,7 @@ 8088980976b1cd67f9759db87789062b *R/fourthcorner.R 60336b42bd5ee95f3ae4145506d31979 *R/fourthcorner.rlq.R 89a593d1a3097687949a2e59bbcfdd38 *R/fourthcorner2.R -25cf8282371d427c6d11e3b13e37ad6b *R/fuzzygenet.R d2f63c500851905fe0398b3fa4dae7ab *R/gearymoran.R -ca9eb1f03876e785d040836506ce3f50 *R/genet.R 4b51d288b3c7c57a485f7728676e0c56 *R/gridrowcol.R b54921287a7845457bc2f46761ef9c5a *R/inertia.dudi.R acf786e3e3c41f3820cae2ec95b94607 *R/is.euclid.R @@ -68,7 +64,7 @@ dabf8b637a1eb66f1208dcdc920504f3 *R/kplot.sepan.R 4c71c804258b9bc07e9bf8311a8dbcec *R/kplot.statis.R ebf1adeb0f4edeb226c99e22d31523ca *R/krandboot.R -e692563dd969dc8c9f433d7048fe986d *R/krandtest.R +8440c7cb6606d8e962780e58d691c9f0 *R/krandtest.R bd8808a1e276364ec39159e3f0c20519 *R/krandxval.R 85deed07d28fe236504f0c13eacf1b67 *R/ktab.R 255ee82b258fe012a20bd04b37522ec6 *R/ktab.data.frame.R @@ -77,26 +73,25 @@ 9d4a9f10a538cbf896a72535ea0961b3 *R/ktab.match2ktabs.R d7b3319992f78918e90fcd49bf16e23e *R/ktab.within.R 6aa6c74464a2d1a55b2562561795cdc2 *R/lingoes.R +77b75b0b5750c343c90a80a9c028ecda *R/loocv.R 865f71d4617be075737dd1d22e37297d *R/mantel.randtest.R 282b41479955a96001a1b35768643bb0 *R/mantel.rtest.R -f494217bd4284707773bef0441402956 *R/mbpcaiv.R -e5a18eae0dbb3b3da88ad67340da0036 *R/mbpls.R +61e6ea24eb1b11e1dfbca8a2edd0942c *R/mbpcaiv.R +9adff3592123f838e1e77fff35db84eb *R/mbpls.R f2069eaaf0ff7a8c492ca744e26241db *R/mcoa.R 7df34204586cf5a1d8851262ccf62b0b *R/mdpcoa.R 7c3bc2cbb167182b3fcddbd2d882c628 *R/mfa.R bc8897b6d8e662fa44e5b162fed075cb *R/mld.R c1e78e310e6e2bc4466825be29723bec *R/mstree.R -874c603e0edd7ce3207da8d2d17f8d7e *R/multiblock.R -1325476d0bfb6ce1561e4b56bfedf645 *R/multispati.R +8aceb7b693c0d266579b001deea73fef *R/multiblock.R +5e8940534b80bb3d5e6dafffabfa5a49 *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 a5939daada55ec456b59114d9f8ccbb1 *R/nipals.R -cddace7000d26910f06569592051ebd0 *R/optimEH.R e66347d5ded70e8e4e7813992cc61db1 *R/originality.R -11342c6f340945bef7a294199ae73565 *R/orisaved.R 91b2d6977ee59f2c277f25cc8a8ed8b7 *R/orthobasis.R 521653f773c0cd262df985b09fb16b48 *R/p.adjust.4thcorner.R c55d5f7719d4967dca129e6442923802 *R/pcaiv.R @@ -111,7 +106,6 @@ 36ed83c95f350afb554284f83ee73e0b *R/procuste.rtest.R b9ea3592cbc6bd086555067572cdf291 *R/pta.R 83adfebc61e4cf82a35faa164fbfdec0 *R/quasieuclid.R -003f7cf536fa387e02f87fbb8246dcf9 *R/randEH.R 724fb865747d7a8e3d135b34f3f2dc55 *R/randboot.R 78de2c2c0e973cd080e01a5d96c94414 *R/randtest-internal.R 744ab897f6c77dc8ec232c9e83caed17 *R/randtest.R @@ -119,7 +113,7 @@ 02c2e72ec7f369bf34a1691e8db38832 *R/randtest.between.R b59ad08ad77ab61c9415d1d37f5899fc *R/randtest.coinertia.R 9c990f7f1bb883b8bf50d47c13ff67ba *R/randtest.discrimin.R -6fbbc2e6e94a170efa9864c9eb38f5e5 *R/randtest.dpcoa.R +c1f24646f76da2d109250246b9359e58 *R/randtest.dpcoa.R 5d9e9ff4cc2f01ec6973e7678bdab54f *R/randtest.pcaiv.R d494a580b2eb22f88afc106cde1a0ac0 *R/randtest.pcaivortho.R 35e9b020452713720e3c6a51d937c152 *R/randtest.rlq.R @@ -169,7 +163,8 @@ 91c6e96e5a83ae05746a1de1288c145c *R/summary.4thcorner.R 834b2cb4dffc468ba24caaeb0283c40c *R/supcol.R 75906367d78ef6392d01d1768daf8f79 *R/supdist.R -c9a63e6c11929fa56e927d8537a410e2 *R/suprow.R +e33f1c8289114fabb487926fa8436ffe *R/suprow.R +c3e87c6f6f8239a62e083de02646648c *R/suprow.pta.R 19128aaadc6cb691920aaeb97679551c *R/symbols.phylog.R bc70ddf20e036e5273144e0628a20165 *R/table.cont.R 471ba8b286985e644cf15d7ff3f2bdb7 *R/table.dist.R @@ -298,7 +293,7 @@ 53df52b0b8de963f7cd1ed72ff171da5 *data/worksurv.rda 55cd9d01e39691f67acfd1ffdd607652 *data/yanomama.rda f19df1a99aa3d39631422b7b247f4511 *data/zealand.rda -2552cb1686c21b5b3b70c944e35aad7d *inst/CITATION +d405ab13c699b4ee8333f300ed1785e0 *inst/CITATION a134ce28598a2867b151d0cf11e944b7 *inst/pictures/atyacarto.pnm 6a427fa2a11dc07d5b2686fa50405d28 *inst/pictures/atyadigi.pnm d62a9968f404a5d984e336ebd95f68e9 *inst/pictures/avijonseau.pnm @@ -313,32 +308,31 @@ 53343ad8450770f6033539cc253665da *inst/pictures/paris.pnm ddc70df388a9749473b91e043cd9241c *inst/pictures/sarcelles.pnm 87829cd565c28ba216b7be12d9e54bf9 *inst/pictures/tintoodiel.pnm -8a2d1a94a1b20c6b9856a8d75c16cecc *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 -b64a5ffac41034d00abf2b96eb3fc1c6 *man/ade4-deprecated.Rd +7985f70da05d1696bde6d65eeff7ad26 *man/ade4-deprecated.Rd b1507f756729f1164a1efd34a3b626b9 *man/ade4-internal.Rd e61beaf727c5182a9324cd60844b599f *man/ade4.package.Rd e3b0339a997676fb728a424b20db4ebe *man/adegraphicsLoaded.Rd a8af05ea4d586e8c7b625a1f0339682f *man/aminoacyl.Rd 249b4c19f78f6aa3474ecc5f7e177075 *man/amova.Rd -f7a565f2113fce262a2ff36368425080 *man/apis108.Rd +9b1de95ac28e695890066928148e95ac *man/apis108.Rd 208ec14214b92c594f5cfe076af1cac8 *man/apqe.Rd 18ca41e0078353333d595ad74220dc6a *man/aravo.Rd 2b3a479de8f346040a701a4cb10d3d98 *man/ardeche.Rd 447412b7f57ebf964e0be55eb27fe7f3 *man/area.plot.Rd -4ffac3a403122350d3bf25b048d22108 *man/arrival.Rd +d1e2492547f7244a362a8519e2b9ffd1 *man/arrival.Rd 26759451a77308d6f556575ec677e0d7 *man/as.taxo.Rd d48c9dd29ea109fc24fd73d9b82ec60e *man/atlas.Rd f0cba96fb22a52646c8b24985117704e *man/atya.Rd 1bdea97edb5f00aa921d3d9a3002140f *man/avijons.Rd 5b46f1b3eb76344f4bb52728b124c7be *man/avimedi.Rd dabc0712d7712db91faa37724853c41e *man/aviurba.Rd -fd704368c94caeeb530355dd68e36c24 *man/bacteria.Rd +5c8a0ee4db834548090f4c69c236986d *man/bacteria.Rd 3bc4630371d25aa72f07bf1f7b866479 *man/banque.Rd 820bd2c569ba9044f27a5159f8b3ce41 *man/baran95.Rd 8feb1f2e871b5671c1754cb3e3ccff45 *man/bca.Rd @@ -351,16 +345,16 @@ 54aeb9d389d5b11a58808ccf6c8a4465 *man/buech.Rd 629fd7b535eb008a7c798080b4f2ee76 *man/butterfly.Rd c29141ff24a81ba211d3a1e2222ac9bc *man/bwca.dpcoa.Rd -6ffb638f5a058ab25cae4894ee002dc8 *man/cailliez.Rd +7cfada60ad3ecab55ceb38d595b1fa11 *man/cailliez.Rd 10cbbd758037ebc5dc5897390c32ab97 *man/capitales.Rd d0ab9fd2335bbc6fc9ccf329c3e79b7b *man/carni19.Rd f24f566df0b44c9b44180a3aa3565ad3 *man/carni70.Rd 8db45c0d262f6993068d8a78141550bf *man/carniherbi49.Rd -f356254b1f57a940c3465a14d7128f69 *man/casitas.Rd +4ccf0b89085c82b39617671cb9cc58ab *man/casitas.Rd 36917a4def5673847ad737e21ca0ff09 *man/chatcat.Rd 148d03c767a82f8d666d5862eaaa3b46 *man/chats.Rd db6510a81935c5bb821a0f631a001db0 *man/chazeb.Rd -55a059411ffbb9e2e329c64a4dba2ff6 *man/chevaine.Rd +ed535328bfc9a7bec9b12f178aac8851 *man/chevaine.Rd ba42eda2b1386ec657937901943ca286 *man/chickenk.Rd 303f97951f27ed47f4b1c2d972960a96 *man/clementines.Rd 5b4f9b96b33f6b48c86eb5abef0f5491 *man/cnc2003.Rd @@ -378,7 +372,6 @@ 30c9421e4bb3c2adcd0a4bbb568ab3f4 *man/discrimin.coa.Rd 722ea45480bc97122a7a5e2285a9486f *man/dist.binary.Rd ef1758a31c80808665c088526667bcae *man/dist.dudi.Rd -0730b36b2f69b95464e1a0cbbb8fb22d *man/dist.genet.Rd 977087338f8fce066c7db8b9868c8d36 *man/dist.ktab.Rd 5ccf470ce27b4a31abf024f13cc08e2b *man/dist.neig.Rd 74cc1ac08c5cae5d0695e07ed2e40487 *man/dist.prop.Rd @@ -410,13 +403,11 @@ 2107a61245d9c09a5a3df1784778ad2f *man/fourthcorner.Rd 3adeabc79ad58a8adf4fbb9353ce07f5 *man/friday87.Rd e2bea0a520462821a036f271409f33f8 *man/fruits.Rd -6f45dc6f6799eb2888dad233a7478231 *man/fuzzygenet.Rd c90c906094000915af6e610beb8fc0d8 *man/gearymoran.Rd -39fe0ff367eabd911efc2096ca7556d9 *man/genet.Rd 9a6010d352e9734c29a91fbe423f37f5 *man/ggtortoises.Rd 600bfb1450a9c03464de8198195d6f82 *man/granulo.Rd 38ccaeabba9710759fa0a92563943b7d *man/gridrowcol.Rd -c617fccd9ed44d9de41ebceef9827589 *man/hdpg.Rd +18306e14e56a4a4180ce12b65c89c4db *man/hdpg.Rd 657fa22c3ec73f707d87bc3a1aa4dad4 *man/housetasks.Rd 34ede9cd77aadc0483270ce83d94f3c8 *man/humDNAm.Rd 329d66616200815109272f705f9c3721 *man/ichtyo.Rd @@ -425,10 +416,10 @@ d8932e7c9545fb802e44acaee5e715c2 *man/is.euclid.Rd faa31ce6d9bc268b91f6db62072891fa *man/julliot.Rd 2bbbff77a1a6fa0d5bb10828c61153bb *man/jv73.Rd -5be96bdf1fbbbc7963849c03b4b3b3e2 *man/kcponds.Rd -a0693ed8183307bc121d3787ea5f0598 *man/kdist.Rd +f4fc6375fdf07689163f62a4e42b358e *man/kcponds.Rd +afc00e97c0ed1bf5b8eb912e21fdd0b6 *man/kdist.Rd b0961249596434ce3a0159a22b41af52 *man/kdist2ktab.Rd -30ee8d5bdf4c64570a3736fc31b76802 *man/kdisteuclid.Rd +5c5bf2d6728f253c759d57886e8f2920 *man/kdisteuclid.Rd ea9e77da2931e615fed14ccd10c32182 *man/kplot.Rd 53c3dcbe1d9f87d9ef79a254c73cdf1f *man/kplot.foucart.Rd d92e7fefc64d4187c7072ef645c6539d *man/kplot.mcoa.Rd @@ -436,7 +427,7 @@ 868a49832171df02105a2159a34029f3 *man/kplot.pta.Rd 671cc100f0f4fec221fb23c26b6a5f2f *man/kplot.sepan.Rd 2caa270bbf015958aeae072475d64cc4 *man/kplot.statis.Rd -168deecf33ce2e4989691e6d3bc15efb *man/krandtest.Rd +8f5b862f8043398cce7c49367f83192d *man/krandtest.Rd 178ec4ef0849a18731765c8fefe50a25 *man/ktab.Rd 8794927f88fd6a392b53fd9ff91ccb65 *man/ktab.data.frame.Rd 798f0ef80c974286bd5024505ca2641e *man/ktab.list.df.Rd @@ -446,6 +437,9 @@ 8079d383b8fe439a05b5327598c2d8c0 *man/lascaux.Rd a60aec1e73f6e5e44469dc5cae1b6515 *man/lingoes.Rd d4c0558a22707b775e0ff79c7771adf3 *man/lizards.Rd +43dad9f48768d1454f04560426d9634a *man/loocv.bca.Rd +2460374c81a0976c3a713eab05179ef7 *man/loocv.discrimin.Rd +e7031c3e7a6577642215a02b93a578d9 *man/loocv.dudi.Rd ffb4c26da7697a5ed7b1e1edec99d13e *man/macaca.Rd 2e0a5f29e020638da962402a07c41c94 *man/macon.Rd 738d6ad074c9750d7f583d3580886a35 *man/macroloire.Rd @@ -454,8 +448,8 @@ 8b4cdae21e7d8f90d7fcaa9a5250a054 *man/mantel.rtest.Rd fe18b1f6484a339f1641fc864446894e *man/maples.Rd e5bd6190c3964632a6eac8982a5244c9 *man/mariages.Rd -2083f479afedf29247df0fdc61395abc *man/mbpcaiv.Rd -d2d5dd3666ef4cadcb90ab0ac181a0d9 *man/mbpls.Rd +9ba6c227e04469429168582e9a9a3b0d *man/mbpcaiv.Rd +378f539fc0aac14deca2a3bb9cd04171 *man/mbpls.Rd 4fff9cfa974199382a0386f57f28f21a *man/mcoa.Rd faf07f3c20cd21f6fac74cc9aeecac1d *man/mdpcoa.Rd 701ca4c18001cbe33d42124c74595898 *man/meau.Rd @@ -468,8 +462,8 @@ 5ae787bce8773ba944d9daffc2ac6640 *man/monde84.Rd aa0678333c8ba7621a3470615cd2a9f1 *man/morphosport.Rd e5c6a90a580066a1cb959074111a49bd *man/mstree.Rd -0a66f03fa824c011f95cc83fffe697a6 *man/multiblock.Rd -93921990147d7a102a55ebe3c0a1f2bd *man/multispati.Rd +d8b686219e71014db4761a0f583073c9 *man/multiblock.Rd +cecb185ac49a0adafc53cbd8471efb90 *man/multispati.Rd 025c831146e303e447aaa9ff8bfd5823 *man/multispati.randtest.Rd 30f6c9a3a1689cae14882fb9d301d778 *man/multispati.rtest.Rd 3df1c08ac1bb6e3f651e3f3c9d47f52b *man/neig.Rd @@ -479,10 +473,8 @@ 3eb9fb98b456ccd5b2eeffefff2833d7 *man/nipals.Rd f02b2779f45cf6fd48bf2925804aa82a *man/njplot.Rd d9c4a1e91ba04f2a2eb913dd6d2fa695 *man/olympic.Rd -f7acf764e3d6a92bd8202d45a6c930d7 *man/optimEH.Rd -0ea029ae19803ca758031d0518270d82 *man/oribatid.Rd +9bdee9281c16e39dcf1a0f1fcc1726c7 *man/oribatid.Rd 4f57c9b6bb73c1a91f282680be86b243 *man/originality.Rd -445701ec72c9a2372ce874b41b926fcb *man/orisaved.Rd e2da1e1d881391b948bf64693f153391 *man/orthobasis.Rd 379903c55f52fde22eaafe09521c9386 *man/ours.Rd f9b9b774c9a3c9e21f9f29744a8df996 *man/palm.Rd @@ -490,29 +482,28 @@ b33e7fc3381597afc498baead8ca5047 *man/pcaiv.Rd 0fd2c833f564dc8b178b8328c0573d70 *man/pcaivortho.Rd e5af7e7dca04d7a7914bdae08c680c55 *man/pcoscaled.Rd -d4a610cb68738e3538148f6836eac7ee *man/pcw.Rd +4b32aba5f366309250ee7a5795daa58a *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 +55cac3301626df21c8543d62519d1c70 *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 -1aa57de64ef7402419052e569ecbc277 *man/randEH.Rd dbabb33255dfdbc2a709b9f43b16c644 *man/randboot.Rd -b3312d143490ca1848f89e91c3bb7eb0 *man/randboot.multiblock.Rd -ad10c7a872d3118ca2621064d1581459 *man/randtest.Rd +ebc9228ddb7078707b753945e065bee5 *man/randboot.multiblock.Rd +66af2805133b21892d1a27c25998c46a *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 +66586dadf5d8e68388a3671a42044344 *man/randtest.dpcoa.Rd 91a19c1a4b2c57b93f32f755dd564898 *man/randtest.pcaiv.Rd 82d7f423171d3aaad0ff11c740e3362a *man/randxval.Rd f5ce90e1dae92961860a0309aea92340 *man/rankrock.Rd @@ -531,7 +522,7 @@ 7e446aecefbca6590e7572252d027a7a *man/s.distri.Rd 2a7e048a9a7a20bc350e2a9d8ad7dd27 *man/s.hist.Rd 42603cdc29372482b4979b4a5e13bdc0 *man/s.image.Rd -80c0bd018dbd97bd792bf355ba4e43c5 *man/s.kde2d.Rd +5c9ec162f2d537f6a19b52a55943c907 *man/s.kde2d.Rd 8ab446112c535068bd8cc452f830599d *man/s.label.Rd 970aa00c1f1866dcf169062589f3c010 *man/s.logo.Rd eeebdfc6d77794d7f360ce7088c67dec *man/s.match.Rd @@ -570,6 +561,7 @@ e7bb33c3766623f999c645948417efbe *man/supcol.Rd a3e6a34dd8837531d1d88578af895761 *man/supdist.Rd bbcc6af7809354956215e40b4df6fbf6 *man/suprow.Rd +e169a8e85a52bd18ba2b72d95453cdd8 *man/suprow.pta.Rd ebe8f79b0d7da4bd698db7a34a9f9637 *man/symbols.phylog.Rd 7f17d062ca1a936f7d1bf014ee68211c *man/syndicats.Rd 5e491778d14df4d6d7176b6ec7041577 *man/t3012.Rd @@ -581,7 +573,7 @@ 5dda2bd3b7a9baec7611872a472320d0 *man/tarentaise.Rd 49707fd1338711908204bc755bff9b74 *man/taxo.eg.Rd a52e54243d7afbe5ede4597a081c7637 *man/testdim.Rd -3183df2fe77649d04a60823bc095af96 *man/testdim.multiblock.Rd +354b20ef5260c11f76dce7e0cb21cf16 *man/testdim.multiblock.Rd a7dd35af6744709d16b452fcfe204d1c *man/tintoodiel.Rd 0873ff2c03cfa3379873314253f90b90 *man/tithonia.Rd 1234e35f8fdc5cae3b06ff17652f6f78 *man/tortues.Rd @@ -592,7 +584,7 @@ e852befdc36a81e8785d75b7cf4c0f1e *man/ungulates.Rd 77ba948fc7720a971e8c3724e0f0a023 *man/uniquewt.df.Rd 990dce46e5096ae2710a21272b40cbfe *man/variance.phylog.Rd -444080d8d1ca325add04965c6a51c54c *man/varipart.Rd +96dcd326f778582ac773e0cbac8bb125 *man/varipart.Rd bb50bf8f6978c7cce94bb949afd3366a *man/vegtf.Rd ba7ac081a6b0ab9ad0dcd1fe5671a2d5 *man/veuvage.Rd 7632fa15447224d022a1ce1ee19d2e94 *man/wca.Rd diff -Nru ade4-1.7-13/NAMESPACE ade4-1.7-16/NAMESPACE --- ade4-1.7-13/NAMESPACE 2018-08-06 07:00:26.000000000 +0000 +++ ade4-1.7-16/NAMESPACE 2020-10-20 06:28:59.000000000 +0000 @@ -10,6 +10,8 @@ S3method("[","dudi") S3method("[","kdist") S3method("[","ktab") +S3method("[","krandtest") +S3method("[[","krandtest") S3method("as.data.frame","kdist") S3method("bca","coinertia") S3method("bca","dpcoa") @@ -28,6 +30,9 @@ S3method("kplot","pta") S3method("kplot","sepan") S3method("kplot","statis") +S3method("loocv","dudi") +S3method("loocv","between") +S3method("loocv","discrimin") S3method("plot","4thcorner") S3method("plot","betcoi") S3method("plot","betrlq") @@ -155,6 +160,7 @@ S3method("suprow","fca") S3method("suprow","mix") S3method("suprow","pca") +S3method("suprow","pta") S3method("t","dudi") S3method("t","ktab") S3method("tab.names<-","ktab") @@ -173,10 +179,11 @@ ##################################### 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", "shapiro.test", "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("stats", "IQR", "shapiro.test", "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") importFrom("MASS", "ginv", "kde2d") +importFrom("progress", "progress_bar") ##################################### ## Export ## @@ -193,7 +200,7 @@ 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" ) +export("bca", "col.names", "col.names<-", "inertia", "kplot", "loocv", "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") @@ -216,12 +223,9 @@ 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", "phylog.extract", "phylog.permut", "PI2newick", "radial.phylog","symbols.phylog", "table.phylog", "taxo2phylog", "variance.phylog") -export("EH", "randEH", "optimEH", "originality", "orisaved") +export("originality") ## ******* orthobasis ******* export("haar2level", "mld", "orthobasis.circ", "orthobasis.haar", "orthobasis.line", "orthobasis.mat", "orthobasis.neig", "is.orthobasis") @@ -239,7 +243,16 @@ ## ******* deprecated ******* ## "between" ## "betweencoinertia" +## "char2genet" +## "count2genet" +## "dist.genet" +## "EH" +## "freq2genet" +## "fuzzygenet" +## "optimEH" +## "orisaved" ## "orthogram" +## "randEH" ## "within" ## "withincoinertia" diff -Nru ade4-1.7-13/R/ade4-deprecated.R ade4-1.7-16/R/ade4-deprecated.R --- ade4-1.7-13/R/ade4-deprecated.R 2017-11-02 14:23:37.000000000 +0000 +++ ade4-1.7-16/R/ade4-deprecated.R 2020-10-16 11:22:21.000000000 +0000 @@ -212,3 +212,770 @@ w$scores.order <- scores.order return(w) } + +"EH" <- function(phyl, select = NULL) { + .Deprecated(new="EH", package="ade4", + msg="This function is now deprecated. Please use the 'EH' function in the 'adiv' package.") + 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) + } +} + +"orisaved" <- function(phyl, rate = 0.1, method = 1) { + .Deprecated(new="orisaved", package="ade4", + msg="This function is now deprecated. Please use the 'orisaved' function in the 'adiv' package.") + 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) +} + +"randEH" <- function(phyl, nbofsp, nbrep = 10) { + .Deprecated(new="randEH", package="ade4", + msg="This function is now deprecated. Please use the 'randEH' function in the 'adiv' package.") + 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) +} + +"optimEH" <- function(phyl, nbofsp, tol = 1e-8, give.list = TRUE) { + .Deprecated(new="optimEH", package="ade4", + msg="This function is now deprecated. Please use the 'optimEH' function in the 'adiv' package.") + 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) +} + +"dist.genet" <- function (genet, method = 1, diag = FALSE, upper = FALSE) { + + .Deprecated(new="dist.genet", package="ade4", + msg="This function is now deprecated. Please use the 'dist.genpop' function in the 'adegenet' package.") + + 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) +} + +"fuzzygenet" <- function(X) { + + .Deprecated(new="fuzzygenet", package="ade4", + msg="This function is now deprecated. Please use the 'df2genind' function in the 'adegenet' package.") + + 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) +} + +"char2genet" <- function(X,pop,complete=FALSE) { + + .Deprecated(new="char2genet", package="ade4", + msg="This function is now deprecated. Please use the 'df2genind' and 'genind2genpop' functions in the 'adegenet' package.") + + 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@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) { + + .Deprecated(new="count2genet", package="ade4", + msg="This function is now deprecated. Please use the 'df2genind' and 'genind2genpop' functions in the 'adegenet' package.") + + # 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) { + + .Deprecated(new="freq2genet", package="ade4", + msg="This function is now deprecated. Please use the 'df2genind' and 'genind2genpop' functions in the 'adegenet' package.") + + # 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) +} \ No newline at end of file diff -Nru ade4-1.7-13/R/dist.binary.R ade4-1.7-16/R/dist.binary.R --- ade4-1.7-13/R/dist.binary.R 2015-10-14 11:19:57.000000000 +0000 +++ ade4-1.7-16/R/dist.binary.R 2020-10-16 11:22:21.000000000 +0000 @@ -1,5 +1,5 @@ "dist.binary" <- function (df, method = NULL, diag = FALSE, upper = FALSE) { - METHODS <- c("JACCARD S3", "SOCKAL & MICHENER S4", "SOCKAL & SNEATH S5", + METHODS <- c("JACCARD S3", "SOKAL & MICHENER S4", "SOKAL & 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"))) @@ -18,9 +18,9 @@ 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("2 = SOKAL & 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("3 = SOKAL & 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") diff -Nru ade4-1.7-13/R/dist.genet.R ade4-1.7-16/R/dist.genet.R --- ade4-1.7-13/R/dist.genet.R 2017-11-02 14:18:06.000000000 +0000 +++ ade4-1.7-16/R/dist.genet.R 1970-01-01 00:00:00.000000000 +0000 @@ -1,108 +0,0 @@ -"dist.genet" <- function (genet, method = 1, diag = FALSE, upper = FALSE) { - - .Deprecated(new="dist.genet", package="ade4", - msg="This function is now deprecated. Please use the 'dist.genpop' function in the 'adegenet' package.") - - 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 -Nru ade4-1.7-13/R/dist.ktab.R ade4-1.7-16/R/dist.ktab.R --- ade4-1.7-13/R/dist.ktab.R 2017-02-27 07:37:04.000000000 +0000 +++ ade4-1.7-16/R/dist.ktab.R 2020-10-16 11:22:21.000000000 +0000 @@ -38,9 +38,9 @@ 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("2 = SOKAL & 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 & + cat("3 = SOKAL & 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 & @@ -563,7 +563,7 @@ } verif <- function(u){ - if(any(is.na(match(u, c(0, 1))))) + if(any(!u[!is.na(u)] %in% c(0, 1))) stop("Dichotomous variables should have only 0, and 1") } @@ -1170,9 +1170,9 @@ 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("2 = SOKAL & 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 & + cat("3 = SOKAL & 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 & @@ -1481,7 +1481,7 @@ } verif <- function(u){ - if(any(is.na(match(u, c(0, 1))))) + if(any(!u[!is.na(u)] %in% c(0, 1))) stop("Dichotomous variables should have only 0, and 1") } @@ -1812,9 +1812,9 @@ 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("2 = SOKAL & 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 & + cat("3 = SOKAL & 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 & @@ -2126,7 +2126,7 @@ } verif <- function(u){ - if(any(is.na(match(u, c(0,1))))) + if(any(!u[!is.na(u)] %in% c(0, 1))) stop("Dichotomous variables should have only 0, and 1") } @@ -2288,7 +2288,7 @@ x[x < tol] <- 0 return(x) } - thedis <- lapply(res, funfor0) + thedis <- lapply(listdis, funfor0) names(thedis) <- attributes(x[[i]])$Labels } } @@ -2400,7 +2400,7 @@ x[x < tol] <- 0 return(x) } - thedis <- lapply(res, funfor0) + thedis <- lapply(listdis, funfor0) names(thedis) <- names(x[[i]]) } } @@ -2884,7 +2884,7 @@ } verif <- function(u){ - if(any(is.na(match(u, c(0,1))))) + if(any(!u[!is.na(u)] %in% c(0, 1))) stop("Dichotomous variables should have only 0, and 1") } diff -Nru ade4-1.7-13/R/EH.R ade4-1.7-16/R/EH.R --- ade4-1.7-13/R/EH.R 2017-11-02 14:23:45.000000000 +0000 +++ ade4-1.7-16/R/EH.R 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -"EH" <- function(phyl, select = NULL) -{ - .Deprecated(new="EH", package="ade4", - msg="This function is now deprecated. Please use the 'EH' function in the 'adiv' package.") - 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 -Nru ade4-1.7-13/R/fuzzygenet.R ade4-1.7-16/R/fuzzygenet.R --- ade4-1.7-13/R/fuzzygenet.R 2017-11-02 14:18:11.000000000 +0000 +++ ade4-1.7-16/R/fuzzygenet.R 1970-01-01 00:00:00.000000000 +0000 @@ -1,147 +0,0 @@ -"fuzzygenet" <- function(X) { - - .Deprecated(new="fuzzygenet", package="ade4", - msg="This function is now deprecated. Please use the 'df2genind' function in the 'adegenet' package.") - - 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 -Nru ade4-1.7-13/R/genet.R ade4-1.7-16/R/genet.R --- ade4-1.7-13/R/genet.R 2017-11-02 14:19:35.000000000 +0000 +++ ade4-1.7-16/R/genet.R 1970-01-01 00:00:00.000000000 +0000 @@ -1,387 +0,0 @@ -"char2genet" <- function(X,pop,complete=FALSE) { - - .Deprecated(new="char2genet", package="ade4", - msg="This function is now deprecated. Please use the 'df2genind' and 'genind2genpop' functions in the 'adegenet' package.") - - 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@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) { - - .Deprecated(new="count2genet", package="ade4", - msg="This function is now deprecated. Please use the 'df2genind' and 'genind2genpop' functions in the 'adegenet' package.") - - # 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) { - - .Deprecated(new="freq2genet", package="ade4", - msg="This function is now deprecated. Please use the 'df2genind' and 'genind2genpop' functions in the 'adegenet' package.") - - # 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 -Nru ade4-1.7-13/R/krandtest.R ade4-1.7-16/R/krandtest.R --- ade4-1.7-13/R/krandtest.R 2018-01-16 08:47:26.000000000 +0000 +++ ade4-1.7-16/R/krandtest.R 2020-10-16 11:22:21.000000000 +0000 @@ -118,3 +118,50 @@ } + +"[.krandtest" <- function(x, i) { + res <- list() + if (!inherits(x, "lightkrandtest")) + if(length(i) == 1) + res$sim <- x$sim[, i, drop = FALSE] + else + res$sim <- x$sim[, i] + res$obs <- x$obs[i] + res$alter <- x$alter[i] + res$rep <- x$rep[i] + res$ntest <- length(i) + res$expvar <- x$expvar[i, ] + res$names <- x$names[i] + res$pvalue <- x$pvalue[i] + res$plot <- x$plot[i] + res$adj.pvalue <- x$adj.pvalue[i] + res$adj.method <- x$adj.method + res$call <- match.call() + class(res) <- class(x) + return(res) +} + +"[[.krandtest" <- function(x, i) { + if(length(i) != 1) + stop("Only one element can be selected: 'i' must be an index of length at 1.") + + obj <- x[i] + + res <- list() + if (!inherits(x, "lightkrandtest")) + res$sim <- obj$sim + res$obs <- obj$obs + res$alter <- obj$alter + res$rep <- obj$rep + res$expvar <- obj$expvar + res$pvalue <- obj$pvalue + res$plot <- obj$plot + res$call <- match.call() + + class(res) <- "randtest" + if (inherits(x, "lightkrandtest")) + class(res) <- c(class(res), "lightrandtest") + + return(res) +} + diff -Nru ade4-1.7-13/R/loocv.R ade4-1.7-16/R/loocv.R --- ade4-1.7-13/R/loocv.R 1970-01-01 00:00:00.000000000 +0000 +++ ade4-1.7-16/R/loocv.R 2020-10-20 06:28:59.000000000 +0000 @@ -0,0 +1,240 @@ +"loocv" <- function(x, ...) { + UseMethod("loocv") +} + +loocv.between <- function(x, progress = FALSE, ...) + ## Leave-one-out cross-validation for bca + ## x = the bca to be cross-validated + ## progress = logical to display a progress bar + ## Returns a list with the cross-validated row coordinates (XValCoord), + ## the predicted residual error sum of squares (PRESS) for each individual, + ## the total PRESS for each axis, (PRESSTot), + ## the root-mean-square error (RMSE), and + ## RMSEIQR, the interquartile range normalized RMSE. + # +{ + if (!inherits(x, "dudi")) + stop("Object of class dudi expected") + if (!inherits(x, "between")) + stop("Object of class between expected") + bcaCall <- x$call + nf1 <- x$nf + ## Get the parameters of the original analysis: + ## dudi, factor, and number of rows + dudiCall <- eval.parent(bcaCall[[2]]) + fac <- eval.parent(bcaCall[[3]]) + lig1 <- nrow(dudiCall$tab) + if (length(fac) != lig1) + stop("Non convenient dimension") + xcoo1 <- as.data.frame(matrix(0, lig1, nf1)) + mean.w <- function(x, w, fac, cla.w) { + z <- x * w + z <- tapply(z, fac, sum)/cla.w + return(z) + } + if (progress) pb <- progress_bar$new(total = lig1, + format = " Computing [:bar] :percent eta: :eta") + for (ind1 in 1:lig1) { + if (progress) pb$tick() + ## Remove each row of the data table, one at a time, + ## then do the analysis and the bca on the new table + ## and estimate the coordinates of the missing row + # + ## The original analysis can be any dudi, so wee need to start from dudiCall$call: + jcall1 <- dudiCall$call + ## Change the df argument to discard row #ind1: + jcall1[[2]] <- eval.parent(jcall1[[2]])[-ind1, ] + ## Check that the scannf argument is set to FALSE: + if (any(names(jcall1) == "scannf")) jcall1[[which(names(jcall1) == "scannf")]] <- FALSE + else { + ## If scannf is not in the args list, add it and is set to FALSE: + jcall1[[length(jcall1) + 1]] <- quote(FALSE) + names(jcall1)[length(jcall1)] <- "scannf" + } + ## Run the analysis without row #ind1: + if (inherits(dudiCall, "fca") || inherits(dudiCall, "fpca")) { + colblo1 <- attr(jcall1[[2]], "col.blocks") + jcall1[[2]] <- prep.fuzzy.var(jcall1[[2]], colblo1) + } + jdudi1 <- eval.parent(jcall1) + ## Check that axes are in the same direction as orignal analysis axes; + ## if not, change the sign + ## for (j in 1:nf1) + # if (cor(jdudi1$li[,j], dudiCall$li[-ind1,j]) < 0) jdudi1$li[,j] <- -jdudi1$li[,j] + ## then do the BGA on this analysis: + jfac1 <- fac[-ind1] + cla.w1 <- tapply(jdudi1$lw, jfac1, sum) + tabmoy <- apply(jdudi1$tab, 2, mean.w, w = jdudi1$lw, fac = jfac1, cla.w = cla.w1) + tabmoy <- data.frame(tabmoy) + jres <- as.dudi(tabmoy, jdudi1$cw, as.vector(cla.w1), scannf = FALSE, + nf = nf1, call = match.call(), type = "bet") + ## Check that jackknifed axes are in the same direction as original bca axes; + ## if not, change the sign + for (j in 1:nf1) + if (cor(jres$c1[,j], x$c1[,j]) < 0) jres$c1[,j] <- -jres$c1[,j] + U <- as.matrix(jres$c1) * unlist(jres$cw) + ## Compute #ind1 row coordinates in this BGA and store it in xcoo1: + xcoo1[ind1,] <- as.matrix(dudiCall$tab[ind1,]) %*% U + } + PRESS1 <- as.data.frame(matrix(0, lig1, nf1)) + for (j in 1:nf1) PRESS1[,j] <- (xcoo1[,j] - x$ls[,j])^2 + PRESSTot <- colSums(PRESS1) + RMSE <- sqrt(PRESSTot/lig1) + RMSEIQR <- sqrt(PRESSTot/lig1) + for (j in 1:nf1) RMSEIQR[j] <- RMSEIQR[j]/IQR(x$ls[,j]) + names(xcoo1) <- names(PRESS1) <- names(PRESSTot) <- names(RMSE) <- names(RMSEIQR) <- names(x$ls) + res1 <- list(xcoo1, PRESS1, PRESSTot, RMSE, RMSEIQR) + names(res1) <- c("XValCoord", "PRESS", "PRESSTot", "RMSE", "RMSEIQR") + return(res1) +} + +loocv.discrimin <- function(x, progress = FALSE, ...) + ## Leave-one-out cross-validation for discriminant analysis (aka CVA) + ## x = the discrimin analysis to be cross-validated + ## progress = logical to display a progress bar + ## Returns a list with the cross-validated row coordinates (XValCoord), + ## the predicted residual error sum of squares (PRESS) for each individual, + ## the total PRESS for each axis, (PRESSTot), + ## the root-mean-square error (RMSE), and + ## RMSEIQR, the interquartile range normalized RMSE. + # +{ + if (!inherits(x, "discrimin")) + stop("Object of class discrimin expected") + discCall <- x$call + ## Get the parameters of the original analysis: + ## dudi, factor, and number of rows + nf1 <- x$nf + dudiOrig <- eval.parent(discCall[[2]]) + rank <- dudiOrig$rank + dudiOrig <- redo.dudi(dudiOrig, rank) + fac <- eval.parent(discCall[[3]]) + lig1 <- nrow(dudiOrig$tab) + if (length(fac) != lig1) + stop("Non convenient dimension") + xcoo1 <- as.data.frame(matrix(0, lig1, nf1)) + mean.w <- function(x, w, fac, cla.w) { + z <- x * w + z <- tapply(z, fac, sum)/cla.w + return(z) + } + if (progress) pb <- progress_bar$new(total = lig1, + format = " Computing [:bar] :percent eta: :eta") + for (ind1 in 1:lig1) { + if (progress) pb$tick() + ## Remove each row of the data table, one at a time, + ## then do the original analysis and the discriminant analysis + ## on the new table and estimate the coordinates of the missing row + # + ## The original analysis can be any dudi, so wee need to start from dudiOrig$call: + origCall <- dudiOrig$call + ## Change the df argument to discard row #ind1: + origCall[[2]] <- eval.parent(origCall[[2]])[-ind1, ] + ## Check that the scannf argument is set to FALSE: + if (any(names(origCall) == "scannf")) origCall[[which(names(origCall) == "scannf")]] <- FALSE + else { + ## If scannf is not in the args list, add it and is set to FALSE: + origCall[[length(origCall) + 1]] <- quote(FALSE) + names(origCall)[length(origCall)] <- "scannf" + } + if (inherits(dudiOrig, "fca") || inherits(dudiOrig, "fpca")) { + colblo1 <- attr(origCall[[2]], "col.blocks") + origCall[[2]] <- prep.fuzzy.var(origCall[[2]], colblo1) + } + ## Run the analysis without row #ind1: + dudi1 <- eval.parent(origCall) + rank1 <- dudi1$rank + dudi1 <- redo.dudi(dudi1, rank1) + ## Check that axes are in the same direction as orignal analysis axes; + ## if not, change the sign + ## for (j in 1:nf1) + # if (cor(dudi1$li[,j], dudiOrig$li[-ind1,j]) < 0) dudi1$li[,j] <- -dudi1$li[,j] + ## then do the discriminant analysis: + jfac1 <- fac[-ind1] + disc2 <- discrimin(dudi1, jfac1, scannf = FALSE) + ## Check that jackknifed axes are in the same direction as original discrimin axes; + ## if not, change the sign + for (j in 1:nf1) + if (cor(disc2$fa[,j], x$fa[,j]) < 0) disc2$fa[,j] <- -disc2$fa[,j] + ## Compute #ind1 row coordinates in this discriminant analysis and store it in xcoo1: + xcoo1[ind1,] <- as.matrix(dudiOrig$tab[ind1,]) %*% as.matrix(disc2$fa) + } + PRESS1 <- as.data.frame(matrix(0, lig1, nf1)) + for (j in 1:nf1) PRESS1[,j] <- (xcoo1[,j] - x$li[,j])^2 + PRESSTot <- colSums(PRESS1) + RMSE <- sqrt(PRESSTot/lig1) + RMSEIQR <- sqrt(PRESSTot/lig1) + for (j in 1:nf1) RMSEIQR[j] <- RMSEIQR[j]/IQR(x$li[,j]) + names(xcoo1) <- names(PRESS1) <- names(PRESSTot) <- names(RMSE) <- names(RMSEIQR) <- names(x$li[1:nf1]) + res1 <- list(xcoo1, PRESS1, PRESSTot, RMSE, RMSEIQR) + names(res1) <- c("XValCoord", "PRESS", "PRESSTot", "RMSE", "RMSEIQR") + return(res1) +} + +loocv.dudi <- function(x, progress = FALSE, ...) + ## Leave-one-out cross-validation for a dudi analysis + ## x = the dudi to be cross-validated + ## progress = logical to display a progress bar + ## Returns a list with the cross-validated row coordinates (XValCoord), + ## the predicted residual error sum of squares (PRESS) for each individual, + ## the total PRESS for each axis, (PRESSTot), + ## the root-mean-square error (RMSE), and + ## RMSEIQR, the interquartile range normalized RMSE. + # +{ + if (!inherits(x, "dudi")) + stop("Object of class dudi expected") + if (!(inherits(x, "pca") | inherits(x, "coa") | inherits(x, "acm"))) + stop("Leave-one-out cross-validation not available for this type of analysis") + dudiCall <- x$call + nf1 <- x$nf + tab1 <- eval.parent(dudiCall[[2]]) + lig1 <- nrow(tab1) + xcoo1 <- as.data.frame(matrix(0, lig1, nf1)) + if (progress) pb <- progress_bar$new(total = lig1, + format = " Computing [:bar] :percent eta: :eta") + for (ind1 in 1:lig1) { + if (progress) pb$tick() + ## Remove each row of the data table, one at a time, + ## then do the analysis on the new table and estimate the coordinates + ## of all the rows except the one that was removed + # + tab2 <- tab1[-ind1, ] + ## Check that the scannf argument is set to FALSE: + if (any(names(dudiCall) == "scannf")) dudiCall[[which(names(dudiCall) == "scannf")]] <- FALSE + else { + ## If scannf is not in the args list, add it and is set to FALSE: + dudiCall[[length(dudiCall) + 1]] <- quote(FALSE) + names(dudiCall)[length(dudiCall)] <- "scannf" + } + ## Set the nf argument to the value of the nf of the analysis: + if (any(names(dudiCall) == "nf")) dudiCall[[which(names(dudiCall) == "nf")]] <- nf1 + ## If nf is not in the args list, add it and is set to nf1: + else { + dudiCall[[length(dudiCall) + 1]] <- nf1 + names(dudiCall)[length(dudiCall)] <- "nf" + } + ## Run the analysis without row #ind1: + dudiCall[[2]] <- tab2 + jdudi <- eval.parent(dudiCall) + ## Check that axes are in the same direction as orignal analysis axes; if not, change the sign + for (j in 1:nf1) + if (cor(jdudi$c1[, j], x$c1[, j]) < 0) jdudi$c1[,j] <- -jdudi$c1[,j] + + ## Compute #ind1 row coordinates in the analysis and store it in xcoo1: + xcoo1[ind1, ] <- as.matrix(x$tab[ind1, , drop = FALSE]) %*% (as.matrix(jdudi$c1) * jdudi$cw) + + } + + + PRESS1 <- as.data.frame(matrix(0, lig1, nf1)) + for (j in 1:nf1) PRESS1[,j] <- (xcoo1[,j] - x$li[,j])^2 + PRESSTot <- colSums(PRESS1) + RMSE <- sqrt(PRESSTot/lig1) + RMSEIQR <- sqrt(PRESSTot/lig1) + for (j in 1:nf1) RMSEIQR[j] <- RMSEIQR[j]/IQR(x$li[,j]) + names(xcoo1) <- names(PRESS1) <- names(PRESSTot) <- names(RMSE) <- names(RMSEIQR) <- names(x$li[1:nf1]) + res1 <- list(xcoo1, PRESS1, PRESSTot, RMSE, RMSEIQR) + names(res1) <- c("XValCoord", "PRESS", "PRESSTot", "RMSE", "RMSEIQR") + return(res1) +} diff -Nru ade4-1.7-13/R/mbpcaiv.R ade4-1.7-16/R/mbpcaiv.R --- ade4-1.7-13/R/mbpcaiv.R 2017-12-05 14:49:39.000000000 +0000 +++ ade4-1.7-16/R/mbpcaiv.R 2020-10-16 11:22:21.000000000 +0000 @@ -24,12 +24,8 @@ 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") + if (!any(dudi.type(dudiY$call) == c(3,4))) + stop("Only implemented for centred pca") option <- match.arg(option) @@ -38,7 +34,7 @@ ## ------------------------------------------------------------------------------- ## Preparation of the data frames - Y <- scalewt(as.matrix(dudiY$tab), wt = dudiY$lw, center = TRUE, scale = scale) + Y <- as.matrix(dudiY$tab) nblo <- length(ktabX$blo) Xk <- lapply(unclass(ktabX)[1 : nblo], scalewt, wt = ktabX$lw, center = TRUE, scale = scale) @@ -185,19 +181,6 @@ 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 ##----------------------------------------------------------------------- @@ -240,7 +223,6 @@ 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 -Nru ade4-1.7-13/R/mbpls.R ade4-1.7-16/R/mbpls.R --- ade4-1.7-13/R/mbpls.R 2017-12-05 14:49:33.000000000 +0000 +++ ade4-1.7-16/R/mbpls.R 2020-10-16 11:22:21.000000000 +0000 @@ -24,8 +24,8 @@ 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") + 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))) @@ -38,7 +38,7 @@ ## ------------------------------------------------------------------------------- ## Preparation of the data frames - Y <- scalewt(as.matrix(dudiY$tab), wt = dudiY$lw, center = TRUE, scale = scale) + Y <- as.matrix(dudiY$tab) nblo <- length(ktabX$blo) Xk <- lapply(unclass(ktabX)[1 : nblo], scalewt, wt = ktabX$lw, center = TRUE, scale = scale) @@ -177,19 +177,6 @@ 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 ##----------------------------------------------------------------------- @@ -232,7 +219,6 @@ 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 -Nru ade4-1.7-13/R/multiblock.R ade4-1.7-16/R/multiblock.R --- ade4-1.7-13/R/multiblock.R 2017-10-09 13:09:17.000000000 +0000 +++ ade4-1.7-16/R/multiblock.R 2020-10-16 11:22:21.000000000 +0000 @@ -16,7 +16,6 @@ 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 @@ -37,7 +36,8 @@ for (i in 1 : nrepet){ s <- sample(x = nr, replace = TRUE) Xboot <- X[, s, ] - Yboot <- Y[s, ] + Yboot <- Y[s, ] + Yboot$call <- Y$call # to pass dudi.type resboot <- do.call(method, list(dudiY = Yboot, ktabX = Xboot, scale = scale, option = option, scannf = FALSE, nf = as.integer(optdim))) @@ -94,21 +94,18 @@ Xv <- X[, -s, ] Yc <- Y[s, ] Yv <- Y[-s, ] + Yc$call <- Yv$call <- Y$call # to pass dudi.type ## 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) + residYc <- as.matrix(rescal$tabY) - as.matrix(rescal$tabX) %*% XYcoef.cal + RMSEC[i, j] <- sqrt(sum(residYc^2) / (Nc * q)) + residYv <- as.matrix(resval$tabY) - as.matrix(resval$tabX) %*% XYcoef.cal RMSEV[i, j] <- sqrt(sum(residYv^2) / (Nv * q)) } } diff -Nru ade4-1.7-13/R/multispati.R ade4-1.7-16/R/multispati.R --- ade4-1.7-13/R/multispati.R 2017-12-05 14:47:04.000000000 +0000 +++ ade4-1.7-16/R/multispati.R 2020-10-16 11:22:21.000000000 +0000 @@ -3,75 +3,78 @@ .Deprecated(new="multispati", package="ade4", msg="This function is now deprecated. Please use the 'multispati' function in the 'adespatial' package.") - 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 + 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)) - 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) + 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, ...) { + .Deprecated(new="summary.multispati", package="ade4", + msg="This method is now deprecated. Please use the 'summary.multispati' method in the 'adespatial' package.") + norm.w <- function(X, w) { f2 <- function(v) sum(v * v * w)/sum(w) norm <- apply(X, 2, f2) @@ -124,92 +127,99 @@ -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") +"print.multispati" <- function(x, ...) { + + .Deprecated(new="print.multispati", package="ade4", + msg="This method is now deprecated. Please use the 'print.multispati' method in the 'adespatial' package.") + + 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) - + + .Deprecated(new="plot.multispati", package="ade4", + msg="This method is now deprecated. Please use the 'plot.multispati' method in the 'adespatial' package.") + + 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 -Nru ade4-1.7-13/R/optimEH.R ade4-1.7-16/R/optimEH.R --- ade4-1.7-13/R/optimEH.R 2017-11-02 14:23:41.000000000 +0000 +++ ade4-1.7-16/R/optimEH.R 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -"optimEH" <- function(phyl, nbofsp, tol = 1e-8, give.list = TRUE) -{ - .Deprecated(new="optimEH", package="ade4", - msg="This function is now deprecated. Please use the 'optimEH' function in the 'adiv' package.") - 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 -Nru ade4-1.7-13/R/orisaved.R ade4-1.7-16/R/orisaved.R --- ade4-1.7-13/R/orisaved.R 2017-11-02 14:23:46.000000000 +0000 +++ ade4-1.7-16/R/orisaved.R 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -"orisaved" <- function(phyl, rate = 0.1, method = 1) -{ - .Deprecated(new="orisaved", package="ade4", - msg="This function is now deprecated. Please use the 'orisaved' function in the 'adiv' package.") - 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 -Nru ade4-1.7-13/R/randEH.R ade4-1.7-16/R/randEH.R --- ade4-1.7-13/R/randEH.R 2017-11-02 14:23:47.000000000 +0000 +++ ade4-1.7-16/R/randEH.R 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -"randEH" <- function(phyl, nbofsp, nbrep = 10) -{ - .Deprecated(new="randEH", package="ade4", - msg="This function is now deprecated. Please use the 'randEH' function in the 'adiv' package.") - 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 -Nru ade4-1.7-13/R/randtest.dpcoa.R ade4-1.7-16/R/randtest.dpcoa.R --- ade4-1.7-13/R/randtest.dpcoa.R 2017-02-14 17:02:38.000000000 +0000 +++ ade4-1.7-16/R/randtest.dpcoa.R 2020-10-16 11:22:21.000000000 +0000 @@ -1,4 +1,4 @@ -randtest.dpcoa <- function(xtest, model = c("1p","1s"), nrep = 99, alter = c("greater", "less", "two-sided"), ...){ +randtest.dpcoa <- function(xtest, model = c("1p","1s"), nrepet = 99, alter = c("greater", "less", "two-sided"), ...){ if (!inherits(xtest, "dpcoa")) stop("Type 'dpcoa' expected") @@ -43,7 +43,7 @@ } - ressim <- sapply(1:nrep, funrandomization) + ressim <- sapply(1:nrepet, funrandomization) res <- as.randtest(obs = obs, sim = ressim, alter = alter, call = match.call(), ...) return(res) diff -Nru ade4-1.7-13/R/suprow.pta.R ade4-1.7-16/R/suprow.pta.R --- ade4-1.7-13/R/suprow.pta.R 1970-01-01 00:00:00.000000000 +0000 +++ ade4-1.7-16/R/suprow.pta.R 2020-10-16 11:22:21.000000000 +0000 @@ -0,0 +1,55 @@ +"suprow.pta" <- function(x, Xsup, facSup, ...) { + if (!inherits(x, "pta")) + stop("Object of class 'pta' expected") + if(!inherits(Xsup, "data.frame")) + stop("Object of class 'data.frame' expected") + if(!is.factor(facSup)) + stop("factor expected") + lig <- nrow(Xsup) + if(length(facSup) != lig) + stop("Non convenient dimension") + appel <- as.list(x$call) + kta2 <- eval.parent(appel$X) + appel.kta2 <- as.list(kta2$call) + kta1 <- eval.parent(appel.kta2$x) + appel.kta1 <- as.list(kta1$call) + wit1 <- eval.parent(appel.kta1$dudiwit) + appel.wit1 <- as.list(wit1$call) + ok <- (appel.wit1[[1]] == "withinpca") && (appel.kta1[[1]] == "ktab.within") && (appel.kta2[[1]] == "t.ktab") && (appel[[1]] == "pta") + if (!ok) + stop("Non convenient call sequence") + dfX <- eval.parent(appel.wit1$df) + facX <- eval.parent(appel.wit1$fac) + dfXw <- scalewt(dfX, center = TRUE, scale = TRUE) + mean.dfXw <- attr(dfXw, "scaled:center") + var.dfXw <- attr(dfXw, "scaled:scale") + Xsupmean <- sweep(Xsup, 2, mean.dfXw, "-") + Xsupw <- sweep(Xsupmean, 2, var.dfXw, "/") + scaling <- appel.wit1$scaling + if (scaling == "total") { + dfXw <- scalewt(dfXw, center = FALSE, scale = TRUE) + dfXw2 <- data.frame() + for (i in levels(facX)) { + w <- dfXw[facX == i, ] + w <- scalewt(w, center = TRUE, scale = FALSE) + dfXw2 <- rbind(dfXw2, w) + mean.w <- attr(w, "scaled:center") + Xsupw[facSup == i, ] <- sweep(Xsupw[facSup == i, ], 2, mean.w, "-") + } + dfXw2 <- scalewt(dfXw2, center = FALSE, scale = TRUE) + var.dfXw2 <- attr(dfXw2, "scaled:scale") + Xsupw <- sweep(Xsupw, 2, var.dfXw2, "/") + } + if (scaling == "partial") { + for (i in levels(facX)) { + w <- dfXw[facX == i, ] + w <- scalewt(w, center = TRUE, scale = TRUE) + mean.w <- attr(w, "scaled:center") + var.w <- attr(w, "scaled:scale") + Xsupw[facSup == i, ] <- sweep(Xsupw[facSup == i, ], 2, mean.w, "-") + Xsupw[facSup == i, ] <- sweep(Xsupw[facSup == i, ], 2, var.w, "/") + } + } + coosup <- as.matrix(Xsupw) %*% (as.matrix(x$c1) * x$cw) + return(list(tabsup = Xsupw, lisup = coosup)) +} \ No newline at end of file diff -Nru ade4-1.7-13/R/suprow.R ade4-1.7-16/R/suprow.R --- ade4-1.7-13/R/suprow.R 2018-04-04 08:38:11.000000000 +0000 +++ ade4-1.7-16/R/suprow.R 2020-10-16 11:22:21.000000000 +0000 @@ -35,8 +35,8 @@ "suprow.dudi" <- function (x, Xsup, ...) { # modif pour Culhane, Aedin" # 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") + 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") @@ -155,4 +155,4 @@ coosup <- data.frame(coosup, row.names = row.names(Xsup)) names(coosup) <- names(x$li) return(list(tabsup = Xsup, lisup = coosup)) -} \ No newline at end of file +}