how to create two independent drill down plot using Highcharter? - r

I'm working on shiny app that contains two drill down charts, both read from same data file the only difference is the first chart excute summation, while the second one gets averages, the issue is whatever the change I make both charts still conflicting , here is the used code
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)
all needed is just copy and paste the code above and try to drill down in the first chart to see the breakdown of total count it will not respond while chart 2 will respond to the click on chart one column
the hover text on each column shows the difference between two charts
as how the first one show the summation while the second one shows the average value.
the data frame might be long but it is a sample of my dataset
minor request, I need only the 3rd level on both plots to be line chart
update another unsuccessful trial ------------------
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)


Here you go, both graphs operate independently of each other's drilldowns.
I simplified your code as well as you had a lot of observes and reactives that were not needed (in this example at least).
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)

Related

Confused with Shiny Modules and renderUI

I am trying to plot a dygraph in my Shiny App but I can't seem to get the output working. I would like to do it using modules.
Comprar = purchase and Alquiler = Rental.
I randomly create some price data and some dates
Generate some summary statistics for the average price and number of observations in the data comprar_stats and alquiler_stats
I store some metrics in a list that I would like to call throughout the App.
Then in ui_dygraph I try to generate the dropdown module for each option on my data comprar_main, alquiler_main and price_to_rent. I am able to generate a dropdown but not an output of the dygraph...
How I can I obtain the output of the dygraph? - This code is a mix of some Shiny code I took from the Appsilon "Enterprice Shiny" App - I would like to try and modularise my Apps.
Expected Output: Obtain the dygraph outputs depending on the dropdown.
Shiny App:
library(bslib)
library(shiny)
library(tidyverse)
library(dygraphs)
library(zoo)
################################################################################
startDate <- as.Date("2023-01-01")
endDate <- as.Date("2023-06-01")
dates <- rep(dates, each = 10)
propertyPrices <- round(rnorm(length(dates), mean = 100000, sd = 20000), 2)
comprar_main <- data.frame(collectionDate = dates, price = propertyPrices)
propertyRentals <- round(rnorm(length(dates), mean = 1000, sd = 200), 2)
alquiler_main <- data.frame(collectionDate = dates, price = propertyRentals)
################################################################################
################################################################################
comprar_stats = comprar_main %>%
filter(collectionDate > as.Date("2022-09-27")) %>% # accidently have rental data before this date
filter(price < 1000000) %>%
filter(price > 100000) %>%
group_by(collectionDate) %>%
summarise(
mean_price = mean(price),
mean_price = round(mean_price, 0),
propertiesListed = n()
) %>%
ungroup() %>%
mutate(
rolling_average = rollapply(mean_price, fill=NA, width = 14, mean, align = "right"),
rolling_average = round(rolling_average, 0)
) %>%
add_column(
type = "comprar_main"
)
alquiler_stats = alquiler_main %>%
filter(collectionDate > as.Date("2022-09-27")) %>%
filter(price < 2500) %>%
filter(price > 200) %>%
group_by(collectionDate) %>%
summarise(
mean_price = mean(price),
mean_price = round(mean_price, 0),
propertiesListed = n()
) %>%
ungroup() %>%
mutate(
rolling_average = rollapply(mean_price, fill=NA, width = 14, mean, align = "right"),
rolling_average = round(rolling_average, 0)
) %>%
add_column(
type = "alquiler_main"
)
stats = bind_rows(comprar_stats, alquiler_stats)
stats_price_to_rent = full_join(comprar_stats, alquiler_stats, by = "collectionDate") %>%
mutate(
mean_price = mean_price.x / (mean_price.y * 12), # annualise the rent
mean_price = round(mean_price),
rolling_average = rollapply(mean_price, fill=NA, width = 14, mean, align = "right"),
rolling_average = round(rolling_average, 0),
propertiesListed = propertiesListed.y / propertiesListed.x,
propertiesListed = round(propertiesListed, 2)
) %>%
add_column(type = "price_to_rent_main") %>%
select(c(collectionDate, mean_price, propertiesListed, rolling_average, type))
################################################################################
metrics_list <- list(
comprar_main = list(
id = "comprar_main",
title = "Comprar (All Spain)",
currency = "€",
category = "comprar",
legend = "Purchase Spain",
legend2 = "# of properties"
),
alquiler_main = list(
id = "alquiler_main",
title = "Alquiler (All Spain)",
currency = "€",
category = "alquiler",
legend = "Rental Spain",
legend2 = "# of properties"
),
price_to_rent_main = list(
id = "price_to_rent_main",
title = "Price to Rent (All Spain)",
currency = "€",
category = "misc",
legend = "Price To Rent",
legend2 = "# of rentals / # of purchases",
caption = "Some info here"
)
)
################################################################################
################################################################################
########################### User interfaces ####################################
ui_dygraph <- function(id) {
ns <- NS(id)
# Add all available metrics to dygraph chart
choices <- names(metrics_list)
tagList(
tags$div(
class = "panel-header",
selectInput(
ns("metric"), "Select metric for the time chart",
choices,
width = NULL,
selectize = TRUE,
selected = choices[[1]]
)
),
tags$div(
class = "chart-time-container",
dygraphOutput(ns("dygraph"), height = "240px")
)
)
}
################################################################################
ui <- navbarPage(
fluidPage(
theme = bs_theme(bootswatch = "minty"),
title = "hi",
ui_dygraph("dygraph"),
renderUI(output$dygraph)
)
)
server <- function(input, output, session, df) {
metric <- reactive({ metrics_list[[input$metric]] })
output$dygraph <- renderDygraph({
data = df
metric_suffix <- ifelse(!is.null(metric()$currency), glue::glue(" ({metric()$currency})"), "")
metric_legend <- paste0(metric()$legend, metric_suffix)
metric_legend2 <- paste0(metric()$legend2)
if(metric()$id == "comprar_main") {
dyAxisValueRange = c(220000, 310000)
dy2AxisValueRange = c(0, 15000)
} else if (metric()$id == "alquiler_main") {
dyAxisValueRange = c(0, 2700)
dy2AxisValueRange = c(0, 4000)
} else { # price_to_rent_main axis
dyAxisValueRange = c(15, 35)
dy2AxisValueRange = c(0, 3.5)
}
if (metric()$id == "comprar_main") {
data = stats
} else if (metric()$id == "alquiler_main") {
data = stats
} else {
data = stats_price_to_rent
}
data %>%
filter(type == metric()$id) %>%
select(-c(type)) %>%
column_to_rownames("collectionDate") %>%
as.xts() %>%
# as.xts(order.by = .$collectionDate)
dygraph(main = glue::glue("{metric()$title}")) %>%
dySeries("mean_price", label = metric_legend, drawPoints = FALSE, color = "#0099F9") %>%
dySeries("rolling_average", label = "Rolling Average (14 days)", drawPoints = FALSE, color = "#15354A") %>%
dyAxis("y", label = "Price", valueRange = dyAxisValueRange, independentTicks = TRUE,
valueFormatter = 'function(d){return d.toString().replace(/\\B(?=(\\d{3})+(?!\\d))/g, ",");}',
axisLabelFormatter = 'function(d){return d.toString().replace(/\\B(?=(\\d{3})+(?!\\d))/g, ",");}'
) %>%
dyAxis("y2", label = metric_legend2, valueRange = dy2AxisValueRange, independentTicks = TRUE,
valueFormatter = 'function(d){return d.toString().replace(/\\B(?=(\\d{3})+(?!\\d))/g, ",");}',
axisLabelFormatter = 'function(d){return d.toString().replace(/\\B(?=(\\d{3})+(?!\\d))/g, ",");}'
) %>%
dySeries("propertiesListed", label = metric_legend2, stepPlot = TRUE, fillGraph = TRUE, color = "#bdc2c6", axis=('y2')) %>%
dyOptions(
includeZero = FALSE,
axisLineColor = "#585858",
gridLineColor = "#bdc2c6",
axisLabelFontSize = 12,
axisLabelColor = "#585858",
disableZoom = TRUE
)
})
}
shinyApp(ui = ui, server = server)

