rshinyplotly

Hover displaying fillcolour instead of text in Plotly

I previously had R Shiny code where everything worked as expected with regards to the hovertext in a renderPlotly plot:

  1. The individual scatter points displayed information when hovered over
  2. The coloured backgrounds displayed custom hover text which was specifically defined

However, when I have moved the plot out to a separate function, this broke point 2 above. Here is a reproducible example:

library(shiny)
library(plotly)
library(data.table)

# Create dummy data
set.seed(123)
create_dummy_data <- function(n = 50) {
  data.table(
    client_name = paste("Client", 1:n),
    assigned = sample(c("Dr. A", "Dr. B", "Dr. C"), n, replace = TRUE),
    T1 = runif(n, 0, 100),
    T2 = runif(n, 0, 100)
  )
}

# Plot generation function
generate_firstvlast_plot <- function(dat, is_administrator = FALSE) {
  minScore <- 0
  maxScore <- 100
  min_fvl_score <- 10
  
  upper_red <- data.frame(x=c(minScore,minScore,(maxScore-min_fvl_score)),y=c((minScore+min_fvl_score),maxScore, maxScore))
  lower_green <- data.frame(x=c((minScore+min_fvl_score),maxScore,maxScore),y=c(minScore,minScore,(maxScore-min_fvl_score)))
  middle_grey <- data.frame(x=c(minScore, minScore,(maxScore-min_fvl_score),maxScore, maxScore,(minScore+min_fvl_score)), 
                            y=c(minScore, (minScore+min_fvl_score),maxScore,maxScore,(maxScore-min_fvl_score),minScore))
  
  p <- plot_ly(height = 600) %>%
    config(displayModeBar = FALSE) %>%
    add_polygons(data = upper_red, x = ~x, y = ~y, fillcolor = "#ffa9a4", line = list(width = 0),
                 hoverinfo = "text", text = "Deteriorated") %>%
    add_polygons(data = lower_green, x = ~x, y = ~y, fillcolor = "#b9ffaf", line = list(width = 0),
                 hoverinfo = "text", text = "Significantly Improved") %>%
    add_polygons(data = middle_grey, x = ~x, y = ~y, fillcolor = "lightgray", line = list(width = 0),
                 hoverinfo = "text", text = "Little Change") %>%
    add_segments(x = minScore, xend = maxScore, y = minScore, yend = maxScore, 
                 line = list(color = "gray", width = 0.25, dash = "dot"), 
                 hoverinfo = "none") %>%
    layout(
      xaxis = list(title = "First Assessment", range = c(minScore, maxScore)),
      yaxis = list(title = "Last Assessment", range = c(minScore, maxScore)),
      showlegend = FALSE
    )
  
  if (is_administrator) {
    hover_text <- paste0(
      "<b>Client:</b> ", dat$client_name,
      "<br><b>First Score:</b> ", round(dat$T1, 1),
      "<br><b>Last Score:</b> ", round(dat$T2, 1),
      "<br><b>Practitioner:</b> ", dat$assigned)
  } else {
    hover_text <- paste0(
      "<b>Client:</b> ", dat$client_name,
      "<br><b>First Score:</b> ", round(dat$T1, 1),
      "<br><b>Last Score:</b> ", round(dat$T2, 1))
  }
  
  p <- p %>%
    add_markers(data = dat, x = ~jitter(T1), y = ~T2, 
                marker = list(size = 6, color = "#3279b7"), 
                hoverinfo = "text", text = hover_text)
  
  # This used to work when it was not done as a function:
  # p$x$data[[1]]$text <- "Deteriorated"
  # p$x$data[[2]]$text <- "Significantly Improved"
  # p$x$data[[3]]$text <- "Little Change"
  
  return(p)
}

# Shiny app
ui <- fluidPage(
  titlePanel("First vs Last Assessment Plot"),
  sidebarLayout(
    sidebarPanel(
      checkboxInput("is_admin", "Administrator View", FALSE)
    ),
    mainPanel(
      plotlyOutput("firstvlast_plot")
    )
  )
)

server <- function(input, output, session) {
  dummy_data <- reactive({
    create_dummy_data()
  })
  
  output$firstvlast_plot <- renderPlotly({
    generate_firstvlast_plot(dummy_data(), input$is_admin)
  })
}

shinyApp(ui, server)

