Вы получаете двойной ответ на этот.Есть два основных способа достичь желаемого.Один из них - использовать детализацию, предоставляемую Highcharts, даже если вы должны собрать подсерии из бэкэнда R.Другой - просто заменить развертку Highcharts и внедрить развертку на основе R, используя Highcharts только для рендеринга.
Поскольку это, вероятно, легче переварить, я начну с последнего.
Функциональность детализации от Shiny
Просто забудьте, что Highcharts может выполнять детализацию.У вас уже есть все, что вам нужно, поскольку вы знаете, как добавить транслятор событий, который сообщит вам, когда была нажата точка на графике.
Для этого вы действительно используете реактивность renderHighcharts и повторновизуализировать диаграмму с другим набором данных, который представляет текущую развертку.Процесс выглядит следующим образом: щелкается столбец «Ферма», и теперь вы визуализируете диаграмму с подмножеством «Ферма».В следующем столбце щелкают, и вы строите еще более глубокое вложенное подмножество и отображаете его.Единственное, что предоставил 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).Обратите внимание, что это не событие щелчка, а более специализированное (только при наличии детализации).
Данные, которые мы отправляем обратно, должны быть правильно отформатированы, поэтому здесь вам понадобится некоторое представление о API Highcharts (JS)., не highcharter).
Существует так много способов создания данных детализации, поэтому здесь я написал еще одну функцию, которая делает это еще более широко.Однако самое важное, что вы работаете с идентификаторами уровней, которые можно использовать для определения того, какой уровень фильтра мы используем в данный момент.В коде есть некоторые комментарии, указывающие на такие ситуации.
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)