I am trying to create a dashboard in rShiny which follow the following steps
Select a parameter
Filter data from a source table for this parameter
Create a list of this filtered data for one of the column
Iterate over this list to display graphs etc...
I have tried various options for making this work but the communication between ui and server is not happening as expected
I have created a setup as below fot testing
library(shiny)
df_mtcars <- mtcars
df_mtcars <- cbind(CarName = rownames(df_mtcars), df_mtcars)
df_mtcars$CarName <- sub(" ", "_", df_mtcars$CarName)
select the number of gears
Find the cars with that number of gears
Create a list of these cars
Display the data for each of the car by using loop. Loop is needed as other output types like graphs can be latter added
simpUI <- function(id) {
tagList(tableOutput(NS(id, "dat_output"))
numericInput(NS(id, "GearNumber"), "Gear Numbers", 3),
lapply(seq(1, length(v_lst_CarName), by = 1), function(i) {
v_CarName = v_lst_CarName[i]
v_obj_CarName = paste0('sp_cars_', v_CarName)
tableOutput(NS(id, v_obj_CarName))
}))
}
simpServer <- function(id) {
moduleServer(id, function(input, output, session) {
output$dat_output <- renderTable(df_mtcars)
v_lst_CarName <-
reactive(df_mtcars[GearNumber == input$GearNumber]$CarName)
for (v_CarName in v_lst_CarName)
v_obj_CarName = paste0('sp_cars_', v_CarName)
output$v_obj_CarName <- renderTable(v_obj_CarName)
})
}
ui <- fluidPage(fluidRow(simpUI("cars")))
server <- function(input, output, session) {
simpServer("cars")
}
shinyApp(ui = ui, server = server)
It is better to do server side processing. Try this
library(shiny)
library(ggplot2)
df_mtcars <- mtcars
df_mtcars <- cbind(CarName = rownames(df_mtcars), df_mtcars)
df_mtcars$CarName <- sub(" ", "_", df_mtcars$CarName)
simpUI <- function(id) {
ns <- NS(id)
tagList(tableOutput(ns("dat_output")),
numericInput(ns("GearNumber"), "Gear Numbers", 3),
uiOutput(ns("plotxy")),
tableOutput(ns("v_obj_CarName")),
verbatimTextOutput(ns("mylist")),
plotOutput(ns("myplot"))
)
}
simpServer <- function(id) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
output$dat_output <- renderTable(head(df_mtcars))
mydf <- reactive(df_mtcars[df_mtcars$gear == input$GearNumber,])
v_lst_CarName <- eventReactive(mydf(), {paste0("sp_cars_",mydf()$CarName)})
output$plotxy <- renderUI({
req(mydf())
tagList(
selectInput(ns("xvar"), label = "X-axis variable", choices = names(mydf()), selected=names(mydf())[2] ),
selectInput(ns("yvar"), label = "Y-axis variable", choices = names(mydf()), selected=names(mydf())[5] )
)
})
output$v_obj_CarName <- renderTable({mydf()})
output$mylist <- renderPrint(list(v_lst_CarName() ))
output$myplot <- renderPlot({
req(input$xvar,input$yvar)
ggplot(mydf(),aes(x=.data[[input$xvar]], y=.data[[input$yvar]])) + geom_point()
})
})
}
ui <- fluidPage(fluidRow(simpUI("cars")))
server <- function(input, output, session) {
simpServer("cars")
}
shinyApp(ui = ui, server = server)
Related
I'm trying to write a module that gets a reactive dataframe as an input and allows the user to manipulate it (for the sake of the Minimal Reproducible Example, to add to the table a single row)
Initially, the data that being passed to the module from the main app is some default dataframe (hard coded in the MRE), so the module is always initiated with data.
In addition, I also want to allow the user to manipulate that data from outside the module (for the sake of the MRE, override the dataset with a different, hard-coded dataset).
I cannot make both functionalities in the MRE to work at the same time. At the moment, the update from main app works, but the update from within the module won't work. I found some solutions that would enable the opposite situation.
when trying to add row: no response and no error.
Note 1: The use of modules in the MRE is artificial and not really needed, but it is very much needed in the real app.
Note2: returning a new data frame instead of updating it is not ideal in my case as I would want to allow the user other manipulations, and only after all changes are done, to return the the new data frame.
Minimal Reproducible Example:
library(shiny)
library(tidyverse)
DEFAULT_DATA <- tribble(
~letter, ~number,
"A", 1,
"B", 2,
)
changeDataUI <- function(id) {
ns <- NS(id)
tagList(
tableOutput(ns("tbl"))
,br()
,actionButton(ns("add_row"), 'Add Row')
)
}
changeDataServer <- function(id, data) {
moduleServer(
id,
function(input, output, session) {
observeEvent(input$add_row, {
data <- data() %>% add_row(letter = "C", number = 3)
})
output$tbl <- renderTable(data())
}
)
}
ui <- fluidPage(
titlePanel("MRE App")
,fluidRow(column(6, actionButton("change_dataset", "Change Dataset")))
,fluidRow(column(6, changeDataUI("some_id")))
)
server <- function(input, output) {
glob_rvs <- reactiveValues(data = DEFAULT_DATA)
observeEvent(input$change_dataset, {
glob_rvs$data <- tribble(
~letter, ~number,
"D", 4,
"E", 5,
)
})
changeDataServer(id = "some_id", data = reactive(glob_rvs$data))
}
shinyApp(ui = ui, server = server)
With R, you typically want your modules to act as functional as possible. This, as you point out allows you to better reason about your app. I would have your module return the rows to be added and then have your top level app append them. Otherwise you module is essentially causing side effects. Also, this way your top level app (or another module) could coordinate multiple manipulations. The module could still show the data
Example implementation for module server:
changeDataServer <- function(id, data) {
moduleServer(
id,
function(input, output, session) {
additionalRows <- reactiveVal()
observeEvent(input$change, {
additionalRows(
data.frame(letter = sample(letters, 1) , number = runif(1, 0, 10))
)
})
output$tbl <- renderTable(data())
# return reactive with additional rows to allow to be merged at top level
additionalRows
}
)
}
Then update the server (also changed the input for the upload handler to match the UI (input$uploaded_data not input$uploaded_scheme)
server <- function(input, output) {
glob_rvs <- reactiveValues(data = DEFAULT_DATA)
observeEvent(input$uploaded_data, {
uploaded_data <- read_csv(input$uploaded_data$datapath)
glob_rvs$data <- uploaded_data
})
newRows <- changeDataServer(id = "some_id", data = reactive(glob_rvs$data))
observe({
glob_rvs$data <- bind_rows(glob_rvs$data, newRows())
}) %>%
bindEvent(newRows())
}
What you want to do here is to pass you reactiveValues object as an argument of your module server.
I advise you read this article about how to communicate data between modules
library(shiny)
library(tidyverse)
DEFAULT_DATA <- tribble(
~letter, ~number,
"A", 1,
"B", 2,
)
changeDataUI <- function(id) {
ns <- NS(id)
tagList(
tableOutput(ns("tbl"))
,br()
,actionButton(ns("change"), 'Add Row')
)
}
changeDataServer <- function(id, glob_rvs) {
moduleServer(
id,
function(input, output, session) {
observeEvent(input$change, {
print(glob_rvs$data)
glob_rvs$data <- glob_rvs$data %>% add_row(letter = "C", number = 3)
})
output$tbl <- renderTable(glob_rvs$data)
}
)
}
ui <- fluidPage(
titlePanel("MRE App")
,fluidRow(column(6,
fileInput("uploaded_data",
"would ypu like to upload your own data?",
multiple = FALSE,
accept = c(".csv"))))
,fluidRow(column(6, changeDataUI("some_id")))
)
server <- function(input, output) {
glob_rvs <- reactiveValues(data = DEFAULT_DATA)
observeEvent(input$uploaded_data, {
uploaded_data <- read_csv(input$uploaded_scheme$datapath)
glob_rvs$data <- uploaded_data
})
changeDataServer(id = "some_id", glob_rvs = glob_rvs)
}
shinyApp(ui = ui, server = server)
Following the solution by #Marcus, here is a working version that is consistent with the last version of post:
library(shiny)
library(tidyverse)
DEFAULT_DATA <- tribble(
~letter, ~number,
"A", 1,
"B", 2,
)
changeDataUI <- function(id) {
ns <- NS(id)
tagList(
tableOutput(ns("tbl"))
,br()
,actionButton(ns("add_row"), 'Add Row')
)
}
changeDataServer <- function(id, data) {
moduleServer(
id,
function(input, output, session) {
additionalRows <- reactiveVal()
observeEvent(input$add_row, {
additionalRows(
data.frame(letter = sample(letters, 1) , number = runif(1, 0, 10))
)
})
output$tbl <- renderTable(data())
# return reactive with additional rows to allow to be merged at top level
additionalRows
}
)
}
ui <- fluidPage(
titlePanel("MRE App")
,fluidRow(column(6, actionButton("change_dataset", "Change Dataset")))
,fluidRow(column(6, changeDataUI("some_id")))
)
server <- function(input, output) {
glob_rvs <- reactiveValues(data = DEFAULT_DATA)
observeEvent(input$change_dataset, {
glob_rvs$data <- tribble(
~letter, ~number,
"D", 4,
"E", 5,
)
})
newRows <- changeDataServer(id = "some_id", data = reactive(glob_rvs$data))
observe({
glob_rvs$data <- bind_rows(glob_rvs$data, newRows())
}) %>%
bindEvent(newRows())
}
shinyApp(ui = ui, server = server)
I'm learning Shiny modules. And I'm stuck in a very silly thing: I don't know how to call an input inside moduleServer. In this reprex, the table does not show, I think its because the getInput argument is not properly used in the server. Here's a reprex:
library(shiny)
library(DT)
tablaResumen <- function(id, getInput, tabla1, tabla2) {
moduleServer(id, function(input, output, session) {
output$table <- renderDT({
if(getInput == FALSE){
tabla <- tabla1
}else{
tabla <- tabla2
}
DT::datatable(tabla, escape = FALSE, rownames = FALSE)
})
})
}
ui <- fluidPage(
checkboxInput("input1", label = "Change table"),
DTOutput("table1")
)
server <- function(input, output, session) {
tablaResumen("table1", input$input1, mtcars, iris)
}
shinyApp(ui, server)
library(shiny)
library(DT)
tablaResumen <- function(id, parent_in, get, tabla1, tabla2) {
moduleServer(id, function(input, output, session) {
output$mytable <- renderDT({
if(parent_in[[get]] == FALSE){
tabla <- tabla1
}else{
tabla <- tabla2
}
DT::datatable(tabla, escape = FALSE, rownames = FALSE)
})
})
}
tablaResumenUI <- function(id) {
ns <- NS(id)
DTOutput(ns("mytable"))
}
ui <- fluidPage(
checkboxInput("input1", label = "Change table"),
tablaResumenUI("table")
)
server <- function(input, output, session) {
tablaResumen("table", parent_in = input, "input1", mtcars, iris)
}
shinyApp(ui, server)
Things are a little tricky here.
To render the table, you must put the DTOutput under the same namespace as your mod server. The way we usually do it is by creating a mod UI function and use NS to wrap the id to create the namespace.
You module is depend on a reactive input value input$input1, but the server function itself is not reactive. This means if you provide it as an argument for the mod function, it will be run only one time, so getInput will never be changed after the app is initialized. It becomes a fixed value. To get the reactive value of input1, you need to provide the parent input as an argument as access from there.
I have a table where I get a value from the same column but from different rows and I would like to display in a verbatimTextOutput each value without overwriting each time.
I tried to do that but I get an error:
library(shiny)
library(DT)
ui <- fluidPage(
DT::dataTableOutput("table"),
verbatimTextOutput("output", placeholder = TRUE)
)
server <- function(input, output) {
val <- reactiveVal(as.character(dt[input$table_rows_selected, 2]))
o <- reactiveVal(NULL)
observeEvent(input$table_rows_selected, {
o(c(o(), "\n", "You chose :", val()))
output$output <- renderText({ o() })
})
dt <- data.frame("a" = paste("a", 1:10), "b" = paste("b", 1:10))
output$table <- DT::renderDataTable({
DT::datatable(dt, selection = list(target = 'row'))
})
}
shinyApp(ui = ui, server = server)
Error in .getReactiveEnvironment()$currentContext() :
Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)
I'm building a shiny app that would display in dygraphs a basic dataset and then offer an option to add new time series upon selecting the checkbox input. However, as I coded it now, I'm 'stuck' at the original dataset and unable to add/remove new content. Any hints how to solve this are very welcome, thanks.
library(shinydashboard)
library(dygraphs)
library(dplyr)
ui <-dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs(),
checkboxGroupInput(inputId = 'options',
label = 'Choose your plot(s)',
choices = list("mdeaths" = 1,
"ldeaths" = 2)
),
uiOutput("Ui1")
)
)
server <- function(input, output, session) {
output$Ui1 <- renderUI({
output$plot1 <- renderDygraph({
final_ts <- ldeaths
p <- dygraph(final_ts, main = 'Main plot') %>%
dygraphs::dyRangeSelector()
if(1 %in% input$options) {
final_ts <- cbind(final_ts, mdeaths)
p <- p %>%
dySeries('mdeaths', 'Male Deaths')
} else if(2 %in% input$options) {
final_ts <- cbind(final_ts, fdeaths)
p <- p %>%
dySeries('fdeaths', 'Female Deaths')
}
p
})
dygraphOutput('plot1')
})
}
shinyApp(ui, server)
I'd suggest to dynamically filter the data based on the user selection instead of dynamically adding/removing traces from the plot:
library(shinydashboard)
library(shinyjs)
library(dygraphs)
library(dplyr)
lungDeaths <- cbind(ldeaths, mdeaths, fdeaths)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs(),
selectizeInput(
inputId = "options",
label = "Choose your trace(s)",
choices = colnames(lungDeaths),
selected = colnames(lungDeaths)[1],
multiple = TRUE,
options = list('plugins' = list('remove_button'))
),
uiOutput("Ui1")
)
)
server <- function(input, output, session) {
output$Ui1 <- renderUI({
filteredLungDeaths <- reactive({
lungDeaths[, input$options]
})
output$plot1 <- renderDygraph({
p <- dygraph(filteredLungDeaths(), main = 'Main plot') %>%
dygraphs::dyRangeSelector()
if('mdeaths' %in% colnames(filteredLungDeaths())){
p <- dySeries(p, 'mdeaths', 'Male Deaths')
}
if('fdeaths' %in% colnames(filteredLungDeaths())){
p <- dySeries(p, 'fdeaths', 'Female Deaths')
}
p
})
dygraphOutput('plot1')
})
}
shinyApp(ui, server)
The app is intended to display summarized_mod when the action button is clicked. But I keep getting a summarized_mod missing error.
summarized <- data.frame(id = 1:20, group = letters[1:4], TY_COMP = runif(20), LY_COMP = runif(20))
library(shiny)
ui <- fluidPage(
verbatimTextOutput("text"),
actionButton("btn", "Show the summarized")
)
server <- function(input, output){
summarized <- reactive({summarized})
observeEvent(input$btn,{
summarized_mod <-summarized()$TY_COMP / summarized()$LY_COMP-1 }
})
output$text <- renderPrint(summarized_mod())
}
shinyApp(ui, server)
dat <- data.frame(id = 1:20,
group = letters[1:4],
TY_COMP = runif(20),
LY_COMP = runif(20))
library(shiny)
ui <- fluidPage(
verbatimTextOutput("text"),
actionButton("btn", "Show the summarized")
)
server <- function(input, output){
# summarized <- reactive({summarized}) useless !
summarized_mod <- eventReactive(input$btn, {
dat$TY_COMP / dat$LY_COMP-1
})
output$text <- renderPrint(summarized_mod())
}
shinyApp(ui, server)