绘图更新时无法单击交互点

问题描述

在一个闪亮的应用程序中,我有一个可以点击点的图形散点图。单击一个点会启动一个模态,您可以在其中输入一个值,该值存储在数据库中。使用a reactivePoll 该应用程序检查数据库中是否有更新,随后更新绘图。
问题是,当我在更新的图上单击与以前相同的点时,模态对话框不会启动。我必须在不同的位置多次点击同一点才能尝试启动该模式,有时我会成功启动它。
但是,如果我先点击任何其他点,关闭启动的模态,然后点击更新的点,那么相应的模态就会很容易启动。
我不知道确切的原因,但我知道这是由于使用 ggimage::geom_icon 随着 ggiraph::geom_point_interactive 。我该如何解决此问题?

可复制示例

library(shiny)
library(ggiraph)
library(ggplot2)
library(DBI)
library(RSQLite)
library(bslib)
library(ggimage)

# Initialize SQLite database
db <- dbConnect(SQLite(), "points.db")
dbExecute(db, "CREATE TABLE IF NOT EXISTS points (
  id INTEGER PRIMARY KEY,
  value TEXT
)")
dbDisconnect(db)

ui <- page_fluid(
  card(
    card_body(
      girafeOutput("plot")
    )
  )
)

server <- function(input, output, session) {
  # Function to get database values
  get_db_values <- function() {
    db <- dbConnect(SQLite(), "points.db")
    values <- dbGetQuery(db, "SELECT * FROM points")
    dbDisconnect(db)
    return(values)
  }
  
  # Reactive poll to check database changes
  db_values <- reactivePoll(
    intervalMillis = 10000,  # 10 seconds
    session = session,
    checkFun = function() {
      db <- dbConnect(SQLite(), "points.db")
      result <- dbGetQuery(db, "SELECT COUNT(*) as count FROM points")
      dbDisconnect(db)
      return(result$count)
    },
    valueFunc = function() {
      return(get_db_values())
    }
  )
  
  # Create the interactive plot
  output$plot <- renderGirafe({
    values <- db_values()
    completed_points <- values$id
    
    df <- data.frame(
      x = c(1, 2, 3),
      y = c(1, 1, 1),
      id = 1:3,
      tooltip = paste("Point", 1:3),
      icon = ifelse(1:3 %in% completed_points, "checkmark-circle", "ellipse")
    )
    
    p <- ggplot(df, aes(x = x, y = y)) +
      geom_icon(aes(image = icon), size = 0.08) +
      geom_point_interactive(
        aes(tooltip = tooltip,
            data_id = id,
            onclick = sprintf('Shiny.setInputValue("selected_point", %d)', id)),
        size = 20,
        alpha = 0.0001  # Not completely transparent to maintain SVG presence
      ) +
      theme_minimal() +
      xlim(0, 4) +
      ylim(0, 2) +
      theme(axis.text = element_blank(),
            axis.title = element_blank())
    
    girafe(ggobj = p, 
           width_svg = 8, 
           height_svg = 4,
           options = list(
             opts_hover(css = "cursor:pointer;"),
             opts_selection(type = "single", only_shiny = FALSE)
           ))
  })
  
  # Handle point clicks
  observeEvent(input$selected_point, {
    showModal(modalDialog(
      title = paste("Enter value for Point", input$selected_point),
      textInput("point_value", "Value:"),
      footer = tagList(
        modalButton("Cancel"),
        actionButton("submit", "Submit")
      )
    ))
  })
  
  # Handle form submission
  observeEvent(input$submit, {
    req(input$point_value, input$selected_point)
    
    # Store in database
    db <- dbConnect(SQLite(), "points.db")
    dbExecute(db, 
              "INSERT OR REPLACE INTO points (id, value) VALUES (?, ?)",
              params = list(input$selected_point, input$point_value))
    dbDisconnect(db)
    
    removeModal()
  })
}

shinyApp(ui, server)