R/闪亮钻取报告

Question

尝试制作一个饼图（或者最好是圆环图），以显示每个类别的总数，并允许在单击时向下钻取以显示每个类别的详细信息。有意义吗？

我想我可能没有正确设置每个系统设置，因为复制/粘贴标准示例也会呈现一个空白页面。除非那是某种过时的东西。 我的系统：Ubuntu 20.04, R 4.0.5, packageVersion("shiny") 1.6.0, shiny-server --version 1.5.16.958 空白示例：https://plotly-r.com/linking-views-with-shiny.html#drill-down 和 Creating drill down report in R Shiny（以及其他）

我目前的尝试（还没有反应，因为我一辈子都想不通）：

library(shiny)
library(DBI)
library(ggplot2)
library(dplyr)
library(ggiraph)

ui<-fluidPage(
  titlePanel("Budget visuals"),

  sidebarLayout(
    sidebarPanel(
      selectInput("fase", "Choose a budget phase:", choices = c("Budget" = "OWB", "Report" = "JV")),
      selectInput("jaar", "Choose a year:", choices = c(2021, 2020, 2019, 2018, 2017, 2016, 2015)),
      selectInput("vuo", "V/U/O:", choices = c("Verplichtingen" = "V", "Uitgaven" = "U", "Ontvangsten" = "O")),
      submitButton("Submit")
    ),

    mainPanel(
      h4(textOutput("header")),
      girafeOutput("donut"),
      tableOutput("view")
    )
  )
)

server<-function(input, output, session) {
  output$header <- renderText({paste0("Visual: ", input$fase, " (", input$vuo, ") ", input$jaar)})

  output$donut <- renderGirafe({
    conn <- dbConnect(
      drv = RMySQL::MySQL(),
      dbname = "btabellen",
      host = "localhost",
      username = "dbuser",
      password = "***")
    on.exit(dbDisconnect(conn), add = TRUE)
    dbGetQuery(conn, 'set character set "utf8"')
    data <- dbGetQuery(conn, paste0(
      "SELECT naam_begroting as begroting, sum(bedrag_t) as bedrag FROM ", input$fase, " WHERE jaar = ", input$jaar, " AND VUO = '", input$vuo, "' GROUP BY jaar, naam_begroting ORDER BY bedrag DESC;"))
    data$fraction <- data$bedrag / sum(data$bedrag)
    data$fraclbl <- paste0(round(100 * data$fraction, 1), "%")
    data$ymax <- cumsum(data$fraction)
    data$ymin <- c(0, head(data$ymax, n=-1))
    data$label <- paste0(data$begroting, ": € ", format(data$bedrag, big.mark=".", decimal.mark=","), " (k)")

    donut_plot <- ggplot(data, aes(y = bedrag, fill = begroting, data_id = begroting)) +
    geom_bar_interactive(
      aes(x = 1, tooltip = label),
      width = 0.1,
      stat = "identity",
      show.legend = FALSE
      ) +
    coord_polar(theta = "y") +
    theme_void() +
    theme(legend.position = "bottom")

    girafe(ggobj = donut_plot, opts_selection(type = "single"))
  })

  output$view <- renderTable({
    conn <- dbConnect(
      drv = RMySQL::MySQL(),
      dbname = "btabellen",
      host = "localhost",
      username = "dbuser",
      password = "***")
    on.exit(dbDisconnect(conn), add = TRUE)
    dbGetQuery(conn, 'set character set "utf8"')
    data <- dbGetQuery(conn, paste0(
      "SELECT naam_begroting as Begroting, SUM(bedrag_t) as Bedrag FROM ", input$fase, " WHERE jaar = ", input$jaar, " AND VUO = '", input$vuo, "' GROUP BY jaar, naam_begroting ORDER BY bedrag DESC;"))
  }, digits=0)
}

shinyApp(ui=ui, server=server)

所以基本上，我想要实现的是打开页面，其中显示预算的甜甜圈图，显示类别的所有总数。单击类别时，甜甜圈应自行更新以显示刚刚单击的类别的每个子类别的总数。实际上，在用户选择这些参数的情况下，单击应将 SQL 查询更改为"SELECT artikelnaam, sum(bedrag_t) FROM OWB WHERE jaar=2018 AND VUO='U' AND naam_begroting='Financiën'"。理想情况下，renderTable 应该显示一个列出子类别的嵌套表，但这是针对不同的问题。

有什么想法我可能做错了吗？

Answer 1

关键是使用input$donut_selected，自动生成_selected-后缀输入，见https://davidgohel.github.io/ggiraph/articles/offcran/shiny.html#access-the-selected-values。
像这样：

