为什么这个 dplyr 过滤器在闪亮时不起作用，但在 运行 没有闪亮时工作正常？
Why does this dplyr filter not work in shiny, but works fine when run without shiny?
下面的代码 运行 没有 Shiny，可以很好地通过 2 种不同的测量时间范围的方法（按日历月（“Period_1”）和自元素起源以来经过的月数对数据进行分组("Period_2"))，并在按 Period_2:
分组时将数据框扩展到校正周期
library(tidyverse)
data <- data.frame(
ID = c(1,1,2,2,2,2),
Period_1 = c("2020-03", "2020-04", "2020-01", "2020-02", "2020-03", "2020-04"),
Period_2 = c(1, 2, 1, 2, 3, 4),
ColA = c(10, 20, 30, 40, 50, 52),
ColB = c(15, 25, 35, 45, 55, 87)
)
### Expand the dataframe to including missing rows ###
dataExpand <-
data %>%
tidyr::complete(ID, nesting(Period_2)) %>%
tidyr::fill(ColA, ColB, .direction = "down")
### Run the expanded data frame through grouping code ###
# Group by calendar month (Period_1)
groupData_1 <-
dataExpand %>%
group_by(Period_1) %>%
select("ColA","ColB") %>%
summarise(across(everything(), sum)) %>%
filter(!is.na(Period_1)) # << Add this code to delete NA row for calendar period
# Group by vintage month (Period_2)
groupData_2 <-
dataExpand %>%
group_by(Period_2) %>%
select("ColA","ColB") %>%
summarise(across(everything(), sum, na.rm = TRUE))
结果（当运行使用上面的代码时是正确的）：
> groupData_1
# A tibble: 4 x 3
Period_1 ColA ColB
<chr> <dbl> <dbl>
1 2020-01 30 35
2 2020-02 40 45
3 2020-03 60 70
4 2020-04 72 112
> groupData_2
# A tibble: 4 x 3
Period_2 ColA ColB
<dbl> <dbl> <dbl>
1 1 40 50
2 2 60 70
3 3 70 80
4 4 72 112
但是，当我将以上内容放入 Shiny 中时，用户可以单击单选按钮以 select 按 Period_1 或 Period_2 分组，应用程序崩溃。问题似乎出在 if(input$grouping == 'Period_1'... 行中，因为当我将其注释掉时，App 运行s（但没有像这条线那样删除 NA 的 Period_1） .如何解决？
library(shiny)
library(tidyverse)
ui <-
fluidPage(
h3("Data table:"),
tableOutput("data"),
h3("Sum the data table columns:"),
radioButtons(
inputId = "grouping",
label = NULL,
choiceNames = c("By period 1", "By period 2"),
choiceValues = c("Period_1", "Period_2"),
selected = "Period_1",
inline = TRUE
),
tableOutput("sums")
)
server <- function(input, output, session) {
data <- reactive({
data.frame(
ID = c(1,1,2,2,2,2),
Period_1 = c("2020-03", "2020-04", "2020-01", "2020-02", "2020-03", "2020-04"),
Period_2 = c(1, 2, 1, 2, 3, 4),
ColA = c(10, 20, 30, 40, 50, 52),
ColB = c(15, 25, 35, 45, 55, 87)
)
})
dataExpand <- reactive({
data() %>%
tidyr::complete(ID, nesting(Period_2)) %>%
tidyr::fill(ColA, ColB, .direction = "down")
})
summed_data <- reactive({
dataExpand() %>%
group_by(!!sym(input$grouping)) %>%
select("ColA","ColB") %>%
summarise(across(everything(), sum, na.rm = TRUE)) #%>%
# Below removes Period_1 rows that are added due to Period_2 < 4 when grouping by Period_2
if(input$grouping == 'Period_1'){filter(!is.na(Period_1))}
})
output$data <- renderTable(data())
output$sums <- renderTable(summed_data())
}
shinyApp(ui, server)
这更接近您的需求吗？
library(shiny)
library(tidyverse)
ui <-
fluidPage(
h3("Data table:"),
tableOutput("data"),
h3("Sum the data table columns:"),
radioButtons(
inputId = "grouping",
label = NULL,
choiceNames = c("By period 1", "By period 2"),
choiceValues = c("Period_1", "Period_2"),
selected = "Period_1",
inline = TRUE
),
tableOutput("sums")
)
server <- function(input, output, session) {
data <- reactive({
data.frame(
ID = c(1,1,2,2,2,2),
Period_1 = c("2020-03", "2020-04", "2020-01", "2020-02", "2020-03", "2020-04"),
Period_2 = c(1, 2, 1, 2, 3, 4),
ColA = c(10, 20, 30, 40, 50, 52),
ColB = c(15, 25, 35, 45, 55, 87)
)
})
dataExpand <- reactive({
data() %>%
tidyr::complete(ID, nesting(Period_2)) %>%
tidyr::fill(ColA, ColB, .direction = "down")
})
choice <- reactive(input$grouping)
summed_data <- reactive({
dataExpand() %>%
group_by(across(choice())) %>%
select("ColA","ColB") %>%
summarise(across(everything(), sum, na.rm = TRUE)) |>
filter(across(1,.fns = ~ .x |> negate(is.na)() ))
# Below removes Period_1 rows that are added due to Period_2 < 4 when grouping by Period_2
})
output$data <- renderTable(data())
output$sums <- renderTable(summed_data())
}
shinyApp(ui, server)
你的summed_data块没有return任何东西。
summed_data <- reactive({
dataExpand() %>%
group_by(!!sym(input$grouping)) %>%
select("ColA","ColB") %>%
summarise(across(everything(), sum, na.rm = TRUE)) %>%
# Below removes Period_1 rows that are added due to Period_2 < 4 when grouping by Period_2
if(input$grouping == 'Period_1'){ filter(!is.na(Period_1)) }
})
实际上应该会失败并出现错误。
input <- list(grouping = "Period_2")
mtcars %>%
if (input$grouping == "Period_1") filter(cyl == 4L)
# Warning in if (.) F else filter(is.na(cyl)) :
# the condition has length > 1 and only the first element will be used
# Error in if (.) F else filter(is.na(cyl)) :
# argument is not interpretable as logical
一种解决方法是
mtcars %>%
{ if (input$grouping == "Period_1") filter(., cyl == 4) else .; }
在那里完成：
- 用大括号括起来
{ ... }；
- 在对
filter的调用中使用了特殊的.，因此它实际上有数据可以操作；和
- 添加了一个
else，否则 return 是所有数据。
另一种方法：
mtcars %>%
filter(input$grouping != "Period_1" | cyl == 4L)
备注：
- 请注意，我颠倒了逻辑。也就是你的逻辑是分组为Period_1才过滤；在这里，
input$grouping != "Period_1" returns TRUE 当它不是 Period_1 时，这意味着 cyl == 4 中的任何内容都无关紧要，一切都将是真实的；如果是Period_1，那么return就是假的，然后cyl == 4就会有影响。
您的代码的另一个问题是您处理管道 data_Expand() %>% ... summarize(.) 但是因为您没有将该表达式捕获到变量中，所以它从未被使用过。与 R 中的许多东西（包括函数和反应块）一样，最后计算的表达式将是 return 值（或显式 return(.) 调用中的任何内容，尽管通常不是必需的）。在您的情况下，最后评估 if 语句。如果条件为真，那么它会尝试 运行 filter(!is.na(Period_1))，但是没有数据（管道中没有明确表示）；如果条件为假，因为没有 else 块，它 returns NULL （不可见）。
尝试将该块更改为：
summed_data <- reactive({
dataExpand() %>%
group_by(!!sym(input$grouping)) %>%
select("ColA","ColB") %>%
summarise(across(everything(), sum, na.rm = TRUE)) %>%
filter(input$grouping != "Period_1" | !is.na(Period_1))
})
下面的代码 运行 没有 Shiny，可以很好地通过 2 种不同的测量时间范围的方法（按日历月（“Period_1”）和自元素起源以来经过的月数对数据进行分组("Period_2"))，并在按 Period_2:
分组时将数据框扩展到校正周期library(tidyverse)
data <- data.frame(
ID = c(1,1,2,2,2,2),
Period_1 = c("2020-03", "2020-04", "2020-01", "2020-02", "2020-03", "2020-04"),
Period_2 = c(1, 2, 1, 2, 3, 4),
ColA = c(10, 20, 30, 40, 50, 52),
ColB = c(15, 25, 35, 45, 55, 87)
)
### Expand the dataframe to including missing rows ###
dataExpand <-
data %>%
tidyr::complete(ID, nesting(Period_2)) %>%
tidyr::fill(ColA, ColB, .direction = "down")
### Run the expanded data frame through grouping code ###
# Group by calendar month (Period_1)
groupData_1 <-
dataExpand %>%
group_by(Period_1) %>%
select("ColA","ColB") %>%
summarise(across(everything(), sum)) %>%
filter(!is.na(Period_1)) # << Add this code to delete NA row for calendar period
# Group by vintage month (Period_2)
groupData_2 <-
dataExpand %>%
group_by(Period_2) %>%
select("ColA","ColB") %>%
summarise(across(everything(), sum, na.rm = TRUE))
结果（当运行使用上面的代码时是正确的）：
> groupData_1
# A tibble: 4 x 3
Period_1 ColA ColB
<chr> <dbl> <dbl>
1 2020-01 30 35
2 2020-02 40 45
3 2020-03 60 70
4 2020-04 72 112
> groupData_2
# A tibble: 4 x 3
Period_2 ColA ColB
<dbl> <dbl> <dbl>
1 1 40 50
2 2 60 70
3 3 70 80
4 4 72 112
但是，当我将以上内容放入 Shiny 中时，用户可以单击单选按钮以 select 按 Period_1 或 Period_2 分组，应用程序崩溃。问题似乎出在 if(input$grouping == 'Period_1'... 行中，因为当我将其注释掉时，App 运行s（但没有像这条线那样删除 NA 的 Period_1） .如何解决？
library(shiny)
library(tidyverse)
ui <-
fluidPage(
h3("Data table:"),
tableOutput("data"),
h3("Sum the data table columns:"),
radioButtons(
inputId = "grouping",
label = NULL,
choiceNames = c("By period 1", "By period 2"),
choiceValues = c("Period_1", "Period_2"),
selected = "Period_1",
inline = TRUE
),
tableOutput("sums")
)
server <- function(input, output, session) {
data <- reactive({
data.frame(
ID = c(1,1,2,2,2,2),
Period_1 = c("2020-03", "2020-04", "2020-01", "2020-02", "2020-03", "2020-04"),
Period_2 = c(1, 2, 1, 2, 3, 4),
ColA = c(10, 20, 30, 40, 50, 52),
ColB = c(15, 25, 35, 45, 55, 87)
)
})
dataExpand <- reactive({
data() %>%
tidyr::complete(ID, nesting(Period_2)) %>%
tidyr::fill(ColA, ColB, .direction = "down")
})
summed_data <- reactive({
dataExpand() %>%
group_by(!!sym(input$grouping)) %>%
select("ColA","ColB") %>%
summarise(across(everything(), sum, na.rm = TRUE)) #%>%
# Below removes Period_1 rows that are added due to Period_2 < 4 when grouping by Period_2
if(input$grouping == 'Period_1'){filter(!is.na(Period_1))}
})
output$data <- renderTable(data())
output$sums <- renderTable(summed_data())
}
shinyApp(ui, server)
这更接近您的需求吗？
library(shiny)
library(tidyverse)
ui <-
fluidPage(
h3("Data table:"),
tableOutput("data"),
h3("Sum the data table columns:"),
radioButtons(
inputId = "grouping",
label = NULL,
choiceNames = c("By period 1", "By period 2"),
choiceValues = c("Period_1", "Period_2"),
selected = "Period_1",
inline = TRUE
),
tableOutput("sums")
)
server <- function(input, output, session) {
data <- reactive({
data.frame(
ID = c(1,1,2,2,2,2),
Period_1 = c("2020-03", "2020-04", "2020-01", "2020-02", "2020-03", "2020-04"),
Period_2 = c(1, 2, 1, 2, 3, 4),
ColA = c(10, 20, 30, 40, 50, 52),
ColB = c(15, 25, 35, 45, 55, 87)
)
})
dataExpand <- reactive({
data() %>%
tidyr::complete(ID, nesting(Period_2)) %>%
tidyr::fill(ColA, ColB, .direction = "down")
})
choice <- reactive(input$grouping)
summed_data <- reactive({
dataExpand() %>%
group_by(across(choice())) %>%
select("ColA","ColB") %>%
summarise(across(everything(), sum, na.rm = TRUE)) |>
filter(across(1,.fns = ~ .x |> negate(is.na)() ))
# Below removes Period_1 rows that are added due to Period_2 < 4 when grouping by Period_2
})
output$data <- renderTable(data())
output$sums <- renderTable(summed_data())
}
shinyApp(ui, server)
你的summed_data块没有return任何东西。
summed_data <- reactive({
dataExpand() %>%
group_by(!!sym(input$grouping)) %>%
select("ColA","ColB") %>%
summarise(across(everything(), sum, na.rm = TRUE)) %>%
# Below removes Period_1 rows that are added due to Period_2 < 4 when grouping by Period_2
if(input$grouping == 'Period_1'){ filter(!is.na(Period_1)) }
})
实际上应该会失败并出现错误。
input <- list(grouping = "Period_2")
mtcars %>%
if (input$grouping == "Period_1") filter(cyl == 4L)
# Warning in if (.) F else filter(is.na(cyl)) :
# the condition has length > 1 and only the first element will be used
# Error in if (.) F else filter(is.na(cyl)) :
# argument is not interpretable as logical
一种解决方法是
mtcars %>%
{ if (input$grouping == "Period_1") filter(., cyl == 4) else .; }
在那里完成：
- 用大括号括起来
{ ... }； - 在对
filter的调用中使用了特殊的.，因此它实际上有数据可以操作；和 - 添加了一个
else，否则 return 是所有数据。
另一种方法：
mtcars %>%
filter(input$grouping != "Period_1" | cyl == 4L)
备注：
- 请注意，我颠倒了逻辑。也就是你的逻辑是分组为Period_1才过滤；在这里，
input$grouping != "Period_1"returnsTRUE当它不是 Period_1 时，这意味着cyl == 4中的任何内容都无关紧要，一切都将是真实的；如果是Period_1，那么return就是假的，然后cyl == 4就会有影响。
您的代码的另一个问题是您处理管道 data_Expand() %>% ... summarize(.) 但是因为您没有将该表达式捕获到变量中，所以它从未被使用过。与 R 中的许多东西（包括函数和反应块）一样，最后计算的表达式将是 return 值（或显式 return(.) 调用中的任何内容，尽管通常不是必需的）。在您的情况下，最后评估 if 语句。如果条件为真，那么它会尝试 运行 filter(!is.na(Period_1))，但是没有数据（管道中没有明确表示）；如果条件为假，因为没有 else 块，它 returns NULL （不可见）。
尝试将该块更改为：
summed_data <- reactive({
dataExpand() %>%
group_by(!!sym(input$grouping)) %>%
select("ColA","ColB") %>%
summarise(across(everything(), sum, na.rm = TRUE)) %>%
filter(input$grouping != "Period_1" | !is.na(Period_1))
})