На это вы получите двойной ответ. Есть два основных способа достичь желаемого. Один из них - использовать развертку, которую предоставляет Highcharts, даже если вам нужно собрать подсерию из бэкэнда R. Другой - просто заменить развертку Highcharts и реализовать развертку на основе R, используя Highcharts только для рендеринга.
Поскольку его, вероятно, легче переваривать, я начну с последнего.
Функциональность Drilldown от 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)
Функциональность Drilldown от Highcharts
Здесь у нас есть ситуация, когда вам нужно отправить данные из бэкэнда в JavaScript, чтобы использовать метод addSeriesAsDrilldown из библиотеки диаграмм. Это работает своего рода асинхронным способом: Highcharts предупреждает о том, что некоторая точка была запрошена для детализации (щелкнув по ней). Затем серверная часть должна вычислить соответствующий набор данных, а затем отправить этот набор данных обратно в Highcharts, чтобы его можно было визуализировать. Для этого мы используем CustomMessageHandler.
Мы не добавляем никаких серий детализации к исходным Highcharts, но мы сообщаем Highcharts, какое ключевое слово он должен отправить при запросе детализации (событие детализации). Обратите внимание, что это не событие щелчка, а более специализированное (только при наличии детализации).
Данные, которые мы отправляем обратно, должны быть правильно отформатированы, поэтому здесь вам понадобится некоторое представление об 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)
person
K. Rohde
schedule
15.03.2019
