Convert eventReactive() to function() (#55)

* Add logiv for eventReactive and simplify

* Add test

* Add new functions to select right expression for evaluation

* Use new return_inner_expression() in update_expressions()

* Add importFrom methods formalArgs

* Create test-return-inner-expression.R

* Add methods to desc

DESCRIPTION

@@ -13,6 +13,7 @@ Imports:
   glue,
   knitr,
   magrittr,
+  methods,
   pander,
   purrr,
   readr,

NAMESPACE

@@ -18,6 +18,7 @@ importFrom(glue,glue)
 importFrom(glue,glue_collapse)
 importFrom(knitr,purl)
 importFrom(magrittr,"%>%")
+importFrom(methods,formalArgs)
 importFrom(pander,pandoc.table)
 importFrom(readr,read_file)
 importFrom(readr,read_lines)

R/utilities-evaluation.R

@@ -27,3 +27,64 @@ eval_code <- function(x, envir = NULL) {
 confirm_function <- function(expr, fun) {
   identical(eval_bare(expr), fun)
 }
+
+
+
+#' Find expression one level below current call
+#'
+#' @param x 
+#' @param name 
+#' @noRd
+#'
+#' @examples
+#' code <- expression(y <- eventReactive(input$button, {print(input$n)}))
+#' return_inner_expression(x = code[[1]][[3]], name = "valueExpr")
+return_inner_expression <- function(x, name) {
+  i <- which(full_argument_names(x) == name)
+  x[[i]]
+}
+
+
+#' Get name of assigned  function from expression
+#'
+#' @param x 
+#' @noRd
+#' @importFrom methods formalArgs
+#' @examples
+#' full_argument_names(expression(gsub(' ', '_', 'a b c')))
+#' full_argument_names(expression(gsub(x = 'a b c', ' ', '_')))
+#' full_argument_names(expression(gsub(x = 'a b c', pat = ' ', rep = '_')))
+full_argument_names <- function(x) {
+  x_fn <- x
+
+  default_args <- c("", formalArgs(args(eval(x_fn[[1]]))))
+  missing_names <- is.null(names(x_fn))
+
+  seq_args <- seq_along(x_fn)
+  #skip_last <- head(seq_args, -1)
+
+
+  if (missing_names) {
+    # assign names after first position
+    names(x_fn) <- default_args[seq_args]
+  } else {
+
+    orig_args <- names(x_fn)
+    has_name <- nchar(orig_args) > 0
+
+    # line up args including partial matches
+    explicit_args <- pmatch(orig_args[has_name], default_args)
+    # update names
+    names(x_fn)[which(has_name)] <- default_args[explicit_args]
+    updated_args <- names(x_fn)
+
+    # missing args
+    avail_args <- setdiff(default_args, updated_args[has_name])
+    missing_name <- which(!has_name)
+    implicit_args <- avail_args[seq_along(missing_name)]
+    # update names
+    names(x_fn)[missing_name] <- implicit_args
+  }
+
+  names(x_fn)
+}

R/utilities-find-and-convert.R

@@ -40,19 +40,23 @@ find_all_assignments_rmd <- function(file) {
 #' Update expressions to be non-reactive
 #' @param x code to evaluate
 #' @noRd
+#' @examples
+#' update_expressions(expression(y <- eventReactive(input$button, {print(input$n)})))
 update_expressions <- function(x){
-  char_code <- as.character(x)
+  char_code <- as.character(as.expression(x))
 
   if (!grepl("<-.*\\(", char_code)) {
     final_code <- x
   } else {
     code_as_call <- as.call(x)[[1]]
     get_symbol <- code_as_call[[2]] 
-    get_formals <- code_as_call[[3]][[2]]
+    get_formals <- code_as_call[[3]][[2]] # works for most
 
 
-    if (grepl("reactive\\(", char_code)) {
-      get_formals <- code_as_call[[3]][[2]]
+    if (grepl("reactive\\(", char_code, ignore.case = TRUE)) {
+      if (grepl("eventReactive\\(", char_code)) {
+        get_formals <- return_inner_expression(code_as_call[[3]], "valueExpr")
+      } 
       new_exp <-
         as.expression(
           bquote(
@@ -74,7 +78,7 @@ update_expressions <- function(x){
         )
 
       final_code <- new_exp
-    } else if (grepl("output\\$", as.character(x))) {
+    } else if (grepl("output\\$", char_code)) {
       new_exp <-
         as.expression(
           bquote(

tests/testthat/test-return-inner-expression.R

@@ -0,0 +1,46 @@
+test_that("return argument pulls returns right piece of code", {
+  x <- expression(y <- eventReactive(input$button, {print(input$n)}))
+  code_as_call <- as.call(x)[[1]]
+
+  all_args <- full_argument_names(code_as_call[[3]])
+
+  expect_equal(
+    object = all_args, 
+    expected = c("", "eventExpr", "valueExpr")
+  )
+
+  get_event <- return_inner_expression(code_as_call[[3]], "eventExpr")
+  get_value <- return_inner_expression(code_as_call[[3]], "valueExpr")
+
+  expect_equal(
+    object = as.call(get_event), 
+    expected = as.call(quote(input$button))
+  )
+
+  expect_equal(
+    object = as.character(get_value)[[2]], 
+    expected = "print(input$n)"
+  )
+})
+
+
+
+test_that("full_argument_names works", {
+  all_args <- c("", "pattern", "replacement", "x")
+
+  expect_equal(
+    object = full_argument_names(parse(text = "gsub(' ', '_', 'a b c')")[[1]]),
+    expected = all_args
+  )
+
+  expect_equal(
+    object = full_argument_names(expression(gsub(x = "a b c", " ", "_"))[[1]]),
+    expected = all_args[c(1,4,2,3)]
+  )
+
+  expect_equal(
+    object = full_argument_names(expression(gsub(x = "a b c", pat = " ", rep = "_"))[[1]]),
+    expected = all_args[c(1,4,2,3)]
+  )
+})
+

tests/testthat/test-update-expression.R

@@ -64,3 +64,15 @@ test_that("updates reactive to function", {
     expected = "expression(y <- function() {print(input$n)})"
   )
 })
+
+
+
+test_that("updates eventReactive to function", {
+  code <- expression(y <- eventReactive(input$button, {print(input$n)}))
+  new_code <- update_expressions(code)
+  actual <- paste(trimws(deparse(new_code)), collapse = "")
+  expect_equal(
+    object = actual,
+    expected = "expression(y <- function() {print(input$n)})"
+  )
+})