## ----setup, include = FALSE--------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>", warning = FALSE, message = FALSE, eval = interactive() ) ## ----libs--------------------------------------------------------------------- # library(ggpaintr) # library(ggplot2) # library(rlang) # for `%||%`, sym(), call2(), abort() used in the examples ## ----app-basic---------------------------------------------------------------- # ptr_app( # ggplot(mtcars, aes(x = ppVar, y = ppVar)) + geom_point() # ) ## ----formula-tour------------------------------------------------------------- # ptr_app( # mtcars |> # dplyr::filter(ppExpr(mpg > 15)) |> # ggplot(aes(x = ppVar, y = ppVar, color = ppVar)) + # geom_point(size = ppNum) + # labs(title = ppText) # ) ## ----app-basic-seeded--------------------------------------------------------- # ptr_app( # ggplot(mtcars, aes(x = ppVar("wt"), y = ppVar("mpg"))) + # geom_point(size = ppNum(3), alpha = ppNum(0.6)) + # labs(title = ppText("Weight vs. mileage")) # ) ## ----define-value------------------------------------------------------------- # ptr_define_placeholder_value( # keyword = "ppPercent", # # build_ui = function(node, label = NULL, selected = NULL, # named_args = list(), ...) { # step <- named_args$step %||% 1 # shiny::sliderInput( # node$id, label = label %||% "Percent", # min = 0, max = 100, # value = selected %||% node$default %||% 50, # step = step # ) # }, # # resolve_expr = function(value, node, ...) { # if (is.null(value)) return(NULL) # as.numeric(value) / 100 # }, # # validate_session_input = function(value, ctx) { # v <- suppressWarnings(as.numeric(value)) # if (length(v) != 1L || is.na(v) || v < 0 || v > 100) { # rlang::abort("Percent must be a single number between 0 and 100.") # } # value # }, # # parse_positional_arg = ptr_arg_numeric(), # parse_named_args = list(step = ptr_arg_numeric()), # embellish_eval = function(x, ...) as.numeric(x) / 100, # ui_text_defaults = list(label = "Percent for {param}") # ) ## ----define-value-app--------------------------------------------------------- # ptr_app( # ggplot(mtcars, aes(x = ppVar("wt"), y = ppVar("mpg"))) + # geom_point(alpha = ppPercent(40, step = 5)) # ) ## ----embellish-bind, eval = FALSE--------------------------------------------- # ppPercent <- ptr_define_placeholder_value("ppPercent", ...) # ppPercent(40) # => 0.4, as ordinary R ## ----define-consumer---------------------------------------------------------- # ptr_define_placeholder_consumer( # keyword = "colvars", # # build_ui = function(node, cols = character(), data = NULL, # label = NULL, selected = character(0), ...) { # shiny::selectInput( # node$id, label = label %||% "Columns", # choices = cols, # selected = intersect(selected, cols), # keep only still-valid picks # multiple = TRUE # ) # }, # # resolve_expr = function(value, node, ...) { # if (length(value) == 0L) return(NULL) # rlang::call2("c", !!!as.list(value)) # c(col1, col2, ...) # }, # # parse_positional_arg = ptr_arg_symbol_or_string(), # ui_text_defaults = list(label = "Columns for {param}") # # validate_session_input / parse_named_args / embellish_eval: same shape as 2.1, omitted here. # ) ## ----define-consumer-app------------------------------------------------------ # ptr_app( # mtcars |> # dplyr::select(colvars) |> # ggplot(aes(x = ppVar, y = ppVar)) + geom_point() # ) ## ----define-source------------------------------------------------------------ # .env <- environment() # the scope whose data frames should be loadable # # ptr_define_placeholder_source( # keyword = "ppDataset", # shortcut = TRUE, # # build_ui = function(node, label = NULL, ...) { # # env-name-only source: the framework's shortcut text box is the sole # # entry point, so build_ui contributes no widget of its own. # NULL # }, # # resolve_data = function(value, node, ...) { # nm <- if (is.character(value) && length(value) == 1L && nzchar(value)) value else NULL # if (is.null(nm)) return(NULL) # tryCatch(get(nm, envir = .env, inherits = TRUE), # error = function(e) NULL) # }, # # resolve_expr = function(value, node, ...) rlang::sym(value), # ui_text_defaults = list(label = "Dataset for {param}") # ) ## ----define-source-app-------------------------------------------------------- # ptr_app( # ppDataset() |> ggplot(aes(x = ppVar("mpg"))) + geom_histogram() # ) ## ----module-app--------------------------------------------------------------- # f <- rlang::expr(ggplot(mtcars, aes(x = ppVar("wt"), y = ppVar("mpg"))) + geom_point()) # # ui <- shiny::fluidPage( # shiny::h3("My dashboard"), # ptr_ui(!!f, "plot1") # ) # server <- function(input, output, session) { # ptr_server(!!f, "plot1") # } # shiny::shinyApp(ui, server) ## ----l2-shared-partition------------------------------------------------------ # # A custom value placeholder for the shared size control: a 1-6 slider. # ptr_define_placeholder_value( # keyword = "ppSize", # parse_positional_arg = ptr_arg_numeric(), # build_ui = function(node, label = NULL, selected = NULL, ...) { # val <- suppressWarnings(as.numeric(selected %||% node$default %||% 3)) # if (length(val) != 1L || is.na(val)) val <- 3 # shiny::sliderInput(node$id, label %||% "Size", min = 1, max = 6, value = val) # }, # resolve_expr = function(value, node, ...) { # out <- suppressWarnings(as.numeric(value)) # if (length(out) != 1L || is.na(out)) NULL else out # } # ) # # plots <- list( # rlang::expr(ggplot(iris, aes(x = ppVar(shared = "ax1"), y = Sepal.Width, # color = Species)) + geom_point(size = ppSize(shared = "sz"))), # rlang::expr(ggplot(iris, aes(x = ppVar(shared = "ax2"), y = Petal.Width, # color = Species)) + geom_point(size = ppSize(shared = "sz"))) # ) # # obj <- ptr_shared(formulas = plots) # a list of formulas, passed as-is # obj$panel_keys # "sz" -- used by both formulas, so panel-owned # # ui <- shiny::fluidPage( # ptr_shared_panel(obj), # holds the shared size slider # shiny::fluidRow( # shiny::column(6, ptr_ui(!!plots[[1]], "plot_1", shared = obj)), # ax1 inline # shiny::column(6, ptr_ui(!!plots[[2]], "plot_2", shared = obj)) # ax2 inline # ) # ) # server <- function(input, output, session) { # sh <- ptr_shared_server(obj) # ptr_server(!!plots[[1]], "plot_1", shared_state = sh) # ptr_server(!!plots[[2]], "plot_2", shared_state = sh) # } # shiny::shinyApp(ui, server)