In the following example I have two static radio buttons representing the mtcars and iris datasets. Upon making a selection, the user is presented with a second set of buttons based on data in each dataset. For the mtcars dataset, the user can filter by selecting from the unique list of carburetors or in the case of the iris dataset, the species. Now, I require another set of buttons based on the carb/species buttons to further filter the data. Say, for the mtcars dataset the list of unique gear selections associated with the carburetor selection and for the Iris the unique set of petal lengths. Given the real world application of what I'm trying to accomplish, there is no getting away from requiring a third set of reactive radio buttons. I just have no clue how to approach the next step.
ui.R
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "My DFS Dashboard"),
dashboardSidebar(
sidebarMenu(
menuItem("MTCARS", tabName = "dashboard", icon = icon("dashboard")),
menuItem("IRIS", tabName = "widgets", icon = icon("th"))
)
),
dashboardBody(
fluidRow (
column(width = 3,
box(title = "Select Dataset", width = NULL, status = "primary", background = "aqua",
radioButtons ("mydataset",
"",
inline = TRUE,
c("mtcars", "iris"),
selected = "mtcars"))),
column(width = 3,
box(title="Select Filter One", width = NULL, status = "primary", background = "aqua",
uiOutput("filter1"))),
column(width = 3,
box(title = "Select Fitler Two", width = NULL, status = "primary", background = "aqua",
uiOutput("filter2")))
)
)
)
server.R
library(tidyverse)
server <- function(input, output, session) {
data("mtcars")
data("iris")
cars <- mtcars
flowers <- iris
carbs <- cars %>%
dplyr::select(carb)
carbs <- carbs$carb
carbs <- as.data.frame(carbs)
carbs <- unique(carbs$carb)
spec <- flowers %>%
dplyr::select(Species)
spec <- unique(spec$Species)
vards <- reactive ({
switch(input$mydataset,
"mtcars" = carbs,
"iris" = spec,
)
})
output$filter1 <- renderUI({
radioButtons("fil1","", choices=vards())
})
}
Perhaps this may be helpful. You can add another reactive expression to filter your dataset and obtain choices for the third set of radio buttons. I included isolate so that the third set of buttons does not react to changes in the dataset (only changes in the second radio buttons, which is dependent already on the dataset). Please let me know if this is what you had in mind for behavior.
server <- function(input, output, session) {
data("mtcars")
data("iris")
cars <- mtcars
flowers <- iris
vards1 <- reactive({
switch(input$mydataset,
"mtcars" = unique(cars$carb),
"iris" = unique(flowers$Species),
)
})
vards2 <- reactive({
req(input$fil1)
if (isolate(input$mydataset) == "mtcars") {
cars %>%
filter(carb == input$fil1) %>%
pull(gear) %>%
unique()
} else {
flowers %>%
filter(Species == input$fil1) %>%
pull(Petal.Length) %>%
unique()
}
})
output$filter1 <- renderUI({
radioButtons("fil1","", choices=vards1())
})
output$filter2 <- renderUI({
radioButtons("fil2","", choices=vards2())
})
}
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 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 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)
})
In the below code, I am attempting to create an input to show all of my markets, or just a selection within a plot and a data table. I am doing this through, or attempting, through ifelse statements within my render functions, however I am getting errors, and neither the plot or data table will render. They do render without the if else statements. I have included an Example data set to hopefully help place in context.
ui <- dashboardPage(
dashboardHeader(title = "Example"),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "Dashboard"),
menuItem("Example", tabName = "example"))),
dashboardBody(
tabItems(
tabItem(tabName = "Dashboard",
fluidRow(
valueBoxOutput("example"))),
tabItem(tabName = "example",
fluidRow(
box(title = "Example",
plotOutput("plotexample"), width = 12),
box(title = "Data Selection",
selectInput("market","Market(s): ", c(unique(data$marketnum),"All"),multiple = T, selectize = T, selected = "All"))),
fluidRow(
box(DT::dataTableOutput("markettable"), width = 12))))))
server <- function(input,output) {
ExampleAllMarkets <- reactive({
ExampleData %>%
group_by(Event,marketnum) %>%
summarise(ItemCount = n_distinct(ItemNumber))
})
Example <- reactive({
ExampleData %>%
filter(marketnum == input$market) %>%
group_by(Event,marketnum) %>%
summarise(PolicyCount = n_distinct(Policy_Number_9_Digit))
})
output$example <- renderValueBox({
valueBox(
paste0("44", "%"), "example", icon = icon("car"),
color = "red"
)
})
I am placing ifelse statements within my render blocks reactive to whether or not "All" is selected.
output$plotexample <- renderPlot({
ifelse(input$market=="All",
ggplot(Example(), aes(x=MBC_Number, y=ItemCount)) +
geom_bar(stat="identity"),
ggplot(ExampleAllMarkets(), aes(x=marketnum, y=ItemCount))
+
geom_bar(stat="identity"))
})
output$markettable <- DT::renderDataTable({
ifelse(input$market == "All",
ExampleAllMarkets(),
Example())
})
}
shinyApp(ui,server)
Example Data in csv format
marketnum,ItemNumber
2,118
7,101
1,109
2,109
10,101
4,102
8,100
12,103
5,106
13,116
5,112
10,103
7,113
9,114
10,112
6,114
2,116
11,113
3,107
13,102
8,107
10,109
12,110
1,120
4,106
8,116
2,112
2,106
11,101
6,108
11,107
10,111
6,120
10,118
11,119
13,117
You probably cannot use ifelse in this scenario.
Analyzing the source code for ifelse, since a plot object is not so simple, it does not just return the plot itself, but
rep(plot, length.out = 1)
or equivalently plot[1] which is just the dataset of the plot. A plot object has a length > 1 and for those, ifelse only returns its first element.
This can be easily confirmed by evaluating
> ifelse(T, c(1, 2), c(3, 4))
[1] 1
So the render function cannot draw anything, since it's input is just this dataset.
You will simply have to use the regular if else.
I have created a simplified Shiny dashboard. Data in the dashboard are based on dataset foo containing 3 variables "selVar1", "selVar2" and "val".
The sidebar panel consists of two parts. An input control for selecting either the selVar1 or selVar2 column and a conditional panel showing the unique values of either selVar1 or selVar2 (conditional values based on selectInput's selVar).
If selVar == selVar1 is selected, then the unique values of column foo$selVar1 are shown
If selVar == selVar2 is selected then the unique values of column foo$selVar2 are shown
The output is a single value after filtering dataset foo based on the value selected in the conditional filter.
Issue
I can't seem to formulate the filter-statement correctly. Dynamic referall of input$selVar doesn't work:
filter(input$selVar == input$selData), while explicitely mentioning selVar1 in the filter statement does work, but loses dynamic behavior: filter(selVar1 == input$selData). I have tried multiple combinations of using filter_ or filter, but I can't seem to get it right. How can I obtain dynamic filtering of the dataset based on the result of the input-control buttons? Seems I don't really understand what is happening with the non-standard versus standard evaluation expression to make it work.
#generate textOutput
outp <- reactive({
tmp <- foo %>%
select_(input$selVar, 'val') %>%
filter(input$selVar == input$selData) %>%
summarise(val = sum(val)) %>%
select(val) %>%
as.character()
})
Example
#Input dataset foo:
selVar1 selVar2 val
1 b 10
2 d 30
3 d 50
4 c 70
5 b 90
#input selection selVar == selVar1
#input selection conditional panel selVar 1 == 3
#output: val = 50
See below for the complete Shiny server and ui setup.
library(shiny)
library(shinydashboard)
library(dplyr)
#dataset
foo <- structure(list(selVar1 = 1:5,
selvar2 = c("b", "d", "d", "c","b"),
val = c(10, 30, 50, 70, 90)),
.Names = c("selVar1", "selVar2","val"), row.names = c(NA, -5L), class = "data.frame")
#Selection lists for conditional selection input:
lstSelVar <- c('selVar1', 'selVar2')
lstVar1 <- unique(foo$selVar1)[order(unique(foo$selVar1))]
lstVar2 <- unique(foo$selVar2)[order(unique(foo$selVar2))]
#UI setup:
'== sidebar
========================'
sidebar <- dashboardSidebar(
sidebarMenu(
selectInput("selVar", h5("Select variable:"), choices = as.list(lstSelVar), selected = 1),
conditionalPanel(
condition = "input.selVar == 'selVar1'",
selectInput("selData", h5("Select value:"), choices = as.list(lstVar1), selected = 1)
),
conditionalPanel(
condition = "input.selVar == 'selVar2'",
selectInput("selData", h5("Select value:"), choices = as.list(lstVar2), selected = 1)
)
)
)
'== body
========================'
body <- dashboardBody(
fluidRow(
column(
dataTableOutput("tbl"), width = 3
),
column(
box(
h4("Single output value:"),
textOutput("outpVal")
), width = 3
)
)
)
'== Define UI for application
========================'
ui <- dashboardPage(
dashboardHeader(title = "Conditional Panels"),
sidebar,
body
)
'== Define server logic
========================'
server <- function(input, output) {
output$tbl <- renderDataTable(foo)
#generate textOutput
outp <- reactive({
tmp <- foo %>%
select_(input$selVar, 'val') %>%
filter(input$selVar == input$selData) %>%
summarise(val = sum(val)) %>%
select(val) %>%
as.character()
})
output$outpVal <- renderText({
outp()
})
}
'== Run the application
========================'
shinyApp(ui = ui, server = server)
It would be better to have different names for the selectInput. Also, we can use the select_at and filter_at for selecting and filtering rows.
sidebar <- dashboardSidebar(
sidebarMenu(
selectInput("selVar", h5("Select variable:"), choices = as.list(lstSelVar), selected = 1),
conditionalPanel(
condition = "input.selVar == 'selVar1'",
selectInput("selData1", h5("Select value:"), choices = as.list(lstVar1), selected = 1)
),
conditionalPanel(
condition = "input.selVar == 'selVar2'",
selectInput("selData2", h5("Select value:"), choices = as.list(lstVar2), selected = 1)
)
)
)
body <- dashboardBody(
fluidRow(
column(
dataTableOutput("tbl"), width = 3
),
column(
box(
h4("Single output value:"),
textOutput("outpVal")
), width = 3
)
)
)
ui <- dashboardPage(
dashboardHeader(title = "Conditional Panels"),
sidebar,
body
)
server <- function(input, output) {
output$tbl <- renderDataTable(foo)
#generate textOutput
outp <- reactive({
sD <- if(input$selVar == 'selVar1') input$selData1 else input$selData2
tmp <- foo %>%
select_at(vars(input$selVar, 'val')) %>%
filter_at(vars(input$selVar), all_vars(.== sD)) %>%
summarise(val = sum(val)) %>%
select(val) %>%
as.character()
})
output$outpVal <- renderText({
outp()
})
}
shinyApp(ui = ui, server = server)
-output