How to add hover option with multiple row in ggplot2 bar chart?

Question

I'm developing a dashboard using flexdashboard in R and need help on how to hover in ggplot2

Here is my sample data:

data <- data.frame(Name= c('PARVIN', 'SOHEL', 'OVI', 'MD.HANIF','RAJU','AHMED','RANA','BEGUM','YOUSUF','KHAN'),
                   Age = c(55,65,25,70,35,40,66,62,33,55),
                   Occupation= c ('computer shop','grocery business' ,'computer shop','computer shop',
                                  'grocery business','grocery business','rice business','rice business','rice business','rice business'),
                   spend= c( 'Yes','Yes','Yes','Yes','Yes','Yes','Yes','Yes','Yes','Yes'),
                   spendbdp = c ( 'Yes','Yes','No','Yes','No','No','Yes','No','Yes','Yes'))

In my database there are some participants with their age, occupation, spending money and spending money as business plan status.

My goal is to make a bar chart with column spent and stackbar with column spendBDP. So, I use the gather function to prepare the data.

data$spend <- paste("Spent-", data$spend)
data$spendbdp <- paste("Spent BDP-", data$spendbdp)

chart <- data %>%
  select(3:5) %>%
  gather("type", "legend",-Occupation)%>%
  group_by(Occupation,type,legend ) %>%
  summarise(n = length(legend))

Then I use ggplot2 to plot the data.

ggplot(chart, aes(x=type, y=n, fill=legend)) +
  facet_grid(. ~ Occupation,switch = "both") + geom_bar(stat='identity') +
  theme_classic() +
  theme(strip.placement = "outside")

Here is my output:

Now, I want to add a hover option to see who didn't spend their money as business plan and who spend their money as business plan with their age information. For, example if I click on "computer shop" spendBDP bars Yes portion so I can see participants list or table with their age.

Or, it can be popup table. How could I do this?

Answer 1

What do you want in the table exactly? We can do something like that (the style of the tables can be improved):

library(shiny)
library(ggplot2)
library(tidyr)
library(xtable)

data <- data.frame(Name= c('PARVIN', 'SOHEL', 'OVI', 'MD.HANIF','RAJU','AHMED','RANA','BEGUM','YOUSUF','KHAN'),
                   Age = c(55,65,25,70,35,40,66,62,33,55),
                   Occupation= c ('computer shop','grocery business' ,'computer shop','computer shop',
                                  'grocery business','grocery business','rice business','rice business','rice business','rice business'),
                   spend= c( 'Yes','Yes','Yes','Yes','Yes','Yes','Yes','Yes','Yes','Yes'),
                   spendbdp = c ( 'Yes','Yes','No','Yes','No','No','Yes','No','Yes','Yes'))
data$spend <- paste("Spent-", data$spend)
data$spendbdp <- paste("Spent BDP-", data$spendbdp)

chart <- data %>%
  select(3:5) %>%
  gather("type", "legend",-Occupation)%>%
  group_by(Occupation,type,legend ) %>%
  summarise(n = length(legend))
  
gg <- ggplot(chart, aes(x=type, y=n, fill=legend)) +
  facet_grid(. ~ Occupation,switch = "both") + geom_bar(stat='identity') +
  theme_classic() +
  theme(strip.placement = "outside")


ui <- fluidPage(
  br(),
  plotOutput(
    "ggplot",
    click = "plot_click"
  ),
  uiOutput("click_info")
)

server <- function(input, output, session){

  output$ggplot <- renderPlot({gg})
  
  output$click_info <- renderUI({
    info <- input$plot_click
    if(is.null(info)){
      return(NULL)
    }
    left_pct <- (info$x - info$domain$left) / (info$domain$right - info$domain$left)
    top_pct <- (info$domain$top - info$y) / (info$domain$top - info$domain$bottom)

    left_px <- info$range$left + left_pct * (info$range$right - info$range$left)
    top_px <- info$range$top + top_pct * (info$range$bottom - info$range$top)

    style <- paste0("position:absolute; z-index:100; background-color: rgba(245, 245, 245, 0.85); ",
                    "left:", left_px + 2, "px; top:", top_px + 2, "px;")
    
    dat <- subset(data, Occupation == info$panelvar1)
    table <- print.xtable(xtable(dat), type = "html", print.results = FALSE)

    wellPanel(
      style = style,
      div(HTML(table))
    )
    
  })

}

