I am trying to use a basin, and then update the possible choices of sub-basins within that basin.
However, my code is not working. I cannot make it work neither with observe, nor with reactive, nor with observeEvent nor without all of them.
My ui side is as:
selectInput(inputId = 'countyType_id',
label = '1. Select a basin',
choices = all_basins
),
selectizeInput(inputId = 'subbasins_id',
label = '2. Select subbasins',
choices = subbasins,
selected = head(subbasins, 1),
multiple = TRUE)
and the server side looks like :
observe({
#
# from
# https://shiny.rstudio.com/reference/shiny/latest/updateSelectInput.html
#
subbasins <- sort(unique(curr_spatial$subbasin))
# Can also set the label and select items
updateSelectizeInput(session,
server = FALSE,
"subbasins_id",
label = "2. Select subbasins",
choices = subbasins,
selected = head(subbasins, 1)
)
# It seems the followin has no effect:
# and when it is outside observe, it produces errors!
curr_spatial <- curr_spatial %>%
filter(subbasin %in% input$subbasins_id) %>%
data.table()
})
Any input? please.
I did put the data and the whole code in google drive:
https://drive.google.com/file/d/1qaZG6-VmBhIgMsxs5dffX9PmagkMhuB8/view?usp=sharing
The second selectInput should render from the server and not from the UI to be interactive.
ui.R
selectInput(inputId = 'countyType_id',
label = '1. Select a basin',
choices = all_basins
),
uiOutput('subbasins_id')
server.R
output$subbasins_id <- renderUI({
## add some code to filter subbasin based on the selected basin, i.e. input$countyType_id
curr_spatial <- curr_spatial %>%
filter(subbasin %in% input$subbasins_id) %>%
data.table()
subbasins <- sort(unique(curr_spatial$subbasin))
selectizeInput(inputId = 'subbasins_id',
label = '2. Select subbasins',
choices = subbasins,
selected = head(subbasins, 1),
multiple = TRUE)
})
Related
I am trying to build an interactive data table that changes the displayed columns based on filters chosen by the user. The aim is to have a user select the columns they want to see via a dropdown, which will then cause the datatable to display those columns only.
library(shinyWidgets)
library(DT)
ui <-
fluidPage(
fluidRow(
box(width = 4,
pickerInput(inputId = "index_picker",
label = "Select index/indices",
choices = c("RPI", "RPIX", "CPI", "GDP Deflator"),
selected = "RPI",
multiple = T
)
)
)
fluidRow(
box(DT::dataTableOutput("index_table"), title = "Historic Inflation Indices", width = 12,
solidHeader = T, status = "primary")
)
)
server <- function(input, output, session) {
df_filt <- reactive({
if({
input$index_picker == "RPI" &
!is.null()
})
df_index %>%
select(Period, RPI.YOY, RPI.INDEX)
else if({
input$index_picker == "RPIX"
})
df_index %>%
select(Period, RPIX.YOY, RPIX.INDEX)
})
output$index_table <- renderDataTable({
DT::datatable(df_filt(),
options =
list(dom = "itB",
fixedHeader = T
),
rownames = F
)
})
}
I have similar code to the above that filters based on the row instead, and this works just fine, however, for this column filtering I am getting this error:
Warning in if ({ : the condition has length > 1 and only the first element will be used
I understand that I'm passing a vector to the if statement, but not sure how to recode - would anyone be able to help?
I am trying to generate a shiny app that will first allow the user to (using the notion of dplyr verbs) select the variables they are interested in and then filter those variables based on subsequent selections. I am trying to do this using conditionalPanel() but I am getting stuck finding a way to access the input$ from each conditional panel.
Here is an example:
library('shiny')
library('tidyverse')
library('shinyWidgets')
#Create the data
data <- select(mtcars, c(gear, carb))
#Create page with sidebarlayout
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
#Create picker input where relevant variables are selected
pickerInput(
inputId = 'vars',
label = 'Variables',
choices = colnames(data),
selected = colnames(data),
multiple = T,
pickerOptions(actionsBox = TRUE)
),
#Create conditional panels which show when the variable above is selected
#These panels will be used to filter the data that is selected based on the above variables
conditionalPanel(condition = "input.vars.includes('gear')",
pickerInput(inputId = 'gear',
label = 'Gear',
choices = unique(data$gear),
selected = unique(data$gear),
multiple = T,
pickerOptions(actionsBox = TRUE)
)
),
conditionalPanel(condition = "input.vars.includes('carb')",
pickerInput(inputId = 'carb',
label = 'Carb',
choices = unique(data$carb),
selected = unique(data$carb),
multiple = T,
pickerOptions(actionsBox = TRUE)
)
)
),
mainPanel(
#Show the selected data
verbatimTextOutput('term_selected'),
#Show the selected and filtered data - this won't show
verbatimTextOutput('term_selected_filtered'),
#Try debug with just getting the
verbatimTextOutput('debug_print')
)
)
)
server <- function(input, output) {
#Create the reactive selected data
selected_data <- reactive ({
data %>%
select(input$vars)
})
#Render the selected data
output$term_selected <- renderPrint(selected_data())
#This is where i am stuck
#I need to find a way to access the inputs related to the conditional functions
# selected_filtered_data <- reactive ({
# for (i in length(input$vars)) {
# selected_data() %>%
# filter(input$[first condiitonal panel select] %in% as.symbol(input$vars[i])
# }
# })
#
output$term_selected_filtered <- renderPrint(selected_filtered_data())
#Try to render input input$[first item of input.vars]
output$debug_print <- renderPrint(input$as.symbol(input$vars[1]))
}
shinyApp(ui = ui, server = server)
The problem lies in the server. I have tried input$as.symbol(input$vars[1]) to access the input$gear (assuming that was selected), but it just throws the error: attempt to apply non-function. I tried adding !! as syntactic sugar in front of as.symbol(), but that makes no difference.
I also tried this, in the hope that i could conditionally filter, and had no luck.
selected_filtered_data <- reactive({
selected_data() %>%
if('gear' %in% input$vars) {
filter(gear %in% input$gear) %>%
}
if('carb' %in% input$vars) {
filter(carb %in% input$carb)
}
})
How should I go about doing this?
We may use across (if we want to filter the rows when both column conditions are TRUE) or replace across with if_any (if either one of them is TRUE when they are both selected)
selected_data() %>%
filter(across(all_of(intersect(input$vars,
c('gear', "carb"))), ~ .x %in% input[[cur_column()]]))
-full code
library('shiny')
library('dplyr')
library(tidyr)
library('shinyWidgets')
#Create the data
data <- select(mtcars, c(gear, carb))
#Create page with sidebarlayout
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
#Create picker input where relevant variables are selected
pickerInput(
inputId = 'vars',
label = 'Variables',
choices = colnames(data),
selected = colnames(data),
multiple = TRUE,
pickerOptions(actionsBox = TRUE)
),
#Create conditional panels which show when the variable above is selected
#These panels will be used to filter the data that is selected based on the above variables
conditionalPanel(condition = "input.vars.includes('gear')",
pickerInput(inputId = 'gear',
label = 'Gear',
choices = unique(data$gear),
selected = unique(data$gear),
multiple = T,
pickerOptions(actionsBox = TRUE)
)
),
conditionalPanel(condition = "input.vars.includes('carb')",
pickerInput(inputId = 'carb',
label = 'Carb',
choices = unique(data$carb),
selected = unique(data$carb),
multiple = TRUE,
pickerOptions(actionsBox = TRUE)
)
)
),
mainPanel(
#Show the selected data
verbatimTextOutput('term_selected'),
#Show the selected and filtered data - this won't show
verbatimTextOutput('term_selected_filtered'),
#Try debug with just getting the
verbatimTextOutput('debug_print')
)
)
)
server <- function(input, output) {
#Create the reactive selected data
selected_data <- reactive ({
req(input$vars)
data %>%
select(input$vars)
})
#Render the selected data
output$term_selected <- renderPrint(selected_data())
#This is where i am stuck
#I need to find a way to access the inputs related to the conditional functions
selected_filtered_data <- reactive ({
selected_data() %>%
filter(across(all_of(intersect(input$vars, c('gear', "carb"))), ~ .x %in% input[[cur_column()]]))
})
#
output$term_selected_filtered <- renderPrint(
selected_filtered_data()
)
output$debug_print <- renderPrint(input[[input$vars[1]]])
}
shinyApp(ui = ui, server = server)
-output
This one has me really going around in circles.
I am working on an R script that loads a dataframe and uses fields from the dataframe to populate a hierarchical set of selectizeInput. E.g. each of the inputs represent a subset of what is in the previous. Each SubRegion contains multiple LCC’s, Each LCC contains multiple ENB’s, and so on.
When the user select a value in any of the inputs, that value will used to filter the dataframe and all of the other selectizeInputs need to be updated from the filtered data.
It seems to work fine for the first input (SubRegionInput) but every time I try to get it to respond to and/or filter by any of the others (e.g. add input$LCCInput to the observe block) they get populated for a few seconds and then go blank.
I suspect the answer is quite simple and/or I am doing something really dumb, but I am a total hack with no formal R training so am probably missing something quite basic (if so sorry).
Below is a partial chunk of code (sorry I can’t include it all but this is for work and I can’t share the details of what I am doing).
NOTES
The current outputs are just so I can see what is going on while I develop this portion of the code.
I know right now it is only set up to filter on the one value…everything I have tried to do it on more has failed so I included the most functional code I have so far.
ui <- fluidPage(
# Application title
titlePanel("KPI DrillDown"),
# Sidebar with a slider input for number of bins
fluidRow(
selectizeInput("SubRegionInput", "SubRegion", SubRegionList ,selected = NULL, multiple = TRUE),
selectizeInput("LCCInput", "LCC", LCCList,selected = NULL, multiple = TRUE),
selectizeInput("ENBIDInput", "ENBID", ENBIDList,selected = NULL, multiple = TRUE),
selectizeInput("SiteNumInput", "SiteNumber", SiteNumberList,selected = NULL, multiple = TRUE),
selectizeInput("SiteNameInput", "SiteName", SiteNameList,selected = NULL, multiple = TRUE),
selectizeInput("LNCELInput", "LNCell", LNCellList,selected = NULL, multiple = TRUE),
selectizeInput("SectorInput", "Sector", SectorList,selected = NULL, multiple = TRUE),
mainPanel(
#plotOutput("distPlot")
verbatimTextOutput("SubRegionText"),
verbatimTextOutput("LCCText"),
verbatimTextOutput("view")
)
)
)
server <- function(input, output) {
observe({
input$SubRegionInput
temp <- SiteInfo[SiteInfo$SITE_SUB_REGION %in% input$SubRegionInput, ]
thisLCCList = sort(temp$BACKHAUL_LCC[!is.na(temp$BACKHAUL_LCC)])
updateSelectizeInput(session = getDefaultReactiveDomain()
, inputId = "LCCInput"
, choices = thisLCCList
, selected= NULL)
thisENBIDList = sort(temp$ENODEB_ID[!is.na(temp$ENODEB_ID)])
updateSelectizeInput(session = getDefaultReactiveDomain()
, inputId = "ENBIDInput"
, choices = thisENBIDList
, selected= NULL)
thisSiteNumberList = sort(temp$SITE_NUMBER[!is.na(temp$SITE_NUMBER)])
updateSelectizeInput(session = getDefaultReactiveDomain()
, inputId = "SiteNumInput"
, choices = thisSiteNumberList
, selected= NULL)
thisSiteNameList = sort(temp$SITE_NAME[!is.na(temp$SITE_NAME)])
updateSelectizeInput(session = getDefaultReactiveDomain()
, inputId = "SiteNameInput"
, choices = thisSiteNameList
, selected= NULL)
thisLNCellList = sort(temp$SECTOR_NUMBER[!is.na(temp$SECTOR_NUMBER)])
updateSelectizeInput(session = getDefaultReactiveDomain()
, inputId = "LNCELInput"
, choices = thisLNCellList
, selected= NULL)
thisSectorList = sort(temp$Sector[!is.na(temp$Sector)])
updateSelectizeInput(session = getDefaultReactiveDomain()
, inputId = "SectorInput"
, choices = thisSectorList
, selected= NULL)
output$view<- renderPrint(temp)
})
Since I do not have access to your data, I used mtcars as an example.
To begin with, since you have so many filtering, I would suggest creating a search or update button, which is what I did in my codes. I only did one filtering using dplyr after extracting all the selectizeInputs. I have to manually change all the empty searching parameter to select all in order to avoid filtering to NA.
Overall, I think the problem with your code was you are observing too many updateSelectizeInputs at once. I did try to recreate using your way, and what I ended with was that I could only update single selectizeInput, and the other selectizeInputs were not selectable.
Hopefully, this method fits your data.
Codes:
library(shiny)
library(dplyr)
library(DT)
data <- mtcars
SubRegionList <- unique(data$cyl)
LCCList <- unique(data$gear)
ENBIDList <- unique(data$am)
SiteNumberList <- unique(data$vs)
# Define UI
ui <- fluidPage(
# Application title
titlePanel("KPI DrillDown"),
# Sidebar with a slider input for number of bins
fluidRow(
selectizeInput("SubRegionInput", "SubRegion/cyl", SubRegionList ,selected = NULL, multiple = TRUE),
uiOutput("LCCInput"),
uiOutput("ENBIDInput"),
uiOutput("SiteNumInput"),
uiOutput("Search"),
mainPanel(
verbatimTextOutput("view")
)
)
)
# Define server logic required
server <- function(input, output, session) {
SiteInfo <- data
# temp <- ""
observe({
if (!is.null(input$SubRegionInput)){
subRegionSelected <- input$SubRegionInput
## Create a temp dataset with the selected sub regions.
temp <- SiteInfo[SiteInfo$cyl %in% subRegionSelected, ]
## Push the newly created selectizeInput to UI
output$LCCInput <- renderUI({
selectizeInput("LCCInput", "LCC/gear", unique(temp$gear), selected = NULL, multiple = TRUE)
})
output$ENBIDInput <- renderUI({
selectizeInput("ENBIDInput", "ENBID/am", unique(temp$am),selected = NULL, multiple = TRUE)
})
output$SiteNumInput <- renderUI({
selectizeInput("SiteNumInput", "SiteNumber/vs", unique(temp$vs), selected = NULL, multiple = TRUE)
})
output$Search <- renderUI({
actionButton("Search", "Search")
})
## Function that linked to the actionButton
display <- eventReactive(input$Search,{
temp <- SiteInfo[SiteInfo$cyl %in% input$SubRegionInput, ]
# ## manually change all the empty searching parameter to select all in order to avoid filtering to NA
LCC <- input$LCCInput
if (is.null(input$LCCInput)){LCC <- unique(temp$gear)}
ENBID <- input$ENBIDInput
if (is.null(input$ENBIDInput)){EBVID <- unique(temp$am)}
SiteNum <- input$SiteNumInput
if (is.null(input$SiteNumInput)){LCC <- unique(temp$vs)}
## Dplyr::filter data
temp <- temp %>%
filter(gear %in% LCC & am %in% ENBID & vs %in% SiteNum)
temp
})
## Run the actionButton
output$view <- renderPrint({
display()
})
} else {
## Display waht the data looks like when no Sub Region is selected
output$view<- renderPrint(data)
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
here is part of code I have written, and the problem I am having is that after selecting both player 1 and player, if I wish to change player 1 again, player 2 also resets. I had to make Player 2's input dependent on Player1 because I do not want the user to be able to select the same player for both the dropdowns. Here is my code:
server.R
shinyServer <- function(input, output) {
# Creates the first drop down menu through which the user can select the first player.
output$firstdropdown <- renderUI({
selectizeInput("player1", label = "Choose Player 1:", choices = winrateRole(input$role)$player,
selected = NULL, multiple = FALSE, options = NULL)
})
# Creates the second drop down menu. User cannot select the same player he/she select as the first player.
output$seconddropdown <- renderUI({
all.choices <- winrateRole(input$role)$player
without.player1 <- all.choices[which(all.choices != input$player1)]
selectizeInput("player2", label = "Choose Player 2:", choices = without.player1,
selected = NULL, multiple = FALSE, options = NULL)
})
ui.R
shinyUI <- fluidPage(
navbarPage(strong("Test1"),
tabPanel("Overview"),
tabPanel("Tab1",
sidebarLayout(
sidebarPanel(
uiOutput("firstdropdown"),
br(),
uiOutput("seconddropdown")
)
))
)
winrateRole
winrateRole <- function(role) {
blue.role <- paste0("blue", role)
blue <- league.data %>%
group_by_(blue.role) %>%
summarise(winrate.blue = round((sum(bResult) / n() * 100), digits = 2)) %>%
arrange_(blue.role) %>%
select(player = blue.role, winrate.blue)
red.role <- paste0("red", role)
red <- league.data %>%
group_by_(red.role) %>%
summarise(winrate.red = round((sum(rResult) / n() * 100), digits = 2)) %>%
arrange_(red.role) %>%
select(player = red.role, winrate.red)
return (left_join(blue, red))
}
your problem is that you recreate the whole input everytime the value of the first select changes.
In this case you want to use the updateInput method which only changes the values you want but leaves the rest unchanged. Unfortunatly updateSelectizeInput seems to reset selected every time choises are changed so you need to save the value of the input in a reactivevariable.
server <- function(input, output, session) {
current_selection <- reactiveVal(NULL)
observeEvent(input$player2, {
current_selection(input$player2)
})
# update player 2
observeEvent({
input$player1
},{
all.choices <- winrateRole
without.player1 <- all.choices[which(all.choices != input$player1)]
updateSelectInput(
inputId = "player2",
session = session,
selected = current_selection(),
choices = without.player1
)
},
ignoreInit = FALSE
)
output$firstdropdown <- renderUI({
selectizeInput(
"player1",
label =
"Choose Player 1:",
choices = winrateRole,
selected = NULL,
multiple = FALSE,
options = NULL) })
# Creates the second drop down menu. User cannot select the same player he/she select as the first player.
output$seconddropdown <- renderUI({
selectizeInput(
"player2",
label = "Choose Player 2:",
choices = winrateRole,
selected = NULL,
multiple = FALSE,
options = NULL)})
}
** ui.R**
shinyUI <- fluidPage(
navbarPage(strong("Test1"),
tabPanel("Overview"),
tabPanel("Tab1",
sidebarLayout(
sidebarPanel(
uiOutput("firstdropdown"),
br(),
uiOutput("seconddropdown")
))
)
I'm a Shiny newbie and was trying to get something simple working, but unable to :(
Here is a part of my ui.R
sidebarLayout(
sidebarPanel(
radioButtons("market",
"Choose a Region to build the Sales file:",
c("North America & ANZ" = "NA", "Europe" = "EU"), inline = TRUE),
conditionalPanel(
condition = "input.market == 'NA'",
radioButtons("Locale",
"Choose a locale to see the sales Calendar:",
c("US and Canada" = "US_CA", "ANZ" = "ANZ"), inline = TRUE),
numericInput("sale_num", "Choose a Sale Number from the Table below",1,width = '100px' )
),
conditionalPanel(
condition = "input.market == 'EU'",
radioButtons("Locale",
"Choose a locale to see the sales Calendar:",
c("UK" = "UK", "FR and RoE" = "FR_ROE","DE,AT & CH" = "DACH"), inline = TRUE),
numericInput("sale_num", "Choose a Sale Number from the Table below",1,width = '100px' )),
dataTableOutput("sales"))
),
Here is my server.R
server <- shinyServer(function(input, output) {
output$sales <- renderDataTable({
saleTable(input$Locale)
},options = list(autoWidth = FALSE,searching = FALSE,pageLength=10))
})
When a change in the market radio button is triggered, the Locale radio does not update and hence the sales output table still has stale values and is not reflected by any change in Locale values.
I know I'm supposed to use something like UpdateRadiobuttons, but I'm not sure how. :(
saleTable is just a function in my Rscript that produces a data table.
Please help!
Thanks in advance!
Please post a minimal example, i.e. your function saleTable. Don't use the same input ID twice in your app, it's bad style and will not work in most cases. Here are two solutions: First one is bad style, second one better style.
1) Rename the second Locale to Locale2 and put this in your output$sales:
output$sales <- renderDataTable({
if(input$market == 'NA') data <- input$Locale
else if(input$market=="EU") data <- input$Locale2
saleTable(data)
}, options = list(autoWidth = FALSE,searching = FALSE,pageLength=10))
)
2) Create the second output as UIOutput and make it dependent on the first one:
ui <- shinyUI(
sidebarLayout(
sidebarPanel(
radioButtons("market",
"Choose a Region to build the Sales file:",
c("North America & ANZ" = "NA", "Europe" = "EU"), inline = TRUE),
uiOutput("Locale")),
mainPanel(dataTableOutput("sales"))))
server <- function(input, output, session) {
output$Locale <- renderUI({
if(input$market == "NA") myChoices <- c("US and Canada" = "US_CA", "ANZ" = "ANZ")
else myChoices <- c("UK" = "UK", "FR and RoE" = "FR_ROE","DE,AT & CH" = "DACH")
radioButtons("Locale","Choose a locale to see the sales Calendar:",
choices <- myChoices,
inline = TRUE)
})
output$sales <- renderDataTable({
saleTable(input$Locale)
},options = list(autoWidth = FALSE,searching = FALSE,pageLength=10))
}
shinyApp(ui = ui, server = server)
Based on the expressed interest in using updateRadioButtons, I put together a simple example with two radio buttons and a table output.
The first radio button input does not change. The second radio button input depends on the value of the first input. The table displayed is the mtcars data frame filtered by the values of the two radio button groups.
Using observeEvent ensures the value of the carb radio input updates each time the cyl radio input is changed. This will also trigger when the application is first launched and is why we do not see the default, dummy, choice "will be replaced" for the carb radio input.
Make sure to include session as one of the Shiny server function arguments. All of Shiny's update*Input functions require you pass a session object to them.
I hope this proves useful.
library(shiny)
shinyApp(
ui = fluidPage(
fluidRow(
column(
width = 4,
radioButtons(
inputId = "cyl",
label = "Choose number of cylinders:",
choices = unique(mtcars$cyl),
selected = unique(mtcars$cyl)[1]
),
radioButtons(
inputId = "carb",
label = "Choose number of carburetors:",
choices = "will be replaced"
)
),
column(
width = 8,
tableOutput(
outputId = "mtcars"
)
)
)
),
server = function(input, output, session) {
observeEvent(input$cyl, {
newChoices <- sort(unique(mtcars[mtcars$cyl == input$cyl, ]$carb))
updateRadioButtons(
session = session,
inputId = "carb",
choices = newChoices,
selected = newChoices[1]
)
})
output$mtcars <- renderTable({
req(input$cyl, input$carb)
mtcars[mtcars$cyl == input$cyl & mtcars$carb == input$carb, ]
})
}
)