diff --git a/R/align_move.R b/R/align_move.R index b4ee79e..2aa50c8 100644 --- a/R/align_move.R +++ b/R/align_move.R @@ -152,10 +152,10 @@ align_move <- function(m, res = "minimum", start_end_time = NULL, fill_na_values # assemble sf object m_aligned <- lapply(1:length(m_tracks), function(i) st_sf( - interpolated = c(rep(FALSE, nrow(m_tracks[[i]])), rep(TRUE, length(m_aligned[[i]]))), + interpolated = TRUE, track = names(m_tracks)[i], - timestamp = c(mt_time(m_tracks[[i]]), times_target[[i]]), - geometry = c(st_geometry(m_tracks[[i]]), m_aligned[[i]]) + timestamp = times_target[[i]], + geometry = m_aligned[[i]] )) m_aligned <- do.call(rbind, m_aligned) colnames(m_aligned) <- c("interpolated", mt_track_id_column(m), mt_time_column(m), attr(m, "sf_column")) @@ -181,41 +181,24 @@ align_move <- function(m, res = "minimum", start_end_time = NULL, fill_na_values m_aligned <- m_aligned[order(m_aligned$timestamp),] m_aligned <- m_aligned[order(mt_track_id(m_aligned)),] - # fill variables - if(isTRUE(fill_na_values)){ - m_aligend_filled <- lapply(split(m_aligned, mt_track_id(m_aligned)), function(m_track){ - for(x in names_attr){ - this_attr <- m_track[[x]] - - m_track[[x]] <- sapply(1:length(this_attr), function(i){ - if(!is.na(this_attr[i])){ - this_attr[i] - } else{ - left <- if(i == 1) NULL else 1:(i-1) - right <- if(i == length(this_attr)) NULL else (i+1):length(this_attr) - - if(!is.null(left)){ - non_na <- left[which(!is.na(this_attr[left]))[1]] - } else non_na <- NULL - if(!is.null(right)){ - non_na <- c(non_na, right[which(!is.na(this_attr[right]))[1]]) - } - - non_na_diff <- abs(sapply(non_na, function(.non_na){ - difftime( - m_track[[mt_time_column(m_track)]][.non_na], - m_track[[mt_time_column(m_track)]][i], - units = "secs" - ) - })) - - this_attr[non_na[which.min(non_na_diff)]] - } - }) + if (isTRUE(fill_na_values) && length(names_attr) > 0) { + m_aligned_filled <- split(m_aligned, mt_track_id(m_aligned)) + + # Split by track to avoid interpolating values across tracks + for (i in seq(1, length(m_aligned_filled))) { + for (att in names_attr) { + # Identify closest timestamps for each missing record + idx <- nearest_time_idx( + m_aligned_filled[[i]][[att]], + mt_time(m_aligned_filled[[i]]) + ) + + x <- m_aligned_filled[[i]][[att]] + m_aligned_filled[[i]][[att]][is.na(x)] <- x[!is.na(x)][idx] } - return(m_track) - }) - m_aligned <- do.call(rbind, m_aligend_filled) + } + + m_aligned <- do.call(rbind, m_aligned_filled) } # for now, we just return the aligned data @@ -223,4 +206,20 @@ align_move <- function(m, res = "minimum", start_end_time = NULL, fill_na_values m_aligned$interpolated <- NULL return(m_aligned) +} + +# Helper to identify index position of the temporally closest filled records +# using an input vector `x` with values to use for interpolation (and `NA` +# values at locations that need interpolation) and an input timestamp vector +# `time` that is used to identify the closest temporal records in `x`. +nearest_time_idx <- function(x, time) { + stopifnot(length(x) == length(time)) + non_na <- !is.na(x) + if (all(non_na) || all(!non_na)) return(x) + + # numeric representation of time for distance comparisons + time <- as.numeric(time) + time_non_na <- time[non_na] + + sapply(time[!non_na], function(t) which.min(abs(time_non_na - t))) } \ No newline at end of file diff --git a/tests/testthat/test-align_move.R b/tests/testthat/test-align_move.R index 506ceed..ca3291e 100644 --- a/tests/testthat/test-align_move.R +++ b/tests/testthat/test-align_move.R @@ -33,3 +33,21 @@ test_that("align_move (default)", { expect_warning(align_move(m, digit = "max", verbose = F)) }) #} + +test_that("Fill most proximate value when `fill_na_vals = TRUE`", { + m <- move_data + m[["x"]] <- sample(100, size = nrow(m), replace = TRUE) + + a <- align_move(m, res = units::set_units(2, "min"), verbose = FALSE) + + # Check each track separately, as timestamps should not be matched + # for interpolation across tracks. Each interpolated value in `a` should + # match the value in `m` where the min timestamp criterion is met + for (track in unique(a$track)) { + a1 <- move2::filter_track_data(a, .track_id = track) + m1 <- move2::filter_track_data(m, .track_id = track) + + idx <- sapply(a1$timestamp, function(x) which.min(abs(x - m1$timestamp))) + expect_equal(a1$x, m1$x[idx]) + } +})