Related
My objective is to plot some graphs based on the data uploaded by users. Users can select how it is plotted. It works but there are warnings showing in the console. I think the issue lies with how the server module looks up values in the UI module but the UI module is not yet initalised. How can I get rid of the warnings? Thanks
Sample data:
fwrite(data.table(
age.band = c("45-54","55-64","55-64","55-64","55-64","45-54","35-44","25-34"),
gender = c("MALE","FEMALE","FEMALE","FEMALE","FEMALE","FEMALE","MALE","FEMALE"),
event = c("13/04/2022","8/04/2022","20/05/2021","12/02/2022","19/02/2021","19/03/2022","16/03/2021","19/03/2021"),
cause = c('Cancer','Cancer','Cancer','Mental Illness','Cancer','Musculoskeletal','Mental Illness','Musculoskeletal'),
type= c('Type1','Type1','Type1','Type2','Type2','Type2','Type2','Type2'),
rate = rep(1,8),
status = rep("accepted",8)
),"sample.csv",row.names=F)
Here is my code:
### UI and server to load data
loadDataUI <- function(id,label = "Upload",buttonLabel = "Browse") {
ns <- NS(id)
tagList(
fileInput(ns("file"),label=label,buttonLabel=buttonLabel,accept = c('.csv'),placeholder = "No file selected")
)
}
loadData <- function(id) {
moduleServer(
id,
function(input, output, session) {
userFile <- reactive({
shiny::validate(need(input$file, message = FALSE))
input$file
})
dt <- reactive({fread(userFile()$datapath)})
return(dt)
}
)
}
### UI and server to plot data
edaUI <- function(id,cat.option) {
ns <- NS(id)
tagList(
box(
dropdown(
selectInput(inputId = ns('category'),
label = 'Category',
choices = cat.option,selected = "all"),
dateRangeInput(ns("eventdaterange"), "Loss date range",
start = Sys.Date()-10,
end = Sys.Date()+10)
),
highchartOutput(ns("hc_init"))
)
)
}
eda <- function(id,filtered.data,measure){
moduleServer(
id,
function(input, output, session) {
observeEvent(filtered.data(), {
updateDateRangeInput(session,"eventdaterange",
start = min(filtered.data()$event),
end = max(filtered.data()$event))
})
output$hc_init <- renderHighchart({
tmp <- filtered.data() %>%
filter(event >= input$eventdaterange[1],event <= input$eventdaterange[2]) %>%
mutate(event.date = as.character(as.yearqtr(event)))
if (input$category == "all") {
tmp %>% group_by(event.date) %>%
summarise(measure=sum(!!sym(measure))) %>%
hchart("line", hcaes(x = event.date, y = measure)) %>%
hc_title(text="Chart")
} else {
tmp %>%
group_by(cat = !!sym(input$category),event.date) %>%
summarise(measure=sum(!!sym(measure))) %>% ungroup() %>%
arrange(cat,event.date) %>%
hchart("line", hcaes(x = event.date, y = measure,group = cat)) %>%
hc_title(text="Chart")
}
})
}
)
}
### Main UI and server
ui <- function() {
fluidPage(useShinydashboard(),
navbarPage(
tabPanel(
title = "Data analysis",
sidebarLayout(
sidebarPanel(
width = 2,
loadDataUI("input","","Upload data"),
awesomeRadio(
inputId = "benefit",
label = strong("Select type"),
choices = c("Type1", "Type2"),
selected = NULL,inline = TRUE,checkbox = FALSE)
),
mainPanel(
width = 10,edaUI("dt1",cat.option=c("all","age.band","gender"))
)
)
)
)
)
}
server <- function(input, output, session) {
data <- loadData("input")
filtered_data <- reactive({
date.cols <- c("event")
data()[type == input$benefit][,(date.cols):= lapply(.SD, dmy),.SDcols = date.cols]
})
eda("dt1",filtered_data,measure="rate")
}
shinyApp(ui = ui, server = server)
I'm working on a shiny dashboard that makes heavy use of shiny modules and my client has asked me to make it so that the same two inputs from my dashboard's various tabs take on the same values regardless of tab. I'm having a huge problem doing this and was able to recreate it using a toy example that you'll find below.
#app.R
library(data.table)
library(shiny)
library(ggplot2)
library(ggthemes)
library(shinythemes)
source("Modules.R")
penguins <<- as.data.table(palmerpenguins::penguins)
ui = uiOutput("ui")
inputs <<- reactiveValues(species = NULL, island = NULL)
server <- function(input, output, session) {
bill_species_server("tab1")
flipper_mass_scatter_server("tab2")
output$ui = renderUI({
fluidPage(
titlePanel("", "Penguin Dashboard"),
tabsetPanel(
tabPanel("Bill Length by Species",
ui_code("tab1")
),
tabPanel("Flipper Length by Body Mass",
ui_code("tab2")
)
)
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
#Modules.R
ui_code = function (id) {
ns = NS(id)
sidebarLayout(position = "left",
sidebarPanel(
selectInput(ns("species"), "Choose 1+ species:", choices = penguins[, sort(unique(species))], multiple = TRUE),
selectInput(ns("island"), "Choose 1+ islands:", choices = penguins[, sort(unique(island))], multiple = TRUE)
),
mainPanel(
plotOutput(ns("plot"))
)
)
}
bill_species_server = function(id) {
moduleServer(id, function(input, output, session) {
observeEvent(inputs$species, ignoreInit = TRUE, ignoreNULL = TRUE, {
if (length(inputs$species) > 0) {
updateSelectInput(session = session, inputId = "species", selected = inputs$species)
}
})
observeEvent(inputs$island, ignoreInit = TRUE, ignoreNULL = TRUE, {
if (length(inputs$island) > 0) {
updateSelectInput(session = session, inputId = "island", selected = inputs$island)
}
})
output$plot = renderPlot({
if (length(input$species) > 0) {
penguins = penguins[species %in% input$species]
}
if (length(input$island) > 0) {
penguins = penguins[island %in% input$island]
}
ggplot(penguins) + geom_histogram(aes(x = `bill_length_mm`, fill = species)) + scale_fill_canva(palette = "Striking and energetic")
})
observeEvent(input$species, ignoreNULL = TRUE, ignoreInit = TRUE, {
inputs$species = input$species
})
observeEvent(input$island, ignoreNULL = TRUE, ignoreInit = TRUE, {
inputs$island = input$island
})
})
return(inputs)
}
flipper_mass_scatter_server = function (id) {
moduleServer(id, function(input, output, session) {
observeEvent(inputs$species, ignoreInit = TRUE, ignoreNULL = TRUE, {
if (length(inputs$species) > 0) {
updateSelectInput(session = session, inputId = "species", selected = inputs$species)
}
})
observeEvent(inputs$island, ignoreInit = TRUE, ignoreNULL = TRUE, {
if (length(inputs$island) > 0) {
updateSelectInput(session = session, inputId = "island", selected = inputs$island)
}
})
output$plot = renderPlot({
if (length(input$species) > 0) {
penguins = penguins[species %in% input$species]
}
if (length(input$island) > 0) {
penguins = penguins[island %in% input$island]
}
ggplot(penguins) + geom_point(aes(x = `flipper_length_mm`, y = body_mass_g, colour = species)) + scale_colour_canva(palette = "Striking and energetic")
})
observeEvent(input$species, ignoreNULL = TRUE, ignoreInit = TRUE, {
inputs$species = input$species
})
observeEvent(input$island, ignoreNULL = TRUE, ignoreInit = TRUE, {
inputs$island = input$island
})
})
return(inputs)
}
So the two inputs that I'm trying to link in this toy example are species and island. I've set it up so that when someone makes a new selection on either input, an observer should update a global variable which in this case I've labelled inputs. And then if inputs is updated, the other tab should then update its own selectInput.
Weirdly, I find that with this code, if I make my selections kind of slowly, all works just fine! However, the moment that I click 2+ choices in rapid succession, it causes an infinite loop to happen in the current tab where the second choice appears, then disappears, then appears... etc. Conversely, when I have 3 choices selected and try to delete options in rapid succession, it just doesn't let me delete all choices!!
So weird.
Anyone know what the problem is with my code, and how I can force the inputs in both tabs to keep the same values as chosen in the other tabs?
Thanks!
I significantly restructured how I approached this problem and came up with a solution. Basically, I used shinydashboard and decided that I would define the species and island selectInput controls outside of my modules.
The values to those controls were then passed to the modules as reactive objects that were then used to filter the data before the data got plotted. This works so much better now! Have a look at my two files:
#app.R
library(data.table)
library(shiny)
library(ggplot2)
library(ggthemes)
library(shinythemes)
library(shinydashboard)
source("Modules.R")
penguins <<- as.data.table(palmerpenguins::penguins)
ui = dashboardPage(header = dashboardHeader(title = "Penguin Dashboard"),
sidebar = dashboardSidebar(
sidebarMenu(id = "tabs",
selectInput("species", "Choose 1+ species:", choices = penguins[, sort(unique(species))], multiple = TRUE),
selectInput("island", "Choose 1+ islands:", choices = penguins[, sort(unique(island))], multiple = TRUE),
menuItem("Bill Length by Species", expandedName = "tab1", tabName = "tab1", startExpanded = TRUE,
sliderInput("mass", "Select a range of body masses:",
min = penguins[, min(body_mass_g, na.rm=TRUE)],
max = penguins[, max(body_mass_g, na.rm=TRUE)],
value = penguins[, range(body_mass_g, na.rm=TRUE)])
),
menuItem("Flipper Length by Body Mass", expandedName = "tab2", tabName = "tab2",
checkboxGroupInput("sex", "Choose sex of penguins:",
choices = c("male","female")))
)),
body = dashboardBody(
uiOutput("plots")
)
)
#inputs <<- reactiveValues(species = NULL, island = NULL)
server <- function(input, output, session) {
#inputs <- reactiveValues(species=input$species, island=input$island)
in_species = reactive({input$species})
in_island = reactive({input$island})
in_mass = reactive({input$mass})
in_sex = reactive({input$sex})
bill_species_server("tab1", in_species, in_island, in_mass)
flipper_mass_scatter_server("tab2", in_species, in_island, in_sex)
output$plots = renderUI({
validate(need(!is.null(input$sidebarItemExpanded), ""))
if (input$sidebarItemExpanded == "tab1") {
ui_code("tab1")
} else {
ui_code("tab2")
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
#Modules.R
ui_code = function (id) {
ns = NS(id)
plotOutput(ns("plot"))
}
bill_species_server = function(id, in_species, in_island, in_mass) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
output$plot = renderPlot({
if (length(in_species()) > 0) {
penguins = penguins[species %in% in_species()]
}
if (length(in_island()) > 0) {
penguins = penguins[island %in% in_island()]
}
penguins = penguins[body_mass_g %between% c(in_mass()[1], in_mass()[2])]
ggplot(penguins) + geom_histogram(aes(x = `bill_length_mm`, fill = species)) + scale_fill_canva(palette = "Striking and energetic")
})
})
}
flipper_mass_scatter_server = function (id, in_species, in_island, in_sex) {
moduleServer(id, function(input, output, session) {
output$plot = renderPlot({
if (length(in_species()) > 0) {
penguins = penguins[species %in% in_species()]
}
if (length(in_island()) > 0) {
penguins = penguins[island %in% in_island()]
}
if (length(in_sex()) > 0) {
penguins = penguins[sex %in% in_sex()]
}
ggplot(penguins) + geom_point(aes(x = `flipper_length_mm`, y = body_mass_g, colour = species)) + scale_colour_canva(palette = "Striking and energetic")
})
})
}
I'm dynamically generating inputs using a custom function render_panels that creates a wellPanel with a selectizeInput and actionButton contained within, the actionButton removes the entire wellPanel using removeUI by using the id of the div as the selector. I also have a global add button to add new wellPanel.
I have a method to remove the wellPanel by observing the remove button event for each panel, then using removeUI and specifying corresponding div id as selector, but I'm wondering if there is a more efficient method to do this with either for loop or vectorized approach.
Edit Note: Instead of insertUI, I'm specifically using this approach in order to provide the ability to initialize the app with panels already inserted. The shiny app will be executed as a function where users could provide a character vector of dropdown selection values, for example. I've added a character vector prevInputs inside server, a reactive value counter$n which has replaced input$add in order to create initial panels of length(prevInputs) if !is.null(prevInputs) and a method to initialize the selected values argument for selectizeInput with existing values inside make_panels to illustrate the point.
See reprex:
library(shiny)
render_panels <- function(n, removed_panels, inputs){
make_panels <- function(n, inputs){
panels <- tags$div(id = n,
wellPanel(
selectizeInput(inputId = paste0("dropdown", n), label = paste0("dropdown", n), choices = c("a", "b", "c"), selected = inputs[[paste0("dropdown", n)]]),
actionButton(paste0("remove", n), label = paste0("remove", n))
)
)
}
ui_out <- vector(mode = "list", length = n)
for(i in seq_along(ui_out)){
if(i %in% removed_panels) next
ui_out[[i]] <- tagList(
make_panels(n = i, inputs)
)
}
return(ui_out)
}
ui <- fluidPage(
fluidRow(
column(width = 6,
actionButton("add", label = "add"),
uiOutput("mypanels")
)
)
)
server <- function(input, output, session){
removed <- reactiveValues(
values = list()
)
prevInputs <- c("a", "b", "c")
reactiveInputs <- reactiveValues(values = list())
observe({
reactiveInputs$values$dropdown1 = prevInputs[[1]]
reactiveInputs$values$dropdown2 = prevInputs[[2]]
reactiveInputs$values$dropdown3 = prevInputs[[3]]
})
counter <- reactiveValues(n = ifelse(!is.null(prevInputs), length(prevInputs), 0))
observeEvent(input$add, {
counter$n <- counter$n + 1
})
observeEvent(input$remove1,{
removed$values <- c(removed$values, 1)
removeUI(
selector = "div#1", immediate = TRUE,
)
}, once = TRUE)
observeEvent(input$remove2,{
removed$values <- c(removed$values, 2)
removeUI(
selector = "div#2", immediate = TRUE,
)
}, once = TRUE)
observeEvent(input$remove3,{
removed$values <- c(removed$values, 3)
removeUI(
selector = "div#3", immediate = TRUE,
)
}, once = TRUE)
output$mypanels <- renderUI({
render_panels(n = counter$n, removed_panels = removed$values, inputs = reactiveInputs$values)
})
}
shinyApp(ui, server)
As you can see, if there are 100 wellPanels generated, I'd have to use 100 observeEvent, not what we want...here is my attempt at for loop:
I'd like to replace all observeEvent calls with something like below, but cannot seem to get things working.
observe({
req(input$remove1)
for(i in seq_len(input$add)){
if(input[[paste0("remove", i)]] == 1){
removeUI(selector = paste0("div#", i), immediate = TRUE)
}
}
})
Edit:
Here is an attempt from a provided answer using shinymaterial package for alternative UI. Note shinymaterial package requires you to wrap ui elements in render_material_from_server inside renderUI for any UI generated on the server side i.e.
output$dropdown <- renderUI({
render_material_from_server(
material_dropdown(input_id = paste0("dropdown", n), label = paste0("dropdown", n), choices = c("a", "b", "c"), selected = "a")
)
})
This function render_material_from_server is newly available and only exists in current development version of package on GH: shinymaterial
In any case, insertUI does not render UI elements as expected using material_page UI of from shinymaterial
library(shiny)
library(shinymaterial)
make_panels <- function(n, selected){
tags$div(
material_card(
material_dropdown(input_id = paste0("dropdown", n), label = paste0("dropdown", n), choices = c("a", "b", "c"), selected = selected),
actionButton(paste0("remove", n), label = paste0("remove", n), class = "mybtn")
)
)
}
ui <- material_page(
tags$script("
$(document).on('click', '.mybtn', function(){
$(this).parent().remove();
})
"),
material_row(
material_column(width = 6,
actionButton("add", label = "add"),
uiOutput("mypanels")
)
)
)
server <- function(input, output, session){
choices = c("a", "b", "c")
init_counter <- reactiveVal(3)
observe({
for(i in seq_len(isolate(init_counter()))){
insertUI(selector = "#mypanels", where = "beforeEnd", ui = make_panels(i, choices[i]))
}
})
observeEvent(input$add, {
panel_index <- init_counter() + input$add
insertUI(selector = "#mypanels", where = "beforeEnd", ui = make_panels(panel_index, choices[panel_index]))
})
}
shinyApp(ui, server)
I think that this situation is a good usecase for modules. Basically, you only write the code once how to generate a panel and then call this module every time you want a new panel. Inside the module, the observeEvent is automatically generated so you don't have to repeat code.
2 things to add:
if you want to access the data returned by the module, you need to store the output of the module call in the main server function
having a lot of modules generates a lot of observers. These observers also stay when a module ui is removed. See this blog post how to deal with this if it should get a problem.
library(shiny)
mod_panel_ui <- function(id) {
ns <- NS(id)
panel_number <- regmatches(id,
regexpr("[0-9]+", id))
tags$div(id = id,
wellPanel(
selectizeInput(inputId = ns("dropdown"),
label = paste0("dropdown ", panel_number),
choices = c("a", "b", "c"),
selected = NULL),
actionButton(ns("remove"), label = paste0("remove ", panel_number))
)
)
}
mod_panel <- function(id) {
moduleServer(id,
function(input, output, session) {
observeEvent(input$remove, {
removeUI(selector = paste0("div#", id))
})
})
return(list(
dropdown = reactive(input$dropdown)
))
}
ui <- fluidPage(
fluidRow(
column(width = 6,
actionButton("add", label = "add"),
div(id = "add_panels_here")
)
)
)
server <- function(input, output, session) {
counter_panels <- 1
observeEvent(input$add, {
current_id <- paste0("panel_", counter_panels)
mod_panel(current_id)
insertUI(selector = "#add_panels_here",
ui = mod_panel_ui(current_id))
# update counter
counter_panels <<- counter_panels + 1
})
}
shinyApp(ui, server)
Edit
Here is a solution that uses shinymaterial and already shows 2 panels on startup. The selected element can be specified by an additional argument to the module server function:
library(shiny)
library(shinymaterial)
mod_panel_ui <- function(id) {
ns <- NS(id)
uiOutput(ns("placeholder"))
}
mod_panel <- function(id, selection = NULL) {
moduleServer(id,
function(input, output, session) {
# generate the UI on the server side
ns <- session$ns
panel_number <- regmatches(id,
regexpr("[0-9]+", id))
output$placeholder <- renderUI({render_material_from_server(tags$div(id = id,
material_card(
material_dropdown(input_id = ns("dropdown"),
label = paste0("dropdown ", panel_number),
choices = c("a", "b", "c"),
selected = selection),
actionButton(ns("remove"), label = paste0("remove ", panel_number))
)
))
})
# remove the element
observeEvent(input$remove, {
removeUI(selector = paste0("div#", id))
})
})
return(list(
dropdown = reactive(input$dropdown)
))
}
ui <- material_page(
material_row(
material_column(width = 6,
actionButton("add", label = "add"),
div(id = "add_panels_here")
)
)
)
server <- function(input, output, session) {
counter_panels <- 1
panels_on_startup <- 2
selected_on_startup <- c("b", "c")
# add counters on startup
lapply(seq_len(panels_on_startup), function(i) {
current_id <- paste0("panel_", counter_panels)
mod_panel(current_id, selected_on_startup[i])
insertUI(selector = "#add_panels_here",
ui = mod_panel_ui(current_id))
# update counter
counter_panels <<- counter_panels + 1
})
observeEvent(input$add, {
current_id <- paste0("panel_", counter_panels)
mod_panel(current_id)
insertUI(selector = "#add_panels_here",
ui = mod_panel_ui(current_id))
# update counter
counter_panels <<- counter_panels + 1
})
}
shinyApp(ui, server)
There is a very simple way to do so if you know some javascript.
There is no need to use for loop
There is no need to save things in a list.
There is no need for renderUI
There is no need to observe every panel
All you need to do is add a js listener to the remove button and add a class in R class = "mybtn" for js to listen to.
$(document).on('click', '.mybtn', function(){
$(this).parent().remove();
})
In your server, you need to think the reverse way, using insertUI rather than removeUI. You only need one observer for the add button. When every time you click on add, add a panel to a div. In my case, I'm lazy, so I just directly select your uiOutput("mypanels")
library(shiny)
make_panels <- function(n){
tags$div(
wellPanel(
selectizeInput(inputId = paste0("dropdown", n), label = paste0("dropdown", n), choices = c("a", "b", "c"), selected = NULL),
actionButton(paste0("remove", n), label = paste0("remove", n), class = "mybtn")
)
)
}
ui <- fluidPage(
tags$script("
$(document).on('click', '.mybtn', function(){
$(this).parent().remove();
})
"),
fluidRow(
column(width = 6,
actionButton("add", label = "add"),
uiOutput("mypanels")
)
)
)
server <- function(input, output, session){
observeEvent(input$add, {
insertUI(selector = "#mypanels", where = "beforeEnd", ui = make_panels(input$add))
})
observe({
print(input$dropdown5)
})
}
shinyApp(ui, server)
To make sure this works, I add a test observer to watch the dropdown5 (the dropdown when you add the 5th panel). You will see the dropdown value in console once you add the 5th panel.
EDIT for your note:
You can still insert with preset panels. Add a reactive counter for how many panels you want to initiate. Just make sure you isolate the counter and the choice if that is reactive too. In my example choice is hard-coded so I didn't isolate. This is to prevent the panel initialization been run later. The observe I added will only run once.
I also use [] instead of [[]] which gives NA instead of error when out of boundary.
library(shiny)
make_panels <- function(n, selected){
tags$div(
wellPanel(
selectizeInput(inputId = paste0("dropdown", n), label = paste0("dropdown", n), choices = c("a", "b", "c"), selected = selected),
actionButton(paste0("remove", n), label = paste0("remove", n), class = "mybtn")
)
)
}
ui <- fluidPage(
tags$script("
$(document).on('click', '.mybtn', function(){
$(this).parent().remove();
})
"),
fluidRow(
column(width = 6,
actionButton("add", label = "add"),
uiOutput("mypanels")
)
)
)
server <- function(input, output, session){
choices = c("a", "b", "c")
init_counter <- reactiveVal(3)
observe({
for(i in seq_len(isolate(init_counter()))){
insertUI(selector = "#mypanels", where = "beforeEnd", ui = make_panels(i, choices[i]))
}
})
observeEvent(input$add, {
panel_index <- init_counter() + input$add
insertUI(selector = "#mypanels", where = "beforeEnd", ui = make_panels(panel_index, choices[panel_index]))
})
}
shinyApp(ui, server)
To work with materialUI:
change the tags$script() to this one
library(shiny)
library(shinymaterial)
make_panels <- function(n, selected){
tags$div(
material_card(
material_dropdown(input_id = paste0("dropdown", n), label = paste0("dropdown", n), choices = c("a", "b", "c"), selected = selected),
actionButton(paste0("remove", n), label = paste0("remove", n), class = "mybtn")
)
)
}
ui <- material_page(
HTML("<script>
$(document).on('click', '.mybtn', function(){
$(this).parent().remove();
})
var formatDropdown = function() {
function initShinyMaterialDropdown(callback) {
$('.shiny-material-dropdown').formSelect();
callback();
}
initShinyMaterialDropdown(function() {
var shinyMaterialDropdown = new Shiny.InputBinding();
$.extend(shinyMaterialDropdown, {
find: function(scope) {
return $(scope).find('select.shiny-material-dropdown');
},
getValue: function(el) {
var ans;
ans = $(el).val();
if (ans === null) {
return ans;
}
if (typeof(ans) == 'string') {
return ans.replace(new RegExp('_shinymaterialdropdownspace_', 'g'), ' ');
} else if (typeof(ans) == 'object') {
for (i = 0; i < ans.length; i++) {
if (typeof(ans[i]) == 'string') {
ans[i] = ans[i].replace(new RegExp('_shinymaterialdropdownspace_', 'g'), ' ');
}
}
return ans;
} else {
return ans;
}
},
subscribe: function(el, callback) {
$(el).on('change.shiny-material-dropdown', function(e) {
callback();
});
},
unsubscribe: function(el) {
$(el).off('.shiny-material-dropdown');
}
});
Shiny.inputBindings.register(shinyMaterialDropdown);
});
}
$(document).ready(function(){
setTimeout(formatDropdown, 500);
})
$(document).on('click', '#add', function(){
setTimeout(formatDropdown, 100);
})
</script>"),
material_row(
material_column(width = 6,
actionButton("add", label = "add"),
uiOutput("mypanels")
)
)
)
server <- function(input, output, session){
choices = c("a", "b", "c")
init_counter <- reactiveVal(3)
observe({
for(i in seq_len(isolate(init_counter()))){
insertUI(selector = "#mypanels", where = "beforeEnd", ui = make_panels(i, choices[i]))
}
})
observeEvent(input$add, {
panel_index <- init_counter() + input$add
insertUI(selector = "#mypanels", where = "beforeEnd", ui = make_panels(panel_index, choices[panel_index]))
})
}
shinyApp(ui, server)
Good morning,
in my dashboard I inserted a checkbox to select one or more output to display. In the ui I entered the checkbox and in the server all the conditions (if ... else if ...). When I launch the app it only shows me a plot, even when I select more than one choice in the checkbox. In addition it gives me this error in console:
"Warning in if (input$checkGroup == 1) { :the condition has length > 1 and only the first element will be used"
I suppose it's telling me that I can't handle more than one choice, how do I view all the plots I choose?
ui <- fluidPage(titlePanel("IULM Dashboard"), sidebarLayout(sidebarPanel(
selectInput("selection", "Choose a Dataset:",
choices = datasets),
("Barplot","Network",'Wordcloud', "LDA-Latent topic"),
#selected = "Barplot", inline = TRUE),
checkboxGroupInput("checkGroup", label = ("Checkbox group"),
choices = list("Barplot" = 1, "Network" = 2), selected = 1, inline = TRUE),
actionButton("update", "Change"))
, mainPanel(
uiOutput("plot")))
server <- function(input, output){
datasetInput <- reactive({
input$update
isolate({
withProgress({
setProgress(message = "Processing corpus...")
getTermMatrix(input$selection)
})
})
})
output$plot <- renderUI({
if(input$checkGroup== 1 ){
output$barplot <- renderPlot({
v=datasetInput()
dtm1 = removeSparseTerms(v, 0.992)
freq <- colSums(as.matrix(dtm1))
wf = data.frame(term = names(freq), occurrences = freq)
wf <- wf[order(wf$occurrences, decreasing = TRUE),]
wf2 = subset(wf[1:input$maxB,])
ggplot(wf2, aes(term, occurrences)) +
geom_bar(stat="identity", fill="darkred", colour="black", width=0.5)+
theme(axis.text.x=element_text(angle=45, hjust=1))+
ggtitle("Word barplot")})
plotOutput(outputId = "barplot", width = 600, height = 400)
}
else if(input$checkGroup== 2 ){
output$network <- renderPlot({
v=datasetInput()
dtm1 = removeSparseTerms(v, 0.992)
rowTotals <- apply(dtm1 , 1, sum)
dtm2 <- dtm1[rowTotals> 0, ]
wdtm <- weightTf(dtm2)
dtm1 <- removeSparseTerms(wdtm, 0.96)
dfm <- as.dfm(dtm1)
textplot_network(dfm, min_freq = 0.5, omit_isolated = TRUE,
edge_color = "#1F78B4", edge_alpha = 0.5, edge_size = 2,
vertex_color = "#4D4D4D", vertex_size = 2,
vertex_labelsize = 5, offset = NULL)})
plotOutput(outputId = "network", width = 600, height = 600)}
})
}
shinyApp(ui = ui, server = server)
You can try
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxGroupInput("variable", "Variables to show:",
c("Cylinders" = "cyl",
"Transmission" = "am",
"Gears" = "gear"))
),
mainPanel(
uiOutput("plots")
)))
server <- function(input, output) {
output$plots <- renderUI({
req(input$variable)
output = tagList()
if(any(input$variable %in% "cyl")){
tmp <- mtcars$cyl
output[[1]] <- renderPlot({plot(mtcars$mpg, tmp)})
}
if(any(input$variable %in% "am")){
tmp <- mtcars$am
output[[2]] <- renderPlot({boxplot(mtcars$mpg, tmp)})
}
output
})
}
shinyApp(ui = ui, server = server)
I'm quite a beginner in R Shiny and I would like to create many multiple selectize inputs which are connected with each other. In other words : if an item is selected in one of the selectizeinputs i would like that it disappears from the other selectizeinputs' choices.
Below is an example of what i want (does not work)
modalities <- LETTERS[1:10]
library(shiny)
app <- shinyApp(
ui = tabPanel("Change modalities",
selectizeInput("ui_mod_choose1", label=paste0("Modality 1"),choices=NULL, multiple = TRUE),
selectizeInput("ui_mod_choose2", label=paste0("Modality 2"),choices=NULL, multiple = TRUE),
selectizeInput("ui_mod_choose3", label=paste0("Modality 3"),choices=NULL, multiple = TRUE)
),
server = function(input, output, session) {
observe({
updateSelectizeInput(session,"ui_mod_choose1",choices= modalities)
updateSelectizeInput(session,"ui_mod_choose2",choices= modalities)
updateSelectizeInput(session,"ui_mod_choose3",choices= modalities)
})
}
)
runApp(app)
EDIT : Here is a solution based on Bertil Nestorius' answer
modalities <- LETTERS[1:10]
library(shiny)
app <- shinyApp(
ui = tabPanel("Change modalities",
numericInput("ui_number", label="Number of modalities",min = 1, max = 4, value=3),
uiOutput("renderui")
),
server = function(input, output, session) {
output$renderui <- renderUI({
output = tagList()
for(i in 1:input$ui_number){
output[[i]] = tagList()
output[[i]][[1]] = selectizeInput(paste0("ui_mod_choose",i), label=paste0("Modality ",i),choices=modalities, multiple = TRUE)
}
return(output)
})
lapply(
X = 1:100, ####### QUESTION HERE
FUN = function(j){
observeEvent({
input[[paste0("ui_mod_choose",j)]]
},
{
sapply(1:input$ui_number,function(i){
vecteur <- do.call(c,lapply((1:input$ui_number)[-i],function(i){input[[paste0("ui_mod_choose",i)]]}))
updateSelectizeInput(session,paste0("ui_mod_choose",i),choices= modalities[!modalities %in% vecteur],selected = input[[paste0("ui_mod_choose",i)]])
})
},
ignoreNULL = FALSE)
}
)
observeEvent({
input$ui_num
},
{
sapply(1:nput$ui_num,function(i){
updateSelectizeInput(session,paste0("ui_mod_choose",i),choice= modalities,selected=NULL)
})
}
)
}
)
runApp(app)
The only problem I have left is on the following line :
X = 1:100, ####### QUESTION HERE
See this issue for more information : lapply function using a numericInput parameter around an observeEvent in RShiny
To have them all interconnected I would do something like this
modalities <- LETTERS[1:10]
library(shiny)
app <- shinyApp(
ui = tabPanel("Change modalities",
selectizeInput("ui_mod_choose1", label=paste0("Modality 1"),choices=NULL, multiple = TRUE),
selectizeInput("ui_mod_choose2", label=paste0("Modality 2"),choices=NULL, multiple = TRUE),
selectizeInput("ui_mod_choose3", label=paste0("Modality 3"),choices=NULL, multiple = TRUE)
),
server = function(input, output, session) {
observe({
updateSelectizeInput(session,"ui_mod_choose1",choices= modalities)
updateSelectizeInput(session,"ui_mod_choose2",choices= modalities)
updateSelectizeInput(session,"ui_mod_choose3",choices= modalities)
})
observeEvent({
input$ui_mod_choose2
input$ui_mod_choose3
},
{
updateSelectizeInput(session,"ui_mod_choose1",choices= modalities[!modalities %in% c(input$ui_mod_choose2,input$ui_mod_choose3)],selected = input$ui_mod_choose1)
},
ignoreNULL = FALSE)
observeEvent({
input$ui_mod_choose1
input$ui_mod_choose3
},
{
updateSelectizeInput(session,"ui_mod_choose2",choices= modalities[!modalities %in% c(input$ui_mod_choose1,input$ui_mod_choose3)],selected = input$ui_mod_choose2)
},
ignoreNULL = FALSE)
observeEvent({
input$ui_mod_choose2
input$ui_mod_choose1
},
{
updateSelectizeInput(session,"ui_mod_choose3",choices= modalities[!modalities %in% c(input$ui_mod_choose2,input$ui_mod_choose1)],selected = input$ui_mod_choose3)
},
ignoreNULL = FALSE)
}
)
runApp(app)
Something like this?
rm(list = ls())
library(shiny)
modalities <- LETTERS[1:10]
app <- shinyApp(
ui = tabPanel("Change modalities",
selectizeInput("ui_mod_choose1", label=paste0("Modality 1"),choices= modalities, multiple = TRUE),
selectizeInput("ui_mod_choose2", label=paste0("Modality 2"),choices=NULL, multiple = TRUE),
selectizeInput("ui_mod_choose3", label=paste0("Modality 3"),choices=NULL, multiple = TRUE)
),
server = function(input, output, session) {
observe({
updateSelectizeInput(session,"ui_mod_choose2",choices = modalities[!modalities%in% input$ui_mod_choose1])
})
observe({
updateSelectizeInput(session,"ui_mod_choose3",choices = modalities[!modalities %in% c(input$ui_mod_choose1,input$ui_mod_choose2)])
})
}
)
runApp(app)