当点根据类别着色时，在散点图中使用 plotlyProxy 重新设计轨迹是不稳定的

Question

我有一个闪亮的应用程序，它可以构建散点图并通过 plotlyProxy 重新设置标记轮廓来突出显示单击的点。该应用程序还对数据进行子集化，并将与点击点对应的条目从原始“数据table”移动到“异常值table”。

当标记全部为相同颜色时，或者当标记由连续变量着色时，这似乎工作正常。但是当我用一个分类变量（比如“物种”）给点上色时，它有一个奇怪的行为，重新设计每个类别的标记而不是点击的标记。数据子集正确。

我认为 restyle 函数应该更新所有轨迹，除非另有说明，所以我不确定问题到底出在哪里。

这是我的代码：

library(plotly)
library(DT)

    ui <- fluidPage(
     mainPanel(
      fluidRow(
       div(
        column(
            width = 2,
            uiOutput('chartOptions')),
        column(width = 5,
               h3("Scatter plot"),
               plotlyOutput("scatterplot"),
               verbatimTextOutput("click")
        )
      )
),
    hr(),
    div(
        column(width = 6,
               h2("Data Table"),
               div(
                   DT::dataTableOutput(outputId = "table_keep"),
                   style = "height:auto; overflow-y: scroll;overflow-x: scroll;")),
        
        column(width = 6,
               h2("Outlier Data"),
               div(
                   DT::dataTableOutput(outputId = "table_outliers"),
                   style = "height:auto; overflow-y: scroll;overflow-x: scroll;"))
    )
 ))
server <- function(input, output, session){
  datasetInput <- reactive({
     df <- iris
       return(df)
  })

output$chartOptions <- renderUI({#choose variables to plot
    if(is.null(datasetInput())){}
    else {
        list(
            selectizeInput("xAxisSelector", "X Axis Variable",
                           colnames(datasetInput())),
            selectizeInput("yAxisSelector", "Y Axis Variable",
                           colnames(datasetInput())),
            selectizeInput("colorBySelector", "Color By:",
                           c(c("Do not color",colnames(datasetInput()))))
        )      
    }
})

vals <- reactiveValues(#define reactive values for:
    data = NULL,
    data_keep = NULL,
    data_exclude = NULL)

observe({
    vals$data <- datasetInput()
    vals$data_keep <- datasetInput()
    
})

## Datatable 
output$table_keep <- renderDT({
    vals$data_keep      
},options = list(pageLength = 5))

output$table_outliers <- renderDT({
    vals$data_exclude      
},options = list(pageLength = 5))

# mechanism for managing selected points
keys <- reactiveVal()

observeEvent(event_data("plotly_click", source = "outliers", priority = "event"), {
    req(vals$data)
    is_outlier <- NULL
    key_new <- event_data("plotly_click", source = "outliers")$key
    key_old <- keys()
    if (key_new %in% key_old){
        keys(setdiff(key_old, key_new))
    } else {
        keys(c(key_new, key_old))
    }
    is_outlier <- rownames(vals$data) %in% keys()
    
    vals$data_keep <- vals$data[!is_outlier, ]
    vals$data_exclude <- vals$data[is_outlier, ]
    
    plotlyProxy("scatterplot", session) %>%
        plotlyProxyInvoke(
            "restyle", 
            list(marker.line = list(
                    color = as.vector(ifelse(is_outlier,'black','grey')),
                    width = 2
                
            ))
        )
})

observeEvent(event_data("plotly_doubleclick", source = "outliers"), {
    req(vals$data)
    keys(NULL)
    vals$data_keep <- vals$data
    vals$data_exclude <- NULL
    plotlyProxy("scatterplot", session) %>%
        plotlyProxyInvoke(
            "restyle", 
            list(marker.line = list(
                    color = 'grey',
                    width = 2
                )
            ))
        
})

output$scatterplot <- renderPlotly({
    req(vals$data,input$xAxisSelector,input$yAxisSelector)
    dat <- vals$data
    key <- rownames(vals$data)
    x <- input$xAxisSelector
    y <- input$yAxisSelector
    
    if(input$colorBySelector != "Do not color"){
        color <-  dat[, input$colorBySelector] 
    }else{
        color <- "orange"
    }
    
    scatterplot <- dat %>%
        plot_ly(x = dat[,x], y = dat[,y], source = "outliers") %>%
        add_markers(key = key,color = color,
                    marker = list(size = 10, line = list(
                        color = 'grey',
                        width = 2
                    ))) %>%
        layout(showlegend = FALSE)
    
    return(scatterplot)
})


output$click <- renderPrint({#click event data
    d <- event_data("plotly_click", source = "outliers")
    if (is.null(d)) "click events appear here (double-click to clear)" else d
})
}
 shinyApp(ui, server)

