Adds replace_na functions and classify_low_periods

roaldarbol · roaldarbol · Jan 4, 2025 · Dec 7, 2024 · Dec 12, 2024 · Dec 12, 2024
commit e0589f256287b36d74eafa6f87463c47478b2124
diff --git a/NAMESPACE b/NAMESPACE
@@ -12,7 +12,8 @@ export(check_na_timing)
 export(check_pose)
 export(classify_by_stability)
 export(classify_by_threshold)
-export(classify_peak_periods)
+export(classify_high_periods)
+export(classify_low_periods)
 export(clean_kinematics)
 export(does_file_have_expected_headers)
 export(ensure_file_has_expected_headers)
@@ -48,6 +49,12 @@ export(read_trackball)
 export(read_treadmill)
 export(read_trex)
 export(replace_missing)
+export(replace_na)
+export(replace_na_linear)
+export(replace_na_locf)
+export(replace_na_spline)
+export(replace_na_stine)
+export(replace_na_value)
 export(rotate_coords)
 export(set_framerate)
 export(set_individual)

diff --git a/R/classify_peak_periods.R b/R/classify_peak_periods.R
diff --git a/R/classify_peak_trough.R b/R/classify_peak_trough.R
@@ -0,0 +1,130 @@
+#' Classifies Periods of High Activity in Time Series Using Peaks and Troughs
+#'
+#' @description
+#' Identifies periods of high activity in a time series by analyzing peaks and troughs,
+#' returning a logical vector marking these periods. The function handles special cases
+#' like adjacent peaks and the initial/final sequences.
+#'
+#' @param x numeric vector; the time series values
+#' @param peaks logical vector; same length as x, TRUE indicates peak positions
+#' @param troughs logical vector; same length as x, TRUE indicates trough positions
+#'
+#' @return logical vector; TRUE indicates periods of high activity
+#'
+#' @details
+#' The function performs the following steps:
+#' 1. Resolves adjacent peaks by keeping only the highest
+#' 2. Handles the initial sequence before the first trough
+#' 3. Handles the final sequence after the last event
+#' 4. Identifies regions between troughs containing exactly one peak
+#'
+#' @examples
+#' x <- c(1, 3, 2, 1, 4, 2, 1)
+#' peaks <- c(FALSE, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE)
+#' troughs <- c(FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, TRUE)
+#' classify_high_periods(x, peaks, troughs)
+#'
+#' @export
+classify_high_periods <- function(x, peaks, troughs) {
+  # Input validation
+  if (length(peaks) != length(troughs) || length(x) != length(peaks)) {
+    cli::cli_abort("Lengths of x, peaks, and troughs must match")
+  }
+
+  n <- length(x)
+  result <- logical(n)
+
+  # First handle adjacent peaks - keep only highest
+  peak_indices <- which(peaks)
+  for(i in 1:(length(peak_indices)-1)) {
+    # Look at all peaks until we find a trough
+    for(j in (i+1):length(peak_indices)) {
+      if(any(troughs[peak_indices[i]:peak_indices[j]])) break
+      # Keep highest peak, remove others
+      if(x[peak_indices[i]] <= x[peak_indices[j]]) {
+        peaks[peak_indices[i]] <- FALSE
+        break
+      } else {
+        peaks[peak_indices[j]] <- FALSE
+      }
+    }
+  }
+
+  # Handle start sequence
+  first_event <- min(c(peak_indices[1], trough_indices[1]))
+  result[1:first_event] <- ifelse(first_event == peak_indices[1], TRUE, FALSE)
+
+  # End sequence
+  last_event <- max(c(peak_indices[length(peak_indices)],
+                      trough_indices[length(trough_indices)]))
+  result[last_event:n] <- ifelse(last_event == peak_indices[length(peak_indices)],
+                                 TRUE, FALSE)
+
+  # Find regions between troughs that have exactly one peak
+  for(i in 1:(length(trough_indices)-1)) {
+    current_trough <- trough_indices[i]
+    next_trough <- trough_indices[i+1]
+    peaks_between <- which(peaks[current_trough:next_trough])
+
+    if(length(peaks_between) == 1) {
+      result[(current_trough+1):(next_trough-1)] <- TRUE
+    }
+  }
+
+  return(result)
+}
+
+#' Classifies Periods of Low Activity in Time Series Using Peaks and Troughs
+#'
+#' @description
+#' Identifies periods of low activity in a time series by analyzing peaks and troughs,
+#' returning a logical vector marking these periods. Low activity periods are defined
+#' as regions between consecutive troughs that contain no peaks.
+#'
+#' @param peaks logical vector; TRUE indicates peak positions
+#' @param troughs logical vector; same length as peaks, TRUE indicates trough positions
+#'
+#' @return logical vector; TRUE indicates periods of low activity
+#'
+#' @details
+#' The function performs the following steps:
+#' 1. Validates input lengths
+#' 2. Initializes all periods as potentially low activity (TRUE)
+#' 3. For each pair of consecutive troughs:
+#'    - If no peaks exist between them, maintains TRUE for that period
+#'    - If any peaks exist, marks that period as FALSE (not low activity)
+#'
+#' @examples
+#' peaks <- c(FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE)
+#' troughs <- c(FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, TRUE)
+#' classify_low_periods(peaks, troughs)
+#'
+#' @export
+classify_low_periods <- function(peaks, troughs) {
+  # Input validation
+  if (length(peaks) != length(troughs)) {
+    cli::cli_abort("Lengths of peaks and troughs must match")
+  }
+
+  # Initialize output vector
+  result <- rep(TRUE, length(peaks))
+
+  # Find indices of troughs
+  trough_indices <- which(troughs)
+
+  # For each consecutive pair of troughs
+  for (i in seq_len(length(trough_indices) - 1)) {
+    start_idx <- trough_indices[i]
+    end_idx <- trough_indices[i + 1]
+
+    # Check if there are any peaks between these troughs
+    between_slice <- peaks[(start_idx + 1):(end_idx - 1)]
+
+    if (length(between_slice) > 0 && !any(between_slice)) {
+      # If no peaks between troughs, set those positions to FALSE
+      result[(start_idx + 1):(end_idx - 1)] <- FALSE
+    }
+  }
+
+  return(result)
+}
diff --git a/R/replace_na.R b/R/replace_na.R
@@ -1,3 +1,80 @@
+#' Replace Missing Values Using Various Methods
+#'
+#' @description
+#' A wrapper function that replaces missing values using various interpolation
+#' or filling methods.
+#'
+#' @param x A vector containing numeric data with missing values (NAs)
+#' @param method Character string specifying the replacement method:
+#'   - "linear": Linear interpolation (default)
+#'   - "spline": Spline interpolation for smoother curves
+#'   - "stine": Stineman interpolation preserving data shape
+#'   - "locf": Last observation carried forward
+#'   - "value": Replace with a constant value
+#' @param value Numeric value for replacement when method = "value"
+#' @param min_gap Integer specifying minimum gap size to interpolate/fill. Gaps shorter
+#'   than this will be left as NA. Default is 1 (handle all gaps).
+#' @param max_gap Integer or Inf specifying maximum gap size to interpolate/fill. Gaps longer
+#'   than this will be left as NA. Default is Inf (no upper limit).
+#' @param ... Additional parameters passed to the underlying interpolation functions
+#'
+#' @return A numeric vector with NA values replaced according to the specified method
+#' where gap length criteria are met.
+#'
+#' @examples
+#' \dontrun{
+#' x <- c(1, NA, NA, 4, 5, NA, NA, NA, 9)
+#'
+#' # Different methods
+#' replace_na(x, method = "linear")
+#' replace_na(x, method = "spline")
+#' replace_na(x, method = "stine")
+#' replace_na(x, method = "locf")
+#' replace_na(x, method = "value", value = 0)
+#'
+#' # With gap constraints
+#' replace_na(x, method = "linear", min_gap = 2)
+#' replace_na(x, method = "spline", max_gap = 2)
+#' replace_na(x, method = "linear", min_gap = 2, max_gap = 3)
+#' }
+#'
+#' @seealso
+#' - replace_na_linear() for linear interpolation details
+#' - replace_na_spline() for spline interpolation details
+#' - replace_na_stine() for Stineman interpolation details
+#' - replace_na_locf() for last observation carried forward details
+#' - replace_na_value() for constant value replacement details
+#'
+#' @export
+replace_na <- function(x, method = "linear", value = NULL,
+                       min_gap = 1, max_gap = Inf, ...) {
+  # Input validation
+  if (!is.numeric(x)) {
+    cli::cli_abort("Input must be numeric")
+  }
+
+  valid_methods <- c("linear", "spline", "stine", "locf", "value")
+  method <- match.arg(method, valid_methods)
+
+  # Check if value is provided when needed
+  if (method == "value" && is.null(value)) {
+    cli::cli_abort("value must be specified when method = 'value'")
+  }
+
+  # Dispatch to appropriate method
+  result <- switch(method,
+                   "linear" = replace_na_linear(x, min_gap = min_gap, max_gap = max_gap, ...),
+                   "spline" = replace_na_spline(x, min_gap = min_gap, max_gap = max_gap, ...),
+                   "stine" = replace_na_stine(x, min_gap = min_gap, max_gap = max_gap, ...),
+                   "locf" = replace_na_locf(x, min_gap = min_gap, max_gap = max_gap),
+                   "value" = replace_na_value(x, value = value, min_gap = min_gap, max_gap = max_gap)
+  )
+
+  return(result)
+}
+
+
+
 #' Replace Missing Values in Movement Data
 #'
 #' @description