shinyApp(ui, server)

---

EDIT: style

library(shiny)
library(ggplot2)
library(tidyr)
library(xtable)

data0 <- data.frame(
  Name = c(
    "PARVIN", "SOHEL", "OVI", "MD.HANIF", "RAJU", 
    "AHMED", "RANA", "BEGUM", "YOUSUF", "KHAN"
  ),
  Age = c(
    55, 65, 25, 70, 35, 40, 66, 62, 33, 55
  ),
  Occupation = c(
    "computer shop", "grocery business", "computer shop", "computer shop",
    "grocery business", "grocery business", "rice business", 
    "rice business", "rice business", "rice business"
  ),
  spend = c(
    "Yes", "Yes", "Yes", "Yes", "Yes", "Yes", "Yes", "Yes", "Yes", "Yes"
  ),
  spendbdp = c(
    "Yes", "Yes", "No", "Yes", "No", "No", "Yes", "No", "Yes", "Yes"
  )
)

data <- data0
data$spend <- paste("Spent-", data$spend)
data$spendbdp <- paste("Spent BDP-", data$spendbdp)

chart <- data %>%
  select(3:5) %>%
  gather("type", "legend", -Occupation) %>%
  group_by(Occupation, type, legend) %>%
  summarise(n = length(legend))

gg <- ggplot(chart, aes(x = type, y = n, fill = legend)) +
  facet_grid(. ~ Occupation, switch = "both") +
  geom_bar(stat = "identity") +
  theme_classic() +
  theme(strip.placement = "outside")


# shiny UI
ui <- fluidPage(
  tags$head(
    tags$style(
      HTML(
        "th, td {
          padding: 7px;
        }"
      )
    )
  ),
  br(),
  fluidRow(
    column(
      8,
      plotOutput("ggplot", click = "plot_click"),
      uiOutput("click_info")
    ),
    column(4)
  )
)

# shiny server
server <- function(input, output, session) {
  output$ggplot <- renderPlot({
    gg
  })

  output$click_info <- renderUI({
    info <- input$plot_click
    if (is.null(info)) {
      return(NULL)
    }
    left_pct <- (info$x - info$domain$left) /
      (info$domain$right - info$domain$left)
    top_pct <- (info$domain$top - info$y) /
      (info$domain$top - info$domain$bottom)
    left_px <-
      info$range$left + left_pct * (info$range$right - info$range$left)
    top_px <-
      info$range$top + top_pct * (info$range$bottom - info$range$top)

    style <- paste0(
      "position:absolute; z-index:100; ",
      "background-color: rgba(245, 245, 245, 0.85); ",
      "left:", left_px + 2, "px; top:", top_px + 2, "px;"
    )

    dat <- subset(data0, Occupation == info$panelvar1)
    table <- print.xtable(xtable(dat), type = "html", print.results = FALSE)

    wellPanel(
      style = style,
      div(
        id = "table-container",
        HTML(table)
      )
    )
  })
}

shinyApp(ui, server)

---

EDIT

Use this server to have the possibility to dismiss the tooltip on the second click:

server <- function(input, output, session) {

  output$ggplot <- renderPlot({
    gg
  })

  Group <- ""
  Counter <- 0

  output$click_info <- renderUI({
    info <- input$plot_click
    if (is.null(info)) {
      return(NULL)
    }

    group <- info$panelvar1
    if(group == Group) Counter <<- Counter + 1 else Counter <<- 1
    Group <<- group
    if (Counter == 2) {
      Counter <<- 0
      return(NULL)
    }

    left_pct <- (info$x - info$domain$left) /
      (info$domain$right - info$domain$left)
    top_pct <- (info$domain$top - info$y) /
      (info$domain$top - info$domain$bottom)
    left_px <-
      info$range$left + left_pct * (info$range$right - info$range$left)
    top_px <-
      info$range$top + top_pct * (info$range$bottom - info$range$top)

    style <- paste0(
      "position: absolute; z-index: 100; ",
      "background-color: rgba(245, 245, 245, 0.85); ",
      "left: ", left_px + 2, "px; top: ", top_px + 2, "px;"
    )

    dat <- subset(data0, Occupation == group)
    table <- print.xtable(xtable(dat), type = "html", print.results = FALSE)

    wellPanel(
      style = style,
      div(
        HTML(table)
      )
    )
  })
}