## ----include = FALSE---------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ## ----run-app-package, eval=FALSE---------------------------------------------- # library(shiny) # library(shinystate) # runExample("bookmark_module", package = "shinystate") ## ----shinylive_url, echo = FALSE, results = 'asis'---------------------------- code <- paste0( c( "webr::install('shinystate', repos = c('https://rpodcast.r-universe.dev', 'https://repo.r-wasm.org'))", knitr::knit_code$get("utils"), knitr::knit_code$get("bookmark-modules"), knitr::knit_code$get("filter-module"), knitr::knit_code$get("select-module"), knitr::knit_code$get("summarize-module"), knitr::knit_code$get("main-app") ), collapse = "\n" ) url <- roxy.shinylive::create_shinylive_url(code) cat(sprintf("[Open in Shinylive](%s)\n\n", url)) ## ----shinylive_iframe, echo = FALSE, out.width = '150%', out.extra = 'style = "position: relative; z-index:1"', eval = knitr::is_html_output() && identical(Sys.getenv("IN_PKGDOWN"), "true")---- # knitr::include_url(url, height = "800px") ## ----main-app, eval=FALSE----------------------------------------------------- # library(shiny) # library(shinystate) # library(dplyr) # library(DT) # library(rlang) # library(lubridate) # # # recommended to define a directory for storage or a pins board # storage <- StorageClass$new() # # ui <- function(req) { # tagList( # # Bootstrap header # tags$header( # class = "navbar navbar-default navbar-static-top", # tags$div( # class = "container-fluid", # tags$div( # class = "navbar-header", # tags$div(class = "navbar-brand", "Bookmark Module Demo") # ), # # Links for restoring/loading sessions # tags$ul( # class = "nav navbar-nav navbar-right", # tags$li( # bookmark_modal_load_ui("bookmark") # ), # tags$li( # bookmark_modal_save_ui("bookmark") # ) # ) # ) # ), # fluidPage( # use_shinystate(), # sidebarLayout( # position = "right", # column( # width = 4, # wellPanel( # select_vars_ui("select") # ), # wellPanel( # filter_ui("filter") # ) # ), # mainPanel( # tabsetPanel( # id = "tabs", # tabPanel("Plot", tags$br(), plotOutput("plot", height = 600)), # tabPanel("Summary", tags$br(), verbatimTextOutput("summary")), # tabPanel("Table", tags$br(), tableOutput("table")) # ) # ) # ) # ) # ) # } # # server <- function(input, output, session) { # callModule(bookmark_mod, "bookmark", storage) # storage$register_metadata() # datasetExpr <- reactive(expr(mtcars %>% mutate(cyl = factor(cyl)))) # filterExpr <- callModule(filter_mod, "filter", datasetExpr) # selectExpr <- callModule( # select_vars, # "select", # reactive(names(eval_clean(datasetExpr()))), # filterExpr # ) # # data <- reactive({ # resultExpr <- selectExpr() # df <- eval_clean(resultExpr) # validate(need(nrow(df) > 0, "No data matches the filter")) # df # }) # # output$table <- renderTable( # { # data() # }, # rownames = TRUE # ) # # do_plot <- function() { # plot(data()) # } # # output$plot <- renderPlot({ # do_plot() # }) # # output$summary <- renderPrint({ # summary(data()) # }) # # output$code <- renderText({ # format_tidy_code(selectExpr()) # }) # } # # shinyApp(ui, server, onStart = function() { # shiny::enableBookmarking("server") # }) # ## ----bookmark-modules, eval=FALSE--------------------------------------------- # bookmark_modal_save_ui <- function(id) { # ns <- NS(id) # # tagList( # actionLink(ns("show_save_modal"), "Save session") # ) # } # # bookmark_modal_load_ui <- function(id) { # ns <- NS(id) # # tagList( # actionLink(ns("show_load_modal"), "Restore session") # ) # } # # bookmark_load_ui <- function(id) { # ns <- NS(id) # tagList( # uiOutput(ns("saved_sessions")) # ) # } # # bookmark_mod <- function(input, output, session, storage) { # ns <- session$ns # session_df <- reactive({ # storage$get_sessions() # }) # # output$saved_sessions_placeholder <- renderUI({ # DT::dataTableOutput(session$ns("saved_sessions_table")) # }) # # output$saved_sessions_table <- DT::renderDataTable({ # req(session_df()) # DT::datatable( # session_df(), # escape = FALSE, # selection = "single" # ) # }) # # session_choice <- reactive({ # req(session_df()) # req(input$saved_sessions_table_rows_selected) # i <- input$saved_sessions_table_rows_selected # url <- session_df()[i, "url"] # return(url) # }) # # observeEvent(input$restore, { # req(session_choice()) # storage$restore(session_choice()) # }) # # shiny::setBookmarkExclude(c( # "show_save_modal", # "show_load_modal", # "save_name", # "save", # "session_choice", # "restore" # )) # # observeEvent(input$show_load_modal, { # showModal(modalDialog( # size = "xl", # easyClose = TRUE, # title = "Restore session", # footer = tagList( # modalButton("Cancel"), # actionButton(session$ns("restore"), "Restore", class = "btn-primary") # ), # tagList( # uiOutput(session$ns("saved_sessions_placeholder")) # ) # )) # }) # # observeEvent(input$show_save_modal, { # showModal(modalDialog( # easyClose = TRUE, # textInput(session$ns("save_name"), "Give this session a name"), # footer = tagList( # modalButton("Cancel"), # actionButton(session$ns("save"), "Save", class = "btn-primary") # ) # )) # }) # # observeEvent(input$save, ignoreInit = TRUE, { # tryCatch( # { # if (!isTruthy(input$save_name)) { # stop("Please specify a bookmark name") # } else { # removeModal() # storage$snapshot( # session_metadata = list( # save_name = input$save_name, # timestamp = Sys.time() # ) # ) # showNotification( # "Session successfully saved" # ) # } # }, # error = function(e) { # showNotification( # conditionMessage(e), # type = "error" # ) # } # ) # }) # } ## ----filter-module, eval=FALSE------------------------------------------------ # filter_ui <- function(id) { # ns <- NS(id) # # tagList( # div(id = ns("filter_container")), # actionButton(ns("show_filter_dialog_btn"), "Add filter") # ) # } # # filter_mod <- function(input, output, session, data_expr) { # ns <- session$ns # # setBookmarkExclude(c("show_filter_dialog_btn", "add_filter_btn")) # # filter_fields <- list() # makeReactiveBinding("filter_fields") # # onBookmark(function(state) { # state$values$filter_field_names <- names(filter_fields) # }) # # onRestore(function(state) { # filter_field_names <- state$values$filter_field_names # for (fieldname in filter_field_names) { # addFilter(fieldname) # } # }) # # observeEvent(input$show_filter_dialog_btn, { # available_fields <- names(eval_clean(data_expr())) %>% # base::setdiff(names(filter_fields)) # # showModal(modalDialog( # title = "Add filter", # # radioButtons(ns("filter_field"), "Field to filter", available_fields), # # footer = tagList( # modalButton("Cancel"), # actionButton(ns("add_filter_btn"), "Add filter") # ) # )) # }) # # observeEvent(input$add_filter_btn, { # addFilter(input$filter_field) # removeModal() # }) # # addFilter <- function(fieldname) { # id <- paste0("filter__", fieldname) # # filter <- createFilter( # data = eval_clean(data_expr())[[fieldname]], # id = ns(id), # fieldname = fieldname # ) # # freezeReactiveValue(input, id) # # insertUI( # paste0("#", ns("filter_container")), # "beforeEnd", # # TODO: escape special characters in fieldname # filter$ui # ) # # filter$inputId <- id # filter_fields[[fieldname]] <<- filter # } # # reactive({ # result_expr <- data_expr() # # if (length(filter_fields) == 0) { # return(result_expr) # } # # # Gather up all filter expressions # exprs <- lapply(names(filter_fields), function(name) { # filter <- filter_fields[[name]] # x <- as.symbol(name) #df[[name]] # param <- input[[filter[["inputId"]]]] # cond_expr <- filter[["filterExpr"]](x = x, param = param) # if (!is.null(cond_expr)) { # result_expr <<- expr(!!result_expr %>% filter(!!cond_expr)) # } # invisible() # }) # # result_expr # }) # } # # createFilter <- function(data, id, fieldname) { # UseMethod("createFilter") # } # # createFilter.character <- function(data, id, fieldname) { # list( # ui = textInput(id, fieldname, ""), # filterExpr = function(x, param) { # if (!nzchar(param)) { # NULL # } else { # expr(grepl(!!param, !!x, ignore.case = TRUE, fixed = TRUE)) # } # } # ) # } # # createFilter.numeric <- function(data, id, fieldname) { # list( # ui = sliderInput( # id, # fieldname, # min = min(data), # max = max(data), # value = range(data) # ), # filterExpr = function(x, param) { # expr(!!x >= !!param[1] & !!x <= !!param[2]) # } # ) # } # # createFilter.integer <- createFilter.numeric # # createFilter.factor <- function(data, id, fieldname) { # inputControl <- if (length(levels(data)) > 6) { # selectInput(id, fieldname, levels(data), character(0), multiple = TRUE) # } else { # checkboxGroupInput(id, fieldname, levels(data)) # } # # list( # ui = inputControl, # filterExpr = function(x, param) { # if (length(param) == 0) { # NULL # } else { # expr(!!x %in% !!param) # } # } # ) # } # # createFilter.POSIXt <- createFilter.numeric ## ----select-module, eval=FALSE------------------------------------------------ # select_vars_ui <- function(id) { # ns <- NS(id) # tagList( # uiOutput(ns("vars_ui")) # ) # } # # select_vars <- function(input, output, session, vars, data_expr) { # ns <- session$ns # # output$vars_ui <- renderUI({ # freezeReactiveValue(input, "vars") # selectInput(ns("vars"), "Variables to display", vars(), multiple = TRUE) # #checkboxGroupInput(ns("vars"), "Variables", names(data), selected = names(data)) # }) # # reactive({ # if (length(input$vars) == 0) { # data_expr() # } else { # expr(!!data_expr() %>% select(!!!syms(input$vars))) # } # }) # } # ## ----summarize-module, eval=FALSE--------------------------------------------- # summarize_ui <- function(id) { # ns <- NS(id) # tagList( # uiOutput(ns("summarize_ui")) # ) # } # # summarize_mod <- function(input, output, session, vars, data_expr) { # output$summarize_ui <- renderUI({ # ns <- session$ns # # tagList( # selectInput( # ns("group_by"), # "Group by", # choices = vars(), # multiple = TRUE # ), # selectInput( # ns("operation"), # "Summary operation", # c("mean", "sum", "count") # ), # selectInput( # ns("aggregate"), # "Summary value", # choices = vars(), # multiple = TRUE # ) # ) # }) # # reactive({ # result_expr <- data_expr() # if (length(input$group_by) > 0) { # result_expr <- expr(!!result_expr %>% group_by(!!!syms(input$group_by))) # } # if (length(input$aggregate) > 0) { # op <- switch( # input$operation, # mean = quote(mean), # sum = quote(sum), # count = quote(length) # ) # agg_exprs <- lapply(input$aggregate, function(var) { # col_name <- deparse(expr((!!sym(input$operation))(!!sym(var)))) # expr(!!col_name := (!!op)(!!sym(var))) # }) # result_expr <- expr(!!result_expr %>% summarise(!!!agg_exprs)) # } # result_expr # }) # } ## ----utils, eval=FALSE-------------------------------------------------------- # #' Evaluate an expression in a fresh environment # #' # #' Like eval_tidy, but with different defaults. By default, instead of running # #' in the caller's environment, it runs in a fresh environment. # #' @export # eval_clean <- function(expr, env = list(), enclos = clean_env()) { # eval_tidy(expr, env, enclos) # } # # #' Create a clean environment # #' # #' Creates a new environment whose parent is the global environment. # #' @export # clean_env <- function() { # new.env(parent = globalenv()) # } # # #' Join calls into a pipeline # expr_pipeline <- function(..., .list = list(...)) { # exprs <- .list # if (length(exprs) == 0) { # return(NULL) # } # # exprs <- rlang::flatten(exprs) # # exprs <- Filter(Negate(is.null), exprs) # # if (length(exprs) == 0) { # return(NULL) # } # # Reduce( # function(memo, expr) { # expr(!!memo %>% !!expr) # }, # tail(exprs, -1), # exprs[[1]] # ) # } # # friendly_time <- function(t) { # t <- round_date(t, "seconds") # now <- round_date(Sys.time(), "seconds") # # abs_day_diff <- abs(day(now) - day(t)) # age <- now - t # # abs_age <- abs(age) # future <- age != abs_age # dir <- ifelse(future, "from now", "ago") # # format_rel <- function(singular, plural = paste0(singular, "s")) { # x <- as.integer(round(time_length(abs_age, singular))) # sprintf("%d %s %s", x, ifelse(x == 1, singular, plural), dir) # } # # ifelse( # abs_age == seconds(0), # "Now", # ifelse( # abs_age < minutes(1), # format_rel("second"), # ifelse( # abs_age < hours(1), # format_rel("minute"), # ifelse( # abs_age < hours(6), # format_rel("hour"), # # Less than 24 hours, and during the same calendar day # ifelse( # abs_age < days(1) & abs_day_diff == 0, # strftime(t, "%I:%M:%S %p"), # ifelse( # abs_age < days(3), # strftime(t, "%a %I:%M:%S %p"), # strftime(t, "%Y/%m/%d %I:%M:%S %p") # ) # ) # ) # ) # ) # ) # }