Merge pull request #73 from asardaes/feature/rlang

Sanitize internal usage of do.call

.github/workflows/check-non-master.yaml

@@ -1,9 +1,4 @@
-# For help debugging build failures open an issue on the RStudio community with the 'github-actions' tag.
-# https://community.rstudio.com/new-topic?category=Package%20development&tags=github-actions
 on:
-  push:
-    branches-ignore:
-      - master
   pull_request:
     branches:
       - master

CHANGELOG.md

@@ -1,7 +1,8 @@
 # Changelog
 
-## Version master
+## Version 5.6.0
 * Update Makevars for ARM version of Windows.
+* Sanitize internal usage of `do.call` to avoid huge backtraces.
 
 ## Version 5.5.12
 * Remove explicit C++ requirements.

DESCRIPTION

@@ -47,7 +47,7 @@ Suggests:
     knitr,
     rmarkdown,
     testthat
-Date: 2023-02-28
+Date: 2024-06-22
 Author: Alexis Sarda-Espinosa
 Maintainer: Alexis Sarda <[email protected]>
 BugReports: https://github.com/asardaes/dtwclust/issues

NAMESPACE

@@ -122,7 +122,17 @@ importFrom(parallel,splitIndices)
 importFrom(proxy,dist)
 importFrom(proxy,pr_DB)
 importFrom(reshape2,melt)
+importFrom(rlang,"!!!")
 importFrom(rlang,.data)
+importFrom(rlang,as_environment)
+importFrom(rlang,as_string)
+importFrom(rlang,enexpr)
+importFrom(rlang,enexprs)
+importFrom(rlang,env_bind)
+importFrom(rlang,exprs)
+importFrom(rlang,is_call)
+importFrom(rlang,list2)
+importFrom(rlang,syms)
 importFrom(shiny,runApp)
 importFrom(shiny,shinyApp)
 importFrom(shinyjs,useShinyjs)

R/CENTROIDS-pam.R

@@ -3,6 +3,7 @@
 #' Extract the medoid time series based on a distance measure.
 #'
 #' @export
+#' @importFrom rlang exprs
 #' @importFrom Matrix rowSums
 #'
 #' @param series The time series in one of the formats accepted by [tslist()].
