在 flexdashboard 中添加下载处理程序时分页被切断

Posted 2023-03-24

【中文标题】在 flexdashboard 中添加下载处理程序时分页被切断

【英文标题】：Pagination getting cut off when adding download handler in flexdashboard

【发布时间】：2022-01-13 14:51:42

【问题描述】：

我在使用来自闪亮 (downloadHandler) 的下载处理程序和使用 DT 渲染表（使用 renderDataTable）时遇到问题。当我使用下载处理程序并在我的 flexdashboard 应用程序中呈现表格时，分页被切断。因此，用户无法切换到表格的不同页面，因为分页不适合呈现表格的容器或“框”。这只发生在我包含 downloadHandler 时。如果我使用 DT 的扩展名包含按钮，则​​分页不会被切断。问题是我需要使用 downloadHandler，因为我的应用程序中的数据量非常大。请注意，示例数据不代表数据的大小。有谁知道如何解决这个问题？

这是我正在使用的代码：

---
title: "Test"
output: 
  flexdashboard::flex_dashboard:
  orientation: rows
  vertical_layout: fill

runtime: shiny
---

```r global, include=FALSE
library(dplyr)
library(tidyquant)
library(ggplot2)
library(stringr)
library(tidyr)
library(pins)
library(shiny)
library(httr)
library(XML)
library(DT)
library(plotly)
library(purrr)


test_data  <- structure(list(Toys = c("Slinky", "Slinky", "Slinky", "Slinky", 
"Slinky", "Slinky", "Tin Solider", "Tin Solider", "Tin Solider", 
"Tin Solider", "Tin Solider", "Tin Solider", "Hungry Hungry Hippo", 
"Hungry Hungry Hippo", "Hungry Hungry Hippo", "Hungry Hungry Hippo", 
"Hungry Hungry Hippo", "Hungry Hungry Hippo"), Manufacturer = c("Manufacturer A", 
"Manufacturer B", "Manufacturer C", "Manufacturer A", "Manufacturer A", 
"Manufacturer A", "Manufacturer B", "Manufacturer B", "Manufacturer B", 
"Manufacturer B", "Manufacturer B", "Manufacturer B", "Manufacturer C", 
"Manufacturer C", "Manufacturer C", "Manufacturer C", "Manufacturer C", 
"Manufacturer C"), Price = c(5.99, 6.99, 7.99, 9, 6, 5.54, 7, 
9.99, 6.99, 6.75, 8, 7.99, 9.99, 7.99, 5.99, 8.99, 10.99, 9.75
), change = c(0, 16.69449082, 14.30615165, 12.640801, -33.33333333, 
-7.666666667, 0, 42.71428571, -30.03003003, -3.433476395, 18.51851852, 
-0.125, 0, -20.02002002, -25.03128911, 50.08347245, 22.24694105, 
-11.28298453), Dates = c("1/1/2021", "3/1/2021", "5/1/2021", 
"7/1/2021", "9/1/2021", "10/1/2021", "1/1/2021", "3/1/2021", 
"5/1/2021", "7/1/2021", "9/1/2021", "10/1/2021", "1/1/2021", 
"3/1/2021", "5/1/2021", "7/1/2021", "9/1/2021", "10/1/2021")), class = "data.frame", row.names = c(NA, 
-18L))
names(test_data) <- c("Toys", "Manufacturer", "Price", "change", "Dates")
```


Sidebar .sidebar
-----------------------------------------------------------------------

```r

selectInput("Toys",
            label = "Toys",
            choices = unique(sort(test_data$Toys)),
            selected = "Slinky")


selectizeInput("Manufacturer",
            label = "Manufacturer",
            choices = c("Select All",as.character(unlist(test_data %>%
                        dplyr::select(Manufacturer) %>%
                        dplyr::arrange(Manufacturer) %>%
                        distinct()))), 
            multiple = TRUE,
            options = list(placeholder = 'Make a selection below'))               
```

