r - 从 Shiny 模块中读取反应元素

Question

我正在尝试使用预定义函数中的一些反应元素，并从模块中调用该数据来生成绘图，但数据在选择时没有得到更新。我也尝试在内部调用函数reactive()并从模块中调用它，但结果仍然相同。我的方法如下：

library(shiny)
library(shinyWidgets)
library(highcharter)
library(data.table)
library(dplyr)

employement_type_count <- function(
  data,
  category,
  ...
){

  data[employee_category %in% category, .(count = .N), by = employee_category]

}

pie_chart_ui <- function(id) {
  ns <- NS(id)
  highchartOutput(ns("pie"))
}

pie_chart_server <- function(
  id, 
  data, 
  var_x = names(data)[1], 
  var_y = names(data)[2], 
  lab_x = names(data)[1], 
  lab_y = names(data)[2], 
  tooltip_name = names(data)[2],
  export_title = NA
) {
  moduleServer(
    id,
    function(input, output, session) {
      output$pie <- renderHighchart({
        data %>%
          hchart(
            'pie', 
            hcaes_(x = var_x, y = var_y), 
            name = tooltip_name
          ) %>% 
          hc_xAxis(title = list(text = lab_x)) %>% 
          hc_yAxis(title = list(text = lab_y)) %>% 
          hc_plotOptions(
            pie = list(
              allowPointSelect = TRUE,
              cursor = 'pointer',
              dataLabels = list(
                enabled = TRUE,
                format = '<b>{point.name}</b>: {point.percentage:.1f}%',
                style = list(
                  color = "(Highcharts.theme && Highcharts.theme.contrastTextColor) || 'black'"
                )
              )
            )
          ) %>% 
          hc_exporting(
            enabled = TRUE,
            buttons = list(
              contextButton = list(
                align = 'right'
              )
            ),
            chartOptions = list(
              title = list(
                text = export_title
              )
            )
          )
      })
      
    }
  )    
}

ui <- fluidPage(
  sidebarPanel(
    pickerInput(
      "employee_type",
      "Employee Type",
      choices = c("Regular", "Project", "Service", "Part-Time"),
      selected = c("Regular", "Project", "Service", "Part-Time"),
      multiple = TRUE
    )
  ),
  mainPanel(
    pie_chart_ui("employee_category")
  )
)

server <- function(input, output, session){
  
  # data_common <- fread("data_common.csv")
  
  data_common <- data.table(
    id = 1:26,
    employee_name = LETTERS,
    gender_type = rep(c("Male", "Female"), each = 13),
    employee_category = c("Regular", "Project", rep(c("Regular", "Project", "Service", "Part-Time"), times = 6))
  )
  
  pie_chart_server(
    "employee_category", 
    employement_type_count(
      data_common,
      input$employee_type
    )
  )
  
}

shinyApp(ui, server)

请注意，数据应该从服务器而不是全局导入，因为它会不断更新。

标签： rshinyreactiveshinymodules

Answer 1

一种方法如下所示。

library(shiny)
library(shinyWidgets)
library(highcharter)
library(data.table)
library(dplyr)


df1 <- data.table(
  id = 1:26,
  employee_name = LETTERS,
  gender_type = rep(c("Male", "Female"), each = 13),
  employee_category = c("Regular", "Project", rep(c("Regular", "Project", "Service", "Part-Time"), times = 6))
)

employement_type_count <- function(
  data,
  category,
  ...
){
  data <- data()
  if (is.null(category())) {df <- data
  }else df <- data[employee_category %in% category(), .(count = .N), by = employee_category]
  
  return(df)
  
}

pie_chart_ui <- function(id) {
  ns <- NS(id)
  highchartOutput(ns("pie"))
}

pie_chart_server <- function(
  id, 
  data, 
  var_x = names(data)[1], 
  var_y = names(data)[2], 
  lab_x = names(data)[1], 
  lab_y = names(data)[2], 
  tooltip_name = names(data)[2],
  export_title = NA
) {
  moduleServer(
    id,
    function(input, output, session) {
      output$pie <- renderHighchart({
        data %>%
          hchart(
            'pie', 
            hcaes_(x = var_x, y = var_y), 
            name = tooltip_name
          ) %>% 
          hc_xAxis(title = list(text = lab_x)) %>% 
          hc_yAxis(title = list(text = lab_y)) %>% 
          hc_plotOptions(
            pie = list(
              allowPointSelect = TRUE,
              cursor = 'pointer',
              dataLabels = list(
                enabled = TRUE,
                format = '<b>{point.name}</b>: {point.percentage:.1f}%',
                style = list(
                  color = "(Highcharts.theme && Highcharts.theme.contrastTextColor) || 'black'"
                )
              )
            )
          ) %>% 
          hc_exporting(
            enabled = TRUE,
            buttons = list(
              contextButton = list(
                align = 'right'
              )
            ),
            chartOptions = list(
              title = list(
                text = export_title
              )
            )
          )
      })
      
    }
  )    
}

ui <- fluidPage(
  sidebarPanel(
    pickerInput(
      "employee_type",
      "Employee Type",
      choices = c("Regular", "Project", "Service", "Part-Time"),
      selected = c("Regular", "Project", "Service", "Part-Time"),
      multiple = TRUE
    )
  ),
  mainPanel(
    pie_chart_ui("employee_category") 
  )
)

server <- function(input, output, session){
  
  # data_common <- fread("data_common.csv")
  
  data_common <- reactive(df1)
  employee <- reactive(input$employee_type)
  
  observe({
    mydata <- employement_type_count(
      data_common,
      employee
    )
    
    pie_chart_server(
      "employee_category", 
      mydata
    )
    
  })
}

shinyApp(ui, server)