As mentioned by #YBS in the comments the issue is that your digraph module misses a moduleServer. Moving you code from the main server to a module server will fix your issue:
library(xts)
library(bslib)
library(shiny)
library(tidyverse)
library(dygraphs)
ui_dygraph <- function(id) {
ns <- NS(id)
choices <- names(metrics_list)
tagList(
tags$div(
class = "panel-header",
selectInput(
ns("metric"), "Select metric for the time chart",
choices,
width = NULL,
selectize = TRUE,
selected = choices[[1]]
)
),
tags$div(
class = "chart-time-container",
dygraphOutput(ns("dygraph"), height = "240px")
)
)
}
server_dygraph <- function(id) {
moduleServer(id, function(input, output, session) {
metric <- reactive({
metrics_list[[input$metric]]
})
output$dygraph <- renderDygraph({
data <- df
metric_suffix <- ifelse(!is.null(metric()$currency), glue::glue(" ({metric()$currency})"), "")
metric_legend <- paste0(metric()$legend, metric_suffix)
metric_legend2 <- paste0(metric()$legend2)
if (metric()$id == "comprar_main") {
dyAxisValueRange <- c(220000, 310000)
dy2AxisValueRange <- c(0, 15000)
} else if (metric()$id == "alquiler_main") {
dyAxisValueRange <- c(0, 2700)
dy2AxisValueRange <- c(0, 4000)
} else {
dyAxisValueRange <- c(15, 35)
dy2AxisValueRange <- c(0, 3.5)
}
if (metric()$id == "comprar_main") {
data <- stats
} else if (metric()$id == "alquiler_main") {
data <- stats
} else {
data <- stats_price_to_rent
}
data %>%
filter(type == metric()$id) %>%
select(-c(type)) %>%
column_to_rownames("collectionDate") %>%
as.xts() %>%
dygraph(main = glue::glue("{metric()$title}")) %>%
dySeries("mean_price", label = metric_legend, drawPoints = FALSE, color = "#0099F9") %>%
dySeries("rolling_average", label = "Rolling Average (14 days)", drawPoints = FALSE, color = "#15354A") %>%
dyAxis("y",
label = "Price", valueRange = dyAxisValueRange, independentTicks = TRUE,
valueFormatter = 'function(d){return d.toString().replace(/\\B(?=(\\d{3})+(?!\\d))/g, ",");}',
axisLabelFormatter = 'function(d){return d.toString().replace(/\\B(?=(\\d{3})+(?!\\d))/g, ",");}'
) %>%
dyAxis("y2",
label = metric_legend2, valueRange = dy2AxisValueRange, independentTicks = TRUE,
valueFormatter = 'function(d){return d.toString().replace(/\\B(?=(\\d{3})+(?!\\d))/g, ",");}',
axisLabelFormatter = 'function(d){return d.toString().replace(/\\B(?=(\\d{3})+(?!\\d))/g, ",");}'
) %>%
dySeries("propertiesListed", label = metric_legend2, stepPlot = TRUE, fillGraph = TRUE, color = "#bdc2c6", axis = ("y2")) %>%
dyOptions(
includeZero = FALSE,
axisLineColor = "#585858",
gridLineColor = "#bdc2c6",
axisLabelFontSize = 12,
axisLabelColor = "#585858",
disableZoom = TRUE
)
})
})
}
ui <- navbarPage(
fluidPage(
theme = bs_theme(bootswatch = "minty"),
title = "hi",
ui_dygraph("dygraph")
)
)
server <- function(input, output, session, df) {
server_dygraph("dygraph")
}
shinyApp(ui = ui, server = server)

