问题描述
我有一个Shiny应用程序，它可以通过散点图通过plotlyProxy重新设置标记轮廓来构建散点图并突出显示单击的点。 该应用程序还可以对数据进行子集处理，并将与单击的点相对应的条目从原始“数据表”移到“异常表”。
当标记都具有相同的颜色或使用连续变量进行标记时，这似乎很好用。但是，当我使用分类变量（例如“种类”）为点着色时，它具有怪异的行为，将每个类别的标记重新设置为样式，而不是单击的类别。数据子集正确。
我认为，除非另有说明，否则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",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",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)
解决方法
您上面的代码存在的问题是没有为temp_df = audiob_adv['Listening Time'].str.extract(r'(\d+)[^\d]+(\d+)').astype('int32')
audiob_adv["Time"] = temp_df.iloc[:,0]*60 + temp_df.iloc[:,1]
提供traceIndices参数。请参阅this。
在您的示例中，一旦您将颜色切换为因子restyle，就不会再创建一条迹线，而是创建三条迹线。这是在JS中发生的，因此计数是从0到2。
要Species这些迹线，您可以通过curveNumber（在这种情况下为restyle）和pointNumber（每条迹线0:2中有50个数据点）对其进行寻址
使用一条跟踪，您的示例就可以像0:49一样工作，并且跟踪的长度相同（150）。
由于您提供的代码很长，因此我只关注“种类”问题。在所有其他情况下都无法使用，但是您应该可以从中推断出更通用的方法：
key 
作为一种快速的解决方法，为避免创建3条痕迹，我只将分配给color的类别变量转换为数字，然后隐藏了colorbar，所以输出如下所示：
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)
})
更新：
我发现的另一个解决方案是为click事件中的每个跟踪/类别创建一个绘图代理循环。 因此，点击事件如下所示：
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,width = 2
))
)
}
}else{
p %>%
plotlyProxyInvoke(
"restyle",list(marker.line = list(
color = as.vector(ifelse(is_outlier,width = 2
))
)
}
})