lots of improvements

DESCRIPTION

@@ -17,9 +17,11 @@ BugReports: https://github.com/roaldarbol/animovement/issues
 Encoding: UTF-8
 LazyData: true
 Imports: 
+    circular,
     cli,
     collapse,
     dplyr,
+    lifecycle,
     rlang,
     vroom,
     zoo
@@ -35,7 +37,9 @@ Suggests:
     ggplot2,
     patchwork,
     performance,
-    see
+    see,
+    markdown,
+    tidyr
 Config/testthat/edition: 3
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.2

NAMESPACE

@@ -2,6 +2,8 @@
 
 export(calculate_kinematics)
 export(calculate_statistics)
+export(calculate_straightness)
+export(clean_kinematics)
 export(ensure_file_has_expected_headers)
 export(ensure_file_has_headers)
 export(read_animalta)
@@ -18,10 +20,17 @@ export(validate_deeplabcut_csv)
 export(validate_files)
 export(validate_time)
 export(validate_trackball)
+import(circular)
 import(dplyr)
+importFrom(circular,circular)
+importFrom(circular,is.circular)
 importFrom(cli,cli_abort)
 importFrom(collapse,fmean)
+importFrom(collapse,fmedian)
+importFrom(collapse,fsd)
+importFrom(lifecycle,deprecated)
 importFrom(rlang,":=")
 importFrom(rlang,.data)
+importFrom(stringi,stri_rand_strings)
 importFrom(vroom,vroom)
 importFrom(zoo,rollmean)

R/animovement-package.R

@@ -2,6 +2,7 @@
 "_PACKAGE"
 
 ## usethis namespace: start
+#' @importFrom lifecycle deprecated
 #' @importFrom rlang :=
 ## usethis namespace: end
 NULL

R/calculate_kinematics.R

@@ -1,6 +1,8 @@
 #' Calculate kinematics
 #'
 #' @description
+#' `r lifecycle::badge('experimental')`
+#'
 #' Calculate kinematics.
 #'
 #' @param data Data frame
@@ -18,27 +20,80 @@ calculate_kinematics <- function(
   data <- data |>
     dplyr::mutate(dx = .data$x - lag(.data$x),
                   dy = .data$y - lag(.data$y),
-                  dt = .data$time - lag(.data$time))
+                  # dt = .data$time - lag(.data$time)
+                  )
 
   # Find the sampling rate
-  sampling_rate <- round(1 / stats::median(data$dt, na.rm = TRUE))
+  # sampling_rate <- round(1 / stats::median(data$dt, na.rm = TRUE))
 
   # Calculate kinematics
   data <- data |>
-    dplyr::mutate(distance = if_else(.data$dx^2 > 0 & .data$dy^2 > 0, sqrt(.data$dx^2 + .data$dy^2), 0),
-                  v_translation = .data$distance * sampling_rate,
-                  direction = if_else(.data$dx^2 > 0 & .data$dy^2 > 0, atan2(.data$dx, .data$dy), 0),
-                  direction = if_else(.data$dy == 0 | .data$dy == 0, NA, .data$direction),
-                  rotation = .data$direction - lag(.data$direction),
-                  v_rotation = .data$rotation * sampling_rate,
+    dplyr::mutate(distance = calculate_distance(.data$dx, .data$dy),
+                  v_translation = calculate_derivative(.data$distance, 0, .data$time, lag(.data$time)),
+                  a_translation = calculate_derivative(.data$v_translation, lag(.data$v_translation), .data$time, lag(.data$time)),
+                  direction = calculate_direction(.data$dx, .data$dy),
+                  rotation = calculate_angular_difference(.data$direction, lag(.data$direction)),
+                  v_rotation = calculate_derivative(0, .data$rotation, .data$time, lag(.data$time)),
+                  a_rotation = calculate_derivative(.data$v_rotation, lag(.data$v_rotation), .data$time, lag(.data$time)),
                   # We change the directions to stay within 2pi only here, otherwise rotation becomes harder to alculate
-                  direction = if_else(.data$direction < 0, .data$direction + 2*pi, .data$direction), # Keep direction between 0 and 2*pi
-                  direction = zoo::na.locf(.data$direction, na.rm = FALSE),
+                  direction = adjust_direction(.data$direction) # Keep direction between 0 and 2*pi
     )
 
   # Remove leftover columns
   data <- data |>
-    select(-c("dx", "dy", "dt"))
+    select(-c("dx", "dy"))
+    # select(-c("dx", "dy", "dt"))
 
   return(data)
 }
