使用悬停输入在 Shiny 中注释 ggplot？

Question

我正在开发 Shiny 应用程序。我的应用程序中的图之一是随时间推移芝加哥驱逐的面积图。我在图表上对数据中的峰值和最新值（分别为 2012 年和 2019 年）进行了永久注释。 我想这样做，当您用鼠标悬停在绘图上时，也会出现您的鼠标最接近的任何年份的另一个注释。现在，基于悬停输入的注释会短暂闪烁，然后消失。

这是该应用程序的配对版本，其中只有麻烦的情节，以便您可以看到它的行为，这是相关代码：

# In ui
plotOutput("evict_plot", hover = "hover")

# Current code
output$evict_plot <- renderPlot({
    yr <- ifelse(is.null(input$hover), 0, round(input$hover$x))
    evict_base + 
      {if(yr == 2010)annotate("text", x = 2010.57, y = 25296, 
                                    label = 'atop("23,058 evictions", bold("81.1% back rent cases"))',
                                    family = "lato", parse = TRUE)} +
      < additional if statements >

我认为使用无功值可能会解决问题......

# Attempt using reactive value
output$evict_plot <- renderPlot({
    yr <- reactiveVal()
    yr(0)
    observeEvent(input$hover,
                 yr(round(input$hover$x)))
    evict_base + 
      {if(yr() == 0 | yr() == 2010)annotate("text", x = 2010.57, y = 25296, 
                                    label = 'atop("23,058 evictions", bold("81.1% back rent cases"))',
                                    family = "lato", parse = TRUE)} +
      < additional if statements >

但事实并非如此。当我第一次打开带有无功值实现的应用程序时，2010 被注释了，正如我对上面的代码所期望的那样：

但是，当我将鼠标悬停在绘图上时，应用程序开始挂起：

有谁知道如何使用悬停输入添加一年的注释，该注释将保持不变，直到您将鼠标移近不同的年份（而不是像现在一样短暂闪烁）？我'我将尝试使用 hoverOpts，但我觉得我们应该有一种方法可以仅使用基本的悬停语法来完成此操作，因为我不需要 overOpts 提供的任何附加功能。

谢谢！

Answer 1

这是一种使用 HTML 注释的方式：

library(dplyr)
library(tidyr)
library(ggplot2)
library(shiny)

#evictions <- readr::read_csv("https://raw.githubusercontent.com/fvescia/hover-trouble/main/data/eviction_data_tract.csv")

back_rent <- evictions %>%
  pivot_longer(col = c("case_type_single_action", "case_type_joint_action"),
               names_to = "back_rent",
               values_to = "comp_cases") %>%
  select(filing_year, tract, back_rent, comp_cases) %>%
  group_by(filing_year, back_rent) %>%
  summarize(comp_cases = sum(comp_cases)) %>%
  mutate(back_rent = case_when(
    back_rent == "case_type_single_action" ~ as.factor("No"),
    back_rent == "case_type_joint_action" ~ as.factor("Yes")
  ))

back_rent2 <- back_rent %>%
  group_by(filing_year) %>%
  reframe(
    y = rep(sum(comp_cases), 2),
    percent = rep(comp_cases[1] * 100 / sum(comp_cases), 2)
  )

gg <- ggplot(back_rent, aes(x = filing_year, y = comp_cases)) +
  geom_area(aes(fill = back_rent)) +
  scale_x_continuous(limits = c(2010, 2020.75),
                     breaks = seq(from = 2010, to = 2019, by = 1), expand = c(0, 0)) +
  scale_y_continuous(breaks = seq(from = 0, to = 25000, by = 7500)) +
  scale_fill_manual(values = c("No" = "#fce39e", "Yes" = "#fccb41")) +
  annotate("text", x = 2012, y = 27000,
           label = 'atop("24,762 evictions", bold("80.97% back rent cases"))',
           family = "lato", parse = TRUE) +
  annotate("text", x = 2019, y = 17822,
           label = 'atop("15,584 evictions", bold("78.81% back rent cases"))',
           family = "lato", parse = TRUE) +
  labs(y = "Completed eviction filings", fill = "Back rent case") +
  theme(
    text = element_text(family = "lato"),
    panel.background = element_blank(),
    axis.ticks = element_blank(),
    axis.title.x = element_blank(),
    legend.position = "none"
  )


css <- HTML(
  "
  .annotation {
    position: absolute;
  pointer-events:none;
  z-index: 100;
  background: rgba(245,245,245,0.8);
  border: 1px solid black;
  border-radius: 5px;
  font-size: 16px;
}"
)

shinyApp(
  ui = fluidPage(
    tags$head(tags$style(css)),
    div(
      style = "position: relative;",
      plotOutput("ggplot", hover = hoverOpts("plot_hover")),
      uiOutput("hoverinfo")
    )
  ),

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

    output$hoverinfo <- renderUI({
      hover <- input[["plot_hover"]]
      if(is.null(hover)) return(NULL)
      point <- nearPoints(
        back_rent2, hover, threshold = 50, maxpoints = 1, yvar ="y"
      )
      if(nrow(point) == 0) return(NULL)
      left_pct <-
        (point[["filing_year"]] - hover$domain$left) /
        (hover$domain$right - hover$domain$left)
      top_pct <-
        (hover$domain$top - point[["y"]]) /
        (hover$domain$top - hover$domain$bottom)
      left_px <-
        (hover$range$left + left_pct * (hover$range$right - hover$range$left)) /
        hover$img_css_ratio$x
      right_px <- hover$range$right / hover$img_css_ratio$x - left_px
      top_px <-
        (hover$range$top + top_pct * (hover$range$bottom - hover$range$top)) /
        hover$img_css_ratio$y
      t <- 18/2*3 + 5
      style <-
        ifelse(top_px>t,
               paste0(ifelse(left_pct<0.5,
                             paste0("left: ", left_px + 9 + 5),
                             paste0("right: ", right_px + 9 + 10)), "px; ",
                      "top: ", top_px - t, "px;"),
               paste0("top: ", top_px + 9 + 5, "px; ",
                      "left: ", left_px - 50, "px; ",
                      "min-width: 100px;"))

      tooltip <- HTML(
        sprintf("%s evictions", point[["y"]]), "<br/>",
        sprintf(
          "<b>%s%% back rent cases</b>",
          formatC(point[["percent"]], format = "f", digits = 1)
        )
      )
      div(
        class = "annotation",
        style = style,
        p(tooltip)
      )
    })
  }
)