Maintaining an Input/Output Log in R

How can I keep input track log in shiny, then print it and save it?

You could store the values of the textInput inside a reactiveValues which get updated when clicking a button. In the following example you initialize an empty data.frame and a counter which both get updated when clicking the button. All Inputs get stored in a the data.frame.

If you want would like to store this values after the session for reusage you could use a bookmarkButton for local storage or you could also store the values in an SQL-Database or a NoSQL-Database for permanent storage.

  library(shiny)

ui <- fluidPage(
titlePanel("TRY-1"),
sidebarLayout(
sidebarPanel(
textInput("txtInput", "Input to Display"),
actionButton("store", "Store value in dataframe")
),
mainPanel(
tableOutput("table")
)
)
)

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

rv <- reactiveValues(dfnew=data.frame(matrix(ncol = 2, nrow = 0)) ,count=1)

storedvalues <- observeEvent(input$store, {
if(nchar(input$txtInput) > 0) {
rv$dfnew <- rbind(rv$dfnew, df())
rv$count = rv$count + 1
} else {
}
})

df <- reactive({
data.frame(
id = rv$count,
value = input$txtInput
)
})

output$table <- renderTable({
rv$dfnew
})

})

shinyApp(ui = ui, server = server)

How do you sink input and output to a text file in R?

library(TeachingDemos)

txtStart("temp.txt")
1:10
txtStop()

The text file now looks like

> 1:10
[1] 1 2 3 4 5 6 7 8 9 10

Can I maintain input defaults across different instances of a Shiny App Module?

Yes, it is possible. Here's one way of doing it.