+
+#' Calculate distance (Pythagoras)
+#' Calculate distance from an x and y distance, using Pythagoras theorem.
+#' @param dx dx
+#' @param dy dy
+#' @keywords internal
+calculate_distance <- function(dx, dy){
+  sqrt(dx^2 + dy^2)
+}
+
+#' Calculate direction
+#' Calculate direction (angle) from x and y distance using the (two-argument) arc-tangent. Converts to `circular`.
+#' @inheritParams calculate_distance
+#' @importFrom circular circular
+#' @keywords internal
+calculate_direction <- function(dx, dy){
+  if_else(dx == 0 & dy == 0, NA, circular::circular(atan2(dy, dx), modulo = "asis"))
+}
+
+#' Calculate angular difference
+#' @param from_angle From angle
+#' @param to_angle To angle
+#' @keywords internal
+calculate_angular_difference <- function(from_angle, to_angle){
+  ensure_circular(from_angle)
+  ensure_circular(to_angle)
+  diff_angle <- from_angle - to_angle
+  case_when(diff_angle > pi ~ diff_angle - 2*pi,
+            diff_angle < -pi ~ diff_angle + 2*pi,
+            .default = diff_angle)
+}
+
+#' Calculate the derivative (dx/dt)
+#' Calculate the derivative (dx/dt) with four arguments
+#' @param from_x Current x value
+#' @param to_x Lagging x value
+#' @param from_t Current timestamp
+#' @param to_t Lagging timestamp
+#' @keywords internal
+calculate_derivative <- function(from_x, to_x, from_t, to_t){
+  (from_x - to_x) / (from_t - to_t)
+}
+
+#' Adjust direction
+#' Constrains the direction to be between 0 and 2pi
+#' @param direction Direction
+#' @importFrom circular circular
+#' @keywords internal
+adjust_direction <- function(direction){
+  circular::circular(direction, modulo = "2pi")
+}

R/calculate_statistics.R

@@ -1,42 +1,83 @@
 #' Calculate summary statistics
 #'
 #' @description
+#' `r lifecycle::badge('experimental')`
+#'
 #' Calculate summary statistics for tracks
 #'
 #' @param data A kinematics data frame
-#' @param threshold_velocity Choose which observations to use based on the velocity. A number, "auto" or "none". Can take a number (e.g. estimated from histograms) or "auto". "auto" fits a density function to the velocities and tries to identify a local minimum between the first and second local maxima, and uses that as the threshold. "none" keeps all observations.
-#'
+#' @param measures Measures of central tendency and dispersion. Options are `median_mad` (default) and `mean_sd`. See description for more information.
+#' @param straightness Which method to calculate path straightness. Choose between "A" (default), "B", "C"... or a combination (e.g. "c("A","B")"). See description for details about the different calculations.
 #' @return An data frame data frame with kinematics calculated
 #' @export
 #' @import dplyr
