Need help making dependent dropdown boxes in the RStudio package Shiny - r

I have two datasets, one with a list of two hundred cities and their corresponding state and another much larger dataset that I'd like to make an app to sort through. I need help making two drop down boxes in my shiny app where the first is the state variable and the second is the list of cities within that chosen state. I then want those selections to filter the much larger, second dataset in the output. I've tried solutions from several similar but slightly different examples online, but I'm having trouble translating it to what I'm doing.
So far I have this:
ui <- fluidPage(
headerPanel(''),
sidebarPanel(
#add selectinput boxs
htmlOutput("state_selector"),
htmlOutput("city_selector"),
),
mainPanel(
fluidRow(
# Create a new row for the table.
DT::dataTableOutput("table")
)
server <- function(session, input, output) {
output$state_selector = renderUI({
selectInput("state", label = h4("State"),
choices = as.character(unique(citystatedata$state)), selected = NULL)
})
output$city_selector = renderUI({
data_available = citystatedata[citystatedata$State == input$state, "state"]
selectInput(inputId = "city", #name of input
label = "City", #label displayed in ui
choices = unique(data_available), #calls list of available cities
selected = unique(data_available)[1])
})
shinyApp(ui = ui, server = server)
I tried to take out the portions of the code that weren't specifically related to the drop down boxes, since that's what I was more specifically asking about. So I'm sorry if I've left anything out! Let me know if I need to include anything else

Using available gapminder data, you can try this.
df <- gapminder
df$state <- gapminder$continent
df$city <- gapminder$country
citystatedata <- df
ui <- fluidPage(
headerPanel('Test'),
sidebarPanel(
#add selectinput boxs
uiOutput("state_selector"),
uiOutput("city_selector"),
),
mainPanel(
fluidRow(
# Create a new row for the table.
DTOutput("table")
)
)
)
server <- function(session, input, output) {
output$state_selector = renderUI({
selectInput("state", label = h4("State"),
choices = as.character(unique(citystatedata$state)), selected = NULL)
})
output$city_selector = renderUI({
data_available = citystatedata[citystatedata$state == req(input$state),]
selectInput(inputId = "city", #name of input
label = "City", #label displayed in ui
choices = unique(data_available$city), #calls list of available cities
selected = 1)
})
mydt <- reactive({
citystatedata %>% filter(citystatedata$state == req(input$state) & citystatedata$city %in% req(input$city))
})
output$table <- renderDT(mydt())
}
shinyApp(ui = ui, server = server)

Related

R Shiny Custom User Filter with Checkboxes

I have data table output that I want users to be able to create their own custom table by using checkboxes to select which row/element they want. In the example below is a mtcars output. For example I want users to be able to pick say A Mazda, Fiat, Toyota, and a Dodge model using a check box. As far as trying any code, I haven't found any examples that come close.
library(shiny)
if (interactive()) {
# basic example
shinyApp(
ui = fluidPage(
selectInput("variable", "Variable:",
c("Cylinders" = "cyl",
"Transmission" = "am",
"Gears" = "gear"), multiple = T),
tableOutput("data")
),
server = function(input, output) {
output$data <- renderTable({
mtcars[, c("mpg", input$variable), drop = FALSE]
}, rownames = TRUE)
}
)
}
The general approach below is 1) create a checkbox group input listing the car names (i.e. rownames) as the names, having the corresponding values be the row numbers and 2) using those row numbers to filter your data.frame on the server.
Using the reactive rowsToUse will update every time the selection changes. It also allows the handling of the case when no rows are selecting (default to all rows in the example below).
shinyApp(
ui = fluidPage(
checkboxGroupInput(
inputId = "variable",
label = "Cars:",
choiceNames = rownames(mtcars),
choiceValues = seq(NROW(mtcars))
),
tableOutput("data")
),
server = function(input, output) {
rowsToUse <- reactive(
if(is.null(input$variable)) {
seq(NROW(mtcars))
} else{
as.numeric(input$variable)
}
)
output$data <- renderTable({
mtcars[rowsToUse(), , drop = FALSE]
}, rownames = TRUE)
}
)

How to restart an lapply loop within a renderUI

I am trying to create a shiny code that is able to filter a table non pre-determined number of times. When the user uploads a different (new) table, unfortunately the code breaks as I need to restart a lapply loop somehow, throwing out the previously stored column names.
I would like to create an non pre-defined filtering options for a table within Shiny. The user can select a column and filter a table choosing different categorical variables within that column. It is possible to add additional selection fields by pressing the 'Add' button.
the UI:
library(shiny)
library(shinydashboard)
library(dplyr)
ui <- shinyUI(
pageWithSidebar(
headerPanel("testing of dynamic number of selection"),
sidebarPanel(
uiOutput("buttons")),
mainPanel(
uiOutput("drops")
,tableOutput("table")
)
))
The server:
A table (test.csv) is automatically stored in a reactive values and a first searching field appears with 3 buttons (Add = to add a new searching field by reading in the colnames and a multiselect that stores the unique variables from that columns. The filtering function is activated by the Calculate button)
server<-function(input, output, session) {
###### read in test file
values<-reactiveValues(number = 1,
upload = NULL,
input = NULL)
values$upload<-read.csv("test.csv")
#just the "add" button, in this instance it shouldn't be a uiOutput
output$buttons <- renderUI({
div(
actionButton(inputId = "add", label = "Add"), actionButton(inputId = "calc", label = "Calculate"),
actionButton(inputId = "new", label = "new table")
)
})
#pressing the add button
observeEvent(input$add, {
cat("i adding a new record\n")
values$number <- values$number + 1L })
daStuff <- function(i){
inputName<-paste0("drop", i)
inputName2<-paste0("select", i)
inputText<-if(values$number>0){input[[paste0("drop",i)]]}else{F} # previously selected value for dropdown
inputSelect <- if(values$number>1){input[[paste0("select",i)]]}else{F} # previously selected value for dropdown
fluidRow(
column(6,selectInput(inputName, inputName, c(colnames(values$upload)), selected = inputText)),
column(6,selectInput(inputName2, inputName2,
na.omit(unique(as.vector(values$upload[,input[[paste0("drop",i)]]]))),
multiple=TRUE, selectize=TRUE, selected=inputSelect)) )}
output$drops<- renderUI({
lapply(seq_len(values$number), daStuff)})
By pressing the Calculate button, the uploaded table is subjected to filtering, depending on the selected unique values and shown in the output$table
observeEvent(input$calc, {
values$input<-NULL
for (i in 1:values$number){
if(!is.null(input[[paste0("select",i)]])){
if(is.null(values$input)){
values$input<- filter(values$upload,values$upload[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])}
else{
values$input<- filter(values$input,values$input[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])}
} }
if (is.null(values$input)){values$input<-values$upload}
output$table <- renderTable({values$input})
})
My problem is when I upload a new table (test2.csv), I don't know how to erase the previously stored selections (drop* and select* values) and gives back an error message.
observeEvent(input$new,{
values$upload<-read.csv("test2.csv")
})
}
shinyApp(ui=ui, server = server)
I suppose I should stop somehow the lapply loop and restart it over, so the previously stored values are replaced depending on the new selection, but I am a bit stuck on how I could achieve that.
Just in case you might still be looking for solutions, I wanted to share something that was similar and could potentially be adapted for your needs.
This uses observeEvent for all select inputs. If it detects any changes, it will update all inputs, including the possibilities for select based on drop.
In addition, when a new file is read, the selectInput for drop and select are reset to first value.
Edit: I forgot to keep selected = input[[paste0("drop",i)]] in place for the dropdown (see revised code). It seems to keep the values now when new filters are added - let me know if this is what you had in mind.
library(shiny)
library(shinydashboard)
library(dplyr)
myDataFrame <- read.csv("test.csv")
ui <- shinyUI(
pageWithSidebar(
headerPanel("Testing of dynamic number of selection"),
sidebarPanel(
fileInput("file1", "Choose file to upload", accept = ".csv"),
uiOutput("buttons")
),
mainPanel(
uiOutput("inputs"),
tableOutput("table")
)
)
)
server <- function(input, output, session) {
myInputs <- reactiveValues(rendered = c(1))
myData <- reactive({
inFile <- input$file1
if (is.null(inFile)) {
d <- myDataFrame
} else {
d <- read.csv(inFile$datapath)
}
d
})
observeEvent(lapply(paste0("drop", myInputs$rendered), function(x) input[[x]]), {
for (i in myInputs$rendered) {
updateSelectInput(session,
paste0('select', i),
choices = myData()[input[[paste0('drop', i)]]],
selected = input[[paste0("select",i)]])
}
})
output$buttons <- renderUI({
div(
actionButton(inputId = "add", label = "Add"),
actionButton(inputId = "calc", label = "Calculate")
)
})
observeEvent(input$add, {
myInputs$rendered <- c(myInputs$rendered, max(myInputs$rendered)+1)
})
observeEvent(input$calc, {
showData <- NULL
for (i in 1:length(myInputs$rendered)) {
if(!is.null(input[[paste0("select",i)]])) {
if(is.null(showData)) {
showData <- filter(myData(), myData()[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])
}
else {
showData <- filter(showData, showData[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])
}
}
}
if (is.null(showData)) { showData <- myData() }
output$table <- renderTable({showData})
})
observe({
output$inputs <- renderUI({
rows <- lapply(myInputs$rendered, function(i){
fluidRow(
column(6, selectInput(paste0('drop',i),
label = "",
choices = colnames(myData()),
selected = input[[paste0("drop",i)]])),
column(6, selectInput(paste0('select',i),
label = "",
choices = myData()[1],
multiple = TRUE,
selectize = TRUE))
)
})
do.call(shiny::tagList, rows)
})
})
}
shinyApp(ui, server)

R/Shiny Dataframe Columns

I'm working with Shiny, and i have another question, hopefully much easier:
I have a dataframe (uploaded from a CSV), where I want the user to select a Dependent variable, and then select their independent variables, but the list of available columns for the IV selection should now not include the dependent variable that they just selected.
I've been staring and reactive expressions all day, and have no clue. It's probably really obvious too.
Any help would be great.
Here is a code snippet from the Server code
# Read file ----
df <- reactive({
req(input$uploaded_file)
read.csv(input$uploaded_file$datapath,
header = input$header,
sep = input$sep)
})
# dynamically allow the user to select a dependent variable ----
output$selectbox <- renderUI({
selectInput(inputId = "select_dev",
label = "Select target variable",
choices = names(df()))
})
# Dynamically allow the user to select their independent variables using checkboxes ----
###
### Here is where I would like to remove the variable from the DF that they selected in output$selectbox.
###
output$checkbox <- renderUI({
checkboxGroupInput(inputId = "select_var",
label = "Select variables",
choices = names(df()),
selected = names(df()))
})
Perhaps there is an easier way than this to manipulate a reactive function. The goal is to have dataframe that I can treat as a set of independent variables, and be able to call on it for multiple analyses.
There you go -
library(shiny)
shinyApp(
ui = fluidPage(
uiOutput("selectbox"),
uiOutput("checkbox")
),
server = function(input, output, session) {
df <- reactive(iris)
output$selectbox <- renderUI({
selectInput(inputId = "select_dev",
label = "Select target variable",
choices = names(df()))
})
output$checkbox <- renderUI({
checkboxGroupInput(inputId = "select_var",
label = "Select variables",
choices = setdiff(names(df()), input$select_dev),
selected = setdiff(names(df()), input$select_dev))
})
}
)

Multiple reactiveValues In a Shiny App

I use reactiveValues in Shiny a lot as they are more flexible than just the input and output objects. Nested reactiveValues are tricky since any changes in any of the children also triggers the reactivity linked to the parents. To get around this, I tried to make two different reactiveValues objects ( not two objects in the same list, but two different lists altogether ) and it seems to be working. I'm not able to find any example of this and want to find out if it's suppose to work this way. Are there any issues that might arise because of this?
In this app, there are two reactive values objects - reac1 and reac2. Each of them are linked to a drop down, column1 and column2 respectively. Changing column1 or column2 updates the reactive values with the latest time, updates the plot, and prints the latest values in reac1 and reac2.
ui = fluidPage(
titlePanel("Multiple reactive values"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "column1", "Reac1", letters, selected = "a"),
selectInput(inputId = "column2", "Reac2", letters, selected = "a")
),
mainPanel(
plotOutput("plot1")
)
)
)
server = function(input, output, session) {
reac1 <- reactiveValues(asdasd = 0)
reac2 <- reactiveValues(qweqwe = 0)
# If any inputs are changed, set the redraw parameter to FALSE
observe({
input$column2
reac2$qweqwe = Sys.time()
})
observe({
input$column1
reac1$asdasd = Sys.time()
})
# Only triggered when the copies of the inputs in reac are updated
# by the code above
output$plot1 <- renderPlot({
print(paste(reac1$asdasd, 'reac1'))
print(paste(reac2$qweqwe, 'reac2'))
hist(runif(1000))
})
}
shinyApp(ui, server)
ReactiveValues are like a read/write version of input$, and you can have several 'independent' variables inside one reactiveValue list. So, you do not need two reactive values in your example. See code below.
ui = fluidPage(
titlePanel("Multiple reactive values"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "column1", "Reac1", letters, selected = "a"),
selectInput(inputId = "column2", "Reac2", letters, selected = "a")
),
mainPanel(
verbatimTextOutput("txt1"),
verbatimTextOutput("txt2")
)
)
)
server = function(input, output, session) {
reac <- reactiveValues()
#reac2 <- reactiveValues(qweqwe = 0)
# If any inputs are changed, set the redraw parameter to FALSE
observe({
reac$asdasd = input$column1
})
observe({
reac$qweqwe = input$column2
})
# Only triggered when the copies of the inputs in reac are updated
# by the code above
output$txt1 <- renderPrint({
print('output 1')
print(paste(reac$asdasd, 'reac1'))
})
output$txt2 <- renderPrint({
print('output2')
print(paste(reac$qweqwe, 'reac2'))
})
}
shinyApp(ui, server)

