Add callWithData(), moved from kwb.rabimo

also add related helper functions
- expandToVector()
- nDims()
- rbindFirstRows()
- seqAlongRows()
- splitIntoIdenticalRows()

DESCRIPTION

@@ -20,6 +20,8 @@ Description: This package contains some small helper
 License: MIT + file LICENSE
 URL: https://github.com/kwb-r/kwb.utils
 BugReports: https://github.com/kwb-r/kwb.utils/issues
+Imports:
+    methods
 Suggests:
     PKI,
     testthat,
@@ -30,4 +32,4 @@ Suggests:
 VignetteBuilder: 
     knitr
 Encoding: UTF-8
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.1

NAMESPACE

@@ -31,6 +31,7 @@ export(atLeastOneRowIn)
 export(backspace)
 export(breakInSequence)
 export(callWith)
+export(callWithData)
 export(callWithStringsAsFactors)
 export(catAndRun)
 export(catChanges)
@@ -303,4 +304,5 @@ export(warningDeprecated)
 export(windowsPath)
 export(writeDictionary)
 export(writeText)
+importFrom(methods,formalArgs)
 importFrom(utils,capture.output)

NEWS.md

@@ -1,6 +1,7 @@
 # Changes since last release
 
 - add loadFunctions()
+- add callWithData()
 - multiColumnLookup()
   - allow to lookup more than one value column
   - add arguments "drop", "includeKeys" 

R/callWithData.R

@@ -0,0 +1,137 @@
+# callWithData -----------------------------------------------------------------
+
+#' Call a Function with Argument Combinations from a Data Frame
+#'
+#' @param FUN function to be called
+#' @param data data frame with one column per argument of \code{FUN}
+#' @param \dots further (constant) arguments to \code{FUN} that are passed to
+#'   \code{\link{mapply}} via \code{MoreArgs}
+#' @param threshold if the ratio of unique value combinations in the relevant
+#'   columns in data to all value combinations in these columns is below this
+#'   threshold value then FUN will be called only with the unique value
+#'   combinations. This should increase performance.
+#' @param SIMPLIFY passed to\code{\link{mapply}}, default: \code{TRUE}
+#' @param USE.NAMES passed to\code{\link{mapply}}, default: \code{TRUE}
+#' @return vector of length \code{nrow(data)} with the result values returned by
+#'   \code{FUN}
+#' @importFrom methods formalArgs
+#' @export
+#' @examples
+#' combis <- expand.grid(x = 1:2, y = c(10, 20, 30))
+#' combis
+#'
+#' callWithData(`+`, combis)
+callWithData <- function(
+    FUN,
+    data,
+    ...,
+    threshold = 0.5,
+    SIMPLIFY = TRUE,
+    USE.NAMES = TRUE
+)
+{
+  # What arguments does FUN have?
+  all_args <- methods::formalArgs(FUN)
+
+  # Select the columns from data that are arguments of FUN
+  arg_data <- selectColumns(data, intersect(all_args, names(data)))
+
+  # Split arg_data into sets of identical rows
+  sets <- splitIntoIdenticalRows(arg_data)
+
+  # Number of all value combinations
+  n_all <- nrow(arg_data)
+
+  # Number of unique value combinations
+  n_unique <- length(sets)
+
+  # Should we run FUN only for the unique value combinations?
+  run_unique <- (n_unique / n_all < threshold)
+
+  # Name of the function to be called
+  fun_name <- deparse(substitute(FUN))
+
+  # Run FUN for each row of run_data
+  results <- catAndRun(
+    messageText = if (run_unique) {
+      sprintf(
+        "-> Calling %s() for %d unique value combinations",
+        fun_name, n_unique
+      )
+    } else {
+      sprintf(
+        "-> Calling %s() for all %d value combinations",
+        fun_name, n_all
+      )
+    },
+    expr = {
+
+      more_args <- list(...)
+
+      mapply_args_fix <- list(
+        FUN = FUN,
+        MoreArgs = if (length(more_args)) more_args,
+        SIMPLIFY = SIMPLIFY,
+        USE.NAMES = USE.NAMES
+      )
+
+      mapply_args_var <- if (run_unique) {
+        removeColumns(rbindFirstRows(sets), "row.")
+      } else {
+        arg_data
+      }
+
+      do.call(mapply, c(mapply_args_fix, mapply_args_var))
+    }
+  )
+
+  if (!run_unique) {
+    return(results)
+  }
+
+  catAndRun(
+    "-> Expanding the results to the extent of the input",
+    expandToVector(
+      x = results,
+      indices = lapply(sets, selectColumns, "row.")
+    )
+  )
+}
+
+# splitIntoIdenticalRows -------------------------------------------------------
+splitIntoIdenticalRows <- function(data)
+{
+  split(cbind(data, row. = seqAlongRows(data)), f = data, drop = TRUE)
+}
+
+# seqAlongRows ---------------------------------------------------------------
+seqAlongRows <- function(data)
+{
+  seq_len(nrow(data))
+}
+
+# rbindFirstRows ---------------------------------------------------------------
+rbindFirstRows <- function(x)
+{
+  stopifnot(is.list(x), all(sapply(x, nDims) == 2L))
+
+  resetRowNames(do.call(rbind, lapply(x, utils::head, 1L)))
+}
+
+# nDims: number of dimensions --------------------------------------------------
+nDims <- function(x)
+{
+  length(dim(x))
+}
+
+# expandToVector ---------------------------------------------------------------
+expandToVector <- function(x, indices)
+{
+  stopifnot(length(x) == length(indices))
+
+  result <- list()
+
+  result[unlist(indices)] <- rep(x, lengths(indices))
+
+  result
+}

