How to create a clickable histogram in Shiny? - r

Question

I want to create a clickable histogram in shiny but I don't know if it is possible.
Some months ago I saw a clickable volcano plot which gives you a table of what you click.
Source: https://2-bitbio.com/2017/12/clickable-volcano-plots-in-shiny.html
The closest post that I found about creating clickable histograms is this one Click to get coordinates from multiple histogram in shiny
However, I don't want to get the coordinates. I want the rownames of the dataframe.
Having this dataframe, can I get the rownames everytime I click a bar from the histogram?
mtcars <- mtcars %>%
select("hp")
mtcars <- as.matrix(mtcars)
One example (but not clickable) in shiny:
library(shiny)
library(ggplot2)
library(scales)
library(dplyr)
ui <- fluidPage(
titlePanel("Histogram"),
sidebarLayout(
sidebarPanel(
),
mainPanel(
plotOutput("hist"),
)
)
)
mtcars <- mtcars %>%
select("hp")
mtcars <- as.matrix(mtcars)
server <- function(input, output) {
output$hist <- renderPlot({
pp <- qplot(mtcars, geom = "histogram", bins = 10, xlab="values",
ylab="Frequency", main="Histogram",
fill=I("red"), col=I("black"), alpha=I(0.4))
pp + scale_x_continuous(breaks=pretty(mtcars, n=10))
})
}
shinyApp(ui = ui, server = server)
Does anyone know how to do it?
Thanks very much in advance!
Regards

Answer 1