Answer 1

上面代码的问题是没有为 restyle 提供 traceIndices 参数。请参阅 this。

在您的示例中，一旦您将颜色切换为因子 Species，绘图就不再创建一个轨迹，而是三个。这发生在 JS 中，因此从 0 到 2 进行计数。

对于 restyle 这些轨迹，您可以通过 curveNumber（在本例中 0:2）和 pointNumber（每个轨迹中有 50 个数据点 0:49）

使用单条跟踪，您的示例与您的 key 一样工作，并且您的跟踪具有相同的长度 (150)。

由于您提供的代码很长，我只关注“物种”问题。它不适用于所有其他情况，但您应该能够从中推导出更通用的方法：

library(shiny)
library(plotly)
library(DT)

ui <- fluidPage(
  mainPanel(
    fluidRow(
      div(
        column(
          width = 2,
          uiOutput('chartOptions')),
        column(width = 5,
               h3("Scatter plot"),
               plotlyOutput("scatterplot"),
               verbatimTextOutput("click")
        )
      )
    ),
    hr(),
    div(
      column(width = 6,
             h2("Data Table"),
             div(
               DT::dataTableOutput(outputId = "table_keep"),
               style = "height:auto; overflow-y: scroll;overflow-x: scroll;")),
      
      column(width = 6,
             h2("Outlier Data"),
             div(
               DT::dataTableOutput(outputId = "table_outliers"),
               style = "height:auto; overflow-y: scroll;overflow-x: scroll;"))
    )
  ))
server <- function(input, output, session){
  datasetInput <- reactive({
    df <- iris
    df$is_outlier <- FALSE
    return(df)
  })
  
  output$chartOptions <- renderUI({#choose variables to plot
    if(is.null(datasetInput())){}
    else {
      list(
        selectizeInput("xAxisSelector", "X Axis Variable",
                       colnames(datasetInput())),
        selectizeInput("yAxisSelector", "Y Axis Variable",
                       colnames(datasetInput())),
        selectizeInput("colorBySelector", "Color By:",
                       c(c("Do not color",colnames(datasetInput()))))
      )      
    }
  })
  
  vals <- reactiveValues(#define reactive values for:
    data = NULL,
    data_keep = NULL,
    data_exclude = NULL)
  
  observe({
    vals$data <- datasetInput()
    vals$data_keep <- datasetInput()
    
  })
  
  ## Datatable 
  output$table_keep <- renderDT({
    vals$data_keep      
  },options = list(pageLength = 5))
  
  output$table_outliers <- renderDT({
    vals$data_exclude      
  },options = list(pageLength = 5))
  
  # mechanism for managing selected points
  keys <- reactiveVal()
  
  myPlotlyProxy <- plotlyProxy("scatterplot", session)
  
  observeEvent(event_data("plotly_click", source = "outliers", priority = "event"), {
    req(vals$data)
    is_outlier <- NULL
    plotlyEventData <- event_data("plotly_click", source = "outliers")
    key_new <- plotlyEventData$key
    key_old <- keys()
    if (key_new %in% key_old){
      keys(setdiff(key_old, key_new))
    } else {
      keys(c(key_new, key_old))
    }
    vals$data[keys(),]$is_outlier <- TRUE
    is_outlier <- vals$data$is_outlier
    vals$data_keep <- vals$data[!is_outlier, ]
    vals$data_exclude <- vals$data[is_outlier, ]
    print(paste("pointNumber:", plotlyEventData$pointNumber))
    print(paste("curveNumber:", plotlyEventData$curveNumber))
      plotlyProxyInvoke(
        myPlotlyProxy,
        "restyle", 
        list(marker.line = list(
          color = as.vector(ifelse(vals$data[vals$data$Species %in% vals$data[plotlyEventData$key, ]$Species, ]$is_outlier,'black','grey')),
          width = 2
        )), plotlyEventData$curveNumber
      )
  })
  
  observeEvent(event_data("plotly_doubleclick", source = "outliers"), {
    req(vals$data)
    keys(NULL)
    vals$data_keep <- vals$data
    vals$data_exclude <- NULL
      plotlyProxyInvoke(
        myPlotlyProxy,
        "restyle",
        list(marker.line = list(
          color = 'grey',
          width = 2
        )
        ))

  })
  
  output$scatterplot <- renderPlotly({
    req(datasetInput(),input$xAxisSelector,input$yAxisSelector)
    dat <- datasetInput()
    key <- rownames(dat)
    x <- input$xAxisSelector
    y <- input$yAxisSelector
    
    if(input$colorBySelector != "Do not color"){
      color <-  dat[, input$colorBySelector] 
    }else{
      color <- "orange"
    }
    
    scatterplot <- dat %>%
      plot_ly(x = dat[,x], y = dat[,y], source = "outliers") %>%
      add_markers(key = key,color = color,
                  marker = list(size = 10, line = list(
                    color = 'grey',
                    width = 2
                  ))) %>%
      layout(showlegend = FALSE)
    
    return(scatterplot)
  })
  
  
  output$click <- renderPrint({#click event data
    d <- event_data("plotly_click", source = "outliers")
    if (is.null(d)) "click events appear here (double-click to clear)" else d
  })
}
shinyApp(ui, server)

