Commit 779251a4 by Eric Coissac

Allows procmod.frame to include distance matrix

parent abf73c64
......@@ -37,38 +37,85 @@ NULL
.procmod_coerce_value = function(x,nrows=0) {
xi <- if (is.data.frame(x))
as.matrix(x)
else if (is.matrix(x))
else if (is.matrix(x) || inherits(x,'dist'))
x
else
as.matrix(x)
if (! is.matrix(xi))
if (! (is.matrix(xi) || inherits(x,'dist')))
stop('Value cannot be coerced to a Matrix')
dxi=dim(xi)
rownamesi = rownames(xi)
colnamesi = colnames(xi)
xi = as.numeric(xi)
if (is.matrix(xi)) {
dxi=dim(xi)
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)
}
}
else {
N = attr(xi,"Size")
if (nrows > 0L && N != nrows) {
stop(sprintf(ngettext(N, "replacement has %d row, data has %d",
"replacement has %d rows, data has %d"),
N, nrows),
domain = NA)
}
}
dim(xi)=dxi
rownames(xi) = rownamesi
colnames(xi) = colnamesi
return(xi)
}
N = nrow(xi)
.siteNames = function(x) {
if (inherits(x,'dist'))
attr(x,'Labels')
else
rownames(x)
}
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)
`.siteNames<-` = function(x,value) {
if (inherits(x,'dist')) {
stopifnot(is.null(value) || length(value)==attr(x,'Size'))
attr(x,'Labels')=value
}
else
rownames(x)=value
x
}
return(xi)
.siteCount = function(x) {
if (inherits(x,'dist'))
attr(x,'Size')
else
nrow(x)
}
.siteSelect = function(x,select) {
if (inherits(x,'dist'))
as.dist(as.matrix(x)[select,select,drop=FALSE])
else
x[select,,drop=FALSE]
}
#' Build a procmod.frame data structure.
#'
#' @author Eric Coissac
......@@ -92,7 +139,7 @@ procmod.frame = function(...,
# message(row.names)
if ((! has.row.names || is.null(row.names)) && n >= 1)
row.names = rownames(x[[1]])
row.names = .siteNames(x[[1]])
nrows <- integer(n)
value <- vector(mode = "list", length = n)
......@@ -110,10 +157,10 @@ procmod.frame = function(...,
if (reorder.rows &&
! is.null(row.names) &&
! is.null(rownames(xi)))
xi=xi[row.names,,drop=FALSE]
! is.null(.siteNames(xi)))
xi=.siteSelect(xi,row.names)
nrows[i] <- nrow(xi)
nrows[i] <- .siteCount(xi)
value[[i]]=xi
}
......@@ -123,16 +170,16 @@ procmod.frame = function(...,
attr(value,"row.names")=row.names
if (check.rows)
for (i in seq_len(n)) {
if (! all(row.names == rownames(value[[i]])))
if (! all(row.names == .siteNames(value[[i]])))
stop("Row names among matrices are not consistant")
}
else
for (i in seq_len(n))
rownames(value[[i]])=row.names
.siteNames(value[[i]])=row.names
}
else
for (i in seq_len(n))
rownames(value[[i]])=NULL
.siteNames(value[[i]])=NULL
return(make_subS3Class(value, "procmod.frame"))
}
......@@ -223,7 +270,7 @@ dim.procmod.frame = function(x)
if (!is.null(value)) {
value=.procmod_coerce_value(value,nrows)
N <- nrow(value)
N <- .siteCount(value)
if (N > nrows)
stop(sprintf(ngettext(N, "replacement has %d row, data has %d",
......@@ -239,7 +286,7 @@ dim.procmod.frame = function(x)
}
rownames(value)=attr(x,"row.names")
.siteNames(value)=attr(x,"row.names")
x[[i]] <- value
class(x)=cl
......@@ -288,7 +335,7 @@ dim.procmod.frame = function(x)
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])
y = lapply(x, function(m) .siteSelect(m,i))
}
else if ( has.i && has.j ) {
# message('Case 5 : X[i,j]')
......
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