3

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?

1 Answer 1

3

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)
Sign up to request clarification or add additional context in comments.

1 Comment

Thanks for your response! That works perfectly :)

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.