Commit e1365710 by Eric Coissac

Version of the module related to the manuscript on IRLs

parent 142cdcb8
...@@ -13,17 +13,22 @@ RoxygenNote: 6.1.1 ...@@ -13,17 +13,22 @@ RoxygenNote: 6.1.1
Imports: MASS, Imports: MASS,
permute, permute,
expm, expm,
Matrix,
mvtnorm, mvtnorm,
stats, stats,
roxygen2 doParallel,
foreach
Suggests: knitr, Suggests: knitr,
rmarkdown, rmarkdown,
roxygen2,
vegan vegan
VignetteBuilder: knitr VignetteBuilder: knitr
Collate: Collate:
'IR.R'
'internals.R' 'internals.R'
'procmod_frame.R' 'procmod_frame.R'
'multivariate.R' 'multivariate.R'
'covls.R' 'covls.R'
'corls_test.R'
'procuste.R' 'procuste.R'
'simulate.R' 'simulate.R'
# Generated by roxygen2: do not edit by hand # Generated by roxygen2: do not edit by hand
S3method("$",procmod.corls)
S3method("$",procmod.varls)
S3method("$<-",procmod.frame) S3method("$<-",procmod.frame)
S3method("[",procmod.frame) S3method("[",procmod.frame)
S3method("[[<-",procmod.frame) S3method("[[<-",procmod.frame)
...@@ -7,9 +9,11 @@ S3method(as.data.frame,dist) ...@@ -7,9 +9,11 @@ S3method(as.data.frame,dist)
S3method(as.list,procmod.frame) S3method(as.list,procmod.frame)
S3method(as.procmod.frame,array) S3method(as.procmod.frame,array)
S3method(as.procmod.frame,list) S3method(as.procmod.frame,list)
S3method(as.procmod.frame,matrix)
S3method(as.procmod.frame,pm) S3method(as.procmod.frame,pm)
S3method(as.procmod.frame,procmod.frame) S3method(as.procmod.frame,procmod.frame)
S3method(dim,procmod.frame) S3method(dim,procmod.frame)
S3method(names,procmod.varls)
S3method(ortho,data.frame) S3method(ortho,data.frame)
S3method(ortho,dist) S3method(ortho,dist)
S3method(ortho,matrix) S3method(ortho,matrix)
...@@ -21,6 +25,8 @@ export(as.procmod.frame) ...@@ -21,6 +25,8 @@ export(as.procmod.frame)
export(bicenter) export(bicenter)
export(corls) export(corls)
export(corls.partial) export(corls.partial)
export(corls.test)
export(icor)
export(is.euclid) export(is.euclid)
export(is.procmod.frame) export(is.procmod.frame)
export(nmds) export(nmds)
...@@ -33,4 +39,5 @@ export(simulate_correlation) ...@@ -33,4 +39,5 @@ export(simulate_correlation)
export(simulate_matrix) export(simulate_matrix)
export(varls) export(varls)
import(MASS) import(MASS)
import(expm) import(doParallel)
import(foreach)
#' @author Christelle Gonindard-Melodelima
#' @author Eric Coissac
NULL
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
icor <- function(x, y = NULL) {
if (is.data.frame(y)) {
y <- as.matrix(y)
}
if (is.data.frame(x)) {
x <- as.matrix(x)
}
if (!is.matrix(x) && is.null(y)) {
stop("supply both 'x' and 'y' or a matrix-like 'x'")
}
if (!(is.numeric(x) || is.logical(x))) {
stop("'x' must be numeric")
}
stopifnot(is.atomic(x))
if (!is.null(y)) {
if (!(is.numeric(y) || is.logical(y))) {
stop("'y' must be numeric")
}
stopifnot(is.atomic(y))
}
if (!is.matrix(x)) {
x <- t(t(x))
}
if (is.null(y)) {
y <- x
}
if (!is.matrix(y)) {
y <- t(t(y))
}
xc <- scale(x, scale = FALSE, center = TRUE)
yc <- scale(y, scale = FALSE, center = TRUE)
n <- nrow(x)
cov <- crossprod(xc, yc) / (n - 1)
print(cov)
sdx <- apply(x, MARGIN = 2, sd)
sdy <- apply(y, MARGIN = 2, sd)
rcov <- sqrt(1 / (n - 1)) * (sdx %o% sdy)
print(rcov)
s <- sign(cov)
icov <- (s * cov - rcov) * s
print(icov)
isdx <- sqrt(1 - sqrt(1 / (n - 1))) * sdx
isdy <- sqrt(1 - sqrt(1 / (n - 1))) * sdy
ipearson <- icov / (isdx %o% isdy)
ipearson
}
#' @include covls.R
#'
#' @author Christelle Gonindard-Melodelima
#' @author Eric Coissac
NULL
#' Generate permutation matrix according to a schema.
#'
#' @param perm
#' @param n
#' @param strata
#'
#'
#' The permutation schema is defined using the `how` function.
#' The implementation of this function is inspired
#' from the VEGAN package and reproduced here to avoid an extra
#' dependency on an hidden vegan function.
#'
getPermuteMatrix = function(perm, n, strata = NULL)
{
if (length(perm) == 1) {
perm <- permute::how(nperm = perm)
}
if (!missing(strata) && !is.null(strata)) {
if (inherits(perm, "how") && is.null(permute::getBlocks(perm)))
permute::setBlocks(perm) <- strata
}
if (inherits(perm, "how"))
perm <- permute::shuffleSet(n, control = perm)
else {
if (!is.integer(perm) && !all(perm == round(perm)))
stop("permutation matrix must be strictly integers: use round()")
}
if (is.null(attr(perm, "control")))
attr(perm, "control") <- structure(list(within = list(type = "supplied matrix"),
nperm = nrow(perm)), class = "how")
perm
}
#' Compute the person correlation matrix of K coordinate matrices
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
corls.test <- function(...,
permutations = permute::how(nperm = 999),
p.adjust.method="holm") {
eps <- sqrt(sqrt(.Machine$double.eps))
xs <- list(...)
if (length(xs) == 1) {
x <- xs[[1]]
if (is.procmod.frame(x)) {
xs <- x
} else {
xs <- procmod.frame(x)
}
}
else {
xs <- as.procmod.frame(xs)
}
x_names <- names(xs)
xs <- ortho(xs)
cov <- varls(xs, nperm = 0)
lcov <- cov - eps
ngreater <- array(0,dim = dim(cov))
n <- nrow(xs)
nx <- length(xs)
pmatrix <- getPermuteMatrix(permutations, n)
if (ncol(pmatrix) != n) {
stop(gettextf(
"'permutations' have %d columns, but data have %d observations",
ncol(pmatrix), n
))
}
npermutation <- nrow(pmatrix)
for (i in seq_len(npermutation)) {
ps <- sample(1:npermutation,
size = nx,
replace = FALSE
)
rcov = varls(as.procmod.frame(
lapply(
1:nx,
function(j) xs[[j]][pmatrix[ps[j], ], ]
)
),
nperm = 0
)
ngreater <- ngreater + (
rcov >= lcov)
}
p_values <- ngreater / npermutation
diag(p_values) <- 0
c_p_values <- p.adjust(p_values[upper.tri(p_values,diag = FALSE)],
method = p.adjust.method,
n = (nx - 1) * nx / 2)
p_values[upper.tri(p_values,diag = FALSE)] <- c_p_values
p_values <- as.matrix(Matrix::forceSymmetric(p_values, uplo = "U"))
colnames(p_values) <- x_names
rownames(p_values) <- x_names
p_values
}
...@@ -310,6 +310,24 @@ as.procmod.frame.pm <- function(data, ...) { ...@@ -310,6 +310,24 @@ as.procmod.frame.pm <- function(data, ...) {
vars.procmod(terms(data), data$model) vars.procmod(terms(data), data$model)
} }
#' Coerce to a ProcMod Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.procmod.frame.matrix <- function(data, ...) {
l <- vector(mode = "list", length = ncol(data))
for (i in seq_len(ncol(data))) {
l[[i]] <- data[, i]
}
if (!is.null(colnames(data))) {
names(l) <- colnames(data)
}
as.procmod.frame(l)
}
#' Dimensions of a Matrix Frame. #' Dimensions of a Matrix Frame.
#' #'
#' @author Eric Coissac #' @author Eric Coissac
......
...@@ -8,7 +8,7 @@ NULL ...@@ -8,7 +8,7 @@ NULL
#' the variances to 1 with all the covariances set to 0. #' the variances to 1 with all the covariances set to 0.
#' #'
#' @export #' @export
simulate_matrix <- function(n, p, equal.var = FALSE) { simulate_matrix <- function(n, p, equal.var = TRUE) {
new <- rnorm(n * p, mean = 0, sd = 1) new <- rnorm(n * p, mean = 0, sd = 1)
dim(new) <- c(n, p) dim(new) <- c(n, p)
...@@ -25,36 +25,35 @@ simulate_matrix <- function(n, p, equal.var = FALSE) { ...@@ -25,36 +25,35 @@ simulate_matrix <- function(n, p, equal.var = FALSE) {
#' Simulate n points of dimension p correlated with a reference matrix. #' Simulate n points of dimension p correlated with a reference matrix.
#' #'
#' @export #' @export
simulate_correlation <- function(reference, p, r2, equal.var = FALSE) {
simulate_correlation <- function(reference, p, r2, equal.var = TRUE) {
n <- nrow(reference) n <- nrow(reference)
maxdim <- max(ncol(reference), p) maxdim <- max(ncol(reference), p)
noise <- simulate_matrix(n, p, equal.var = equal.var) noise <- simulate_matrix(n, p, equal.var = equal.var)
if (maxdim == p && maxdim > ncol(reference)) { if (maxdim == p && maxdim > ncol(reference)) {
temp <- reference # noise is the largest matrix
reference <- noise YX <- crossprod(noise, reference)
noise <- temp svd.YX <- svd(YX)
switched <- TRUE rot <- svd.YX$v %*% t(svd.YX$u)
} rotr <- svd.YX$u %*% t(svd.YX$v)
else {
switched <- FALSE
}
noise.rotate <- protate(noise, reference) print(rot)
print(rotr)
inflate <- sqrt(r2 / (1 - r2)) new = ((reference %*% rot) * sqrt(r2) +
noise * sqrt(1 - r2)) %*% rotr
}
else {
# reference is the largest matrix
YX <- crossprod(reference, noise)
svd.YX <- svd(YX)
rot <- svd.YX$v %*% t(svd.YX$u)
rotr <- svd.YX$u %*% t(svd.YX$v)
if (switched) { new = (reference * sqrt(r2) +
new <- protate( (noise %*% rot) * sqrt(1 - r2)) %*% rotr
noise.rotate * inflate + reference,
reference
)
} else {
new <- protate(
reference * inflate + noise.rotate,
noise
)
} }
new <- scale(new, scale = FALSE) new <- scale(new, scale = FALSE)
...@@ -65,4 +64,4 @@ simulate_correlation <- function(reference, p, r2, equal.var = FALSE) { ...@@ -65,4 +64,4 @@ simulate_correlation <- function(reference, p, r2, equal.var = FALSE) {
return(new) return(new)
} }
# simulate_matrix_tree #simulate_matrix_tree
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/procmod_frame.R
\name{as.procmod.frame.matrix}
\alias{as.procmod.frame.matrix}
\title{Coerce to a ProcMod Frame.}
\usage{
\method{as.procmod.frame}{matrix}(data, ...)
}
\description{
Coerce to a ProcMod Frame.
}
\author{
Eric Coissac
Christelle Gonindard-Melodelima
}
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
\alias{corls} \alias{corls}
\title{Compute the person correlation matrix of K coordinate matrices} \title{Compute the person correlation matrix of K coordinate matrices}
\usage{ \usage{
corls(..., nperm = 100, rcovls = FALSE) corls(..., nrand = 100, p.adjust.method = "holm")
} }
\description{ \description{
Compute the person correlation matrix of K coordinate matrices Compute the person correlation matrix of K coordinate matrices
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
\alias{corls.partial} \alias{corls.partial}
\title{Compute the person partial correlation matrix of K coordinate matrices} \title{Compute the person partial correlation matrix of K coordinate matrices}
\usage{ \usage{
corls.partial(..., nperm = 100, rcovls = FALSE) corls.partial(..., nrand = 100)
} }
\description{ \description{
Compute the person partial correlation matrix of K coordinate matrices Compute the person partial correlation matrix of K coordinate matrices
......
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/corls_test.R
\name{corls.test}
\alias{corls.test}
\title{Compute the person correlation matrix of K coordinate matrices}
\usage{
corls.test(..., permutations = permute::how(nperm = 999),
p.adjust.method = "holm")
}
\description{
Compute the person correlation matrix of K coordinate matrices
}
\author{
Eric Coissac
Christelle Gonindard-Melodelima
}
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/corls_test.R
\name{getPermuteMatrix}
\alias{getPermuteMatrix}
\title{Generate permutation matrix according to a schema.}
\usage{
getPermuteMatrix(perm, n, strata = NULL)
}
\arguments{
\item{strata}{The permutation schema is defined using the `how` function.
The implementation of this function is inspired
from the VEGAN package and reproduced here to avoid an extra
dependency on an hidden vegan function.}
}
\description{
Generate permutation matrix according to a schema.
}
...@@ -21,7 +21,6 @@ Internal function do not use. ...@@ -21,7 +21,6 @@ Internal function do not use.
\examples{ \examples{
m <- matrix(1:16, nrow = 4) m <- matrix(1:16, nrow = 4)
ProcMod:::.Trace(m) ProcMod:::.Trace(m)
} }
\author{ \author{
Eric Coissac Eric Coissac
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
\alias{simulate_correlation} \alias{simulate_correlation}
\title{Simulate n points of dimension p correlated with a reference matrix.} \title{Simulate n points of dimension p correlated with a reference matrix.}
\usage{ \usage{
simulate_correlation(reference, p, r2, equal.var = FALSE) simulate_correlation(reference, p, r2, equal.var = TRUE)
} }
\description{ \description{
Simulate n points of dimension p correlated with a reference matrix. Simulate n points of dimension p correlated with a reference matrix.
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
\alias{simulate_matrix} \alias{simulate_matrix}
\title{Simulate n points of dimension p.} \title{Simulate n points of dimension p.}
\usage{ \usage{
simulate_matrix(n, p, equal.var = FALSE) simulate_matrix(n, p, equal.var = TRUE)
} }
\description{ \description{
Points are simulated using the \code{\link[mvtnorm]{rmvnorm}} from Points are simulated using the \code{\link[mvtnorm]{rmvnorm}} from
......
...@@ -4,12 +4,19 @@ ...@@ -4,12 +4,19 @@
\alias{varls} \alias{varls}
\title{Compute the variance, covariance matrix of K coordinate matrices.} \title{Compute the variance, covariance matrix of K coordinate matrices.}
\usage{ \usage{
varls(..., nperm = 100, rcovls = FALSE) varls(..., nrand = 100, p.adjust.method = "holm")
} }
\arguments{ \arguments{
\item{...}{the set of matrices} \item{...}{the set of matrices}
\item{rcovls}{} \item{nrand}{number of randomisation used to estimate the mean
covariance observed between two random matrix.}
\item{p.adjust.method}{the multiple test correction method used
to adjust p values. \code{p.adjust.method} belongs
one of the folowing values: "holm", "hochberg", "hommel",
"bonferroni", "BH", "BY", "fdr", "none". The default is
set to "holm".}
} }
\description{ \description{
Covariance between two matrices is defined as the sum of the Covariance between two matrices is defined as the sum of the
...@@ -22,8 +29,8 @@ A <- matrix(1:9, nrow = 3) ...@@ -22,8 +29,8 @@ A <- matrix(1:9, nrow = 3)
B <- matrix(10:15, nrow = 3) B <- matrix(10:15, nrow = 3)
C <- matrix(20:31, nrow = 3) C <- matrix(20:31, nrow = 3)
# compute the variance covariance matrix # compute the variance covariance matrix
varls2(A, B, C) varls(A, B, C)
varls2(A = A, B = B, C = C) varls(A = A, B = B, C = C)
} }
\author{ \author{
Eric Coissac Eric Coissac
......
% ALGORITHM STYLE -- Released 8 April 1996
% for LaTeX-2e
% Copyright -- 1994 Peter Williams
%
% E-mail pwil3058@bigpond.net.au
%
% This style file is free software; you can redistribute it and/or
% modify it under the terms of the GNU Lesser General Public
% License as published by the Free Software Foundation; either
% version 2 of the License, or (at your option) any later version.
%
% This style file is distributed in the hope that it will be useful,
% but WITHOUT ANY WARRANTY; without even the implied warranty of
% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
% Lesser General Public License for more details.
%
% You should have received a copy of the GNU Lesser General Public
% License along with this style file; if not, write to the
% Free Software Foundation, Inc., 59 Temple Place - Suite 330,
% Boston, MA 02111-1307, USA.
%
\NeedsTeXFormat{LaTeX2e}
\ProvidesPackage{algorithm}
\typeout{Document Style `algorithm' - floating environment}
\RequirePackage{float}
\RequirePackage{ifthen}
\newcommand{\ALG@within}{nothing}
\newboolean{ALG@within}
\setboolean{ALG@within}{false}
\newcommand{\ALG@floatstyle}{ruled}
\newcommand{\ALG@name}{Algorithm}
\newcommand{\listalgorithmname}{List of \ALG@name s}
% Declare Options
% first appearance
\DeclareOption{plain}{
\renewcommand{\ALG@floatstyle}{plain}
}
\DeclareOption{ruled}{
\renewcommand{\ALG@floatstyle}{ruled}
}
\DeclareOption{boxed}{
\renewcommand{\ALG@floatstyle}{boxed}
}
% then numbering convention
\DeclareOption{part}{
\renewcommand{\ALG@within}{part}
\setboolean{ALG@within}{true}
}
\DeclareOption{chapter}{
\renewcommand{\ALG@within}{chapter}
\setboolean{ALG@within}{true}
}
\DeclareOption{section}{
\renewcommand{\ALG@within}{section}
\setboolean{ALG@within}{true}
}
\DeclareOption{subsection}{
\renewcommand{\ALG@within}{subsection}
\setboolean{ALG@within}{true}
}
\DeclareOption{subsubsection}{
\renewcommand{\ALG@within}{subsubsection}
\setboolean{ALG@within}{true}
}
\DeclareOption{nothing}{
\renewcommand{\ALG@within}{nothing}
\setboolean{ALG@within}{true}
}
\DeclareOption*{\edef\ALG@name{\CurrentOption}}
% ALGORITHM
%
\ProcessOptions
\floatstyle{\ALG@floatstyle}
\ifthenelse{\boolean{ALG@within}}{
\ifthenelse{\equal{\ALG@within}{part}}
{\newfloat{algorithm}{htbp}{loa}[part]}{}
\ifthenelse{\equal{\ALG@within}{chapter}}
{\newfloat{algorithm}{htbp}{loa}[chapter]}{}
\ifthenelse{\equal{\ALG@within}{section}}
{\newfloat{algorithm}{htbp}{loa}[section]}{}
\ifthenelse{\equal{\ALG@within}{subsection}}
{\newfloat{algorithm}{htbp}{loa}[subsection]}{}
\ifthenelse{\equal{\ALG@within}{subsubsection}}
{\newfloat{algorithm}{htbp}{loa}[subsubsection]}{}
\ifthenelse{\equal{\ALG@within}{nothing}}
{\newfloat{algorithm}{htbp}{loa}}{}
}{
\newfloat{algorithm}{htbp}{loa}
}
\floatname{algorithm}{\ALG@name}
\newcommand{\listofalgorithms}{\listof{algorithm}{\listalgorithmname}}
\ No newline at end of file
% ALGORITHMIC STYLE for LaTeX version 2e
%
% This style file is free software; you can redistribute it and/or
% modify it under the terms of the GNU Lesser General Public
% License as published by the Free Software Foundation; either
% version 2 of the License, or (at your option) any later version.
%
% This style file is distributed in the hope that it will be useful,
% but WITHOUT ANY WARRANTY; without even the implied warranty of
% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
% Lesser General Public License for more details.
%
% You should have received a copy of the GNU Lesser General Public
% License along with this style file; if not, write to the
% Free Software Foundation, Inc., 59 Temple Place - Suite 330,
% Boston, MA 02111-1307, USA.
%
\NeedsTeXFormat{LaTeX2e}
\ProvidesPackage{algorithmic}[2006/06/02]
\typeout{Document Style `algorithmic' - environment}
%
\RequirePackage{ifthen}
\RequirePackage{calc}
\RequirePackage{keyval}
\newboolean{ALC@noend}
\setboolean{ALC@noend}{false}
\newcounter{ALC@line}
\newcounter{ALC@rem}
\newcounter{ALC@depth}
\newlength{\ALC@tlm}
%
\DeclareOption{noend}{\setboolean{ALC@noend}{true}}
%
\ProcessOptions
%
% For keyval-style options
\def\algsetup{\setkeys{ALG}}
%
% For indentation of algorithms
\newlength{\algorithmicindent}
\setlength{\algorithmicindent}{0pt}
\define@key{ALG}{indent}{\setlength{\algorithmicindent}{#1}}
\ifthenelse{\lengthtest{\algorithmicindent=0pt}}%
{\setlength{\algorithmicindent}{1em}}{}
%
% For line numbers' delimiters
\newcommand{\ALC@linenodelimiter}{:}
\define@key{ALG}{linenodelimiter}{\renewcommand{\ALC@linenodelimiter}{#1}}