R Shiny: как отфильтровать данные по нажатию на гистограмму?

Question

В моем приложении Shiny у меня есть модуль гистограммы, который создает гистограмму данных оценки проекта (например, проекты оцениваются от 0 до 100). Мне бы хотелось, чтобы, когда пользователь нажимал на любую из полос гистограммы, страница прокручивалась до таблицы ниже (вывод через DTOutput), чтобы показать список идентификаторов проекта, которые представляет эта полоса в гистограмме.

Как мне это сделать?

Похоже, мне нужно было бы добавить прослушиватель событий на каждую полосу гистограммы. Следующие ссылки имеют отношение к добавлению прослушивателей событий:

Как создать функцию события Highcharter для создания «выпадающей функции» в Shiny R

https://redoakstrategic.com/javascript_r_click_events/

Также доступна функция observeEvent:

https://shiny.rstudio.com/reference/shiny/1.0.3/observeEvent.html

Однако во всех этих примерах событие слушатель должен быть в том же файле. Мой модуль гистограммы, код пользовательского интерфейса и т. Д. c. все в отдельных файлах.

Если бы я создавал это приложение в ReactJS, я бы использовал Redux для обработки потока данных и глобальных переменных на стороне клиента. В VueJS я бы использовал шаблон излучателя. Что-нибудь подобное доступно с R Shiny? Здесь ниже мой модуль гистограммы:

#' Histogram Module
#'
#' @param id shiny module namespace ID
#'
#' @return tagList containing histos
#' @export
#'
#' @examples
histogram_module_ui <- function(id) {

  ns <- NS(id)

  tagList(
    withTags(
      div(
        style = "margin:auto;",
        # using dropdown instead of dropdownButton
        # dropdown has more flexibility see ?shinyWidgets::dropdown vs dropdownButton
        highchartOutput(
          ns("histogram_chart"),
          height = "220px"
        ) %>%
          withSpinner()
      )
    )
  )

}


#' Histogram Module - Server
#'
#' @param input shiny input
#' @param output shiny output
#' @param session shiny session
#' @param data data for histogram as a vector
#' @param chart_title chart title
#' @param y_axis_title y-axis title
#'
histogram_module <- function(input, output, session,
                             data = NA,
                             chart_title = "",
                             reactive_subtitle = NULL,
                             y_axis_title = chart_title) {

  hist_object <- reactive({
    req(length(data()) > 0)

    dat <- data()

    hist(
      x = dat,
      breaks = 50
    )
  })

  observe({
    data()
    shinyjs::toggle(id = "options_dropdown", condition = length(data() > 0))
  })


  d <- reactive({
    hist_object <- hist_object()

    diff(hist_object$breaks)[1]
  })

  df <- reactive({
    hist_object <- hist_object()
    d <- d()

    tibble(
      x = hist_object$mids,
      y = hist_object$counts,
      name = sprintf("(%s, %s]", hist_object$mids - d / 2, hist_object$mids + d / 2)
    )
  })

  cdf_pct75 <- reactive({
    quantile(data(), probs = 75 / 100) %>% unname()
  })
  cdf_pct50 <- reactive({
    quantile(data(), probs = 50 / 100) %>% unname()
  })
  cdf_pct25 <- reactive({
    quantile(data(), probs = 25 / 100) %>% unname()
  })

  plot_lines <- reactive({

    dat <- data()
    out <- list()

    if (TRUE) {
    # if ("perc" %in% input$options) {

      out[["percentile75"]] <- list(
        label = list(
          text = paste0(
            "75th = ",
            format(round(cdf_pct75(), 3), nsmall = 3)
          ),
          style = list(
            color = hc_colors[4]
          )
        ),
        color = hc_colors[4],
        width = 3,
        value = cdf_pct75(),
        zIndex = 5,
        dashStyle = "dash"
      )

      out[["percentile50"]] <- list(
        label = list(
          text = paste0(
            "50th = ",
            format(round(cdf_pct50(), 3), nsmall = 3)
          ),
          style = list(
            color = hc_colors[3]
          )
        ),
        color = hc_colors[3],
        width = 3,
        value = cdf_pct50(),
        zIndex = 5.1,
        dashStyle = "dash"
      )

      out[["percentile25"]] <- list(
        label = list(
          text = paste0(
            "25th = ",
            format(round(cdf_pct25(), 3), nsmall = 3)
          ),
          style = list(
            color = hc_colors[2]
          )
        ),
        color = hc_colors[2],
        width = 3,
        value = cdf_pct25(),
        zIndex = 5.2,
        dashStyle = "dash"
      )
    }

    unname(out)

  })

  output$histogram_chart <- renderHighchart({
    df <- df()
    d <- d()

    out <- highchart() %>%
      hc_subtitle(text = reactive_subtitle()) %>%
      hc_add_dependency("modules/histogram-bellcurve.js") %>%
      hc_title(
        text = chart_title #,
        # verticalAlign = "bottom",
        # y = -50
      ) %>%
      hc_legend(enabled = FALSE) %>%
      hc_xAxis(
        min = 0,
        max = 100,
        plotLines = plot_lines()
      ) %>%
      hc_yAxis(
        min = 0,
        title = list(
          text = y_axis_title,
          style = list(
            "font-size" = "16px"
          )
        )
      ) %>%
      hc_add_series(
        data = list_parse(df),
        type = "column",
        pointRange = d,
        groupPadding = 0,
        pointPadding = 0,
        borderWidth = 2,
        borderColor = "#000",
        name = "Observations"
      )

  })

}