Question

我能够根据以下问题Highcharter - Click event to filter data from graph的回答，通过click事件创建反应式表格，但是我似乎无法弄清楚如何添加反应式图表来代替表格。下面的代码演示了如何制作表格。

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)

谢谢！

下面的代码是我遇到问题的地方。假设我已经更新了正文，以显示第二个图表与表格。

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))

这不起作用。我不确定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)

运行上面的代码将显示下面的图像

Answer 1

由于我不能在评论中发表太多内容，因此这是我的解决方案。但是，我不是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)

这是我的输出：

通过单击非反应性高图创建反应性高图

1 个答案: