本文介绍了R绘图+闪亮的反应耦合事件-刷新图表并单击同一图表上的参数的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我整天都在苦苦挣扎，所以希望有人可以为我解释一个可行的解决方案/指出我的方法中的错误.
I've been struggling with this all day, so hopefully somebody can explain a working solution for me/point out the error in my approach.
我想直观地看到这个网络.目的是仅显示直接连接到参考节点的节点.
I have this network I want to visualize.The goal is to only show the nodes that are directly connected to the reference node.
我想在以下情况下更新此图表:1)下拉列表中的参考节点已更改，或者2)单击当前图中应为新参考节点的外围节点之一时.第一个选项有效，但我无法2)正常工作.
I want to update this chart when either 1) the reference node in the drop down list is changed or 2) when I click on one of the outlying nodes in the current plot that should be the new reference node.The first option works, but I can't get 2) to work properly.
在output $ selection中，我目前评论了我认为应该做的事情.当我活跃时，这种奇怪的循环行为就会发生，我不理解.
In output$selection I have currently commented what I thought should do the job. When I active this however weird looping behaviour happens that I don't understand.
我应该添加些什么才能获得上述功能?下面是一个可复制的示例.
What should I add to get the above described functionality?Below a reproducible example.
library(plotly)
library(shiny)
library(dplyr)
library(tidyr)
### Selectionlist
varidlist = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'), stringsAsFactors = F)
derivedvaridlist = data.frame(derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)
chartlist = data.frame(charts = paste0('1.1.', 1:9), stringsAsFactors = F)
selectionOptions = c(varidlist$varid, derivedvaridlist$derivedvarid, chartlist$charts)
ui <- fluidPage(
mainPanel(
fixedRow(selectInput('selectedID', label = 'Select varid',
choices = selectionOptions,
selected = 'VAR1')),
fixedRow(plotlyOutput("network"))
),
verbatimTextOutput("selection")
)
server <- function(input, output, session) {
createGraph <- function(selectedID){
varidlist = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'), stringsAsFactors = F)
derivedvaridlist = data.frame(derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)
chartlist = data.frame(charts = paste0('1.1.', 1:9), stringsAsFactors = F)
selectionOptions = c(varidlist$varid, derivedvaridlist$derivedvarid, chartlist$charts)
varid_derivedvarid = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'),
derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)
chart_varidderivedvarid = data.frame(chart = c('1.1.1'),
varidderivedvarid = c('OAP1', 'DERIVEDVAR1', 'DERIVEDVAR2', 'DERIVEDVAR3', 'DERIVEDVAR4'),
stringsAsFactors = F)
# if selectedID is VAR
if(selectedID %in% varidlist$varid){
adjacencyMatrix = varid_derivedvarid %>%
filter(varid == selectedID) %>%
mutate(type = 'derivedvarid') %>%
bind_rows(chart_varidderivedvarid %>%
filter(varidderivedvarid == selectedID) %>%
rename(varid = varidderivedvarid,
derivedvarid = chart) %>%
mutate(type='chart')) %>%
select(derivedvarid, varid, type)
nodeMatrix = adjacencyMatrix %>%
select(derivedvarid, type) %>%
add_row(derivedvarid=selectedID, type='varid')
}
# if selectedID is DERIVEDVAR
if(selectedID %in% derivedvaridlist$derivedvarid){
adjacencyMatrix = varid_derivedvarid %>%
filter(derivedvarid == selectedID) %>%
mutate(type = 'varid') %>%
bind_rows(chart_varidderivedvarid %>%
filter(varidderivedvarid == selectedID) %>%
rename(varid = varidderivedvarid,
derivedvarid = chart) %>%
mutate(type='chart')) %>%
select(derivedvarid, varid, type)
nodeMatrix = adjacencyMatrix %>%
select(varid, type) %>%
add_row(varid=selectedID, type='derivedvarid')
}
# if selectedID is chart
if(selectedID %in% chartlist$charts) {
adjacencyMatrix = chart_varidderivedvarid %>%
filter(chart == selectedID) %>%
mutate(type = '',
type = replace(type, varidderivedvarid %in% varidlist$varid, 'varid'),
type = replace(type, varidderivedvarid %in% derivedvaridlist$derivedvarid, 'derivedvarid')) %>%
select(varidderivedvarid, chart, type)
nodeMatrix = adjacencyMatrix %>%
select(varidderivedvarid, type) %>%
add_row(varidderivedvarid=selectedID, type='chart')
}
# Create all vertices:
nrNodes = dim(adjacencyMatrix)[1]
# Reference node coordinates
x0 = 0
y0 = 0
r = 4
nodes = data.frame(angles = 2*pi / nrNodes * 1:nrNodes,
nodeKey = adjacencyMatrix[, 1]) %>%
mutate(angles = angles + rnorm(n(), mean = 0, sd = .15), # Add noise to angle to avoid overlap in x-coordinate
x = x0 + r * cos(angles),
y = y0 + r * sin(angles)) %>%
add_row(x=x0, y=y0, nodeKey = selectedID)
# Create edges
edges = nodes %>%
select(x, y, nodeKey) %>%
filter(nodeKey != selectedID) %>%
mutate(x0=x0, y0=y0)
edge_shapes <- list()
for(i in 1:dim(edges)[1]) {
edge_shape = list(
type = "line",
line = list(color = "#030303", width = 0.3),
x0 = edges$x0[i],
y0 = edges$y0[i],
x1 = edges$x[i],
y1 = edges$y[i]
)
edge_shapes[[i]] <- edge_shape
}
# Layout for empty background
emptyBackground = list(title = "",
showgrid = FALSE,
showticklabels = FALSE,
zeroline = FALSE)
# Plot plotly
p = plot_ly(nodes, source='networkplot') %>%
add_trace(x = ~x, y = ~y, type = 'scatter',
mode = 'text', text = ~nodeKey,
textposition = 'middle',
hoverinfo='text',
textfont = list(color = '#000000', size = 16)) %>%
layout(title='Network',
showlegend = FALSE,
shapes = edge_shapes,
xaxis = emptyBackground,
yaxis = emptyBackground)
return(p)
}
output$network <- renderPlotly({
selectedID = input$selectedID
createGraph(selectedID)
})
output$selection <- renderPrint({
s <- event_data("plotly_click", source = "networkplot")
if (length(s) == 0) {
"Click on a node to use it as reference node"
} else {
# Get id of clicked node
plotdata = plotly_data(createGraph(input$selectedID))
newvarid = plotdata$nodeKey[s$pointNumber + 1]
# updateSelectInput(session,
# inputId = 'selectedID',
# label = 'Select ID',
# choices = selectionOptions,
# selected = newvarid)
# Get chart coordinates
cat("You selected: \n\n")
# as.list(s)
newvarid
}
})
}
shinyApp(ui, server, options = list(display.mode = "showcase"))
推荐答案
此处的窍门是避免循环反应事件.使用注释的updateSelectInput函数时，由于更新的输入会触发renderPrint函数，而renderPrint会更新菜单，因此您会陷入循环.
The trick here is to avoid circular reactive events. When using the updateSelectInput function you commented out, you end up in a loop because the updated input triggers the renderPrint function and renderPrint updates the menu.
您可以通过引入observe()函数来打破此行为.一种方法是将updateSelectInput()函数粘贴到observeEvent()函数中，该函数仅在用户单击绘图时才触发，而在使用下拉菜单时才触发.此功能将忽略来自input$selectedID的所有更新.请参阅下面的完整示例.我在底部指出了部分代码.
You can break this behaviour by introducing observe() functions. One way to do this is to stick the updateSelectInput() function into an observeEvent() function that is only triggered if the user clicks on the plot and not if the dropdown menu is used. Any updates coming from input$selectedID are ignored by this function. Please see the full example below. I indicated the part of the code that changed at the bottom.
library(plotly)
library(shiny)
library(dplyr)
library(tidyr)
### Selectionlist
varidlist = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'), stringsAsFactors = F)
derivedvaridlist = data.frame(derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)
chartlist = data.frame(charts = paste0('1.1.', 1:9), stringsAsFactors = F)
selectionOptions = c(varidlist$varid, derivedvaridlist$derivedvarid, chartlist$charts)
ui <- fluidPage(
mainPanel(
fixedRow(selectInput('selectedID', label = 'Select varid',
choices = selectionOptions,
selected = 'VAR1')),
fixedRow(plotlyOutput("network"))
),
verbatimTextOutput("selection")
)
server <- function(input, output, session) {
createGraph <- function(selectedID){
varidlist = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'), stringsAsFactors = F)
derivedvaridlist = data.frame(derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)
chartlist = data.frame(charts = paste0('1.1.', 1:9), stringsAsFactors = F)
selectionOptions = c(varidlist$varid, derivedvaridlist$derivedvarid, chartlist$charts)
varid_derivedvarid = data.frame(varid = c('VAR1', 'VAR2', 'VAR3'),
derivedvarid = paste0('DERIVEDVAR', 1:18), stringsAsFactors = F)
chart_varidderivedvarid = data.frame(chart = c('1.1.1'),
varidderivedvarid = c('OAP1', 'DERIVEDVAR1', 'DERIVEDVAR2', 'DERIVEDVAR3', 'DERIVEDVAR4'),
stringsAsFactors = F)
# if selectedID is VAR
if(selectedID %in% varidlist$varid){
adjacencyMatrix = varid_derivedvarid %>%
filter(varid == selectedID) %>%
mutate(type = 'derivedvarid') %>%
bind_rows(chart_varidderivedvarid %>%
filter(varidderivedvarid == selectedID) %>%
rename(varid = varidderivedvarid,
derivedvarid = chart) %>%
mutate(type='chart')) %>%
select(derivedvarid, varid, type)
nodeMatrix = adjacencyMatrix %>%
select(derivedvarid, type) %>%
add_row(derivedvarid=selectedID, type='varid')
}
# if selectedID is DERIVEDVAR
if(selectedID %in% derivedvaridlist$derivedvarid){
adjacencyMatrix = varid_derivedvarid %>%
filter(derivedvarid == selectedID) %>%
mutate(type = 'varid') %>%
bind_rows(chart_varidderivedvarid %>%
filter(varidderivedvarid == selectedID) %>%
rename(varid = varidderivedvarid,
derivedvarid = chart) %>%
mutate(type='chart')) %>%
select(derivedvarid, varid, type)
nodeMatrix = adjacencyMatrix %>%
select(varid, type) %>%
add_row(varid=selectedID, type='derivedvarid')
}
# if selectedID is chart
if(selectedID %in% chartlist$charts) {
adjacencyMatrix = chart_varidderivedvarid %>%
filter(chart == selectedID) %>%
mutate(type = '',
type = replace(type, varidderivedvarid %in% varidlist$varid, 'varid'),
type = replace(type, varidderivedvarid %in% derivedvaridlist$derivedvarid, 'derivedvarid')) %>%
select(varidderivedvarid, chart, type)
nodeMatrix = adjacencyMatrix %>%
select(varidderivedvarid, type) %>%
add_row(varidderivedvarid=selectedID, type='chart')
}
# Create all vertices:
nrNodes = dim(adjacencyMatrix)[1]
# Reference node coordinates
x0 = 0
y0 = 0
r = 4
nodes = data.frame(angles = 2*pi / nrNodes * 1:nrNodes,
nodeKey = adjacencyMatrix[, 1]) %>%
mutate(angles = angles + rnorm(n(), mean = 0, sd = .15), # Add noise to angle to avoid overlap in x-coordinate
x = x0 + r * cos(angles),
y = y0 + r * sin(angles)) %>%
add_row(x=x0, y=y0, nodeKey = selectedID)
# Create edges
edges = nodes %>%
select(x, y, nodeKey) %>%
filter(nodeKey != selectedID) %>%
mutate(x0=x0, y0=y0)
edge_shapes <- list()
for(i in 1:dim(edges)[1]) {
edge_shape = list(
type = "line",
line = list(color = "#030303", width = 0.3),
x0 = edges$x0[i],
y0 = edges$y0[i],
x1 = edges$x[i],
y1 = edges$y[i]
)
edge_shapes[[i]] <- edge_shape
}
# Layout for empty background
emptyBackground = list(title = "",
showgrid = FALSE,
showticklabels = FALSE,
zeroline = FALSE)
# Plot plotly
p = plot_ly(nodes, source='networkplot') %>%
add_trace(x = ~x, y = ~y, type = 'scatter',
mode = 'text', text = ~nodeKey,
textposition = 'middle',
hoverinfo='text',
textfont = list(color = '#000000', size = 16)) %>%
layout(title='Network',
showlegend = FALSE,
shapes = edge_shapes,
xaxis = emptyBackground,
yaxis = emptyBackground)
return(p)
}
###############################################################################################
### Updated part
# Define reactive data
values <- reactiveValues(newvarid = NULL) # ID = "VAR1"
# Observer for change in dropdown menu
# observeEvent(input$selectedID, {
# values$ID = input$selectedID
# })
# Update dropdown menue based on click event
observeEvent(event_data("plotly_click", source = "networkplot"), {
s <- event_data("plotly_click", source = "networkplot")
plotdata = plotly_data(createGraph(input$selectedID))
values$newvarid = plotdata$nodeKey[s$pointNumber + 1]
updateSelectInput(session,
inputId = 'selectedID',
label = 'Select ID',
choices = selectionOptions,
selected = values$newvarid)
})
# Render Plot
output$network <- renderPlotly({
createGraph(input$selectedID)
})
# Render text
output$selection <- renderPrint({
if (is.null(values$newvarid)) {
"Click on a node to use it as reference node"
} else {
# Get chart coordinates
cat("You selected: \n\n")
# as.list(s)
values$newvarid
}
})
}
shinyApp(ui, server, options = list(display.mode = "showcase"))
我不确定反应式values$newvarid是否真的必要.
I am not sure if the reactive values$newvarid is really necessary.
这篇关于R绘图+闪亮的反应耦合事件-刷新图表并单击同一图表上的参数的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！