Commit 147a729b by Eric Coissac

Add the procmod.frame data strucutre

parent b7960bb6
......@@ -13,3 +13,8 @@ RoxygenNote: 6.0.1
Suggests: knitr,
rmarkdown
VignetteBuilder: knitr
Collate:
'internals.R'
'formula.procmod.frame.R'
'mprocuste.R'
'procmod.frame.R'
# Generated by roxygen2: do not edit by hand
S3method("$<-",procmod.frame)
S3method("[",procmod.frame)
S3method("[[<-",procmod.frame)
S3method(AIC,pm)
S3method(BIC,pm)
S3method(anova,pm)
S3method(as.list,procmod.frame)
S3method(as.procmod.frame,array)
S3method(as.procmod.frame,list)
S3method(as.procmod.frame,procmod.frame)
S3method(deviance,pm)
S3method(dim,procmod.frame)
S3method(extractAIC,pm)
S3method(formula,procmod.frame)
S3method(plot,pm)
S3method(print,pm)
S3method(residuals,pm)
S3method(subset,procmod.frame)
export(as.procmod.frame)
export(is.procmod.frame)
export(mcor)
export(mvar)
export(pm)
export(procmod.frame)
export(weighted.residuals)
......@@ -18,4 +18,4 @@ StripTrailingWhitespace: Yes
BuildType: Package
PackageUseDevtools: Yes
PackageInstallArgs: --no-multiarch --with-keep.source
PackageRoxygenize: rd,collate,namespace,vignette
PackageRoxygenize: rd,collate,namespace
make_subS3Class = function(obj,subclass) {
class(obj) = c(paste(subclass,
collapse = "_"),
class(obj))
return(obj)
}
dots.names=function(...) {
varnames = substitute(list(...))[-1L]
dots = list(...)
isname = sapply(varnames,is.name)
charname = as.character(varnames)
charname[!isname]=""
n=length(dots)
explicit = names(dots)
if (is.null(explicit))
explicit=character(n)
ze = !nzchar(explicit)
explicit[ze]=charname[ze]
ze = !nzchar(explicit)
dnames <- paste('V',seq_len(n),sep='')
explicit[ze]=dnames[ze]
return(explicit)
}
make_procmod_subS3Class = function(obj,subclass) {
class(obj) = c(paste("procmod",subclass,
sep="_",collapse = "_"),
class(obj))
return(obj)
}
make_procmod_data = function(obj,subclass) {
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 (! missing(subclass))
obj = make_procmod_subS3Class(obj,subclass)
return(obj)
}
#' @include internals.R
NULL
#' Internal function repeating a matrix.
#'
#' @description repeats several times the rows of a matrix
#' to create a new matrix with more rows. The
#' final row count must be a multiple of the
#' initial row count
#'
#' @param x The matrix to replicate
#' @param length.out an interger value specifying the number of row
#' of the returned matrix
#'
#' @return a new matrix with the same number of columns but with `length.out`
#' rows.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#'
.rep_matrix = function(x,length.out) {
N = nrow(x)
if ((length.out%%N != 0L))
stop(sprintf("The size of the longest object (%d) is not a multiple of the size of the shortest (%d)",
nrows,N),
domain = NA)
rep=x
while (nrow(rep) < length.out)
rep = rbind(rep,x)
return(rep)
}
.procmod_coerce_value = function(x,nrows=0) {
xi <- if (is.data.frame(x))
as.matrix(x)
else if (is.matrix(x))
x
else
as.matrix(x)
dxi = dim(xi)
if (is.null(dxi))
dxi=c(1,1)
rownamesi = rownames(xi)
colnamesi = colnames(xi)
xi = as.numeric(xi)
dim(xi)=dxi
rownames(xi) = rownamesi
colnames(xi) = colnamesi
N = nrow(xi)
if (nrows > 0L && N < nrows)
if (N > 0L && (nrows%%N == 0L))
xi <- .rep_matrix(xi, length.out = nrows)
else stop(sprintf(ngettext(N, "replacement has %d row, data has %d",
"replacement has %d rows, data has %d"),
N, nrows),
domain = NA)
return(xi)
}
#' Build a procmod.frame data structure.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
procmod.frame = function(...,
row.names = NULL,
check.rows = FALSE,
check.names = TRUE,
fix.empty.names = TRUE)
{
mirn <- missing(row.names)
mrn <- is.null(row.names)
varnames = dots.names(...)
x <- list(...)
n <- length(x)
nrows <- integer(n)
value <- vector(mode = "list", length = n)
names(value)=varnames
types <- character(n)
for (i in seq_len(n)) {
if (i==1)
xi <- .procmod_coerce_value(x[[i]])
else
xi <- .procmod_coerce_value(x[[i]],
nrows = nrows[1])
nrows[i] <- nrow(xi)
value[[i]]=xi
}
stopifnot(all(nrows[i]==nrows))
if (length(row.names)==nrows[i]) {
attr(value,"row.names")=row.names
for (i in seq_len(n))
rownames(value[[i]])=row.names
}
return(make_subS3Class(value, "procmod.frame"))
}
#' Check if an object is a Matrix Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
is.procmod.frame = function(x) {
inherits(x, "procmod.frame")
}
#' Coerce to a Matrix Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.procmod.frame = function(data) {
UseMethod("as.procmod.frame",data)
}
#' Coerce to a ProcMod Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.procmod.frame.list = function(data) {
do.call(procmod.frame,data)
}
#' Coerce to a ProcMod Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.procmod.frame.procmod.frame = function(data) {
data
}
#' Coerce to a ProcMod Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.procmod.frame.array = function(data) {
di = dim(data)
stopifnot(length(di)==3)
l = lapply(seq_len(di[3]),
function(i) data[,,i])
if (length(attr(data,"dimnames"))==3)
names(l)=attr(data,"dimnames")[[3]]
do.call(procmod.frame,l)
}
#' Dimensions of a Matrix Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
dim.procmod.frame = function(x)
return(c(nrow(x[[1]]),length(x)))
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
`[[<-.procmod.frame` = function (x, i, value)
{
cl = class(x)
nrows=nrow(x)
class(x)="list"
if (!is.null(value)) {
value=.procmod_coerce_value(value,nrows)
N <- nrow(value)
if (N > nrows)
stop(sprintf(ngettext(N, "replacement has %d row, data has %d",
"replacement has %d rows, data has %d"),
N, nrows),
domain = NA)
if (N < nrows)
stop(sprintf(ngettext(N, "replacement has %d row, data has %d",
"replacement has %d rows, data has %d"),
N, nrows),
domain = NA)
}
if (length(attr(x,"row.names"))==nrows)
rownames(value)=attr(x,"row.names")
x[[i]] <- value
class(x)=cl
return(x)
}
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
`$<-.procmod.frame` = function (x, name, value) {
x[[name]] <- value
return(x)
}
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
`[.procmod.frame` = function (x, i, j,
drop = if (missing(i)) TRUE
else length(cols) == 1)
{
has.j = !missing(j)
has.i = !missing(i)
has.drop = !missing(drop)
Narg = nargs() - 2 + (has.i | has.j | has.drop) - has.drop
# message("Nargs = ",Narg," i:",has.i," j:",has.j," drop:",has.drop)
if (!all(names(sys.call()) %in% c("", "drop")))
warning("named arguments other than 'drop' are discouraged")
# Case 1 : X[]
if (! has.i && ! has.j)
return(x)
# Case 2 : X[,j]
if (! has.i && has.j) {
y <- x[j,drop=FALSE]
if (drop && length(y) == 1L)
y=y[[1L]]
return(y)
}
# Case 3 : X[i]
if ( has.i && Narg==1) {
nm <- names(x)
if (is.null(nm))
nm <- character()
if (!is.character(i) && anyNA(nm)) {
names(nm) <- names(x) <- seq_along(x)
y <- as.list(x)[i]
cols <- names(y)
if (anyNA(cols))
stop("undefined columns selected")
cols <- names(y) <- nm[cols]
}
else {
y <- as.list(x)[i]
cols <- names(y)
if (!is.null(cols) && anyNA(cols))
stop("undefined columns selected")
}
if (anyDuplicated(cols))
names(y) <- make.unique(cols)
attr(y, "row.names") <- .row_names_info(x, 0L)
attr(y, "class") <- oldClass(x)
return(y)
}
# Case 3 : X[i,]
if ( has.i && !has.j && Narg>1) {
y = lapply(x, function(m) m[i,,drop=FALSE])
attr(y, "row.names") <- .row_names_info(x, 0L)
attr(y, "class") = class(x)
return(y)
}
if ( has.i && has.j ) {
y = x[j,drop=drop]
y = y[i,,drop=drop]
return(y)
}
}
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
subset.procmod.frame = function (x, subset, select, drop = FALSE, ...)
{
r <- if (missing(subset))
rep_len(TRUE, nrow(x))
else {
e <- substitute(subset)
r <- eval(e, x, parent.frame())
if (!is.logical(r))
stop("'subset' must be logical")
r & !is.na(r)
}
vars <- if (missing(select))
TRUE
else {
nl <- as.list(seq_along(x))
names(nl) <- names(x)
eval(substitute(select), nl, parent.frame())
}
x[r, vars, drop = drop]
}
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.list.procmod.frame = function(x, ...) {
class(x)='list'
return(x)
}
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