R shinydashboard + highcharter: arguments are not named in hc_add_series

I'm trying to create a dashboard where a state can be selected and the graph is updated by that selection, but I get this error:
'Warning: Error in : 'df', 'hcaes(x = date, y = injured)' arguments
are not named in hc_add_series [No stack trace available]'
library(tidyverse)
library(shiny)
library(shinydashboard)
library(highcharter)
ui <- dashboardPage(dashboardHeader(title = 'Test Dashboard'),
dashboardSidebar(),
dashboardBody(fluidPage(selectInput('select',
label = 'States',
choices = unique(opts),
selected = 'Alabama'),
box(title = "Stock",
status = "primary",
solidHeader = TRUE,
collapsible = TRUE,
highchartOutput('plot')))))
server <- function(input,
output) {
output$plot <- renderHighchart({
df <- reactive({
df <- massShooting2018.order %>%
filter(state %in% input$select) %>%
group_by(date) %>%
summarise(
dead = sum(dead),
injured = (sum(injured)),
total = sum(total)
)
})
highchart(type = "stock") %>%
hc_chart("line",
name = "base",
hcaes(x = date)
) %>%
hc_add_series(df,
name = "Total",
type = "line",
hcaes(
x = date,
y = total
)
) %>%
hc_add_series(df,
name = "Dead",
type = "line",
hcaes(
x = date,
y = dead
)
) %>%
hc_add_series(df,
name = "Injured",
type = "line",
hcaes(
x = date,
y = injured
)
) %>%
hc_tooltip(
crosshairs = TRUE,
shared = TRUE,
borderWidth = 2,
table = TRUE
)
})
}
shinyApp(ui, server)
DataSource
using the previous dataset:
massShooting2018 <- read.csv('shootings_2018.csv')
massShooting2018.clean <- massShooting2018 %>%
clean_names() %>%
mutate(date = dmy(date))
massShooting2018.order <- massShooting2018.clean %>%
group_by(date, state) %>%
summarise(dead = sum(dead),
injured = sum(injured),
total = sum(total),
description, .groups = 'drop')
opts <- massShooting2018.order %>%
sample_frac(1) %>%
select(state) %>%
arrange(state)
Thank you very much for reading and I hope I can solve this problem.

