Merge pull request #15 from topepo/mapping

data conversion methods and Savitzky-Golay filter

DESCRIPTION

@@ -26,6 +26,7 @@ Suggests:
     covr,
     knitr,
     modeldata,
+    prospectr,
     rmarkdown,
     roxygen2,
     testthat (>= 3.0.0),
@@ -38,4 +39,4 @@ Config/testthat/edition: 3
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.2.3.9000

NAMESPACE

@@ -1,26 +1,34 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(bake,step_baseline)
 S3method(bake,step_measure_input_long)
 S3method(bake,step_measure_input_wide)
 S3method(bake,step_measure_output_long)
 S3method(bake,step_measure_output_wide)
+S3method(bake,step_measure_savitzky_golay)
+S3method(prep,step_baseline)
 S3method(prep,step_measure_input_long)
 S3method(prep,step_measure_input_wide)
 S3method(prep,step_measure_output_long)
 S3method(prep,step_measure_output_wide)
+S3method(prep,step_measure_savitzky_golay)
 S3method(print,step_baseline)
 S3method(print,step_measure_input_long)
 S3method(print,step_measure_input_wide)
 S3method(print,step_measure_output_long)
 S3method(print,step_measure_output_wide)
+S3method(print,step_measure_savitzky_golay)
+S3method(required_pkgs,step_isomap)
 S3method(tidy,step_measure_input_long)
 S3method(tidy,step_measure_input_wide)
 S3method(tidy,step_measure_output_long)
 S3method(tidy,step_measure_output_wide)
+S3method(tidy,step_measure_savitzky_golay)
 export(step_measure_input_long)
 export(step_measure_input_wide)
 export(step_measure_output_long)
 export(step_measure_output_wide)
+export(step_measure_savitzky_golay)
 export(subtract_rf_baseline)
 import(recipes)
 import(rlang)

R/baseline.R

@@ -41,6 +41,7 @@ step_baseline_new <-
     )
   }
 
+#' @export
 prep.step_baseline <- function(x, training, info = NULL, ...) {
   col_names <- recipes::recipes_eval_select(x$terms, training, info)
   recipes::check_type(x, quant = TRUE)
@@ -84,6 +85,7 @@ subtract_rf_baseline <- function(data, yvar, span = 2/3, maxit = c(5, 5)){
     )
 }
 
+#' @export
 bake.step_baseline <- function(object, new_data, ...) {
   cli::cli_alert_danger("Not yet implemented.")
 }

R/checks.R

@@ -16,3 +16,18 @@ check_single_selector <- function(res, arg) {
     rlang::abort(msg)
   }
 }
+
+check_measure_dims <- function(x) {
+  num_rows <- purrr::map_int(x$.measures, nrow)
+  num_unique <- sort(table(num_rows), decreasing = TRUE)
+  most_freq <- as.integer(names(num_unique)[1])
+  if (length(num_unique) != 1) {
+    which_rows <- which(num_rows != most_freq)
+    n_bad <- length(which_rows)
+    chr_rows <- paste(which_rows, collapse = ", ")
+    cli::cli_abort("The number of rows in each measure should be the same.
+                   Most samples have {most_freq} rows and these do not:
+                   {chr_rows}. Please pad the input with missing values.")
+  }
+  invisible(NULL)
+}

R/helpers.R

@@ -13,6 +13,52 @@ add_location <- function(.data, loc) {
   )
 }
 
+# ------------------------------------------------------------------------------
+# Move between lists of tibbles and matrices (and back)
+# Assumes identical locations. We have code to check that the per-sample
+# dimensions are equal but nothing yet for identical locations.
+
+measure_to_matrix <- function(x) {
+  res <- do.call("rbind", purrr::map(x, ~ .x[["value"]]))
+  res
+}
+
+matrix_to_measure <- function(x, loc) {
+  # x is {num_samples} x {num_features}
+  # We need to convert this to a list of length {num_samples}.
+  # Each list element is a tibble that is {num_features} x 2
+  if (!is.matrix(x)) {
+    cli::cli_abort("Input should be a matrix.")
+  }
+  if (length(loc) != ncol(x)) {
+    cli::cli_abort("# locations should be the same at the number of columns in the source matrix.")
+  }
+
+  x <- t(x)
+  x <-  tibble::as_tibble(x, .name_repair = "minimal")
+
+  res <- purrr::map(x, ~ tibble::new_tibble(list(location = loc, value = .x)))
+  unname(res)
+}
+
+measure_to_tibble <- function(x) {
+  x <-
+    tibble::tibble(x = x, sample_num = seq_along(x)) %>%
+    tidyr::unnest(cols = x)
+  x
+}
+
+# ------------------------------------------------------------------------------
+
+check_for_measure <- function(x) {
+  if (!any(names(x) == ".measures")) {
+    cli::cli_abort("A column called {.code .measures} should be in the data. See
+                    {.fn step_measure_input_wide} and
+                    {.fn step_measure_input_long}.")
+  }
+  invisible(NULL)
+}
+
 # ------------------------------------------------------------------------------
 # Make sue that data are in the correct format.
 

R/input_long.R

@@ -31,6 +31,13 @@
 #' rows. We advise having a column with 7 unique values indicating which of the
 #' rows correspond to each sample.
 #'
+#' # Missing Data
+#'
+#' Currently, \pkg{measure} assumes that there are equal numbers of values
+#' within a sample. If there are missing values in the measurements, you'll
+#' need to pad them with missing values (as opposed to an absent row in the
+#' long format). If not, an error will occur.
+#'
 #' # Tidying
 #'
 #' When you [`tidy()`][tidy.recipe()] this step, a tibble indicating which of
@@ -118,6 +125,8 @@ bake.step_measure_input_long <- function(object, new_data, ...) {
       tidyr::nest(.by = c(-value), .key = ".measures")
   }
 
+  check_measure_dims(new_data)
+
   new_data
 }
 
@@ -129,6 +138,8 @@ print.step_measure_input_long <-
     invisible(x)
   }
 
+#' Tidiers for measure steps
+#' @param x A recipe step.
 #' @rdname tidy.recipe
 #' @export
 tidy.step_measure_input_long <- function(x, ...) {

R/input_wide.R

@@ -173,6 +173,7 @@ wide_to_list <- function(x, ind, selections) {
     ) %>%
     dplyr::select(-temp) %>%
     # TODO convert some of this to use vctrs
+    # https://www.tidyverse.org/blog/2023/04/performant-packages/#nest
     tidyr::nest(.by = c(-value), .key = ".measures") %>%
     dplyr::select(-..row) %>%
     add_location(ind)