Commit 221518a4 by Eric Coissac

Many changes... ;-)

parent 53d16d8f
......@@ -9,7 +9,7 @@ Description: More about what it does (maybe more than one line)
License: CECILL 2.1
Encoding: UTF-8
LazyData: true
RoxygenNote: 6.0.1
RoxygenNote: 6.1.1
Imports: MASS,
stats,
roxygen2
......@@ -28,4 +28,5 @@ Collate:
'anova.pm.R'
'mcov.R'
'plot.pm.R'
'procuste.R'
'zzzz.R'
......@@ -41,6 +41,7 @@ export(pca)
export(pcoa)
export(pm)
export(procmod.frame)
export(protate)
export(vars.procmod)
export(weighted.residuals)
import(MASS)
......@@ -8,11 +8,11 @@ NULL
.transformData = function(x) {
if (is.data.frame(x) && !is.null(attr(x,'is.dist')) && attr(x,'is.dist')==TRUE)
return(dist2orthospace(as.dist(as.matrix(x))))
return(ortho.dist(as.dist(as.matrix(x))))
if (inherits(x,'dist'))
return(dist2orthospace(x))
return(ortho.dist(x))
pca(x)
}
......@@ -46,6 +46,7 @@ NULL
names[i]=varnames[i]
}
j=1
for (i in seq_len(ndots)) {
if (! is.null(dots[[i]])) {
......@@ -60,6 +61,7 @@ NULL
names(data)=names
data$row.names=row.names
data = do.call(ProcMod::procmod.frame,data)
......@@ -184,7 +186,9 @@ model.procmod.default = function (formula,
rownames <- .row_names_info(data, 0L)
vars <- attr(formula, "variables")
predvars <- attr(formula, "predvars")
if (is.null(predvars))
predvars <- vars
......@@ -278,7 +282,7 @@ model.procmod.default = function (formula,
}
#' Plays the role of model.matrix in classical lm
#'
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
......@@ -311,17 +315,17 @@ vars.procmod = function(object, data = environment(object),
1,
any)]
resp = data[[attr(t, "response")]]
XYs <- lapply(i.factors,function(x) crossprod(resp, x))
sol_yxs <- lapply(XYs,svd)
A_xys <- lapply(sol_yxs, function(x) x$v %*% t(x$u))
Xrots <- mapply(function(x,a) x %*% a,
i.factors,A_xys,
SIMPLIFY = FALSE)
for (i in seq_len(ncol(interactions))) {
inter = names(which(interactions[,i] >0))
i.val=Xrots[[inter[1]]]
......@@ -330,55 +334,55 @@ vars.procmod = function(object, data = environment(object),
}
data[[i.labels[i]]] = i.val
}
}
return(data)
}
model.matrix.pm = function (object,
data = environment(object),
model.matrix.pm = function (object,
data = environment(object),
contrasts.arg = NULL,
xlev = NULL, ...)
xlev = NULL, ...)
{
t <- if (missing(data))
t <- if (missing(data))
terms(object)
else terms(object, data = data)
if (is.null(attr(data, "terms")))
if (is.null(attr(data, "terms")))
data <- model.procmod.default(object, data, xlev = xlev)
else {
deparse2 <- function(x) paste(deparse(x, width.cutoff = 500L),
deparse2 <- function(x) paste(deparse(x, width.cutoff = 500L),
collapse = " ")
reorder <- match(vapply(attr(t, "variables"), deparse2,
reorder <- match(vapply(attr(t, "variables"), deparse2,
"")[-1L], names(data))
if (anyNA(reorder))
if (anyNA(reorder))
stop("model frame and formula mismatch in model.matrix()")
if (!identical(reorder, seq_len(ncol(data))))
if (!identical(reorder, seq_len(ncol(data))))
data <- data[, reorder, drop = FALSE]
}
int <- attr(t, "response")
if (length(data)) {
contr.funs <- as.character(getOption("contrasts"))
namD <- names(data)
for (i in namD) if (is.character(data[[i]]))
for (i in namD) if (is.character(data[[i]]))
data[[i]] <- factor(data[[i]])
isF <- vapply(data, function(x) is.factor(x) || is.logical(x),
isF <- vapply(data, function(x) is.factor(x) || is.logical(x),
NA)
isF[int] <- FALSE
isOF <- vapply(data, is.ordered, NA)
for (nn in namD[isF]) if (is.null(attr(data[[nn]], "contrasts")))
for (nn in namD[isF]) if (is.null(attr(data[[nn]], "contrasts")))
contrasts(data[[nn]]) <- contr.funs[1 + isOF[nn]]
if (!is.null(contrasts.arg) && is.list(contrasts.arg)) {
if (is.null(namC <- names(contrasts.arg)))
if (is.null(namC <- names(contrasts.arg)))
stop("invalid 'contrasts.arg' argument")
for (nn in namC) {
if (is.na(ni <- match(nn, namD)))
warning(gettextf("variable '%s' is absent, its contrast will be ignored",
if (is.na(ni <- match(nn, namD)))
warning(gettextf("variable '%s' is absent, its contrast will be ignored",
nn), domain = NA)
else {
ca <- contrasts.arg[[nn]]
if (is.matrix(ca))
if (is.matrix(ca))
contrasts(data[[ni]], ncol(ca)) <- ca
else contrasts(data[[ni]]) <- contrasts.arg[[nn]]
}
......@@ -390,7 +394,7 @@ model.matrix.pm = function (object,
data[["x"]] <- raw(nrow(data))
}
ans <- .External2(C_modelmatrix, t, data)
cons <- if (any(isF))
cons <- if (any(isF))
lapply(data[isF], attr, "contrasts")
attr(ans, "contrasts") <- cons
ans
......
......@@ -36,7 +36,7 @@ pm.fit = function(covmat,y,xs,
.ctrace <- function(MAT) sum(MAT^2)
#' Tests that the object is as `pm` instance.
#'
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
......@@ -103,7 +103,7 @@ pm = function (formula,data, subset, weights, na.action, method = "qr",
z$A <- NULL
}
else {
vars <- vars.procmod(mt, mf)
nvars=ncol(vars)
irep = attr(vars,"response")
......@@ -115,8 +115,8 @@ pm = function (formula,data, subset, weights, na.action, method = "qr",
vars.norm = as.procmod.frame(mapply(function(x) scale(x,scale = FALSE),
vars,
SIMPLIFY = FALSE))
if (is.null(w)) {
subset.w=rep(TRUE,nvars)
......
......@@ -194,11 +194,12 @@ ortho.procmod.frame = function(x) {
return(x)
n = ncol(x)
p = vector(mode = 'character', length = n)
for (i in seq_len(n)) {
xt=ortho(x[[i]])
x[[i]]=xt
p[i]=attributes(xt)$projected
xt=ortho(x[[i]])
p[i]=attributes(xt)$projected
x[[i]]=xt
}
names(p) = names(x)
......
#' Default plot function for `pm` objects.
#'
#' Data are plotted with blue dots and fitted values with red dot.
#' A black arrow links a fitted value to its corresponding original value.
#' A barplot on the right side indicates the relative part of the global
#' variance affected to each factor.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
......
#' @include internals.R
#'
#' @title ProcMod
#' @description blabla
#' @author Christelle Gonindard-Melodelima
#' @author Eric Coissac
#'
NULL
#' @export
protate = function(src,dest) {
YX = crossprod(dest, src)
svd.YX = svd(YX)
rot = svd.YX$v %*% t(svd.YX$u)
src %*% rot
}
......@@ -8,7 +8,10 @@
arrow.length = 0.05, asp = 1, ...)
}
\description{
Default plot function for `pm` objects.
Data are plotted with blue dots and fitted values with red dot.
A black arrow links a fitted value to its corresponding original value.
A barplot on the right side indicates the relative part of the global
variance affected to each factor.
}
\author{
Eric Coissac
......
......@@ -5,8 +5,8 @@
\title{Performs a procruste model on a set of coordinate matrices}
\usage{
pm(formula, data, subset, weights, na.action, method = "qr",
singular.ok = TRUE, tol = 1e-07, model = TRUE, x = TRUE, y = TRUE,
A = TRUE)
singular.ok = TRUE, tol = 1e-07, model = TRUE, x = TRUE,
y = TRUE, A = TRUE)
}
\description{
Performs a procruste model on a set of coordinate matrices
......
......@@ -4,8 +4,8 @@
\alias{residuals.pm}
\title{Extract Model Residuals.}
\usage{
\method{residuals}{pm}(object, type = c("working", "response", "deviance",
"pearson", "partial"), ...)
\method{residuals}{pm}(object, type = c("working", "response",
"deviance", "pearson", "partial"), ...)
}
\arguments{
\item{type}{the type of residuals which should be returned.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment