diff --git a/DESCRIPTION b/DESCRIPTION index 2749ab3..a76f53e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -19,6 +19,7 @@ Imports: purrr, readr, rio, + rlang, shiny, shinyFiles, stringr, diff --git a/NAMESPACE b/NAMESPACE index 22354fb..dda6e6b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,7 @@ # Generated by roxygen2: do not edit by hand export(create_demo_framework) +export(from_example_to_function) export(from_function_to_mask) export(run_app) import(shiny) diff --git a/R/fct_from_example_to_function.R b/R/fct_from_example_to_function.R new file mode 100644 index 0000000..b552024 --- /dev/null +++ b/R/fct_from_example_to_function.R @@ -0,0 +1,156 @@ +#' From example to function +#' +#' @description From a user exemple code (expr), get the corresponding function +#' +#' @param expr The expression user wants to transform to a function +#' @param env Working environment +#' @return Function 1L. Output function. +#' +#' @export +from_example_to_function <- function(expr, env = parent.frame()) { + if (! (is.expression(expr) & length(expr) == 1)) stop ("expr must be an expression of length 1") + + key_to_param <- new.env(parent = emptyenv()) + params <- list() + + make_param <- function(key, default) { + if (exists(key, envir = key_to_param, inherits = FALSE)) { + get(key, envir = key_to_param, inherits = FALSE) + } else { + pname <- paste0("param_", length(params) + 1) + assign(key, pname, envir = key_to_param) + params[[pname]] <<- default + pname + } + } + + is_missing_arg <- function(x) { + identical(x, rlang::missing_arg()) || + (is.symbol(x) && length(as.character(x)) == 1 && as.character(x) == "") + } + + # Detect x <- ..., x = ... (as assignment), x <<- ..., ... -> x, ... ->> x + is_assignment_call <- function(x) { + is.call(x) && is.symbol(x[[1]]) && as.character(x[[1]]) %in% + c("<-", "=", "<<-", "->", "->>") + } + + # Extract symbol bound by an assignment call (only if LHS is a bare symbol) + assignment_lhs_symbol <- function(x) { + if (!is_assignment_call(x)) return(NULL) + op <- as.character(x[[1]]) + + # For -> and ->>, the assigned symbol is the 3rd element + lhs <- if (op %in% c("->", "->>")) x[[3]] else x[[2]] + + if (is.symbol(lhs)) { + nm <- as.character(lhs) + if (length(nm) == 1 && !is.na(nm) && nm != "") return(nm) + } + NULL + } + + rewrite <- function(node, bound = character()) { + # Strings -> params + if (is.character(node) && length(node) == 1) { + key <- paste0("chr:", node) + pname <- make_param(key, node) + return(rlang::sym(pname)) + } + + # Symbols: keep local/bound; capture external non-functions + if (is.symbol(node)) { + s <- as.character(node) + if (length(s) != 1 || is.na(s) || s == "") return(node) + if (s %in% bound) return(node) + + if (exists(s, envir = env, inherits = TRUE)) { + val <- get(s, envir = env, inherits = TRUE) + if (!is.function(val)) { + key <- paste0("sym:", s) + pname <- make_param(key, val) + return(rlang::sym(pname)) + } + } + return(node) + } + + # Expression vectors + if (is.expression(node)) { + out <- lapply(as.list(node), rewrite, bound = bound) + return(as.expression(out)) + } + + # Calls + if (is.call(node)) { + head <- node[[1]] + head_name <- if (is.symbol(head)) as.character(head) else NULL + + # Handle { ... } as a sequential block with growing bound vars + if (!is.null(head_name) && head_name == "{") { + args <- as.list(node) + # args[[1]] is "{" + cur_bound <- bound + + if (length(args) >= 2) { + for (i in seq.int(2, length(args))) { + stmt <- args[[i]] + + # Rewrite statement with current bound + args[[i]] <- rewrite(stmt, bound = cur_bound) + + # If original statement binds a new symbol, extend bound for following statements + new_nm <- assignment_lhs_symbol(stmt) + if (!is.null(new_nm)) { + cur_bound <- unique(c(cur_bound, new_nm)) + } + } + } + return(as.call(args)) + } + + # Nested function definitions: function(...) { ... } and \(...) { ... } + if (!is.null(head_name) && head_name %in% c("function", "\\")) { + formals_pl <- node[[2]] + nms <- names(formals_pl) + nms <- if (is.null(nms)) character() else nms + nms <- nms[nms != "" & !is.na(nms) & nms != "..."] + new_bound <- unique(c(bound, nms)) + new_body <- rewrite(node[[3]], bound = new_bound) + return(as.call(list(head, formals_pl, new_body))) + } + + # Assignments: rewrite RHS only, and treat LHS symbol as local thereafter (handled in `{`) + if (!is.null(head_name) && head_name %in% c("<-", "=", "<<-")) { + lhs <- node[[2]] + rhs <- node[[3]] + rhs2 <- rewrite(rhs, bound = bound) + return(as.call(list(rlang::sym(head_name), lhs, rhs2))) + } + if (!is.null(head_name) && head_name %in% c("->", "->>")) { + rhs <- node[[2]] + lhs <- node[[3]] + rhs2 <- rewrite(rhs, bound = bound) + return(as.call(list(rlang::sym(head_name), rhs2, lhs))) + } + + # Generic call: rewrite arguments (not head) + args <- as.list(node) + if (length(args) >= 2) { + for (i in seq.int(2, length(args))) { + if (!is_missing_arg(args[[i]])) { + args[[i]] <- rewrite(args[[i]], bound = bound) + } + } + } + return(as.call(args)) + } + + node + } + + new_body <- rewrite(expr[[1]], bound = character()) + fmls <- rlang::pairlist2(!!!params) + rlang::new_function(args = fmls, body = new_body, env = env) +} + diff --git a/dev/02_dev.R b/dev/02_dev.R index 276c778..291ba1f 100644 --- a/dev/02_dev.R +++ b/dev/02_dev.R @@ -31,6 +31,7 @@ golem::add_fct("add_trycatch_logrow", with_test = TRUE) golem::add_fct("rename_function_params", with_test = TRUE) golem::add_fct("create_demo_framework", with_test = FALSE) golem::add_fct("from_function_to_mask", with_test = TRUE) +golem::add_fct("from_example_to_function", with_test = TRUE) golem::add_fct("genproc", with_test = TRUE) golem::add_utils("helpers", with_test = TRUE) diff --git a/man/from_example_to_function.Rd b/man/from_example_to_function.Rd new file mode 100644 index 0000000..6ded5bf --- /dev/null +++ b/man/from_example_to_function.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_from_example_to_function.R +\name{from_example_to_function} +\alias{from_example_to_function} +\title{From example to function} +\usage{ +from_example_to_function(expr, env = parent.frame()) +} +\arguments{ +\item{expr}{The expression user wants to transform to a function} + +\item{env}{Working environment} +} +\value{ +Function 1L. Output function. +} +\description{ +From a user exemple code (expr), get the corresponding function +} diff --git a/tests/testthat/test-fct_from_example_to_function.R b/tests/testthat/test-fct_from_example_to_function.R new file mode 100644 index 0000000..8bb9f36 --- /dev/null +++ b/tests/testthat/test-fct_from_example_to_function.R @@ -0,0 +1,145 @@ +test_that("from_example_to_function is consistent", { + + library(purrr) + library(dplyr) + + # most arbitrary expr possible + expect_equal(from_example_to_function(expression({ + # intentionally very long and nonsense function + get("cars") %>% select(1) %>% (\(x) pull(x, names(x)[[1]])) %>% + paste0(collapse = " test ") %>% + (\(p) { + x <- "test2" + list(is.numeric(x), p) + }) + })), function (param_1 = "cars", + param_2 = " test ", + param_3 = "test2") + { + get(param_1) %>% select(1) %>% (function(x) + pull(x, names(x)[[1]])) %>% + paste0(collapse = param_2) %>% (function(p) { + x <- param_3 + list(is.numeric(x), p) + }) + }) + + # error + expect_error(from_example_to_function(get("cars") %>% select(1)), + "expr must be an expression of length 1") + + # simple expr and func + myexpr_1 <- expression({ + map(c("cars", "mtcars"), get) %>% + map(mutate_all, as.character) + }) + myfunc_1 <- from_example_to_function(myexpr_1) + expect_equal(from_example_to_function(myexpr_1), + function (param_1 = "cars", param_2 = "mtcars") + { + map(c(param_1, param_2), get) %>% map(mutate_all, as.character) + }) + expect_equal(myfunc_1(param_1 = "airquality", param_2 = "anscombe"), + # this is a dput() output: + list(structure(list( + Ozone = c("41", "36", "12", "18", NA, "28", + "23", "19", "8", NA, "7", "16", "11", "14", "18", "14", "34", + "6", "30", "11", "1", "11", "4", "32", NA, NA, NA, "23", "45", + "115", "37", NA, NA, NA, NA, NA, NA, "29", NA, "71", "39", NA, + NA, "23", NA, NA, "21", "37", "20", "12", "13", NA, NA, NA, NA, + NA, NA, NA, NA, NA, NA, "135", "49", "32", NA, "64", "40", "77", + "97", "97", "85", NA, "10", "27", NA, "7", "48", "35", "61", + "79", "63", "16", NA, NA, "80", "108", "20", "52", "82", "50", + "64", "59", "39", "9", "16", "78", "35", "66", "122", "89", "110", + NA, NA, "44", "28", "65", NA, "22", "59", "23", "31", "44", "21", + "9", NA, "45", "168", "73", NA, "76", "118", "84", "85", "96", + "78", "73", "91", "47", "32", "20", "23", "21", "24", "44", "21", + "28", "9", "13", "46", "18", "13", "24", "16", "13", "23", "36", + "7", "14", "30", NA, "14", "18", "20"), Solar.R = c("190", "118", + "149", "313", NA, NA, "299", "99", "19", "194", NA, "256", "290", + "274", "65", "334", "307", "78", "322", "44", "8", "320", "25", + "92", "66", "266", NA, "13", "252", "223", "279", "286", "287", + "242", "186", "220", "264", "127", "273", "291", "323", "259", + "250", "148", "332", "322", "191", "284", "37", "120", "137", + "150", "59", "91", "250", "135", "127", "47", "98", "31", "138", + "269", "248", "236", "101", "175", "314", "276", "267", "272", + "175", "139", "264", "175", "291", "48", "260", "274", "285", + "187", "220", "7", "258", "295", "294", "223", "81", "82", "213", + "275", "253", "254", "83", "24", "77", NA, NA, NA, "255", "229", + "207", "222", "137", "192", "273", "157", "64", "71", "51", "115", + "244", "190", "259", "36", "255", "212", "238", "215", "153", + "203", "225", "237", "188", "167", "197", "183", "189", "95", + "92", "252", "220", "230", "259", "236", "259", "238", "24", + "112", "237", "224", "27", "238", "201", "238", "14", "139", + "49", "20", "193", "145", "191", "131", "223"), Wind = c("7.4", + "8", "12.6", "11.5", "14.3", "14.9", "8.6", "13.8", "20.1", "8.6", + "6.9", "9.7", "9.2", "10.9", "13.2", "11.5", "12", "18.4", "11.5", + "9.7", "9.7", "16.6", "9.7", "12", "16.6", "14.9", "8", "12", + "14.9", "5.7", "7.4", "8.6", "9.7", "16.1", "9.2", "8.6", "14.3", + "9.7", "6.9", "13.8", "11.5", "10.9", "9.2", "8", "13.8", "11.5", + "14.9", "20.7", "9.2", "11.5", "10.3", "6.3", "1.7", "4.6", "6.3", + "8", "8", "10.3", "11.5", "14.9", "8", "4.1", "9.2", "9.2", "10.9", + "4.6", "10.9", "5.1", "6.3", "5.7", "7.4", "8.6", "14.3", "14.9", + "14.9", "14.3", "6.9", "10.3", "6.3", "5.1", "11.5", "6.9", "9.7", + "11.5", "8.6", "8", "8.6", "12", "7.4", "7.4", "7.4", "9.2", + "6.9", "13.8", "7.4", "6.9", "7.4", "4.6", "4", "10.3", "8", + "8.6", "11.5", "11.5", "11.5", "9.7", "11.5", "10.3", "6.3", + "7.4", "10.9", "10.3", "15.5", "14.3", "12.6", "9.7", "3.4", + "8", "5.7", "9.7", "2.3", "6.3", "6.3", "6.9", "5.1", "2.8", + "4.6", "7.4", "15.5", "10.9", "10.3", "10.9", "9.7", "14.9", + "15.5", "6.3", "10.9", "11.5", "6.9", "13.8", "10.3", "10.3", + "8", "12.6", "9.2", "10.3", "10.3", "16.6", "6.9", "13.2", "14.3", + "8", "11.5"), Temp = c("67", "72", "74", "62", "56", "66", "65", + "59", "61", "69", "74", "69", "66", "68", "58", "64", "66", "57", + "68", "62", "59", "73", "61", "61", "57", "58", "57", "67", "81", + "79", "76", "78", "74", "67", "84", "85", "79", "82", "87", "90", + "87", "93", "92", "82", "80", "79", "77", "72", "65", "73", "76", + "77", "76", "76", "76", "75", "78", "73", "80", "77", "83", "84", + "85", "81", "84", "83", "83", "88", "92", "92", "89", "82", "73", + "81", "91", "80", "81", "82", "84", "87", "85", "74", "81", "82", + "86", "85", "82", "86", "88", "86", "83", "81", "81", "81", "82", + "86", "85", "87", "89", "90", "90", "92", "86", "86", "82", "80", + "79", "77", "79", "76", "78", "78", "77", "72", "75", "79", "81", + "86", "88", "97", "94", "96", "94", "91", "92", "93", "93", "87", + "84", "80", "78", "75", "73", "81", "76", "77", "71", "71", "78", + "67", "76", "68", "82", "64", "71", "81", "69", "63", "70", "77", + "75", "76", "68"), Month = c("5", "5", "5", "5", "5", "5", "5", + "5", "5", "5", "5", "5", "5", "5", "5", "5", "5", "5", "5", "5", + "5", "5", "5", "5", "5", "5", "5", "5", "5", "5", "5", "6", "6", + "6", "6", "6", "6", "6", "6", "6", "6", "6", "6", "6", "6", "6", + "6", "6", "6", "6", "6", "6", "6", "6", "6", "6", "6", "6", "6", + "6", "6", "7", "7", "7", "7", "7", "7", "7", "7", "7", "7", "7", + "7", "7", "7", "7", "7", "7", "7", "7", "7", "7", "7", "7", "7", + "7", "7", "7", "7", "7", "7", "7", "8", "8", "8", "8", "8", "8", + "8", "8", "8", "8", "8", "8", "8", "8", "8", "8", "8", "8", "8", + "8", "8", "8", "8", "8", "8", "8", "8", "8", "8", "8", "8", "9", + "9", "9", "9", "9", "9", "9", "9", "9", "9", "9", "9", "9", "9", + "9", "9", "9", "9", "9", "9", "9", "9", "9", "9", "9", "9", "9", + "9", "9", "9"), Day = c("1", "2", "3", "4", "5", "6", "7", "8", + "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", + "20", "21", "22", "23", "24", "25", "26", "27", "28", "29", "30", + "31", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", + "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", + "23", "24", "25", "26", "27", "28", "29", "30", "1", "2", "3", + "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", + "16", "17", "18", "19", "20", "21", "22", "23", "24", "25", "26", + "27", "28", "29", "30", "31", "1", "2", "3", "4", "5", "6", "7", + "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", + "19", "20", "21", "22", "23", "24", "25", "26", "27", "28", "29", + "30", "31", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", + "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", + "22", "23", "24", "25", "26", "27", "28", "29", "30")), row.names = c(NA, + -153L), class = "data.frame"), structure(list(x1 = c("10", "8", + "13", "9", "11", "14", "6", "4", "12", "7", "5"), x2 = c("10", + "8", "13", "9", "11", "14", "6", "4", "12", "7", "5"), x3 = c("10", + "8", "13", "9", "11", "14", "6", "4", "12", "7", "5"), x4 = c("8", + "8", "8", "8", "8", "8", "8", "19", "8", "8", "8"), y1 = c("8.04", + "6.95", "7.58", "8.81", "8.33", "9.96", "7.24", "4.26", "10.84", + "4.82", "5.68"), y2 = c("9.14", "8.14", "8.74", "8.77", "9.26", + "8.1", "6.13", "3.1", "9.13", "7.26", "4.74"), y3 = c("7.46", + "6.77", "12.74", "7.11", "7.81", "8.84", "6.08", "5.39", "8.15", + "6.42", "5.73"), y4 = c("6.58", "5.76", "7.71", "8.84", "8.47", + "7.04", "5.25", "12.5", "5.56", "7.91", "6.89")), row.names = c(NA, + -11L), class = "data.frame"))) + +})