Add tween_at_t()

DESCRIPTION

@@ -26,7 +26,7 @@ Imports:
     vctrs
 LinkingTo: 
     cpp11 (>= 0.4.2)
-RoxygenNote: 7.2.1
+RoxygenNote: 7.2.3
 Roxygen: list(markdown=TRUE)
 Suggests: testthat,
     covr

NAMESPACE

@@ -62,6 +62,7 @@ export(tween)
 export(tween_along)
 export(tween_appear)
 export(tween_at)
+export(tween_at_t)
 export(tween_color)
 export(tween_color_t)
 export(tween_colour)

NEWS.md

@@ -1,6 +1,7 @@
 # tweenr (development version)
 
 * Fix coercion bug from the switch to vctrs
+* At `tween_at_t()` for interpolating a full data frame at multiple locations
 
 # tweenr 2.0.2
 

R/cpp11.R

@@ -44,28 +44,24 @@ numlist_at_interpolator <- function(from, to, at, ease) {
   .Call(`_tweenr_numlist_at_interpolator`, from, to, at, ease)
 }
 
-numeric_element_at_interpolator <- function(data, group, time, at, ease) {
-  .Call(`_tweenr_numeric_element_at_interpolator`, data, group, time, at, ease)
+numeric_at_t_interpolator <- function(from, to, at, ease) {
+  .Call(`_tweenr_numeric_at_t_interpolator`, from, to, at, ease)
 }
 
-colour_element_at_interpolator <- function(data, group, time, at, ease) {
-  .Call(`_tweenr_colour_element_at_interpolator`, data, group, time, at, ease)
+colour_at_t_interpolator <- function(from, to, at, ease) {
+  .Call(`_tweenr_colour_at_t_interpolator`, from, to, at, ease)
 }
 
-constant_element_at_interpolator <- function(data, group, time, at, ease) {
-  .Call(`_tweenr_constant_element_at_interpolator`, data, group, time, at, ease)
+constant_at_t_interpolator <- function(from, to, at, ease) {
+  .Call(`_tweenr_constant_at_t_interpolator`, from, to, at, ease)
 }
 
-list_element_at_interpolator <- function(data, group, time, at, ease) {
-  .Call(`_tweenr_list_element_at_interpolator`, data, group, time, at, ease)
+list_at_t_interpolator <- function(from, to, at, ease) {
+  .Call(`_tweenr_list_at_t_interpolator`, from, to, at, ease)
 }
 
-numlist_element_at_interpolator <- function(data, group, time, at, ease) {
-  .Call(`_tweenr_numlist_element_at_interpolator`, data, group, time, at, ease)
-}
-
-phase_element_at_interpolator <- function(data, group, time, at, ease) {
-  .Call(`_tweenr_phase_element_at_interpolator`, data, group, time, at, ease)
+numlist_at_t_interpolator <- function(from, to, at, ease) {
+  .Call(`_tweenr_numlist_at_t_interpolator`, from, to, at, ease)
 }
 
 numeric_element_interpolator <- function(data, group, frame, ease) {
@@ -92,6 +88,30 @@ phase_element_interpolator <- function(data, group, frame, ease) {
   .Call(`_tweenr_phase_element_interpolator`, data, group, frame, ease)
 }
 
+numeric_element_at_interpolator <- function(data, group, time, at, ease) {
+  .Call(`_tweenr_numeric_element_at_interpolator`, data, group, time, at, ease)
+}
+
+colour_element_at_interpolator <- function(data, group, time, at, ease) {
+  .Call(`_tweenr_colour_element_at_interpolator`, data, group, time, at, ease)
+}
+
+constant_element_at_interpolator <- function(data, group, time, at, ease) {
+  .Call(`_tweenr_constant_element_at_interpolator`, data, group, time, at, ease)
+}
+
+list_element_at_interpolator <- function(data, group, time, at, ease) {
+  .Call(`_tweenr_list_element_at_interpolator`, data, group, time, at, ease)
+}
+
+numlist_element_at_interpolator <- function(data, group, time, at, ease) {
+  .Call(`_tweenr_numlist_element_at_interpolator`, data, group, time, at, ease)
+}
+
+phase_element_at_interpolator <- function(data, group, time, at, ease) {
+  .Call(`_tweenr_phase_element_at_interpolator`, data, group, time, at, ease)
+}
+
 numeric_fill_interpolator <- function(data, ease) {
   .Call(`_tweenr_numeric_fill_interpolator`, data, ease)
 }

R/interpolate_at.R

@@ -52,3 +52,58 @@ interpolate_numlist_at <- function(from, to, at, ease) {
   attributes(data) <- attributes(from)
   data
 }
+
+interpolate_numeric_at_t <- function(from, to, at, ease) {
+  numeric_at_t_interpolator(as.numeric(from), as.numeric(to), as.numeric(at), as.character(ease))
+}
+
+interpolate_logical_at_t <- function(from, to, at, ease) {
+  as.logical(round(interpolate_numeric_at_t(from, to, at, ease)))
+}
+
+#' @importFrom farver decode_colour encode_colour
+interpolate_colour_at_t <- function(from, to, at, ease) {
+  from <- decode_colour(from, alpha = TRUE, to = 'lab')
+  to <- decode_colour(to, alpha = TRUE, to = 'lab')
+  data <- colour_at_t_interpolator(from, to, as.numeric(at), as.character(ease))
+  encode_colour(data[, 1:3, drop = FALSE], alpha = data[,4], from = 'lab')
+}
+
+interpolate_constant_at_t <- function(from, to, at, ease) {
+  constant_at_t_interpolator(as.character(from), as.character(to), as.numeric(at), as.character(ease))
+}
+
+interpolate_character_at_t <- interpolate_constant_at_t
+
+interpolate_date_at_t <- function(from, to, at, ease) {
+  data <- interpolate_numeric_at(from, to, at, ease)
+  as.Date(data, origin = BASEDATE)
+}
+
+interpolate_datetime_at_t <- function(from, to, at, ease) {
+  if (inherits(from, 'POSIXlt')) {
+    warning("POSIXlt converted to POSIXct")
+    from <- as.POSIXct(from)
+  }
+  tz <- attr(from, 'tzone')
+  data <- interpolate_numeric_at(from, to, at, ease)
+  as.POSIXct(data, origin = BASEDATETIME, tz = tz)
+}
+
+interpolate_factor_at_t <- function(from, to, at, ease) {
+  all_levels <- unique(c(levels(from), levels(to)))
+  data <- interpolate_constant_at(from, to, at, ease)
+  if (is.ordered(from)) ordered(data, all_levels) else factor(data, all_levels)
+}
+
+interpolate_list_at_t <- function(from, to, at, ease) {
+  data <- list_at_t_interpolator(as.list(from), as.list(to), as.numeric(at), as.character(ease))
+  attributes(data) <- attributes(from)
+  data
+}
+
+interpolate_numlist_at_t <- function(from, to, at, ease) {
+  data <- numlist_at_t_interpolator(lapply(from, as.numeric), lapply(to, as.numeric), as.numeric(at), as.character(ease))
+  attributes(data) <- attributes(from)
+  data
+}

R/tween_at.R

@@ -77,3 +77,92 @@ tween_at <- function(from, to, at, ease) {
 
   structure(tweendata, names = names(from), row.names = .set_row_names(length(tweendata[[1]])), class = 'data.frame')
 }
+#' Get several specific position between two states
+#'
+#' This tween is a variation of [tween_at()]. Instead of having `at` refer to
+#' the tweening position of each row, each `at` will interpolate the full data
+#' at that position.
+#'
+#' @param from,to A data.frame or vector of the same type. If either is of
+#' length/nrow 1 it will get repeated to match the length of the other
+#' @param at A numeric vector with values between 0 and 1.
+#' @param ease A character vector giving valid easing functions. Recycled to
+#' match the ncol of `from`
+#'
+#' @return If `from`/`to` is a data.frame then a data.frame with the same
+#' columns. If `from`/`to` is a vector then a vector.
+#'
+#' @export
+#'
+#' @examples
+#' tween_at_t(mtcars[1:6, ], mtcars[6:1, ], runif(3), 'cubic-in-out')
+#'
+tween_at_t <- function(from, to, at, ease) {
+  single_vec <- !is.data.frame(from)
+  if (single_vec) {
+    if (length(from) == 0 || length(to) == 0) return(to[integer()])
+    from_df <- data.frame(data = rep(NA, length(from)))
+    to_df <- data.frame(data = rep(NA, length(to)))
+    from_df$data <- from
+    to_df$data <- to
+    from <- from_df
+    to <- to_df
+  } else {
+    if (nrow(from) == 0 || nrow(to) == 0) return(to[integer(), ])
+  }
+  if (length(at) == 0) stop('at must have length > 0', call. = FALSE)
+  if (nrow(from) == 1) from <- from[rep(1, nrow(to)), , drop = FALSE]
+  if (nrow(to) == 1) to <- to[rep(1, nrow(from)), , drop = FALSE]
+  if (nrow(from) != nrow(to)) {
+    stop('from and to must be same length', call. = FALSE)
+  }
+  if (any(names(from) != names(to))) {
+    stop('`from` and `to` must have the same columns', call. = FALSE)
+  }
+  ease <- rep(ease, length.out = ncol(from))
+  classes <- col_classes(from)
+  to_classes <- col_classes(to)
+  mismatch <- to_classes != classes
+  for (i in which(mismatch)) {
+    all_na_to <- all(is.na(to[[i]]))
+    all_na_from <- all(is.na(from[[i]]))
+    if (all_na_from) {
+      storage.mode(from[[i]]) <- storage.mode(to[[i]])
+    } else if (all_na_to) {
+      storage.mode(to[[i]]) <- storage.mode(from[[i]])
+    } else {
+      stop('The ', names(to)[i], 'column differs in type between the two inputs', call. = FALSE)
+    }
+  }
+  tweendata <- lapply(seq_along(classes), function(i) {
+    switch(
+      classes[i],
+      numeric = interpolate_numeric_at_t(from[[i]], to[[i]], at, ease[i]),
+      logical = interpolate_logical_at_t(from[[i]], to[[i]], at, ease[i]),
+      factor = interpolate_factor_at_t(from[[i]], to[[i]], at, ease[i]),
+      character = interpolate_character_at_t(from[[i]], to[[i]], at, ease[i]),
+      colour = interpolate_colour_at_t(from[[i]], to[[i]], at, ease[i]),
+      date = interpolate_date_at_t(from[[i]], to[[i]], at, ease[i]),
+      datetime = interpolate_datetime_at_t(from[[i]], to[[i]], at, ease[i]),
+      constant = interpolate_constant_at_t(from[[i]], to[[i]], at, ease[i]),
+      numlist = interpolate_numlist_at_t(from[[i]], to[[i]], at, ease[i]),
+      list = interpolate_list_at_t(from[[i]], to[[i]], at, ease[i]),
+      phase = interpolate_phase_at_t(from[[i]], to[[i]], at)
+    )
+  })
+  if (single_vec) return(tweendata[[1]])
+
+  tweendata$.frame <- rep(seq_along(at), each = length(tweendata[[1]]))
+
+  structure(tweendata, names = names(from), row.names = .set_row_names(length(tweendata[[1]])), class = 'data.frame')
+}
+
+interpolate_phase_at_t <- function(from, to, at) {
+  phase <- rep(ifelse(from == "enter", "enter", ifelse(to == "exit", "exit", "transition")), times = length(at))
+  start_or_end <- at %in% c(0, 1)
+  if (any(start_or_end)) {
+    start_or_end <- rep(start_or_end, each = length(from))
+    phase[phase == "transition" & start_or_end] <- "raw"
+  }
+  phase
+}

src/at.cpp

@@ -87,3 +87,102 @@ cpp11::list numlist_at_interpolator(cpp11::list_of<cpp11::doubles> from, cpp11::
 
   return res;
 }
+
+[[cpp11::register]]
+cpp11::doubles numeric_at_t_interpolator(cpp11::doubles from, cpp11::doubles to,
+                                         cpp11::doubles at, cpp11::strings ease) {
+  R_xlen_t n = from.size();
+  R_xlen_t m = at.size();
+  std::string easer = ease[0];
+  cpp11::writable::doubles res;
+
+  for (R_xlen_t j = 0; j < m; ++j) {
+    double pos = ease_pos(at[j], easer);
+    for (R_xlen_t i = 0; i < n; ++i) {
+      res.push_back(from[i] + (to[i] - from[i]) * pos);
+    }
+  }
+
+  return res;
+}
+[[cpp11::register]]
+cpp11::doubles_matrix<> colour_at_t_interpolator(cpp11::doubles_matrix<> from, cpp11::doubles_matrix<> to,
+                                                 cpp11::doubles at, cpp11::strings ease) {
+  R_xlen_t n = from.nrow(), nn = from.ncol();
+  R_xlen_t m = at.size();
+  std::string easer = ease[0];
+  cpp11::writable::doubles_matrix<> res(n*m, nn);
+
+  for (R_xlen_t j = 0; j < m; ++j) {
+    double pos = ease_pos(at[j], easer);
+    for (R_xlen_t i = 0; i < n; ++i) {
+      for (R_xlen_t k = 0; k < nn; ++k) {
+        res(i, k) = from(i, k) + (to(i, k) - from(i, k)) * pos;
+      }
+    }
+  }
+
+  return res;
+}
+[[cpp11::register]]
+cpp11::strings constant_at_t_interpolator(cpp11::strings from, cpp11::strings to,
+                                          cpp11::doubles at, cpp11::strings ease) {
+  R_xlen_t n = from.size();
+  R_xlen_t m = at.size();
+  std::string easer = ease[0];
+  cpp11::writable::strings res;
+
+  for (R_xlen_t j = 0; j < m; ++j) {
+    double pos = ease_pos(at[j], easer);
+    for (R_xlen_t i = 0; i < n; ++i) {
+      res.push_back(pos < 0.5 ? from[i] : to[i]);
+    }
+  }
+
+  return res;
+}
+[[cpp11::register]]
+cpp11::list list_at_t_interpolator(cpp11::list from, cpp11::list to,
+                                   cpp11::doubles at, cpp11::strings ease) {
+  R_xlen_t n = from.size();
+  R_xlen_t m = at.size();
+  std::string easer = ease[0];
+  cpp11::writable::list res;
+
+  for (R_xlen_t j = 0; j < m; ++j) {
+    double pos = ease_pos(at[j], easer);
+    for (R_xlen_t i = 0; i < n; ++i) {
+      res.push_back(pos < 0.5 ? from[i] : to[i]);
+    }
+  }
+
+  return res;
+}
+[[cpp11::register]]
+cpp11::list numlist_at_t_interpolator(cpp11::list_of<cpp11::doubles> from, cpp11::list_of<cpp11::doubles> to,
+                                      cpp11::doubles at, cpp11::strings ease) {
+  R_xlen_t n = from.size();
+  R_xlen_t m = at.size();
+  std::string easer = ease[0];
+  cpp11::writable::list res;
+
+  std::vector<cpp11::doubles> aligned_from, aligned_to;
+
+  for (R_xlen_t i = 0; i < n; ++i) {
+    aligned_from.push_back(align_num_elem(from[i], to[i]));
+    aligned_to.push_back(align_num_elem(to[i], aligned_from.back()));
+  }
+
+  for (R_xlen_t j = 0; j < m; ++j) {
+    double pos = ease_pos(at[j], easer);
+    for (R_xlen_t i = 0; i < n; ++i) {
+      cpp11::writable::doubles state_vec(aligned_from[i].size());
+      for (R_xlen_t k = 0; k < aligned_from[i].size(); ++k) {
+        state_vec[k] = aligned_from[i][k] + pos * (aligned_to[i][k] - aligned_from[i][k]);
+      }
+      res.push_back(state_vec);
+    }
+  }
+
+  return res;
+}