R Highcharter：在 Shiny on the fly 中动态向下钻取
R Highcharter: dynamic drilldown in Shiny on the fly
我正在尝试使用 highcharter 和 shiny 中的动态数据创建多层向下钻取图。在 SO 社区（向@K. Rohde 大喊大叫）的帮助下，我们能够通过遍历所有可能的向下钻取来解决这个问题。我实际闪亮的应用程序将有数百个可能的向下钻取，我不想将这个额外的时间添加到应用程序中，而是使用 addSingleSeriesAsDrilldown 即时创建向下钻取。不过不确定如何在 R 中使用它。
下面是我的问题循环遍历所有向下钻取可能性的工作示例：
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)
下面是使用 addSingleSeriesAsDrilldown 的 R 代码示例，但我不确定如何应用它。我需要动态更改 JS 字符串。
library(highcharter)
highchart() %>%
hc_chart(
events = list(
drilldown = JS("function(e) {
var chart = this,
newSeries = [{
color: 'red',
type: 'column',
stacking: 'normal',
data: [1, 5, 3, 4]
}, {
type: 'column',
stacking: 'normal',
data: [3, 4, 5, 1]
}]
chart.addSingleSeriesAsDrilldown(e.point, newSeries[0]);
chart.addSingleSeriesAsDrilldown(e.point, newSeries[1]);
chart.applyDrilldown();
}")
)
) %>%
hc_add_series(type = "pie", data= list(list(y = 3, drilldown = TRUE), list(y = 2, drilldown = TRUE))) %>%
hc_drilldown(
series = list()
)
你得到了这个问题的双重答案。有两种基本方法可以实现您的愿望。一种是使用 Highcharts 提供的向下钻取，即使您必须从 R 后端收集子系列。另一种是简单地替换 Highcharts 钻取并实现 R 驱动的钻取，仅使用 Highcharts 进行渲染。
因为它可能更容易消化，所以我将从后者开始。
来自 Shiny 的向下钻取功能
只是忘了 Highcharts 可以进行向下钻取。您已经拥有了所需的一切，因为您知道如何添加一个事件广播器来告诉您何时单击了图表上的某个点。
为此，您真正使用了 renderHighcharts 的反应性，并使用代表当前向下钻取的不同数据集重新呈现图表。过程如下：单击列 "Farm"，您现在使用 "Farm" 子集呈现图表。单击下一列，您将构建更深的嵌套子集并进行渲染。
Highcharts 唯一提供的功能是添加一个 "Back" 按钮以再次向上钻取。
下面的解决方案一开始可能会令人困惑，因为它包含一些反应式表达式，这些表达式会聚合到一个反应式数据集中，其中包含您当前的向下钻取状态。请注意，我们必须将当前的钻取状态存储在后端，以便能够向上钻取并钻取到更深的级别。
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(
actionButton("Back", "Back"),
highchartOutput("Working"),
verbatimTextOutput("trial")
)
sidebar <- dashboardSidebar()
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
# To hold the current drilldown status as list, i.e. list("Farm", "Sheep")
state <- reactiveValues(drills = list())
# Reactive reacting to the above drill list, giving out a normalized data.frame (category, amount)
filtered <- reactive({
if (length(state$drills) == 0) {
# Case no drills are present.
data.frame(category = dat$x, amount = dat$a)
} else if (length(state$drills) == 1) {
# Case only x_level drill is present.
x_level = state$drills[[1]]
sub <- dat[dat$x == x_level,]
data.frame(category = sub$y, amount = sub$a)
} else if (length(state$drills) == 2) {
# Case x_level and y_level drills are present.
x_level = state$drills[[1]]
y_level = state$drills[[2]]
sub <- dat[dat$x == x_level & dat$y == y_level,]
data.frame(category = sub$z, amount = sub$a)
}
})
# Since Drilldown from Highcharts is not used: Install own click handler that builds up the drill list.
observeEvent(input$ClickedInput, {
if (length(state$drills) < 2) {
# Push drill name.
state$drills <<- c(state$drills, input$ClickedInput)
}
})
# Since Drilldown from Highcharts is not used: Back button is manually inserted.
observeEvent(input$Back, {
if (length(state$drills) > 0) {
# Pop drill name.
state$drills <<- state$drills[-length(state$drills)]
}
})
output$Working <- renderHighchart({
# Using normalized names from above.
summarized <- filtered() %>%
group_by(category) %>%
summarize(Quantity = sum(amount))
summarized <- arrange(summarized, desc(Quantity))
tibbled <- tibble(name = summarized$category, y = summarized$Quantity)
# This time, click handler is needed.
pointClickFunction <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.name);}")
highchart() %>%
hc_xAxis(type = "category") %>%
hc_add_series(tibbled, "column", hcaes(x = name, y = y), color = "#E4551F") %>%
hc_plotOptions(column = list(stacking = "normal", events = list(click = pointClickFunction)))
})
output$trial <- renderText({input$ClickedInput})
}
shinyApp(ui, server)
Highcharts 的向下钻取功能
在这种情况下，您需要将数据从后端发送到 JavaScript 以使用图表库中的 addSeriesAsDrilldown 方法。这以一种异步方式工作：Highcharts 警告某个点被请求向下钻取（通过单击它）。然后后端要计算出对应的数据集，然后将数据集上报给Highcharts，这样就可以渲染了。为此，我们使用 CustomMessageHandler。
我们不向原始 Highcharts 添加任何向下钻取系列，但我们告诉 Highcharts 在请求向下钻取时必须发送什么关键字（向下钻取事件）。请注意，这不是点击事件，而是更专业的事件（仅当向下钻取可用时）。
我们发回的数据必须正确格式化，所以在这里您需要了解 Highcharts（JS，不是 highcharter）的api。
创建下钻数据的方法有很多种，所以我在这里写了另一个函数，它的作用更为普遍。然而，最重要的是您使用可用于确定我们当前所处过滤器级别的级别 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({
# Make the initial data.
summarized <- dat %>%
group_by(x) %>%
summarize(Quantity = sum(a))
summarized <- arrange(summarized, desc(Quantity))
tibbled <- tibble(name = summarized$x, y = summarized$Quantity)
# This time, click handler is needed.
drilldownHandler <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.drilldown);}")
# Also a message receiver for later async drilldown data has to be set.
# Note in the JS: message.point is going to be the point ID. Highcharts addSeriesAsDrilldown need a point to attach
# the drilldown series to. This is retrieved via chart.get which takes the ID of any Highcharts Element.
# This means: IDs are kind of important here, so keep track of what you assign.
installDrilldownReceiver <- JS("function() {
var chart = this;
Shiny.addCustomMessageHandler('drilldown', function(message) {
var point = chart.get(message.point)
chart.addSeriesAsDrilldown(point, message.series);
});
}")
highchart() %>%
# Both events are on the chart layer, not by series.
hc_chart(events = list(load = installDrilldownReceiver, drilldown = drilldownHandler)) %>%
hc_xAxis(type = "category") %>%
# Note: We add a drilldown directive (= name) to tell Highcharts that this has a drilldown functionality.
hc_add_series(tibbled, "column", hcaes(x = name, y = y, drilldown = name, id = name), color = "#E4551F") %>%
hc_plotOptions(column = list(stacking = "normal")) %>%
hc_drilldown(allowPointDrilldown = TRUE)
})
# Drilldown handler to calculate the correct drilldown
observeEvent(input$ClickedInput, {
# We will code the drill levels to be i.e. Farm_Car. By that we calculate the next Sub-Chart.
levels <- strsplit(input$ClickedInput, "_", fixed = TRUE)[[1]]
# This is just for generalizing this function to work in all the levels and even be expandable to further more levels.
resemblences <- c("x", "y", "z")
dataSubSet <- dat
# We subsequently narrow down the original dataset by walking through the drilled levels
for (i in 1:length(levels)) {
dataSubSet <- dat[dat[[resemblences[i]]] == levels[i],]
}
# Create a common data.frame for all level names.
normalized <- data.frame(category = dataSubSet[[resemblences[length(levels) + 1]]], amount = dataSubSet$a)
summarized <- normalized %>%
group_by(category) %>%
summarize(Quantity = sum(amount))
summarized <- arrange(summarized, desc(Quantity))
tibbled <- tibble(name = summarized$category, y = summarized$Quantity)
# Preparing the names and drilldown directives for the next level below.
# If already in "Farm_Car", the name for column "Bob" will be "Farm_Car_Bob"
nextLevelCodes = lapply(tibbled$name, function(fac) {
paste(c(levels, as.character(fac)), collapse = "_")
}) %>% unlist
tibbled$id = nextLevelCodes
# This is dynamic handling for when there is no further drilldown possible.
# If no "drilldown" property is set in the data object, Highcharts will not let further drilldowns be triggered.
if (length(levels) < length(resemblences) - 1) {
tibbled$drilldown = nextLevelCodes
}
# Sending data to the installed Drilldown Data listener.
session$sendCustomMessage("drilldown", list(
series = list(
type = "column",
name = paste(levels, sep = "_"),
data = list_parse(tibbled)
),
# Here, point is, as mentioned above, the ID of the point that triggered the drilldown.
point = input$ClickedInput
))
})
output$trial <- renderText({input$ClickedInput})
}
shinyApp(ui, server)
我正在尝试使用 highcharter 和 shiny 中的动态数据创建多层向下钻取图。在 SO 社区（向@K. Rohde 大喊大叫）的帮助下，我们能够通过遍历所有可能的向下钻取来解决这个问题。我实际闪亮的应用程序将有数百个可能的向下钻取，我不想将这个额外的时间添加到应用程序中，而是使用 addSingleSeriesAsDrilldown 即时创建向下钻取。不过不确定如何在 R 中使用它。
下面是我的问题循环遍历所有向下钻取可能性的工作示例：
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)
下面是使用 addSingleSeriesAsDrilldown 的 R 代码示例，但我不确定如何应用它。我需要动态更改 JS 字符串。
library(highcharter)
highchart() %>%
hc_chart(
events = list(
drilldown = JS("function(e) {
var chart = this,
newSeries = [{
color: 'red',
type: 'column',
stacking: 'normal',
data: [1, 5, 3, 4]
}, {
type: 'column',
stacking: 'normal',
data: [3, 4, 5, 1]
}]
chart.addSingleSeriesAsDrilldown(e.point, newSeries[0]);
chart.addSingleSeriesAsDrilldown(e.point, newSeries[1]);
chart.applyDrilldown();
}")
)
) %>%
hc_add_series(type = "pie", data= list(list(y = 3, drilldown = TRUE), list(y = 2, drilldown = TRUE))) %>%
hc_drilldown(
series = list()
)
你得到了这个问题的双重答案。有两种基本方法可以实现您的愿望。一种是使用 Highcharts 提供的向下钻取，即使您必须从 R 后端收集子系列。另一种是简单地替换 Highcharts 钻取并实现 R 驱动的钻取，仅使用 Highcharts 进行渲染。
因为它可能更容易消化，所以我将从后者开始。
来自 Shiny 的向下钻取功能
只是忘了 Highcharts 可以进行向下钻取。您已经拥有了所需的一切，因为您知道如何添加一个事件广播器来告诉您何时单击了图表上的某个点。
为此，您真正使用了 renderHighcharts 的反应性，并使用代表当前向下钻取的不同数据集重新呈现图表。过程如下：单击列 "Farm"，您现在使用 "Farm" 子集呈现图表。单击下一列，您将构建更深的嵌套子集并进行渲染。
Highcharts 唯一提供的功能是添加一个 "Back" 按钮以再次向上钻取。
下面的解决方案一开始可能会令人困惑，因为它包含一些反应式表达式，这些表达式会聚合到一个反应式数据集中，其中包含您当前的向下钻取状态。请注意，我们必须将当前的钻取状态存储在后端，以便能够向上钻取并钻取到更深的级别。
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(
actionButton("Back", "Back"),
highchartOutput("Working"),
verbatimTextOutput("trial")
)
sidebar <- dashboardSidebar()
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
# To hold the current drilldown status as list, i.e. list("Farm", "Sheep")
state <- reactiveValues(drills = list())
# Reactive reacting to the above drill list, giving out a normalized data.frame (category, amount)
filtered <- reactive({
if (length(state$drills) == 0) {
# Case no drills are present.
data.frame(category = dat$x, amount = dat$a)
} else if (length(state$drills) == 1) {
# Case only x_level drill is present.
x_level = state$drills[[1]]
sub <- dat[dat$x == x_level,]
data.frame(category = sub$y, amount = sub$a)
} else if (length(state$drills) == 2) {
# Case x_level and y_level drills are present.
x_level = state$drills[[1]]
y_level = state$drills[[2]]
sub <- dat[dat$x == x_level & dat$y == y_level,]
data.frame(category = sub$z, amount = sub$a)
}
})
# Since Drilldown from Highcharts is not used: Install own click handler that builds up the drill list.
observeEvent(input$ClickedInput, {
if (length(state$drills) < 2) {
# Push drill name.
state$drills <<- c(state$drills, input$ClickedInput)
}
})
# Since Drilldown from Highcharts is not used: Back button is manually inserted.
observeEvent(input$Back, {
if (length(state$drills) > 0) {
# Pop drill name.
state$drills <<- state$drills[-length(state$drills)]
}
})
output$Working <- renderHighchart({
# Using normalized names from above.
summarized <- filtered() %>%
group_by(category) %>%
summarize(Quantity = sum(amount))
summarized <- arrange(summarized, desc(Quantity))
tibbled <- tibble(name = summarized$category, y = summarized$Quantity)
# This time, click handler is needed.
pointClickFunction <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.name);}")
highchart() %>%
hc_xAxis(type = "category") %>%
hc_add_series(tibbled, "column", hcaes(x = name, y = y), color = "#E4551F") %>%
hc_plotOptions(column = list(stacking = "normal", events = list(click = pointClickFunction)))
})
output$trial <- renderText({input$ClickedInput})
}
shinyApp(ui, server)
Highcharts 的向下钻取功能
在这种情况下，您需要将数据从后端发送到 JavaScript 以使用图表库中的 addSeriesAsDrilldown 方法。这以一种异步方式工作：Highcharts 警告某个点被请求向下钻取（通过单击它）。然后后端要计算出对应的数据集，然后将数据集上报给Highcharts，这样就可以渲染了。为此，我们使用 CustomMessageHandler。
我们不向原始 Highcharts 添加任何向下钻取系列，但我们告诉 Highcharts 在请求向下钻取时必须发送什么关键字（向下钻取事件）。请注意，这不是点击事件，而是更专业的事件（仅当向下钻取可用时）。
我们发回的数据必须正确格式化，所以在这里您需要了解 Highcharts（JS，不是 highcharter）的api。
创建下钻数据的方法有很多种，所以我在这里写了另一个函数，它的作用更为普遍。然而，最重要的是您使用可用于确定我们当前所处过滤器级别的级别 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({
# Make the initial data.
summarized <- dat %>%
group_by(x) %>%
summarize(Quantity = sum(a))
summarized <- arrange(summarized, desc(Quantity))
tibbled <- tibble(name = summarized$x, y = summarized$Quantity)
# This time, click handler is needed.
drilldownHandler <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.drilldown);}")
# Also a message receiver for later async drilldown data has to be set.
# Note in the JS: message.point is going to be the point ID. Highcharts addSeriesAsDrilldown need a point to attach
# the drilldown series to. This is retrieved via chart.get which takes the ID of any Highcharts Element.
# This means: IDs are kind of important here, so keep track of what you assign.
installDrilldownReceiver <- JS("function() {
var chart = this;
Shiny.addCustomMessageHandler('drilldown', function(message) {
var point = chart.get(message.point)
chart.addSeriesAsDrilldown(point, message.series);
});
}")
highchart() %>%
# Both events are on the chart layer, not by series.
hc_chart(events = list(load = installDrilldownReceiver, drilldown = drilldownHandler)) %>%
hc_xAxis(type = "category") %>%
# Note: We add a drilldown directive (= name) to tell Highcharts that this has a drilldown functionality.
hc_add_series(tibbled, "column", hcaes(x = name, y = y, drilldown = name, id = name), color = "#E4551F") %>%
hc_plotOptions(column = list(stacking = "normal")) %>%
hc_drilldown(allowPointDrilldown = TRUE)
})
# Drilldown handler to calculate the correct drilldown
observeEvent(input$ClickedInput, {
# We will code the drill levels to be i.e. Farm_Car. By that we calculate the next Sub-Chart.
levels <- strsplit(input$ClickedInput, "_", fixed = TRUE)[[1]]
# This is just for generalizing this function to work in all the levels and even be expandable to further more levels.
resemblences <- c("x", "y", "z")
dataSubSet <- dat
# We subsequently narrow down the original dataset by walking through the drilled levels
for (i in 1:length(levels)) {
dataSubSet <- dat[dat[[resemblences[i]]] == levels[i],]
}
# Create a common data.frame for all level names.
normalized <- data.frame(category = dataSubSet[[resemblences[length(levels) + 1]]], amount = dataSubSet$a)
summarized <- normalized %>%
group_by(category) %>%
summarize(Quantity = sum(amount))
summarized <- arrange(summarized, desc(Quantity))
tibbled <- tibble(name = summarized$category, y = summarized$Quantity)
# Preparing the names and drilldown directives for the next level below.
# If already in "Farm_Car", the name for column "Bob" will be "Farm_Car_Bob"
nextLevelCodes = lapply(tibbled$name, function(fac) {
paste(c(levels, as.character(fac)), collapse = "_")
}) %>% unlist
tibbled$id = nextLevelCodes
# This is dynamic handling for when there is no further drilldown possible.
# If no "drilldown" property is set in the data object, Highcharts will not let further drilldowns be triggered.
if (length(levels) < length(resemblences) - 1) {
tibbled$drilldown = nextLevelCodes
}
# Sending data to the installed Drilldown Data listener.
session$sendCustomMessage("drilldown", list(
series = list(
type = "column",
name = paste(levels, sep = "_"),
data = list_parse(tibbled)
),
# Here, point is, as mentioned above, the ID of the point that triggered the drilldown.
point = input$ClickedInput
))
})
output$trial <- renderText({input$ClickedInput})
}
shinyApp(ui, server)