Создайте линию разреза в блестящем приложении, используя сочетание наведения и нажмите

Question

Я работаю над блестящим приложением, которое содержит изображение, а затем позволяет нарисовать линию разреза на этом изображении.

Текущее приложение позволяет вам дважды щелкнуть, чтобы создать начальную точку для разреза, и затем оно будет использовать положение при наведении курсора мыши, чтобы создать «конечную» точку для разреза. При перемещении мыши трансект обновляется с новой позицией мыши.

Я хотел бы снова иметь возможность дважды щелкнуть мышью, и это «подтвердило бы» конечную точку трансекта, поэтому теперь трансект будет зафиксирован на месте и не будет реагировать на зависание мыши. Могу ли я как-нибудь это сделать?

library(shiny)
library(magick)
library(ggplot2)


create_image <- function(loaded_image, image_data) {

  displayed_image <- loaded_image +
    geom_point(data = image_data, aes(x = .data$x_values,
                                      y = .data$y_values)) +
    geom_path(data = image_data, aes(x = .data$x_values,
                                     y = .data$y_values
    ),
    color = "black")
  return(displayed_image)
}



ui <- fluidPage(

  titlePanel(""),

  sidebarLayout(
    sidebarPanel(
    ),

    mainPanel(
      plotOutput("current_image_plot", dblclick = "double_click", hover = "hover")
    )
  )
)

server <- function(input, output) {

  image_data <- shiny::reactiveValues()
  image_data$double_click <- data.frame(x_values=c(NA_real_,NA_real_), y_values = c(NA_real_,NA_real_))

  loaded_image <- magick::image_ggplot(image_read("https://jeroen.github.io/images/frink.png"))

  output$current_image_plot <- renderPlot({
    displayed_image <- create_image(loaded_image,
                                    image_data$double_click
    )
    return(displayed_image)
  })

  observeEvent({input$double_click}, {
    clickrow <- data.frame(x_values = input$double_click$x,
                           y_values = input$double_click$y)

    image_data$double_click[1,] <- clickrow

    new_hov<-reactive(
      input$hover
    )  %>% debounce(millis = 150)

    observeEvent(new_hov(), {
      nh <- new_hov()
      hoverrow <- data.frame(x_values = nh$x,
                             y_values = nh$y)

      image_data$double_click[2,] <- hoverrow
    })
  })



}

shinyApp(ui = ui, server = server)

Answer 1

Этого очень легко достичь:

1. Добавить новую переменную n в реактивные значения:

   image_data <- reactiveValues(n = 1)

2. Используйте эту переменную для индексации пары (x, y) в double_click, затем увеличьте ее:

   image_data$double_click[image_data$n, ] <- clickrow

   image_data$n <- image_data$n + 1

3. Используйте его также в событии наведения:

   image_data$double_click[image_data$n, ] <- hoverrow

Это будет добавлять дополнительные точки к траектории. Если вы не хотите больше очков, вы можете отключить события, когда n поворачивается 3.