I am trying to assign dataframes and lists (which are later used in calculations in code) based on some user inputs in a Shiny app. One of the assignments relies on two user inputs - how would I do this? I have tried to attach some reproducible code...
library(shiny)
set.seed(4)
# lists and dataframes to be assigned based on user inputs
A <- list(rnorm(6), rnorm(6))
B <- list(rnorm(6), rnorm(6))
dfA <- as.data.frame(cbind(rnorm(6), rnorm(6)))
dfA_adj <- as.data.frame(cbind(rnorm(6), rnorm(6)))
dfB <- as.data.frame(cbind(rnorm(6), rnorm(6)))
dfB_adj <- as.data.frame(cbind(rnorm(6), rnorm(6)))
ui <- fluidPage(
titlePanel(strong("Title")),
sidebarLayout(
sidebarPanel(
#content
h4(strong("Select data sets to use in calculations:")),
selectInput('L', 'Select list to use', c("List A" = 'a', "List B" = 'b')),
selectInput('P','Select Calculation method', c("Adjusted" = 'Adj', "Standard" = 'St'))
),
mainPanel(
tableOutput("table")
)
)
)
server <- function(input, output) {
#assign dataframes and list to use in code calcs (not shown) based on user inputs
pts <- reactive({ switch(input$L, "a" = A, "b" = B) })
PET <- reactive({ switch(c(input$L, input$P),
c("a", "Adj") = dfA_adj,
c("a", "St") = dfA,
c("b", "Adj") = dfB_adj,
c("b", "St") = dfB })
output$table <- renderTable(PET())
}
shinyApp(ui = ui, server = server)
We can use an if statement:
library(shiny)
set.seed(4)
# lists and dataframes to be assigned based on user inputs
A <- list(rnorm(6), rnorm(6))
B <- list(rnorm(6), rnorm(6))
dfA <- as.data.frame(cbind(rnorm(6), rnorm(6)))
dfA_adj <- as.data.frame(cbind(rnorm(6), rnorm(6)))
dfB <- as.data.frame(cbind(rnorm(6), rnorm(6)))
dfB_adj <- as.data.frame(cbind(rnorm(6), rnorm(6)))
ui <- fluidPage(
titlePanel(strong("Title")),
sidebarLayout(
sidebarPanel(
#content
h4(strong("Select data sets to use in calculations:")),
selectInput('L', 'Select list to use', choices = c("List A" = 'A', "List B" = 'B')),
selectInput('P','Select Calculation method', choices = c("Adjusted", "Standard"))
),
mainPanel(
tableOutput("table")
)
)
)
server <- function(input, output, session) {
PET <- reactive({
if (input$L == "A" && input$P == "Adjusted") {
dfA_adj}
else if (input$L == "A" && input$P == "Standard") {
dfA
} else if (input$L == "B" && input$P == "Adjusted") {
dfB_adj
} else {
dfB
}
})
output$table <- renderTable({PET()})
}
shinyApp(ui = ui, server = server)
Related
If I have a data.frame/data.table with multiple columns needed to be filtered and, later passed to other calculations, how can I filter the data without creating multiple combinations of filtering conditions using if else.
For example, if I have a data with Age, Gender, Ethnicity, and created three selectInput().
What I would like to achieve is that,
If I select Age: 10-19 from the drop down list, then this should be passed to the data and do DT[Age %in% "10-19"]
Similary, if I select Age: 10-19 and Gender: Female, then these should be passed to the data as DT[Age %in% "10-19" & Gender %in% "Female"]
If I deselect Age, then the data will return Gender: Female, such as DT[Gender %in% "Female"]
How can I capture those conditions, and pass to the data filter automatically without explicitly going through those combinations?
Here is a non-working testing example
df <- data.table(AgeGroup = sample(c("0-9", "10-19", "20-29"), 20, replace = TRUE),
Sex = sample(c("Male", "Female"), 20, replace = TRUE))
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("AgeGroup", "Age Group", choices = c("", unique(df$AgeGroup))),
selectInput("Sex", "Sex", choices = c("", unique(df$Sex)))
),
mainPanel(
tableOutput("table")
)
)
)
server <- function(input, output, session) {
# How to modify here so that we don't need to do
# `if (input$AgeGroup) df[AgeGroup == input$AgeGroup]`
# consider multiple filters, some filters are selected and some are not.
# For example, if there are 5 filters, there would be 2^5 combinations
df_out <- reactive(df)
output$table <- renderTable(df_out())
}
shinyApp(ui, server)
We can use | and & to build a filter statement. The trick is to say input$a is either "" (which means return all rows) or a is input$a. You can use %in% instead of == when using multiple input values.
library(shiny)
library(data.table)
df <- data.table(a = c("a", "b", "c"),
b = 1:3)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("a", "Select A", choices = c("", c("a", "b", "c"))),
selectInput("b", "Select B", choices = c("", c(1, 2, 3)))
),
mainPanel(
tableOutput("table")
)
)
)
server <- function(input, output, session) {
df_out <- reactive(df[(input$a == "" | a == input$a) &
(input$b == "" | b == input$b),])
output$table <- renderTable(df_out())
}
shinyApp(ui, server)
A more programmatic solution is to use vapply() and wrap the result in rowMeans():
library(shiny)
library(data.table)
df <- data.table(a = c("a", "b", "c"),
b = 1:3)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("a", "Select A", choices = c("", c("a", "b", "c"))),
selectInput("b", "Select B", choices = c("", c(1, 2, 3)))
),
mainPanel(
tableOutput("table")
)
)
)
server <- function(input, output, session) {
df_out <- reactive({
idx_vec <- vapply(c("a", "b"),
FUN.VALUE = logical(nrow(df)),
FUN = function(x) {
input[[x]] == "" | df[[x]] == input[[x]]
})
df[rowMeans(idx_vec) >= 1,]
})
output$table <- renderTable(df_out())
}
shinyApp(ui, server)
I have numerous reactive elements to create in a {Shiny} reactiveValues object, all requiring almost identical filtering code. But I cannot work out how to do this efficiently, i.e. without writing the filtering code directly for each element. In the sample code below, a radio button controls filtering of some data into 2 groups, A and B. The difference between the good and bad outputs is that the bad one uses a function to define its value, whereas the good one has it specified directly as a reactive object.
When using the function to create the value for the bad one, it seems to be stuck at the intial value, as when changing the data by selecting a different group it does not change. The good one does correctly filter the data however. So how could we create many elements with the same code in the reactiveValues object?
library(shiny)
ui <- fluidPage(
radioButtons(
"group", "",
list(A = "A", B = "B"), list("A"),
inline = TRUE
),
actionButton("go", "Go"),
textOutput("filtered_data_bad"),
textOutput("filtered_data_good")
)
server <- function(input, output) {
data <- tibble(
group = rep(c("A", "B"), c(5, 10))
)
group_saved <- reactiveVal(value = c("A"))
observeEvent(
input$go,
group_saved(input$group),
ignoreInit = TRUE,
ignoreNULL = FALSE
)
filter_data <- function (.data, .group) {
reactive(
.data[.data$group %in% .group,]
)
}
format_text <- function (.data, .group) {
req(nrow(.data) > 0)
paste(
"Selected:",
nrow(.data),
"total"
)
}
rv <- reactiveValues(
bad = filter_data(data, group_saved()),
good = reactive(
data[data$group %in% group_saved(),]
)
)
output$filtered_data_bad <- renderText({
format_text(rv$bad(), group_saved())
})
output$filtered_data_good <- renderText({
format_text(rv$good(), group_saved())
})
}
shinyApp(ui, server)
The code above is as simple as I could get it while showing the issue. I am working with the requirement to be able to select many different groups simultaneously from a common pool of choices (geographical regions in fact), for which the reactiveValues will hold one set of choices per group. Each group has its own reactiveVal object (saved_regions_A, saved_regions_B, ...) that serves as the filter.
regions_saved_A <- reactiveVal(value = regions)
regions_saved_B <- reactiveVal(value = NULL)
regions_saved_C <- reactiveVal(value = NULL)
...
filter_data <- function (.data, .regions) {
reactive(.data %>% filter(region %in% .regions))
}
filtered_data <- reactiveValues(
A = filter_data(data, regions_saved_A()),
B = filter_data(data, regions_saved_B()),
C = filter_data(data, regions_saved_C()),
...
)
I have tried removing the reactive call from the function and calling it with the function call for each value (it seems to be needed as I am relying on a reactiveVal for the saved choices). None of the below work:
filter_data <- function (.data, .regions) {
.data %>% filter(region %in% .regions)
}
filtered_data <- reactiveValues(
A = reactive(filter_data(data, regions_saved_A())),
B = filter_data(data, regions_saved_B()),
...
)
Assign the reactiveValues in an observer. No need to make them reactive again. Try this
library(shiny)
ui <- fluidPage(
radioButtons(
"group", "",
list(A = "A", B = "B"), list("A"),
inline = TRUE
),
actionButton("go", "Go"),
textOutput("filtered_data_bad"),
textOutput("filtered_data_good")
)
server <- function(input, output) {
data <- tibble(
group = rep(c("A", "B"), c(5, 10))
)
group_saved <- reactiveVal(value = c("A"))
observeEvent(
input$go,
group_saved(input$group),
ignoreInit = TRUE,
ignoreNULL = FALSE
)
filter_data <- function (df, .group) {
df[df$group %in% .group,]
# reactive(
# .data[.data$group %in% .group,]
# )
}
format_text <- function (.data, .group) {
req(nrow(.data) > 0)
paste(
"Selected:",
nrow(.data),
"total"
)
}
rv <- reactiveValues(bad=NULL,good=NULL)
observeEvent(input$go, {
group_saved()
rv$bad = filter_data(data, group_saved())
rv$good = data[data$group %in% group_saved(),]
})
output$filtered_data_bad <- renderText({
req(rv$bad)
format_text(rv$bad, group_saved())
})
output$filtered_data_good <- renderText({
req(rv$good)
format_text(rv$good, group_saved())
})
}
shinyApp(ui, server)
I am trying to get input choices dependent on previous input.
require(shiny)
require(dplyr)
dat <- data.frame(id1 = c(rep("A",5),rep("B",5)),
id2 = c(rep("C",3),rep("D",3),rep("E",4)),
id3 = c(rep("F",2),rep("G",3),rep("H",5)), stringsAsFactors=FALSE)
ui <- shinyUI(fluidPage(
sidebarPanel(
selectInput('id1', 'ID1', choices = unique(dat$id1)),
selectInput("id2", "ID2", choices = unique(dat$id2)),
selectInput("id3", "ID3", choices = unique(dat$id3))
)
)
)
server <- function(input, output,session) {
observeEvent(
{
input$id1
},{
input$id2
temp <- dat %>% filter(id1%in%input$id1)
updateSelectInput(session,"id2",choices = unique(temp$id2))
}
)
}
shinyApp(ui = ui, server = server)
This works for Input 1 and 2, however if i add another Input to observeEvent, the app chrashes. E.g:
server <- function(input, output,session) {
observeEvent(
{
input$id1
},{
input$id2
temp <- dat %>% filter(id1%in%input$id1)
updateSelectInput(session,"id2",choices = unique(temp$id2))
},{
input$id3
temp <- dat %>% filter(id1%in%input$id1 & id2%in%input$id2)
updateSelectInput(session,"id3",choices = unique(temp$id3))
}
)
}
How can I pass further Inputs to observeEvent ?
Update: I found a solution for the problem. I wrapped the Inputs in a reactive function, split the Output and passed it to the corresponding observeEvent functions.
server <- function(input, output,session) {
change <- reactive({
unlist(strsplit(paste(c(input$id1,input$id2,input$id3),collapse="|"),"|",fixed=TRUE))
})
observeEvent(input$id1,{
temp <- dat %>% filter(id1 %in% change()[1])
updateSelectInput(session,"id2",choices = unique(temp$id2))
}
)
observeEvent(input$id2,{
temp <- dat %>% filter(id1 %in% change()[1] & id2 %in% change()[2])
updateSelectInput(session,"id3",choices = unique(temp$id3))
}
)
}
Below a simplified version of my shiny app. I looked through some of the examples in the shinyjs package and I did not find anything that could help me.
I want to disable the Submit button if one of the data frame uploaded (in my real example) or selected has a specific column name (Col 3 in the example below).
Can this be done with shinyjs?
library(rhandsontable)
library(shiny)
library(shinyjs)
df1 <- data.frame(col1 = rnorm(20),
col2 = rep(T, 20))
df2 <- data.frame(col1 = rnorm(20),
col2 = rep(F, 20),
col3 = rnorm(20))
server <- function(input, output) {
values = reactiveValues()
values[["df1"]] <- df1
values[["df2"]] <- df2
df <- reactive({
if (input$df == "df1") {
df <- values[["df1"]]
} else {
df <- values[["df2"]]
}
df
})
observeEvent(input$Submit, {
shinyjs::alert("Thank you!")
})
#observe({
# if (is.null(input$df) || input$df == "df1") {
# shinyjs::disable("submit")
#} else {
# shinyjs::enable("submit")
#}
#})
output$out <- renderRHandsontable({
hot <- rhandsontable(df())
hot
})
}
ui <- fluidPage(
shinyjs::useShinyjs(),
sidebarLayout(sidebarPanel(
selectInput(
'df', 'Select data.frame:',
choices = c('df1', 'df2'),
selected = 'df1'
),
actionButton("Submit", label = "Submit")
),
mainPanel(rHandsontableOutput("out"))))
shinyApp(ui = ui, server = server)
First, there is a small typo: Notice the capital "S".
shinyjs::disable("Submit")
Edit: To check for "col3" take the following code:
observe({
if (is.null(input$df) || sum(colnames(df()) == "col3")) {
shinyjs::disable("Submit")
}else{
shinyjs::enable("Submit")
}
})
Same for enable of course.
I can create a data table in shiny that shows data for any individual buffalo but I can't figure out how to display all buffalo data at the same time. Any help is appreciated.
Sample Data:
cleanbuffalo <- data.frame(name = c("queen","toni","pepper"),
longitude = c(31.8,32,33),
latitude = c(-24,-25,-26))
Shiny UI:
shinyUI(navbarPage("Buffalo Migration", id ="nav",
tabPanel("Data",
fluidRow(
column(3,
selectInput("allnamesbuffalo", "Buffalo", c("All Buffalo" = "all buffalo", vars))
)
),
hr(),
DT::dataTableOutput("buffalotable")
)
)
)
Shiny Server:
shinyServer(function(input, output, session) {
observe({
allnamesbuffalo <- if (is.null(input$allnamesbuffalo)) character(0) else {
filter(cleanbuffalo, name %in% input$allnamesbuffalo) %>%
`$`('name') %>%
unique() %>%
sort()
}
})
output$buffalotable <- DT::renderDataTable({
df <- cleanbuffalo %>%
filter(
cleanbuffalo$name == input$allnamesbuffalo,
is.null(input$allnamesbuffalo) | name %in% cleanbuffalo$name
)
action <- DT::dataTableAjax(session,df)
DT::datatable(df, options = list(ajax = list(url = action)),
escape = FALSE)
})
})
Here is a working example. Note that I added stringsAsFactors=F in your data frame, otherwise you need to use levels(cleanbuffalo$name) to get the names.
library(shiny)
library(dplyr)
cleanbuffalo <- data.frame(name = c("queen","toni","pepper"),
longitude = c(31.8,32,33),
latitude = c(-24,-25,-26), stringsAsFactors = F)
ui <- shinyUI(fluidPage(
titlePanel("Example"),
sidebarLayout(
sidebarPanel(
selectInput("allnamesbuffalo", "Buffalo", c("all", cleanbuffalo$name))
),
mainPanel(
dataTableOutput("buffalotable")
)
)
))
server <- shinyServer(function(input, output, session) {
output$buffalotable <- renderDataTable({
names <- NULL
if (input$allnamesbuffalo == "all") {
names <- cleanbuffalo$name
} else {
names <- input$allnamesbuffalo
}
filter(cleanbuffalo, name %in% names)
})
})
shinyApp(ui = ui, server = server)