It Is Possible to Restore a Session, Locally, in a Shiny App If the Inputs Have Been Previously Written in a Rds File

  • Home
  • Languages
  • R
  • It Is Possible to Restore a Session, Locally, in a Shiny App If the Inputs Have Been Previously Written in a Rds File

Can the shiny input read back the values loaded from .Rdata?

You can use reactiveValues to store your input$*** and save the reactiveValues object into RData.

If you want to load the RData file, just read it and names it as same as your reactiveValues variable names.

You can see this shiny app, it save people chatting log into RDS file (similar as RData file).
That is how it work in server.R :

vars <- reactiveValues(chat=NULL, users=NULL)

# Restore the chat log from the last session.

if (file.exists("chat.Rds")){
  vars$chat <- readRDS("chat.Rds")
} else {
  vars$chat <- "Welcome to Shiny Chat!"
}

Your code

I make an example only on input$name and input$age.

library(shiny)
library(pryr)

ui <- function(request){
  fluidPage(
    titlePanel("Put title of the application"),
    sidebarLayout(
      sidebarPanel(
        textInput("name", "Type your name", ""),
        textInput("age", "Type your age", ""),
        radioButtons("gender", "Select your gender", list("Male", "Female"), ""),
        sliderInput("height", "Select your height", min =  5.0, max = 8.0, value = 5.2, step = 0.1),
        selectInput("location", "Select your location", choices = c("","Gurgaon", "Bangalore", "Mumbai")),
        actionButton("save_objs", "Save Objects"),
        actionButton("load_objs", "Load Objects"),
        bookmarkButton()
      ),

      mainPanel(
        textOutput("username"),
        textOutput("userage"),
        textOutput("usergender"),
        textOutput("userheight"),
        textOutput("userlocation"),
        textOutput("userload")
      )
    )
  )
}

server <- function(input, output, session) {
  vals <- reactiveValues()

  output$username <- renderText(input$name)
  output$userage <- renderText(input$age)
  output$usergender <- renderText(input$gender)
  output$userheight <- renderText(input$height)
  output$userlocation <- renderText(input$location)

  isolate({
    vals$name=input$name
    vals$age=input$age
  })

  observeEvent(c(vals$name,vals$age),{
    updateTextInput(session,"name",label="Type your name",value=vals$name)
    updateTextInput(session,"age",label="Type your age",value=vals$name)
  })

  observeEvent(input$save_objs, {
    # Run whenever save_objs button is pressed
    vals$username<-input$name
    vals$userage<-input$age
    vals$usergender<-input$gender
    vals$userheight<-input$height
    vals$userlocation<-input$location
    print("** saving objects! **")

    ## Print the objects being saved
    print(rls())
    # ## Put  objects into current environment
    for(obj in unlist(rls())) {
      if(class(get(obj, pos =  -1))[1] == "reactive"){
        ## execute the reactive objects and put them in to this 
        ## environment i.e. into the environment of this function
        assign(obj, value = eval(call(obj)))
      } else {
        ## grab the global variables and put them into this 
        ## environment
        assign(obj, value = get(obj, pos =  -1))
      }
    }

    input_copy <- list()
    for(nm in names(input)){
      # assign(paste0("input_copy$", nm), value <- input[[nm]])
      input_copy[[nm]] <- input[[nm]]
    }

    ## save objects in current environment
    save(list = ls(), file = "shiny_env.Rdata", envir = environment())

    print("** done saving     **")
  })

  observeEvent(input$load_objs, {
    # Run whenever load_objs button is pressed
    ## Load the objects
    f.loaddata <- function()
    {
      myenv <- new.env()
      load(file = file.choose(), envir = myenv)
      myenv
    }

    print("** About to load objects! **")
    # ## Put  objects into current environment
    some <- f.loaddata()
    #print(some$input_copy$name)
    vals$name <- some$input_copy$name
    vals$age <- some$input_copy$age
    # vals$name <- input$name
    print("** done loading     **")
  })

}

shinyApp(ui, server, enableBookmarking = "server")

URI routing for shinydashboard using shiny.router

Here is how to use the below approach with shiny's tabPanel() function.

Workarounds not using library(shiny.router):

Edit - Alternative using clientData$url_search and mode = "push" for updateQueryString to push a new history entry onto the browser's history stack:

result

