R 點的閃亮重新着色

Question

賞金明天到期。 此問題的答案有資格獲得+50聲望賞金。 Hixon想讓更多人關注這個問題：

跟蹤交互式繪圖上已選擇的點，以顯示已選擇的內容並按顏色分類。

我想要單擊選擇點並根據顏色對它們進行分組。

我可以將帶有顏色信息的選定點保存到新的數據框中並繪制它，但是我想跟蹤並查看交互式繪圖上已經選擇的內容。

如何在“添加選擇”后顯示/標記已經選擇的點或使其永久化？

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)
    })
  }
)