时间戳

首页 > 解决方案 > 如果对输入进行过滤后行 == 0，则让闪亮的应用程序显示自定义消息而不是绘图

r - 如果对输入进行过滤后行 == 0，则让闪亮的应用程序显示自定义消息而不是绘图

问题描述

我有一个闪亮的应用程序，可以在其中选择将数据集过滤为 0 行的输入。有 0 行会导致某些函数抛出错误。我试图了解如何构建应用程序，以便我可以处理当数据集被过滤为 0 行时导致错误的情况。基于其他 SO 答案（示例），我相信一种方法是使用validate()，但我不确定如何正确实施。这可能会被标记为重复，但我认为现有的答案不能证明validate()这个用例（很可能我错过了一些！）。

这是该问题的一个不显眼的 MRE。想象一下，该filter(age >= 36 & age <= 40)步骤来自闪亮应用程序中的滑块输入。玩具数据集的年龄最大为 35，因此将滑块的下限设置为 36 会将数据集过滤为 0 行。（限制滑块范围不是一个选项，因为数据会发生变化，并且可能包括明天 36 岁的人。在我的实际用例中，有多个过滤器和许多通往 0 行的路径。）

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
  )

当数据集被过滤为 0 行时，padr::pad()在此示例中会引发错误。我正在寻找一种策略来绘制 ifrows > 0过滤后，或者 if rows == 0，打印如下消息：

数据集中没有匹配项。尝试移除或放松一个或多个过滤器。

显示此问题的闪亮版本：

要产生错误，请将较低的年龄滑块拖动到 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
    )
})
```

尝试集成的闪亮版本（非工作）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
    )
    )
})
```

标签： rshiny

解决方案

我没有validate()正确使用。此更改给出了正确的结果：

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
    )
})
```

推荐阅读