library(shiny)
library(shinydashboard)

ui <- function(request) {
  dashboardPage(
    header = dashboardHeader(title = "Simple tabs"),
    sidebar = dashboardSidebar(
      sidebarMenu(
        id = "sidebarID",
        menuItem(
          "Dashboard",
          tabName = "dashboard",
          icon = icon("tachometer-alt")
        ),
        menuItem(
          "Widgets",
          icon = icon("th"),
          tabName = "widgets",
          badgeLabel = "new",
          badgeColor = "green"
        )
      )
    ),
    body = dashboardBody(tabItems(
      tabItem(tabName = "dashboard",
              h2("Dashboard tab content")),
      tabItem(tabName = "widgets",
              h2("Widgets tab content"))
    ))
  )
}

server <- function(input, output, session) {
  # http://127.0.0.1:6172/?tab=dashboard
  # http://127.0.0.1:6172/?tab=widgets
  
  observeEvent(getQueryString(session)$tab, {
    currentQueryString <- getQueryString(session)$tab # alternative: parseQueryString(session$clientData$url_search)$tab
    if(is.null(input$sidebarID) || !is.null(currentQueryString) && currentQueryString != input$sidebarID){
      freezeReactiveValue(input, "sidebarID")
      updateTabItems(session, "sidebarID", selected = currentQueryString)
    }
  }, priority = 1)
  
  observeEvent(input$sidebarID, {
    currentQueryString <- getQueryString(session)$tab # alternative: parseQueryString(session$clientData$url_search)$tab
    pushQueryString <- paste0("?tab=", input$sidebarID)
    if(is.null(currentQueryString) || currentQueryString != input$sidebarID){
      freezeReactiveValue(input, "sidebarID")
      updateQueryString(pushQueryString, mode = "push", session)
    }
  }, priority = 0)
  
}

shinyApp(ui, server, enableBookmarking = "disable")

Another Edit - using url_hash (uri fragments):

result_fragments

library(shiny)
library(shinydashboard)

ui <- function(request) {
  dashboardPage(
    header = dashboardHeader(title = "Simple tabs"),
    sidebar = dashboardSidebar(
      sidebarMenu(
        id = "sidebarID",
        menuItem(
          "Dashboard",
          tabName = "dashboard",
          icon = icon("tachometer-alt")
        ),
        menuItem(
          "Widgets",
          icon = icon("th"),
          tabName = "widgets",
          badgeLabel = "new",
          badgeColor = "green"
        )
      )
    ),
    body = dashboardBody(tabItems(
      tabItem(tabName = "dashboard",
              h2("Dashboard tab content")),
      tabItem(tabName = "widgets",
              h2("Widgets tab content"))
    ))
  )
}

server <- function(input, output, session) {
  
  observeEvent(input$sidebarID, {
    # http://127.0.0.1:6172/#dashboard
    # http://127.0.0.1:6172/#widgets
    
    newURL <- paste0(
      session$clientData$url_protocol,
      "//",
      session$clientData$url_hostname,
      ":",
      session$clientData$url_port,
      session$clientData$url_pathname,
      "#",
      input$sidebarID
    )
    updateQueryString(newURL, mode = "replace", session)
  })
  
  observe({
    currentTab <- sub("#", "", session$clientData$url_hash)
    if(!is.null(currentTab)){
      updateTabItems(session, "sidebarID", selected = currentTab)
    }
  })
  
}

shinyApp(ui, server, enableBookmarking = "disable")

Edit - using url_search: Actually we can do the same without bookmarking using getQueryString and updateTabItems:

result_without_bookmarking

library(shiny)
library(shinydashboard)

ui <- function(request) {
  dashboardPage(
    header = dashboardHeader(title = "Simple tabs"),
    sidebar = dashboardSidebar(
      sidebarMenu(
        id = "sidebarID",
        menuItem(
          "Dashboard",
          tabName = "dashboard",
          icon = icon("tachometer-alt")
        ),
        menuItem(
          "Widgets",
          icon = icon("th"),
          tabName = "widgets",
          badgeLabel = "new",
          badgeColor = "green"
        )
      )
    ),
    body = dashboardBody(tabItems(
      tabItem(tabName = "dashboard",
              h2("Dashboard tab content")),
      tabItem(tabName = "widgets",
              h2("Widgets tab content"))
    ))
  )
}