This is a great question, and what makes it challenging is that the qplot/ggplot charts are static images. The below app.r is an example of how I would do it. I'd love to see other approaches.
In essence:
Create a sequence of numbers that will be used both as the breaks in your histogram and as intervals in your dataframe. I based these on user inputs, but you could hardcode them.
Assign a "bin" value to each row in the dataframe based on the interval in which the value falls.
Record the x-coordinate from the user's click event and assign that a "bin" value based on the same set of intervals.
Subset your dataframe and retain only those records where the "bin" value of the data matches the "bin" value of the x-coordinate from the user's click event.
Otherwise, if you're willing to go the d3 route, you could explore something like this posted by R Views.
#Load libraries ----------------------------------------------------
library(shiny)
library(ggplot2)
library(scales)
library(dplyr)
# Prepare data -----------------------------------------------------
df <- mtcars
df <- cbind(model = rownames(df), data.frame(df, row.names = NULL)) # setting the rownames as the first column
dm <- df$hp %>% as.matrix()
# UI function ------------------------------------------------------
ui <- fluidPage(
titlePanel("Histogram"),
sidebarLayout(
sidebarPanel(
tags$h5("I added the below text output only to demonstrate shiny's way for tracking user interaction on static plots. You can click, double-click, or click & drag (i.e. brushing). These functions are AWESOME when exploring scatterplots."),
tags$h3("Chart click and brushing"),
verbatimTextOutput("info"),
tags$h5("Now I'm applying the below UI inputs to the `vec` and `breaks` arguments in `findInterval()` and `qplot()` respectively; I'm using `findInterval()` to bin the values in the dataframe AND to bin the x-value of the user's click event input on the chart. Then we can return the dataframe rows with the same bin values as the x-value of the click input."),
sliderInput("seq_from_to"
, label = h3("Sequence 'From' and 'To'")
, min = 0
, max = 500
, value = c(50, 350)
),
sliderInput("seq_by"
, label = h3("Sequence 'By'")
, min = 25
, max = 200
, value = 50
, step = 5)
),
mainPanel(
plotOutput("hist",
click = "plot_click",
dblclick = "plot_dblclick",
hover = "plot_hover",
brush = "plot_brush"),
dataTableOutput("table")
)
)
)
# Server function --------------------------------------------------
server <- function(input, output) {
# Render Histogram Plot
output$hist <- renderPlot({
# Using the same `qplot` function but inserting the user inputs to set the breaks values in the plot
pp <- qplot(dm
, geom = "histogram"
, breaks = seq(from = input$seq_from_to[1], to = input$seq_from_to[2], by = input$seq_by)
, xlab = "values"
, ylab = "Frequency"
, main = "Histogram"
, fill = I("red")
, col = I("black")
, alpha = I(0.4)
)
# Also using the user inputs to set the breaks values for the x-axis
pp + scale_x_continuous(breaks = seq(from = input$seq_from_to[1], to = input$seq_from_to[2], by = input$seq_by))
})
# This is purely explanatory to help show how shiny can read user interaction on qplot/ggplot objects
# It's taken from the Shiny docs here: https://shiny.rstudio.com/articles/plot-interaction.html
output$info <- renderText({
# Retain the x and y coords of the user click event data
xy_str <- function(e) {
if(is.null(e)) return("NULL\n")
paste0("x=", round(e$x, 1), " y=", round(e$y, 1), "\n")
}
# Retain the x and y range coords of click & drag (brush) data
xy_range_str <- function(e) {
if(is.null(e)) return("NULL\n")
paste0("xmin=", round(e$xmin, 1), " xmax=", round(e$xmax, 1),
" ymin=", round(e$ymin, 1), " ymax=", round(e$ymax, 1))
}
# Paste this together so we can read it in the UI function for demo purposes
paste0(
"click: ", xy_str(input$plot_click),
"dblclick: ", xy_str(input$plot_dblclick),
"hover: ", xy_str(input$plot_hover),
"brush: ", xy_range_str(input$plot_brush)
)
})
# Back to the story. Set a listener to trigger when one of the following is updated:
toListen <- reactive({list(
input$plot_click # user clicks on the plot
, input$seq_from_to # user updates the range slider
, input$seq_by # user updates the number input
)
})
# When one of those events are triggered, update the datatable output
observeEvent(toListen(), {
# Save the user click event data
click_data <- input$plot_click
print(click_data) # during your app preview, you can watch the R Console to see what click data is accessible
# Assign bin values to each row using the intervals that are set by the user input
df$bin <- findInterval(dm, vec = seq(from = input$seq_from_to[1], to = input$seq_from_to[2], by = input$seq_by))
# Similarly assign a bin value to the click event based on what interval the x values falls within
click_data$x_bin <- findInterval(click_data$x, vec = seq(from = input$seq_from_to[1], to = input$seq_from_to[2], by = input$seq_by))
# Lastly, subset the df to only those records within the same interval as the click event x-value
df_results <- subset(df, bin == click_data$x_bin)
# Select what values to view in the table
df_results <- df_results %>% select(model, hp)
# And push these back out to the UI
output$table <- renderDataTable(df_results,
options = list(
pageLength = 5
)
)
})
}
shinyApp(ui = ui, server = server)

Answer 2

Well, someone answered. Since I took the time to put it together, here is another potential solution.
library(shiny)
library(ggplot2)
library(scales)
library(dplyr)
library(DescTools) # added for Closest()
ui <- fluidPage(
titlePanel("Histogram"),
sidebarLayout(
sidebarPanel(
),
mainPanel(
plotOutput("hist", click = 'plot_click'), # added plot_click
verbatimTextOutput("x_value"), # added queues for interactivity
verbatimTextOutput("selected_rows") # added table for bin values
)
)
)
# this can be a dataframe or matrix for qplot or ggplot
# (not sure if there was another reason you had this code?)
# mtcars <- mtcars %>%
# select("hp") # if you only want hp
# mtcars <- as.matrix(mtcars) # I suggest making row names a column
# to keep 2 columns
pp <- ggplot(mtcars) +
geom_histogram(aes(x = hp),
bins = 10,
fill = "red",
color = "black",
alpha = .4) +
labs(x = "values",
y = "Frequency",
title = "Histogram")
# extract data from plot to find where each value falls within the histogram bins
# I kept the pkg name, function in more than one library
bd <- ggplot_build(ggplot2::last_plot())$data[[1]]
# add the assigned bin number to the mtcars frame; used for filtering matches
mtcars$bins <- lapply(mtcars$hp,
function(y) {
which(bd$x == Closest(bd$x, y))
}) %>% unlist()
server <- function(input, output) {
output$hist <- renderPlot({
# moved the plot outside of server, so that global variables could be created
# pp <- qplot(mtcars[,"hp"], geom = "histogram", bins = 10, xlab="values",
# ylab = "Frequency", main = "Histogram",
# fill = I("red"), col = I("black"), alpha = I(0.4))
# scale_x_continuous(breaks=pretty(mtcars, n=10)) # can't use this
pp
})
# # Print the name of the x value # added all that's below with server()
output$x_value <- renderPrint({
if (is.null(input$plot_click$x)) return()
# find the closest bin center to show where the user clicked on the histogram
cBin <- which(bd$x == Closest(bd$x, input$plot_click$x))
paste0("You selected bin ", cBin) # print out selected value based on bin center
})
# Print the rows of the data frame which match the x value
output$selected_rows <- renderPrint({
if (is.null(input$plot_click$x)) return()
# find the closest bin center to show where the user clicked on the histogram
cBin <- which(bd$x == Closest(bd$x, input$plot_click$x))
mtcars %>% filter(bins == cBin)
# mtcars
})
}
shinyApp(ui = ui, server = server)