This commented out part was what modified the hovertext over the coloured backgrounds and this worked beautifully. However when created as a function (using the above-mentioned code), I get a subscript out of bounds error because it would appear that p$x$data no longer exists. Instead the hover just shows the colour (either the hex code or 'lightgray'). I've tried adding: hoverinfo = "text", text = "Deteriorated" within the add_polygons but this makes no difference.

Does anyone have any ideas with regard to a plotly plot running in R Shiny (as a function) and how to modify the colour (that is a background) hovertext?

Solution

  • You'll have to build the plotly object before you can modify its data (please see the plotly_build call below):

    library(shiny)
library(plotly)
library(data.table)

# Create dummy data
set.seed(123)
create_dummy_data <- function(n = 50) {
  data.table(
    client_name = paste("Client", 1:n),
    assigned = sample(c("Dr. A", "Dr. B", "Dr. C"), n, replace = TRUE),
    T1 = runif(n, 0, 100),
    T2 = runif(n, 0, 100)
  )
}

# Plot generation function
generate_firstvlast_plot <- function(dat, is_administrator = FALSE) {
  minScore <- 0
  maxScore <- 100
  min_fvl_score <- 10
  
  upper_red <- data.frame(x=c(minScore,minScore,(maxScore-min_fvl_score)),y=c((minScore+min_fvl_score),maxScore, maxScore))
  lower_green <- data.frame(x=c((minScore+min_fvl_score),maxScore,maxScore),y=c(minScore,minScore,(maxScore-min_fvl_score)))
  middle_grey <- data.frame(x=c(minScore, minScore,(maxScore-min_fvl_score),maxScore, maxScore,(minScore+min_fvl_score)), 
                            y=c(minScore, (minScore+min_fvl_score),maxScore,maxScore,(maxScore-min_fvl_score),minScore))
  
  p <- plot_ly(height = 600) %>%
    config(displayModeBar = FALSE) %>%
    add_polygons(data = upper_red, x = ~x, y = ~y, fillcolor = "#ffa9a4", line = list(width = 0),
                 hoverinfo = "text", text = "Deteriorated") %>%
    add_polygons(data = lower_green, x = ~x, y = ~y, fillcolor = "#b9ffaf", line = list(width = 0),
                 hoverinfo = "text", text = "Significantly Improved") %>%
    add_polygons(data = middle_grey, x = ~x, y = ~y, fillcolor = "lightgray", line = list(width = 0),
                 hoverinfo = "text", text = "Little Change") %>%
    add_segments(x = minScore, xend = maxScore, y = minScore, yend = maxScore, 
                 line = list(color = "gray", width = 0.25, dash = "dot"), 
                 hoverinfo = "none") %>%
    layout(
      xaxis = list(title = "First Assessment", range = c(minScore, maxScore)),
      yaxis = list(title = "Last Assessment", range = c(minScore, maxScore)),
      showlegend = FALSE
    )
  
  if (is_administrator) {
    hover_text <- paste0(
      "<b>Client:</b> ", dat$client_name,
      "<br><b>First Score:</b> ", round(dat$T1, 1),
      "<br><b>Last Score:</b> ", round(dat$T2, 1),
      "<br><b>Practitioner:</b> ", dat$assigned)
  } else {
    hover_text <- paste0(
      "<b>Client:</b> ", dat$client_name,
      "<br><b>First Score:</b> ", round(dat$T1, 1),
      "<br><b>Last Score:</b> ", round(dat$T2, 1))
  }
  
  p <- p %>%
    add_markers(data = dat, x = ~jitter(T1), y = ~T2, 
                marker = list(size = 6, color = "#3279b7"), 
                hoverinfo = "text", text = hover_text)
  
  p <- plotly_build(p)
  p$x$data[[1]]$text <- "Deteriorated"
  p$x$data[[2]]$text <- "Significantly Improved"
  p$x$data[[3]]$text <- "Little Change"
  
  return(p)
}

# Shiny app
ui <- fluidPage(
  titlePanel("First vs Last Assessment Plot"),
  sidebarLayout(
    sidebarPanel(
      checkboxInput("is_admin", "Administrator View", FALSE)
    ),
    mainPanel(
      plotlyOutput("firstvlast_plot")
    )
  )
)

server <- function(input, output, session) {
  dummy_data <- reactive({
    create_dummy_data()
  })
  
  output$firstvlast_plot <- renderPlotly({
    generate_firstvlast_plot(dummy_data(), input$is_admin)
  })
}

shinyApp(ui, server)