In my Shiny app, I have a histogram module that creates a histogram of project evaluation data (e.g. projects are rated from 0 to 100). I would like that when the user clicks on any of the bars in the histogram, the page scrolls down to a table below (output via DTOutput) to show a list of the project IDs that that bar in the histogram represents.
How do I do this?
It looks like I would have to add an event listener to each bar in the histogram. The following links seem relevant for adding event listeners:
How to create a highcharter event function to create a “dropdown function” in Shiny R
https://redoakstrategic.com/javascript_r_click_events/
An observeEvent function is also available:
https://shiny.rstudio.com/reference/shiny/1.0.3/observeEvent.html
In all of these examples, however, the event listener has to be in the same file. My histogram module, UI code, etc. are all in separate files.
If I were building this app in ReactJS, I would use Redux for handling data flow and global variables on the client side. In VueJS, I would use an emitter pattern. Is something similar available with R Shiny? Here below is my histogram module:
#' 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"
)
})
}
