I wonder how we can track changes when the user modifies the input in R Shiny. For example, I want to count the number of times the user changes the x input in the following code, but it seems not to be working.
library(shiny)
ui <- fluidPage(
selectInput(inputId = "x", label = "X", choices = names(mtcars), selected = names(mtcars)[1]),
br(),
br(),
verbatimTextOutput("out")
)
server <- function(input, output, session) {
r <- reactiveVal(0)
y <- eventReactive(input$x,{
r() + 1
})
output$out <- renderPrint({
y()
})
}
shinyApp(ui, server)
Setting the value for a reactiveVal is done by assigning it like this:
r() = 0
r(1) = 1, etc.
So adjust your code like this:
library(shiny)
ui <- fluidPage(
selectInput(inputId = "x", label = "X", choices = names(mtcars), selected = names(mtcars)[1]),
br(),
br(),
verbatimTextOutput("out")
)
server <- function(input, output, session) {
r <- reactiveVal(0)
y <- eventReactive(input$x,{
r(r() + 1)
return(r())
})
output$out <- renderPrint({
y()
})
}
shinyApp(ui, server)
Related
I've got a table that will initialize, but will not update. I use a few inputs, which then get called by a function to calculate the outputs. They will initialize with the correct values, but when I click the actionButton, nothing happens.
output$view<-renderTable({
tabSvol<-isolate(
data.frame(
S=c(
func1(input$in1),
func2(input$in2),
func3(input$in1,input$2)
)
)
)
tabSvol
})
Here's a MRE that allows you to add rows to a reactive table.
library(shiny)
library(tidyverse)
ui <- fluidPage(
numericInput("a", "A: ", value=NA),
selectInput("b", "B:", choices=c("X", "Y", "Z")),
actionButton("add", "Add row"),
tableOutput("table")
)
server <- function(input, output) {
rv <- reactiveValues(table=tibble(A=numeric(0), B=character(0)))
output$table <- renderTable({
rv$table
})
observeEvent(input$add, {
rv$table <- rv$table %>% add_row(A=input$a, B=input$b)
})
}
shinyApp(ui = ui, server = server)
Consider the following example application:
library(shiny)
library(shinyWidgets)
module_UI <- function(id){
tagList(
div(
uiOutput(
outputId = NS(id, "selection")
),
shinyWidgets::dropdown(
uiOutput(outputId = NS(id, "new_option")),
style = "unite",
label = "New",
color = "primary",
animate = animateOptions(
enter = animations$fading_entrances$fadeInLeftBig,
exit = animations$fading_exits$fadeOutRightBig
),
up = F,
width = "600px",
inline = T
)
)
)
}
module_server <- function(id){
moduleServer(id, function(input, output, session){
ns <- session$ns
return_values <- reactiveValues(selection=NULL)
output$selection <- renderUI({
selectInput(inputId = ns("selection"), label = "Select:", choices = 1:5)
})
output$new_option <- renderUI({
div(
numericInput(ns("new_option_input"), label = "Add a new option:"),
shinyWidgets::actionBttn(
inputId = ns("submit_new_option"),
label = "Submit",
icon = icon("paper-plane"))
)
})
observeEvent(input$submit_new_option, {
#does not work as intended
updateSelectInput(session = session, inputId = "selection", selected = input$new_option_input)
})
observe({
return_values$selection <- input$selection
})
return(return_values)
})
}
# Define UI for application that draws a histogram
ui <- fluidPage(
title = "Test App",
module_UI("test"),
verbatimTextOutput(outputId = "selection_chosen")
)
# Define server logic required to draw a histogram
server <- function(input, output) {
picker <- module_server("test")
output$selection_chosen <- renderText({
picker$selection
})
}
# Run the application
shinyApp(ui = ui, server = server)
Basically, the module should do two things:
Allow user to select a pre-existing option --> return that value from module
Allow user to create their own, new option --> return that value from module
I have #1 working, but am struggling on #2. Specifically, where I have the "does not work" comment. How can I achieve this functionality? What are/is the best practice(s) for returning server-side created values from a Shiny module? This is an example app; the real one involves reading the selectInput options from a database, as well as saving the newly created options in the database. Appreciate any help on this! A lot of SO answers regarding Shiny modules have the older callModule(...) syntax, which makes researching this topic a bit more confusing.
You just need to provide the default value in numericInput. Perhaps you are looking for this.
library(shiny)
library(shinyWidgets)
module_UI <- function(id){
ns <- NS(id)
tagList(
div(
uiOutput(
outputId = NS(id, "selection")
),
shinyWidgets::dropdown(
uiOutput(outputId = NS(id, "new_option")),
style = "unite",
label = "New",
color = "primary",
animate = animateOptions(
enter = animations$fading_entrances$fadeInLeftBig,
exit = animations$fading_exits$fadeOutRightBig
),
up = F,
width = "600px",
inline = T
),
DTOutput(ns("t1"))
)
)
}
module_server <- function(id){
moduleServer(id, function(input, output, session){
ns <- session$ns
return_values <- reactiveValues(selection=NULL,myiris = iris)
output$selection <- renderUI({
selectInput(inputId = ns("selection"), label = "Select:", choices = 1:5)
})
output$new_option <- renderUI({
tagList(
numericInput(ns("new_option_input"), label = "Add a new option:",10, min = 1, max = 100),
shinyWidgets::actionBttn(
inputId = ns("submit_new_option"),
label = "Submit",
icon = icon("paper-plane"))
)
})
observeEvent(input$submit_new_option, {
return_values$myiris <- iris[1:input$new_option_input,]
#does work as intended
updateSelectInput(session = session, inputId = "selection", choices= c(1:input$new_option_input), selected = input$new_option_input)
})
output$t1 <- renderDT({return_values$myiris})
observe({
return_values$selection <- input$selection
})
return(return_values)
})
}
# Define UI for application that draws a histogram
ui <- fluidPage(
title = "Test App",
module_UI("test"),
verbatimTextOutput(outputId = "selection_chosen"),
DTOutput("t2")
)
# Define server logic required to draw a histogram
server <- function(input, output) {
picker <- module_server("test")
output$selection_chosen <- renderText({
picker$selection
})
output$t2 <- renderDT({picker$myiris[,c(3:5)]})
}
# Run the application
shinyApp(ui = ui, server = server)
I want to update output data on update button every time.
Here is my code which show the output on update button for the first time I run the code but in runtime if the input is changed, the output is updated automatically.
library(shiny)
ui <- fluidPage(
titlePanel("My Shop App"),
sidebarLayout(
sidebarPanel(
helpText("Controls for my app"),
selectInput("item",
label = "Choose an item",
choices = list("Keyboard",
"Mouse",
"USB",
sliderInput("price",
label = "Set Price:",
min=0, max = 100, value=10),
actionButton ("update","Update Price")
),
mainPanel(
helpText("Selected Item:"),
verbatimTextOutput("item"),
helpText("Price"),
verbatimTextOutput("price")
)
)
)
server <- function(input, output) {
SelectInput <- eventReactive (input$update , {
output$item = renderText(input$item)
output$price = renderText(input$price)
})
output$item <- renderText(SelectInput())
output$price <- renderText(SelectInput())
}
shinyApp(ui = ui, server = server)
Either create a dependency and put them into the reactive and return it:
server <- function(input, output) {
SelectInput <- eventReactive(input$update,{
list(item = input$item, price = input$price)
})
output$item <- renderText(SelectInput()$item)
output$price <- renderText(SelectInput()$price)
}
Or you can isolate, but then you have to add the button reaction to each listener
server <- function(input, output) {
output$item <- renderText({
req(input$update)
input$update
isolate(input$item)
})
output$price <- renderText({
req(input$update)
input$update
isolate(input$price)
})
}
I have a small Shiny app that generates some data whenever the New data button is pressed. The Show plot button shows a hidden plot. I would like the plot to be hidden again automatically whenever the New data button is pressed to make a new data set. A bonus would be for the plot to be hidden also as soon as the slider is changed. I am not looking for a toggle action.
I tried adapting this example that uses conditional panel but I could not successfully figure out how to correctly change the values$show between TRUE and FALSE.
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "number",
label = "Pick a number",
min = 6,
max = 12,
value = 8),
actionButton("new_data",
"New data"),
actionButton("show_plot",
"Show plot")
),
mainPanel(
tableOutput("char_table"),
plotOutput(outputId = "car_plot")
)
)
)
server <- function(input, output) {
t <- eventReactive(input$new_data, {
r <- input$number
c <- r - 1
mat <- matrix(sample(0:1,r*c, replace=TRUE),r,c)
})
output$char_table <- renderTable({
t()
})
p <- eventReactive(input$show_plot, {
plot(cars)
})
output$car_plot <- renderPlot({
p()
})
}
shinyApp(ui = ui, server = server)
You can use a reactive value and a if to control the plot.
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "number",
label = "Pick a number",
min = 6,
max = 12,
value = 8),
actionButton("new_data",
"New data"),
actionButton("show_plot",
"Show plot")
),
mainPanel(
tableOutput("char_table"),
plotOutput(outputId = "car_plot")
)
)
)
server <- function(input, output) {
showPlot <- reactiveVal(FALSE)
t <- eventReactive(input$new_data, {
showPlot(FALSE)
r <- input$number
c <- r - 1
mat <- matrix(sample(0:1,r*c, replace=TRUE),r,c)
})
output$char_table <- renderTable({
t()
})
observeEvent(input$number, {
showPlot(FALSE)
})
observeEvent(input$show_plot, {
showPlot(TRUE)
})
output$car_plot <- renderPlot({
if (showPlot())
plot(cars)
})
}
shinyApp(ui = ui, server = server)
Alternate solution using shinyjs which is handy in these situations.
library(shiny)
library(shinyjs)
ui <- fluidPage( shinyjs::useShinyjs(),
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "number",
label = "Pick a number",
min = 6,
max = 12,
value = 8),
actionButton("new_data",
"New data"),
actionButton("show_plot",
"Show plot")
),
mainPanel(
tableOutput("char_table"),
plotOutput(outputId = "car_plot")
)
)
)
server <- function(input, output) {
t <- eventReactive(input$new_data, {
hide("car_plot")
r <- input$number
c <- r - 1
mat <- matrix(sample(0:1,r*c, replace=TRUE),r,c)
})
output$char_table <- renderTable({
t()
})
observeEvent(input$show_plot, {
show("car_plot")
})
output$car_plot <- renderPlot({
plot(cars)
})
}
shinyApp(ui = ui, server = server)
I have a shiny app that a user can check whether they want the data table displayed in the main panel. Depending on the numericinput, if they select 1, only 1 datatable be displayed or if they select 2 it will display 2 datatables I am not so sure how to code this in shiny R since I am new to this. Thank you for looking into this.
Here is my code
library("shiny")
df1 <- data.frame("2010-01"=double(),
"2010-02"=double(),
"2010-03"=double(),
"2010-04"=double()
)
df1<-rbind(df1,setNames(as.list(c(10,20,30,40)), names(df2)))
df2 <- data.frame("2010-01"=double(),
"2010-02"=double(),
"2010-03"=double(),
"2010-04"=double()
)
df2<-rbind(df2,setNames(as.list(c(100,200,300,400)), names(df2)))
df3 <- data.frame("2010-01"=double(),
"2010-02"=double(),
"2010-03"=double(),
"2010-04"=double()
)
df3<-rbind(df3,setNames(as.list(c(1000,2000,3000,4000)), names(df2)))
ui <-fluidPage(
sidebarPanel(
checkboxInput("add_data", "Add Data Table(s)"),
conditionalPanel(condition="input.add_data === true",
numericInput("numofdata",
label="Number of Data Table(s):",
min = 1,
max = 3,
value = 1,
step = 1),
uiOutput("num_of_data"),
textOutput("see_ranges")
),
actionButton("submit", "Submit")
),
mainPanel(
titlePanel("Output Data Table"),
DT::dataTableOutput("datatable.view", width = "95%")
) # end of main panel
)
server <- function(input, output, session) {
output$num_of_data <- renderUI({
lapply(1:input$numofdata, function(i) {
print(trend_list())
})
})
output$see_ranges <- renderPrint({
print(trend_list())
})
data.filter <- reactive({
df(i)
})
output$datatable.view <- DT::renderDataTable(
{
input$submit
if (input$submit==0) return()
isolate({
for(i in 1:input$numoftrends) {
datatable(data.filter(i),
rownames=FALSE,
extensions = c("FixedColumns", "FixedHeader", "Scroller"),
options = list(searching=FALSE,
autoWidth=TRUE,
rownames=FALSE,
scroller=TRUE,
scrollX=TRUE,
pagelength=1,
fixedHeader=TRUE,
class='cell-border stripe',
fixedColumns =
list(leftColumns=2,heightMatch='none')
)
)
}
})
})
}
shinyApp(ui = ui, server = server)
You should look at this article:
http://shiny.rstudio.com/gallery/creating-a-ui-from-a-loop.html
You will seen then that one has to create multiple renderDataTable instead of muliple datatable within one renderDataTable().
Also in your code you call df like a function df() but it is only defined as a variable.
See a generic running example below.
EDIT: Changed dynamic part of UI.
library(DT)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("amountTable", "Amount Tables", 1:10, 3)
),
mainPanel(
# UI output
uiOutput("dt")
)
)
)
server <- function(input, output, session) {
observe({
lapply(1:input$amountTable, function(amtTable) {
output[[paste0('T', amtTable)]] <- DT::renderDataTable({
iris[1:amtTable, ]
})
})
})
output$dt <- renderUI({
tagList(lapply(1:input$amountTable, function(i) {
dataTableOutput(paste0('T', i))
}))
})
}
shinyApp(ui, server)