diff --git a/R/procmod.frame.R b/R/procmod.frame.R index b7e4fef..99bcdcb 100644 --- a/R/procmod.frame.R +++ b/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 +#' @author Christelle Gonindard-Melodelima +#' @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 +#' @author Christelle Gonindard-Melodelima +#' @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) && diff --git a/man/procmod.frame.Rd b/man/procmod.frame.Rd index 258cd6f..14e46dc 100644 --- a/man/procmod.frame.Rd +++ b/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)