server <- function(input, output, session) {

  observeEvent(input$sidebarID, {
    # http://127.0.0.1:6172/?tab=dashboard
    # http://127.0.0.1:6172/?tab=widgets
    
    newURL <- paste0(
        session$clientData$url_protocol,
        "//",
        session$clientData$url_hostname,
        ":",
        session$clientData$url_port,
        session$clientData$url_pathname,
        "?tab=",
        input$sidebarID
      )
    updateQueryString(newURL, mode = "replace", session)
  })
  
  observe({
    currentTab <- getQueryString(session)$tab # alternative: parseQueryString(session$clientData$url_search)$tab
    if(!is.null(currentTab)){
      updateTabItems(session, "sidebarID", selected = currentTab)
    }
  })
  
}

shinyApp(ui, server, enableBookmarking = "disable")

Using bookmarks:

Not sure if you are interested in a workaround like this, but you could use shiny's bookmarking and updateQueryString to achive a similar behaviour:

result

library(shiny)
library(shinydashboard)

ui <- function(request) {
  dashboardPage(
    header = dashboardHeader(title = "Simple tabs"),
    sidebar = dashboardSidebar(
      sidebarMenu(
        id = "sidebarID",
        menuItem(
          "Dashboard",
          tabName = "dashboard",
          icon = icon("tachometer-alt")
        ),
        menuItem(
          "Widgets",
          icon = icon("th"),
          tabName = "widgets",
          badgeLabel = "new",
          badgeColor = "green"
        )
      )
    ),
    body = dashboardBody(tabItems(
      tabItem(tabName = "dashboard",
              h2("Dashboard tab content")),
      tabItem(tabName = "widgets",
              h2("Widgets tab content"))
    ))
  )
}

server <- function(input, output, session) {
  bookmarkingWhitelist <- c("sidebarID")
  
  observe({
    setBookmarkExclude(setdiff(names(input), bookmarkingWhitelist))
  })
  
  observeEvent(input$sidebarID, {
    # http://127.0.0.1:6172/?_inputs_&sidebarID=%22dashboard%22
    # http://127.0.0.1:6172/?_inputs_&sidebarID=%22widgets%22
    
    newURL <- paste0(
        session$clientData$url_protocol,
        "//",
        session$clientData$url_hostname,
        ":",
        session$clientData$url_port,
        session$clientData$url_pathname,
        "?_inputs_&sidebarID=%22",
        input$sidebarID,
        "%22"
      )
    
    updateQueryString(newURL,
                      mode = "replace",
                      session)
  })
}

shinyApp(ui, server, enableBookmarking = "url")

Some related links:

  • https://rstudio.github.io/shinydashboard/behavior.html#bookmarking
  • https://shiny.rstudio.com/reference/shiny/1.7.0/session.html
  • It is possible to restore a session, locally, in a Shiny app if the inputs have been previously written in a RDS file?
  • shinyjs - setBookmarkExclude for delay IDs
  • https://github.com/rstudio/shiny/issues/3546

URL Bookmarking R Shiny

According to your description I guess for more complex apps you are hitting a browser limit with the encoded state URLs as mentioned in this article:

With an encoded state, the URL could become very long if there are many values. Some browsers have a limit of about 2,000 characters for the length of a URL, so if the bookmark URL is longer than that, it will not work properly in those browsers.

Therefore you should start using saved-to-server bookmarks by setting

enableBookmarking(store = "server")

Instead of:

enableBookmarking(store = "url")

Edit: Also for this to work your UI code must be wrapped in a function taking request as an argument:

2nd Edit: Added id = "myNavbarPage" to the navbarPage - so it will be recognized as an input for bookmarking (and restored accordingly).

library(shiny)
library(ggplot2)
library(DT)
library(shinyjqui)
library(shinydashboard)
library(shinydashboardPlus)
library(data.table)