The important concepts are that

  1. Modules can return a value (or values).
  2. The main server can monitor the values returned by modules.
  3. Modules can react to changes in other modules via arguments to their server functions. (Or via session$userData: the approach I've taken.)

I think you knew that last one as you have a site argument in the module server, although you don't seem to use it.

So, taking each step in turn...

Allow the module to server to return a value

Add the following lines at the end of the module server function

rv <- reactive({input$color.choice})
return(rv)

This creates a reactive and returns it. Note that you return the reactive itself, not the reactive's value.

Monitor the modules' return values in the main server

Modify the callModule calls to

tab1 <- callModule(serverModule, "tab_one")
tab2 <- callModule(serverModule, "tab_two")
tab3 <- callModule(serverModule, "tab_three")

All I've done here is assign the modules' return values to local variables in the main server function. They're reactives, so we can monitor them. Add the following lines to the main server function:

session$userData$settings <- reactiveValues(chosenColour=NA)
observeEvent(tab1(), {session$userData$settings$chosenColour <- tab1()})
observeEvent(tab2(), {session$userData$settings$chosenColour <- tab2()})
observeEvent(tab3(), {session$userData$settings$chosenColour <- tab3()})

You can put print calls inside each observeEvent to see what's going on. I did that whilst testing. I think session$userData is a much underused feature of shiny. Unsurprisingly, it's a section of the session object that's writable by the user. The main server function and all module server functions share the same session$userData object, so it's a neat way of passing information between modules.

I've assumed that you'll want to do more than just change the colour of the dots in your real world case, so I've created a settings object. I've made it reactive so that modules can react to changes in it.

Make the modules react to changes

Add the following code to the module server function

  observeEvent(
session$userData$settings$chosenColour,
{
if (!is.na(session$userData$settings$chosenColour))
updateSelectInput(
session,
"color.choice",
selected=session$userData$settings$chosenColour
)
}
)

[Again, put print calls in the observeEvent to check what's going on.]

And that's it.

As an aside, it's good practice always to add

ns <- session$ns

as the first line of your module server function. You don't need it right now, but it's likely you will. I've spent many hours chasing down a bug that's been due to "not needing" session$ns. Now I just do it by default to save the pain.

Here's the full listing of your modified MWE.

library(shiny)
library(shinydashboard)

dataPlotUI <- function(id) {
ns <- NS(id) # create namespace for entered ID
fluidRow(
box(plotOutput(ns("plot.1"), height = 400)),
box(
selectInput(
ns("color.choice"), "Color:",
c("darkcyan", "darkolivegreen", "deeppink", "lightsalmon2", "slateblue2", "springgreen3")
),
sliderInput(ns("range"), label = "Range", min = 10, max = 100, value = 50)
) # end box
)
}

# Module for Server
serverModule <- function(input, output, session, site) {
ns <- session$ns

output$plot.1 <- renderPlot({
x <- seq(1, input$range, 1) # use slider to set max of x
y <- x + rnorm(length(x), 0, 3)

par(mai = c(.6, .6, .1, .1), las = 1, bty = "l")
plot(y ~ x, pch = 20, col = input$color.choice)
})

observeEvent(session$userData$settings$chosenColour, {
if (!is.na(session$userData$settings$chosenColour)) updateSelectInput(session, "color.choice", selected=session$userData$settings$chosenColour)
})

rv <- reactive({input$color.choice})
return(rv)
}

# UI
ui <- dashboardPage(
dashboardHeader(title = "Menu"),
dashboardSidebar(
sidebarMenu(
id = "sidebar",
# Icons can be found: https://fontawesome.com/icons?d=gallery&m=free
menuItem("Tab Page 1", tabName = "tabA"),
menuItem("Tab Page 2", tabName = "tabB"),
menuItem("Tab Page 3", tabName = "tabC")
)
), # End Dashboard Sidebar
dashboardBody(
# Start with overall tabItems
tabItems(
tabItem(
tabName = "tabA",
dataPlotUI("tab_one")
),
#
tabItem(
tabName = "tabB",
dataPlotUI("tab_two")
),

tabItem(
tabName = "tabC",
dataPlotUI("tab_three")
)
)
) # end dashboard body
)

# Server
server <- function(input, output, session) {
session$userData$settings <- reactiveValues(chosenColour=NA)
tab1 <- callModule(serverModule, "tab_one")
tab2 <- callModule(serverModule, "tab_two")
tab3 <- callModule(serverModule, "tab_three")
# Module observers
observeEvent(tab1(), {session$userData$settings$chosenColour <- tab1()})
observeEvent(tab2(), {session$userData$settings$chosenColour <- tab2()})
observeEvent(tab3(), {session$userData$settings$chosenColour <- tab3()})
}

shinyApp(ui = ui, server = server)

Shiny - How to remember user input after click on refresh?

A native shiny approach is "live" bookmarking - please see ?updateQueryString

library(shiny)

ui = function(req) {
fluidPage(
textInput("caption", "Caption", "Data Summary"),
verbatimTextOutput("value")
)
}

server = function(input, output, session) {
observe({
# Trigger this observer every time an input changes
reactiveValuesToList(input)
session$doBookmark()
})
onBookmarked(function(url) {
updateQueryString(url)
})
output$value <- renderText({ input$caption })
}

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

Another approach would be to use use shiny's onSessionEnded callback to save the current state of the inputs e.g. via save() and load() them on session start - or using library(shinyStore) to save the inputs in the client browser's local storage:

# install.packages("devtools")
# library(devtools)
# install_github("trestletech/shinyStore")

library(shiny)
library(shinyStore)

ui <- fluidPage(
initStore("store", "myUniqueNamespace"),
textInput("caption", "Caption", "Data Summary"),
verbatimTextOutput("value")
)

server <- function(input, output, session) {
observeEvent(input$store$caption, {
freezeReactiveValue(input, "caption")
updateTextInput(session, "caption", value = input$store$caption)
})

observe({
updateStore(session, "caption", input$caption)
})

output$value <- renderText({ input$caption })
}
shinyApp(ui, server)

How to prevent output from running twice when inputs are inter-dependent?

Interesting problem and not easy to solve! Interestingly, what you are asking for is not what you need. Observation:

  1. If the user selects Qn2 while Input1 is "Mississippi", you first set Input1 on Quebec and then hard set Input2 on Qn1, changing the choise of the user. This is bad.
  2. Datatable is always updated once any of the two inputs changes, hence the many re-calculations of the table.

The solution therefore is twofold:

  1. Don't overwrite the user's choice of e.g. Qc2 to Qc1. I used an if condition for that.
  2. Install a watchguard to only update
    the datatable when its contents actually changed. I do this with a reactiveVal() that I only update when the choice of the two inputs was valid (i.e. when the result set is greater than 0).

See the result below. Watch the console output to observe the decisions.

library(shiny)
library(DT)
library(dplyr)
my_data=data.frame(CO2)

shinyApp(
ui = bootstrapPage(
selectInput('type','Choix du type',choices = unique(my_data$Type),selected=my_data$Type[1]),
selectInput('plant','Choix du plant',choices = unique(my_data$Plant),selected=my_data$Plant[1]),
DTOutput('plot')
),
server = function(input, output,session) {

latest_data <- reactiveVal(my_data)
observe({
result <- my_data %>% filter(Type %in% input$type, Plant %in% input$plant)

if(nrow(result) > 0){
latest_data(result)
}else{
cat(format(Sys.time(), "%H:%M:%S"), "Didn't update the dataframe because the choice was not valid.\n")
}
})

observeEvent(input$type,{
if(! input$plant %in% my_data$Plant[my_data$Type == input$type]){
old <- input$plant
new <- my_data %>% filter(Type %in% input$type) %>% slice(1) %>% pull(Plant) %>% as.character()
updateSelectInput(session, "plant", selected = new)
cat(format(Sys.time(), "%H:%M:%S"), "Updated input$plant from", old, "to", new, "so that it represents a valid choice for", input$type, "\n")
}else{
cat(format(Sys.time(), "%H:%M:%S"), "Didn't update input$plant", input$plant, "because it is a valid choice for", input$type, "already\n")
}
})
observeEvent(input$plant,{
updateSelectInput(session, "type",
selected = my_data %>% filter(Plant %in% input$plant) %>% slice(1) %>% pull(Type))
})

output$plot <- renderDT({
cat(format(Sys.time(), "%H:%M:%S"), "updating datatable to only include", isolate(input$plant), "and", isolate(input$type), "\n\n")
latest_data()
datatable(latest_data())
})
}
)

gif of solution

In R Shiny, how to maintain reactivity chain when an object in the chain is hidden from view?

You can do:

  output$secondInput <- renderUI({
req(input1())
secondInput("input2",input$input1[1,1])
})
outputOptions(output, "secondInput", suspendWhenHidden = FALSE)


EDIT

Another possibility is to use the CSS property visibility: hidden to hide the second input, instead of shinyjs::hidden (which sets the CSS property display: none). With this property, the second input is not visible but it takes up some space, it is not "strictly hidden".

ui <- fluidPage(
useShinyjs(),
tags$head(
tags$style(HTML(".Hidden {visibility: hidden;}"))
),
titlePanel("Model"),
sidebarLayout(
sidebarPanel(
uiOutput("panel"),
div(
id = "secondInputContainer",
class = "Hidden",
uiOutput("secondInput")
)
),
mainPanel(plotOutput("plot1"))
)
)

server <- function(input, output) {

# input1 <- reactive(input$input1) useless
# input2 <- reactive(input$input2) useless

output$panel <- renderUI({
tagList(
firstInput("input1"),
actionButton('show', 'Show 2nd inputs'),
actionButton('hide', 'Hide 2nd inputs'))
})

output$secondInput <- renderUI({
req(input$input1)
secondInput("input2", input$input1[1,1])
})

output$plot1 <-renderPlot({
req(input$input2)
plot(rep(input$input2, times=5))
})

observeEvent(input$show, {
removeCssClass("secondInputContainer", "Hidden")
})
observeEvent(input$hide, {
addCssClass("secondInputContainer", "Hidden")
})
}

R Shiny: keep old output

Here's an approach that works. It uses a reactiveValues object, and each time you click the "Fit Model" button, it appends the new model to the end of the list. The numeric input controls how many models to display on the screen. This preserves every model you fit in the session.

I didn't do the stargazer table because I'm not that familiar with it. But you should be able to adapt this pretty easily.

library(shiny)
library(broom)

shinyApp(
ui =
shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
checkboxGroupInput(inputId = "indep",
label = "Independent Variables",
choices = names(mtcars)[-1],
selected = NULL),
actionButton(inputId = "fit_model",
label = "Fit Model"),
numericInput(inputId = "model_to_show",
label = "Show N most recent models",
value = 2)
),
mainPanel(
htmlOutput("model_record")
)
)
)
),

server =
shinyServer(function(input, output, session){
Model <- reactiveValues(
Record = list()
)

observeEvent(
input[["fit_model"]],
{
fit <-
lm(mpg ~ .,
data = mtcars[c("mpg", input[["indep"]])])

Model$Record <- c(Model$Record, list(fit))
}
)

output$model_record <-
renderText({
tail(Model$Record, input[["model_to_show"]]) %>%
lapply(tidy) %>%
lapply(knitr::kable,
format = "html") %>%
lapply(as.character) %>%
unlist() %>%
paste0(collapse = "<br/><br/>")
})

})
)


Related Topics



Leave a reply



Submit