Added track align.

NAMESPACE

@@ -191,6 +191,7 @@ S3method(time_of_day,steps_xyt)
 S3method(time_of_day,track_xyt)
 S3method(to,track_xyt)
 S3method(tot_dist,track_xy)
+S3method(track_align,track_xyt)
 S3method(track_resample,track_xyt)
 S3method(transform_coords,track_xy)
 S3method(ungroup,track_xy)
@@ -339,6 +340,7 @@ export(time_of_day)
 export(to)
 export(tot_dist)
 export(track)
+export(track_align)
 export(track_resample)
 export(tracked_from_to)
 export(transform_coords)

NEWS.md

@@ -1,5 +1,8 @@
 # amt 0.3.0
 
+## New features
+- `track_align()` added to the package. 
+
 ## Fixes
 - Fixed issue #109
 - Solved issue #108

R/track_align.R

@@ -1,34 +1,66 @@
-# #' Selects relocations that fit a new time series
-# #'
-# #' Functions to only selects relocations that can be aligned with a new time series (within some tolerance).
-# #' @param x A track.
-# #' @param nt The new time trajectory.
-# #' @param tol The tolerance.
-# #' @template dots_none
-# #' @return A `track_xyt`.
-# #' @name track_align
-# #' @export
-#
-# track_align <- function(x, ...) {
-#   UseMethod("track_align", x)
-# }
-#
-# #' @rdname track_align
-# #' @export
-# track_align.track_xyt <- function(x, nt, tol, ...) {
-#   x[["burst_"]] <- track_align_raw(x, nt, tol, type = "burst")
-#   x[x$burst_ > -1, ] # -1 indicates that point is left out
-# }
-#
-#
-# track_align_raw <- function(x, nt, tol, type = "burst") {
-#   if (!type %in% c("which", "diff", "burst")) {
-#     stop("type should be one of: 'which', 'diff' or 'burst'.")
-#   }
-#
-#   if (!lubridate::is.POSIXct(nt)) {
-#     stop("nt should be of class: POSIXct")
-#   }
-#   xx <- track_align_cpp(as.integer(x$t_), as.integer(nt), as.integer(lubridate::period_to_seconds(tol)),
-#                         switch(type,  which = 1L,  diff = 2L, burst = 3L))
-# }
+#' Selects relocations that fit a new time series
+ #'
+ #' Functions to only selects relocations that can be aligned with a new time series (within some tolerance).
+ #' @param x A track.
+ #' @param new.times The new time trajectory.
+ #' @param tolerance The tolerance between observed time stamps and new time stamps in seceonds. This should be either a vector of length 1 or length `new.times`.
+ #' @template dots_none
+ #' @return A `track_xyt`.
+ #' @name track_align
+ #' @export
+
+ track_align <- function(x, ...) {
+   UseMethod("track_align", x)
+ }
+
+ #' @rdname track_align
+ #' @export
+ track_align.track_xyt <- function(x, new.times, tolerance, ...) {
+
+   # checks
+   if (max(new.times) <= min(x$t_)) {
+     stop("new time stamps do not overlap with observed time stamps.")
+   }
+
+   checkmate::assert_numeric(tolerance, lower = 0)
+
+   if (!length(tolerance) %in% c(1, length(new.times))) {
+     stop("Tolerance should be either 1 or `length(new.times)`.")
+   }
+
+   # Do the calculations
+   obs.times <- x$t_
+
+   # Calculate temporal differences between observed and new time stamps
+   r1 <- outer(as.numeric(obs.times), as.numeric(new.times),
+               FUN = function(x, y) abs(x - y))
+
+   ids <- apply(r1, 2, which.min)
+   ids.ok <- abs(as.numeric(obs.times[ids]) - as.numeric(new.times)) <= tolerance
+
+   x <- x[ids, c("x_", "y_")]
+   x$t_ <- new.times
+   x$burst_ = ids.ok
+
+   # Remove observations that are off in time
+   rx <- rle(x$burst_)
+
+   # If all false
+   if (all(!rx$values)) {
+     stop("No observed relocations within tolerance of new time stamps.")
+   }
+
+   lt <- rx$lengths[rx$values]
+   x <- x[x$burst_, ]
+   x$burst_ <- rep(1:length(lt), lt)
+
+   if (all(x$burst_)) {
+     x[["burst_"]] <- NULL
+     # make sure track is not bursted
+   } else {
+     # make sure track is bursted
+   }
+
+   x
+
+ }

inst/tinytest/test_track_align.R

@@ -0,0 +1,29 @@
+library(amt)
+library(lubridate)
+
+# Some data
+dat <- data.frame(
+  x = runif(100),
+  y = runif(100),
+  t_ = ymd_hms("1900-01-01 00:00:00") + hours(0:99)
+)
+
+dat <- dat |> make_track(x, y, t_)
+
+
+# Align to every 2 hours
+new.times <- seq(from(dat), to(dat), by = "2 hours")
+tolerance <- 100
+
+expect_equal(
+  nrow(
+    track_align(dat, new.times = new.times, tolerance = tolerance)
+  ), 50)
+
+tolerance <- 10000000
+
+expect_equal(
+  nrow(
+    track_align(dat, new.times = new.times, tolerance = tolerance)
+  ), 50)
+