https://github.com/cran/spacetime
Tip revision: dadc1ac88cff04c9634fc0885cc087f229c59fca authored by Edzer Pebesma on 06 September 2013, 00:00:00 UTC
version 1.0-9
version 1.0-9
Tip revision: dadc1ac
STFDF-methods.R
STF = function(sp, time, endTime = delta(time)) {
new("STF", ST(sp, time, endTime))
}
STFDF = function(sp, time, data, endTime = delta(time)) {
new("STFDF", STF(sp, time, endTime), data = data)
}
myCoordinates = function(x) {
stopifnot(is(x, "Spatial"))
if (is(x, "SpatialLines"))
do.call(rbind, lapply(coordinates(x), function(x) x[[1]][1,]))
else
coordinates(x)
}
setMethod("coordinates", "STF", function(obj) {
mc = myCoordinates(obj@sp)
m = matrix(apply(mc, 2, rep, nrow(obj@time)), ncol = ncol(mc))
dimnames(m)[[2]] = coordnames(obj@sp)
m
}
)
index.STF = function(x, ...) {
rep(index(x@time), each = length(x@sp))
}
index.STFDF = index.STF
as.data.frame.STF = function(x, row.names = NULL, ...) {
if (is.null(row.names(x@sp)))
row.names(x@sp) = 1:nrow(x@sp)
timedata = apply(x@time, 2, rep, each = length(x@sp))
ret = data.frame(as.data.frame(coordinates(x)),
sp.ID = rep(factor(row.names(x@sp), levels = row.names(x@sp)),
nrow(x@time)),
time = index(x),
endTime = rep(x@endTime, each= length(x@sp)),
timedata,
row.names = row.names, ...)
if ("data" %in% slotNames(x@sp)) {
x = apply(x@sp@data, 2, rep, nrow(x@time))
row.names(x) = NULL
ret = data.frame(ret, x)
}
#ret = data.frame(ret, timedata)
ret
}
setAs("STF", "data.frame", function(from) as.data.frame.STF(from))
as.data.frame.STFDF = function(x, row.names = NULL, ...) {
f = as.data.frame(as(x, "STF"))
data.frame(f, x@data, row.names = row.names, ...)
}
setAs("STFDF", "data.frame", function(from) as.data.frame.STFDF(from))
unstack.STFDF = function(x, form, which = 1,...) {
if(missing(form))
# form = as.formula(paste(names(x@data)[which],
# paste(coordnames(x@sp),collapse="+"), sep = "~"))
form = as.formula(paste(names(x@data)[which], "sp.ID", sep = "~"))
ret = unstack(as(x, "data.frame"), form, ...)
rownames(ret) = as.character(index(x@time))
ret
}
as.STFDF.xts = function(from) {
nc = seq_along(from@data) # attribute columns indexes
ret = do.call(cbind, lapply(nc,
function(i) {
ix = index(from@time)
if (is(ix, "Date"))
xts(unstack(from[,,i]), ix)
else
xts(unstack(from[,,i]), ix, tzone = attr(from@time, "tzone"))
}
)
)
if (length(nc) > 1)
names(ret) = as.vector(t(outer(names(from@data), row.names(from@sp), paste, sep = ".")))
else
names(ret) = row.names(from@sp)
ret
}
setAs("STFDF", "xts", as.STFDF.xts)
as.zoo.STFDF = function(x,...) as.zoo(as(x, "xts"))
setAs("STFDF", "zoo", function(from) as.zoo.STFDF(from))
as.array.STFDF = function(x, ...) {
a = array(NA, dim(x))
for (i in 1:dim(x)[3])
a[,,i] = t(as(x[,,i], "xts"))
dimnames(a) = list(names(x@sp), make.names(index(x@time)), names(x@data))
a
}
subs.STFDF <- function(x, i, j, ... , drop = TRUE) {
nr = dim(x)[1]
nc = dim(x)[2]
n.args = nargs()
dots = list(...)
missing.i = missing(i)
missing.j = missing(j)
if (length(dots) > 0) {
missing.k = FALSE
k = dots[[1]]
} else
missing.k = TRUE
if (missing.i && missing.j && missing.k)
return(x)
if (!missing.k) {
x@data = x@data[ , k, drop = FALSE]
if (missing.j && n.args == 2)
return(x)
}
if (missing.i)
s = 1:length(x@sp)
else {
if (is(i, "Spatial")) {
s = which(!is.na(over(x@sp, geometry(i))))
} else if (is.logical(i)) {
i = rep(i, length.out = length(x@sp))
s = which(i)
} else if (is.character(i)) { # suggested by BG:
s = match(i, row.names(x@sp), nomatch = FALSE)
} else
s = i
}
x@sp = x@sp[s,]
if (missing.j)
t = 1:nrow(x@time)
else {
if (is.logical(j))
j = which(j)
nct = ncol(x@time)
x@time = cbind(x@time, 1:nrow(x@time))
# uses [.xts, deals with character/iso8601;
# takes care of negative indices:
x@time = x@time[j]
# get back the corresponding index vector t, to use for @data:
t = as.vector(x@time[, nct+1])
x@time = x@time[,-(nct+1)]
x@endTime = x@endTime[t]
}
#x@data = x@data[ssel & tsel, k, drop = FALSE]
x@data = data.frame(
lapply(x@data, function(v) as.vector(matrix(v, nr, nc)[s,t])))
if (drop) {
if (length(s) == 1 && all(s > 0)) { # space index has only 1 item:
if (length(t) == 1) # drop time as well:
x = x@data[1,]
else {
ix = index(x@time)
if (is(ix, "Date"))
x = xts(x@data, ix)
else
x = xts(x@data, ix, tzone = attr(x@time, "tzone"))
}
} else if (length(t) == 1) # only one time step:
x = addAttrToGeom(x@sp, x@data, match.ID = FALSE)
}
x
}
setMethod("[", "STFDF", subs.STFDF)
# provide a na.omit-method for STFDF objects
# removes rows and columns from the space-time grid
# containing NAs in the data
# Tom Gottfried
na.omit.STFDF <- function(object, drop=TRUE, ...){
data <- na.omit(object@data)
omit <- attr(data, "na.action")
n <- length(object@sp)
s <- unique((omit-1) %% n + 1)
t <- unique((omit-1) %/% n + 1)
if (drop && (length(s)==n || length(t)==nrow(object@time)))
return(NA)
else
# return(object[-s,-t, drop=drop])
# <= negative indices are partly not handled by [-method
# return(object[(1:n)[!(1:n) %in% s],
# (1:nrow(object@time))[!1:nrow(object@time) %in% t],
# drop=drop])
# <= logical indices partly not handled by [-method
return(object[(1:n)[!(1:n) %in% s],
(1:nrow(object@time))[!1:nrow(object@time) %in% t],
drop=drop])
}
setMethod("addAttrToGeom", signature(x = "STF", y = "data.frame"),
function(x, y, match.ID, ...)
new("STFDF", x, data = y)
)
length.STF = function(x) { prod(dim(x)[1:2]) }
length.STFDF = function(x) { prod(dim(x)[1:2]) }
setMethod("geometry", "STFDF", function(obj) as(obj, "STF"))
nbMult = function(nb, st, addT = TRUE, addST = FALSE) {
stopifnot(is(st, "STF"))
stopifnot(is(nb, "nb"))
stopifnot(length(nb) == length(st@sp))
n = dim(st)[2] # time dimension
if (n <= 1)
return(nb)
L = length(nb)
ret = list()
FN = function(x,i,j,L) {
ret = as.integer(x + i * L) # spatial-only, for time i+1
if (addT) {
if (addST)
now = c(ret, j + i * L)
else
now = j + i * L
if (i > 0)
ret = c(ret, now - L) # time-previous: j-iL
if (i < (n-1))
ret = c(ret, now + L) # time-next: j+iL
}
sort(ret)
}
for (i in 0:(n-1)) {
app = lapply(1:L, function(j) FN(nb[[j]], i, j, L))
ret = append(ret, app)
}
attributes(ret) = attributes(nb)
attr(ret, "region.id") = as.character(1:length(ret))
ret
}