# Bookmark Modules Example

## Introduction

The `shinystate` package was greatly inspired by an example application created by Joe Cheng (creator of Shiny) to accompany his keynote presentation at the 2018 R/Pharma conference. Among other notable features as documented in the GitHub repository README, the application provided an alternative user interface powered by Shiny modules to save and restore bookmarkable state. The following example is an adaptation of the original version to utilize `shinystate` to manage the bookmarkable state features.

## How to Run Application

The application source code is included in the ‘shinystate’ package and it can be launched with the following code:

    library(shiny)
    library(shinystate)
    runExample("bookmark_module", package = "shinystate")

If you are viewing this package vignette in a web browser, the application can also be viewed using the Shinylive service:

Open in Shinylive

## Application Code

The remainder of this vignette contains the source code of the application. Note that the version included in the package is constructed with separate R scripts containing the module and utility function code.

The same principles for using `shinystate` in an application apply in this example as well, but here are specific notes for the implementation used in this example application:

- The module `bookmark_mod` contains a parameter for the `StorageClass` instance used for the application.
- Bookmarkable state sessions are displayed using an interactive table produced by `DT::datatable()` with the ability to select the row used to restore a saved session. This is just one approach to display sessions in a Shiny application.
- A reactive object `session_choice` corresponding to the `url` value of the selected row in the sessions table is supplied to the `restore()` method of the `StorageClass` instance.
- Additional information corresponding to the session name entered in a text input as well as the current time are saved as part of the bookmarkable state snapshot metadata, assembled as a `list()` object with named elements for each variable.

### `app.R`

    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.R`

    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.R`

    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.R`

    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.R`

    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.R`

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