dbGetQuery(conn, paste0(
      "SELECT .... ",
      "FROM ", input$fase, " WHERE .... ",

      if (!is.null(input$donut_selected)) paste0(" AND naam_begroting = '", input$donut_selected, "' "),

      " GROUP BY ....;"))

（正如 cmets 中所讨论的，不对查询进行参数化是不好的做法，但以上内容按原样提供以解决主要问题（如何深入研究）。

请注意，由于使用了submitButton，整个应用程序（包括向下钻取功能）不会完全反应，并且只有在单击“提交”时才会发生向下钻取（请参阅?submitButton）

---

使示例可重现/可运行（但不是最小）：

将磁盘写入虚拟 SQLite 数据库：

library(DBI)

if (!dir.exists("data")) dir.create("data")
if (!file.exists(csv_file <- "data/OWB.csv")) {
  download.file("https://www.gitlab-minfin.nl/datasets/OWB.csv",
                destfile = csv_file)
}
if (!file.exists(db_file <- "data/owb.sqlite")) {
  df <- read.csv(csv_file, fileEncoding = "UTF-8")
  con <- dbConnect(RSQLite::SQLite(), db_file)
  dbWriteTable(con, "owb", df)
}

适用于 SQLite 数据库的示例：

library(shiny)
library(ggplot2)
library(dplyr)
library(ggiraph)

ui<-fluidPage(
  titlePanel("Budget visuals"),
  
  sidebarLayout(
    sidebarPanel(
      selectInput("fase", "Choose a budget phase:", choices = c(
        "Budget" = "OWB", "Report" = "JV")),
      selectInput("jaar", "Choose a year:", choices = c(
        2021, 2020, 2019, 2018, 2017, 2016, 2015)),
      selectInput("vuo", "V/U/O:", choices = c(
        "Verplichtingen" = "V", "Uitgaven" = "U", "Ontvangsten" = "O")),
      submitButton("Submit")
    ),
    
    mainPanel(
      h4(textOutput("header")),
      girafeOutput("donut"),
      tableOutput("view")
    )
  )
)

server<-function(input, output, session) {
  output$header <- renderText({
    paste0("Visual: ", input$fase, " (", input$vuo, ") ", input$jaar)
  })
  
  output$donut <- renderGirafe({
    conn <- dbConnect(drv = RSQLite::SQLite(), db_file)
    on.exit(dbDisconnect(conn), add = TRUE)
    data <- dbGetQuery(conn, paste0(
      "SELECT naam_begroting as begroting, sum(bedrag_t) as bedrag ",
      "FROM ", input$fase, " WHERE jaar = ", input$jaar, " AND VUO = '", input$vuo, 
      "' GROUP BY jaar, naam_begroting ORDER BY bedrag DESC;"))
    data$fraction <- data$bedrag / sum(data$bedrag)
    data$fraclbl <- paste0(round(100 * data$fraction, 1), "%")
    data$ymax <- cumsum(data$fraction)
    data$ymin <- c(0, head(data$ymax, n=-1))
    data$label <- paste0(
      data$begroting, ": € ", 
      format(data$bedrag, big.mark=".", decimal.mark=","), " (k)")
    
    donut_plot <- ggplot(data, aes(y = bedrag, fill = begroting, data_id = begroting)) +
      geom_bar_interactive(
        aes(x = 1, tooltip = label),
        width = 0.1,
        stat = "identity",
        show.legend = FALSE
      ) +
      coord_polar(theta = "y") +
      theme_void() +
      theme(legend.position = "bottom")
    
      girafe(ggobj = donut_plot, options = list(opts_selection(type = "single")))
  })
  
  output$view <- renderTable({
    conn <- dbConnect(drv = RSQLite::SQLite(), db_file)
    on.exit(dbDisconnect(conn), add = TRUE)
    data <- dbGetQuery(conn, paste0(
      "SELECT naam_begroting as Begroting, SUM(bedrag_t) as Bedrag ",
      "FROM ", input$fase, " WHERE jaar = ", input$jaar, " AND VUO = '", input$vuo, "' ",
      
      if (!is.null(input$donut_selected)) paste0(" AND naam_begroting = '", input$donut_selected, "' "),
      
      " GROUP BY jaar, naam_begroting ORDER BY bedrag DESC;"))
  }, digits=0)
}

shinyApp(ui=ui, server=server)

其他变化：

• girafe 选项传递
• 删除可能与 SQLite 不兼容且与问题无关的 set 指令