Answer 3

Just in case someone ends in this post looking a way to include brushedPoints... inspired on this post, I found a way to do it!
Code:
#Load libraries ----------------------------------------------------
library(shiny)
library(ggplot2)
library(scales)
library(dplyr)
# Prepare data -----------------------------------------------------
df <- mtcars
df <- cbind(model = rownames(df), data.frame(df, row.names = NULL)) # setting the rownames as the first column
breaks_data = pretty(mtcars$hp, n=10)
my_breaks = seq(min(breaks_data), to=max(breaks_data), by=30)
# UI function ------------------------------------------------------
ui <- fluidPage(
titlePanel("Histogram"),
sidebarLayout(
sidebarPanel(
actionButton("draw_plot", "Draw the plot")
),
mainPanel(
plotOutput("hist",
brush = brushOpts("plot_brush", resetOnNew = T, direction = "x")),
dataTableOutput("table"),
)
)
)
# Server function --------------------------------------------------
server <- function(input, output) {
observeEvent(input$plot_brush, {
info_plot <- brushedPoints(df, input$plot_brush)
output$table <- renderDataTable(info_plot)
})
# If the user didn't choose to see the plot, it won't appear.
output$hist <- renderPlot({
df %>% ggplot(aes(hp)) +
geom_histogram(alpha=I(0.4), col = I("black"), fill = I("red"), bins=10) +
labs(x = "values",
y = "Frequency",
title = "Histogram") +
scale_x_continuous(breaks = my_breaks)
})
}
shinyApp(ui = ui, server = server)

Answer 4

How to do a scatterplot with hover
library(shiny)
library(tidyverse)
ui <- fluidPage(
titlePanel("hover tooltips demo"),
mainPanel(
plotOutput("plot1", hover = hoverOpts(id = "plot_hover", delay = 100, delayType = "debounce")),
uiOutput("hover_info") # , style = "pointer-events: none")
)
)
server <- function(input, output) {
output$plot1 <- renderPlot({
mtcars %>%
ggplot(aes(mpg, hp)) +
geom_point()
})
output$hover_info <- renderUI({
hover <- input$plot_hover
point <- shiny::nearPoints(mtcars,
coordinfo = hover,
xvar = 'mpg',
yvar = 'hp',
threshold = 20,
maxpoints = 1,
addDist = TRUE)
if (nrow(point) == 0) return(NULL)
style <- paste0("position:absolute; z-index:100; background-color: #3c8dbc; color: #ffffff;",
"font-weight: normal; font-size: 11pt;",
"left:", hover$coords_css$x + 5, "px;",
"top:", hover$coords_css$y + 5, "px;")
wellPanel(
style = style,
p(HTML(paste0("Some info about car: <br/>MPG ", point$mpg, "<br/>HP ", point$hp)))
)
})
}
shinyApp(ui = ui, server = server)