Nothing
## compare tracks
setGeneric(
name = "compare",
def = function(tr1, tr2) standardGeneric("compare")
)
## get distances between 2 Track objects for each point in time where they overlap
## extend each track with these points
## create corresponding lines
## returns a difftrack object
compare.track <- function(tr1, tr2) {
if (!requireNamespace("xts", quietly = TRUE))
stop("package xts required for track comparison")
if (!(xts::first(tr1@endTime) < xts::last(tr2@endTime) && xts::first(tr2@endTime) < xts::last(tr1@endTime)))
stop("Time itervals don't overlap!")
if (!identicalCRS(tr1, tr2))
stop("CRS are not identical!")
crs <- tr1@sp@proj4string
track1.df <- cbind(as.data.frame(tr1)[c(coordnames(tr1), "time")])
track2.df <- cbind(as.data.frame(tr2)[c(coordnames(tr2), "time")])
# intervals timestamps fall in
ivs1 <- findInterval(track1.df$time, track2.df$time)
ivs2 <- findInterval(track2.df$time, track1.df$time)
# find points and create new extended data frames
newTrack1.df <- findPoints(track2.df, track1.df, ivs2)
newTrack2.df <- findPoints(track1.df, track2.df, ivs1)
# points on the original
conns12 <- merge(newTrack2.df, track1.df, "time")
conns21 <- merge(track2.df, newTrack1.df, "time")
conns12 <- lineConnections(conns12, crs)
conns21 <- lineConnections(conns21, crs)
# extended tracks
newTrack1 <- STIDF(SpatialPoints(cbind(newTrack1.df$x, newTrack1.df$y), crs), newTrack1.df$time, data.frame(1:nrow(newTrack1.df)))
newTrack2 <- STIDF(SpatialPoints(cbind(newTrack2.df$x, newTrack2.df$y), crs), newTrack2.df$time, data.frame(1:nrow(newTrack2.df)))
newTrack1 <- Track(newTrack1)
newTrack2 <- Track(newTrack2)
new("difftrack", track1 = newTrack1, track2 = newTrack2, conns1 = conns12, conns2 = conns21)
}
setMethod("compare", signature("Track"), compare.track)
## distances between 2 Tracks objects
setGeneric(
name = "dists",
def = function(tr1, tr2, ...) standardGeneric("dists")
)
## returns a matrix with the distance between each pair of tracks
dists.tracks <- function(tr1, tr2, f = mean, ...) {
cols <- dim(tr1)[[1]]
rows <- dim(tr2)[[1]]
dists <- matrix(nrow=rows, ncol=cols) # matrix with NA's
for (i in 1:cols) {
for (j in 1:rows) {
if (identical(f, frechetDist)) {
dists[j,i] <- f(tr1[i], tr2[j])
} else try({ ## try in case compare gives an error because tracks don't overlap in time
difftrack <- compare(tr1[i], tr2[j])
dists[j,i] <- f(c(difftrack@conns1@data$dists, difftrack@conns2@data$dists), ...)
})
}
}
dists
}
setMethod("dists", signature(tr1 = "Tracks", tr2 = "Tracks"), dists.tracks)
## finds corresponding points for track1 on track2
findPoints <- function(tr1, tr2, ivs) {
x <- tr2[,1]
y <- tr2[,2]
time <- tr2[,3]
for (i in 1:nrow(tr1)) {
if (!ivs[i] == 0 && !ivs[i] == nrow(tr2)) {
iv <- ivs[i]
# tdiff1 <- tr1$time[i] - tr2$time[iv] # diff between timestamp and start of the interval it falls in
tdiff1 <- difftime(tr1$time[i], tr2$time[iv])
# tdiff2 <- tr2$time[iv+1] - tr2$time[iv] # diff between timestamps (calculated here because it often varies)
tdiff2 <- difftime(tr2$time[iv+1], tr2$time[iv], units = units(tdiff1))
ratio <- as.numeric(tdiff1)/as.numeric(tdiff2)
x1 <- tr2[iv,1] # segment coordinates
y1 <- tr2[iv,2]
x2 <- tr2[iv+1,1]
y2 <- tr2[iv+1,2]
x <- c(x, x1 + ratio * (x2 - x1)) #find point
y <- c(y, y1 + ratio * (y2 - y1))
time <- c(time, tr1$time[i])
}
}
newTrack <- data.frame(x, y, time)
newTrack <- newTrack[!duplicated(newTrack),] # remove duplicates
newTrack <- newTrack[order(newTrack$time),] # sort by timestamp
newTrack
}
## creates SpatialLines
lineConnections <- function(conns, crs) {
Lines <- list()
coords1 <- cbind(conns[,2], conns[,3])
coords2 <- cbind(conns[,4], conns[,5])
for (i in 1:nrow(conns)) {
Lines <- c(Lines, list(Lines(Line(rbind(coords1[i,], coords2[i,])), ID = i)))
}
sl <- SpatialLines(Lines, crs)
dists <- SpatialLinesLengths(sl)
sl <- SpatialLinesDataFrame(sl, data.frame(time = conns$time, dists), FALSE)
sl
}
frechetDist <- function(track1, track2) {
stopifnot(is(track1, "Track"), is(track2, "Track"))
if (!requireNamespace("xts", quietly = TRUE))
stop("package xts required for frechetDist comparison")
if (!identicalCRS(track1, track2))
stop("CRS are not identical!")
dists <- spDists(track1@sp, track2@sp) #dists between all points
dists[,1] <- cummax(dists[,1]) # cases where one of the trajectories is a point
dists[1,] <- cummax(dists[1,])
for (i in 2:nrow(dists)) { # build rest of frechet distance matrix
for (j in 2:ncol(dists)) {
dists[i,j] <- max(dists[i,j], min(dists[i-1,j], dists[i-1,j-1], dists[i,j-1]))
}
}
max(xts::last(xts::last(dists)))
}
## downsamples a track to the length of another one
setGeneric(
name = "downsample",
def = function(track1, track2, ...) standardGeneric("downsample")
)
# track1: track that will be downsampled
# track2: to the dimension of track2
downsample.track <- function(track1, track2) {
if(!identicalCRS(track1, track2))
stop("CRS are not identical!")
if(dim(track1) == dim(track2))
stop("Dimensions are euqal!")
tr <- track1
xy <- coordinates(track1)
time <- index(track1@time)
crs <- track1@sp@proj4string
while(dim(track1) > dim(track2)) {
d1 <- track1$distance # distances
n <- length(d1) - 1 # number of segments between every second point
xy1 <- cbind(head (xy, n), tail (xy, n))
d2.long <- head(d1, n) + tail(d1, n)
xy.new <- list()
for(i in 1:n) {xy.new[[i]] <- rbind(head(xy, n)[i,], tail(xy, n)[i,])}
d2.short <- sapply (xy.new, function(x) spDists(as.matrix(x), longlat=TRUE)[1,2])
remove <- which.min(d2.long - d2.short) + 1
xy <- xy[- remove,]
time <- time[- remove]
stidf <- STIDF(SpatialPoints (xy, crs), time, data.frame(extraDat=rnorm(n)))
track1 <- Track (stidf)
}
track1
}
setMethod("downsample", signature("Track"), downsample.track)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.