Column 
-------------------------------------
```r
#Hides initial error messages
tags$style(type="text/css",
  ".shiny-output-error  visibility: hidden; ",
  ".shiny-output-error:before  visibility: hidden; "
)


observe(
if (!is.null(input$Toys))
  updateSelectInput(
    inputId = "Manufacturer",
    choices =c("Select All", test_data %>%
      dplyr::filter(Toys == input$Toys) %>%
      dplyr::select(Manufacturer) %>%
      dplyr::distinct() %>%
      dplyr::pull(Manufacturer) %>%
      str_sort),
    selected = test_data %>%
      dplyr::filter(Toys == input$Toys) %>%
      dplyr::select(Manufacturer) %>%
      dplyr::distinct() %>% slice_head()
    )
  
)

observe (
  if("Select All" %in% input$Manufacturer)
    updateSelectInput(
      inputId = "Manufacturer", 
    selected = test_data %>%
      dplyr::filter(Toys == input$Toys) %>%
      dplyr::select(Manufacturer) %>%
      dplyr::distinct() %>%
      dplyr::pull(Manufacturer) %>%
      str_sort 
    )
  
)

Toys_reactive <- reactive(
  if(length(unique(test_data$Manufacturer)) >= 1)
    Toys_reactive = NULL
    for(i in input$Manufacturer)
      subset_toys <- test_data %>% 
        dplyr::filter(Manufacturer == i & Toys == input$Toys)
      Toys_reactive <- rbind(Toys_reactive, subset_toys)
    
  
  Toys_reactive
)

    
```

.tabset .tabset-fade
-------------------------------------

### Table 1
```r

downloadLink('downBtn1', 'Download all data')
output$downloadUI <- renderUI( 
  downloadButton("downBtn1", "Example.csv")
)

output$downBtn1 <- downloadHandler(
  filename = function() 
    "Example.csv"
  ,
  content = function(file) 
    write.csv(Toys_reactive(), file, row.names = FALSE)
  
)


DT::renderDataTable(
datatable(Toys_reactive(),
          fillContainer = TRUE, 
          options = list(dom = 'lfrtip',
                           lengthMenu = list(c(15,30,45,-1),
                                             c(15,30,45,"All"))))

)


```

【参考方案1】：

经过多次尝试和错误，我找到了一个可行的解决方案。我使用 css 块将重载从隐藏更改为自动。当表格溢出容器时，这个块会显示分页。 ```css my-style, echo = FALSE

.chart-wrapper .chart-stage 
    overflow: auto;

```

带有附加块的整个测试代码：

---

title: "Test"
output: 
  flexdashboard::flex_dashboard:
runtime: shiny
---

```r global, include=FALSE
library(dplyr)
library(tidyquant)
library(ggplot2)
library(stringr)
library(tidyr)
library(pins)
library(shiny)
library(httr)
library(XML)
library(DT)
library(plotly)
library(purrr)


test_data  <- structure(list(Toys = c("Slinky", "Slinky", "Slinky", "Slinky", 
"Slinky", "Slinky", "Tin Solider", "Tin Solider", "Tin Solider", 
"Tin Solider", "Tin Solider", "Tin Solider", "Hungry Hungry Hippo", 
"Hungry Hungry Hippo", "Hungry Hungry Hippo", "Hungry Hungry Hippo", 
"Hungry Hungry Hippo", "Hungry Hungry Hippo"), Manufacturer = c("Manufacturer A", 
"Manufacturer B", "Manufacturer C", "Manufacturer A", "Manufacturer A", 
"Manufacturer A", "Manufacturer B", "Manufacturer B", "Manufacturer B", 
"Manufacturer B", "Manufacturer B", "Manufacturer B", "Manufacturer C", 
"Manufacturer C", "Manufacturer C", "Manufacturer C", "Manufacturer C", 
"Manufacturer C"), Price = c(5.99, 6.99, 7.99, 9, 6, 5.54, 7, 
9.99, 6.99, 6.75, 8, 7.99, 9.99, 7.99, 5.99, 8.99, 10.99, 9.75
), change = c(0, 16.69449082, 14.30615165, 12.640801, -33.33333333, 
-7.666666667, 0, 42.71428571, -30.03003003, -3.433476395, 18.51851852, 
-0.125, 0, -20.02002002, -25.03128911, 50.08347245, 22.24694105, 
-11.28298453), Dates = c("1/1/2021", "3/1/2021", "5/1/2021", 
"7/1/2021", "9/1/2021", "10/1/2021", "1/1/2021", "3/1/2021", 
"5/1/2021", "7/1/2021", "9/1/2021", "10/1/2021", "1/1/2021", 
"3/1/2021", "5/1/2021", "7/1/2021", "9/1/2021", "10/1/2021")), class = "data.frame", row.names = c(NA, 
-18L))
names(test_data) <- c("Toys", "Manufacturer", "Price", "change", "Dates")
```


