R/interpolateTime.R

In move: Visualizing and Analyzing Animal Track Data

# require(move)
setGeneric("interpolateTime", function(x, time, spaceMethod = c("euclidean", "greatcircle", "rhumbline"), ...) {
  standardGeneric("interpolateTime")
})
setOldClass("difftime")
setMethod("interpolateTime",
  signature = c(".MoveTrackSingle", "numeric"),
  definition = function(x, time, ...) {
    stopifnot(length(time) == 1)
    time <- seq(min(timestamps(x)), max(timestamps(x)), length.out = time)
    callGeneric()
  }
)
setMethod("interpolateTime",
  signature = c(".MoveTrackSingle", "difftime"),
  definition = function(x, time, ...) {
    stopifnot(length(time) == 1)
    time <- seq(min(timestamps(x)), max(timestamps(x)), by = time)
    callGeneric()
  }
)
setMethod("interpolateTime",
  signature = c(".MoveTrackSingle", "POSIXct"),
  definition = function(x, time, spaceMethod = c("euclidean", "greatcircle", "rhumbline"), ...) {
    stopifnot(max(time) <= max(timestamps(x)))
    stopifnot(min(time) >= min(timestamps(x)))
    spaceMethod <- match.arg(spaceMethod)
    if (spaceMethod == "euclidean" & isLonLat(x)) {
      warning("Euclidean interpolation seems unsuitable for the longitude latitude projection")
    }
    # the next two steps are the slow ones
    # previous loc
    prevLoc <- unlist(lapply(lapply(lapply(time, ">=", timestamps(x)), which), max))
    # next loc
    nextLoc <- unlist(lapply(lapply(lapply(time, "<=", timestamps(x)), which), min))
    p <- as.numeric(time - timestamps(x)[prevLoc], units = "secs") / as.numeric(timestamps(x)[nextLoc] - timestamps(x)[prevLoc], units = "secs")
    if (all(is.nan(p))) {
      return(x[prevLoc, ])
    }
    fun <- switch(spaceMethod,
      euclidean = function(x, y, p) {
        (x) * (1 - p) + (y) * p
      },
      greatcircle = function(x, y, p) {
        destPoint(x, ifelse(is.na(bearing(x, y)), 0, bearing(x, y)), distHaversine(x, y) * p)
      },
      rhumbline = function(x, y, p) {
        destPointRhumb(x, ifelse(is.na(bearingRhumb(x, y)), 0, bearingRhumb(x, y)), distRhumb(x, y) * p)
      }
    )
    # 	  crds<-do.call('rbind',mapply(function(x,y,p,f,m){if(is.nan(p)){return(coordinates(m[x,]))}else{f(m[x,],m[y,],p)}},x=prevLoc, y=nextLoc,p=p,MoreArgs=list(m=x,f=fun), SIMPLIFY=FALSE))

    crds <- matrix(fun(coordinates(x)[prevLoc, ], coordinates(x)[nextLoc, ], ifelse(is.nan(p), 0, p)), ncol = 2) # matrix incase only one location
    colnames(crds) <- colnames(coordinates(x))
    sensor <- factor(ifelse(is.nan(p), as.character(x@sensor[prevLoc]), "interpolateTime"), levels = c(levels(x@sensor), "interpolateTime"))
    m <- new("Move", x[prevLoc, ], coords = crds, timestamps = time, sensor = sensor, sensorUnUsedRecords = factor(x@sensorUnUsedRecords, levels = c(levels(x@sensorUnUsedRecords), "interpolateTime")))
    m[!is.nan(p), ] <- NA
    return(m)
  }
)