ui <- function(request) {navbarPage(
  "Navbar!", id = "myNavbarPage",
  tabPanel("Plot",
           sidebarLayout(
             sidebarPanel(radioButtons(
               "plotType", "Plot type",
               c("Scatter" = "p", "Line" = "l")
             )),
             mainPanel(plotOutput("plot"))
           )),
  tabPanel(
    "Summary",
    fluidPage(
      plotOutput("bookmarkplot"),
      sliderInput("n", "Number of observations", 1, nrow(faithful), 100),
      fluidRow(column(
        2,
        textInput(
          inputId = "description",
          label = "Bookmark description",
          placeholder = "Data Summary"
        )
      ), column(2, bookmarkButton(id = "bookmarkBtn"))),
      DT::dataTableOutput("urlTable", width = "100%"),
      tags$style(type = 'text/css', "#bookmarkBtn { width:100%; margin-top: 25px;}")
    )
  ),
  navbarMenu(
    "More",
    tabPanel("Table",
             DT::dataTableOutput("table")),
    tabPanel("About",
             fluidRow(column(
               3,
               img(
                 class = "img-polaroid",
                 src = paste0(
                   "http://upload.wikimedia.org/",
                   "wikipedia/commons/9/92/",
                   "1919_Ford_Model_T_Highboy_Coupe.jpg"
                 )
               ),
               tags$small(
                 "Source: Photographed at the Bay State Antique ",
                 "Automobile Club's July 10, 2005 show at the ",
                 "Endicott Estate in Dedham, MA by ",
                 a(href = "http://commons.wikimedia.org/wiki/User:Sfoskett",
                   "User:Sfoskett")
               )
             )))
  )
)}

server <- function(input, output, session) {
  output$plot <- renderPlot({
    plot(cars, type = input$plotType)
  })

  output$summary <- renderPrint({
    summary(cars)
  })

  output$table <- DT::renderDataTable({
    DT::datatable(cars)
  })

  #BOOKMARK AND SAVING THEM
  myBookmarks <- reactiveValues(urlDF = NULL)
  observeEvent(input$bookmarkBtn, {
    session$doBookmark()
  })

  if (file.exists("bookmarks.rds")) {
    myBookmarks$urlDF <- readRDS("bookmarks.rds")
  } else {
    myBookmarks$urlDF <- NULL
  }

  session$onSessionEnded(function() {
    tmpUrlDF <- isolate({
      myBookmarks$urlDF
    })
    if (!is.null(tmpUrlDF)) {
      saveRDS(tmpUrlDF, "bookmarks.rds")
    }
  })

  setBookmarkExclude(
    c(
      "bookmarkBtn",
      "data_table_rows_all",
      "data_table_rows_current",
      "data_table_rows_selected",
      "data_table_rows_search",
      "data_table_rows_state",
      "data_table_rows_last_clicked",
      "bar",
      "navbar",
      "Scenario",
      "description",
      "urlTable_cell_clicked",
      "urlTable_rows_all",
      "urlTable_rows_current",
      "urlTable_rows_selected",
      "urlTable_search",
      "urlTable_state",
      "urlTable_row_last_clicked"
    )
  )

  output$bookmarkplot <- renderPlot({
    hist(faithful$eruptions[seq_len(input$n)], breaks = 40)
  })

  onBookmarked(
    fun = function(url) {
      if (!url %in% myBookmarks$urlDF$URL) {
        if (is.null(myBookmarks$urlDF)) {
          myBookmarks$urlDF <-
            unique(
              data.table(
                Description = input$description,
                URL = paste0("<a href='", url, "'>", url, "</a>"),
                Timestamp = Sys.time(),
                Session = session$token
              ),
              by = "URL"
            )
        } else {
          myBookmarks$urlDF <-
            unique(rbindlist(list(
              myBookmarks$urlDF,
              data.table(
                Description = input$description,
                URL = paste0("<a href='", url, "'>", url, "</a>"),
                Timestamp = Sys.time(),
                Session = session$token
              )
            )), by = "URL")
        }
      }
    }
  )

  output$urlTable = DT::renderDataTable({
    req(myBookmarks$urlDF)
    myBookmarks$urlDF
  }, escape = FALSE)

  enableBookmarking(store = "server")
}
shinyApp(ui = ui, server = server)

See ?enableBookmarking or my earlier answer.

Bookmarking and saving the bookmarks in R shiny

Here is an alternative approach to my earlier answer using saveRDS() instead of sqlite:

Edit: Added username check.

library(shiny)
# library(RSQLite)
library(data.table)

