R 点的闪亮重新着色

Question

我想要单击选择点并根据颜色对它们进行分组。

我可以将带有颜色信息的选定点保存到新的数据框中并绘制它，但是我想跟踪并查看交互式绘图上已选择的内容。

如何在“添加选择”后显示/标记已选择的点或使其永久化？

library(shiny)
library(tidyverse)
library(DT)
library(colourpicker)

ui = fluidPage(
    colourInput("col", "Select colour", "purple"),
    actionButton("addToDT", "Add selection", icon = icon("plus")), hr(),
    plotOutput("plot", click = "plot_click", dblclick = "plot_reset"),
    DT::dataTableOutput('plot_DT'), hr(),
    textOutput("clickcoord"),
    DT::dataTableOutput('final_DT'),
    plotOutput("plotSelected")
)

server = function(input, output, session) {
    
    selectedPoint = reactiveVal(rep(FALSE, nrow(mtcars)))
    
    output$clickcoord <- renderPrint({
        print(input$plot_click)
    })
    
    observeEvent(input$plot_click, {
        clicked = nearPoints(mtcars, input$plot_click, allRows = TRUE)$selected_
        selectedPoint(clicked | selectedPoint())
    })
    
    observeEvent(input$plot_reset, {
        selectedPoint(rep(FALSE, nrow(mtcars)))
    })
    
    output$plot_DT = DT::renderDataTable({
        mtcars$sel = selectedPoint()
        mtcars = dplyr::filter(mtcars, sel == TRUE) %>% mutate(group_color = input$col)
    })
    
    final_DT = reactiveValues()
    final_DT$df = data.frame()
    
    FinalData = eventReactive(input$addToDT, {
        mtcars$sel = selectedPoint()
        mtcars = dplyr::filter(mtcars, sel == TRUE) %>% mutate(group_color = input$col)
        final_DT$df = bind_rows(final_DT$df, mtcars)
    })
    
    output$final_DT = renderDataTable({FinalData()})
    
    output$plot = renderPlot({
        mtcars$sel = selectedPoint()
        ggplot(mtcars, aes(wt, mpg, color =  mtcars$sel, fill=mpg)) +
            geom_point(shape = 21, size = 6, stroke = 2) + 
            scale_color_manual(values = c("#ffffff00", input$col)) + 
            scale_fill_viridis_c() + 
            theme_bw()
    })
    
    output$plotSelected = renderPlot({
        sel_df = FinalData()
        ggplot(sel_df, aes(wt, mpg, fill = group_color, colour = group_color)) +
            geom_point(shape = 21, size = 6, stroke = 2) + 
            scale_color_manual(values = unique(sel_df$group_color)) + 
            scale_fill_manual(values = unique(sel_df$group_color)) + 
            theme_bw()
    })
    
    observeEvent(input$addToDT, {
        selectedPoint(rep(FALSE, nrow(mtcars)))
    })
}

shinyApp(ui, server)

Answer 1

我认为这是您正在寻找的“症结”。我使用了在帮助中找到的一个非常相似的示例，标题为：

单击、悬停和刷动的演示

（https://shiny.rstudio.com/reference/shiny/0.13.1/plotoutput）

它与你的例子非常相似。

我创建了一个 T/F 元素矩阵，其中行是观测值，列是选择观测值的批次。因此，当您启动时，整个矩阵为 False，但当您单击观察结果时，第一列中会切换为正值。然后，如果您单击 addSelection 并继续，您将开始切换下一列中的观察结果。您能确认这就是您正在寻找的吗？下面是代码。

shinyApp(
  ui = basicPage(
    fluidRow(
      column(
        width = 4,
        plotOutput("plot",
                   height = 300,
                   click = "plot_click", # Equiv, to click=clickOpts(id='plot_click')
        ),
        actionButton("addToDT", "Add selection", icon = icon("plus")), hr(),
        h4("Clicked points"),
        tableOutput("plot_clickedpoints"),
      ),
      column(
        width = 4,
        verbatimTextOutput("counter"),
      ),
    )
  ),
  server = function(input, output, session) {
    data <- reactive({
      input$newplot
      # Add a little noise to the cars data so the points move
      cars + rnorm(nrow(cars))
    })
    output$plot <- renderPlot({
      d <- data()
      plot(d$speed, d$dist, main = paste("No of Sets Chosen", input$addToDT))
    })
    output$plot_clickinfo <- renderPrint({
      cat("Click:
")
      str(input$plot_click)
    })
    
    selectedPoints <- reactiveVal(rep(FALSE, nrow(cars)))
    selectionMatrix <- reactiveVal(matrix(data = F, nrow = nrow(cars), ncol = 7))
    
    observeEvent(input$plot_click, {
      clicked <- nearPoints(data(), input$plot_click, "speed", "dist", allRows = TRUE)$selected
      selectedPoints(clicked | selectedPoints())
      tmp <- unlist(selectionMatrix())
      tmp[, (input$addToDT + 1)] <- selectedPoints()
      selectionMatrix(tmp)
    })
    observeEvent(input$addToDT, {
      selectedPoints(rep(FALSE, nrow(cars)))
    })
    output$plot_clickedpoints <- renderTable({
      #  if (input$addToDT==0) {
      res <- selectionMatrix()
      return(res)
    })
  }
)