J'ai une application Shiny qui crée un nuage de points et met en évidence les points cliqués en redessinant le contour du marqueur via plotlyProxy. L'application sous-ensembles également les données et déplace les entrées correspondant aux points cliqués de la «table de données» d'origine vers une «table des valeurs aberrantes».

Cela semble fonctionner correctement lorsque les marqueurs sont tous de la même couleur ou lorsqu'ils sont colorés par une variable continue. Mais quand je colore les points par une variable catégorielle (comme "Espèce"), il a un comportement étrange, restyling un marqueur de chaque catégorie au lieu de celui cliqué. Les sous-ensembles de données correctement.

Je pense que la fonction de restyle devrait mettre à jour toutes les traces, sauf indication contraire, donc je ne sais pas où se situe exactement le problème.

Voici mon code:

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)
1
Wanda 21 sept. 2020 à 15:57

2 réponses

Meilleure réponse

Le problème avec votre code ci-dessus est qu'aucun argument traceIndices n'est fourni pour restyle. Veuillez consulter ceci < / a>.

Dans votre exemple, une fois que vous avez basculé la coloration sur le facteur Species, l'intrigue ne crée plus une trace, mais trois. Cela se produit dans JS donc le comptage se fait de 0 à 2.

Pour restyle ces traces, vous pouvez les adresser via curveNumber (dans ce cas 0:2) et pointNumber (50 points de données dans chaque trace 0:49)

Avec une seule trace, votre exemple fonctionne comme votre key et votre trace a la même longueur (150).

Comme votre code fourni est assez long, je me suis concentré sur le problème des "espèces". Cela ne fonctionnera pas dans tous les autres cas, mais vous devriez pouvoir en déduire une approche plus générale:

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)

result

0
ismirsehregal 24 sept. 2020 à 10:58

Pour contourner rapidement le problème, pour éviter de créer 3 traces, j'ai simplement converti la variable catégorielle affectée à la couleur en numérique et j'ai masqué la barre de couleurs, de sorte que la sortie ressemble à ceci:

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

Mise à jour:

Une autre solution que j'ai trouvée est de créer une boucle de proxys tracés pour chaque trace / catégorie dans l'événement de clic. Ainsi, l'événement de clic ressemble à ceci:

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

                ))
            )
    }
    
})
0
Wanda 30 sept. 2020 à 15:52