Add the procmod.frame data strucutre

DESCRIPTION

@@ -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'

NAMESPACE

 # 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)

ProcMod.Rproj

@@ -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

R/internals.R

+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)
+}

R/procmod.frame.R

+#' @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)
+}