Eric Green
Reputation: 7725
if rows == 0 after filtering on inputs, have shiny app display custom message instead of plot
I have a shiny app where it's possible to select inputs that filter the dataset to 0 rows. Having 0 rows causes some functions to throw an error. I'm trying to understand how to structure the app so that I can handle a situation where an error results when the dataset is filtered to 0 rows. Based on other SO answers (example), I believe one approach is to use validate(), but I'm not sure how to implement correctly. This might get flagged as a duplicate, but I don't think existing answers demonstrate validate() for this use case (very possible I missed some though!).
Here's a non-shiny MRE of the problem. Imagine that the filter(age >= 36 & age <= 40) step comes in from a slider input in a shiny app. The toy dataset only has ages up to 35, so setting the lower bound of the slider to 36 will filter the dataset to 0 rows. (Limiting the slider range is not an option because the data change and could include someone age 36 tomorrow. In my real use case, there are multiple filters and many pathways to 0 rows.)
library(tidyverse)
library(dygraphs)
library(magrittr)
library(padr)
set.seed(1)
dat <- data.frame(date = seq(as.Date("2018-01-01"),
as.Date("2018-06-30"),
"days"),
sex = sample(c("male", "female"), 181, replace=TRUE),
lang = sample(c("english", "spanish"), 181, replace=TRUE),
age = sample(20:35, 181, replace=TRUE))
dat <- dplyr::sample_n(dat, 80)
grp_col <- rlang::sym("sex")
dat %>%
mutate(Total = 1) %>%
filter(age >= 36 & age <= 40) %>% # leads to 0 rows
mutate(my_group = !!grp_col) %>%
group_by(date = lubridate::floor_date(date, "1 week"), my_group) %>%
count() %>% spread(my_group, n) %>% ungroup() %>%
padr::pad() %>% replace(is.na(.), 0) %>%
xts::xts(order.by = .$date) %>%
dygraph() %>%
dyRangeSelector() %>%
dyOptions(
useDataTimezone = FALSE, stepPlot = TRUE,
drawGrid = FALSE, fillGraph = TRUE
)
When the dataset is filtered to 0 rows, padr::pad() in this example throws an error. I'm looking for a strategy to plot if rows > 0 after filtering, or if rows == 0, print a message like:
There are no matches in the dataset. Try removing or relaxing one or more filters.
Shiny version that shows this problem:
To produce error, drag lower age slider above 35.
---
title: "test"
output:
flexdashboard::flex_dashboard:
theme: bootstrap
runtime: shiny
---
```{r setup, include=FALSE}
library(flexdashboard)
library(tidyverse)
library(tibbletime)
library(dygraphs)
library(magrittr)
library(xts)
```
```{r global, include=FALSE}
# generate data
set.seed(1)
dat <- data.frame(date = seq(as.Date("2018-01-01"),
as.Date("2018-06-30"),
"days"),
sex = sample(c("male", "female"), 181, replace=TRUE),
lang = sample(c("english", "spanish"), 181, replace=TRUE),
age = sample(20:35, 181, replace=TRUE))
dat <- dplyr::sample_n(dat, 80)
```
Sidebar {.sidebar}
=====================================
```{r}
radioButtons("diss", label = "Disaggregation",
choices = list("All" = "Total",
"By Sex" = "sex",
"By Language" = "lang"),
selected = "Total")
sliderInput("agerange", label = "Age",
min = 15,
max = 99,
value = c(15, 99),
step=1)
```
Page 1
=====================================
```{r plot}
# credit to https://stackoverflow.com/a/52325173/841405
renderDygraph({
grp_col <- rlang::sym(input$diss) # This converts the input selection to a symbol
dat %>%
mutate(Total = 1) %>% # This is a hack to let us "group" by Total -- all one group
filter(age >= input$agerange[1] & age <= input$agerange[2]) %>%
# Here's where we unquote the symbol so that dplyr can use it to refer to a column.
# In this case I make a dummy column that's a copy of whatever column we want to group
mutate(my_group = !!grp_col) %>%
group_by(date = lubridate::floor_date(date, "1 week"), my_group) %>%
count() %>% spread(my_group, n) %>% ungroup() %>%
padr::pad() %>% replace(is.na(.), 0) %>%
xts::xts(order.by = .$date) %>%
dygraph() %>%
dyRangeSelector() %>%
dyOptions(
useDataTimezone = FALSE, stepPlot = TRUE,
drawGrid = FALSE, fillGraph = TRUE
)
})
```
Shiny version (non-working) that attempts to integrate validate():
---
title: "test"
output:
flexdashboard::flex_dashboard:
theme: bootstrap
runtime: shiny
---
```{r setup, include=FALSE}
library(flexdashboard)
library(tidyverse)
library(tibbletime)
library(dygraphs)
library(magrittr)
library(xts)
```
```{r global, include=FALSE}
# generate data
set.seed(1)
dat <- data.frame(date = seq(as.Date("2018-01-01"),
as.Date("2018-06-30"),
"days"),
sex = sample(c("male", "female"), 181, replace=TRUE),
lang = sample(c("english", "spanish"), 181, replace=TRUE),
age = sample(20:35, 181, replace=TRUE))
dat <- dplyr::sample_n(dat, 80)
```
Sidebar {.sidebar}
=====================================
```{r}
radioButtons("diss", label = "Disaggregation",
choices = list("All" = "Total",
"By Sex" = "sex",
"By Language" = "lang"),
selected = "Total")
sliderInput("agerange", label = "Age",
min = 15,
max = 99,
value = c(15, 99),
step=1)
```
Page 1
=====================================
```{r plot}
# credit to https://stackoverflow.com/a/52325173/841405
renderDygraph({
grp_col <- rlang::sym(input$diss) # This converts the input selection to a symbol
filtered <-
dat %>%
mutate(Total = 1) %>% # This is a hack to let us "group" by Total -- all one group
filter(age >= input$agerange[1] & age <= input$agerange[2]) %>%
validate(need(nrow(filtered)<1, "Need at least 1 row"),
filtered %>%
mutate(my_group = !!grp_col) %>%
group_by(date = lubridate::floor_date(date, "1 week"), my_group) %>%
count() %>% spread(my_group, n) %>% ungroup() %>%
padr::pad() %>% replace(is.na(.), 0) %>%
xts::xts(order.by = .$date) %>%
dygraph() %>%
dyRangeSelector() %>%
dyOptions(
useDataTimezone = FALSE, stepPlot = TRUE,
drawGrid = FALSE, fillGraph = TRUE
)
)
})
```
Upvotes: 1
Views: 614
Answers (1)
Eric Green
Reputation: 7725
I was not using validate() correctly. This change gives the correct result:
validate(need(nrow(filtered)!=0, "There are no matches in the dataset. Try removing or relaxing one or more filters."))
---
title: "test"
output:
flexdashboard::flex_dashboard:
theme: bootstrap
runtime: shiny
---
```{r setup, include=FALSE}
library(flexdashboard)
library(tidyverse)
library(tibbletime)
library(dygraphs)
library(magrittr)
library(xts)
```
```{r global, include=FALSE}
# generate data
set.seed(1)
dat <- data.frame(date = seq(as.Date("2018-01-01"),
as.Date("2018-06-30"),
"days"),
sex = sample(c("male", "female"), 181, replace=TRUE),
lang = sample(c("english", "spanish"), 181, replace=TRUE),
age = sample(20:35, 181, replace=TRUE))
dat <- dplyr::sample_n(dat, 80)
```
Sidebar {.sidebar}
=====================================
```{r}
radioButtons("diss", label = "Disaggregation",
choices = list("All" = "Total",
"By Sex" = "sex",
"By Language" = "lang"),
selected = "Total")
sliderInput("agerange", label = "Age",
min = 15,
max = 99,
value = c(15, 99),
step=1)
```
Page 1
=====================================
```{r plot}
# credit to https://stackoverflow.com/a/52325173/841405
renderDygraph({
grp_col <- rlang::sym(input$diss) # This converts the input selection to a symbol
filtered <-
dat %>%
mutate(Total = 1) %>% # This is a hack to let us "group" by Total -- all one group
filter(age >= input$agerange[1] & age <= input$agerange[2])
validate(need(nrow(filtered)!=0, "There are no matches in the dataset. Try removing or relaxing one or more filters."))
filtered %>%
mutate(my_group = !!grp_col) %>%
group_by(date = lubridate::floor_date(date, "1 week"), my_group) %>%
count() %>% spread(my_group, n) %>% ungroup() %>%
padr::pad() %>% replace(is.na(.), 0) %>%
xts::xts(order.by = .$date) %>%
dygraph() %>%
dyRangeSelector() %>%
dyOptions(
useDataTimezone = FALSE, stepPlot = TRUE,
drawGrid = FALSE, fillGraph = TRUE
)
})
```
Upvotes: 1
Related Questions
- Check for missing values in data and give warning message if there is
- Show a message instead of/within plot while data is loading in R Shiny
- R Shiny: How not to display plot when NULL
- Shiny: How to change output (visual data to warning message & vice-versa) when input conditions are evaluated via actionButton
- How to display a text when dataset is empty in ploty
- Shiny R - ggplotly - Show custom message instead of empty plot when the dataset does not return any information
- Evaluate if a shiny app input is not empty not working, how to do it right?
- Conditional Output Shiny UI
- How to add conditional rows which consist of few user inputs in Shiny app
- Rendering Shiny user inputs based on conditional logic in server