r - R Highcharter：Shiny 中的动态多级钻取
问题描述
我正在尝试highcharter使用shiny. 我可以只使用带有一组的 R 代码来完成此操作，input但是当我将它放在一个闪亮的应用程序中并尝试让它动态地对数据进行子集时，它会失败。
以下是有效的代码R（仅从农场向下钻取到绵羊）：
library(shinyjs)
library(tidyr)
library(data.table)
library(highcharter)
library(dplyr)
x <- c("Farm","Farm","Farm","City","City","City","Ocean","Ocean")
y <- c("Sheep","Sheep","Cow","Car","Bus","Bus","Boat","Boat")
z <- c("Bill","Tracy","Sandy","Bob","Carl","Newt","Fig","Tony")
a <- c(1,1,1,1,1,1,1,1)
dat <- data.frame(x,y,z,a)
input <- "Farm"
input2 <- "Sheep"
#First Tier
datSum <- dat %>%
group_by(x) %>%
summarize(Quantity = sum(a)
)
datSum <- arrange(datSum,desc(Quantity))
Lvl1dfStatus <- tibble(name = datSum$x, y = datSum$Quantity, drilldown = tolower(name))
#Second Tier
datSum2 <- dat[dat$x == input,]
datSum2 <- datSum2 %>%
group_by(y) %>%
summarize(Quantity = sum(a)
)
datSum2 <- arrange(datSum2,desc(Quantity))
Lvl2dfStatus <- tibble(name = datSum2$y,y = datSum2$Quantity, drilldown = tolower(name))
#Third Tier
datSum2 <- dat[dat$x == input,]
datSum3 <- datSum2[datSum2$y == input2,]
datSum3 <- datSum3 %>%
group_by(z) %>%
summarize(Quantity = sum(a)
)
datSum3 <- arrange(datSum3,desc(Quantity))
Lvl3dfStatus <- tibble(name = datSum3$z,y = datSum3$Quantity)
#Graph
ClickedTest <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.name);}")
highchart() %>%
hc_xAxis(type = "category") %>%
hc_add_series(Lvl1dfStatus, "column", hcaes(x = name, y = y), color = "#E4551F") %>%
hc_plotOptions(column = list(stacking = "normal",
events = list(click = ClickedTest))) %>%
hc_drilldown(
allowPointDrilldown = TRUE,
series = list(
list(id = tolower(input), type = "column", data = list_parse(Lvl2dfStatus)),
list(id = tolower(input2), type = "column", data = list_parse2(Lvl3dfStatus))
)
)
Shiny以下是更改input为动态时失败的代码：
library (shinyjs)
library (tidyr)
library (data.table)
library (highcharter)
library (dplyr)
library (shinydashboard)
library (shiny)
x <- c("Farm","Farm","Farm","City","City","City","Ocean","Ocean")
y <- c("Sheep","Sheep","Cow","Car","Bus","Bus","Boat","Boat")
z <- c("Bill","Tracy","Sandy","Bob","Carl","Newt","Fig","Tony")
a <- c(1,1,1,1,1,1,1,1)
dat <- data.frame(x,y,z,a)
# input <- "Farm"
# input2 <- "Sheep"
header <- dashboardHeader()
body <- dashboardBody(
highchartOutput("Test"),
verbatimTextOutput("trial")
)
sidebar <- dashboardSidebar()
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
Lvl1ClickHardCoded <- ""
output$Test <- renderHighchart({
#First Tier
datSum <- dat %>%
group_by(x) %>%
summarize(Quantity = sum(a)
)
datSum <- arrange(datSum,desc(Quantity))
Lvl1dfStatus <- tibble(name = datSum$x, y = datSum$Quantity, drilldown = tolower(name))
#Second Tier
rowcheck <- dat[dat$x == input$ClickedInput,]
if (nrow(rowcheck)!=0){
datSum2 <- dat[dat$x == input$ClickedInput,]
datSum2 <- datSum2 %>%
group_by(y) %>%
summarize(Quantity = sum(a)
)
datSum2 <- arrange(datSum2,desc(Quantity))
Lvl2dfStatus <- tibble(name = datSum2$y,y = datSum2$Quantity, drilldown = tolower(name))
Lvl1ClickHardCoded <<- input$ClickedInput
Lvl1id <<- tolower(input$ClickedInput)
}
else{
Lvl2dfStatus <- data.table(Group.1=numeric(), x=numeric())
Lvl2dfStatus <- tibble(name = Lvl2dfStatus$Group.1,y = Lvl2dfStatus$x)
Lvl1id <- ""
}
#Third Tier
rowcheck <- dat[dat$x == Lvl1ClickHardCoded,]
rowcheck <- rowcheck[rowcheck$y == input$ClickedInput,]
if (nrow(rowcheck)!=0){
datSum2 <- dat[dat$x == Lvl1ClickHardCoded,]
datSum3 <- datSum2[datSum2$y == input$ClickedInput,]
datSum3 <- datSum3 %>%
group_by(z) %>%
summarize(Quantity = sum(a)
)
datSum3 <- arrange(datSum3,desc(Quantity))
Lvl3dfStatus <- tibble(name = datSum3$z,y = datSum3$Quantity)
Lvl2id <<- tolower(input$ClickedInput)
}
else{
Lvl3dfStatus <- data.table(Group.1=numeric(), x=numeric())
Lvl3dfStatus <- tibble(name = Lvl3dfStatus$Group.1,y = Lvl3dfStatus$x)
Lvl2id <- ""
}
#Graph
ClickedTest <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.name);}")
highchart() %>%
hc_xAxis(type = "category") %>%
hc_add_series(Lvl1dfStatus, "column", hcaes(x = name, y = y), color = "#E4551F") %>%
hc_plotOptions(column = list(stacking = "normal",
events = list(click = ClickedTest))) %>%
hc_drilldown(
allowPointDrilldown = TRUE,
series = list(
list(id = Lvl1id, type = "column", data = list_parse(Lvl2dfStatus)),
list(id = Lvl2id, type = "column", data = list_parse2(Lvl3dfStatus))
)
)
})
output$trial <- renderText({input$ClickedInput})
}
shinyApp(ui, server)
解决方案
您的方法有点被点击功能误导。这是完全没有必要的，因为（从不闪亮的例子中可以看出）Highcharts 有自己的机制来检测系列点击，并且可以自己查找和呈现向下钻取。
您试图捕捉点击事件使 Highcharts 图表构建功能每次都重新呈现（重置任何向下钻取），因此您根本看不到任何向下钻取事件。
解决方案是将您的工作 Highcharts 示例复制到renderHighchart函数中。您将立即看到“农场”和“绵羊”下拉菜单有效。
我想您对子级别名称使用术语“输入”感到困惑，因为它们根本没有输入（在闪亮的意义上）。要使向下钻取正常工作，您必须在创建 Highcharts 图表时预先定义向下钻取集。因此，您提前告诉插件将使用哪些向下钻取，Highchart 仅根据您指定的 ID 向下钻取。
我编辑了您的代码，以便在循环中创建所有可能的钻取并且一切正常：
library (shinyjs)
library (tidyr)
library (data.table)
library (highcharter)
library (dplyr)
library (shinydashboard)
library (shiny)
x <- c("Farm","Farm","Farm","City","City","City","Ocean","Ocean")
y <- c("Sheep","Sheep","Cow","Car","Bus","Bus","Boat","Boat")
z <- c("Bill","Tracy","Sandy","Bob","Carl","Newt","Fig","Tony")
a <- c(1,1,1,1,1,1,1,1)
dat <- data.frame(x,y,z,a)
header <- dashboardHeader()
body <- dashboardBody(
highchartOutput("Working"),
verbatimTextOutput("trial")
)
sidebar <- dashboardSidebar()
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
output$Working <- renderHighchart({
#First Tier #Copied
datSum <- dat %>%
group_by(x) %>%
summarize(Quantity = sum(a)
)
datSum <- arrange(datSum,desc(Quantity))
Lvl1dfStatus <- tibble(name = datSum$x, y = datSum$Quantity, drilldown = tolower(name))
#Second Tier # Generalized to not use one single input
# Note: I am creating a list of Drilldown Definitions here.
Level_2_Drilldowns <- lapply(unique(dat$x), function(x_level) {
# x_level is what you called 'input' earlier.
datSum2 <- dat[dat$x == x_level,]
datSum2 <- datSum2 %>%
group_by(y) %>%
summarize(Quantity = sum(a)
)
datSum2 <- arrange(datSum2,desc(Quantity))
# Note: The "drilldown" variable has to be unique, this is why we use level 1 plus level 2 names.
Lvl2dfStatus <- tibble(name = datSum2$y,y = datSum2$Quantity, drilldown = tolower(paste(x_level, name, sep = "_")))
list(id = tolower(x_level), type = "column", data = list_parse(Lvl2dfStatus))
})
#Third Tier # Generalized through all of level 2
# Note: Again creating a list of Drilldown Definitions here.
Level_3_Drilldowns <- lapply(unique(dat$x), function(x_level) {
datSum2 <- dat[dat$x == x_level,]
lapply(unique(datSum2$y), function(y_level) {
datSum3 <- datSum2[datSum2$y == y_level,]
datSum3 <- datSum3 %>%
group_by(z) %>%
summarize(Quantity = sum(a)
)
datSum3 <- arrange(datSum3,desc(Quantity))
Lvl3dfStatus <- tibble(name = datSum3$z,y = datSum3$Quantity)
# Note: The id must match the one we specified above as "drilldown"
list(id = tolower(paste(x_level, y_level, sep = "_")), type = "column", data = list_parse2(Lvl3dfStatus))
})
}) %>% unlist(recursive = FALSE)
highchart() %>%
hc_xAxis(type = "category") %>%
hc_add_series(Lvl1dfStatus, "column", hcaes(x = name, y = y), color = "#E4551F") %>%
hc_plotOptions(column = list(stacking = "normal")) %>%
hc_drilldown(
allowPointDrilldown = TRUE,
series = c(Level_2_Drilldowns, Level_3_Drilldowns)
)
})
output$trial <- renderText({input$ClickedInput})
}
shinyApp(ui, server)
如果出于任何原因，您不应该对事先收集所有明细感到满意，那么有一个用于动态添加明细的 api。尝试搜索 Highcharts 和“addSeriesAsDrilldown”。但是，我不确定这是否可以在 JavaScript 之外访问。
推荐阅读
- c++ - 如何通过stbi_write_png保存高清图片
- python - 将字母和数字的字符串转换为数组
- arrays - 为什么数组吞下的元素多于其容量？
- random - 为什么这个 rand use 语句在 rust 中起作用？
- node.js - UnhandledPromiseRejectionWarning：TypeError：无法读取未定义的属性“缓冲区”
- css - 如何在保持精确的 div 比率的同时阻止文本溢出到另一个 div？
- angular - 如何在 TypeScript 中正确使用 GeolocationPosition？
- html - 使用 BeautifulSoup 抓取非内联样式的 html 元素的 css 属性
- python - 类型错误：只能将 str（不是“float”）连接到 str
- r - 如何在 sparklyr 包中运行 FPGrowth