@@ -42,7 +43,7 @@ pam_cent <- function(series, distance, ids = seq_along(series), distmat = NULL,
         if (missing(distance))
             distance <- attr(distmat, "method")
 
-        args <- list(
+        args <- rlang::exprs(
             distmat = distmat,
             series = series,
             dist_args = dots,
@@ -59,7 +60,7 @@ pam_cent <- function(series, distance, ids = seq_along(series), distmat = NULL,
         }
 
         # S4-Distmat.R
-        distmat <- do.call(Distmat$new, args, TRUE)
+        distmat <- do.call(Distmat$new, args)
     }
 
     d <- distmat[ids, ids, drop = FALSE]

R/CENTROIDS-shape-extraction.R

@@ -73,7 +73,7 @@ shape_extraction <- function(X, centroid = NULL, znorm = FALSE, ..., error.check
         new_c <- Map(mv$series, mv$cent, f = function(xx, cc, ...) {
             new_c <- shape_extraction(xx, cc, znorm = znorm, ..., error.check = FALSE)
         })
-        return(do.call(cbind, new_c, TRUE))
+        return(call_cbind(new_c))
     }
 
     Xz <- if (znorm) zscore(X, ..., error.check = FALSE) else X
@@ -87,18 +87,18 @@ shape_extraction <- function(X, centroid = NULL, znorm = FALSE, ..., error.check
 
     if (is.null(centroid)) {
         if (!different_lengths(Xz)) {
-            A <- do.call(rbind, Xz, TRUE) # use all
+            A <- call_rbind(Xz) # use all
         }
         else {
             centroid <- Xz[[sample(length(Xz), 1L)]] # random choice as reference
             A <- lapply(Xz, function(a) { SBD(centroid, a)$yshift })
-            A <- do.call(rbind, A, TRUE)
+            A <- call_rbind(A)
         }
     }
     else {
         centroid <- zscore(centroid, ..., error.check = FALSE) # use given reference
         A <- lapply(Xz, function(a) { SBD(centroid, a)$yshift })
-        A <- do.call(rbind, A, TRUE)
+        A <- call_rbind(A)
     }
 
     Y <- zscore(A, ..., error.check = FALSE)

R/CLUSTERING-all-cent2.R

@@ -41,6 +41,7 @@ reinit_clusters <- function(x, cent, cent_case, num_empty, empty_clusters, distm
 # --------------------------------------------------------------------------------------------------
 # shape
 shape_cent <- function(x, x_split, cent, id_changed, cl_id, ..., distmat) {
+    force(x)
     # not all arguments are used, but I want them to be isolated from ellipsis
     dots <- list(...)
     dots$error.check <- FALSE
@@ -106,12 +107,12 @@ mean_cent <- function(x_split, ...) {
         if (is_multivariate(xx)) {
             ncols <- ncol(xx[[1L]]) # number of dimensions should be equal
             ncols <- rep(1L:ncols, length(xx))
-            xx <- do.call(cbind, xx, TRUE)
+            xx <- call_cbind(xx)
             xx <- split.data.frame(t(xx), ncols)
-            do.call(cbind, lapply(xx, colMeans), TRUE)
+            call_cbind(lapply(xx, colMeans))
         }
         else {
-            xx <- do.call(cbind, xx, TRUE)
+            xx <- call_cbind(xx)
             rowMeans(xx)
         }
     })
@@ -125,12 +126,12 @@ median_cent <- function(x_split, ...) {
         if (is_multivariate(xx)) {
             ncols <- ncol(xx[[1L]]) # number of dimensions should be equal
             ncols <- rep(1L:ncols, length(xx))
-            xx <- do.call(cbind, xx, TRUE)
+            xx <- call_cbind(xx)
             xx <- split.data.frame(t(xx), ncols)
-            do.call(cbind, lapply(xx, colMedians), TRUE)
+            call_cbind(lapply(xx, colMedians))
         }
         else {
-            xx <- do.call(rbind, xx, TRUE)
+            xx <- call_rbind(xx)
             colMedians(xx)
         }
     })
@@ -150,7 +151,7 @@ fcm_cent <- function(x, u, k, ..., distmat) {
         cent
     }
     else {
-        cent <- t(u) %*% do.call(rbind, x, TRUE)
+        cent <- t(u) %*% call_rbind(x)
         apply(cent, 2L, "/", e2 = colSums(u))
     }
 }

R/CLUSTERING-compare-clusterings.R

@@ -62,7 +62,7 @@ pdc_configs <- function(type = c("preproc", "distance", "centroid"), ...,
     if (length(shared) > 0L && length(share.config) > 0L) {
         # careful, singular and plural below
         shared_cfg <- Map(shared, names(shared), f = function(shared_args, fun) {
-            cfg <- quoted_call(expand.grid, foo = fun, stringsAsFactors = FALSE, dots = shared_args)
+            cfg <- quoted_call(expand.grid, fun, stringsAsFactors = FALSE, dots = shared_args)
             names(cfg)[1L] <- type
             cfg
         })
@@ -86,7 +86,7 @@ pdc_configs <- function(type = c("preproc", "distance", "centroid"), ...,
             if (!is.list(config) || is.null(config_names))
                 stop("All parameters must be named lists.") # nocov
             cfg <- Map(config, config_names, f = function(config_args, fun) {
-                cfg <- quoted_call(expand.grid, foo = fun, stringsAsFactors = FALSE, dots = config_args)
+                cfg <- quoted_call(expand.grid, fun, stringsAsFactors = FALSE, dots = config_args)
                 names(cfg)[1L] <- type
                 cfg
             })
@@ -631,7 +631,7 @@ compare_clusterings <- function(series = NULL, types = c("p", "h", "f", "t"),
         export <- c("trace", "score.clus", "return.objects",
                     "dots",
                     "centroids_included",
-                    "check_consistency", "quoted_call", "enlist", "subset_dots", "get_from_callers",
+                    "check_consistency", "do_call", "quoted_call", "enlist", "subset_dots", "get_from_callers",
                     "setnames_inplace",
                     custom_preprocs, custom_centroids)
 
@@ -682,16 +682,17 @@ compare_clusterings <- function(series = NULL, types = c("p", "h", "f", "t"),
             })
 
             setnames_inplace(args, c("preproc", "dist", "cent"))
-            args <- do.call(tsclust_args, args, TRUE)
+            args <- do_call("tsclust_args", args)
 
             # ----------------------------------------------------------------------------------
             # 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, TRUE)
+            control <- do_call(control_fun_name, control_args)
 
             # ----------------------------------------------------------------------------------
             # get processed series
@@ -719,7 +720,7 @@ compare_clusterings <- function(series = NULL, types = c("p", "h", "f", "t"),
                 distance <- cfg$distance
                 dist_entry <- dist_entries[[distance]]
                 if (!check_consistency(dist_entry$names[1L], "dist"))
-                    do.call(proxy::pr_DB$set_entry, dist_entry, TRUE) # nocov
+                    do_call(proxy::pr_DB$set_entry, dist_entry) # nocov
             }
             else distance <- NULL # dummy
 
@@ -749,7 +750,7 @@ compare_clusterings <- function(series = NULL, types = c("p", "h", "f", "t"),
 
             if (centroid_char == "default") {
                 # do not specify centroid
-                tsc <- do.call(tsclust, this_args, TRUE)
+                tsc <- do_call("tsclust", this_args)
             }
             else if (type %in% c("partitional", "fuzzy") && centroid_char %in% centroids_included) {
                 # with included centroid
@@ -982,7 +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
-                                   result[do.call(base::order, order_args, TRUE), , drop = FALSE]
+                                   base_order <- base::order
+                                   result[do_call("base_order", order_args), , drop = FALSE]
                                })
     # return results
     results

R/CLUSTERING-cvi-evaluators.R

@@ -78,7 +78,7 @@ cvi_evaluators <- function(type = "valid", fuzzy = FALSE, ground.truth = NULL) {
     }
 
     score <- function(objs, ...) {
-        do.call(rbind, lapply(objs, function(obj) {
+        call_rbind(lapply(objs, function(obj) {
             if (length(internal) > 0L)
                 cvis <- cvi(a = obj, type = internal, ...)
             else
@@ -115,7 +115,7 @@ cvi_evaluators <- function(type = "valid", fuzzy = FALSE, ground.truth = NULL) {
         best_overall <- Map(results, best_by_type, f = function(result, row_id) {
             result[row_id, type, drop = FALSE]
         })
-        best_overall <- do.call(rbind, best_overall)
+        best_overall <- call_rbind(best_overall)
         best_overall <- apply(best_overall, 2L, which.max)
         if (length(type) > 1L && length(unique(best_overall)) == length(best_overall))
             stop("All votes are distinct, so majority voting is inconclusive.")

R/CLUSTERING-ddist2.R

@@ -150,7 +150,7 @@ ddist2 <- function(distance, control) {
     warned <- FALSE
 
     # variables/functions from the parent environments that should be exported
-    export <- c("check_consistency", "quoted_call", "parallel_symmetric", "distance", "dist_entry")
+    export <- c("check_consistency", "do_call", "quoted_call", "parallel_symmetric", "distance", "dist_entry")
 
     ret <- function(result, ...) {
         ret <- structure(result, method = toupper(distance), ...)
@@ -219,7 +219,7 @@ ddist2 <- function(distance, control) {
                     .export = export
                 ) %op% {
                     if (!check_consistency(dist_entry$names[1L], "dist")) {
-                        do.call(proxy::pr_DB$set_entry, dist_entry, TRUE) # nocov
+                        do_call(proxy::pr_DB$set_entry, dist_entry) # nocov
                     }
 
                     parallel_symmetric(d_desc, ids, x, distance, dots)
@@ -269,7 +269,7 @@ ddist2 <- function(distance, control) {
             .export = export
         ) %op% {
             if (!check_consistency(dist_entry$names[1L], "dist")) {
-                do.call(proxy::pr_DB$set_entry, dist_entry, TRUE)
+                do_call(proxy::pr_DB$set_entry, dist_entry)
             }
 
             quoted_call(proxy::dist, x = x, y = centroids, method = distance, dots = dots)

R/CLUSTERING-repeat-clustering.R

@@ -95,33 +95,40 @@ repeat_clustering <- function(series, clusterings, config_id, ...) {
     }
 
     # set control args
-    args$control <- do.call(paste0(clus_type, "_control"), control_args, TRUE)
+    args$control <- do_call(paste0(clus_type, "_control"), control_args)
 
     # set remaining tsclust args
     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
-    args$args <- do.call(tsclust_args, quote = TRUE, args = list(
+    args$args <- do_call("tsclust_args", args = list(
         preproc = preproc_args,
         dist = distance_args,
-        cent = centroid_args)
-    )
+        cent = centroid_args
+    ))
 
     # create TSClusters
-    ret <- do.call(tsclust, c(args, list(...)), FALSE)
+    args <- c(args, list(...))
+    ret <- do_call("tsclust", args)
     ret@args <- lapply(ret@args, function(arg) { arg$.rng_ <- NULL; arg })
     ret@dots$.rng_ <- NULL
     ret@preproc <- preproc_char

R/CLUSTERING-tsclust.R

@@ -442,7 +442,7 @@ tsclust <- function(series = NULL, type = "partitional", k = 2L, ...,
             else {
                 # I need to re-register any custom distances in each parallel worker
                 dist_entry <- proxy::pr_DB$get_entry(distance)
-                export <- c("pfclust", "check_consistency", "quoted_call")
+                export <- c("pfclust", "check_consistency", "quoted_call", "do_call")
                 if (is.null(.rng_))
                     .rng_ <- rng_seq(length(k) * nrep, seed = seed, simplify = FALSE) # UTILS-rng.R
                 # if %do% is used, the outer loop replaces values in this envir
@@ -475,7 +475,7 @@ tsclust <- function(series = NULL, type = "partitional", k = 2L, ...,
                                 assign(".Random.seed", rng[[i]], .GlobalEnv)
 
                                 if (!check_consistency(dist_entry$names[1L], "dist"))
-                                    do.call(proxy::pr_DB$set_entry, dist_entry, TRUE) # nocov
+                                    do_call(proxy::pr_DB$set_entry, dist_entry) # nocov
 
                                 # return
                                 list(quoted_call(