obtain the values from a checkboxgroup only once in shiny - r

I have made the following program:
ui.r
library(shiny)
shinyUI(fluidPage(
mainPanel(
textOutput("text1"),
checkboxGroupInput("checkGroup",
label = h3("Alternatives"),
choices = list("A" = 1,
"B" = 2,
"C" = 3,
"D" = 4),
selected = NULL),
actionButton("action", label = "Next")
)
))
server.r
library(shiny)
shinyServer(function(input, output) {
observe({
if(input$action>0 & input$action<=2){
valores<-renderText({
input$checkGroup
})
data<-unlist(strsplit(valores(), split=" "))
print(data)
}
})
})
I have managed to capture the values selected and put them into a vector, so I have solved an issue I got before.
The problem that I have now is that all the time it outputs which values I select or deselect from the checkbox groups, but I would like to only capture the last values selected after I press the Next button.
Any help? I have checked the documentation, but it is pretty scarce.

Here's one way to skin that cat.
We use isolate and reactive with the actionButton to ensure nothing is evaluated until the button is hit. By isolating the input itself from any further formatting we can call it any number of times for any purpose. Note that without the isolate it will evaluate as the inputs are changed.
server.R
library(shiny)
shinyServer(function(input, output) {
# store as a vector to be called wherever desired
# evaluated whenever inputs change
datasetInput <- reactive({
perm.vector <- as.vector(input$checkGroup)
perm.vector
})
# call as a text output
output$textOut <- renderText({
input$action # makes sure nothing moves till the button is hit
# isolate prevents datasetInput from reactively evaluating
isolate(datasetInput())
})
# call in a different place as a data table output
output$dataTableOut <- renderDataTable({
input$action # makes sure nothing moves till the button is hit
isolate(df <- data.frame(inputs = datasetInput()))
df
}, options = list(
lengthMenu = list(c(5, 15, -1), c('5', '15', 'All')),
pageLength = 15)
)
})
ui.R
library(shiny)
shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
checkboxGroupInput("checkGroup",
label = h3("Alternatives"),
choices = list("A" = 1,
"B" = 2,
"C" = 3,
"D" = 4),
selected = NULL),
actionButton("action", label = "Next")
),
mainPanel(
h4("Print as text"), textOutput("textOut"),
h4("Print as data table"), dataTableOutput("dataTableOut")
)
)
))

I found in: http://www.inside-r.org/packages/cran/shiny/docs/isolate
that it was possible to isolate a group of sentences, so the following works nicely:
library(shiny)
shinyServer(function(input, output) {
observe({
if(input$action>0 & input$action<=2){
isolate({
values<-renderText({
input$checkGroup
})
data<-unlist(strsplit(valores(), split=" "))
print(data)
})
}
})
})

Related

How to add a spinner before a selectizeInput has loaded all the choices? [Shiny]

