https://github.com/cran/spacetime
Tip revision: e878bcb191f03b828bcf0c15504b0ca9a809e1df authored by Edzer Pebesma on 19 February 2013, 21:22:04 UTC
version 1.0-4
version 1.0-4
Tip revision: e878bcb
STTDF-methods.R
STT = function(STbox = NULL, trajLst) {
if (is.null(STbox)) {
bb = sapply(trajLst, function(x) bbox(x@sp))
sp = SpatialPoints(rbind(c(min(bb[1,]), min(bb[2,])),
c(max(bb[3,]), max(bb[4,]))), trajLst[[1]]@sp@proj4string)
coordnames(sp) = coordnames(trajLst[[1]]@sp)
tm = do.call(c, lapply(trajLst, index))
rt = range(tm)
STbox = STI(sp, rt)
}
new("STT", STbox, traj = trajLst)
}
STTDF = function(STT, data) {
new("STTDF", STT, data = data)
}
setClass("ltraj", representation("list"))
setAs("ltraj", "STTDF",
function(from) {
d = do.call(rbind, from)
ns = sapply(from, nrow)
burst = sapply(from, function(x) attr(x, "burst"))
id = sapply(from, function(x) attr(x, "id"))
d$burst = factor(rep(burst, ns))
d$id = factor(rep(id, ns))
toSTI = function(x) {
time = x[["date"]]
ret = STI(SpatialPoints(x[c("x", "y")]), time)
attr(ret, "burst") = attr(x, "burst")
attr(ret, "id") = attr(x, "id")
ret
}
rt = range(d$date)
STIbox = STI(SpatialPoints(cbind(range(d$x), range(d$y))), rt)
STTDF(STT(STIbox, trajLst = lapply(from, toSTI)), data = d)
}
)
setAs("STTDF", "ltraj",
function(from) {
x = as(from, "STIDF")
xy = coordinates(x@sp)
da = index(x@time)
as.ltraj(xy, da, id = x[["id"]], burst = x[["burst"]])
}
)
setMethod("coordinates", "STT", function(obj) {
do.call(rbind, lapply(obj@traj, coordinates))
}
)
# plot.STTDF = function(x, y,..., byBurst = TRUE,
# col = "black", lty = 1, lwd = 1,
# type = "l", pch = 1,
# add = FALSE) {
# if (add == FALSE)
# plot(as(x@sp, "Spatial"), ...) # sets up plotting area
# if (byBurst)
# f = x$burst
# else {
# stopifnot(!is.null(x$id))
# f = x$id
# }
# lst = split(data.frame(coordinates(x)), f)
# col = rep(col, length = length(lst))
# lwd = rep(lwd, length = length(lst))
# lty = rep(lty, length = length(lst))
# for (i in seq(along = lst))
# lines(as.matrix(lst[[i]]), col = col[i], lty = lty[i], lwd = lwd[i],
# type = type, pch = pch)
# }
#
# setMethod("plot", signature(x = "STTDF", y = "missing"), plot.STTDF)
subs.STTDF <- function(x, i, j, ... , drop = FALSE) {
missing.i = missing(i)
missing.j = missing(j)
missing.k = k = TRUE
dots = list(...)
if (length(dots) > 0) {
missing.k = FALSE
k = dots[[1]]
}
if (missing.i && missing.j && missing.k)
return(x)
#stop("not yet implemented")
# space
if (missing.i)
i = TRUE
if (is(i, "Spatial") || is(i, "ST")) {
# select trajectories that match
i = !is.na(over(x@sp, geometry(i)))
}
if (is.logical(i)) {
i = rep(i, length.out = length(x@traj))
i = which(i)
} else if (is.character(i)) { # suggested by BG:
i = match(i, row.names(x@sp), nomatch = FALSE)
}
# time
if (missing.j)
j = rep(TRUE, length=nrow(x@time))
else {
if (is.logical(j))
j = which(j)
t = xts(matrix(1:nrow(x@time), dimnames=list(NULL, "timeIndex")),
index(x@time))[j]
j = as.vector(t[,1])
}
if(is.numeric(i))
i = 1:nrow(x@time) %in% i
if(is.numeric(j))
j = 1:nrow(x@time) %in% j
i = i & j
x@sp = x@sp[i,]
x@time = x@time[i,]
x@endTime = x@endTime[i]
x@data = x@data[i, k, drop = FALSE]
if (drop && length(unique(index(x@time))) == 1)
x = addAttrToGeom(x@sp, x@data, match.ID = FALSE)
x
}
setMethod("[", "STTDF", subs.STTDF)