The call of df after reactive function should be df():
library(tidyverse)
library(shiny)
library(shinydashboard)
library(highcharter)
library(janitor)
library(lubridate)
massShooting2018 <- read.csv('shootings_2018.csv')
massShooting2018.clean <- massShooting2018 %>%
clean_names() %>%
mutate(date = dmy(date))
massShooting2018.order <- massShooting2018.clean %>%
group_by(date, state) %>%
summarise(dead = sum(dead),
injured = sum(injured),
total = sum(total),
description, .groups = 'drop')
opts <- massShooting2018.order %>%
sample_frac(1) %>%
select(state) %>%
arrange(state)
ui <- dashboardPage(dashboardHeader(title = 'Test Dashboard'),
dashboardSidebar(),
dashboardBody(fluidPage(selectInput('select',
label = 'States',
choices = unique(opts),
selected = 'Alabama'),
box(title = "Stock",
status = "primary",
solidHeader = TRUE,
collapsible = TRUE,
highchartOutput('plot')))))
server <- function(input,
output)
{
output$plot <- renderHighchart({
df <- reactive({df <- massShooting2018.order %>%
filter(state %in% input$select) %>%
group_by(date) %>%
summarise(dead = sum(dead),
injured = (sum(injured)),
total = sum(total))})
highchart(type = 'stock') %>%
hc_chart('line',
name = 'base',
hcaes(x = date)) %>%
hc_add_series(df(),
name = 'Total',
type = 'line',
hcaes(x = date,
y = total)) %>%
hc_add_series(df(),
name = 'Dead',
type = 'line',
hcaes(x = date,
y = dead)) %>%
hc_add_series(df(),
name = 'Injured',
type = 'line',
hcaes(x = date,
y = injured)) %>%
hc_tooltip(crosshairs = TRUE,
shared = TRUE,
borderWidth = 2,
table = TRUE)})
}
shinyApp(ui, server)

plotly shiny reactive values "error function not found"

I'm working on a Shiny app in which I want to drill down into a plot with multiple levels. I am having difficulty getting the reactiveValues function to work so I can update the plot. If I set selections <- reactiveVal() I get no errors, but nothing happens when I click on the plot. On the other hand, if I use selections <- reactiveValues() I get the error "Error in selections: could not find function "selection""
Based on reading other posts, it seems like my problem is likely having to do with how exactly I set the update to the variable but I can't quite figure out how to fix it / where the issue is in my code.
Here is a reproducible example:
library(bs4Dash)
library(plotly)
library(tidyverse)
fake_data_wide <- tibble(level_1 = rep(c("A", "B", "C"), each = 50),
level_2 = rep(c(c("1", "2"), c("3", "4"), c("5", "6")), each = 25),
level_3 = c(rep("a", 40), rep("b", 10), rep("c", 30), rep("d", 20),
rep("e", 20), rep("f", 30)),
sent = rnorm(150),
number = rpois(150, lambda = 1))
fake_data_long <- fake_data_wide %>%
pivot_longer(level_1:level_3, names_to = "level_of_specificity",
values_to = "group_name")
one_level_down <- fake_data_wide %>%
select(group_name = level_1,
one_down = level_2) %>%
bind_rows(fake_data_wide %>%
select(group_name = level_2,
one_down = level_3)) %>% distinct()
ui <- dashboardPage(
header = dashboardHeader(title = "test"),
sidebar = dashboardSidebar(),
body = dashboardBody(fluidRow(box(plotlyOutput("drill_down_plot"),
id = "test_box"),
uiOutput("back")))
)
server <- function(input, output){
selections <- reactiveValues()
observeEvent(event_data("plotly_selected", source = "drill_down_plot"), {
new <- event_data("plotly_selected")$customdata[[1]]
old <- selections()
selections(c(old, new))
})
output$drill_down_plot <- renderPlotly({
if(length(selections() == 0)){
fake_data_long %>%
filter(level_of_specificity == "level_1") %>%
group_by(group_name) %>%
summarise(g_sent_mean = mean(sent),
g_total_mean = mean(number)) %>% ungroup() %>%
plot_ly(x = ~g_sent_mean, y = ~g_total_mean,
size = ~g_total_mean, customdata = ~group_name)
} else {
one_level_down %>%
filter(group_name %in% selections_test) %>%
mutate(group_name = one_down) %>% select(-one_down) %>%
inner_join(fake_data_long) %>%
group_by(group_name) %>%
summarise(g_sent_mean = mean(sent),
g_total_mean = mean(number)) %>% ungroup() %>%
plot_ly(x = ~g_sent_mean, y = ~g_total_mean,
size = ~g_total_mean, customdata = ~group_name)
}
})
output$back <- renderUI({
if (length(selections()))
actionButton("clear", "Back", icon("chevron-left"))
})
}
shinyApp(ui = ui, server = server)