I want to make an app with 2 actionButtons: 1) to submit the changes before loading a selectizeInput and 2) to draw the plot.
I know how to add a spinner after clicking a actionButton but the majority of the cases is added when you want to show the plot.
However, is it possible to add a spinner without showing any plot?
In this particular case, I want to show a spinner after clicking "Submit" until the selectizeInput from the 'Selection tab' is loaded. As you can see the example that I attach, it takes a bit to load all the choices (since the file has 25000 rows).
I already have one spinner after clicking the second actionButton (Show the plot) but I need one more.
I have created an example, but for some reason the plot is not shown in the shiny app and it appears in the window from R (I don't know why but I added the plot just to show you how I put the second spinner. I want a similar one but with the first actionButton.).
library(shiny)
library(shinycssloaders)
ui <- fluidPage(
titlePanel("My app"),
sidebarLayout(
sidebarPanel(
tabsetPanel(
tabPanel("Submit",
checkboxInput("log2", "Log2 transformation", value = FALSE),
actionButton("submit", "Submit")
),
tabPanel("Selection",
br(),
selectizeInput(inputId = "numbers", label = "Choose one number:", choices=character(0)),
actionButton("show_plot", "Show the plot")
))
),
mainPanel(
conditionalPanel(
condition = "input.show_plot > 0",
style = "display: none;",
withSpinner( plotOutput("hist"),
type = 5, color = "#0dc5c1", size = 1))
)
)
)
server <- function(input, output, session) {
data <- reactive({
data = read.csv("https://people.sc.fsu.edu/~jburkardt/data/csv/hw_25000.csv")
data[,1] <- as.character(data[,1])
if(input$log2 == TRUE){
cols <- sapply(data, is.numeric)
data[cols] <- lapply(data[cols], function(x) log2(x+1))
}
return(data)
})
mylist <- reactive({
req(data())
data <- data()
data <- data[,1]
return(data)
})
# This is to generate the choices (gene list) depending on the user's input.
observeEvent(input$submit, {
updateSelectizeInput(
session = session,
inputId = "numbers",
choices = mylist(), options=list(maxOptions = length(mylist()))
)
})
v <- reactiveValues()
observeEvent(input$show_plot, {
data <- data()
v$plot <- plot(x=data[,1], y=data[,2])
})
# If the user didn't choose to see the plot, it won't appear.
output$hist <- renderPlot({
req(data())
if (is.null(v$plot)) return()
if(input$show_plot > 0){
v$plot
}
})
}
Does anyone know how to help me, please?
Thanks very much
It's a little tricky.
First of all I'd update the selectizeInput on the server side as the warning suggests:
Warning: The select input "numbers" contains a large number of
options; consider using server-side selectize for massively improved
performance. See the Details section of the ?selectizeInput help
topic.
Furthermore I switched to ggplot2 regarding the plotOutput - Please see this related post.
To show the spinner while the selectizeInput is updating choices we'll need to know how long the update takes. This information can be gathered via shiny's JS events - please also see this article.
Finally, we can show the spinner for a non-existent output, so we are able to control for how long the spinner is shown (see uiOutput("dummyid")):
library(shiny)
library(shinycssloaders)
library(ggplot2)
ui <- fluidPage(
titlePanel("My app"),
tags$script(HTML(
"
$(document).on('shiny:inputchanged', function(event) {
if (event.target.id === 'numbers') {
Shiny.setInputValue('selectizeupdate', true, {priority: 'event'});
}
});
$(document).on('shiny:updateinput', function(event) {
if (event.target.id === 'numbers') {
Shiny.setInputValue('selectizeupdate', false, {priority: 'event'});
}
});
"
)),
sidebarLayout(
sidebarPanel(
tabsetPanel(
tabPanel("Submit",
checkboxInput("log2", "Log2 transformation", value = FALSE),
actionButton("submit", "Submit")
),
tabPanel("Selection",
br(),
selectizeInput(inputId = "numbers", label = "Choose one number:", choices=NULL),
actionButton("show_plot", "Show the plot")
))
),
mainPanel(
uiOutput("plotProxy")
)
)
)
server <- function(input, output, session) {
previousEvent <- reactiveVal(FALSE)
choicesReady <- reactiveVal(FALSE)
submittingData <- reactiveVal(FALSE)
observeEvent(input$selectizeupdate, {
if(previousEvent() && input$selectizeupdate){
choicesReady(TRUE)
submittingData(FALSE)
} else {
choicesReady(FALSE)
}
previousEvent(input$selectizeupdate)
})
data <- reactive({
data = read.csv("https://people.sc.fsu.edu/~jburkardt/data/csv/hw_25000.csv")
if(input$log2 == TRUE){
cols <- sapply(data, is.numeric)
data[cols] <- lapply(data[cols], function(x) log2(x+1))
}
return(data)
})
mylist <- reactive({
req(data()[,1])
})
observeEvent(input$submit, {
submittingData(TRUE)
reactivePlotObject(NULL) # reset
updateSelectizeInput(
session = session,
inputId = "numbers",
choices = mylist(), options=list(maxOptions = length(mylist())),
server = TRUE
)
})
reactivePlotObject <- reactiveVal(NULL)
observeEvent(input$show_plot, {
reactivePlotObject(ggplot(data(), aes_string(x = names(data())[1], y = names(data())[2])) + geom_point())
})
output$hist <- renderPlot({
reactivePlotObject()
})
output$plotProxy <- renderUI({
if(submittingData() && !choicesReady()){
withSpinner(uiOutput("dummyid"), type = 5, color = "#0dc5c1", size = 1)
} else {
conditionalPanel(condition = "input.show_plot > 0", withSpinner(plotOutput("hist"), type = 5, color = "#0dc5c1", size = 1), style = "display: none;")
}
})
}
shinyApp(ui, server)
First 100 rows of your example data (dput(head(data, 100)) - your link might be offline some day):
structure(list(Index = 1:100, Height.Inches. = c(65.78331, 71.51521,
69.39874, 68.2166, 67.78781, 68.69784, 69.80204, 70.01472, 67.90265,
66.78236, 66.48769, 67.62333, 68.30248, 67.11656, 68.27967, 71.0916,
66.461, 68.64927, 71.23033, 67.13118, 67.83379, 68.87881, 63.48115,
68.42187, 67.62804, 67.20864, 70.84235, 67.49434, 66.53401, 65.44098,
69.5233, 65.8132, 67.8163, 70.59505, 71.80484, 69.20613, 66.80368,
67.65893, 67.80701, 64.04535, 68.57463, 65.18357, 69.65814, 67.96731,
65.98088, 68.67249, 66.88088, 67.69868, 69.82117, 69.08817, 69.91479,
67.33182, 70.26939, 69.10344, 65.38356, 70.18447, 70.40617, 66.54376,
66.36418, 67.537, 66.50418, 68.99958, 68.30355, 67.01255, 70.80592,
68.21951, 69.05914, 67.73103, 67.21568, 67.36763, 65.27033, 70.84278,
69.92442, 64.28508, 68.2452, 66.35708, 68.36275, 65.4769, 69.71947,
67.72554, 68.63941, 66.78405, 70.05147, 66.27848, 69.20198, 69.13481,
67.36436, 70.09297, 70.1766, 68.22556, 68.12932, 70.24256, 71.48752,
69.20477, 70.06306, 70.55703, 66.28644, 63.42577, 66.76711, 68.88741
), Weight.Pounds. = c(112.9925, 136.4873, 153.0269, 142.3354,
144.2971, 123.3024, 141.4947, 136.4623, 112.3723, 120.6672, 127.4516,
114.143, 125.6107, 122.4618, 116.0866, 139.9975, 129.5023, 142.9733,
137.9025, 124.0449, 141.2807, 143.5392, 97.90191, 129.5027, 141.8501,
129.7244, 142.4235, 131.5502, 108.3324, 113.8922, 103.3016, 120.7536,
125.7886, 136.2225, 140.1015, 128.7487, 141.7994, 121.2319, 131.3478,
106.7115, 124.3598, 124.8591, 139.6711, 137.3696, 106.4499, 128.7639,
145.6837, 116.819, 143.6215, 134.9325, 147.0219, 126.3285, 125.4839,
115.7084, 123.4892, 147.8926, 155.8987, 128.0742, 119.3701, 133.8148,
128.7325, 137.5453, 129.7604, 128.824, 135.3165, 109.6113, 142.4684,
132.749, 103.5275, 124.7299, 129.3137, 134.0175, 140.3969, 102.8351,
128.5214, 120.2991, 138.6036, 132.9574, 115.6233, 122.524, 134.6254,
121.8986, 155.3767, 128.9418, 129.1013, 139.4733, 140.8901, 131.5916,
121.1232, 131.5127, 136.5479, 141.4896, 140.6104, 112.1413, 133.457,
131.8001, 120.0285, 123.0972, 128.1432, 115.4759)), row.names = c(NA,
100L), class = "data.frame")

Why the selectInput() does not work correctly when multipe = TRUE?

I want to get the items that were selected from selectInput(). However, it seems only the first item could be transferred to server().
The UI:
sidebarLayout(
sidebarPanel(width = 4,
selectInput("cell_marker_density_surv", "Cell type", choices = cell_list,
selected = colnames(density)[1:3], multiple = TRUE),
textOutput("warning_density_roc_1"),
),
mainPanel(width = 8,
)
)
The server()
warning_density_roc_1_output <- reactive({
a = input$cell_marker_density_surv
paste0(input$cell_marker_density_surv, collapse = ",")
})
output$warning_density_roc_1 <- renderText(warning_density_roc_1_output())
As we can see, only the first item showed, even in the default situation.
enter image description here
I have realized that there are many questions related to these problems, but I do not know how to solve it. Is it caused by the selectInput() function itself? In fact, I want to give back a warning when the selected inputs are more than five, so I need to know how many items were selected. Could you help me? Thank you!
The following is the code modified based on the first answers:
library(shiny)
mpg <- ggplot2::mpg
library(shinyFeedback)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
width = 4,
textOutput("warning_density_roc_1"),
selectInput("cell_marker_density_surv", "Cell type",
choices = names(mpg),
selected = names(mpg)[1:6], multiple = TRUE
)
),
mainPanel(width = 8, )
)
)
server <- function(input, output, session) {
warning_density_roc_1_output <- reactive({
print(length(input$cell_marker_density_surv))
num_input_density_roc <- if(length(input$cell_marker_density_surv) > 5) {
print("TRUE")
TRUE
} else {
print("FALSE")
FALSE
}
num_input_density_roc
feedbackWarning("cell_marker_density_surv", num_input_density_roc, "Warning, more than five items selected.")
})
output$warning_density_roc_1 <- renderText(warning_density_roc_1_output())
}
shinyApp(ui, server)
However, the feedbackWarning() could not work correctly.
Edit: Using shinyFeedback::feedbackWarning().
library(shiny)
library(shinyFeedback)
mpg <- ggplot2::mpg
ui <- fluidPage(
shinyFeedback::useShinyFeedback(),
sidebarLayout(
sidebarPanel(
width = 4,
# textOutput("warning_density_roc_1"),
selectInput("cell_marker_density_surv", "Cell type",
choices = names(mpg),
selected = names(mpg)[1:6], multiple = TRUE
)
),
mainPanel(width = 8, )
)
)
server <- function(input, output, session) {
observeEvent(input$cell_marker_density_surv, {
shinyFeedback::feedbackWarning(
"cell_marker_density_surv",
length(input$cell_marker_density_surv) > 5,
"Warning, more than five items selected."
)
})
}
shinyApp(ui, server)
Old answer:
Maybe this can help, I used mpg dataset as dummy data.
library(shiny)
mpg <- ggplot2::mpg
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
width = 4,
textOutput("warning_density_roc_1"),
selectInput("cell_marker_density_surv", "Cell type",
choices = names(mpg),
selected = names(mpg)[1:6], multiple = TRUE
)
),
mainPanel(width = 8, )
)
)
server <- function(input, output, session) {
warning_density_roc_1_output <- reactive({
if (length(input$cell_marker_density_surv) > 5) {
"Warning, more than five items selected."
}
})
output$warning_density_roc_1 <- renderText(warning_density_roc_1_output())
}
shinyApp(ui, server)

