R Highcharter:“动态"中的“动态"深入分析 [英] R Highcharter: dynamic drilldown in Shiny on the fly
本文介绍了R Highcharter:“动态"中的“动态"深入分析的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我正在尝试使用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进行渲染，以替换Highcharts细分并实施R驱动的细分.
因为它可能更容易消化，所以我将从后者开始.
Shiny的向下钻取功能
忘了Highcharts可以进行深入分析.您已经拥有了所需的一切，因为您知道如何添加事件广播器，该事件广播器会告诉您何时单击了图形上的某个点.
为此，您实际上使用了renderHighcharts的反应性，并使用代表当前向下钻取的不同数据集重新呈现了图表.过程如下:单击"Farm"列，现在使用"Farm"子集呈现图表.单击下一列，您将构建更深层的嵌套子集并进行渲染.
Highcharts唯一提供的内容是您必须要做的，就是添加后退"按钮以再次进行钻取.
首先，以下解决方案可能会令人困惑，因为它由一些反应式表达式组成，这些反应式表达式收敛到包含您当前钻取状态的一个反应式数据集中.请注意，我们必须将当前钻取状态存储在后端中，以便能够进行回钻并钻取更深的层次.
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当请求向下钻取(drilldown-event)时，它必须发送什么关键字.请注意，这不是单击事件，而是更专门的事件(仅当有向下钻取时可用).
我们发送回的数据必须正确格式化，因此在这里您需要对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)
I am trying to create a multi-layer drilldown graph using highcharter with dynamic data in shiny. With the help of the SO Community (shoutout to @K. Rohde) was able to figure it out by looping through all possible drilldowns. My actual shiny application will have hundreds off possible drilldowns and I don't want to add this extra time to the application but rather have the drilldown be created on the fly using addSingleSeriesAsDrilldown. Unsure of how to use it in R though.
Below is the working example of my issue looping through all drilldown possibilities:
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)
Below is an example of R code using the addSingleSeriesAsDrilldown but I am unsure of how to apply it. I would need to dynamically change the JS string.
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()
)
解决方案
You're getting a double answer for this one. There are two basic ways to achieve what you desire. One is to use the drilldown that Highcharts provides, even though you have to collect the sub-series from the R backend. The other one is to simply replace the Highcharts drilldown and implementing an R driven drilldown, using Highcharts only for rendering.
Since it is probably easier to digest, I will start with the latter.
Drilldown functionality from Shiny
Just forget that Highcharts can do drilldowns. You already have all you need, since you know how to add an event broadcaster that tells you when a point on the graph has been clicked.
For that, you really use the reactiveness of renderHighcharts and re-render the chart with a different data set that represents the current drilldown. The process is as follows: Column "Farm" gets clicked and you now render the Chart with the "Farm" subset. The next column gets clicked and you build the even deeper nested subset and render that.
The only thing that Highcharts has been providing, which you have to do yourself, is to add a "Back" button to drill up again.
The solution below might be confusing at first, since it consists of some reactive expressions that converge into one reactive dataset which contains your current drilldown status. Note that we have to store the current drill status in the backend in order to be able to drill back up and also drill to deeper levels.
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)
Drilldown functionality from Highcharts
Here we have the situation, that you need to send data from the backend to the JavaScript to make use of the addSeriesAsDrilldown method from the charting library. This works in a kind of asynchronous way: Highcharts alerts that some point was requested to drill down (by clicking on it). Then the backend has to calculate the corresponding dataset and then report the dataset back to Highcharts so that it can be rendered. We use the CustomMessageHandler for this.
We don't add any drilldown series to the original Highcharts but we tell Highcharts what keyword it has to send when a drilldown is requested (drilldown-event). Note that this is not the click event, but more specialized (only if drilldown available).
The data we send back has to be formatted correctly, so here you would need some insight into the api of Highcharts (JS, not highcharter).
There are so many ways to create the drilldown data, so here I wrote another function that does it even more generally. The most important thing, however, is that you work with level-IDs that can be used to determine what filter level we are currently at. There are some comments in the code to point out those situations.
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)
这篇关于R Highcharter:“动态"中的“动态"深入分析的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