The following should help you.
library(bs4Dash)
library(plotly)
library(tidyverse)
fake_data_wide <- tibble(level_1 = rep(c("A", "B", "C"), each = 50),
level_2 = rep(c(c("1", "2"), c("3", "4"), c("5", "6")), each = 25),
level_3 = c(rep("a", 40), rep("b", 10), rep("c", 30), rep("d", 20),
rep("e", 20), rep("f", 30)),
sent = rnorm(150),
number = rpois(150, lambda = 1))
fake_data_long <- fake_data_wide %>%
pivot_longer(level_1:level_3, names_to = "level_of_specificity",
values_to = "group_name")
one_level_down <- fake_data_wide %>%
dplyr::select(group_name = level_1, one_down = level_2) %>%
bind_rows(fake_data_wide %>%
dplyr::select(group_name = level_2, one_down = level_3)) %>% distinct()
ui <- dashboardPage(
header = dashboardHeader(title = "test"),
sidebar = dashboardSidebar(),
body = dashboardBody(fluidRow(box(plotlyOutput("drill_down_plot"),
id = "test_box"),
uiOutput("back")))
)
server <- function(input, output){
my <- reactiveValues(selections=NULL)
observeEvent(event_data("plotly_selected", source = "drill_down_plot", priority = "event"), {
my$selections <- event_data("plotly_selected", priority = "event")$customdata[[1]]
old <- my$selections
#print(my$selections) # c(old, new)
}, ignoreNULL = FALSE)
output$drill_down_plot <- renderPlotly({
select_data <- event_data("plotly_selected", priority = "event")
my$selections <- select_data$customdata
print(select_data)
if (is.null(select_data)) {
print("hello1")
df1 <- fake_data_long %>%
dplyr::filter(level_of_specificity == "level_1") %>%
group_by(group_name) %>%
dplyr::summarise(g_sent_mean = mean(sent),
g_total_mean = mean(number)) %>% ungroup() # %>%
# plot_ly(x = ~g_sent_mean, y = ~g_total_mean,
# size = ~g_total_mean, customdata = ~group_name)
} else {
print("hello2")
df1 <- one_level_down %>%
dplyr::filter(group_name %in% select_data$customdata) %>%
mutate(group_name = one_down) %>% dplyr::select(-one_down) %>%
inner_join(fake_data_long) %>%
group_by(group_name) %>%
dplyr::summarise(g_sent_mean = mean(sent),
g_total_mean = mean(number)) %>% ungroup() #%>%
# plot_ly(x = ~g_sent_mean, y = ~g_total_mean,
# size = ~g_total_mean, customdata = ~group_name)
}
plot_ly(df1, x = ~g_sent_mean, y = ~g_total_mean,
size = ~g_total_mean, customdata = ~group_name) %>% layout(dragmode = "lasso")
})
output$back <- renderUI({
if (!is.null(my$selections)) actionButton("clear", "Back", icon("chevron-left"))
})
}
shinyApp(ui = ui, server = server)

R Shiny, how to use highcharts drilldown in shinyapp depending on selectinput widget result?

I am trying to create a drill down chart using highcharts package, the chart must be dependent on the selectinput results.
The current error is
Error in .getReactiveEnvironment()$currentContext() :
Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)
the expected or desired output is to get dynamic plot depending on the selected value.
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)
b <- c(3,2,5,1,3,5,1,5)
c <- c(4,6,7,7,4,2,1,6)
xxxx <- data.frame(x, y, z, a, b, c, stringsAsFactors = FALSE)
header <- dashboardHeader()
body <- dashboardBody(
selectInput("selectid","Select a Measurement",choices=c("a","b","c"),selected = "a"),
highchartOutput("Working"))
sidebar <- dashboardSidebar()
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
zzz<-reactive({
#browser
select(xxxx,one_of(c("x", "y", "z", input$selectid)))})
output$Working <- renderHighchart({
summarized <- zzz() %>%
group_by(x) %>%
summarize(Quantity = sum(!!sym(input$selectid)))
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);}")
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 = "#E4551F") %>%
hc_plotOptions(column = list(stacking = "normal")) %>%
hc_drilldown(allowPointDrilldown = TRUE)
})
observeEvent(
#browser
input$ClickedInput, {
levels <- strsplit(input$ClickedInput, "_", fixed = TRUE)[[1]]
resemblences <- c("x", "y", "z")
dataSubSet <- reactive({
#browser()
zzz()
})
for (i in 1:length(levels)) {
dataSubSet() <- zzz()[zzz()[[resemblences[i]]] == levels[i],]
}
normalized <- data.frame(category = dataSubSet()[[resemblences[length(levels) + 1]]], amount = input$selectid)
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})
}
shinyApp(ui, server)

