Commit b74e226c by Eric Coissac

The procmod.frame data structure

parent fcd918ed
...@@ -77,19 +77,21 @@ procmod.frame = function(..., ...@@ -77,19 +77,21 @@ procmod.frame = function(...,
row.names = NULL, row.names = NULL,
check.rows = FALSE, check.rows = FALSE,
check.names = TRUE, check.names = TRUE,
fix.empty.names = TRUE) reorder.rows = FALSE)
{ {
mirn <- missing(row.names) has.row.names = ! missing(row.names)
mrn <- is.null(row.names)
varnames = dots.names(...) varnames = dots.names(...)
x <- list(...) x <- list(...)
n <- length(x) n <- length(x)
nrows <- integer(n) if ((! has.row.names || is.null(row.names)) && n >= 1)
row.names = rownames(x[[1]])
nrows <- integer(n)
value <- vector(mode = "list", length = n) value <- vector(mode = "list", length = n)
names(value)=varnames names(value)=varnames
types <- character(n) types <- character(n)
...@@ -100,17 +102,33 @@ procmod.frame = function(..., ...@@ -100,17 +102,33 @@ procmod.frame = function(...,
else else
xi <- .procmod_coerce_value(x[[i]], xi <- .procmod_coerce_value(x[[i]],
nrows = nrows[1]) nrows = nrows[1])
if (reorder.rows &&
! is.null(row.names) &&
! is.null(rownames(xi)))
xi=xi[row.names,]
nrows[i] <- nrow(xi) nrows[i] <- nrow(xi)
value[[i]]=xi value[[i]]=xi
} }
stopifnot(all(nrows[i]==nrows)) stopifnot(all(nrows[i]==nrows))
message(row.names," : ",length(row.names),",",nrows[i])
if (length(row.names)==nrows[i]) { if (length(row.names)==nrows[i]) {
attr(value,"row.names")=row.names attr(value,"row.names")=row.names
for (i in seq_len(n)) if (check.rows)
rownames(value[[i]])=row.names 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")) return(make_subS3Class(value, "procmod.frame"))
} }
...@@ -124,12 +142,12 @@ is.procmod.frame = function(x) { ...@@ -124,12 +142,12 @@ is.procmod.frame = function(x) {
inherits(x, "procmod.frame") inherits(x, "procmod.frame")
} }
#' Coerce to a Matrix Frame. #' Coerce to a ProcMod Frame.
#' #'
#' @author Eric Coissac #' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima #' @author Christelle Gonindard-Melodelima
#' @export #' @export
as.procmod.frame = function(data) { as.procmod.frame = function(data,...) {
UseMethod("as.procmod.frame",data) UseMethod("as.procmod.frame",data)
} }
...@@ -138,8 +156,8 @@ as.procmod.frame = function(data) { ...@@ -138,8 +156,8 @@ as.procmod.frame = function(data) {
#' @author Eric Coissac #' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima #' @author Christelle Gonindard-Melodelima
#' @export #' @export
as.procmod.frame.list = function(data) { as.procmod.frame.list = function(data,...) {
do.call(procmod.frame,data) do.call(procmod.frame,data,...)
} }
#' Coerce to a ProcMod Frame. #' Coerce to a ProcMod Frame.
...@@ -147,7 +165,7 @@ as.procmod.frame.list = function(data) { ...@@ -147,7 +165,7 @@ as.procmod.frame.list = function(data) {
#' @author Eric Coissac #' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima #' @author Christelle Gonindard-Melodelima
#' @export #' @export
as.procmod.frame.procmod.frame = function(data) { as.procmod.frame.procmod.frame = function(data,...) {
data data
} }
...@@ -156,7 +174,7 @@ as.procmod.frame.procmod.frame = function(data) { ...@@ -156,7 +174,7 @@ as.procmod.frame.procmod.frame = function(data) {
#' @author Eric Coissac #' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima #' @author Christelle Gonindard-Melodelima
#' @export #' @export
as.procmod.frame.array = function(data) { as.procmod.frame.array = function(data,...) {
di = dim(data) di = dim(data)
stopifnot(length(di)==3) stopifnot(length(di)==3)
...@@ -166,7 +184,7 @@ as.procmod.frame.array = function(data) { ...@@ -166,7 +184,7 @@ as.procmod.frame.array = function(data) {
if (length(attr(data,"dimnames"))==3) if (length(attr(data,"dimnames"))==3)
names(l)=attr(data,"dimnames")[[3]] names(l)=attr(data,"dimnames")[[3]]
do.call(procmod.frame,l) do.call(procmod.frame,l,...)
} }
#' Dimensions of a Matrix Frame. #' Dimensions of a Matrix Frame.
...@@ -204,8 +222,7 @@ dim.procmod.frame = function(x) ...@@ -204,8 +222,7 @@ dim.procmod.frame = function(x)
} }
if (length(attr(x,"row.names"))==nrows) rownames(value)=attr(x,"row.names")
rownames(value)=attr(x,"row.names")
x[[i]] <- value x[[i]] <- value
class(x)=cl class(x)=cl
...@@ -225,73 +242,51 @@ dim.procmod.frame = function(x) ...@@ -225,73 +242,51 @@ dim.procmod.frame = function(x)
#' @author Christelle Gonindard-Melodelima #' @author Christelle Gonindard-Melodelima
#' @export #' @export
`[.procmod.frame` = function (x, i, j, `[.procmod.frame` = function (x, i, j,
drop = if (missing(i)) TRUE drop = TRUE)
else length(cols) == 1)
{ {
has.j = !missing(j) has.j = !missing(j)
has.i = !missing(i) has.i = !missing(i)
has.drop = !missing(drop) has.drop = !missing(drop)
Narg = nargs() - 2 + (has.i | has.j | has.drop) - has.drop Narg = nargs() - 2 + (has.i | has.j | has.drop) - has.drop
# message("Nargs = ",Narg," i:",has.i," j:",has.j," drop:",has.drop) message("Nargs = ",Narg," i:",has.i," j:",has.j," drop:",has.drop)
if (!all(names(sys.call()) %in% c("", "drop"))) if (!all(names(sys.call()) %in% c("", "drop")))
warning("named arguments other than 'drop' are discouraged") warning("named arguments other than 'drop' are discouraged")
# Case 1 : X[]
if (! has.i && ! has.j) if (! has.i && ! has.j)
# Case 1 : X[]
return(x) return(x)
else if (! has.i && has.j) {
# Case 2 : X[,j] # Case 2 : X[,j] ou x[i]
if (! has.i && has.j) { message('Case 2 : X[,j]')
y <- x[j,drop=FALSE] y <- as.list(x)[j]
if (drop && length(y) == 1L)
y=y[[1L]]
return(y)
} }
else if ( has.i && Narg==1) {
# Case 3 : X[i] # Case 3 : X[,j] ou x[i]
if ( has.i && Narg==1) { message('Case 3 : X[i]')
nm <- names(x) y <- as.list(x)[i]
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)
} }
else if ( has.i && !has.j && Narg>1) {
# Case 3 : X[i,] # Case 4 : X[i,]
if ( has.i && !has.j && Narg>1) { message('Case 4 : X[i,]')
y = lapply(x, function(m) m[i,,drop=FALSE]) y = lapply(x, function(m) m[i,,drop=FALSE])
attr(y, "row.names") <- .row_names_info(x, 0L) }
attr(y, "class") = class(x) else if ( has.i && has.j ) {
return(y) message('Case 5 : X[i,j]')
y = x[j,drop=FALSE]
y = y[i,,drop=FALSE]
} }
if ( has.i && has.j ) { if (drop && length(y)==1L)
y = x[j,drop=drop] y = y[[1]]
y = y[i,,drop=drop] else {
y = make_subS3Class(y, "procmod.frame")
return(y) attr(y,"row.names")=rownames(y[[1]])
} }
return(y)
} }
#' @author Eric Coissac #' @author Eric Coissac
......
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