diff --git a/R/replace_na_linear.R b/R/replace_na_linear.R
@@ -0,0 +1,93 @@
+#' Replace Missing Values Using Linear Interpolation
+#'
+#' @description
+#' Replaces missing values using linear interpolation, with control over both
+#' minimum and maximum gap sizes to interpolate.
+#'
+#' @param x A vector containing numeric data with missing values (NAs)
+#' @param min_gap Integer specifying minimum gap size to interpolate. Gaps shorter
+#'   than this will be left as NA. Default is 1 (interpolate all gaps).
+#' @param max_gap Integer or Inf specifying maximum gap size to interpolate. Gaps longer
+#'   than this will be left as NA. Default is Inf (no upper limit).
+#' @param ... Additional parameters passed to stats::approx
+#'
+#' @return A numeric vector with NA values replaced by interpolated values where
+#' gap length criteria are met.
+#'
+#' @details
+#' The function applies both minimum and maximum gap criteria:
+#' - Gaps shorter than min_gap are left as NA
+#' - Gaps longer than max_gap are left as NA
+#' - Only gaps that meet both criteria are interpolated
+#' If both parameters are specified, min_gap must be less than or equal to max_gap.
+#'
+#' @examples
+#' \dontrun{
+#' x <- c(1, NA, NA, 4, 5, NA, NA, NA, 9)
+#' replace_na_linear(x)  # interpolates all gaps
+#' replace_na_linear(x, min_gap = 2)  # only gaps >= 2
+#' replace_na_linear(x, max_gap = 2)  # only gaps <= 2
+#' replace_na_linear(x, min_gap = 2, max_gap = 3)  # gaps between 2 and 3
+#' }
+#'
+#' @importFrom stats approx
+#' @importFrom methods hasArg
+#' @export
+replace_na_linear <- function(x, min_gap = 1, max_gap = Inf, ...) {
+  # Input validation
+  if (!is.numeric(x)) {
+    cli::cli_abort("Input must be numeric")
+  }
+
+  if (min_gap < 1) {
+    cli::cli_abort("min_gap must be >= 1")
+  }
+
+  if (max_gap < min_gap) {
+    cli::cli_abort("max_gap must be >= min_gap")
+  }
+
+  if (!anyNA(x)) {
+    return(x)
+  }
+
+  if (sum(!is.na(x)) < 2) {
+    cli::cli_warn("At least 2 non-NA data points required for interpolation")
+    return(x)
+  }
+
+  # Get indices
+  n <- length(x)
+  missindx <- is.na(x)
+  allindx <- seq_len(n)
+  indx <- allindx[!missindx]
+
+  # Perform interpolation
+  if (methods::hasArg(rule)) {
+    interp <- stats::approx(indx, x[indx], allindx, ...)$y
+  } else {
+    interp <- stats::approx(indx, x[indx], allindx, rule = 2, ...)$y
+  }
+
+  # Apply gap filtering
+  if (min_gap > 1 || is.finite(max_gap)) {
+    # Get run lengths of NA sequences
+    runs <- rle(is.na(x))
+
+    # Create logical vector for valid gap sizes
+    valid_gaps <- runs$values &
+      runs$lengths >= min_gap &
+      runs$lengths <= max_gap
+
+    # Update runs to only interpolate valid gaps
+    runs$values[runs$values] <- valid_gaps[runs$values]
+    gaps <- inverse.rle(runs)
+
+    # Keep original NAs for invalid gaps
+    interp[!gaps & missindx] <- NA
+  }
+
+  # Replace only the NA values
+  x[missindx] <- interp[missindx]
+  return(x)
+}