I have a shiny module where I want to read one data frame or another based on the user's selection. After the user selects one data frame or another, I want to give the user the option to plot one variable or another using a material switch. Mexico button means that it will be a data frame grouped by states. Municipal button means that it is a data frame grouped by municipality.
I am struggling to connect the material switch with the df selected with the action button. I have just tried with one action button.
Here is the code
require(shiny)
require(ggplot2)
require(dplyr)
require(tidyr)
require(readr)
require(data.table)
require(shinyWidgets)
require(ggplot2)
mod_dfSelector_ui <- function(id){
ns <- NS(id)
fluidRow(
column(2,
actionButton(inputId = ns("mexico_df"),
label = "Mexico")),
column(2,
actionButton(inputId = ns("municipal_df"),
label = "Municipal")),
column(4,
tags$div(
materialSwitch(inputId = "cumdeath", label = "Cumulative sum of covid deaths",
inline = TRUE),
tags$div(
materialSwitch(inputId = "exdeath", label = "Excess mortality",
inline = TRUE)
)
)
),
column(2,
plotOutput(
outputId = ns("plot"))
)
)
}
mod_dfSelector_server <- function(id){
moduleServer(id, function(input, output, session){
ns <- session$ns
# ----- buttons
countryDF <- eventReactive(input$mexico_df,{
fread("../data-raw/mexico-covid-final.csv", header = T) %>%
group_by(id_ent, month_def, year_def) %>%
summarise(tot_covid_deaths = sum(tot_covid_deaths, na.rm = T),
excess_mortality_ssa = sum(excess_mortality_ssa, na.rm = T),
excess_mortality_inegi = sum(excess_mortality_inegi, na.rm = T))
})
municipalDF <- eventReactive(input$municipal_df,{
fread("../data-raw/mexico-covid-final.csv", header = T)
})
# ---- switch
cumulativeEnt <- eventReactive(input$cumdeath, {
countryDF() %>%
select(month_def, year_def, tot_covid_deaths)
})
output$plot <- renderPlot({
cumulativeEnt() %>%
ggplot(aes(tot_covid_deaths)) +
geom_histogram()
})
})
}
## To be copied in the UI
# mod_histogram_ui("histogram_ui_1")
## To be copied in the server
# mod_histogram_server("histogram_ui_1")
ui <- fluidPage(
mod_dfSelector_ui("country")
)
server <- function(input, output, session) {
mod_dfSelector_server("country")
}
shinyApp(ui, server)
Related
I am trying to create my first shiny app but I am facing a difficulty: in the reproducible example below I am creating a reactive pickerInput (i.e. only show brands proposing a cylindre equal to the input visitors select).
I then want that based on the combination input_cyl and picker_cny (remember that picker_cny depends on input_cyl) to display a table which shows the relevant data for the observation matching the combination input_cyl and picker_cny.
Thank you for your help!
df <- mtcars
df$brand <- rownames(mtcars)
df$brand <- gsub("([A-Za-z]+).*", "\\1", df$brand)
if (interactive()) {
library(shiny)
library(shinyWidgets)
library(shinythemes)
library(shinycssloaders)
# Define UI -----------------------------------------------
ui <- fluidPage(
# Application title
titlePanel("Reproducible Example"),
# Parameters
sidebarLayout(
sidebarPanel(
selectInput(inputId = "input_cyl", label = "Cyl",
choices = c("6", "4", "8")),
pickerInput(
inputId = "picker_cny",
label = "Select Company",
choices = paste0(unique(df$brand)),
options = list(`actions-box` = TRUE),
multiple = TRUE),
width = 2),
# Show Text
mainPanel(
tableOutput("table"),
width = 10)
))
# Define Server ------------------------------------------
server <- function(input, output, session) {
# Reactive pickerInput ---------------------------------
observeEvent(input$input_cyl, {
df_mod <- df[df$cyl == paste0(input$input_cyl), ]
# Method 1
disabled_choices <- !df$cyl %in% df_mod$cyl
updatePickerInput(session = session,
inputId = "picker_cny",
choices = paste0(unique(df$brand)),
choicesOpt = list(
disabled = disabled_choices,
style = ifelse(disabled_choices,
yes = "color: rgba(119, 119, 119, 0.5);",
no = "")
))
}, ignoreInit = TRUE)
output$table <- renderTable(df)
}
}
# Run the application
shinyApp(ui = ui, server = server)
You need a reactive that will handle the change in the input and subset the dataframe before giving it to the output table. For that, you just need to add this block to your server:
data <- reactive({
if (length(input$picker_cny) > 0)
df[df$brand %in% input$picker_cny,]
else
df
})
and update the output$table like this:
output$table <- renderTable(data())
Note: feel free to remove the if else in the reactive to get that:
data <- reactive({
df[df$brand %in% input$picker_cny,]
})
The only difference in that case is: would you show all or nothing when no input has been entered yet. That's a matter of taste.
I am building a shiny app with a selectize input.
The choices in the input are dependent upon the ids in the underlying data.
In my real app, the data updates with a call to an API.
I would like the selected id choice in the selectize input to hold constant when I hit the "update data" button.
I was able to do this prior to using shiny modules. However, when I tried to transform my code to use a shiny module, it fails to hold the selected id value, and resets the selectize input each time I update the underlying data.
The following example was helpful without the module, but when I use the module it doesn't seem to work...link here
Below is a reprex. Thanks for any help.
library(shiny)
library(tidyverse)
# module UI
mymod_ui <- function(id){
ns <- NS(id)
tagList(
uiOutput(ns("ids_lookup")),
)
}
# module server
mymod_server <- function(input, output, session, data, actionb){
ns <-session$ns
ids <- reactive(
data() %>%
filter(!is.na(first_name) & !is.na(last_name) & !is.na(ages)) %>%
mutate(ids = paste(first_name, last_name, sep = " ")) %>%
select(ids)
)
output$ids_lookup <- renderUI({
selectizeInput(ns("lookup"),
label = "Enter id:",
choices = c("Type here ...", ids()), multiple = FALSE)
})
# here is where I would like to hold on to the selected ids when updating the table
# when I click the "reload_data" button I don't want the name to change
# I pass the button from the main server section into the module
current_id_selection <- reactiveVal("NULL")
observeEvent(actionb(), {
current_id_selection(ns(input$ids_lookup))
updateSelectizeInput(session,
inputId = ns("lookup"),
choices = ids(),
selected = current_id_selection())
})
}
ui <- fluidPage(
titlePanel("Test module app"),
br(),
# this button reloads the data
actionButton(
inputId = "reload_data",
label = "Reload data"
),
br(),
br(),
# have a look at the data
h4("Raw data"),
tableOutput("mytable"),
br(),
# now select a single id for further analysis in a much larger app
mymod_ui("mymod"),
)
server <- function(input, output, session) {
df <- eventReactive(input$reload_data, {
# in reality, df is a dataframe which is updated from an API call everytime you press the action button
df <- tibble(
first_name = c("john", "james", "jenny", "steph"),
last_name = c("x", "y", "z", NA),
ages = runif(4, 30, 60)
)
return(df)
}
)
output$mytable <- renderTable({
df()
})
# make the reload data button a reactive val that can be passed to the module for the selectize Input
mybutton <- reactive(input$reload_data)
callModule(mymod_server, "mymod", data = df, actionb = mybutton)
}
shinyApp(ui, server)
Just using inputId = "lookup" instead of inputId = ns("lookup") in updateSelectizeInput() will do it. Also, you had another typo in there. Try this
library(shiny)
library(tidyverse)
# module UI
mymod_ui <- function(id){
ns <- NS(id)
tagList(
uiOutput(ns("ids_lookup")),
verbatimTextOutput(ns("t1"))
)
}
# module server
mymod_server <- function(input, output, session, data, actionb){
ns <-session$ns
ids <- reactive(
data() %>%
filter(!is.na(first_name) & !is.na(last_name) & !is.na(ages)) %>%
mutate(ids = paste(first_name, last_name, sep = " ")) %>%
select(ids)
)
output$ids_lookup <- renderUI({
selectizeInput(ns("lookup"),
label = "Enter id:",
choices = c("Type here ...", ids()), multiple = FALSE)
})
# here is where I would like to hold on to the selected ids when updating the table
# when I click the "reload_data" button I don't want the name to change
# I pass the button from the main server section into the module
current_id_selection <- reactiveValues(v=NULL)
observeEvent(actionb(), {
req(input$lookup)
current_id_selection$v <- input$lookup
output$t1 <- renderPrint(paste0("Current select is ",current_id_selection$v))
updateSelectizeInput(session,
inputId = "lookup",
choices = ids(),
selected = current_id_selection$v )
})
}
ui <- fluidPage(
titlePanel("Test module app"),
br(),
# this button reloads the data
actionButton(inputId = "reload_data", label = "Reload data"
),
br(),
br(),
# have a look at the data
h4("Raw data"),
tableOutput("mytable"),
br(),
# now select a single id for further analysis in a much larger app
mymod_ui("mymod")
)
server <- function(input, output, session) {
df <- eventReactive(input$reload_data, {
# in reality, df is a dataframe which is updated from an API call everytime you press the action button
df <- tibble(
first_name = c("john", "james", "jenny", "steph"),
last_name = c("x", "y", "z", NA),
ages = runif(4, 30, 60)
)
return(df)
})
output$mytable <- renderTable({
df()
})
# make the reload data button a reactive val that can be passed to the module for the selectize Input
mybutton <- reactive(input$reload_data)
callModule(mymod_server, "mymod", data = df, actionb = mybutton)
}
shinyApp(ui, server)
I have an app, which fetches data from an SQL-db, then allows the user to edit it, and this should be saved to the DB. In the repex I have used a CSV-file, but the logic should still be comparable.
However, the data is saved in the session once I edit the column value, but if I switch input or close the app and re-open, it's back to the original. Edits are not reflected in the summary table. What am I doing wrong?
# Load libraries
library(DT)
library(gt)
library(shiny)
library(shinydashboard)
library(dplyr)
# Load data (run once for replication; in real use case will be a DB-connection)
#gtcars_tbl <- gtcars
#write.csv(gtcars_tbl, "gtcars_tbl.csv", row.names = FALSE)
# Simple UI
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Summary table", tabName = "summary", icon = icon("project-diagram")),
menuItem("Edit table", tabName = "edit", icon = icon("project-diagram")),
uiOutput("country")
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName = "summary",
h2("Summary of GT Cars"),
gt_output(outputId = "gt_filt_tbl")
),
tabItem(tabName = "edit",
h2("Editer GT Cars"),
DTOutput("edit")
)
)
)
ui <- dashboardPage(
dashboardHeader(title = "GT Cars"),
sidebar,
body)
# Define server functions
server <- function(input, output, session) {
# Load data
gtcars_tbl <- read.csv("gtcars_tbl.csv")
countries <- sort(as.vector(unique(gtcars_tbl$ctry_origin)))
# Create dropdown output
output$country <- renderUI({
selectInput("country", "Country", countries)
})
# Create reactive table
gt_tbl_react <- reactiveVal(NULL)
gt_tbl_react(gtcars_tbl)
# Create filtered table
gt_filt_tbl <- reactive({
req(input$country)
gt_tbl_react() %>%
filter(ctry_origin == input$country)
})
# Render summary table
output$gt_filt_tbl <- render_gt({
gt_filt_tbl() %>%
group_by(ctry_origin, mfr) %>%
summarise(
N = n(),
Avg_HP = mean(hp),
MSRP = mean(msrp)
) %>%
gt(
rowname_col = "ctry_origin",
groupname_col = "mfr")
})
# Render editable table
output$edit <- renderDT(
gt_tbl_react() %>%
filter(ctry_origin == input$country),
selection = 'none', editable = TRUE,
rownames = TRUE,
extensions = 'Buttons'
)
observeEvent(input$edit_cell_edit, {
gtcars_tbl[input$edit_cell_edit$row,input$edit_cell_edit$col] <<- input$edit_cell_edit$value
write.csv(gtcars_tbl, "gtcars_tbl.csv", row.names = FALSE)
})
}
# Run app
shinyApp(ui, server)
The issue is that input$edit_cell_edit$row and input$edit_cell_edit$col are provided according to the subsetted dataframe that is displayed whereas you are changing the values on complete dataframe.
Use this in observeEvent -
observeEvent(input$edit_cell_edit, {
inds <- which(gtcars_tbl$ctry_origin == input$country)
gtcars_tbl[inds[input$edit_cell_edit$row],input$edit_cell_edit$col] <- input$edit_cell_edit$value
write.csv(gtcars_tbl, "gtcars_tbl.csv", row.names = FALSE)
})
The user interface of the Shiny app I'm working on is supposed to work in the following manner:
User finds the desired observation(s) after applying a set of filters.
User clicks "Add" action button, so selected observation(s) are added to a running list/vector/etc of observations to be analyzed.
User modifies filters to find other observations which are to be included as well.
Loop back to step 1 as many times as user desires.
I cannot seem to find a way to save this list of observations to be analyzed. In the example I attached, the "observation ID" is the name of the model of the car (mtcars is used). I also did not include any data analysis, since I do not think that's necessary. In essence, the entire dataset (mtcars) should be filtered using dplyr in a reactive environment to only include the running list of selected observations.
Here's the code:
data("mtcars")
mtcars$model <- rownames(mtcars)
ui <- fluidPage(
titlePanel("sample"),
sidebarLayout(
sidebarPanel(
uiOutput("disp"),
uiOutput("qsec"),
uiOutput("model"),
actionButton("add", "Add"),
uiOutput("selectedModel")
),
mainPanel(
plotOutput("data_analysis")
)
)
)
server <- function(input, output) {
output$disp <- renderUI({
selectInput(
"disp_sel",
"Select disp:",
unique(mtcars$disp),
selected = NULL,
multiple = T,
selectize = T
)
})
output$qsec <- renderUI({
temp = mtcars
if (!is.null(input$disp_sel)){temp = temp %>% filter(disp %in% input$disp_sel)}
selectInput(
"qsec_sel",
"Select qsec:",
unique(temp$qsec),
selected = NULL,
multiple = T,
selectize = T
)
})
output$model <- renderUI({
temp = mtcars
if (!is.null(input$disp_sel)){temp = temp %>% filter(disp %in% input$disp_sel)}
if (!is.null(input$qsec_sel)){temp = temp %>% filter(qsec %in% input$qsec_sel)}
selectInput(
"model_sel",
"Select model:",
unique(temp$model),
selected = NULL,
multiple = T,
selectize = T
)
})
output$selectedModel <- renderUI({
req(input$add)
selectInput(
"list_of_selections",
"Selected models:",
unique(mtcars$model),
selected = NULL, # this should change when "Add" is pressed
multiple = T,
selectize = T
)
})
r_data = eventReactive(input$add,{
mtcars %>% filter(model %in% input$list_of_selections)
})
output$data_analysis <- renderPlot({
# do something with r_data (filtered data)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I've looked into modular code, reactive lists, and other stuff I don't even remember... Any help is greatly appreciated.
Try this
data("mtcars")
mtcars$model <- rownames(mtcars)
df1 <- mtcars
ui <- fluidPage(
titlePanel("sample"),
sidebarLayout(
sidebarPanel(
uiOutput("disp"),
uiOutput("qsec"),
uiOutput("model"),
actionButton("add", "Add"),
uiOutput("selectedModel")
),
mainPanel(
DTOutput("selecteddata"),
plotOutput("data_analysis")
)
)
)
server <- function(input, output) {
output$disp <- renderUI({
selectInput(
"disp_sel",
"Select disp:",
unique(mtcars$disp),
selected = NULL,
multiple = T,
selectize = T
)
})
output$qsec <- renderUI({
temp = mtcars
if (!is.null(input$disp_sel)){temp = temp %>% filter(disp %in% input$disp_sel)}
selectInput(
"qsec_sel",
"Select qsec:",
unique(temp$qsec),
selected = NULL,
multiple = T,
selectize = T
)
})
output$model <- renderUI({
temp = mtcars
if (!is.null(input$disp_sel)){temp = temp %>% filter(disp %in% input$disp_sel)}
if (!is.null(input$qsec_sel)){temp = temp %>% filter(qsec %in% input$qsec_sel)}
selectInput(
"model_sel",
"Select model:",
unique(temp$model),
selected = NULL,
multiple = T,
selectize = T
)
})
selected_data <- eventReactive(input$add,{
df1 %>% filter(model %in% input$model_sel)
})
output$selecteddata <- renderDT(
selected_data(), # reactive data
class = "display nowrap compact", # style
filter = "top", # location of column filters
options = list( # options
scrollX = TRUE # allow user to scroll wide tables horizontally
)
)
output$selectedModel <- renderUI({
req(input$add)
selectInput(
"list_of_selections",
"Selected models:",
choices = unique(selected_data()$model),
selected = unique(selected_data()$model), # this should change when "Add" is pressed
multiple = T,
selectize = T
)
})
r_data = eventReactive(input$add,{
mtcars %>% filter(model %in% input$list_of_selections)
})
output$data_analysis <- renderPlot({
ggplot(data=selected_data(), aes(x=disp, y=qsec)) + geom_point()
# do something with r_data (filtered data)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Found the answer. I included
selected <- reactiveValues(s = NULL)
observeEvent(input$add,{selected$s = c(selected$s, input$model})
into the server part. Then the selected models are stored in selected$s.
Issues between inputs and plot output
Hi,
I'm testing out a basic ShinyApp where I can generate a plot of commercial services broken down by geography and service type.
The idea is I want the user to use three drop-down menu inputs, each dependent upon the previous selection, to subset the data, which then gets output in a ggplot.
However, I'm having issues connecting the inputs to the plot output (see below). The inputs are working fine and reactive when selected, but I can't work out how to link that to the plot, I get the feeling I'm not using the right data source (but have no idea how to ensure it is). Furthermore, I'm not familiar with how I would go about adding a third filter (for "service") seeing as I don't know how to link my data source in the first place.
Sorry this is probably simple, but some help would be really appreciated.
UI
#Data
Test <- dataframe(
Geography1 = c("Region","Local Authority","County"...),
Geography2 = c("North West","Aldershot","Cheshire"...),
Service = c("Shop","Cafe","Library"...),
Overall_rating = c("Awesome","Good","Fantatstic"...),
Locations = c(4000, 1300, 1700...)
)
#SHINY APP
ui <- fluidPage(
titlePanel("Tool"),
sidebarLayout(
sidebarPanel(
uiOutput("geography1"),
uiOutput("geography2"),
uiOutput("service")),
mainPanel(
plotOutput("plot", height = "400px"))
)
)
Server
server <- function(input, output) {
output$geography1 = renderUI({
selectInput(inputId = "geog1",
label = "Geography 1:",
choices = as.character(unique(Test$Geography1)),
selected = "Region")
})
output$geography2 = renderUI({
datasub <- Test[Test$Geography1 == input$geog1, "Name"]
selectInput(inputId = "geog2",
label = "Geography2:",
choices = unique(datasub),
selected = unique(datasub)[1])
})
output$service = renderUI({
datasub2 <- unique(datasub)
selectInput(inputId = "service",
label = "Service type:",
choices = unique(...),
selected = unique(...)[1])
})
output$plot = renderPlot({
ggplot(datasub2(),aes(x = Overall_rating, y = Locations, fill= Overall_rating))+
geom_bar(stat = "identity")
})
}
shinyApp(ui, server)
It's hard to tell how the provided data is supposed to be filtered in the app but this code will at least run and be interactive. Hopefully from there you can figure out how to adjust the dataset.
As BigDataScientist said one fault is that you're not using a reactive dataset.
#Data
Test <- data.frame(
Geography1 = c("Region","Local Authority","County"),
Geography2 = c("North West","Aldershot","Cheshire"),
Service = c("Shop","Cafe","Library"),
Overall_rating = c("Awesome","Good","Fantatstic"),
Locations = c(4000, 1300, 1700)
)
#SHINY APP
ui <- fluidPage(
titlePanel("Tool"),
sidebarLayout(
sidebarPanel(
uiOutput("geography1"),
uiOutput("geography2"),
uiOutput("service")),
mainPanel(
plotOutput("plot", height = "400px"))
)
)
server <- function(input, output) {
output$geography1 = renderUI({
selectInput(inputId = "geog1",
label = "Geography 1:",
choices = as.character(unique(Test$Geography1)),
selected = "Region")
})
datasub <- reactive({
Test[Test$Geography1 == input$geog1,]
})
output$geography2 = renderUI({
selectInput(inputId = "geog2",
label = "Geography2:",
choices = unique(datasub()[,"Geography2"]),
selected = unique(datasub()[,"Geography2"])[1])
})
datasub2 <- reactive({
datasub()[Test$Geography2 == input$geog2, ]
})
output$service = renderUI({
selectInput(inputId = "service",
label = "Service type:",
choices = unique(datasub2()[,"Service"]),
selected = unique(datasub2()[,"Service"])[1])
})
datasub3 <- reactive({
datasub()[Test$Service == input$service, ]
})
output$plot = renderPlot({
ggplot(datasub3(),aes(x = Overall_rating, y = Locations, fill= Overall_rating))+
geom_bar(stat = "identity")
})
}
shinyApp(ui, server)