## ----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")
#             )
#           )
#         )
#       )
#     )
#   )
# }

