#' @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, reorder.rows = FALSE) { has.row.names = ! missing(row.names) varnames = dots.names(...) x <- list(...) n <- length(x) if ((! has.row.names || is.null(row.names)) && n >= 1) row.names = rownames(x[[1]]) 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]) if (reorder.rows && ! is.null(row.names) && ! is.null(rownames(xi))) xi=xi[row.names,] nrows[i] <- nrow(xi) value[[i]]=xi } stopifnot(all(nrows[i]==nrows)) message(row.names," : ",length(row.names),",",nrows[i]) if (length(row.names)==nrows[i]) { attr(value,"row.names")=row.names if (check.rows) for (i in seq_len(n)) { if (! all(row.names == rownames(value[[i]]))) stop("Row names among matrices are not consistant") } else for (i in seq_len(n)) rownames(value[[i]])=row.names } else for (i in seq_len(n)) rownames(value[[i]])=NULL 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 ProcMod 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) } 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 = TRUE) { 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") if (! has.i && ! has.j) # Case 1 : X[] return(x) else if (! has.i && has.j) { # Case 2 : X[,j] ou x[i] message('Case 2 : X[,j]') y <- as.list(x)[j] } else if ( has.i && Narg==1) { # Case 3 : X[,j] ou x[i] message('Case 3 : X[i]') y <- as.list(x)[i] } else if ( has.i && !has.j && Narg>1) { # Case 4 : X[i,] message('Case 4 : X[i,]') y = lapply(x, function(m) m[i,,drop=FALSE]) } else if ( has.i && has.j ) { message('Case 5 : X[i,j]') y = x[j,drop=FALSE] y = y[i,,drop=FALSE] } if (drop && length(y)==1L) y = y[[1]] else { y = make_subS3Class(y, "procmod.frame") attr(y,"row.names")=rownames(y[[1]]) } 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) }