通过单击非反应性高图创建反应性高图
Create reactive highchart from click on non reactive highchart
我能够根据以下问题 提供的答案从点击事件创建反应式 table，但是我似乎无法弄清楚如何添加反应性高图而不是 table。下面的代码演示了如何制作 table.
library (shiny)
library (shinydashboard)
library (dplyr)
library (tibble)
library (highcharter)
library(shinyjs)
library (DT)
rm(list=ls())
header <- dashboardHeader()
sidebar <- dashboardSidebar()
body <- dashboardBody(
fluidRow(
box(
tags$head(tags$style(HTML("#OnTime{height:20vh !important;} "))),
title = "On Time", status = "primary", solidHeader = TRUE, width = 6,
highchartOutput("OnTime")
)
),
fluidRow(
box(
title = "WIP Table", status = "primary", solidHeader = TRUE,
DT::dataTableOutput("Table")
###I know i need to replace this with a highchartOutput
)
),
fluidRow(
box(
textOutput("text")
)
)
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output) {
Customer <- c("England", "France", "US", "Canada", "England", "France", "US", "Canada", "England")
OnTime <- c("On Time", "On Time", "Overdue", "On Time", "Overdue", "On Time", "Overdue","On Time", "On Time")
Gate <- c(1,2,3,2,3,2,1,2,3)
Quantity <- c(1,1,1,1,1,1,1,1,1)
data <- data.frame(Customer,OnTime,Gate, Quantity)
output$OnTime <- renderHighchart({
Lvl1GroupingStatus <- aggregate(data$Quantity, by = list(data$OnTime),FUN=sum)
Lvl1dfStatus <- data_frame(name = Lvl1GroupingStatus$Group.1,y = Lvl1GroupingStatus$x,drilldown = tolower(name))
Lvl2WIPOverDue <- data[data$OnTime == "Overdue",]
Lvl2WIPOverDueb <- aggregate(Lvl2WIPOverDue$Quantity, by = list(Lvl2WIPOverDue$Customer),FUN=sum)
Lvl2dfWIPOverDue <- arrange(data_frame(name = Lvl2WIPOverDueb$Group.1,value = Lvl2WIPOverDueb$x),desc(value))
Lvl2WIPOnTime <- data[data$OnTime == "On Time",]
Lvl2WIPOnTimeb <- aggregate(Lvl2WIPOnTime$Quantity, by = list(Lvl2WIPOnTime$Customer),FUN=sum)
Lvl2dfWIPOnTime <- arrange(data_frame(name = Lvl2WIPOnTimeb$Group.1,value = Lvl2WIPOnTimeb$x),desc(value))
ClickFunction <- JS("function(event) {Shiny.onInputChange('Clicked', event.point.name);}")
highchart() %>%
hc_chart(type = "column") %>%
hc_xAxis(type = "category") %>%
hc_legend(enabled = FALSE) %>%
hc_yAxis(gridLineWidth = 0) %>%
hc_plotOptions(series = list(column = list(stacking = "normal"),
borderWidth=0,
dataLabels = list(enabled = TRUE),
events = list(click = ClickFunction)
)
) %>%
hc_add_series(data=Lvl1dfStatus,name="Status", colorByPoint = TRUE,colors = c("#003395","#D20000")) %>%
hc_drilldown(
allowPointDrilldown = TRUE,
series = list(
list(id = "overdue", data = list_parse2(Lvl2dfWIPOverDue), name="Customer"),
list(id = "on time", data = list_parse2(Lvl2dfWIPOnTime), name="Customer")
)
)
})
makeReactiveBinding("outputText")
observeEvent(input$Clicked, {
outputText <<- paste0(input$Clicked)
})
output$text <- renderText({
outputText
})
###Can I use this same filtering format with highchart instead of DT?
output$Table <- DT::renderDataTable({
temp <- data
rowcheck <- temp[temp$OnTime == input$Clicked,]
if (nrow(rowcheck)!=0) {
temp <- temp[temp$OnTime == input$Clicked,]
Lvl1Click <<- input$Clicked
}
else {
temp <- temp[temp$OnTime == Lvl1Click,]
temp <- temp[temp$Customer == input$Clicked,]
}
return (temp)
})
}
#Combines Dasboard and Data together
shinyApp(ui, server)
谢谢！
下面的代码是我遇到问题的地方。假设我更新了正文以显示第二个高位图与 table.
output$chart2<- renderhighchart({
temp <- data
rowcheck <- temp[temp$RESERVOIR == input$Clicked,]
if (nrow(rowcheck)!=0) {
temp <- temp[temp$RESERVOIR == input$Clicked,]
Lvl1Click <<- input$Clicked
}
else {
temp <- temp[temp$RESERVOIR == Lvl1Click,]
temp <- temp[temp$RESERVOIR == input$Clicked,]
}
return (temp)
hchart(**temp**, "scatter", hcaes(x = Customer, y = Quantity))
这不起作用。我不确定 where/how 在 hchart 中包含临时数据集。
这是改成highchartoutput和renderHighchart后的后续
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output) {
Customer <- c("England", "France", "US", "Canada", "England", "France", "US", "Canada", "England")
OnTime <- c("On Time", "On Time", "Overdue", "On Time", "Overdue", "On Time", "Overdue","On Time", "On Time")
Gate <- c(1,2,3,2,3,2,1,2,3)
Quantity <- c(1,1,1,1,1,1,1,1,1)
data <- data.frame(Customer,OnTime,Gate, Quantity)
output$OnTime <- renderHighchart({
Lvl1GroupingStatus <- aggregate(data$Quantity, by = list(data$OnTime),FUN=sum)
Lvl1dfStatus <- data_frame(name = Lvl1GroupingStatus$Group.1,y = Lvl1GroupingStatus$x,drilldown = tolower(name))
Lvl2WIPOverDue <- data[data$OnTime == "Overdue",]
Lvl2WIPOverDueb <- aggregate(Lvl2WIPOverDue$Quantity, by = list(Lvl2WIPOverDue$Customer),FUN=sum)
Lvl2dfWIPOverDue <- arrange(data_frame(name = Lvl2WIPOverDueb$Group.1,value = Lvl2WIPOverDueb$x),desc(value))
Lvl2WIPOnTime <- data[data$OnTime == "On Time",]
Lvl2WIPOnTimeb <- aggregate(Lvl2WIPOnTime$Quantity, by = list(Lvl2WIPOnTime$Customer),FUN=sum)
Lvl2dfWIPOnTime <- arrange(data_frame(name = Lvl2WIPOnTimeb$Group.1,value = Lvl2WIPOnTimeb$x),desc(value))
ClickFunction <- JS("function(event) {Shiny.onInputChange('Clicked', event.point.name);}")
highchart() %>%
hc_chart(type = "column") %>%
hc_xAxis(type = "category") %>%
hc_legend(enabled = FALSE) %>%
hc_yAxis(gridLineWidth = 0) %>%
hc_plotOptions(series = list(column = list(stacking = "normal"),
borderWidth=0,
dataLabels = list(enabled = TRUE),
events = list(click = ClickFunction)
)
) %>%
hc_add_series(data=Lvl1dfStatus,name="Status", colorByPoint = TRUE,colors = c("#003395","#D20000")) %>%
hc_drilldown(
allowPointDrilldown = TRUE,
series = list(
list(id = "overdue", data = list_parse2(Lvl2dfWIPOverDue), name="Customer"),
list(id = "on time", data = list_parse2(Lvl2dfWIPOnTime), name="Customer")
)
)
})
makeReactiveBinding("outputText")
observeEvent(input$Clicked, {
outputText <<- paste0(input$Clicked)
})
output$text <- renderText({
outputText
})
###Can I use this same filtering format with highchart instead of DT?
output$chart2 <- renderHighchart({
temp <- data
rowcheck <- temp[temp$OnTime == input$Clicked,]
if (nrow(rowcheck)!=0) {
temp <- temp[temp$OnTime == input$Clicked,]
Lvl1Click <<- input$Clicked
}
else {
temp <- temp[temp$OnTime == Lvl1Click,]
temp <- temp[temp$Customer == input$Clicked,]
}
return (temp)
hchart(temp, "scatter", hcaes(x = Customer, y = Quantity))
})
}
#Combines Dasboard and Data together
shinyApp(ui, server)
运行以上代码得到如下图
因为我不能 post 评论那么多，这是我的解决方案。但是，我不是 100% 确定这是否是 OP 的意图
library (shiny)
library (shinydashboard)
library (dplyr)
library (tibble)
library (highcharter)
library(shinyjs)
library (DT)
rm(list=ls())
header <- dashboardHeader()
sidebar <- dashboardSidebar()
body <- dashboardBody(
fluidRow(
box(
tags$head(tags$style(HTML("#OnTime{height:20vh !important;} "))),
title = "On Time", status = "primary", solidHeader = TRUE, width = 6,
highchartOutput("OnTime")
)
),
fluidRow(
box(
title = "WIP Table", status = "primary", solidHeader = TRUE,
highchartOutput("Table")
###I know i need to replace this with a highchartOutput
)
),
fluidRow(
box(
textOutput("text")
)
)
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output) {
Customer <- c("England", "France", "US", "Canada", "England", "France", "US", "Canada", "England")
OnTime <- c("On Time", "On Time", "Overdue", "On Time", "Overdue", "On Time", "Overdue","On Time", "On Time")
Gate <- c(1,2,3,2,3,2,1,2,3)
Quantity <- c(1,1,1,1,1,1,1,1,1)
data <- data.frame(Customer,OnTime,Gate, Quantity)
output$OnTime <- renderHighchart({
Lvl1GroupingStatus <- aggregate(data$Quantity, by = list(data$OnTime),FUN=sum)
Lvl1dfStatus <- data_frame(name = Lvl1GroupingStatus$Group.1,y = Lvl1GroupingStatus$x,drilldown = tolower(name))
Lvl2WIPOverDue <- data[data$OnTime == "Overdue",]
Lvl2WIPOverDueb <- aggregate(Lvl2WIPOverDue$Quantity, by = list(Lvl2WIPOverDue$Customer),FUN=sum)
Lvl2dfWIPOverDue <- arrange(data_frame(name = Lvl2WIPOverDueb$Group.1,value = Lvl2WIPOverDueb$x),desc(value))
Lvl2WIPOnTime <- data[data$OnTime == "On Time",]
Lvl2WIPOnTimeb <- aggregate(Lvl2WIPOnTime$Quantity, by = list(Lvl2WIPOnTime$Customer),FUN=sum)
Lvl2dfWIPOnTime <- arrange(data_frame(name = Lvl2WIPOnTimeb$Group.1,value = Lvl2WIPOnTimeb$x),desc(value))
ClickFunction <- JS("function(event) {Shiny.onInputChange('Clicked', event.point.name);}")
highchart() %>%
hc_chart(type = "column") %>%
hc_xAxis(type = "category") %>%
hc_legend(enabled = FALSE) %>%
hc_yAxis(gridLineWidth = 0) %>%
hc_plotOptions(series = list(column = list(stacking = "normal"),
borderWidth=0,
dataLabels = list(enabled = TRUE),
events = list(click = ClickFunction)
)
) %>%
hc_add_series(data=Lvl1dfStatus,name="Status", colorByPoint = TRUE,colors = c("#003395","#D20000")) %>%
hc_drilldown(
allowPointDrilldown = TRUE,
series = list(
list(id = "overdue", data = list_parse2(Lvl2dfWIPOverDue), name="Customer"),
list(id = "on time", data = list_parse2(Lvl2dfWIPOnTime), name="Customer")
)
)
})
makeReactiveBinding("outputText")
observeEvent(input$Clicked, {
outputText <<- paste0(input$Clicked)
})
output$text <- renderText({
outputText
})
###Can I use this same filtering format with highchart instead of DT?
output$Table <- renderHighchart({
temp <- data
rowcheck <- temp[temp$OnTime == input$Clicked,]
if (nrow(rowcheck)!=0) {
temp <- temp[temp$OnTime == input$Clicked,]
Lvl1Click <<- input$Clicked
}
else {
temp <- temp[temp$OnTime == Lvl1Click,]
temp <- temp[temp$Customer == input$Clicked,]
}
hchart(temp, "scatter", hcaes(x = Customer, y = Quantity))
})
}
#Combines Dasboard and Data together
shinyApp(ui, server)
这是我的输出：
我能够根据以下问题
library (shiny)
library (shinydashboard)
library (dplyr)
library (tibble)
library (highcharter)
library(shinyjs)
library (DT)
rm(list=ls())
header <- dashboardHeader()
sidebar <- dashboardSidebar()
body <- dashboardBody(
fluidRow(
box(
tags$head(tags$style(HTML("#OnTime{height:20vh !important;} "))),
title = "On Time", status = "primary", solidHeader = TRUE, width = 6,
highchartOutput("OnTime")
)
),
fluidRow(
box(
title = "WIP Table", status = "primary", solidHeader = TRUE,
DT::dataTableOutput("Table")
###I know i need to replace this with a highchartOutput
)
),
fluidRow(
box(
textOutput("text")
)
)
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output) {
Customer <- c("England", "France", "US", "Canada", "England", "France", "US", "Canada", "England")
OnTime <- c("On Time", "On Time", "Overdue", "On Time", "Overdue", "On Time", "Overdue","On Time", "On Time")
Gate <- c(1,2,3,2,3,2,1,2,3)
Quantity <- c(1,1,1,1,1,1,1,1,1)
data <- data.frame(Customer,OnTime,Gate, Quantity)
output$OnTime <- renderHighchart({
Lvl1GroupingStatus <- aggregate(data$Quantity, by = list(data$OnTime),FUN=sum)
Lvl1dfStatus <- data_frame(name = Lvl1GroupingStatus$Group.1,y = Lvl1GroupingStatus$x,drilldown = tolower(name))
Lvl2WIPOverDue <- data[data$OnTime == "Overdue",]
Lvl2WIPOverDueb <- aggregate(Lvl2WIPOverDue$Quantity, by = list(Lvl2WIPOverDue$Customer),FUN=sum)
Lvl2dfWIPOverDue <- arrange(data_frame(name = Lvl2WIPOverDueb$Group.1,value = Lvl2WIPOverDueb$x),desc(value))
Lvl2WIPOnTime <- data[data$OnTime == "On Time",]
Lvl2WIPOnTimeb <- aggregate(Lvl2WIPOnTime$Quantity, by = list(Lvl2WIPOnTime$Customer),FUN=sum)
Lvl2dfWIPOnTime <- arrange(data_frame(name = Lvl2WIPOnTimeb$Group.1,value = Lvl2WIPOnTimeb$x),desc(value))
ClickFunction <- JS("function(event) {Shiny.onInputChange('Clicked', event.point.name);}")
highchart() %>%
hc_chart(type = "column") %>%
hc_xAxis(type = "category") %>%
hc_legend(enabled = FALSE) %>%
hc_yAxis(gridLineWidth = 0) %>%
hc_plotOptions(series = list(column = list(stacking = "normal"),
borderWidth=0,
dataLabels = list(enabled = TRUE),
events = list(click = ClickFunction)
)
) %>%
hc_add_series(data=Lvl1dfStatus,name="Status", colorByPoint = TRUE,colors = c("#003395","#D20000")) %>%
hc_drilldown(
allowPointDrilldown = TRUE,
series = list(
list(id = "overdue", data = list_parse2(Lvl2dfWIPOverDue), name="Customer"),
list(id = "on time", data = list_parse2(Lvl2dfWIPOnTime), name="Customer")
)
)
})
makeReactiveBinding("outputText")
observeEvent(input$Clicked, {
outputText <<- paste0(input$Clicked)
})
output$text <- renderText({
outputText
})
###Can I use this same filtering format with highchart instead of DT?
output$Table <- DT::renderDataTable({
temp <- data
rowcheck <- temp[temp$OnTime == input$Clicked,]
if (nrow(rowcheck)!=0) {
temp <- temp[temp$OnTime == input$Clicked,]
Lvl1Click <<- input$Clicked
}
else {
temp <- temp[temp$OnTime == Lvl1Click,]
temp <- temp[temp$Customer == input$Clicked,]
}
return (temp)
})
}
#Combines Dasboard and Data together
shinyApp(ui, server)
谢谢！
下面的代码是我遇到问题的地方。假设我更新了正文以显示第二个高位图与 table.
output$chart2<- renderhighchart({
temp <- data
rowcheck <- temp[temp$RESERVOIR == input$Clicked,]
if (nrow(rowcheck)!=0) {
temp <- temp[temp$RESERVOIR == input$Clicked,]
Lvl1Click <<- input$Clicked
}
else {
temp <- temp[temp$RESERVOIR == Lvl1Click,]
temp <- temp[temp$RESERVOIR == input$Clicked,]
}
return (temp)
hchart(**temp**, "scatter", hcaes(x = Customer, y = Quantity))
这不起作用。我不确定 where/how 在 hchart 中包含临时数据集。
这是改成highchartoutput和renderHighchart后的后续
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output) {
Customer <- c("England", "France", "US", "Canada", "England", "France", "US", "Canada", "England")
OnTime <- c("On Time", "On Time", "Overdue", "On Time", "Overdue", "On Time", "Overdue","On Time", "On Time")
Gate <- c(1,2,3,2,3,2,1,2,3)
Quantity <- c(1,1,1,1,1,1,1,1,1)
data <- data.frame(Customer,OnTime,Gate, Quantity)
output$OnTime <- renderHighchart({
Lvl1GroupingStatus <- aggregate(data$Quantity, by = list(data$OnTime),FUN=sum)
Lvl1dfStatus <- data_frame(name = Lvl1GroupingStatus$Group.1,y = Lvl1GroupingStatus$x,drilldown = tolower(name))
Lvl2WIPOverDue <- data[data$OnTime == "Overdue",]
Lvl2WIPOverDueb <- aggregate(Lvl2WIPOverDue$Quantity, by = list(Lvl2WIPOverDue$Customer),FUN=sum)
Lvl2dfWIPOverDue <- arrange(data_frame(name = Lvl2WIPOverDueb$Group.1,value = Lvl2WIPOverDueb$x),desc(value))
Lvl2WIPOnTime <- data[data$OnTime == "On Time",]
Lvl2WIPOnTimeb <- aggregate(Lvl2WIPOnTime$Quantity, by = list(Lvl2WIPOnTime$Customer),FUN=sum)
Lvl2dfWIPOnTime <- arrange(data_frame(name = Lvl2WIPOnTimeb$Group.1,value = Lvl2WIPOnTimeb$x),desc(value))
ClickFunction <- JS("function(event) {Shiny.onInputChange('Clicked', event.point.name);}")
highchart() %>%
hc_chart(type = "column") %>%
hc_xAxis(type = "category") %>%
hc_legend(enabled = FALSE) %>%
hc_yAxis(gridLineWidth = 0) %>%
hc_plotOptions(series = list(column = list(stacking = "normal"),
borderWidth=0,
dataLabels = list(enabled = TRUE),
events = list(click = ClickFunction)
)
) %>%
hc_add_series(data=Lvl1dfStatus,name="Status", colorByPoint = TRUE,colors = c("#003395","#D20000")) %>%
hc_drilldown(
allowPointDrilldown = TRUE,
series = list(
list(id = "overdue", data = list_parse2(Lvl2dfWIPOverDue), name="Customer"),
list(id = "on time", data = list_parse2(Lvl2dfWIPOnTime), name="Customer")
)
)
})
makeReactiveBinding("outputText")
observeEvent(input$Clicked, {
outputText <<- paste0(input$Clicked)
})
output$text <- renderText({
outputText
})
###Can I use this same filtering format with highchart instead of DT?
output$chart2 <- renderHighchart({
temp <- data
rowcheck <- temp[temp$OnTime == input$Clicked,]
if (nrow(rowcheck)!=0) {
temp <- temp[temp$OnTime == input$Clicked,]
Lvl1Click <<- input$Clicked
}
else {
temp <- temp[temp$OnTime == Lvl1Click,]
temp <- temp[temp$Customer == input$Clicked,]
}
return (temp)
hchart(temp, "scatter", hcaes(x = Customer, y = Quantity))
})
}
#Combines Dasboard and Data together
shinyApp(ui, server)
运行以上代码得到如下图
因为我不能 post 评论那么多，这是我的解决方案。但是，我不是 100% 确定这是否是 OP 的意图
library (shiny)
library (shinydashboard)
library (dplyr)
library (tibble)
library (highcharter)
library(shinyjs)
library (DT)
rm(list=ls())
header <- dashboardHeader()
sidebar <- dashboardSidebar()
body <- dashboardBody(
fluidRow(
box(
tags$head(tags$style(HTML("#OnTime{height:20vh !important;} "))),
title = "On Time", status = "primary", solidHeader = TRUE, width = 6,
highchartOutput("OnTime")
)
),
fluidRow(
box(
title = "WIP Table", status = "primary", solidHeader = TRUE,
highchartOutput("Table")
###I know i need to replace this with a highchartOutput
)
),
fluidRow(
box(
textOutput("text")
)
)
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output) {
Customer <- c("England", "France", "US", "Canada", "England", "France", "US", "Canada", "England")
OnTime <- c("On Time", "On Time", "Overdue", "On Time", "Overdue", "On Time", "Overdue","On Time", "On Time")
Gate <- c(1,2,3,2,3,2,1,2,3)
Quantity <- c(1,1,1,1,1,1,1,1,1)
data <- data.frame(Customer,OnTime,Gate, Quantity)
output$OnTime <- renderHighchart({
Lvl1GroupingStatus <- aggregate(data$Quantity, by = list(data$OnTime),FUN=sum)
Lvl1dfStatus <- data_frame(name = Lvl1GroupingStatus$Group.1,y = Lvl1GroupingStatus$x,drilldown = tolower(name))
Lvl2WIPOverDue <- data[data$OnTime == "Overdue",]
Lvl2WIPOverDueb <- aggregate(Lvl2WIPOverDue$Quantity, by = list(Lvl2WIPOverDue$Customer),FUN=sum)
Lvl2dfWIPOverDue <- arrange(data_frame(name = Lvl2WIPOverDueb$Group.1,value = Lvl2WIPOverDueb$x),desc(value))
Lvl2WIPOnTime <- data[data$OnTime == "On Time",]
Lvl2WIPOnTimeb <- aggregate(Lvl2WIPOnTime$Quantity, by = list(Lvl2WIPOnTime$Customer),FUN=sum)
Lvl2dfWIPOnTime <- arrange(data_frame(name = Lvl2WIPOnTimeb$Group.1,value = Lvl2WIPOnTimeb$x),desc(value))
ClickFunction <- JS("function(event) {Shiny.onInputChange('Clicked', event.point.name);}")
highchart() %>%
hc_chart(type = "column") %>%
hc_xAxis(type = "category") %>%
hc_legend(enabled = FALSE) %>%
hc_yAxis(gridLineWidth = 0) %>%
hc_plotOptions(series = list(column = list(stacking = "normal"),
borderWidth=0,
dataLabels = list(enabled = TRUE),
events = list(click = ClickFunction)
)
) %>%
hc_add_series(data=Lvl1dfStatus,name="Status", colorByPoint = TRUE,colors = c("#003395","#D20000")) %>%
hc_drilldown(
allowPointDrilldown = TRUE,
series = list(
list(id = "overdue", data = list_parse2(Lvl2dfWIPOverDue), name="Customer"),
list(id = "on time", data = list_parse2(Lvl2dfWIPOnTime), name="Customer")
)
)
})
makeReactiveBinding("outputText")
observeEvent(input$Clicked, {
outputText <<- paste0(input$Clicked)
})
output$text <- renderText({
outputText
})
###Can I use this same filtering format with highchart instead of DT?
output$Table <- renderHighchart({
temp <- data
rowcheck <- temp[temp$OnTime == input$Clicked,]
if (nrow(rowcheck)!=0) {
temp <- temp[temp$OnTime == input$Clicked,]
Lvl1Click <<- input$Clicked
}
else {
temp <- temp[temp$OnTime == Lvl1Click,]
temp <- temp[temp$Customer == input$Clicked,]
}
hchart(temp, "scatter", hcaes(x = Customer, y = Quantity))
})
}
#Combines Dasboard and Data together
shinyApp(ui, server)
这是我的输出：