R shiny: Cannot delete last value in SelectizeInput

I have a very simple question:
Why is it in the following code not possible to remove the last entered value in SelectizeInput? E.g. I entered "a" "b" & "c" and I want to delete them all afterwards from the SelectizeInput. Why is it no possible to remove the last remaing value from SelectizeInput?
library(shiny)
ui <- bootstrapPage(
textInput(inputId = "txtinput", label = "Insert label", value = "", placeholder = ""),
actionButton(inputId = "actbtn", label = "Add label"),
uiOutput('selctInput')
)
server <- function(input, output, session){
#Create reactive values
rv <- reactiveValues()
#When Button is clicked..
observeEvent(input$actbtn, {
#Save value in a reactiveValues list
rv$new.label <- input$txtinput
#Collect all entries from text input
rv$labels <- c(rv$labels, rv$new.label)
#Clear textinput
updateTextInput(session, "txtinput", value = "")
})
#When selectizeInput changes...
observeEvent(input$selctInput, {
#Why is it not possible to completely empty selectizeInput? The last value just remains.
rv$labels <- input$selctInput
print(input$selctInput)
})
#Add selectizeInput to UI
output$selctInput <- renderUI({
selectizeInput(inputId = "selctInput", label= "Reorder / delete labels",
choices = rv$labels,
selected = rv$labels, multiple=TRUE,
options = list(plugins = list('remove_button', 'drag_drop')))
})
}
shinyApp(ui, server)
You just need to add ignoreNULL = FALSE to your observeEvent so that it "reacts" to the NULL value
#When selectizeInput changes...
observeEvent(input$selctInput, {
#Why is it not possible to completely empty selectizeInput? The last value just remains.
rv$labels <- input$selctInput
print(input$selctInput)
}, ignoreNULL = FALSE)
Update:
After finding this link https://gist.github.com/pvictor/ee154cc600e82f3ed2ce0a333bc7d015 there seems to be a far simpler approach:
library(shiny)
ui <- fluidPage(
selectizeInput("select", "Select", c(),
multiple = TRUE, options = list(
'plugins' = list('remove_button'),
'create' = TRUE,
'persist' = FALSE)
),
textOutput("out")
)
server <- function(input, output){
output$out <- renderText({
input$select
})
}
shinyApp(ui, server)