Sidebar .sidebar
-----------------------------------------------------------------------

```r

selectInput("Toys",
            label = "Toys",
            choices = unique(sort(test_data$Toys)),
            selected = "Slinky")


selectizeInput("Manufacturer",
            label = "Manufacturer",
            choices = c("Select All",as.character(unlist(test_data %>%
                        dplyr::select(Manufacturer) %>%
                        dplyr::arrange(Manufacturer) %>%
                        distinct()))), 
            multiple = TRUE,
            options = list(placeholder = 'Make a selection below'))               
```

Column 
-------------------------------------
```r
#Hides initial error messages
tags$style(type="text/css",
  ".shiny-output-error  visibility: hidden; ",
  ".shiny-output-error:before  visibility: hidden; "
)


observe(
if (!is.null(input$Toys))
  updateSelectInput(
    inputId = "Manufacturer",
    choices =c("Select All", test_data %>%
      dplyr::filter(Toys == input$Toys) %>%
      dplyr::select(Manufacturer) %>%
      dplyr::distinct() %>%
      dplyr::pull(Manufacturer) %>%
      str_sort),
    selected = test_data %>%
      dplyr::filter(Toys == input$Toys) %>%
      dplyr::select(Manufacturer) %>%
      dplyr::distinct() %>% slice_head()
    )
  
)

observe (
  if("Select All" %in% input$Manufacturer)
    updateSelectInput(
      inputId = "Manufacturer", 
    selected = test_data %>%
      dplyr::filter(Toys == input$Toys) %>%
      dplyr::select(Manufacturer) %>%
      dplyr::distinct() %>%
      dplyr::pull(Manufacturer) %>%
      str_sort 
    )
  
)

Toys_reactive <- reactive(
  if(length(unique(test_data$Manufacturer)) >= 1)
    Toys_reactive = NULL
    for(i in input$Manufacturer)
      subset_toys <- test_data %>% 
        dplyr::filter(Manufacturer == i & Toys == input$Toys)
      Toys_reactive <- rbind(Toys_reactive, subset_toys)
    
  
  Toys_reactive
)

    
```

.tabset .tabset-fade
-------------------------------------

### Table 1
```r



output$table1 <- DT::renderDataTable(
datatable(Toys_reactive(),
          fillContainer = TRUE, 
          options = list(dom = 'lfrtip',
                           lengthMenu = list(c(15,30,45,-1),
                                             c(15,30,45,"All"))))

)

downloadLink('downBtn1', 'Download all data')
output$downloadUI <- renderUI( 
  downloadButton("downBtn1", "Example.csv")
)

output$downBtn1 <- downloadHandler(
  filename = function() 
    "Example.csv"
  ,
  content = function(file) 
    write.csv(Toys_reactive()[input[["table1_rows_all"]],], file, row.names = FALSE)
  
)

tabsetPanel(tabPanel("Table1", dataTableOutput("table1")))



```


### Table 2
```r


downloadLink('downBtn', 'Download all data')
output$downloadUI <- renderUI( 
  downloadButton("downBtn", "Example.csvv")
)

output$downBtn <- downloadHandler(
  filename = function() 
    "Example.csv"
  ,
  content = function(file) 
    write.csv(Toys_reactive(), file, row.names = FALSE)
  
)


DT::renderDataTable(
datatable(Toys_reactive(),
          fillContainer = TRUE, 
          options = list(dom = 'lfrtip',
                           lengthMenu = list(c(15,30,45,-1),
                                             c(15,30,45,"All"))))

)
```

```css my-style, echo = FALSE

.chart-wrapper .chart-stage 
    overflow: auto;

```

如果有人有更好的解决方案，请附上，但我会在一天内接受这个答案。