I just started hacking around with Shiny a few days ago.
In my little toy app, the user types a list of comma-separated numbers into a text area and presses the submit button. It then calculates and displays the sum, mean and median of those numbers.
The shinyServer functions that calculate the sum, mean and median all call a function named my_array() that uses strsplit to separate the numbers at the commas and returns a numeric list.
Rather than call my_array() three times, I'd like to call my_array() once after the Submit button has been clicked and save the result globally. Then I'll use that global list to calculate sum, mean and median.
Can someone clue me in as to how I can call my_array() once after submit is hit, and save the result in a global variable? Nothing I'm trying works, and the examples I've seen don't seem to address what I need.
Thanks.
server.R
shinyServer(function(input, output) {
my_array <- reactive ({
number_array <- strsplit(input$text, ",")
as.numeric(number_array[[1]])
})
my_sum <- reactive({
sum(my_array())
})
my_mean <- reactive({
val <- mean(my_array(), na.rm=TRUE)
if (is.nan(val)) {
val = ""
} else {
val
}
})
my_median <- reactive({
val <- median(my_array(), na.rm=TRUE)
if (is.na(val)) {
val = ""
} else {
val
}
})
output$sum <- renderText({ my_sum() })
output$mean <- renderText({ my_mean() })
output$median <- renderText({ my_median() })
})
ui.R
shinyUI(fluidPage(
titlePanel("Average Calculator"),
tags$style(type="text/css", "textarea {width:100%}"),
tags$textarea(id = 'text', placeholder = 'Enter comma-separated numbers here', rows = 8, ""),
submitButton("Submit"),
hr(),
fluidRow(column(2, strong("Sum:"), align="right"), column(3, textOutput("sum"))),
fluidRow(column(2, strong("Mean:"), align="right"), column(3, textOutput("mean"))),
fluidRow(column(2, strong("Median:"), align="right"), column(3, textOutput("median"))),
))
As #zero323 said, the result is already cached, but if you really want to, you can use observeEvent() to fire off when you press the button:
observeEvent(input$your_button_id, {
number_array <- strsplit(input$text, ",")
as.numeric(number_array[[1]])
})
This will fire only once every time you press the button. You might also want to check for NULL or "" variables.
Related
I am working on a shiny app that can generate a determined number of UI outputs in form of inputs based on a value defined by the user. Thanks to the help of #YBS I was able to get the app working. But now I face a new issue. Although I could define min and max value for the inputs generated, I would like to add a warning in the inputs when a value is greater than 100, I found shinyfeedback package can do this but I do not where to put properly the code or what to do in the case of dynamic inputs like the ones generated here.
This is the working app:
library(shiny)
library(shinydashboard)
library(DT)
library(shinyFeedback)
#Function
compute <- function(firstitem,seconditem)
{
Sum <- firstitem+seconditem
Difference <- firstitem+seconditem
Product <- firstitem*seconditem
Ratio <- firstitem/seconditem
Res <- data.frame(C1=Sum,C2=Difference,C3=Product,C4=Ratio)
return(Res)
}
#App
ui = shinyUI(fluidPage(
titlePanel("Compare"),
sidebarLayout(
sidebarPanel(
numericInput("numitems", label = "Number of items to compare?",
min = 1, max = 100, value = 1),
uiOutput("period_cutpoints"),
uiOutput("period_cutpoints2"),
actionButton("submit", "Submit")
),
mainPanel(
uiOutput("t1")
)
)
))
server = shinyServer(function(input, output, session) {
output$period_cutpoints<-renderUI({
req(input$numitems)
lapply(1:(input$numitems), function(i) {
numericInput(inputId=paste0("firstitem",i),
label=paste0("Enter the value of first item ", i, ":"),value = i)
})
})
output$period_cutpoints2<-renderUI({
req(input$numitems)
lapply(1:(input$numitems), function(i) {
numericInput(inputId=paste0("seconditem",i),
label=paste0("Enter the value of second item ", i, ":"),value = i+i)
})
})
seldates <- reactiveValues(x=NULL)
observeEvent(input$submit, {
seldates$x <- list()
lapply(1:(input$numitems), function(i) {
seldates$x[[i]] <- compute(firstitem = input[[paste0("firstitem", i)]],seconditem = input[[paste0("seconditem", i)]])
})
})
observeEvent(input$submit, {
lapply(1:(input$numitems), function(i) {
output[[paste0("table",i)]] <- renderDT(seldates$x[[i]])
})
output$t1 <- renderUI({
tagList(
lapply(1:(input$numitems), function(i) {
DTOutput(paste0("table",i))
})
)
})
})
})
shinyApp(ui = ui , server = server)
I tried to add some code inside the dynamic inputs in this way:
#Code demo
output$period_cutpoints<-renderUI({
req(input$numitems)
lapply(1:(input$numitems), function(i) {
numericInput(inputId=paste0("firstitem",i),
label=paste0("Enter the value of first item ", i, ":"),value = i)
})
lapply(1:(input$numitems), function(i) {
observeEvent(input[[paste0('firstitem',i)]], {
shinyFeedback::feedbackWarning(
inputId = paste0('firstitem',i),
show = input[[paste0('firstitem',i)]] > 100,
text = "Number less than 100 required.",
color="red"
)
})
})
})
Unfortunately, this action broke down the app:
And the first input was not generated as you can see.
How can I solve this issue so that I can have warnings when the value is greater than 100? Moreover, this leads to an additional fact, in the action button if working with multiple inputs generated dynamically, how could I do something like this:
#How to extend the if condition so that it can consider the number of inputs defined by the user
observeEvent(input$submit,
{
if(input$firstitem1 < 0 && input$seconditem1 < 0 && input$firstitem2<0 && input$seconditem1<0)
{
showModal(modalDialog(title ="Warning!!!", "Check fields!!!",easyClose = T))
}
else
{
showModal(modalDialog(title ="Congratulations!!!", "Computing Done!!!",easyClose = T))
}
})
How could I change the if so that it considers all the inputs that can be generated.
Many thanks!
I think you have a couple of problems here.
First, you have forgotten to add useShinyFeedback() to your UI definition.
ui = shinyUI(
fluidPage(
useShinyFeedback(),
titlePanel("Compare"),
...
Second, you've put the observeEvents that monitor your first item values inside your renderUI. That's not going to work: R's standard scoping means that these observeEvents won't be available to monitor changes in the corresponding input widgets. The solution is to create a separate observeEvent to create your observers on the inputs:
observeEvent(input$numitems, {
lapply(1:(input$numitems), function(i) {
observeEvent(input[[paste0('firstitem',i)]], {
shinyFeedback::feedbackWarning(
inputId = paste0('firstitem',i),
show = input[[paste0('firstitem',i)]] > 100,
text = "Number less than 100 required.",
color="red"
)
})
})
})
Making these changes gives me, for example,
With regard to your final question about the Submit actionButton, and as a general observation, I think your life will be much easier if you use Shiny modules to solve this problem. This will allow you to delegate the error checking to the indivudual modules and remove the need to continually loop through the indices of the dynamic inputs. This will lead to shorter, simpler, and more understandable code.
One thing to bear in mind if you do this: make sure you put a call to useShinyFeedback in the definition of the module UI.
I want to collect user inputs, and output them as a table/data frame within Shiny. Inspired by the post here (Collect All user inputs throughout the Shiny App), I was able to do this but with some issues below. Here I have attached the example code, where I intend to collect the user input using the reactive textInput box. The number of textInput boxes is according to the user input for "Number of box". The output table looks fine when I kept increasing the "Number of box", such as I increased the number of boxes from 1 to 2 (see attached screenshot 1 and 2). However, when I changed the number of boxes from 2 back to 1, the output table still showed the previous results "textBox2 the second input" (see screenshot 3). My question is how to remove this previous input ("textBox2 the second input") and only print out the current user input. Thanks!
Example code
library(shiny)
ui <- basicPage(
fluidRow(column(6,
numericInput("nbox", "Number of box", value = 1,
min = 1))),
fluidRow(column(6,style='padding:0px;',
wellPanel(
uiOutput("textInputBox"))),
column(6, style='padding:0px;',
tableOutput('show_inputs')))
)
server <- shinyServer(function(input, output, session){
output$textInputBox <- renderUI({
num <- as.integer(input$nbox)
lapply(1:num, function(i) {
textInput(paste0("textBox", i),
label = paste0("textBox", i))
})
})
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 variable","User input value")
myvalues
})
output$show_inputs <- renderTable({
AllInputs()
})
})
shinyApp(ui = ui, server = server)
Screen shot (1,2,3 in order)
Created inputs are not deleted when a new renderUI is called, so there is no solution this way.
A workaround is to use a counter (like the one previously used to create the input) and use it to rebuild the names:
AllInputs <- reactive({
num <- as.integer( input$nbox )
my_names <- paste0("textBox", 1:num)
all_values <- stack( reactiveValuesToList(input) )
myvalues <- all_values[ all_values$ind %in% c("nbox", my_names),
c(2, 1)]
names(myvalues) <- c("User input variable","User input value")
myvalues
})
Note the use of reactiveValuesToList to replace the loop.
In my tiny Shiny app I am asking the user: how many time periods do you want to cut your time series into? For example, the user selects 3.
I want to use this input to take a fixed vector of dates and make it possible for the user the select from it the desired last date of Time Period 1 (in select box 1), and Time Period 2 (in select box 2). (The last date for time period 3 will be the very last date, so I don't need to ask).
I am not sure how to do it. I understand that because I don't know the desired number of time periods in advance, I have to create a list. But how do I then collect the input from those select boxes?
Thanks a lot!
library(shiny)
### UI #######################################################################
ui = shinyUI(fluidPage(
titlePanel("Defining time periods"),
# Sidebar:
sidebarLayout(
sidebarPanel(
# Slider input for the number of time periods:
numericInput("num_periodsnr", label = "Desired number of time periods?",
min = 1, max = 10, value = 2),
uiOutput("period_cutpoints")
),
# Show just the number of periods so far.
mainPanel(
textOutput("nr_of_periods")
)
)
))
### SERVER ##################################################################
server = shinyServer(function(input, output, session) {
library(lubridate)
output$nr_of_periods <- renderPrint(input$num_periodsnr)
# Define our dates vector:
dates <- seq(ymd('2016-01-02'), ymd('2017-12-31'), by = '1 week')
# STUCK HERE:
# output$period_cutpoints<-renderUI({
# list.out <- list()
# for (i in 1:input$num_periodsnr) {
# list.out[[i]] <- renderPrint(paste0("Sometext", i), ,
# )
# }
# return(list.out)
# })
})
# Run the application
shinyApp(ui = ui, server = server)
This is similar to a question I asked and subsequently worked out an answer to here. The big changes are (predictably) in the server.
Nothing needs to change in the UI, but as you'll see below I've included another textOutput so that you can see the dates you end up selecting, and I've also added an actionButton, which I'll explain later.
The server function has a couple additions, which I'll describe first and then put together at the end. You're right that you need to create a list of input objects inside the renderUI, which you can do through lapply. At this step, you're creating as many selectInputs as you'll have cutpoints, minus one because you say you don't need the last:
output$period_cutpoints<-renderUI({
req(input$num_periodsnr)
lapply(1:(input$num_periodsnr-1), function(i) {
selectInput(inputId=paste0("cutpoint",i),
label=paste0("Select cutpoint for Time Period ", i, ":"),
choices=dates)
})
})
Next, you'll need to access the values selected in each, which you can do in the same way, using a reactiveValues object you create first, and assign the new values to it. In my version of this problem, I couldn't figure out how to get the list to update without using an actionButton to trigger it. Simple reactive() or observe() doesn't do the trick, but I don't really know why.
seldates <- reactiveValues(x=NULL)
observeEvent(input$submit, {
seldates$x <- list()
lapply(1:(input$num_periodsnr-1), function(i) {
seldates$x[[i]] <- input[[paste0("cutpoint", i)]]
})
})
Full working app code then looks like this:
library(shiny)
ui = shinyUI(fluidPage(
titlePanel("Defining time periods"),
sidebarLayout(
sidebarPanel(
numericInput("num_periodsnr", label = "Desired number of time periods?",
min = 1, max = 10, value = 2),
uiOutput("period_cutpoints"),
actionButton("submit", "Submit")
),
mainPanel(
textOutput("nr_of_periods"),
textOutput("cutpoints")
)
)
))
server = shinyServer(function(input, output, session) {
library(lubridate)
output$nr_of_periods <- renderPrint(input$num_periodsnr)
dates <- seq(ymd('2016-01-02'), ymd('2017-12-31'), by = '1 week')
output$period_cutpoints<-renderUI({
req(input$num_periodsnr)
lapply(1:(input$num_periodsnr-1), function(i) {
selectInput(inputId=paste0("cutpoint",i),
label=paste0("Select cutpoint for Time Period ", i, ":"),
choices=dates)
})
})
seldates <- reactiveValues(x=NULL)
observeEvent(input$submit, {
seldates$x <- list()
lapply(1:(input$num_periodsnr-1), function(i) {
seldates$x[[i]] <- input[[paste0("cutpoint", i)]]
})
})
output$cutpoints <- renderText({as.character(seldates$x)})
})
shinyApp(ui = ui, server = server)
you can make the boxes dynamically inside an lapply and send them as 1 output object to the ui
require("shiny")
require('shinyWidgets')
ui = shinyUI(fluidPage(
titlePanel("Defining time periods"),
# Sidebar:
sidebarLayout(
sidebarPanel(
# Slider input for the number of time periods:
numericInput("num_periodsnr", label = "Desired number of time periods?",
min = 1, max = 10, value = 2),
uiOutput("period_cutpoints")
),
# Show just the number of periods so far.
mainPanel(
textOutput("nr_of_periods")
)
)
))
# Define server logic ----
server <- function(session, input, output) {
output$period_cutpoints<- renderUI({
req(input$num_periodsnr > 0)
lapply(1:input$num_periodsnr, function(el) {
airDatepickerInput(inputId = paste('PeriodEnd', el, sep = ''), label = paste('Period End', el, sep = ' '), clearButton = TRUE, range = F, update_on = 'close')
})
})
}
# Run the app ----
shinyApp(ui = ui, server = server)
Since you did not provide a dataset to apply the inputs on, and I don't know what date ranges your data has, I did not add code to set min/max on the date pickers, and not sure what kind of code to provide for you to use the data. You would need to write something to put them in a list indeed
values <- reactiveValues(datesplits = list(),
previous_max = 0)
observeEvent(input$num_periodsnr, {
if(input$num_periodsnr > values$previous_max) {
lapply(values$previous_max:input$num_periodsnr, function(el) {
observeEvent(input[[paste(paste('PeriodEnd', el, sep = '')]], {
values$datesplits[el] <- input[[paste(paste('PeriodEnd', el, sep = '')]]
})
values$previous_max <- max(values$previous_max, input$num_periodsnr)
})
}
})
and then use the list of dates for whatever you need to do with them I think.
I use the trick with run lapenter code hereply from previous_max to input$num_periodsnr if(input$num_periodsnr > values$previous_max){} to avoid the problem you create when you repeatedly create observers for the same input element. Whereas ui elements are overwritten when created in a loop, observeEvents are made as copies, so every time your loop fires, you make another copy of observers 1:n. This results in all copies firing every time, until you have a million observers all firing, creating possible strange bugs, unwanted effects and loss of speed.
I asked this question (Update two sets of radiobuttons reactively - shiny) yesterday but perhaps it was too messy to get a response. I have stripped the question down: why can't I get two sets of radiobuttons to update reactively:
server.R:
# Create example data
Wafer <- rep(c(1:3), each=3)
Length <- c(1,1,2,1,1,1,3,5,1)
Width <- c(3,1,6,1,1,1,1,1,6)
dd <- data.frame(Wafer, Length, Width)
shinyServer(function(input, output, session){
# Get Lengths from user input
a <- eventReactive(input$do, {
subset(dd, Wafer %in% input$wafer, select = Length)
})
# Get Widths from user input
b <- eventReactive(input$do, {
subset(dd, Wafer %in% input$wafer, select = Width)
})
#Observe and update first set of radiobuttons based on a(). Does
#render
observe({
z <- a()
updateRadioButtons(session, "length", choices = unique(z$Length), inline=TRUE)
})
#Observe and update second set of radiobuttons based on b(). Does
#not render
observe({
z <- b()
updateRadioButtons(session, "width", choices = unique(z$Width), inline=TRUE)
})
output$l <- renderDataTable({ a() })
output$w <- renderDataTable({ b() })
})
ui.R:
library(markdown)
shinyUI(fluidPage(
titlePanel("Generic grapher"),
sidebarLayout(
sidebarPanel(
numericInput("wafer", label = h3("Input wafer ID:"), value = NULL),
actionButton("do", "Search wafer"),
radioButtons("length", label="Length", choices=""),
radioButtons("width", label="Width", choices = "")
),
mainPanel(
dataTableOutput(outputId="l"),
dataTableOutput(outputId="w")
)))
)
In the above, I can only get one set of radiobuttons to reactive ("Length"). However, if I comment out the Length observe, the Width one works so my code must be OK in isolation. Maybe I'm missing something simple?
This might be a bug of the updateRadioButtons function. When selected is not set, it is replaced by the first choice. I guess this causes an error if the choices list is numeric.
To fix your problem, you can either convert your choices to characters using as.character or set selected to a random string such as "".
Using as.character is probably better as you then get your first selection automatically selected.
What I'm trying to do is create an arbitrary number of action button, each of which has their own event based on their own individual values.
Let's say we want to create a number of buttons. What we do is draw a random number between 1 and 100 and call it n. Then we create n buttons, each with a value between 1 and n (covering every number once). Then, when we press one of those buttons, we render a text message being the number that we pressed.
To set up the buttons, we have:
ui.R
shinyUI(fluidPage(
actionButton('roll','roll'),
uiOutput('buttons')
))
Server.R
shinyServer(function(input, output) {
n <- eventReactive(input$roll, {
num <- sample(1:100,1)
sample(1:num, num, replace=FALSE)
})
output$buttons <- renderUI({
lapply(1:length(n()), function(i) {
actionButton(as.character(n()[i]), as.character(n()[i]) )
})
})
})
This generates the buttons. However, I'm struggling to find a way to create all the necessary eventReactive()s. I tried calling eventReactive() inside a loop, and in a lapply call. However, in order to make that loop or lapply, you need the value of length(n()), which can only be called inside another reactive or observe command.
Given the buttons generated from the above script, how do we make a reactive expression for each button, and then output the text corresponding to the number pressed?
You can search through the input looking for buttons that have been triggered. Once a button is clicked, its value is greater than 0, so all the picked values will print this way (not sure if that is desired?)
library(shiny)
shinyApp(
shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
actionButton('roll','roll'),
uiOutput('buttons')
),
mainPanel(
textOutput('stuff')
)
)
)),
shinyServer(function(input, output) {
n <- eventReactive(input$roll, {
num <- sample(1:100,1)
sample(1:num, num, replace=FALSE)
})
output$buttons <- renderUI({
lapply(1:length(n()), function(i) {
actionButton(as.character(n()[i]), as.character(n()[i]) )
})
})
output$stuff <- renderText({
val <- which(lapply(paste(n()), function(i) input[[i]]) == TRUE)
if (length(val))
sprintf("Picked %s!", paste(n())[val])
})
})
)