Dynamic ggvis object in Shiny

I'm trying to add a dynamic ggvis plot to a Shiny app. First, user picks a dimension, and then adds items from that dimension.
For global.R and sample data, see https://gist.github.com/tts/a41c8581b9d77f131b31
server.R:
shinyServer(function(input, output, session) {
# Render a selectize drop-down selection box
output$items <- renderUI({
selectizeInput(
inputId = 'items',
label = 'Select max 4. Click to delete',
multiple = TRUE,
choices = aalto_all[ ,names(aalto_all) %in% input$dim],
options = list(maxItems = 4, placeholder = 'Start typing')
)
})
selected <- reactive({
if (is.null(input$items)) {
return(aalto_all)
}
df <- aalto_all[aalto_all[[input$dim]] %in% input$items, ]
df$keys <-seq(1, nrow(df))
df
})
selected %>%
ggvis(~WoS, ~NrOfAuthors, fill = ~School, key := ~keys) %>%
layer_points() %>%
add_tooltip(show_title) %>%
bind_shiny("gv")
show_title <- function(x=NULL) {
if(is.null(x)) return(NULL)
key <- x["keys"][[1]]
selected()$Title20[key]
}
})
ui.R:
shinyUI(fluidPage(
titlePanel('Some (alt)metric data for articles published since 2010'),
sidebarLayout(
sidebarPanel(
selectInput(
inputId = "dim",
label = "Dimension",
choices = dimensions,
selected = c("Title")),
uiOutput("items")
),
mainPanel(
tabsetPanel(
# I'll add more tabs
tabPanel("Plot with ggvis", ggvisOutput("gv"))
)
)
)
))
This is OK
in the beginning, when there are no items selected, and all data is plotted. This is a hack because the ggvis object throws an error if there is no data served.
when all selected items are deleted (which is the same as 1.) and another dimension is chosen
But when I try to switch to another dimension without deleting the items first, I get this:
Error in `$<-.data.frame`(`*tmp*`, "keys", value = c(1L, 0L)) :
replacement has 2 rows, data has 0
I understand that ggvis is very new and constantly developing, but I suspect that there is merely something in Shiny reactive values that is out of sync. If anyone could point out what I'm doing wrong, thanks a lot!
The error is caused because you have a data.frame with zero rows and have a resulting 1:0.
You can change your selected function to:
selected <- reactive({
if (is.null(input$items)) {
return(aalto_all)
}
df <- aalto_all[aalto_all[[input$dim]] %in% input$items, ]
df$keys <-seq_along(df[,1])
if(nrow(df) == 0){
return(aalto_all)
}
df
})

Resources