使用 R 显示信息框中分组条形图中的条数，情节和闪亮

Question

运行以下脚本后，我得到两个分组条形图和一个信息框。我想这样当我点击红色组中的任何条时，我应该在上面的信息框中获得该组中所有条的总和。此外，对于 Green 组也是如此。这意味着信息框将只有两个值，一个用于红色类别，一个用于绿色类别。我有剧本，我也要给个快照。

library(shiny)
library(shinydashboard)
library(ggplot2)
library(plotly)

ui <- dashboardPage(
dashboardHeader(title = "Sankey Chart"),
dashboardSidebar(
width = 0
),
dashboardBody(
fluidRow(
column(10,
         uiOutput('box1'),
         tags$br()),
  tags$br(),
  column(10,


         box(title = "Case Analyses",status = "primary",solidHeader = 
  T,width = 1050,height = 452,
             plotlyOutput("case_hist"))
  ))
  )
  )
  server <- function(input, output) 
  { 
  output$case_hist <- renderPlotly(
  {

  iris$iris_limits <- cut(iris$Sepal.Length, c(1,3,6,9))
  iris$ID <- factor(1:nrow(iris))
  gg <- ggplot(iris, aes(x=ID, y=Sepal.Length, fill=iris_limits)) + 
    geom_bar(stat="identity", position="dodge") +
    facet_wrap(~iris_limits, scales="free_x", labeller=label_both) +
    theme_minimal() + xlab("") + ylab("Sepal Length") +
    theme(axis.text.x=element_blank())
  ggplotly(gg)
  }
  )
  output$box1 <- renderUI({
  tagList(
  infoBox("Total Cases", "a" , icon = icon("fa fa-briefcase"))
  )
  })
  }
  shinyApp(ui, server)

Answer 1

您可以使用event_data("plotly_click") 执行类似的操作。

library(shiny)
library(shinydashboard)
library(ggplot2)
library(plotly)

ui <- dashboardPage(
  dashboardHeader(title = "Sankey Chart"),
  dashboardSidebar(
    width = 0
  ),
  dashboardBody(
    fluidRow(
      column(10,
             uiOutput('box1'),
             tags$br()),
      tags$br(),
      column(10,


             box(title = "Case Analyses",status = "primary",solidHeader = 
                   T,width = 1050,height = 452,
                 plotlyOutput("case_hist"))
      ))
  )
)
server <- function(input, output) 
{ 
  dat <- reactiveValues(Val = iris)

  output$case_hist <- renderPlotly(
    {
      dat$Val$iris_limits <- cut(iris$Sepal.Length, c(1,3,6,9))
      dat$Val$ID <- factor(1:nrow(iris))
      iris$iris_limits <- cut(iris$Sepal.Length, c(1,3,6,9))
      iris$ID <- factor(1:nrow(iris))
      gg <- ggplot(iris, aes(x=ID, y=Sepal.Length, fill=iris_limits)) + 
        geom_bar(stat="identity", position="dodge") +
        facet_wrap(~iris_limits, scales="free_x", labeller=label_both) +
        theme_minimal() + xlab("") + ylab("Sepal Length") +
        theme(axis.text.x=element_blank())
      ggplotly(gg)
    }
  )

  output$box1 <- renderUI({
    d <- event_data("plotly_click")
    tc <- c()
    if(!is.null(d)){

      if(d$curveNumber == 0)#pink click
      {
        tc <- sum(dat$Val$Sepal.Length[which(dat$Val$iris_limits == "(3,6]")])


      }else#green click
      {
        tc <- sum(dat$Val$Sepal.Length[which(dat$Val$iris_limits == "(6,9]")])
      }
    }
      tagList(
        infoBox("Total Cases", tc , icon = icon("fa fa-briefcase"))
      )


  })
}
shinyApp(ui, server)

这里我使用了reactiveValue，以便在单击绘图时计算计数。其他选项是您将值保存在 reactiveValue 中，而不是保存数据。像这样的：

library(shiny)
library(shinydashboard)
library(ggplot2)
library(plotly)

ui <- dashboardPage(
  dashboardHeader(title = "Sankey Chart"),
  dashboardSidebar(
    width = 0
  ),
  dashboardBody(
    fluidRow(
      column(10,
             uiOutput('box1'),
             tags$br()),
      tags$br(),
      column(10,


             box(title = "Case Analyses",status = "primary",solidHeader = 
                   T,width = 1050,height = 452,
                 plotlyOutput("case_hist"))
      ))
  )
)
server <- function(input, output) 
{ 
  dat <- reactiveValues(Val1 = c(), Val2 = c())

  output$case_hist <- renderPlotly(
    {

      iris$iris_limits <- cut(iris$Sepal.Length, c(1,3,6,9))
      iris$ID <- factor(1:nrow(iris))

      dat$Val1 <- sum(iris$Sepal.Length[which(iris$iris_limits == "(3,6]")])
      dat$Val2 <- sum(iris$Sepal.Length[which(iris$iris_limits == "(6,9]")])
      gg <- ggplot(iris, aes(x=ID, y=Sepal.Length, fill=iris_limits)) + 
        geom_bar(stat="identity", position="dodge") +
        facet_wrap(~iris_limits, scales="free_x", labeller=label_both) +
        theme_minimal() + xlab("") + ylab("Sepal Length") +
        theme(axis.text.x=element_blank())
      ggplotly(gg)
    }
  )

  output$box1 <- renderUI({
    d <- event_data("plotly_click")
    tc <- c()
    if(!is.null(d)){

      if(d$curveNumber == 0)#pink click
      {
        tc <- dat$Val1


      }else#green click
      {
        tc <- dat$Val2
      }
    }
      tagList(
        infoBox("Total Cases", tc , icon = icon("fa fa-briefcase"))
      )


  })
}
shinyApp(ui, server)