Answer 2

作为一种快速解决方法，为了避免创建 3 条轨迹，我只是将分配给颜色的分类变量转换为数字，并隐藏了颜色条，因此输出如下所示：

 output$scatterplot <- renderPlotly({
    req(vals$data,input$xAxisSelector,input$yAxisSelector)
    dat <- vals$data
    key <- rownames(vals$data)
    x <- input$xAxisSelector
    y <- input$yAxisSelector
    
    if(input$colorBySelector != "Do not color"){
        color <-  as.numeric(dat[, input$colorBySelector])
    }else{
        color <- "orange"
    }
    
    scatterplot <- dat %>%
        plot_ly(x = dat[,x], y = dat[,y], source = "outliers") %>%
        add_markers(key = key,color = color, 
                    marker = list(size = 10, line = list(
                        color = 'grey',
                        width = 2
                    ))) %>%
        layout(showlegend = FALSE) %>%
        hide_colorbar()%>% 
        event_register("plotly_click")
    
    return(scatterplot)
})

更新：

我发现的另一个解决方案是为点击事件中的每个跟踪/类别创建一个 plotly 代理循环。所以点击事件看起来像这样：

observeEvent(event_data("plotly_click", source = "outliers", priority = "event"), {
    req(vals$data)

    is_outlier <- NULL
    key_new <- event_data("plotly_click", source = "outliers")$key
    key_old <- keys()
    #keys(c(key_new, key_old))
    if (key_new %in% key_old){
        keys(setdiff(key_old, key_new))
    } else {
        keys(c(key_new, key_old))
    }
    is_outlier <- rownames(vals$data) %in% keys()
    
    vals$data_keep <- vals$data[!is_outlier, ]
    vals$data_exclude <- vals$data[is_outlier, ]
    indices <- list()
    p <- plotlyProxy("scatterplot", session) 
         
    
    if(input$colorBySelector != "Do not color"){
        if(is.factor(vals$data[,input$colorBySelector])){
            for (i in 1:length(levels(vals$data[,input$colorBySelector]))){

                indices[[i]] <- rownames(vals$data[which(vals$data[,input$colorBySelector] == levels(vals$data[,input$colorBySelector])[i]), ])     #retrieve indices for each category
                   
                 plotlyProxyInvoke(p,
                        "restyle", 
                        list(marker.line = list(
                            color = as.vector(ifelse(is_outlier[as.numeric(indices[[i]])],'black','grey')),

                            width = 2

                        )), c(i-1)   #specify the trace (traces are indexed from 0)
                    )

            }
        }else{
            p %>%
                plotlyProxyInvoke(
                    "restyle", 
                    list(marker.line = list(
                        color = as.vector(ifelse(is_outlier,'black','grey')),
                        width = 2

                    ))
                )
        }
    }else{
        p %>%
            plotlyProxyInvoke(
                "restyle", 
                list(marker.line = list(
                    color = as.vector(ifelse(is_outlier,'black','grey')),
                    width = 2

                ))
            )
    }
    
})

当点根据类别着色时，在散点图中使用 plotlyProxy 重新设计轨迹是不稳定的

Restyling traces using plotlyProxy in a scatterplot is unstable when points are colored according to category

r

shiny

r-plotly

plotly.js