ui <- function(request) {
  fluidPage(
    plotOutput("plot"),
    sliderInput("n", "Number of observations", 1, nrow(faithful), 100),
    fluidRow(column(2, textInput(inputId = "description", label = "Bookmark description", placeholder = "Data Summary")), column(2, bookmarkButton(id="bookmarkBtn"))),
    DT::dataTableOutput("urlTable", width = "100%"),
    tags$style(type='text/css', "#bookmarkBtn { width:100%; margin-top: 25px;}")
  )
}

server <- function(input, output, session) {

  # con <- dbConnect(RSQLite::SQLite(), "bookmarks.db", overwrite = FALSE)
  myBookmarks <- reactiveValues(urlDF = NULL)

  observeEvent(input$bookmarkBtn, {
    session$doBookmark()
  })

  # if(dbExistsTable(con, "Bookmarks")){
  #   tmpUrlDF <- data.table(dbReadTable(con, "Bookmarks"))
  #   myBookmarks$urlDF <- tmpUrlDF[, Timestamp := as.POSIXct(Timestamp, origin="1970-01-01 00:00")]
  # } else {
  #   myBookmarks$urlDF <- NULL
  # }

  if(file.exists("bookmarks.rds")){
    myBookmarks$urlDF <- readRDS("bookmarks.rds")
  } else {
    myBookmarks$urlDF <- NULL
  }

  session$onSessionEnded(function() {
    tmpUrlDF <- isolate({myBookmarks$urlDF})
    if(!is.null(tmpUrlDF)){
      # dbWriteTable(con, "Bookmarks", tmpUrlDF, overwrite = TRUE)
      saveRDS(tmpUrlDF, "bookmarks.rds")
    }
    # dbDisconnect(con)
  })

  setBookmarkExclude(c("bookmarkBtn", "description", "urlTable_cell_clicked", "urlTable_rows_all", "urlTable_rows_current", "urlTable_rows_selected", "urlTable_search", "urlTable_state", "urlTable_row_last_clicked"))

  output$plot <- renderPlot({
    hist(faithful$eruptions[seq_len(input$n)], breaks = 40)
  })

  onBookmarked(fun=function(url){
    if(!url %in% myBookmarks$urlDF$URL){
      if(is.null(myBookmarks$urlDF)){
        myBookmarks$urlDF <- unique(data.table(Description = input$description, URL = paste0("<a href='", url, "'>", url,"</a>"), Timestamp = Sys.time(), Session = session$token, User = Sys.getenv("USERNAME")), by="URL")
      } else {
        myBookmarks$urlDF <- unique(rbindlist(list(myBookmarks$urlDF, data.table(Description = input$description, URL = paste0("<a href='", url, "'>", url,"</a>"), Timestamp = Sys.time(), Session = session$token, User = Sys.getenv("USERNAME")))), by="URL")
      }
    }
  })

  output$urlTable = DT::renderDataTable({
  req(myBookmarks$urlDF)
    myBookmarks$urlDF[User %in% Sys.getenv("USERNAME")]
  }, escape=FALSE)

}

enableBookmarking(store = "url")
shinyApp(ui, server)

Adding/removing icon in downloadButton() and fileInput()

To add an icon to fileInput(), add a list to the buttonLabel. e.g.

shinyApp(
  fluidPage(
    fileInput("myFileInput",label="Test",buttonLabel=list(icon("folder"),"TestyMcTestFace"))
  ),
  function(input, output, session){
  }
)

Related Topics

R - Cumulative Sum by Condition

Ggplot2: Fill Color Behaviour of Geom_Ribbon

How to Create a Vector of Functions

Replace Nas with Mean of the Same Column of a Data.Table

Rbindlist Two Data.Tables Where One Has Factor and Other Has Character Type for a Column

How to Draw Half-Filled Points in R (Preferably Using Ggplot)

Applying Gsub to Various Columns

Order Categorical Data in a Stacked Bar Plot with Ggplot2

Boxplot of Table Using Ggplot2

Draw Multiple Squares with Ggplot

How Does R's Ifelse Work with Character Data

Generating Non-Duplicate Combination Pairs in R

Suppress Automatic Output to Console in R

Preventing Column-Class Inference in Fread()

Why Doesn't Comparison Between Numeric and Character Variables Give a Warning

Ggplot Set Scale_Color_Gradientn Manually

Str_Replace (Package Stringr) Cannot Replace Brackets in R

R Crashing While Displaying Ggplot After Update (Process Memory Read Out of Range)


Leave a reply



Submit