https://github.com/cran/spatstat
Revision e575bb3736f6d70d2bd2b23ea2e4474cdbae00be authored by Adrian Baddeley on 11 November 2010, 13:09:43 UTC, committed by cran-robot on 11 November 2010, 13:09:43 UTC
1 parent cafe44b
Tip revision: e575bb3736f6d70d2bd2b23ea2e4474cdbae00be authored by Adrian Baddeley on 11 November 2010, 13:09:43 UTC
version 1.21-1
version 1.21-1
Tip revision: e575bb3
hyperframe.R
#
# hyperframe.R
#
# $Revision: 1.40 $ $Date: 2010/05/20 14:20:26 $
#
hyperframe <- function(...,
row.names=NULL, check.rows=FALSE, check.names=TRUE,
stringsAsFactors=default.stringsAsFactors()) {
aarg <- list(...)
nama <- names(aarg)
# number of columns (= variables)
nvars <- length(aarg)
if(nvars == 0) {
# zero columns - return
result <- list(nvars=0,
ncases=0,
vname=character(0),
vtype=factor(,
levels=c("dfcolumn","hypercolumn","hyperatom")),
vclass=character(0),
df=data.frame(),
hyperatoms=list(),
hypercolumns=list())
class(result) <- c("hyperframe", class(result))
return(result)
}
# check column names
if(is.null(nama))
nama <- paste("V", 1:nvars, sep="")
else if(any(unnamed <- (nama == "")))
nama[unnamed] <- paste("V", seq(sum(unnamed)), sep="")
nama <- make.names(nama, unique=TRUE)
names(aarg) <- nama
# Each argument must be either
# - a vector suitable as a column in a data frame
# - a list of objects of the same class
# - a single object of some class
is.dfcolumn <- function(x) {
is.atomic(x) && (is.vector(x) || is.factor(x))
}
is.hypercolumn <- function(x) {
if(!is.list(x))
return(FALSE)
if(length(x) <= 1)
return(TRUE)
cla <- class(x[[1]])
all(sapply(x, function(xi,cla) { identical(class(xi), cla) }, cla=cla))
}
dfcolumns <- sapply(aarg, is.dfcolumn)
hypercolumns <- sapply(aarg, is.hypercolumn)
hyperatoms <- !(dfcolumns | hypercolumns)
# Determine number of rows (= cases)
columns <- dfcolumns | hypercolumns
if(!any(columns))
ncases <- 1
else {
heights <- rep(1, nvars)
heights[columns] <- unlist(lapply(aarg[columns], length))
u <- unique(heights)
if(length(u) > 1) {
u <- u[u != 1]
if(length(u) > 1)
stop(paste("Column lengths are inconsistent:",
paste(u, collapse=",")))
}
ncases <- u
if(ncases > 1 && all(heights[dfcolumns] == 1))
# force the data frame to have 'ncases' rows
aarg[dfcolumns] <- lapply(aarg[dfcolumns], rep, ncases)
}
# Collect the data frame columns into a data frame
if(!any(dfcolumns))
df <- as.data.frame(matrix(, ncases, 0), row.names=row.names)
else {
df <- do.call("data.frame", append(aarg[dfcolumns],
list(row.names=row.names,
check.rows=check.rows,
check.names=check.names,
stringsAsFactors=stringsAsFactors)))
names(df) <- nama[dfcolumns]
}
# Storage type of each variable
vtype <- character(nvars)
vtype[dfcolumns] <- "dfcolumn"
vtype[hypercolumns] <- "hypercolumn"
vtype[hyperatoms] <- "hyperatom"
vtype=factor(vtype, levels=c("dfcolumn","hypercolumn","hyperatom"))
# Class of each variable
class1 <- function(x) { class(x)[1] }
vclass <- character(nvars)
if(any(dfcolumns))
vclass[dfcolumns] <- unlist(lapply(as.list(df), class1))
if(any(hyperatoms))
vclass[hyperatoms] <- unlist(lapply(aarg[hyperatoms], class1))
if(any(hypercolumns))
vclass[hypercolumns] <- unlist(lapply(aarg[hypercolumns],
function(x) { class1(x[[1]]) }))
# Put the result together
result <- list(nvars=nvars,
ncases=ncases,
vname=nama,
vtype=vtype,
vclass=vclass,
df=df,
hyperatoms=aarg[hyperatoms],
hypercolumns=aarg[hypercolumns])
class(result) <- c("hyperframe", class(result))
return(result)
}
is.hyperframe <- function(x) inherits(x, "hyperframe")
print.hyperframe <- function(x, ...) {
ux <- unclass(x)
nvars <- ux$nvars
ncases <- ux$ncases
if(nvars * ncases == 0) {
cat(paste("NULL hyperframe with", ncases,
ngettext(ncases, "row (=case)", "rows (=cases)"),
"and", nvars,
ngettext(nvars, "column (=variable)", "columns (=variables)"),
"\n"))
} else {
cat("Hyperframe:\n")
print(as.data.frame(x, discard=FALSE), ...)
}
return(invisible(NULL))
}
dim.hyperframe <- function(x) {
with(unclass(x), c(ncases, nvars))
}
summary.hyperframe <- function(object, ..., brief=FALSE) {
x <- unclass(object)
y <- list(
nvars = x$nvars,
ncases = x$ncases,
dim = c(x$ncases, x$nvars),
typeframe = data.frame(VariableName=x$vname, Class=x$vclass),
storage = x$vtype,
col.names = x$vname)
classes <- x$vclass
names(classes) <- x$vname
y$classes <- classes
# Ordinary data frame columns
df <- x$df
y$dfnames <- names(df)
y$df <- if(length(df) > 0 && !brief) summary(df) else NULL
y$row.names <- row.names(df)
class(y) <- c("summary.hyperframe", class(y))
return(y)
}
print.summary.hyperframe <- function(x, ...) {
nvars <- x$nvars
ncases <- x$ncases
cat(paste(if(nvars * ncases == 0) "NULL" else NULL,
"hyperframe with", ncases,
ngettext(ncases, "row (=case)", "rows (=cases)"),
"and", nvars,
ngettext(nvars, "column (=variable)", "columns (=variables)"),
"\n"))
if(nvars == 0)
return(invisible(NULL))
# Variable names and types
print(x$typeframe)
# Ordinary data frame columns
if(!is.null(x$df)) {
cat("Summary of data frame columns:\n")
print(x$df, ...)
}
return(invisible(NULL))
}
names.hyperframe <- function(x) { unclass(x)$vname }
"names<-.hyperframe" <- function(x, value) {
x <- unclass(x)
stopifnot(is.character(value))
value <- make.names(value)
if(length(value) != x$nvars)
stop("Incorrect length for vector of names")
x$vname <- value
names(x$df) <- value[x$vtype == "dfcolumn"]
class(x) <- c("hyperframe", class(x))
return(x)
}
row.names.hyperframe <- function(x) {
return(row.names(unclass(x)$df))
}
"row.names<-.hyperframe" <- function(x, value) {
y <- unclass(x)
df <- y$df
row.names(df) <- value
y$df <- df
class(y) <- c("hyperframe", class(y))
return(y)
}
## conversion to hyperframe
as.hyperframe <- function(x, ...) {
UseMethod("as.hyperframe")
}
as.hyperframe.hyperframe <- function(x, ...) {
return(x)
}
as.hyperframe.data.frame <- function(x, ...) {
if(missing(x))
return(do.call("hyperframe", list(...)))
do.call("hyperframe",
resolve.defaults(
as.list(x),
list(...),
list(row.names=rownames(x))))
}
as.hyperframe.listof <- function(x, ...) {
if(missing(x))
return(do.call("hyperframe", list(...)))
do.call("hyperframe",
resolve.defaults(
list(x),
list(...),
list(row.names=names(x))))
}
as.hyperframe.default <- function(x, ...) {
as.hyperframe(as.data.frame(x, ...))
}
#### conversion to other types
as.data.frame.hyperframe <- function(x, row.names = NULL,
optional = FALSE, ...,
discard=TRUE, warn=TRUE) {
ux <- unclass(x)
if(is.null(row.names))
row.names <- row.names(ux$df)
vtype <- ux$vtype
vclass <- ux$vclass
dfcol <- (vtype == "dfcolumn")
if(discard) {
nhyper <- sum(!dfcol)
if(nhyper > 0 && warn)
warning(paste(nhyper,
ngettext(nhyper, "variable", "variables"),
"discarded in conversion to data frame"))
df <- as.data.frame(ux$df, row.names=row.names, optional=optional, ...)
} else {
lx <- as.list(x)
nrows <- ux$ncases
vclassstring <- paste("(", vclass, ")", sep="")
if(any(!dfcol))
lx[!dfcol] <- lapply(as.list(vclassstring[!dfcol]),
function(x,n) { rep(x,n)}, n=nrows)
df <- do.call("data.frame", append(lx, list(row.names=row.names)))
}
return(df)
}
as.list.hyperframe <- function(x, ...) {
ux <- unclass(x)
nama <- ux$vname
names(nama) <- nama
out <- lapply(nama, function(nam, x) { x[, nam, drop=TRUE] }, x=x)
return(out)
}
# evaluation
eval.hyper <- function(e, h, simplify=TRUE, ee=NULL) {
.Deprecated("with.hyperframe", package="spatstat")
if(is.null(ee))
ee <- as.expression(substitute(e))
with.hyperframe(h, simplify=simplify, ee=ee)
}
with.hyperframe <- function(data, expr, ..., simplify=TRUE, ee=NULL,
enclos=NULL) {
if(!inherits(data, "hyperframe"))
stop("data must be a hyperframe")
if(is.null(ee))
ee <- as.expression(substitute(expr))
if(is.null(enclos))
enclos <- parent.frame()
n <- nrow(data)
out <- vector(mode="list", length=n)
for(i in 1:n) {
rowi <- data[i,, drop=FALSE]
outi <- eval(ee, as.list(rowi), enclos)
if(!is.null(outi))
out[[i]] <- outi
}
names(out) <- row.names(data)
if(simplify && all(unlist(lapply(out, is.vector)))) {
# if all results are atomic vectors of equal length,
# return a matrix or vector.
lenfs <- unlist(lapply(out, length))
if(all(unlist(lapply(out, is.atomic))) &&
length(unique(lenfs)) == 1) {
out <- t(as.matrix(as.data.frame(out)))
row.names(out) <- row.names(data)
out <- out[,,drop=TRUE]
return(out)
}
}
out <- hyperframe(result=out, row.names=row.names(data))$result
return(out)
}
cbind.hyperframe <- function(...) {
aarg <- list(...)
narg <- length(aarg)
if(narg == 0)
return(hyperframe())
namarg <- names(aarg)
if(is.null(namarg))
namarg <- rep("", narg)
ishyper <- unlist(lapply(aarg, inherits, what="hyperframe"))
isdf <- unlist(lapply(aarg, inherits, what="data.frame"))
columns <- list()
for(i in 1:narg) {
if(ishyper[i] || isdf[i]){
if(ncol(aarg[[i]]) > 0) {
newcolumns <- as.list(aarg[[i]])
if(namarg[i] != "")
names(newcolumns) <- paste(namarg[i], ".", names(newcolumns), sep="")
columns <- append(columns, newcolumns)
}
} else {
nextcolumn <- list(aarg[[i]])
names(nextcolumn) <- namarg[i]
columns <- append(columns, nextcolumn)
}
}
result <- do.call("hyperframe", columns)
return(result)
}
rbind.hyperframe <- function(...) {
argh <- list(...)
if(length(argh) == 0)
return(NULL)
# convert them all to hyperframes
argh <- lapply(argh, as.hyperframe)
#
nargh <- length(argh)
if(nargh == 1)
return(argh[[1]])
# check for compatibility of dimensions & names
dfs <- lapply(argh, as.data.frame, discard=FALSE)
dfall <- do.call(rbind, dfs)
# check that data frame columns also match
dfs0 <- lapply(argh, as.data.frame, discard=TRUE, warn=FALSE)
df0all <- do.call(rbind, dfs0)
# assemble data
rslt <- list()
nam <- names(dfall)
nam0 <- names(df0all)
for(k in seq(along=nam)) {
nama <- nam[k]
if(nama %in% nam0) {
# data frame column: already made
rslt[[k]] <- dfall[,k]
} else {
# hypercolumns or hyperatoms: extract them
hdata <- lapply(argh,
function(x,nama) { x[, nama, drop=TRUE] },
nama=nama)
# append them
hh <- hdata[[1]]
for(j in 2:nargh) {
hh <- append(hh, hdata[[j]])
}
rslt[[k]] <- hh
}
}
# make hyperframe
names(rslt) <- nam
out <- do.call(hyperframe, append(rslt, list(stringsAsFactors=FALSE)))
return(out)
}
plot.hyperframe <- function(x, e, ..., main, arrange=TRUE,
nrows=NULL, ncols=NULL,
parargs=list(mar=c(1,1,3,1) * marsize),
marsize=0.1) {
xname <- deparse(substitute(x))
main <- if(!missing(main)) main else xname
ee <- as.expression(substitute(e))
if(missing(e)) {
# default: plot first column that contains objects
ok <- (summary(x)$storage %in% c("hypercolumn", "hyperatom"))
if(any(ok)) {
j <- min(which(ok))
x <- x[,j, drop=TRUE]
x <- as.listof(x)
plot(x, ..., main=main, arrange=arrange, nrows=nrows, ncols=ncols)
return(invisible(NULL))
} else {
# hyperframe does not contain any objects
# invoke plot.data.frame
x <- as.data.frame(x)
plot(x, ..., main=main)
return(invisible(NULL))
}
}
# No arrangement: just evaluate the plot expression 'nr' times
if(!arrange) {
with(x, ee=ee)
return(invisible(NULL))
}
# Arrangement
# Decide whether to plot a main header
banner <- (sum(nchar(as.character(main))) > 0)
if(length(main) > 1)
main <- paste(main, collapse="\n")
nlines <- if(!is.character(main)) 1 else length(unlist(strsplit(main, "\n")))
# determine arrangement of plots
# arrange like mfrow(nrows, ncols) plus a banner at the top
n <- summary(x)$ncases
if(is.null(nrows) && is.null(ncols)) {
nrows <- as.integer(floor(sqrt(n)))
ncols <- as.integer(ceiling(n/nrows))
} else if(!is.null(nrows) && is.null(ncols))
ncols <- as.integer(ceiling(n/nrows))
else if(is.null(nrows) && !is.null(ncols))
nrows <- as.integer(ceiling(n/ncols))
else stopifnot(nrows * ncols >= length(x))
nblank <- ncols * nrows - n
# declare layout
mat <- matrix(c(seq(n), rep(0, nblank)),
byrow=TRUE, ncol=ncols, nrow=nrows)
heights <- rep(1, nrows)
if(banner) {
# Increment existing panel numbers
# New panel 1 is the banner
panels <- (mat > 0)
mat[panels] <- mat[panels] + 1
mat <- rbind(rep(1,ncols), mat)
heights <- c(0.1 * (1 + nlines), heights)
}
# initialise plot
layout(mat, heights=heights)
# plot banner
if(banner) {
opa <- par(mar=rep(0,4), xpd=TRUE)
plot(numeric(0),numeric(0),type="n",ann=FALSE,axes=FALSE,
xlim=c(-1,1),ylim=c(-1,1))
cex <- resolve.defaults(list(...), list(cex.title=2))$cex.title
text(0,0,main, cex=cex)
}
# plot panels
npa <- do.call("par", parargs)
if(!banner) opa <- npa
with(x, ee=ee)
# revert
layout(1)
par(opa)
return(invisible(NULL))
}
Computing file changes ...