R plotly + shiny reactive coupled event - Refresh chart with argument from click on same chart

I've been struggling with this all day, so hopefully somebody can explain a working solution for me/point out the error in my approach.
I have this network I want to visualize.
The goal is to only show the nodes that are directly connected to the reference node.
I want to update this chart when either 1) the reference node in the drop down list is changed or 2) when I click on one of the outlying nodes in the current plot that should be the new reference node.
The first option works, but I can't get 2) to work properly.
In output$selection I have currently commented what I thought should do the job. When I active this however weird looping behaviour happens that I don't understand.
What should I add to get the above described functionality?
Below a reproducible example.
library(plotly)
library(shiny)
library(dplyr)
library(tidyr)
### Selectionlist
varidlist = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'), stringsAsFactors = F)
derivedvaridlist = data.frame(derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)
chartlist = data.frame(charts = paste0('1.1.', 1:9), stringsAsFactors = F)
selectionOptions = c(varidlist$varid, derivedvaridlist$derivedvarid, chartlist$charts)
ui <- fluidPage(
mainPanel(
fixedRow(selectInput('selectedID', label = 'Select varid',
choices = selectionOptions,
selected = 'VAR1')),
fixedRow(plotlyOutput("network"))
),
verbatimTextOutput("selection")
)
server <- function(input, output, session) {
createGraph <- function(selectedID){
varidlist = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'), stringsAsFactors = F)
derivedvaridlist = data.frame(derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)
chartlist = data.frame(charts = paste0('1.1.', 1:9), stringsAsFactors = F)
selectionOptions = c(varidlist$varid, derivedvaridlist$derivedvarid, chartlist$charts)
varid_derivedvarid = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'),
derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)
chart_varidderivedvarid = data.frame(chart = c('1.1.1'),
varidderivedvarid = c('OAP1', 'DERIVEDVAR1', 'DERIVEDVAR2', 'DERIVEDVAR3', 'DERIVEDVAR4'),
stringsAsFactors = F)
# if selectedID is VAR
if(selectedID %in% varidlist$varid){
adjacencyMatrix = varid_derivedvarid %>%
filter(varid == selectedID) %>%
mutate(type = 'derivedvarid') %>%
bind_rows(chart_varidderivedvarid %>%
filter(varidderivedvarid == selectedID) %>%
rename(varid = varidderivedvarid,
derivedvarid = chart) %>%
mutate(type='chart')) %>%
select(derivedvarid, varid, type)
nodeMatrix = adjacencyMatrix %>%
select(derivedvarid, type) %>%
add_row(derivedvarid=selectedID, type='varid')
}
# if selectedID is DERIVEDVAR
if(selectedID %in% derivedvaridlist$derivedvarid){
adjacencyMatrix = varid_derivedvarid %>%
filter(derivedvarid == selectedID) %>%
mutate(type = 'varid') %>%
bind_rows(chart_varidderivedvarid %>%
filter(varidderivedvarid == selectedID) %>%
rename(varid = varidderivedvarid,
derivedvarid = chart) %>%
mutate(type='chart')) %>%
select(derivedvarid, varid, type)
nodeMatrix = adjacencyMatrix %>%
select(varid, type) %>%
add_row(varid=selectedID, type='derivedvarid')
}
# if selectedID is chart
if(selectedID %in% chartlist$charts) {
adjacencyMatrix = chart_varidderivedvarid %>%
filter(chart == selectedID) %>%
mutate(type = '',
type = replace(type, varidderivedvarid %in% varidlist$varid, 'varid'),
type = replace(type, varidderivedvarid %in% derivedvaridlist$derivedvarid, 'derivedvarid')) %>%
select(varidderivedvarid, chart, type)
nodeMatrix = adjacencyMatrix %>%
select(varidderivedvarid, type) %>%
add_row(varidderivedvarid=selectedID, type='chart')
}
# Create all vertices:
nrNodes = dim(adjacencyMatrix)[1]
# Reference node coordinates
x0 = 0
y0 = 0
r = 4
nodes = data.frame(angles = 2*pi / nrNodes * 1:nrNodes,
nodeKey = adjacencyMatrix[, 1]) %>%
mutate(angles = angles + rnorm(n(), mean = 0, sd = .15), # Add noise to angle to avoid overlap in x-coordinate
x = x0 + r * cos(angles),
y = y0 + r * sin(angles)) %>%
add_row(x=x0, y=y0, nodeKey = selectedID)
# Create edges
edges = nodes %>%
select(x, y, nodeKey) %>%
filter(nodeKey != selectedID) %>%
mutate(x0=x0, y0=y0)
edge_shapes <- list()
for(i in 1:dim(edges)[1]) {
edge_shape = list(
type = "line",
line = list(color = "#030303", width = 0.3),
x0 = edges$x0[i],
y0 = edges$y0[i],
x1 = edges$x[i],
y1 = edges$y[i]
)
edge_shapes[[i]] <- edge_shape
}
# Layout for empty background
emptyBackground = list(title = "",
showgrid = FALSE,
showticklabels = FALSE,
zeroline = FALSE)
# Plot plotly
p = plot_ly(nodes, source='networkplot') %>%
add_trace(x = ~x, y = ~y, type = 'scatter',
mode = 'text', text = ~nodeKey,
textposition = 'middle',
hoverinfo='text',
textfont = list(color = '#000000', size = 16)) %>%
layout(title='Network',
showlegend = FALSE,
shapes = edge_shapes,
xaxis = emptyBackground,
yaxis = emptyBackground)
return(p)
}
output$network <- renderPlotly({
selectedID = input$selectedID
createGraph(selectedID)
})
output$selection <- renderPrint({
s <- event_data("plotly_click", source = "networkplot")
if (length(s) == 0) {
"Click on a node to use it as reference node"
} else {
# Get id of clicked node
plotdata = plotly_data(createGraph(input$selectedID))
newvarid = plotdata$nodeKey[s$pointNumber + 1]
# updateSelectInput(session,
# inputId = 'selectedID',
# label = 'Select ID',
# choices = selectionOptions,
# selected = newvarid)
# Get chart coordinates
cat("You selected: \n\n")
# as.list(s)
newvarid
}
})
}
shinyApp(ui, server, options = list(display.mode = "showcase"))

