From 921c6ebd75ddf38317df4daa045d482f674dfe0f Mon Sep 17 00:00:00 2001 From: IlyaZar Date: Tue, 28 Mar 2023 20:34:27 +0200 Subject: [PATCH 1/5] fix: add several name-watchers for on() - provides the "or" case for the components of the 'name' argument - implementation: add an expression generator 'generate_watch_expr()': - if 'name' is a vector its elements are parsed to a list of reactives and put inside obeserveEvent() - if length(name) == 1, the default (previouis) behaviour is used - style: run styler::style_file("R/funs.R", style = grkstyle::grk_style_transformer) --- R/funs.R | 60 ++++++++++++++++++++++++++++++++------------------------ 1 file changed, 34 insertions(+), 26 deletions(-) diff --git a/R/funs.R b/R/funs.R index ce25248..03189f2 100644 --- a/R/funs.R +++ b/R/funs.R @@ -11,21 +11,20 @@ #' @importFrom shiny reactiveVal #' @export #' @examples -#' if (interactive()){ +#' if (interactive()) { #' library(shiny) #' library(gargoyle) #' options("gargoyle.talkative" = TRUE) -#' ui <- function(request){ +#' ui <- function(request) { #' tagList( -#' h4('Go'), +#' h4("Go"), #' actionButton("y", "y"), -#' h4('Output of z$v'), +#' h4("Output of z$v"), #' tableOutput("evt") #' ) #' } #' -#' server <- function(input, output, session){ -#' +#' server <- function(input, output, session) { #' # Initiating the flags #' init("airquality", "iris", "renderiris") #' @@ -33,7 +32,7 @@ #' # a reactive structure #' z <- new.env() #' -#' observeEvent( input$y , { +#' observeEvent(input$y, { #' z$v <- mtcars #' # Triggering the flag #' trigger("airquality") @@ -57,25 +56,22 @@ #' watch("renderiris") #' head(z$v) #' }) -#' #' } #' #' shinyApp(ui, server) -#' #' } -init <- function(..., session = getDefaultReactiveDomain()){ +init <- function(..., session = getDefaultReactiveDomain()) { lapply( list(...), - function(x){ + function(x) { session$userData[[x]] <- reactiveVal(0) } ) - } #' @rdname Event #' @export -trigger <- function(..., session = getDefaultReactiveDomain()){ +trigger <- function(..., session = getDefaultReactiveDomain()) { .logs$log <- rbind( .logs$log, data.frame( @@ -86,8 +82,8 @@ trigger <- function(..., session = getDefaultReactiveDomain()){ ) lapply( list(...), - function(x){ - if (getOption("gargoyle.talkative", FALSE)){ + function(x) { + if (getOption("gargoyle.talkative", FALSE)) { cat( "- [Gargoyle] Triggering", x, @@ -99,11 +95,10 @@ trigger <- function(..., session = getDefaultReactiveDomain()){ ) } ) - } #' @rdname Event #' @export -watch <- function(name, session = getDefaultReactiveDomain()){ +watch <- function(name, session = getDefaultReactiveDomain()) { session$userData[[name]]() } @@ -120,23 +115,22 @@ watch <- function(name, session = getDefaultReactiveDomain()){ #' #' @export #' @importFrom shiny observeEvent getDefaultReactiveDomain -#' @importFrom attempt stop_if +#' @importFrom attempt stop_if_not on <- function( name, expr, session = getDefaultReactiveDomain() - ){ - - stop_if( - session$userData[[name]], - is.null, - sprintf( - "[Gargoyle] Flag %s hasn't been initiated: can't listen to it.", + ) { + stop_if_not( + all(name %in% names(session$userData)), + msg = sprintf( + "[Gargoyle] Flag %s hasn't been initiated: can't listen to it.\n", name ) ) + watch_expr <- generate_watch_expr(name) observeEvent( - substitute(gargoyle::watch(name)), + do.call("substitute", list(watch_expr[[1]])), { substitute(expr) }, @@ -147,3 +141,17 @@ on <- function( handler.env = parent.frame() ) } +generate_watch_expr <- function(name) { + if (length(name) > 1) { + tmp_expr <- parse( + text = paste0( + "list(", + paste0("gargoyle::watch(name[", seq_along(name), "])", collapse = ", "), + ")" + ) + ) + } else { + tmp_expr <- parse(text = "gargoyle::watch(name)") + } + return(tmp_expr) +} From 311fc7b384ef86b6cff20c2e1143fa24f2864c05 Mon Sep 17 00:00:00 2001 From: IlyaZar Date: Tue, 4 Jul 2023 09:39:39 +0200 Subject: [PATCH 2/5] docs: updated for changes in on() function - updated doc-string - change stop_if to stop_if_not (see changes to NAMESPACE as well) - add entry to roxygen which seems to be (?) necessary to make a link to a function in a different package via shiny::observeEvent --- DESCRIPTION | 1 + NAMESPACE | 2 +- R/funs.R | 12 +++++++----- 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 5726ac9..afed027 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -20,4 +20,5 @@ Suggests: rmarkdown, testthat (>= 3.0.0) VignetteBuilder: knitr +Roxygen: list(markdown = TRUE) Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index 78b6cc1..06727ff 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,7 +6,7 @@ export(init) export(on) export(trigger) export(watch) -importFrom(attempt,stop_if) +importFrom(attempt,stop_if_not) importFrom(shiny,getDefaultReactiveDomain) importFrom(shiny,observeEvent) importFrom(shiny,reactiveVal) diff --git a/R/funs.R b/R/funs.R index 03189f2..ccf8092 100644 --- a/R/funs.R +++ b/R/funs.R @@ -105,12 +105,14 @@ watch <- function(name, session = getDefaultReactiveDomain()) { #' React on an event #' -#' @param name the name of the event to react to -#' @param expr the expression to run when the event -#' is triggered. -#' @param session The shiny session object +#' @param name The name of the event to react to as a character; can be a +#' character vector of event names in which case a reaction is triggered if +#' any (all) of the events is (are) triggered (i.e. the non-exclusive "OR" +#' case). +#' @param expr The expression to run when the event is triggered. +#' @param session The shiny session object. #' -#' @return An observeEvent object. This object will +#' @return An [shiny::observeEvent()] object. This object will #' rarely be used, `on` is mainly called for side-effects. #' #' @export From edb8c82e0786d7f9ed3bf9ca1749914ed188faed Mon Sep 17 00:00:00 2001 From: IlyaZar Date: Thu, 6 Jul 2023 08:32:35 +0200 Subject: [PATCH 3/5] fix: pass 'session'-argument from on() to watch() - adding the session argument in view of #17 and #18 - remove redundant whitespace --- R/funs.R | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/R/funs.R b/R/funs.R index ccf8092..72cf2de 100644 --- a/R/funs.R +++ b/R/funs.R @@ -102,7 +102,6 @@ watch <- function(name, session = getDefaultReactiveDomain()) { session$userData[[name]]() } - #' React on an event #' #' @param name The name of the event to react to as a character; can be a @@ -148,12 +147,17 @@ generate_watch_expr <- function(name) { tmp_expr <- parse( text = paste0( "list(", - paste0("gargoyle::watch(name[", seq_along(name), "])", collapse = ", "), + paste0( + "gargoyle::watch(name[", + seq_along(name), + "], session = session)", + collapse = ", " + ), ")" ) ) } else { - tmp_expr <- parse(text = "gargoyle::watch(name)") + tmp_expr <- parse(text = "gargoyle::watch(name, session = session)") } return(tmp_expr) } From f84c03d6def01cc7244a7bf160b30944d38c86d5 Mon Sep 17 00:00:00 2001 From: IlyaZar Date: Thu, 6 Jul 2023 11:45:18 +0200 Subject: [PATCH 4/5] feat: finer error msg. in on() for 'name' vector To make the error message more useful: -> inisde stop_if_not(), the exact events/flags that have not been initiated are printed --- R/funs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/funs.R b/R/funs.R index 72cf2de..b76d67f 100644 --- a/R/funs.R +++ b/R/funs.R @@ -126,7 +126,7 @@ on <- function( all(name %in% names(session$userData)), msg = sprintf( "[Gargoyle] Flag %s hasn't been initiated: can't listen to it.\n", - name + name[!(name %in% names(session$userData))] ) ) watch_expr <- generate_watch_expr(name) From e16ff21036c547c4a369b35db5a668a22bd444cb Mon Sep 17 00:00:00 2001 From: IlyaZar Date: Thu, 6 Jul 2023 11:47:39 +0200 Subject: [PATCH 5/5] tests: add tests for feature 'name' vector in on() --- tests/testthat/test-funs.R | 244 +++++++++++++++++++++++++++++++++++++ 1 file changed, 244 insertions(+) diff --git a/tests/testthat/test-funs.R b/tests/testthat/test-funs.R index 737a63e..40e7d2d 100644 --- a/tests/testthat/test-funs.R +++ b/tests/testthat/test-funs.R @@ -25,3 +25,247 @@ test_that("gargoyle works", { shiny::reactiveConsole(FALSE) }) +test_that("gargoyle on() works for name vector", { + shiny::reactiveConsole(TRUE) + + s <- shiny::MockShinySession$new() + + init("pif_01", "pif_02", "pif_03", session = s) + + # 0. Define on() for 'name' vector + # 0.A for pif_01 and pif_02 + on( + c("pif_01", "pif_02"), + { + cat("Event on-Type 1: triggered by pif_{01,02}!\n") + }, + session = s + ) + expect_true( + s$userData$pif_01() == 0 + ) + expect_true( + s$userData$pif_02() == 0 + ) + # 0.B for pif_02 and pif_03 + on( + c("pif_02", "pif_03"), + { + cat("Event on-Type 2: triggered by pif_{02,03}!\n") + }, + session = s + ) + expect_true( + s$userData$pif_02() == 0 + ) + expect_true( + s$userData$pif_03() == 0 + ) + # I. Test single trigger + trigger("pif_01", session = s) + trigger("pif_03", session = s) + expect_true( + s$userData$pif_01() == 1 + ) + expect_true( + s$userData$pif_02() == 0 + ) + expect_true( + s$userData$pif_03() == 1 + ) + + # II. Test double trigger + trigger("pif_02", session = s) + trigger("pif_01", "pif_03", session = s) + expect_true( + s$userData$pif_01() == 2 + ) + expect_true( + s$userData$pif_02() == 1 + ) + expect_true( + s$userData$pif_03() == 2 + ) + + # II. Run tests for on() with errors - uninitialized events + # II.A Provoke error due to uninitialized event(s) - mismatch from init(s) + # first event exists - second does not + expect_error( + on( + c("pif_01", "pif_2"), + { + cat(1 + 1) + }, + session = s + ) + ) + # first does not exits - second event exists + expect_error( + on( + c("pif_1", "pif_02"), + { + cat(1 + 1) + }, + session = s + ) + ) + # both events do not exists + expect_error( + on( + c("pif_1", "pif_2"), + { + cat(1 + 1) + }, + session = s + ) + ) + # II.B Check error message of uninitialized event(s) - mismatch from init(s) + # single mismatch for second event + out_error <- try( + on( + c("pif_01", "pif_2"), + { + cat(1 + 1) + }, + session = s + ), + silent = TRUE + ) + expect_equal( + out_error[[1]], + "Error : [Gargoyle] Flag pif_2 hasn't been initiated: can't listen to it.\n\n" + ) + # single mismatch for first event + out_error <- try( + on( + c("pif_1", "pif_02"), + { + cat(1 + 1) + }, + session = s + ), + silent = TRUE + ) + expect_equal( + out_error[[1]], + "Error : [Gargoyle] Flag pif_1 hasn't been initiated: can't listen to it.\n\n" + ) + # double mismatch for first event + out_error <- try( + on( + c("pif_1", "pif_2"), + { + cat(1 + 1) + }, + session = s + ), + silent = TRUE + ) + expect_equal( + out_error[[1]], + paste0( + "Error : [Gargoyle] Flag pif_1 hasn't been initiated: can't listen to it.", + "\n[Gargoyle] Flag pif_2 hasn't been initiated: can't listen to it.\n\n" + ) + ) + + # II.C Provoke error due to uninitialized event - mismatch from session arg + # both events exist but the session is wrong -> throws error + expect_error( + on( + c("pif_01", "pif_02"), + { + cat(1 + 1) + }, + session = getDefaultReactiveDomain() + ) + ) + # both events exist but the session is wrong -> throws correct error message + # a double mismatch error message as the session is wrong + out_error <- try( + on( + c("pif_01", "pif_02"), + { + cat(1 + 1) + }, + session = getDefaultReactiveDomain() + ), + silent = TRUE + ) + expect_equal( + out_error[[1]], + paste0( + "Error : [Gargoyle] Flag pif_01 hasn't been initiated: can't listen to it.", + "\n[Gargoyle] Flag pif_02 hasn't been initiated: can't listen to it.\n\n" + ) + ) + # a double mismatch error message as the session is wrong + out_error <- try( + on( + c("pif_1", "pif_02"), + { + cat(1 + 1) + }, + session = getDefaultReactiveDomain() + ), + silent = TRUE + ) + expect_equal( + out_error[[1]], + paste0( + "Error : [Gargoyle] Flag pif_1 hasn't been initiated: can't listen to it.", + "\n[Gargoyle] Flag pif_02 hasn't been initiated: can't listen to it.\n\n" + ) + ) + # a double mismatch error message as the session is wrong + out_error <- try( + on( + c("pif_01", "pif_2"), + { + cat(1 + 1) + }, + session = getDefaultReactiveDomain() + ), + silent = TRUE + ) + expect_equal( + out_error[[1]], + paste0( + "Error : [Gargoyle] Flag pif_01 hasn't been initiated: can't listen to it.", + "\n[Gargoyle] Flag pif_2 hasn't been initiated: can't listen to it.\n\n" + ) + ) + # a double mismatch error message as the session is wrong + out_error <- try( + on( + c("pif_1", "pif_2"), + { + cat(1 + 1) + }, + session = getDefaultReactiveDomain() + ), + silent = TRUE + ) + expect_equal( + out_error[[1]], + paste0( + "Error : [Gargoyle] Flag pif_1 hasn't been initiated: can't listen to it.", + "\n[Gargoyle] Flag pif_2 hasn't been initiated: can't listen to it.\n\n" + ) + ) + + # III. Test classes for double on() + expect_identical( + class( + on( + c("pif_01", "pif_02"), + { + cat(1 + 1) + }, + session = s + ) + ), + c("Observer.event", "Observer", "R6") + ) + shiny::reactiveConsole(FALSE) +})