Commit 142cdcb8 by Eric Coissac

First round of source cleaning to focus only on correlation

parent 6f7e253c
...@@ -6,3 +6,9 @@ inst/doc ...@@ -6,3 +6,9 @@ inst/doc
.DS_Store .DS_Store
vignettes.ooo vignettes.ooo
before_trash before_trash
R2_H0.csv
R2_H0.v2.csv
Simulation_R2_Null.Rmd
Simulation_R2_Null.html
demo.Rmd
demo.html
...@@ -22,15 +22,8 @@ Suggests: knitr, ...@@ -22,15 +22,8 @@ Suggests: knitr,
VignetteBuilder: knitr VignetteBuilder: knitr
Collate: Collate:
'internals.R' 'internals.R'
'procmod.frame.R' 'procmod_frame.R'
'multivariate.R' 'multivariate.R'
'formula.procmod.frame.R'
'omit.action.R'
'model.procmod.R'
'mprocuste.R'
'anova.pm.R'
'covls.R' 'covls.R'
'plot.pm.R'
'procuste.R' 'procuste.R'
'simnull.R'
'simulate.R' 'simulate.R'
...@@ -3,51 +3,34 @@ ...@@ -3,51 +3,34 @@
S3method("$<-",procmod.frame) S3method("$<-",procmod.frame)
S3method("[",procmod.frame) S3method("[",procmod.frame)
S3method("[[<-",procmod.frame) S3method("[[<-",procmod.frame)
S3method(AIC,pm)
S3method(BIC,pm)
S3method(anova,pm)
S3method(as.data.frame,dist) 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,pm) S3method(as.procmod.frame,pm)
S3method(as.procmod.frame,procmod.frame) S3method(as.procmod.frame,procmod.frame)
S3method(deviance,pm)
S3method(dim,procmod.frame) S3method(dim,procmod.frame)
S3method(extractAIC,pm)
S3method(formula,procmod.frame)
S3method(na.exclude,procmod.frame)
S3method(na.omit,procmod.frame)
S3method(ortho,data.frame) S3method(ortho,data.frame)
S3method(ortho,dist) S3method(ortho,dist)
S3method(ortho,matrix) S3method(ortho,matrix)
S3method(ortho,procmod.frame) S3method(ortho,procmod.frame)
S3method(plot,pm)
S3method(print,pm)
S3method(print,procmod.corls) S3method(print,procmod.corls)
S3method(print,procmod.varls) S3method(print,procmod.varls)
S3method(residuals,pm)
S3method(subset,procmod.frame) S3method(subset,procmod.frame)
export(as.procmod.frame) export(as.procmod.frame)
export(bicenter) export(bicenter)
export(corls) export(corls)
export(corls.partial) export(corls.partial)
export(is.euclid) export(is.euclid)
export(is.pm)
export(is.procmod.frame) export(is.procmod.frame)
export(model.procmod.default)
export(nmds) export(nmds)
export(null_varls_sim)
export(ortho) export(ortho)
export(pca) export(pca)
export(pcoa) export(pcoa)
export(pm)
export(procmod.frame) export(procmod.frame)
export(protate) export(protate)
export(simulate_correlation) export(simulate_correlation)
export(simulate_matrix) export(simulate_matrix)
export(varls) export(varls)
export(vars.procmod)
export(weighted.residuals)
import(MASS) import(MASS)
import(expm) import(expm)
#' @include mprocuste.R
#' Anova function for `pm` objects.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
anova.pm = function(m, permutations = how(nperm = 999),...) {
mf = m$model
coef = m$coefficients
sdxy = sqrt(diag(m$cov))
mt = terms(mf)
reponse = attr(mt,"response")
explicatives = attr(mt,'term.labels')
nXs = length(explicatives)
coef.norm = coef * sdxy[explicatives] / sdxy[reponse]
cors = m$cov / outer(sdxy,sdxy)
#print(reponse)
#print(explicatives)
cors.Y = cors[reponse,explicatives]
SCT = m$SCT
SCR = sum(m$residuals^2)
SCE = SCT * abs(coef.norm * cors.Y)
names(SCE) = explicatives
SCET = sum(SCE)
SCIT = SCT - SCET - SCR
SumSq = c(SCE,Residuals=SCR)
Df = c(rep(1,nXs),m$df.residual)
MeanSq = SumSq/Df
Fvalue = c(MeanSq[-length(MeanSq)]/MeanSq[length(MeanSq)],NA)
Pvalue = 1-pf(Fvalue,
Df[-length(MeanSq)],
Df[length(MeanSq)])
result = data.frame(Df,
SumSq,
MeanSq,
Fvalue,
Pvalue)
colnames(result)=c("Df","Sum Sq","Mean Sq","F value","Pr(>F)")
attr(result, "heading")= paste("Analysis of Variance Table\n\nResponse:",
all.vars(m$terms)[1]
)
class(result)=c("anova",class(result))
return(result)
}
#' Generate permutation matrix according to a schema.
#'
#' The permutation schema is defined using the `how` function.
#' The implementation of this function is currectly extraced
#' from the VEGAN package and just copied pasted here to avoid
#' dependency on an hidden vegan function.
#'
getPermuteMatrix = function (perm, N, strata = NULL)
{
if (length(perm) == 1) {
perm <- how(nperm = perm)
}
if (!missing(strata) && !is.null(strata)) {
if (inherits(perm, "how") && is.null(getBlocks(perm)))
setBlocks(perm) <- strata
}
if (inherits(perm, "how"))
perm <- 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
}
#' @include procmod.frame.R #' @include procmod_frame.R
#' @include multivariate.R #' @include multivariate.R
#' #'
#' @import expm #' @import expm
...@@ -9,13 +9,12 @@ NULL ...@@ -9,13 +9,12 @@ NULL
#' Compute the trace of a square matrix. #' Compute the trace of a square matrix.
#' #'
#'
#' @param X a square matrix #' @param X a square matrix
#' @return the trace of X #' @return the trace of X
#' #'
#' @examples #' @examples
#' m = matrix(1:16,nrow=4) #' m <- matrix(1:16, nrow = 4)
#' ProcMod:::.Trace(m) #' ProcMod:::.Trace(m)
#' #'
#' @note Internal function do not use. #' @note Internal function do not use.
#' #'
...@@ -23,7 +22,7 @@ NULL ...@@ -23,7 +22,7 @@ NULL
#' @author Eric Coissac #' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima #' @author Christelle Gonindard-Melodelima
#' #'
.Trace = function(X) sum(diag(X)) .Trace <- function(X) sum(diag(X))
#' Compute the variance, covariance matrix of K coordinate matrices. #' Compute the variance, covariance matrix of K coordinate matrices.
#' #'
...@@ -36,111 +35,114 @@ NULL ...@@ -36,111 +35,114 @@ NULL
#' @param rcovls #' @param rcovls
#' #'
#' @examples #' @examples
#' # Build Three matrices of 3 rows. #' # Build Three matrices of 3 rows.
#' A <- matrix(1:9,nrow=3) #' 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) #' varls2(A, B, C)
#' varls2(A=A,B=B,C=C) #' varls2(A = A, B = B, C = C)
#'
#' @author Eric Coissac #' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima #' @author Christelle Gonindard-Melodelima
#' @export #' @export
varls = function(...,nperm = 100,rcovls=FALSE) { varls <- function(..., nperm = 100, rcovls = FALSE) {
if (is.numeric(nperm) && if (is.numeric(nperm) &&
length(nperm)==1 && length(nperm) == 1 &&
nperm==0) nperm == 0) {
nperm=NULL nperm <- NULL
}
if (is.null(nperm)) if (is.null(nperm)) {
rcovls=FALSE rcovls <- FALSE
}
Xs <- list(...) Xs <- list(...)
if (length(Xs)==1) { if (length(Xs) == 1) {
x = Xs[[1]] x <- Xs[[1]]
if (is.procmod.frame(x)) if (is.procmod.frame(x)) {
Xs=x Xs <- x
else if (is.pm(x)) } else if (is.pm(x)) {
return(x$cov) return(x$cov)
else } else {
Xs=procmod.frame(x) Xs <- procmod.frame(x)
}
}
else {
Xs <- as.procmod.frame(Xs)
} }
else
Xs=as.procmod.frame(Xs)
Xnames=names(Xs) x_names <- names(Xs)
Xs <- ortho(Xs) Xs <- ortho(Xs)
XXs = as.procmod.frame(mapply(tcrossprod, XXs <- as.procmod.frame(mapply(tcrossprod,
Xs, Xs,
SIMPLIFY = FALSE)) SIMPLIFY = FALSE
))
nX = length(Xs) nx <- length(Xs)
N = nrow(Xs)-1 N <- nrow(Xs) - 1
CovXXs = matrix(0, nrow = nX, ncol = nX) cov_xxs <- matrix(0, nrow = nx, ncol = nx)
# Computes the standard Covls covariance matrix # Computes the standard Covls covariance matrix
for (i in seq_len(nX)) for (i in seq_len(nx))
for (j in i:nX) { for (j in i:nx) {
CovXXs[i,j] = Re(.Trace(sqrtm(XXs[[i]] %*% XXs[[j]]))) cov_xxs[i, j] <- Re(.Trace(sqrtm(XXs[[i]] %*% XXs[[j]])))
} }
if (!is.null(nperm)) {
r_cov_xxs <- array(0, dim = c(nperm, nx, nx))
v_xs <- vector(mode = "list", nx)
l_xs <- vapply(Xs, FUN = function(x) prod(dim(x)), 0)
d_xs <- vapply(Xs, FUN = function(x) dim(ortho(x)), c(0, 0))
CovXX2s = matrix(0, nrow = nX, ncol = nX) for (i in seq_len(nx))
v_xs[i] <- list(t(sqrt(colMeans(Xs[i]^2) - colMeans(Xs[i])^2)
if (! is.null(nperm)) { %*% t(rep(1, nrow(Xs[i])))))
rCovXXs = array(0,dim=c(nperm,nX,nX))
vXs=vector(mode="list",nX)
lXs=vapply(Xs,FUN = function(x) prod(dim(x)),0)
dXs=vapply(Xs,FUN = function(x) dim(ortho(x)),c(0,0))
for (i in seq_len(nX))
vXs[i]=list(t(sqrt(colMeans(Xs[i]^2) - colMeans(Xs[i])^2) %*% t(rep(1,nrow(Xs[i])))))
for (k in seq_len(nperm)) { for (k in seq_len(nperm)) {
# Generate the random matrix for the kth simulation # Generate the random matrix for the kth simulation
rXs=vector(mode="list",nX) r_xs <- vector(mode = "list", nx)
for (i in seq_len(nX)) for (i in seq_len(nx))
rXs[i]= list(tcrossprod(scale(array(rnorm(lXs[i]), r_xs[i] <- list(tcrossprod(scale(array(rnorm(l_xs[i]),
dim = dXs[,i]) dim = d_xs[, i]
) * vXs[[i]])) )) * v_xs[[i]]))
for (i in seq_len(nX)) for (i in seq_len(nx))
for (j in i:nX) for (j in i:nx)
rCovXXs[k,i,j] = .Trace(sqrtm(rXs[[i]] %*% rXs[[j]])) r_cov_xxs[k, i, j] <- .Trace(sqrtm(r_xs[[i]] %*% r_xs[[j]]))
} }
} }
rCovXXs = apply(rCovXXs, r_cov_xxs <- apply(r_cov_xxs,
MARGIN = c(2,3), MARGIN = c(2, 3),
FUN=function(i) MASS::fitdistr(Re(i), FUN = function(i) MASS::fitdistr(
"normal")$estimate['mean'] Re(i),
) "normal"
)$estimate["mean"]
for (i in seq_len(nX)) )
for (j in i:nX) {
CovXXs[i,j] = max(CovXXs[i,j] - rCovXXs[i,j],0) for (i in seq_len(nx))
CovXXs[j,i] = CovXXs[i,j] for (j in i:nx) {
rCovXXs[j,i] = rCovXXs[i,j] cov_xxs[i, j] <- max(cov_xxs[i, j] - r_cov_xxs[i, j], 0)
cov_xxs[j, i] <- cov_xxs[i, j]
r_cov_xxs[j, i] <- r_cov_xxs[i, j]
} }
CovXXs = CovXXs / N cov_xxs <- cov_xxs / N
colnames(CovXXs)=Xnames colnames(cov_xxs) <- x_names
rownames(CovXXs)=Xnames rownames(cov_xxs) <- x_names
CovXXs = Re(CovXXs) cov_xxs <- Re(cov_xxs)
if (rcovls) if (rcovls) {
attr(CovXXs,"rcovls") = rCovXXs / N attr(cov_xxs, "rcovls") <- r_cov_xxs / N
}
attr(CovXXs,"nperm") = nperm attr(cov_xxs, "nperm") <- nperm
return(make_subS3Class(Re(CovXXs), "procmod.varls")) return(make_subS3Class(Re(cov_xxs), "procmod.varls"))
} }
...@@ -149,16 +151,17 @@ varls = function(...,nperm = 100,rcovls=FALSE) { ...@@ -149,16 +151,17 @@ varls = function(...,nperm = 100,rcovls=FALSE) {
#' @author Eric Coissac #' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima #' @author Christelle Gonindard-Melodelima
#' @export #' @export
corls = function(...,nperm = 100,rcovls=FALSE) { corls <- function(..., nperm = 100, rcovls = FALSE) {
cov = varls(...,nperm = nperm,rcovls = rcovls) cov <- varls(..., nperm = nperm, rcovls = rcovls)
s = sqrt(diag(cov)) s <- sqrt(diag(cov))
vv= outer(s,s) vv <- outer(s, s)
rls = make_subS3Class(cov/vv, "procmod.corls") rls <- make_subS3Class(cov / vv, "procmod.corls")
attr(rls,"nperm")=attr(cov,"nperm") attr(rls, "nperm") <- attr(cov, "nperm")
if (rcovls) if (rcovls) {
attr(rls,"rcovls") = attr(rls,"rcovls") / vv attr(rls, "rcovls") <- attr(rls, "rcovls") / vv
}
return(rls) return(rls)
} }
...@@ -168,14 +171,17 @@ corls = function(...,nperm = 100,rcovls=FALSE) { ...@@ -168,14 +171,17 @@ corls = function(...,nperm = 100,rcovls=FALSE) {
#' @author Eric Coissac #' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima #' @author Christelle Gonindard-Melodelima
#' @export #' @export
corls.partial = function(...,nperm = 100,rcovls=FALSE) { corls.partial <- function(..., nperm = 100, rcovls = FALSE) {
rls = corls(...,nperm = nperm,rcovls = rcovls) rls <- corls(..., nperm = nperm, rcovls = rcovls)
C = solve(rls) C <- solve(rls)
D = sqrt(diag(C) %o% diag(C)) D <- sqrt(diag(C) %o% diag(C))
rp = make_subS3Class(C/D,"procmod.corls") rp <- make_subS3Class(C / D, "procmod.corls")
attr(rp,"nperm")=attr(rls,"nperm")
if (rcovls) attr(rp, "nperm") <- attr(rls, "nperm")
attr(rp,"rcovls") = attr(rls,"rcovls")
if (rcovls) {
attr(rp, "rcovls") <- attr(rls, "rcovls")
}
return(rp) return(rp)
} }
...@@ -185,10 +191,10 @@ corls.partial = function(...,nperm = 100,rcovls=FALSE) { ...@@ -185,10 +191,10 @@ corls.partial = function(...,nperm = 100,rcovls=FALSE) {
#' @author Eric Coissac #' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima #' @author Christelle Gonindard-Melodelima
#' @export #' @export
print.procmod.varls = function (x, ...) { print.procmod.varls <- function(x, ...) {
class(x)="matrix" class(x) <- "matrix"
attr(x,"permutations")=NULL attr(x, "permutations") <- NULL
attr(x,"rcovls") =NULL attr(x, "rcovls") <- NULL
print(x) print(x)
} }
...@@ -197,9 +203,9 @@ print.procmod.varls = function (x, ...) { ...@@ -197,9 +203,9 @@ print.procmod.varls = function (x, ...) {
#' @author Eric Coissac #' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima #' @author Christelle Gonindard-Melodelima
#' @export #' @export
print.procmod.corls = function (x, ...) { print.procmod.corls <- function(x, ...) {
class(x)="matrix" class(x) <- "matrix"
attr(x,"permutations")=NULL attr(x, "permutations") <- NULL
attr(x,"rcovls") =NULL attr(x, "rcovls") <- NULL
print(x) print(x)
} }
#' @include internals.R
NULL
#' Build a formula from a procmod.frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
formula.procmod.frame = function (x, ...)
{
nm <- sapply(names(x), as.name)
if (length(nm) > 1L) {
rhs <- nm[-1L]
lhs <- nm[1L]
}
else if (length(nm) == 1L) {
rhs <- nm[1L]
lhs <- NULL
}
else stop("cannot create a formula from an empty procmod.frame")
ff <- parse(text = paste(lhs,
paste(rhs,
collapse = "+"),
sep = "~"),
keep.source = FALSE)
ff <- eval(ff)
environment(ff) <- parent.frame()
ff
}
make_subS3Class = function(obj,subclass) { make_subS3Class <- function(obj, subclass) {
class(obj) = c(paste(subclass, class(obj) <- c(
collapse = "_"), paste(subclass,
class(obj)) collapse = "_"
),
class(obj)
)
return(obj) return(obj)
} }
dots.names=function(...) { dots.names <- function(...) {
varnames = substitute(list(...))[-1L] varnames <- substitute(list(...))[-1L]
dots = list(...) dots <- list(...)
isname = sapply(varnames,is.name) isname <- sapply(varnames, is.name)
charname = as.character(varnames) charname <- as.character(varnames)
charname[!isname]="" charname[!isname] <- ""
n=length(dots) n <- length(dots)
explicit = names(dots) explicit <- names(dots)
if (is.null(explicit)) if (is.null(explicit)) {
explicit=character(n) explicit <- character(n)
}
ze = !nzchar(explicit) ze <- !nzchar(explicit)
explicit[ze]=charname[ze] explicit[ze] <- charname[ze]
ze = !nzchar(explicit) ze <- !nzchar(explicit)
dnames <- paste('V',seq_len(n),sep='') dnames <- paste("V", seq_len(n), sep = "")
explicit[ze]=dnames[ze] explicit[ze] <- dnames[ze]
return(explicit) return(explicit)
} }
make_procmod_subS3Class = function(obj,subclass) { make_procmod_subS3Class <- function(obj, subclass) {
class(obj) = c(paste("procmod",subclass, class(obj) <- c(
sep="_",collapse = "_"), paste("procmod", subclass,
class(obj)) sep = "_", collapse = "_"
),
class(obj)
)
return(obj) return(obj)
} }
make_procmod_data = function(obj,subclass) { make_procmod_data <- function(obj, subclass) {
eud <- inherits(obj, "procmod_data", which = TRUE)
eud = inherits(obj,'procmod_data',which = TRUE) if (eud > 0) {
class(obj) <- class(obj)[-1:-(eud - 1)]
} else {
obj <- make_procmod_subS3Class(obj, "data")
}
if (eud > 0) if (!missing(subclass)) {
class(obj) = class(obj)[-1:-(eud-1)] obj <- make_procmod_subS3Class(obj, subclass)
else }
obj = make_procmod_subS3Class(obj,'data')
if (! missing(subclass))
obj = make_procmod_subS3Class(obj,subclass)
return(obj) return(obj)
} }
#' @include internals.R
#' @include model.procmod.R
#'
#' @title ProcMod
#' @description blabla
#' @author Christelle Gonindard-Melodelima
#'
NULL
pm.fit = function(covmat,y,xs,
singular.ok = singular.ok,
tol) {
xy.cov = covmat[xs,y,drop=FALSE]
xx.cov = covmat[xs,xs,drop=FALSE]