Internal docs + beginning of considering factors in the model

R/procmod.frame.R

@@ -9,37 +9,60 @@ NULL
 #'              initial row count
 #'
 #' @param x  The matrix to replicate
-#' @param length.out  an interger value specifying the number of row
+#' @param nrow  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`
+#' @return a new matrix with the same number of columns but with `nrow`
 #'         rows.
 #'
-#' @author Eric Coissac
-#' @author Christelle Gonindard-Melodelima
-#' @rdname rep_matrix
+#' @author Eric Coissac <eric.coissac@metabarcoding.org>
+#' @author Christelle Gonindard-Melodelima <christelle.gonindard@metabarcoding.org>
+#' @rdname internal.rep_matrix
 #'
 
-.rep_matrix = function(x,length.out) {
+.rep_matrix = function(x,nrow) {
   N = nrow(x)
 
-  if ((length.out %% N != 0L))
+  if ((nrow %% 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)
+  while (nrow(rep) < nrow)
     rep = rbind(rep,x)
 
   return(rep)
 }
 
-.procmod_coerce_value = function(x,nrows=0) {
+#' Internal function coercing the data to a matrix.
+#'
+#' @description Transforme the \code{x} value into a \code{numeric matrix} of
+#'              the correct size or into a \code{dist} object.
+#'
+#' @param x  The data to coerce
+#' @param nrows  an interger value specifying the number of row
+#'               of the returned matrix
+#'
+#' @return a new numeric matrix with correct size.
+#'
+#' @author Eric Coissac <eric.coissac@metabarcoding.org>
+#' @author Christelle Gonindard-Melodelima <christelle.gonindard@metabarcoding.org>
+#' @rdname internal.procmod_coerce_value
+#'
+.procmod_coerce_value = function(x,nrows=0,contrasts=NULL) {
   xi <- if (is.data.frame(x))
             as.matrix(x)
         else if (is.matrix(x) || inherits(x,'dist'))
             x
+        else if (is.factor(x)) {
+            if (is.null(contrasts))
+              contrasts(x)[x,]
+            else if (is.character(contrasts) || is.function(contrasts))
+              match.fun(contrasts,descend=FALSE)(x)[x,]
+            else
+              contrasts[x,]
+        }
         else
             as.matrix(x)
 
@@ -61,7 +84,7 @@ NULL
 
     if (nrows > 0L && N < nrows) {
       if (N > 0L && (nrows %% N == 0L))
-        xi <- .rep_matrix(xi, length.out = nrows)
+        xi <- .rep_matrix(xi, nrow = nrows)
       else stop(sprintf(ngettext(N, "replacement has %d row, data has %d",
                                  "replacement has %d rows, data has %d"),
                         N, nrows),
@@ -126,7 +149,8 @@ procmod.frame = function(...,
                          row.names = NULL,
                          check.rows = FALSE,
                          check.names = TRUE,
-                         reorder.rows = FALSE)
+                         reorder.rows = FALSE,
+                         contrasts.arg = NULL)
 {
   has.row.names    = ! missing(row.names)
 
@@ -150,11 +174,14 @@ procmod.frame = function(...,
   types <- character(n)
 
   for (i in seq_len(n)) {
+    contrasts = contrasts.arg[varnames[i]]
     if (i==1)
-      xi <- .procmod_coerce_value(x[[i]])
+      xi <- .procmod_coerce_value(x[[i]],
+                                  contrasts=contrasts)
     else
       xi <- .procmod_coerce_value(x[[i]],
-                                  nrows = nrows[1])
+                                  nrows = nrows[1],
+                                  contrasts=contrasts)
 
     if (reorder.rows &&
         ! is.null(row.names) &&

man/procmod.frame.Rd

@@ -7,7 +7,7 @@
 \title{The procmod.frame data structure.}
 \usage{
 procmod.frame(..., row.names = NULL, check.rows = FALSE,
-  check.names = TRUE, reorder.rows = FALSE)
+  check.names = TRUE, reorder.rows = FALSE, contrasts.arg = NULL)
 
 is.procmod.frame(x)