+#' @import circular
+#' @importFrom collapse fmean fmedian fsd
 #' @importFrom rlang :=
 #' @importFrom rlang .data
 #'
 calculate_statistics <- function(
     data,
-    threshold_velocity
+    measures = "median_mad",
+    straightness = c("A", "B", "C", "D")
 ) {
-  # Make some tests to ensure that `calculate_kinematics` has been run first
-
-  # Make sure to remove observations with almost no movement (figure out a robust method for this)
+  validate_statistics()
 
   # Calculate translational and rotational separately (maybe?) and gather at the end
-  data <- data |>
-    dplyr::summarise()
-
-    # dplyr::mutate(distance = sqrt(.data$dx^2 + .data$dy^2),
-    #               v_translation = .data$distance * sampling_rate,
-    #               direction = atan2(.data$dx, .data$dy),
-    #               direction = if_else(.data$dy == 0 | .data$dy == 0, NA, direction),
-    #               direction = if_else(.data$direction < 0, .data$direction + 2*pi, .data$direction), # Keep direction between 0 and 2*pi
-    #               direction = zoo::na.locf(.data$direction, na.rm = FALSE),
-    #               rotation = direction - lag(direction),
-    #               # rotation = dplyr::if_else(abs(.data$dx) > 1 & abs(.data$dy) > 1,
-    #               #                           abs(dplyr::lag(.data$direction) - .data$direction),
-    #               #                           0),
-    #               # rotation = dplyr::if_else(.data$rotation > pi, 2*pi - .data$rotation, .data$rotation),
-    #               v_rotation = .data$rotation * sampling_rate,
-    # )
+  totals <- data |>
+    dplyr::summarise(across(c(.data$distance, .data$rotation), ~ collapse::fsum(abs(.x)), .names = "total_{.col}"),
+                     across(c(.data$x, .data$y), ~ dplyr::last(.x, na_rm = TRUE), .names = "last_{.col}"),
+                     .by = .data$uid)
+
+  totals <- totals |>
+    calculate_straightness(straightness)
+    # dplyr::mutate("straightness_{{ A }} = calculate_straightness(.data$last_x, .data$last_y, .data$total_distance, method = straightness))
+
+
+  if (measures == "median_mad"){
+    data <- data |>
+      dplyr::summarise(across(c(.data$direction), ~ collapse::fmean(circular::circular(.x, modulo = "2pi")), .names = "median_{.col}"),
+                       across(c(.data$direction), ~ calculate_circular_mad(circular::circular(.x, modulo = "2pi")), .names = "mad_{.col}"),
+                       across(c(.data$v_translation, .data$a_translation, .data$v_rotation, .data$a_rotation), ~ collapse::fmedian(abs(.x)), .names = "median_{.col}"),
+                       across(c(.data$v_translation, .data$a_translation, .data$v_rotation, .data$a_rotation), ~ stats::mad(abs(.x), na.rm = TRUE), .names = "mad_{.col}"),
+                       .by = .data$uid
+      ) |>
+      left_join(totals) |>
+      select(-c(last_x, last_y)) |>
+      suppressMessages()
+
+  } else if (measures == "mean_sd"){
+    data <- data |>
+      dplyr::summarise(across(c(.data$direction), ~ collapse::fmean(circular::circular(.x)), .names = "mean_{.col}"),
+                       across(c(.data$direction), ~ circular::sd(circular::circular(.x)), .names = "sd_{.col}"),
+                       across(c(.data$v_translation, .data$a_translation, .data$v_rotation, .data$a_rotation), ~ collapse::fmean(abs(.x)), .names = "mean_{.col}"),
+                       across(c(.data$v_translation, .data$a_translation, .data$v_rotation, .data$a_rotation), ~ collapse::fsd(abs(.x)), .names = "sd_{.col}"),
+                       .by = .data$uid
+      ) |>
+      left_join(totals) |>
+      select(-c(last_x, last_y)) |>
+      suppressMessages()
+  }
 
   return(data)
 }
+
+#' Calculate circular Median Absolute Deviation (MAD)
+#' @param angles Vector of angles
+#' @importFrom circular circular
+#' @importFrom collapse fmedian
+#' @keywords internal
+calculate_circular_mad <- function(angles) {
+  ensure_circular(angles)
+  # Convert angles to circular object
+  angles_circular <- circular::circular(angles, units = "radians")
+
+  # Calculate circular median
+  circular_median <- collapse::fmedian(angles_circular)
+
+  # Compute absolute deviations from the circular median
+  abs_dev <- abs(angles_circular - circular_median)
+
+  # Calculate and return the median absolute deviation
+  collapse::fmedian(abs_dev)
+}

R/calculate_straightness.R