_pkgdown.yml

@@ -345,6 +345,7 @@ reference:
     contents:
       - arglist
       - callWith
+      - callWithData
       - callWithStringsAsFactors
       - getFunctionValueOrDefault
   - title: Cryptographic Functions

tests/testthat/test-function-callWithData.R

@@ -0,0 +1,17 @@
+#
+# This file was generated by kwb.test::create_test_files(), 
+# launched by hsonne on 2024-02-16 08:26:26.874512.
+# Please modify the dummy functions so that real cases are
+# tested. Then, delete this comment.
+#
+
+test_that("callWithData() works", {
+
+  f <- kwb.utils::callWithData
+
+  expect_error(
+    f()
+    # Argument "FUN" fehlt (ohne Standardwert)
+  )
+
+})

tests/testthat/test-function-expandToVector.R

@@ -0,0 +1,17 @@
+#
+# This file was generated by kwb.test::create_test_files(),
+# launched by hsonne on 2024-02-16 08:26:32.982136.
+# Please modify the dummy functions so that real cases are
+# tested. Then, delete this comment.
+#
+
+test_that("expandToVector() works", {
+
+  f <- kwb.utils:::expandToVector
+
+  expect_error(
+    f()
+    # Argument "x" fehlt (ohne Standardwert)
+  )
+
+})

tests/testthat/test-function-nDims.R

@@ -0,0 +1,17 @@
+#
+# This file was generated by kwb.test::create_test_files(),
+# launched by hsonne on 2024-02-16 08:26:32.982136.
+# Please modify the dummy functions so that real cases are
+# tested. Then, delete this comment.
+#
+
+test_that("nDims() works", {
+
+  f <- kwb.utils:::nDims
+
+  expect_error(
+    f()
+    # Argument "x" fehlt (ohne Standardwert)
+  )
+
+})

tests/testthat/test-function-rbind_first_rows.R

@@ -0,0 +1,17 @@
+#
+# This file was generated by kwb.test::create_test_files(),
+# launched by hsonne on 2024-02-16 08:26:32.982136.
+# Please modify the dummy functions so that real cases are
+# tested. Then, delete this comment.
+#
+
+test_that("rbindFirstRows() works", {
+
+  f <- kwb.utils:::rbindFirstRows
+
+  expect_error(
+    f()
+    # Argument "x" fehlt (ohne Standardwert)
+  )
+
+})

tests/testthat/test-function-seqAlongRows.R

@@ -0,0 +1,17 @@
+#
+# This file was generated by kwb.test::create_test_files(),
+# launched by hsonne on 2024-02-16 08:26:32.982136.
+# Please modify the dummy functions so that real cases are
+# tested. Then, delete this comment.
+#
+
+test_that("seqAlongRows() works", {
+
+  f <- kwb.utils:::seqAlongRows
+
+  expect_error(
+    f()
+    # Argument "data" fehlt (ohne Standardwert)
+  )
+
+})

tests/testthat/test-function-splitIntoIdenticalRows.R

@@ -0,0 +1,17 @@
+#
+# This file was generated by kwb.test::create_test_files(), 
+# launched by hsonne on 2024-02-16 08:26:32.982136.
+# Please modify the dummy functions so that real cases are
+# tested. Then, delete this comment.
+#
+
+test_that("splitIntoIdenticalRows() works", {
+
+  f <- kwb.utils:::splitIntoIdenticalRows
+
+  expect_error(
+    f()
+    # Argument "data" fehlt (ohne Standardwert)
+  )
+
+})