Collect All user inputs throughout the Shiny App

Is there a way to show the value from textInput() elsewhere in the UI without having to go through server.R with something very verbose like the following?
ui.R
library(shiny)
shinyUI(
fluidPage(
textInput('text_in', label = 'Write text here'),
# elsewhere in the UI...
textOutput('text_out')
))
server.R
library(shiny)
shinyServer(function(input, output) {
output$text_out = renderText(input$text_in)
})
It's not too bad for this example, but it becomes very verbose when I need to do it many times. My desire is to collect all the inputs the user enters throughout the app and compile them into a nice table at the end so they can confirm everything is laid out right.
I've seen you can reference input elements without going through the server when using a JavaScript expression in conditionalPanel() but I'm not sure how to implement that outside of this specific instance.
For accessing all inputs, you can use reactiveValuesToList server-side. You can access input values via Javascript Events like below (I have taken the example from #Pork Chop) :
library(shiny)
ui <- basicPage(
fluidRow(
column(
width = 6,
textInput('a', 'Text A',"a1"),
textInput('b', 'Text B',"b1"),
textInput('c', 'Text A',"c1"),
textInput('d', 'Text B',"d1"),
textInput('e', 'Text A',"e1"),
textInput('f', 'Text B',"f1")
),
column(
width = 6,
tags$p("Text A :", tags$span(id = "valueA", "")),
tags$script(
"$(document).on('shiny:inputchanged', function(event) {
if (event.name === 'a') {
$('#valueA').text(event.value);
}
});
"
),
tableOutput('show_inputs')
)
)
)
server <- shinyServer(function(input, output, session){
AllInputs <- reactive({
x <- reactiveValuesToList(input)
data.frame(
names = names(x),
values = unlist(x, use.names = FALSE)
)
})
output$show_inputs <- renderTable({
AllInputs()
})
})
shinyApp(ui = ui, server = server)
Since your overall objective is to collect all the user inputs and then compile them into a table I will show you how to achieve that with example below. As you can see all of the input variables can be accessed by names from server. I kept them in a reactive just in case you need it for further analysis or for some renderUI functionality.
#rm(list=ls())
library(shiny)
ui <- basicPage(
textInput('a', 'Text A',"a1"),
textInput('b', 'Text B',"b1"),
textInput('c', 'Text A',"c1"),
textInput('d', 'Text B',"d1"),
textInput('e', 'Text A',"e1"),
textInput('f', 'Text B',"f1"),
tableOutput('show_inputs')
)
server <- shinyServer(function(input, output, session){
AllInputs <- reactive({
myvalues <- NULL
for(i in 1:length(names(input))){
myvalues <- as.data.frame(rbind(myvalues,(cbind(names(input)[i],input[[names(input)[i]]]))))
}
names(myvalues) <- c("User Input","Last Value")
myvalues
})
output$show_inputs <- renderTable({
AllInputs()
})
})
shinyApp(ui = ui, server = server)
If the Shiny inputs all have different lengths and the above does not work (e.g. if you have combination of radio buttons, checkboxgroup, textInput, etc.) this will work and can produce a table of variable:value that you can parse later:
AllInputs <- reactive({
myvalues <- NULL
newvalues <- NULL
for(i in 1:length(names(input))){
newvalues <- paste(names(input)[i], input[[names(input)[i]]], sep=":")
myvalues <- append(myvalues, newvalues)
}
myvalues
})
output$show_inputs <- renderTable({
AllInputs()
})
Borrowing from both Pork Chop and mysteRious, here's a solution that works for multiple types of text & number inputs in shiny.
library(shiny)
AdvRchp3 <- "While you’ve probably already used many (if not all)
of the different types of vectors, you may not have thought
deeply about how they’re interrelated. In this chapter,
I won’t cover individual vectors types in too much detail,
but I will show you how all the types fit together as a whole.
If you need more details, you can find them in R’s documentation."
ui <- fluidPage(
fluidRow(
h4("Text Inputs"),
textInput("text_input", "Input some Text", value = "some text"),
passwordInput("password_input", "Input a Password", value = "1234"),
textAreaInput("text_area_input", "Input lots of Text", rows = 3, value = AdvRchp3)
),
fluidRow(
h4("Numeric Inputs"),
numericInput("numeric_input", "Number 1", value = 1, min = 0, max = 100),
sliderInput("slider_input_single", "Number 50", value = 50, min = 0, max = 100),
sliderInput("slider_input_ranges", "Range 10 to 20", value = c(10, 20), min = 0, max = 100)
),
fluidRow(
tableOutput("show_inputs")
)
)
server <- function(input, output, session) {
all_inputs <- reactive({
input_df <- NULL
df_row <- NULL
for(i in 1:length(names(input))){
df_row <- as.data.frame(cbind(names(input)[i], input[[names(input)[i]]]))
input_df <- as.data.frame(dplyr::bind_rows(input_df, df_row))
}
names(input_df) <- c("input_id", "input_val")
input_df
})
output$show_inputs <- renderTable({
all_inputs()
})
}
shinyApp(ui, server)
notice: the rbind is now dplyr::bind_rows, but plyr::rbind.fill will also work.