@@ -0,0 +1,57 @@
+#' Calculate straightness measures
+#'
+#' @param data Data frame
+#' @param straightness hich method to calculate path straightness. Choose between "A" (default), "B", "C"... or a combination (e.g. "c("A","B")"). See description for details about the different calculations.
+#'
+#' @keywords internal
+#' @export
+calculate_straightness <- function(data, straightness = c("A", "B", "C", "D")){
+  # Make validator to ensure that x,y,total_translation and total_rotation is present
+
+  data <- data |>
+    dplyr::mutate(straightness_A = calculate_straightness_A(
+      .data$last_x,
+      .data$last_y,
+      .data$total_distance),
+      straightness_B = calculate_straightness_B(
+        .data$last_x,
+        .data$last_y,
+        .data$total_distance),
+      straightness_C = calculate_straightness_C(
+        .data$total_distance,
+        .data$total_rotation),
+      straightness_D = calculate_straightness_D(
+        .data$total_distance,
+        .data$total_rotation)
+    )
+
+  # Only select the methods chosen by the user
+  possible_straightness <- c("A", "B", "C", "D")
+  possible_straightness_columns <- paste("straightness", possible_straightness, sep = "_")
+  straightness_columns <- paste("straightness", straightness, sep = "_")
+  columns_not_selected <- possible_straightness_columns[which(!possible_straightness_columns %in% straightness_columns)]
+  data <- data |>
+    dplyr::select(!all_of(columns_not_selected))
+
+  return(data)
+}
+
+#' @keywords internal
+calculate_straightness_A <- function(x, y, distance){
+  calculate_distance(x, y) / distance
+}
+
+#' @keywords internal
+calculate_straightness_B <- function(x, y, distance){
+  distance / calculate_distance(x, y)
+}
+
+#' @keywords internal
+calculate_straightness_C <- function(distance, rotation){
+  distance / as.numeric(rotation)
+}
+
+#' @keywords internal
+calculate_straightness_D <- function(distance, rotation){
+  as.numeric(rotation) / distance
+}

R/clean_kinematics.R

@@ -0,0 +1,18 @@
+#' Clean kinematics
+#'
+#' @description
+#' `r lifecycle::badge('experimental')`
+#'
+#' @param data
+#'
+#' @return a clean kinematics data frame
+#' @export
+clean_kinematics <- function(data){
+  # Place validators here
+
+  # Proceed to make the cleaning
+  data <- data |>
+    dplyr::filter(.data$direction != atan2(1,0) & .data$direction != atan2(0,1)) |>
+    dplyr::filter(.data$v_translation > 0)
+  return(data)
+}

R/smooth_movement.R → R/clean_movement.R

@@ -1,6 +1,8 @@
 #' Smooth tracks
 #'
 #' @description
+#' `r lifecycle::badge('experimental')`
+#'
 #' Filtering/smoothing tracks is standard practice to root out noise in movement data.
 #' Here we provide some filter functions to do this. The function expects the data to be in the standard format,
 #' containing at least x, y and time variables.

R/read_animalta.R

@@ -1,5 +1,8 @@
 #' Read AnimalTA data
 #'
+#' @description
+#' `r lifecycle::badge('experimental')`
+#'
 #' @param path An AnimalTA data frame
 #'
 #' @return a movement dataframe

R/read_deeplabcut.R

@@ -1,5 +1,8 @@
 #' Read DeepLabCut data
 #'
+#' @description
+#' `r lifecycle::badge('experimental')`
+#'
 #' @param data A DeepLabCut data frame
 #'
 #' @return a movement dataframe

R/read_idtracker.R

@@ -1,5 +1,8 @@
 #' Read idtracker.ai data
 #'
+#' @description
+#' `r lifecycle::badge('experimental')`
+#'
 #' @param data An idtracker.ai data frame
 #'
 #' @return a movement dataframe

R/read_movement.R

@@ -1,5 +1,8 @@
 #' Read movement data
 #'
+#' @description
+#' `r lifecycle::badge('experimental')`
+#'
 #' @param data A movement data frame
 #'
 #' @return a movement dataframe

R/read_sleap.R

@@ -1,5 +1,8 @@
 #' Read SLEAP data
 #'
+#' @description
+#' `r lifecycle::badge('experimental')`
+#'
 #' @param data A SLEAP data frame
 #'
 #' @return a movement dataframe