Commit b74e226c by Eric Coissac

The procmod.frame data structure

parent fcd918ed
......@@ -77,19 +77,21 @@ procmod.frame = function(...,
row.names = NULL,
check.rows = FALSE,
check.names = TRUE,
fix.empty.names = TRUE)
reorder.rows = FALSE)
{
mirn <- missing(row.names)
mrn <- is.null(row.names)
has.row.names = ! missing(row.names)
varnames = dots.names(...)
x <- list(...)
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)
names(value)=varnames
types <- character(n)
......@@ -100,17 +102,33 @@ procmod.frame = function(...,
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"))
}
......@@ -124,12 +142,12 @@ is.procmod.frame = function(x) {
inherits(x, "procmod.frame")
}
#' Coerce to a Matrix Frame.
#' Coerce to a ProcMod Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.procmod.frame = function(data) {
as.procmod.frame = function(data,...) {
UseMethod("as.procmod.frame",data)
}
......@@ -138,8 +156,8 @@ as.procmod.frame = function(data) {
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.procmod.frame.list = function(data) {
do.call(procmod.frame,data)
as.procmod.frame.list = function(data,...) {
do.call(procmod.frame,data,...)
}
#' Coerce to a ProcMod Frame.
......@@ -147,7 +165,7 @@ as.procmod.frame.list = function(data) {
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.procmod.frame.procmod.frame = function(data) {
as.procmod.frame.procmod.frame = function(data,...) {
data
}
......@@ -156,7 +174,7 @@ as.procmod.frame.procmod.frame = function(data) {
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.procmod.frame.array = function(data) {
as.procmod.frame.array = function(data,...) {
di = dim(data)
stopifnot(length(di)==3)
......@@ -166,7 +184,7 @@ as.procmod.frame.array = function(data) {
if (length(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.
......@@ -204,7 +222,6 @@ dim.procmod.frame = function(x)
}
if (length(attr(x,"row.names"))==nrows)
rownames(value)=attr(x,"row.names")
x[[i]] <- value
......@@ -225,73 +242,51 @@ dim.procmod.frame = function(x)
#' @author Christelle Gonindard-Melodelima
#' @export
`[.procmod.frame` = function (x, i, j,
drop = if (missing(i)) TRUE
else length(cols) == 1)
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)
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)
# Case 1 : X[]
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)
else if (! has.i && has.j) {
# Case 2 : X[,j] ou x[i]
message('Case 2 : X[,j]')
y <- as.list(x)[j]
}
# 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)
else if ( has.i && Narg==1) {
# Case 3 : X[,j] ou x[i]
message('Case 3 : X[i]')
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")
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])
}
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 ) {
message('Case 5 : X[i,j]')
y = x[j,drop=FALSE]
y = y[i,,drop=FALSE]
}
# 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 (drop && length(y)==1L)
y = y[[1]]
else {
y = make_subS3Class(y, "procmod.frame")
attr(y,"row.names")=rownames(y[[1]])
}
if ( has.i && has.j ) {
y = x[j,drop=drop]
y = y[i,,drop=drop]
return(y)
}
}
#' @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