Customize calls to do.call from do_call

asardaes · Jun 22, 2024 · d0282a1 · d0282a1
1 parent e953830
commit d0282a1
Show file tree

Hide file tree

Showing 3 changed files with 37 additions and 11 deletions.
diff --git a/R/CLUSTERING-compare-clusterings.R b/R/CLUSTERING-compare-clusterings.R
@@ -688,10 +688,11 @@ compare_clusterings <- function(series = NULL, types = c("p", "h", "f", "t"),
             # controls for this configuration
             # ----------------------------------------------------------------------------------
 
-            control_fun <- match.fun(paste0(type, "_control"))
+            control_fun_name <- paste0(type, "_control")
+            control_fun <- match.fun(control_fun_name)
             control_args <- subset_dots(as.list(cfg), control_fun)
             control_args <- lapply(control_args, unlist, recursive = FALSE)
-            control <- do_call(control_fun, control_args)
+            control <- do_call(control_fun_name, control_args)
 
             # ----------------------------------------------------------------------------------
             # get processed series
@@ -982,8 +983,8 @@ compare_clusterings <- function(series = NULL, types = c("p", "h", "f", "t"),
                                f = function(result, cols) {
                                    order_args <- as.list(result[cols])
                                    names(order_args) <- NULL
-                                   .f <- base::order
-                                   result[do_call(".f", order_args), , drop = FALSE]
+                                   base_order <- base::order
+                                   result[do_call("base_order", order_args), , drop = FALSE]
                                })
     # return results
     results

diff --git a/R/CLUSTERING-repeat-clustering.R b/R/CLUSTERING-repeat-clustering.R
@@ -101,16 +101,22 @@ repeat_clustering <- function(series, clusterings, config_id, ...) {
     centroid_char <- args$centroid
     if (centroid_char != "default") {
         if (clus_type %in% c("hierarchical", "tadpole") || !(centroid_char %in% centroids_included)) {
-            centroid <- get_from_callers(centroid_char, "function")
-            args$centroid <- as.name("centroid")
+            args$centroid <- get_from_callers(centroid_char, "function")
+        } else {
+            args$centroid <- centroid_char
         }
     }
     else {
         args$centroid <- NULL
     }
+
     preproc_char <- if (is.null(args$preproc)) "none" else args$preproc
-    preproc <- if (preproc_char == "none") NULL else get_from_callers(preproc_char, "function")
-    args$preproc <- as.name("preproc")
+    if (preproc_char != "none") {
+        args$preproc <- get_from_callers(preproc_char, "function")
+    } else {
+        args$preproc <- NULL
+    }
+
     args$series <- series
     args$type <- clus_type
     args$seed <- seed

diff --git a/R/UTILS-utils.R b/R/UTILS-utils.R
@@ -167,9 +167,28 @@ call_rbind <- function(args) {
     ans
 }
 
-# TODO
-do_call <- function(f, args) {
-    do.call(f, args, envir = parent.frame())
+#' @importFrom rlang as_environment
+#' @importFrom rlang syms
+do_call <- function(f, args, dots = NULL) {
+    args <- c(args, dots)
+    original_names <- tmp_names <- names(args)
+    unnamed <- tmp_names == ""
+
+    if (is.null(original_names)) {
+        tmp_names <- paste0(".arg", seq_along(args))
+        names(args) <- tmp_names
+    }
+    else if (any(unnamed)) {
+        tmp_names[unnamed] <- paste0(".arg", seq_len(sum(unnamed)))
+        names(args) <- tmp_names
+        names(tmp_names) <- original_names
+    }
+    else {
+        names(tmp_names) <- original_names
+    }
+
+    envir <- rlang::as_environment(args, parent.frame())
+    do.call(f, rlang::syms(tmp_names), envir = envir)
 }
 
 # ==================================================================================================