The trick here is to avoid circular reactive events. When using the updateSelectInput function you commented out, you end up in a loop because the updated input triggers the renderPrint function and renderPrint updates the menu.
You can break this behaviour by introducing observe() functions. One way to do this is to stick the updateSelectInput() function into an observeEvent() function that is only triggered if the user clicks on the plot and not if the dropdown menu is used. Any updates coming from input$selectedID are ignored by this function. Please see the full example below. I indicated the part of the code that changed at the bottom.
library(plotly)
library(shiny)
library(dplyr)
library(tidyr)
### Selectionlist
varidlist = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'), stringsAsFactors = F)
derivedvaridlist = data.frame(derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)
chartlist = data.frame(charts = paste0('1.1.', 1:9), stringsAsFactors = F)
selectionOptions = c(varidlist$varid, derivedvaridlist$derivedvarid, chartlist$charts)
ui <- fluidPage(
mainPanel(
fixedRow(selectInput('selectedID', label = 'Select varid',
choices = selectionOptions,
selected = 'VAR1')),
fixedRow(plotlyOutput("network"))
),
verbatimTextOutput("selection")
)
server <- function(input, output, session) {
createGraph <- function(selectedID){
varidlist = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'), stringsAsFactors = F)
derivedvaridlist = data.frame(derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)
chartlist = data.frame(charts = paste0('1.1.', 1:9), stringsAsFactors = F)
selectionOptions = c(varidlist$varid, derivedvaridlist$derivedvarid, chartlist$charts)
varid_derivedvarid = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'),
derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)
chart_varidderivedvarid = data.frame(chart = c('1.1.1'),
varidderivedvarid = c('OAP1', 'DERIVEDVAR1', 'DERIVEDVAR2', 'DERIVEDVAR3', 'DERIVEDVAR4'),
stringsAsFactors = F)
# if selectedID is VAR
if(selectedID %in% varidlist$varid){
adjacencyMatrix = varid_derivedvarid %>%
filter(varid == selectedID) %>%
mutate(type = 'derivedvarid') %>%
bind_rows(chart_varidderivedvarid %>%
filter(varidderivedvarid == selectedID) %>%
rename(varid = varidderivedvarid,
derivedvarid = chart) %>%
mutate(type='chart')) %>%
select(derivedvarid, varid, type)
nodeMatrix = adjacencyMatrix %>%
select(derivedvarid, type) %>%
add_row(derivedvarid=selectedID, type='varid')
}
# if selectedID is DERIVEDVAR
if(selectedID %in% derivedvaridlist$derivedvarid){
adjacencyMatrix = varid_derivedvarid %>%
filter(derivedvarid == selectedID) %>%
mutate(type = 'varid') %>%
bind_rows(chart_varidderivedvarid %>%
filter(varidderivedvarid == selectedID) %>%
rename(varid = varidderivedvarid,
derivedvarid = chart) %>%
mutate(type='chart')) %>%
select(derivedvarid, varid, type)
nodeMatrix = adjacencyMatrix %>%
select(varid, type) %>%
add_row(varid=selectedID, type='derivedvarid')
}
# if selectedID is chart
if(selectedID %in% chartlist$charts) {
adjacencyMatrix = chart_varidderivedvarid %>%
filter(chart == selectedID) %>%
mutate(type = '',
type = replace(type, varidderivedvarid %in% varidlist$varid, 'varid'),
type = replace(type, varidderivedvarid %in% derivedvaridlist$derivedvarid, 'derivedvarid')) %>%
select(varidderivedvarid, chart, type)
nodeMatrix = adjacencyMatrix %>%
select(varidderivedvarid, type) %>%
add_row(varidderivedvarid=selectedID, type='chart')
}
# Create all vertices:
nrNodes = dim(adjacencyMatrix)[1]
# Reference node coordinates
x0 = 0
y0 = 0
r = 4
nodes = data.frame(angles = 2*pi / nrNodes * 1:nrNodes,
nodeKey = adjacencyMatrix[, 1]) %>%
mutate(angles = angles + rnorm(n(), mean = 0, sd = .15), # Add noise to angle to avoid overlap in x-coordinate
x = x0 + r * cos(angles),
y = y0 + r * sin(angles)) %>%
add_row(x=x0, y=y0, nodeKey = selectedID)
# Create edges
edges = nodes %>%
select(x, y, nodeKey) %>%
filter(nodeKey != selectedID) %>%
mutate(x0=x0, y0=y0)
edge_shapes <- list()
for(i in 1:dim(edges)[1]) {
edge_shape = list(
type = "line",
line = list(color = "#030303", width = 0.3),
x0 = edges$x0[i],
y0 = edges$y0[i],
x1 = edges$x[i],
y1 = edges$y[i]
)
edge_shapes[[i]] <- edge_shape
}
# Layout for empty background
emptyBackground = list(title = "",
showgrid = FALSE,
showticklabels = FALSE,
zeroline = FALSE)
# Plot plotly
p = plot_ly(nodes, source='networkplot') %>%
add_trace(x = ~x, y = ~y, type = 'scatter',
mode = 'text', text = ~nodeKey,
textposition = 'middle',
hoverinfo='text',
textfont = list(color = '#000000', size = 16)) %>%
layout(title='Network',
showlegend = FALSE,
shapes = edge_shapes,
xaxis = emptyBackground,
yaxis = emptyBackground)
return(p)
}
###############################################################################################
### Updated part
# Define reactive data
values <- reactiveValues(newvarid = NULL) # ID = "VAR1"
# Observer for change in dropdown menu
# observeEvent(input$selectedID, {
# values$ID = input$selectedID
# })
# Update dropdown menue based on click event
observeEvent(event_data("plotly_click", source = "networkplot"), {
s <- event_data("plotly_click", source = "networkplot")
plotdata = plotly_data(createGraph(input$selectedID))
values$newvarid = plotdata$nodeKey[s$pointNumber + 1]
updateSelectInput(session,
inputId = 'selectedID',
label = 'Select ID',
choices = selectionOptions,
selected = values$newvarid)
})
# Render Plot
output$network <- renderPlotly({
createGraph(input$selectedID)
})
# Render text
output$selection <- renderPrint({
if (is.null(values$newvarid)) {
"Click on a node to use it as reference node"
} else {
# Get chart coordinates
cat("You selected: \n\n")
# as.list(s)
values$newvarid
}
})
}
shinyApp(ui, server, options = list(display.mode = "showcase"))
I am not sure if the reactive values$newvarid is really necessary.

Resources