Multiple reactiveValues In a Shiny App

I use reactiveValues in Shiny a lot as they are more flexible than just the input and output objects. Nested reactiveValues are tricky since any changes in any of the children also triggers the reactivity linked to the parents. To get around this, I tried to make two different reactiveValues objects ( not two objects in the same list, but two different lists altogether ) and it seems to be working. I'm not able to find any example of this and want to find out if it's suppose to work this way. Are there any issues that might arise because of this?
In this app, there are two reactive values objects - reac1 and reac2. Each of them are linked to a drop down, column1 and column2 respectively. Changing column1 or column2 updates the reactive values with the latest time, updates the plot, and prints the latest values in reac1 and reac2.
ui = fluidPage(
titlePanel("Multiple reactive values"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "column1", "Reac1", letters, selected = "a"),
selectInput(inputId = "column2", "Reac2", letters, selected = "a")
),
mainPanel(
plotOutput("plot1")
)
)
)
server = function(input, output, session) {
reac1 <- reactiveValues(asdasd = 0)
reac2 <- reactiveValues(qweqwe = 0)
# If any inputs are changed, set the redraw parameter to FALSE
observe({
input$column2
reac2$qweqwe = Sys.time()
})
observe({
input$column1
reac1$asdasd = Sys.time()
})
# Only triggered when the copies of the inputs in reac are updated
# by the code above
output$plot1 <- renderPlot({
print(paste(reac1$asdasd, 'reac1'))
print(paste(reac2$qweqwe, 'reac2'))
hist(runif(1000))
})
}
shinyApp(ui, server)
ReactiveValues are like a read/write version of input$, and you can have several 'independent' variables inside one reactiveValue list. So, you do not need two reactive values in your example. See code below.
ui = fluidPage(
titlePanel("Multiple reactive values"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "column1", "Reac1", letters, selected = "a"),
selectInput(inputId = "column2", "Reac2", letters, selected = "a")
),
mainPanel(
verbatimTextOutput("txt1"),
verbatimTextOutput("txt2")
)
)
)
server = function(input, output, session) {
reac <- reactiveValues()
#reac2 <- reactiveValues(qweqwe = 0)
# If any inputs are changed, set the redraw parameter to FALSE
observe({
reac$asdasd = input$column1
})
observe({
reac$qweqwe = input$column2
})
# Only triggered when the copies of the inputs in reac are updated
# by the code above
output$txt1 <- renderPrint({
print('output 1')
print(paste(reac$asdasd, 'reac1'))
})
output$txt2 <- renderPrint({
print('output2')
print(paste(reac$qweqwe, 'reac2'))
})
}
shinyApp(ui, server)

Resources