如何使用HighCharge创建两个独立的向下钻取图？ [英] how to create two independent drill down plot using Highcharter?
本文介绍了如何使用HighCharge创建两个独立的向下钻取图？的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我正在开发一个包含两个向下钻取图表的闪亮应用程序，这两个图表都是从同一个数据文件读取的，唯一的区别是第一个图表执行求和，而第二个图表得到平均值，问题是无论我做什么更改，两个图表仍然冲突，这里是用过的代码
cate<-c("Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","drinks","drinks","groceries","groceries","groceries","dairy","dairy","dairy","dairy","groceries","technology","technology","technology","technology","technology","technology","technology","technology","groceries","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","drinks","drinks","groceries","groceries","groceries","dairy","dairy","dairy","dairy","groceries","technology","technology","technology","technology","technology","technology","technology","technology","groceries","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","drinks","drinks","groceries","groceries","groceries","dairy","dairy","dairy","dairy","groceries","technology","technology","technology","technology","technology","technology","technology","technology","groceries","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","drinks","drinks","groceries","groceries","groceries","dairy","dairy","dairy","dairy","groceries","technology","technology","technology","technology","technology","technology","technology","technology","groceries")
Sub_Product<-c("nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug")
Main_Product<-c("outdoor","indoor","outdoor","indoor","indoor","outdoor","indoor","indoor","indoor","indoor","outdoor","outdoor","n&o","n&o","indoor","indoor","indoor","indoor","outdoor","indoor","outdoor","outdoor","outdoor","indoor","outdoor","indoor","outdoor","outdoor","indoor","outdoor","n&o","outdoor","indoor","outdoor","indoor","indoor","outdoor","indoor","indoor","indoor","indoor","outdoor","outdoor","n&o","n&o","indoor","indoor","indoor","indoor","outdoor","indoor","outdoor","outdoor","outdoor","indoor","outdoor","indoor","outdoor","outdoor","indoor","outdoor","n&o","outdoor","indoor","outdoor","indoor","indoor","outdoor","indoor ","indoor ","indoor ","indoor ","outdoor","outdoor","n&o","n&o","indoor","indoor","indoor","indoor","outdoor","indoor","outdoor","outdoor","outdoor","indoor","outdoor","indoor","outdoor","outdoor","indoor","outdoor","n&o","outdoor","indoor","outdoor","indoor","indoor","outdoor","indoor ","indoor ","indoor ","indoor ","outdoor","outdoor","n&o","n&o","indoor","indoor","indoor","indoor","outdoor","indoor","outdoor","outdoor","outdoor","indoor","outdoor","indoor","outdoor","outdoor","indoor","outdoor","n&o")
Product<-c("abc","def","ghh","hig","lmn","opk","cba","dfw","ewr","csad","wer","casd","were","csad","rt","hgf","qeq","hgf","qer","qer2","erqerq","qdq","dwqer","qerqe","erqererq","e2342","ererq","qewrw","qrerqr","qreqw","qerqe","abc","def","ghh","hig","lmn","opk","cba","dfw","ewr","csad","wer","casd","were","csad","rt","hgf","qeq","hgf","qer","qer2","erqerq","qdq","dwqer","qerqe","erqererq","e2342","ererq","qewrw","qrerqr","qreqw","qerqe","abc","def","ghh","hig","lmn","opk","cba","dfw","ewr","csad","wer","casd","were","csad","rt","hgf","qeq","hgf","qer","qer2","erqerq","qdq","dwqer","qerqe","erqererq","e2342","ererq","qewrw","qrerqr","qreqw","qerqe","abc","def","ghh","hig","lmn","opk","cba","dfw","ewr","csad","wer","casd","were","csad","rt","hgf","qeq","hgf","qer","qer2","erqerq","qdq","dwqer","qerqe","erqererq","e2342","ererq","qewrw","qrerqr","qreqw","qerqe")
sum1<-c(43,90,135,125,87,4,23,120,4,127,70,68,129,63,131,90,67,110,90,119,81,68,15,29,49,11,76,82,65,83,25,43,90,135,125,87,4,23,120,4,127,70,68,129,63,131,90,67,110,90,119,81,68,15,29,49,11,76,82,65,83,25,43,90,135,125,87,4,23,120,4,127,70,68,129,63,131,90,67,110,90,119,81,68,15,29,49,11,76,82,65,83,25,43,90,135,125,87,4,23,120,4,127,70,68,129,63,131,90,67,110,90,119,81,68,15,29,49,11,76,82,65,83,25)
sum2<-c(14567,11111,3287,3563,9633,11162,3044,8437,4382,11250,3932,5587,4175,9708,4970,8388,10673,4301,12475,13494,12519,5632,3898,12472,4381,14085,10041,4276,12953,11143,12905,14567,11111,3287,3563,9633,11162,3044,8437,4382,11250,3932,5587,4175,9708,4970,8388,10673,4301,12475,13494,12519,5632,3898,12472,4381,14085,10041,4276,12953,11143,12905,14567,11111,3287,3563,9633,11162,3044,8437,4382,11250,3932,5587,4175,9708,4970,8388,10673,4301,12475,13494,12519,5632,3898,12472,4381,14085,10041,4276,12953,11143,12905,14567,11111,3287,3563,9633,11162,3044,8437,4382,11250,3932,5587,4175,9708,4970,8388,10673,4301,12475,13494,12519,5632,3898,12472,4381,14085,10041,4276,12953,11143,12905)
avg1<-c(48,132,115,83,84,77,111,102,113,96,136,97,89,97,66,18,123,29,37,118,66,87,52,11,97,25,144,21,40,6,36,48,132,115,83,84,77,111,102,113,96,136,97,89,97,66,18,123,29,37,118,66,87,52,11,97,25,144,21,40,6,36,48,132,115,83,84,77,111,102,113,96,136,97,89,97,66,18,123,29,37,118,66,87,52,11,97,25,144,21,40,6,36,48,132,115,83,84,77,111,102,113,96,136,97,89,97,66,18,123,29,37,118,66,87,52,11,97,25,144,21,40,6,36)
avg2<-c(6775,3142,3916,12828,9889,4025,11374,10594,4263,8871,11229,4787,7478,5316,5299,14068,3981,12993,12435,13845,4320,7472,14285,10221,11883,7783,13980,11426,13120,8632,14540,6775,3142,3916,12828,9889,4025,11374,10594,4263,8871,11229,4787,7478,5316,5299,14068,3981,12993,12435,13845,4320,7472,14285,10221,11883,7783,13980,11426,13120,8632,14540,6775,3142,3916,12828,9889,4025,11374,10594,4263,8871,11229,4787,7478,5316,5299,14068,3981,12993,12435,13845,4320,7472,14285,10221,11883,7783,13980,11426,13120,8632,14540,6775,3142,3916,12828,9889,4025,11374,10594,4263,8871,11229,4787,7478,5316,5299,14068,3981,12993,12435,13845,4320,7472,14285,10221,11883,7783,13980,11426,13120,8632,14540)
dat<-data.frame(cate,Sub_Product,Main_Product,Product,sum1,sum2,avg1,avg2)
all_products<-c("Furniture","drinks","groceries","dairy","technology")
ACClist<-c("sum1","sum2")
AVGlist<-c("avg1","avg2")
library (shinyjs)
library (tidyr)
library (data.table)
library (highcharter)
library (dplyr)
library (shinydashboard)
library (shiny)
library (shinyWidgets)
header <-dashboardHeader()
body <- dashboardBody(fluidRow(
column(width = 12,
radioGroupButtons(
inputId = "l1PAD", label = NULL,size = "lg",
choices = all_products, justified = TRUE,
individual = TRUE)
)),
fluidRow(
highchartOutput("accuPA",height = "300px"),
highchartOutput("avgPA",height = "300px")
))
sidebar <- dashboardSidebar(collapsed = T,
radioGroupButtons(
"accuselectPA","sum",choices=ACClist,
direction = "vertical",width = "100%",justified = TRUE
),
br(),
radioGroupButtons(
"avgselectPA","Average ",choices=AVGlist,
direction = "vertical",width = "100%",justified = TRUE
))
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
observe({
print(input$l1PAD)
datz<-reactive({
dat%>%filter(cate==input$l1PAD)
})
print(datz())
str(datz())
output$accuPA <- renderHighchart({
summarized <- datz() %>%
group_by(Main_Product) %>%
summarize(Quantity = sum(!!sym(input$accuselectPA)))
summarized <- arrange(summarized, desc(Quantity))
tibbled <- tibble(name = summarized$Main_Product, y = summarized$Quantity)
drilldownHandler <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.drilldown);}")
installDrilldownReceiver <- JS("function() {
var chart = this;
Shiny.addCustomMessageHandler('drilldown', function(message) {
var point = chart.get(message.point)
chart.addSeriesAsDrilldown(point, message.series);
});
}")
highchart() %>%
hc_chart(events = list(load = installDrilldownReceiver, drilldown = drilldownHandler)) %>%
hc_xAxis(type = "category") %>%
hc_add_series(tibbled, "column", hcaes(x = name, y = y, drilldown = name, id = name), color = "#e6b30a") %>%
hc_plotOptions(column = list(stacking = "normal")) %>%
hc_drilldown(allowPointDrilldown = TRUE)
})
observeEvent(input$ClickedInput, {
levels <- strsplit(input$ClickedInput, "_", fixed = TRUE)[[1]]
resemblences <- c("Main_Product", "Product", "Sub_Product")
dataSubSet <- datz()
for (i in 1:length(levels)) {
dataSubSet <- datz()[datz()[[resemblences[i]]] == levels[i],]}
print(dataSubSet)
str(dataSubSet)
normalized <- data.frame(category = dataSubSet[[resemblences[length(levels) + 1]]],amount= dataSubSet[, input$accuselectPA])
print(normalized)
str(normalized)
summarized <- normalized %>%group_by(category) %>% summarize(Quantity = sum(amount))
summarized <- arrange(summarized, desc(Quantity))
tibbled <- tibble(name = summarized$category, y = summarized$Quantity)
nextLevelCodes = lapply(tibbled$name, function(fac) {paste(c(levels, as.character(fac)), collapse = "_")
}) %>% unlist
tibbled$id = nextLevelCodes
if (length(levels) < length(resemblences) - 1) {
tibbled$drilldown = nextLevelCodes
}
session$sendCustomMessage("drilldown", list(
series = list(type = "column",name = paste(levels, sep = "_"),data = list_parse(tibbled)
),
point = input$ClickedInput
))
})
output$trial <- renderText({input$ClickedInput})
})
observe({
print(input$l1PAD)
datz2<-reactive({
dat%>%filter(cate==input$l1PAD)
})
print(datz2())
str(datz2())
output$avgPA <- renderHighchart({
summarized2 <- datz2() %>%
group_by(Main_Product) %>%
summarize(Quantity2 = mean(!!sym(input$avgselectPA)))
summarized2 <- arrange(summarized2, desc(Quantity2))
tibbled2 <- tibble(name = summarized2$Main_Product, y = summarized2$Quantity2)
drilldownHandler2 <- JS("function(event) {Shiny.onInputChange('ClickedInput2', event.point.drilldown);}")
installDrilldownReceiver2 <- JS("function() {
var chart = this;
Shiny.addCustomMessageHandler('drilldown', function(message) {
var point = chart.get(message.point)
chart.addSeriesAsDrilldown(point, message.series);
});
}")
highchart() %>%
hc_chart(events = list(load = installDrilldownReceiver2, drilldown = drilldownHandler2)) %>%
hc_xAxis(type = "category") %>%
hc_add_series(tibbled2, "column", hcaes(x = name, y = y, drilldown = name, id = name), color = "#e6b30a") %>%
hc_plotOptions(column = list(stacking = "normal")) %>%
hc_drilldown(allowPointDrilldown = TRUE)
})
observeEvent(input$ClickedInput2, {
levels2 <- strsplit(input$ClickedInput2, "_", fixed = TRUE)[[1]]
resemblences2 <- c("Main_Product", "Product", "Sub_Product")
dataSubSet2 <- datz2()
for (i in 1:length(levels2)) {
dataSubSet2 <- datz2()[datz2()[[resemblences2[i]]] == levels2[i],]}
print(dataSubSet2)
str(dataSubSet2)
normalized2 <- data.frame(category = dataSubSet2[[resemblences2[length(levels2) + 1]]],amount= dataSubSet2[, input$avgselectPA])
print(normalized2)
str(normalized2)
summarized2 <- normalized2 %>%group_by(category) %>% summarize(Quantity2 = mean(amount))
summarized2 <- arrange(summarized2, desc(Quantity2))
tibbled2 <- tibble(name = summarized2$category, y = summarized2$Quantity2)
nextLevelCodes2 = lapply(tibbled2$name, function(fac) {paste(c(levels2, as.character(fac)), collapse = "_")
}) %>% unlist
tibbled2$id = nextLevelCodes2
if (length(levels2) < length(resemblences2) - 1) {
tibbled2$drilldown = nextLevelCodes2
}
session$sendCustomMessage("drilldown", list(
series = list(type = "column",name = paste(levels2, sep = "_"),data = list_parse(tibbled2)
),
point = input$ClickedInput2
))
})
output$trial <- renderText({input$ClickedInput2})
})
}
shinyApp(ui, server)
只需复制并粘贴上面的代码，然后尝试在第一个图表中向下钻取，查看它不会响应的总计数的细目，而图表2将响应单击图表一列
每列上的悬停文本显示两个图表之间的差异 因为第一个显示总和，而第二个显示平均值。数据框可能很长，但它是我的数据集的示例
小请求，我只需要两个地块上的第三层就是折线图
更新另一个未成功的试用-
cate<-c("Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","drinks","drinks","groceries","groceries","groceries","dairy","dairy","dairy","dairy","groceries","technology","technology","technology","technology","technology","technology","technology","technology","groceries","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","drinks","drinks","groceries","groceries","groceries","dairy","dairy","dairy","dairy","groceries","technology","technology","technology","technology","technology","technology","technology","technology","groceries","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","drinks","drinks","groceries","groceries","groceries","dairy","dairy","dairy","dairy","groceries","technology","technology","technology","technology","technology","technology","technology","technology","groceries","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","drinks","drinks","groceries","groceries","groceries","dairy","dairy","dairy","dairy","groceries","technology","technology","technology","technology","technology","technology","technology","technology","groceries")
Sub_Product<-c("nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug")
Main_Product<-c("outdoor","indoor","outdoor","indoor","indoor","outdoor","indoor","indoor","indoor","indoor","outdoor","outdoor","n&o","n&o","indoor","indoor","indoor","indoor","outdoor","indoor","outdoor","outdoor","outdoor","indoor","outdoor","indoor","outdoor","outdoor","indoor","outdoor","n&o","outdoor","indoor","outdoor","indoor","indoor","outdoor","indoor","indoor","indoor","indoor","outdoor","outdoor","n&o","n&o","indoor","indoor","indoor","indoor","outdoor","indoor","outdoor","outdoor","outdoor","indoor","outdoor","indoor","outdoor","outdoor","indoor","outdoor","n&o","outdoor","indoor","outdoor","indoor","indoor","outdoor","indoor ","indoor ","indoor ","indoor ","outdoor","outdoor","n&o","n&o","indoor","indoor","indoor","indoor","outdoor","indoor","outdoor","outdoor","outdoor","indoor","outdoor","indoor","outdoor","outdoor","indoor","outdoor","n&o","outdoor","indoor","outdoor","indoor","indoor","outdoor","indoor ","indoor ","indoor ","indoor ","outdoor","outdoor","n&o","n&o","indoor","indoor","indoor","indoor","outdoor","indoor","outdoor","outdoor","outdoor","indoor","outdoor","indoor","outdoor","outdoor","indoor","outdoor","n&o")
Product<-c("abc","def","ghh","hig","lmn","opk","cba","dfw","ewr","csad","wer","casd","were","csad","rt","hgf","qeq","hgf","qer","qer2","erqerq","qdq","dwqer","qerqe","erqererq","e2342","ererq","qewrw","qrerqr","qreqw","qerqe","abc","def","ghh","hig","lmn","opk","cba","dfw","ewr","csad","wer","casd","were","csad","rt","hgf","qeq","hgf","qer","qer2","erqerq","qdq","dwqer","qerqe","erqererq","e2342","ererq","qewrw","qrerqr","qreqw","qerqe","abc","def","ghh","hig","lmn","opk","cba","dfw","ewr","csad","wer","casd","were","csad","rt","hgf","qeq","hgf","qer","qer2","erqerq","qdq","dwqer","qerqe","erqererq","e2342","ererq","qewrw","qrerqr","qreqw","qerqe","abc","def","ghh","hig","lmn","opk","cba","dfw","ewr","csad","wer","casd","were","csad","rt","hgf","qeq","hgf","qer","qer2","erqerq","qdq","dwqer","qerqe","erqererq","e2342","ererq","qewrw","qrerqr","qreqw","qerqe")
sum1<-c(43,90,135,125,87,4,23,120,4,127,70,68,129,63,131,90,67,110,90,119,81,68,15,29,49,11,76,82,65,83,25,43,90,135,125,87,4,23,120,4,127,70,68,129,63,131,90,67,110,90,119,81,68,15,29,49,11,76,82,65,83,25,43,90,135,125,87,4,23,120,4,127,70,68,129,63,131,90,67,110,90,119,81,68,15,29,49,11,76,82,65,83,25,43,90,135,125,87,4,23,120,4,127,70,68,129,63,131,90,67,110,90,119,81,68,15,29,49,11,76,82,65,83,25)
sum2<-c(14567,11111,3287,3563,9633,11162,3044,8437,4382,11250,3932,5587,4175,9708,4970,8388,10673,4301,12475,13494,12519,5632,3898,12472,4381,14085,10041,4276,12953,11143,12905,14567,11111,3287,3563,9633,11162,3044,8437,4382,11250,3932,5587,4175,9708,4970,8388,10673,4301,12475,13494,12519,5632,3898,12472,4381,14085,10041,4276,12953,11143,12905,14567,11111,3287,3563,9633,11162,3044,8437,4382,11250,3932,5587,4175,9708,4970,8388,10673,4301,12475,13494,12519,5632,3898,12472,4381,14085,10041,4276,12953,11143,12905,14567,11111,3287,3563,9633,11162,3044,8437,4382,11250,3932,5587,4175,9708,4970,8388,10673,4301,12475,13494,12519,5632,3898,12472,4381,14085,10041,4276,12953,11143,12905)
avg1<-c(48,132,115,83,84,77,111,102,113,96,136,97,89,97,66,18,123,29,37,118,66,87,52,11,97,25,144,21,40,6,36,48,132,115,83,84,77,111,102,113,96,136,97,89,97,66,18,123,29,37,118,66,87,52,11,97,25,144,21,40,6,36,48,132,115,83,84,77,111,102,113,96,136,97,89,97,66,18,123,29,37,118,66,87,52,11,97,25,144,21,40,6,36,48,132,115,83,84,77,111,102,113,96,136,97,89,97,66,18,123,29,37,118,66,87,52,11,97,25,144,21,40,6,36)
avg2<-c(6775,3142,3916,12828,9889,4025,11374,10594,4263,8871,11229,4787,7478,5316,5299,14068,3981,12993,12435,13845,4320,7472,14285,10221,11883,7783,13980,11426,13120,8632,14540,6775,3142,3916,12828,9889,4025,11374,10594,4263,8871,11229,4787,7478,5316,5299,14068,3981,12993,12435,13845,4320,7472,14285,10221,11883,7783,13980,11426,13120,8632,14540,6775,3142,3916,12828,9889,4025,11374,10594,4263,8871,11229,4787,7478,5316,5299,14068,3981,12993,12435,13845,4320,7472,14285,10221,11883,7783,13980,11426,13120,8632,14540,6775,3142,3916,12828,9889,4025,11374,10594,4263,8871,11229,4787,7478,5316,5299,14068,3981,12993,12435,13845,4320,7472,14285,10221,11883,7783,13980,11426,13120,8632,14540)
dat<-data.frame(cate,Sub_Product,Main_Product,Product,sum1,sum2,avg1,avg2)
all_products<-c("Furniture","drinks","groceries","dairy","technology")
ACClist<-c("sum1","sum2")
AVGlist<-c("avg1","avg2")
library (shinyjs)
library (tidyr)
library (data.table)
library (highcharter)
library (dplyr)
library (shinydashboard)
library (shiny)
library (shinyWidgets)
header <-dashboardHeader()
body <- dashboardBody(fluidRow(
column(width = 12,
radioGroupButtons(
inputId = "l1PAD", label = NULL,size = "lg",
choices = all_products, justified = TRUE,
individual = TRUE)
)),
fluidRow(
highchartOutput("accuPA",height = "300px"),
highchartOutput("avgPA",height = "300px")
))
sidebar <- dashboardSidebar(collapsed = T,
radioGroupButtons(
"accuselectPA","sum",choices=ACClist,
direction = "vertical",width = "100%",justified = TRUE
),
br(),
radioGroupButtons(
"avgselectPA","Average ",choices=AVGlist,
direction = "vertical",width = "100%",justified = TRUE
))
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
observe({
print(input$l1PAD)
datz<-reactive({
dat%>%filter(cate==input$l1PAD)
})
TYT<-reactive({
datz()%>%select(1:4)
})
nont<-reactive({
datz()%>%pull(input$avgselectPA)
})
print(datz())
str(datz())
print(nont())
str(nont())
urt<-reactive({
data_frame(TYT(),nont())
})
print(urt())
str(urt())
output$accuPA <- renderHighchart({
summarized <- datz() %>%
group_by(Main_Product) %>%
summarize(Quantity = sum(!!sym(input$accuselectPA)))
summarized <- arrange(summarized, desc(Quantity))
tibbled <- tibble(name = summarized$Main_Product, y = summarized$Quantity)
drilldownHandler <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.drilldown);}")
installDrilldownReceiver <- JS("function() {
var chart = this;
Shiny.addCustomMessageHandler('drilldown', function(message) {
var point = chart.get(message.point)
chart.addSeriesAsDrilldown(point, message.series);
});
}")
highchart() %>%
hc_chart(events = list(load = installDrilldownReceiver, drilldown = drilldownHandler)) %>%
hc_xAxis(type = "category") %>%
hc_add_series(tibbled, "column", hcaes(x = name, y = y, drilldown = name, id = name), color = "#e6b30a") %>%
hc_plotOptions(column = list(stacking = "normal")) %>%
hc_drilldown(allowPointDrilldown = TRUE)
})
observeEvent(input$ClickedInput, {
levels <- strsplit(input$ClickedInput, "_", fixed = TRUE)[[1]]
resemblences <- c("Main_Product", "Product", "Sub_Product")
dataSubSet <- datz()
for (i in 1:length(levels)) {
dataSubSet <- datz()[datz()[[resemblences[i]]] == levels[i],]}
print(dataSubSet)
str(dataSubSet)
normalized <- data.frame(category = dataSubSet[[resemblences[length(levels) + 1]]],amount= dataSubSet[, input$accuselectPA])
print(normalized)
str(normalized)
summarized <- normalized %>%group_by(category) %>% summarize(Quantity = sum(amount))
summarized <- arrange(summarized, desc(Quantity))
tibbled <- tibble(name = summarized$category, y = summarized$Quantity)
nextLevelCodes = lapply(tibbled$name, function(fac) {paste(c(levels, as.character(fac)), collapse = "_")
}) %>% unlist
tibbled$id = nextLevelCodes
if (length(levels) < length(resemblences) - 1) {
tibbled$drilldown = nextLevelCodes}
session$sendCustomMessage("drilldown", list(
series = list(type = "column",name = paste(levels, sep = "_"),data = list_parse(tibbled)
),
point = input$ClickedInput
))
})
output$avgPA<-renderHighchart({
datSum <- urt() %>%
group_by(Main_Product) %>%
summarize(Quantity = mean('nont')
)
datSum <- arrange(datSum,desc(Quantity))
Lvl1dfStatus <- tibble(name = datSum$Main_Product, 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(urt()$Main_Product), function(x_level) {
# x_level is what you called 'input' earlier.
datSum2 <- urt()[urt()$Main_Product == x_level,]
datSum2 <- datSum2 %>%
group_by(Product) %>%
summarize(Quantity = mean('nont')
)
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$Product,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(urt()$Main_Product), function(x_level) {
datSum2 <- urt()[urt()$Main_Product == x_level,]
lapply(unique(datSum2$Product), function(y_level) {
datSum3 <- datSum2[datSum2$Product == y_level,]
datSum3 <- datSum3 %>%
group_by(Sub_Product) %>%
summarize(Quantity = mean('nont')
)
datSum3 <- arrange(datSum3,desc(Quantity))
Lvl3dfStatus <- tibble(name = datSum3$Sub_Product,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 = Product), color = "#E4551F") %>%
hc_plotOptions(column = list(stacking = "normal")) %>%
hc_drilldown(
allowPointDrilldown = TRUE,
series = c(Level_2_Drilldowns, Level_3_Drilldowns)
)
})
#THE NEXT }) is for observe
})
}
shinyApp(ui, server)
推荐答案
在这里，这两个图表独立于彼此的下钻操作。
我简化了您的代码，并且您有许多不需要的observes和reactives(至少在本例中)。
cate<-c("Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","drinks","drinks","groceries","groceries","groceries","dairy","dairy","dairy","dairy","groceries","technology","technology","technology","technology","technology","technology","technology","technology","groceries","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","drinks","drinks","groceries","groceries","groceries","dairy","dairy","dairy","dairy","groceries","technology","technology","technology","technology","technology","technology","technology","technology","groceries","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","drinks","drinks","groceries","groceries","groceries","dairy","dairy","dairy","dairy","groceries","technology","technology","technology","technology","technology","technology","technology","technology","groceries","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","drinks","drinks","groceries","groceries","groceries","dairy","dairy","dairy","dairy","groceries","technology","technology","technology","technology","technology","technology","technology","technology","groceries")
Sub_Product<-c("nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug")
Main_Product<-c("outdoor","indoor","outdoor","indoor","indoor","outdoor","indoor","indoor","indoor","indoor","outdoor","outdoor","n&o","n&o","indoor","indoor","indoor","indoor","outdoor","indoor","outdoor","outdoor","outdoor","indoor","outdoor","indoor","outdoor","outdoor","indoor","outdoor","n&o","outdoor","indoor","outdoor","indoor","indoor","outdoor","indoor","indoor","indoor","indoor","outdoor","outdoor","n&o","n&o","indoor","indoor","indoor","indoor","outdoor","indoor","outdoor","outdoor","outdoor","indoor","outdoor","indoor","outdoor","outdoor","indoor","outdoor","n&o","outdoor","indoor","outdoor","indoor","indoor","outdoor","indoor","indoor","indoor","indoor","outdoor","outdoor","n&o","n&o","indoor","indoor","indoor","indoor","outdoor","indoor","outdoor","outdoor","outdoor","indoor","outdoor","indoor","outdoor","outdoor","indoor","outdoor","n&o","outdoor","indoor","outdoor","indoor","indoor","outdoor","indoor","indoor","indoor","indoor","outdoor","outdoor","n&o","n&o","indoor","indoor","indoor","indoor","outdoor","indoor","outdoor","outdoor","outdoor","indoor","outdoor","indoor","outdoor","outdoor","indoor","outdoor","n&o")
Product<-c("abc","def","ghh","hig","lmn","opk","cba","dfw","ewr","csad","wer","casd","were","csad","rt","hgf","qeq","hgf","qer","qer2","erqerq","qdq","dwqer","qerqe","erqererq","e2342","ererq","qewrw","qrerqr","qreqw","qerqe","abc","def","ghh","hig","lmn","opk","cba","dfw","ewr","csad","wer","casd","were","csad","rt","hgf","qeq","hgf","qer","qer2","erqerq","qdq","dwqer","qerqe","erqererq","e2342","ererq","qewrw","qrerqr","qreqw","qerqe","abc","def","ghh","hig","lmn","opk","cba","dfw","ewr","csad","wer","casd","were","csad","rt","hgf","qeq","hgf","qer","qer2","erqerq","qdq","dwqer","qerqe","erqererq","e2342","ererq","qewrw","qrerqr","qreqw","qerqe","abc","def","ghh","hig","lmn","opk","cba","dfw","ewr","csad","wer","casd","were","csad","rt","hgf","qeq","hgf","qer","qer2","erqerq","qdq","dwqer","qerqe","erqererq","e2342","ererq","qewrw","qrerqr","qreqw","qerqe")
sum1<-c(43,90,135,125,87,4,23,120,4,127,70,68,129,63,131,90,67,110,90,119,81,68,15,29,49,11,76,82,65,83,25,43,90,135,125,87,4,23,120,4,127,70,68,129,63,131,90,67,110,90,119,81,68,15,29,49,11,76,82,65,83,25,43,90,135,125,87,4,23,120,4,127,70,68,129,63,131,90,67,110,90,119,81,68,15,29,49,11,76,82,65,83,25,43,90,135,125,87,4,23,120,4,127,70,68,129,63,131,90,67,110,90,119,81,68,15,29,49,11,76,82,65,83,25)
sum2<-c(14567,11111,3287,3563,9633,11162,3044,8437,4382,11250,3932,5587,4175,9708,4970,8388,10673,4301,12475,13494,12519,5632,3898,12472,4381,14085,10041,4276,12953,11143,12905,14567,11111,3287,3563,9633,11162,3044,8437,4382,11250,3932,5587,4175,9708,4970,8388,10673,4301,12475,13494,12519,5632,3898,12472,4381,14085,10041,4276,12953,11143,12905,14567,11111,3287,3563,9633,11162,3044,8437,4382,11250,3932,5587,4175,9708,4970,8388,10673,4301,12475,13494,12519,5632,3898,12472,4381,14085,10041,4276,12953,11143,12905,14567,11111,3287,3563,9633,11162,3044,8437,4382,11250,3932,5587,4175,9708,4970,8388,10673,4301,12475,13494,12519,5632,3898,12472,4381,14085,10041,4276,12953,11143,12905)
avg1<-c(48,132,115,83,84,77,111,102,113,96,136,97,89,97,66,18,123,29,37,118,66,87,52,11,97,25,144,21,40,6,36,48,132,115,83,84,77,111,102,113,96,136,97,89,97,66,18,123,29,37,118,66,87,52,11,97,25,144,21,40,6,36,48,132,115,83,84,77,111,102,113,96,136,97,89,97,66,18,123,29,37,118,66,87,52,11,97,25,144,21,40,6,36,48,132,115,83,84,77,111,102,113,96,136,97,89,97,66,18,123,29,37,118,66,87,52,11,97,25,144,21,40,6,36)
avg2<-c(6775,3142,3916,12828,9889,4025,11374,10594,4263,8871,11229,4787,7478,5316,5299,14068,3981,12993,12435,13845,4320,7472,14285,10221,11883,7783,13980,11426,13120,8632,14540,6775,3142,3916,12828,9889,4025,11374,10594,4263,8871,11229,4787,7478,5316,5299,14068,3981,12993,12435,13845,4320,7472,14285,10221,11883,7783,13980,11426,13120,8632,14540,6775,3142,3916,12828,9889,4025,11374,10594,4263,8871,11229,4787,7478,5316,5299,14068,3981,12993,12435,13845,4320,7472,14285,10221,11883,7783,13980,11426,13120,8632,14540,6775,3142,3916,12828,9889,4025,11374,10594,4263,8871,11229,4787,7478,5316,5299,14068,3981,12993,12435,13845,4320,7472,14285,10221,11883,7783,13980,11426,13120,8632,14540)
dat<-data.frame(cate,Sub_Product,Main_Product,Product,sum1,sum2,avg1,avg2, stringsAsFactors = FALSE)
ACClist<-c("sum1","sum2")
AVGlist<-c("avg1","avg2")
library (shinyjs)
library (tidyr)
library (data.table)
library (highcharter)
library (dplyr)
library (shinydashboard)
library (shiny)
library (shinyWidgets)
header <-dashboardHeader()
body <- dashboardBody(fluidRow(
column(width = 12,
radioGroupButtons(
inputId = "l1PAD", label = NULL,size = "lg",
choices = unique(dat$cate), justified = TRUE,
individual = TRUE)
)),
fluidRow(
box(
title = "Summation of dataset", highchartOutput("accuPA",height = "300px")
),
box(
title = "Mean of dataset", highchartOutput("avgPA",height = "300px")
)
))
sidebar <- dashboardSidebar(collapsed = T,
radioGroupButtons(
"accuselectPA","sum",choices=ACClist,
direction = "vertical",width = "100%",justified = TRUE
),
br(),
radioGroupButtons(
"avgselectPA","Average ",choices=AVGlist,
direction = "vertical",width = "100%",justified = TRUE
))
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
#data set
dat_filtered <- reactive({
dat[dat$cate == input$l1PAD,]
})
#Acc/sum graph
output$accuPA<-renderHighchart({
#LEVEL 1
datSum <- dat_filtered() %>%
group_by(Main_Product) %>%
summarize(Quantity = mean(get(input$accuselectPA)))
datSum <- arrange(datSum,desc(Quantity))
Lvl1dfStatus <- tibble(name = datSum$Main_Product, y = datSum$Quantity, drilldown = tolower(name))
#LEVEL 2
Level_2_Drilldowns <- lapply(unique(dat_filtered()$Main_Product), function(x_level) {
datSum2 <- dat_filtered()[dat_filtered()$Main_Product == x_level,]
datSum2 <- datSum2 %>%
group_by(Product) %>%
summarize(Quantity = mean(get(input$accuselectPA)))
datSum2 <- arrange(datSum2,desc(Quantity))
Lvl2dfStatus <- tibble(name = datSum2$Product,y = datSum2$Quantity, drilldown = tolower(paste(x_level, name, sep = "_")))
list(id = tolower(x_level), type = "column", data = list_parse(Lvl2dfStatus))
})
#LEVEL 3
Level_3_Drilldowns <- lapply(unique(dat_filtered()$Main_Product), function(x_level) {
datSum2 <- dat_filtered()[dat_filtered()$Main_Product == x_level,]
lapply(unique(datSum2$Product), function(y_level) {
datSum3 <- datSum2[datSum2$Product == y_level,]
datSum3 <- datSum3 %>%
group_by(Sub_Product) %>%
summarize(Quantity = mean(get(input$accuselectPA)))
datSum3 <- arrange(datSum3,desc(Quantity))
Lvl3dfStatus <- tibble(name = datSum3$Sub_Product,y = datSum3$Quantity)
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)
)
})
#Avg/Avg graph
output$avgPA<-renderHighchart({
#LEVEL 1
datSum <- dat_filtered() %>%
group_by(Main_Product) %>%
summarize(Quantity = mean(get(input$avgselectPA)))
datSum <- arrange(datSum,desc(Quantity))
Lvl1dfStatus <- tibble(name = datSum$Main_Product, y = datSum$Quantity, drilldown = tolower(name))
#LEVEL 2
Level_2_Drilldowns <- lapply(unique(dat_filtered()$Main_Product), function(x_level) {
datSum2 <- dat_filtered()[dat_filtered()$Main_Product == x_level,]
datSum2 <- datSum2 %>%
group_by(Product) %>%
summarize(Quantity = mean(get(input$avgselectPA)))
datSum2 <- arrange(datSum2,desc(Quantity))
Lvl2dfStatus <- tibble(name = datSum2$Product,y = datSum2$Quantity, drilldown = tolower(paste(x_level, name, sep = "_")))
list(id = tolower(x_level), type = "column", data = list_parse(Lvl2dfStatus))
})
#LEVEL 3
Level_3_Drilldowns <- lapply(unique(dat_filtered()$Main_Product), function(x_level) {
datSum2 <- dat_filtered()[dat_filtered()$Main_Product == x_level,]
lapply(unique(datSum2$Product), function(y_level) {
datSum3 <- datSum2[datSum2$Product == y_level,]
datSum3 <- datSum3 %>%
group_by(Sub_Product) %>%
summarize(Quantity = mean(get(input$avgselectPA)))
datSum3 <- arrange(datSum3,desc(Quantity))
Lvl3dfStatus <- tibble(name = datSum3$Sub_Product,y = datSum3$Quantity)
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)
)
})
}
shinyApp(ui, server)
这篇关于如何使用HighCharge创建两个独立的向下钻取图？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
