R Highcharter:Shiny中的动态多级深入分析 [英] R Highcharter: Dynamic multi level drilldown in Shiny
问题描述
我正在尝试使用highcharter和shiny中的动态数据创建多层向下钻取图.我可以只使用带有一组input的R代码来完成此操作，但是当我将其放入一个闪亮的应用程序中并尝试使其动态地对数据进行子集处理时，它将失败.
I am trying to create a multi-layer drilldown graph using highcharter with dynamic data in shiny. I am able to accomplish this using just R code with a set input but when I put it in a shiny application and try to have it subset the data dynamically, it fails.
下面是在R中可用的代码(仅从Farm到Sheep向下钻取):
Below is the code that that works in R (only drilling down from Farm to Sheep):
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))
)
)
下面是将input更改为动态时在Shiny中失败的代码:
Below is the code that fails in Shiny when changing input to dynamic:
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)
推荐答案
您的方法被click函数误导了.完全没有必要，因为(在非发光示例中可以看到)Highcharts具有自己的机制来检测系列点击，并可以自行查找和呈现明细.
Your approach was kind of mislead by the click function. It is totally unnecessary, since (as can be seen in the non-shiny example) Highcharts has its own mechanisms to detect series clicks and can find and render drilldowns on its own.
您试图捕获click事件使Highcharts图表构建功能每次都重新呈现(重置任何向下钻取)，因此您根本看不到任何向下钻取事件.
You trying to catch the click event made the Highcharts chart building function re-render every time (resetting any drilldown) so you could not see any drilldown events at all.
解决方案是将您正在使用的Highcharts示例复制到renderHighchart函数中.您将立即看到农场"和绵羊"下拉菜单起作用.
The solution is to just copy your working Highcharts example into the renderHighchart function. You will immediately see that the "Farm" and "Sheep" dropdowns work.
我想您通过在子级别名称中使用术语输入"来混淆自己，因为它们根本就没有输入(从闪亮的意义上来说).要使向下钻取正常工作，要做的就是在创建Highcharts图表时 pre 定义向下钻取集.因此，您可以提前告诉插件将使用哪些细分，而Highchart仅根据您指定的ID进行细分.
I suppose that you were confusing yourself by using the terms "input" for the sublevel names as they are no input at all (in the shiny sense). What you have to do to get the drilldown working properly is to predefine the drilldown sets when you create the Highcharts chart. So you tell the Plugin in advance what drilldowns will be used and Highchart drills down only based on the IDs you specify.
我编辑了您的代码，以使所有可能的向下钻取都在一个循环中创建，并且一切正常:
I edited your code such that all the possible drilldowns are created in a loop and everything is working:
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之外访问.
If for any reason, you should not be satisfied with collecting all drilldowns beforehand, there is an api for adding drilldowns on the fly. Try searching for Highcharts and "addSeriesAsDrilldown". I am not sure, however, if this is accessible outside of JavaScript.
这篇关于R Highcharter:Shiny中的动态多级深入分析的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
