在调用 onRender() 后擦除所有 selectizeInput() 值而不关闭 Shiny 应用程序
Erasing all selectizeInput() values without Shiny app closing after onRender() has been called
我正在尝试创建一个闪亮的应用程序来探索具有 4 variables/columns（A、B、C、D）和 10,000 行的数据框。有一个输入字段，用户必须 select 4 variables/columns 中的 2 个。一旦他们这样做了，就会在右边显示一个散点图。散点图是一个具有六边形分箱的 Plotly 对象，总结了两个用户 selected variables/columns.
之间 10,000 行的值
此时，用户可以 select 一个 "Go!" 按钮，这会导致对应于第一行的橙色点 2 variables/columns 叠加到 Plotly 对象上.用户可以依次select"Go!"，然后第二行、第三行、第四行等对应的橙色点将叠加到Plotly对象上。散点图矩阵上方输出行ID的名称。
在大多数情况下，该应用程序可以正常运行。只有两件事我想改进：
1) 我希望用户能够在输入字段中 select 新对。这在大多数情况下都有效。但是，在一种特定情况下，这会导致应用程序突然关闭。它发生在橙色点被覆盖到散点图之后。如果用户然后擦除这两个输入对，应用程序会突然关闭。我希望用户能够在不关闭应用程序的情况下擦除两个输入对值并输入两个新对值，即使在将橙色点绘制到散点图后也是如此。
2) 我注意到在绘制橙色点后，行 ID 的输出有些滞后。我想知道为什么会发生这种情况，因为我在脚本中绘制橙色点之前输出了行 ID。我更希望有更少的滞后，但我不确定如何处理它。
如有任何关于如何解决这两个问题的建议，我们将不胜感激！我的 MWE 显示此问题如下。
library(plotly)
library(GGally)
library(hexbin)
library(htmlwidgets)
library(tidyr)
library(shiny)
library(dplyr)
library(data.table)
library(ggplot2)
library(tibble)
myPairs <- c("A", "B", "C", "D")
ui <- shinyUI(fluidPage(
titlePanel("title panel"),
sidebarLayout(position = "left",
sidebarPanel(
selectizeInput("selPair", "Pairs:", choices = myPairs, multiple = TRUE, options = list(maxItems = 2)),
actionButton("goButton", "Go!"),
width = 3
),
mainPanel(
verbatimTextOutput("info"),
plotlyOutput("scatMatPlot")
)
)
))
server <- shinyServer(function(input, output, session) {
# Create data and subsets of data based on user selection of pairs
dat <- data.frame(ID = paste0("ID", 1:10000), A = rnorm(10000), B = rnorm(10000), C = rnorm(10000), D = rnorm(10000))
pairNum <- reactive(input$selPair)
group1 <- reactive(pairNum()[1])
group2 <- reactive(pairNum()[2])
sampleIndex <- reactive(which(colnames(dat) %in% c(group1(), group2())))
# Create data subset based on two letters user chooses
datSel <- eventReactive(sampleIndex(), {
datSel <- dat[, c(1, sampleIndex())]
datSel$ID <- as.character(datSel$ID)
datSel <- as.data.frame(datSel)
datSel
})
sampleIndex1 <- reactive(which(colnames(datSel()) %in% c(group1())))
sampleIndex2 <- reactive(which(colnames(datSel()) %in% c(group2())))
# Create background Plotly graph with hex binning all 100 rows of the two user-selected columns
ggPS <- eventReactive(datSel(), {
minVal = min(datSel()[,-1])
maxVal = max(datSel()[,-1])
maxRange = c(minVal, maxVal)
xbins=7
buffer = (maxRange[2]-maxRange[1])/xbins/2
x = unlist(datSel()[,(sampleIndex1())])
y = unlist(datSel()[,(sampleIndex2())])
h <- hexbin(x=x, y=y, xbins=xbins, shape=1, IDs=TRUE, xbnds=maxRange, ybnds=maxRange)
hexdf <- data.frame (hcell2xy (h), hexID = h@cell, counts = h@count)
attr(hexdf, "cID") <- h@cID
p <- ggplot(hexdf, aes(x=x, y=y, fill = counts, hexID=hexID)) + geom_hex(stat="identity") + geom_abline(intercept = 0, color = "red", size = 0.25) + coord_cartesian(xlim = c(maxRange[1]-1*buffer, maxRange[2]+buffer), ylim = c(maxRange[1]-1*buffer, maxRange[2]+buffer)) + coord_equal(ratio=1) + labs(x = colnames(datSel()[sampleIndex1()]), y = colnames(datSel()[sampleIndex2()]))
ggPS <- ggplotly(p)
ggPS})
# Output hex bin plot created just above
output$scatMatPlot <- renderPlotly({
# Each time user pushes Go! button, the next row of the data frame is selected
datInput <- eventReactive(input$goButton, {
g <- datSel()$ID[input$goButton]
# Output ID of selected row
output$info <- renderPrint({
g
})
# Get x and y values of seleced row
currGene <- datSel()[which(datSel()$ID==g),]
currGene1 <- unname(unlist(currGene[,sampleIndex1()]))
currGene2 <- unname(unlist(currGene[,sampleIndex2()]))
c(currGene1, currGene2)
})
# Send x and y values of selected row into onRender() function
observe({
session$sendCustomMessage(type = "points", datInput())
})
# Use onRender() function to draw x and y values of seleced row as orange point
ggPS() %>% onRender("
function(el, x, data) {
noPoint = x.data.length;
Shiny.addCustomMessageHandler('points', function(drawPoints) {
if (x.data.length > noPoint){
Plotly.deleteTraces(el.id, x.data.length-1);
}
var Traces = [];
var trace = {
x: drawPoints.slice(0, drawPoints.length/2),
y: drawPoints.slice(drawPoints.length/2, drawPoints.length),
mode: 'markers',
marker: {
color: 'orange',
size: 7
},
hoverinfo: 'none'
};
Traces.push(trace);
Plotly.addTraces(el.id, Traces);
});}")
})
})
shinyApp(ui, server)
如@HubertL 所述，最好避免嵌套反应函数。如果您更改它，您的应用可能 运行 会更流畅。
关于您的第一个问题，req and validate 可能是最好的解决方法。这些函数检查用户输入是否有效并处理无效输入。
我根据这些建议对您的代码进行了一些调整，但您仍然可以对其进行更多更改。如果仔细查看 ggPS，您可能会注意到它仅使用 datSel()，因此您可以将其转换为函数。
library(plotly)
library(GGally)
library(hexbin)
library(htmlwidgets)
library(tidyr)
library(shiny)
library(dplyr)
library(data.table)
library(ggplot2)
library(tibble)
myPairs <- c("A", "B", "C", "D")
ui <- shinyUI(fluidPage(
titlePanel("title panel"),
sidebarLayout(
position = "left",
sidebarPanel(
selectizeInput("selPair", "Pairs:", choices = myPairs, multiple = TRUE,
options = list(maxItems = 2)),
actionButton("goButton", "Go!"),
width = 3
),
mainPanel(
verbatimTextOutput("info"),
plotlyOutput("scatMatPlot")
)
)
))
server <- shinyServer(function(input, output, session) {
# Create data and subsets of data based on user selection of pairs
dat <- data.frame(
ID = paste0("ID", 1:10000), A = rnorm(10000),
B = rnorm(10000), C = rnorm(10000), D = rnorm(10000),
stringsAsFactors = FALSE
)
# Create data subset based on two letters user chooses
datSel <- eventReactive(input$selPair, {
validate(need(length(input$selPair) == 2, "Select a pair."))
dat[c("ID", input$selPair)]
}, ignoreNULL = FALSE)
# Create background Plotly graph with hex binning all 100 rows of the two user-selected columns
ggPS <- eventReactive(datSel(), {
minVal = min(datSel()[,-1])
maxVal = max(datSel()[,-1])
maxRange = c(minVal, maxVal)
xbins=7
buffer = (maxRange[2]-maxRange[1])/xbins/2
x = unlist(datSel()[input$selPair[1]])
y = unlist(datSel()[input$selPair[2]])
h <- hexbin(x=x, y=y, xbins=xbins, shape=1, IDs=TRUE,
xbnds=maxRange, ybnds=maxRange)
hexdf <- data.frame (hcell2xy (h), hexID = h@cell, counts = h@count)
attr(hexdf, "cID") <- h@cID
p <- ggplot(hexdf, aes(x=x, y=y, fill = counts, hexID=hexID)) +
geom_hex(stat="identity") + geom_abline(intercept = 0, color = "red", size = 0.25) +
coord_cartesian(xlim = c(maxRange[1]-1*buffer, maxRange[2]+buffer),
ylim = c(maxRange[1]-1*buffer, maxRange[2]+buffer)) +
coord_equal(ratio = 1) +
labs(x = input$selPair[1], y = input$selPair[2])
ggPS <- ggplotly(p)
ggPS
})
# Output ID of selected row
output$info <- renderPrint({ datSel()$ID[req(input$goButton)] })
# Output hex bin plot created just above
output$scatMatPlot <- renderPlotly({
# Use onRender() function to draw x and y values of seleced row as orange point
ggPS() %>% onRender("
function(el, x, data) {
noPoint = x.data.length;
Shiny.addCustomMessageHandler('points', function(drawPoints) {
if (x.data.length > noPoint){
Plotly.deleteTraces(el.id, x.data.length-1);
}
var Traces = [];
var trace = {
x: drawPoints.slice(0, drawPoints.length/2),
y: drawPoints.slice(drawPoints.length/2, drawPoints.length),
mode: 'markers',
marker: {
color: 'orange',
size: 7
},
hoverinfo: 'none'
};
Traces.push(trace);
Plotly.addTraces(el.id, Traces);
});}")
})
observe({
# Get x and y values of seleced row
currGene <- datSel()[input$goButton, -1]
# Send x and y values of selected row into onRender() function
session$sendCustomMessage(type = "points", unname(unlist(currGene)))
})
})
shinyApp(ui, server)
我正在尝试创建一个闪亮的应用程序来探索具有 4 variables/columns（A、B、C、D）和 10,000 行的数据框。有一个输入字段，用户必须 select 4 variables/columns 中的 2 个。一旦他们这样做了，就会在右边显示一个散点图。散点图是一个具有六边形分箱的 Plotly 对象，总结了两个用户 selected variables/columns.
之间 10,000 行的值此时，用户可以 select 一个 "Go!" 按钮，这会导致对应于第一行的橙色点 2 variables/columns 叠加到 Plotly 对象上.用户可以依次select"Go!"，然后第二行、第三行、第四行等对应的橙色点将叠加到Plotly对象上。散点图矩阵上方输出行ID的名称。
在大多数情况下，该应用程序可以正常运行。只有两件事我想改进：
1) 我希望用户能够在输入字段中 select 新对。这在大多数情况下都有效。但是，在一种特定情况下，这会导致应用程序突然关闭。它发生在橙色点被覆盖到散点图之后。如果用户然后擦除这两个输入对，应用程序会突然关闭。我希望用户能够在不关闭应用程序的情况下擦除两个输入对值并输入两个新对值，即使在将橙色点绘制到散点图后也是如此。
2) 我注意到在绘制橙色点后，行 ID 的输出有些滞后。我想知道为什么会发生这种情况，因为我在脚本中绘制橙色点之前输出了行 ID。我更希望有更少的滞后，但我不确定如何处理它。
如有任何关于如何解决这两个问题的建议，我们将不胜感激！我的 MWE 显示此问题如下。
library(plotly)
library(GGally)
library(hexbin)
library(htmlwidgets)
library(tidyr)
library(shiny)
library(dplyr)
library(data.table)
library(ggplot2)
library(tibble)
myPairs <- c("A", "B", "C", "D")
ui <- shinyUI(fluidPage(
titlePanel("title panel"),
sidebarLayout(position = "left",
sidebarPanel(
selectizeInput("selPair", "Pairs:", choices = myPairs, multiple = TRUE, options = list(maxItems = 2)),
actionButton("goButton", "Go!"),
width = 3
),
mainPanel(
verbatimTextOutput("info"),
plotlyOutput("scatMatPlot")
)
)
))
server <- shinyServer(function(input, output, session) {
# Create data and subsets of data based on user selection of pairs
dat <- data.frame(ID = paste0("ID", 1:10000), A = rnorm(10000), B = rnorm(10000), C = rnorm(10000), D = rnorm(10000))
pairNum <- reactive(input$selPair)
group1 <- reactive(pairNum()[1])
group2 <- reactive(pairNum()[2])
sampleIndex <- reactive(which(colnames(dat) %in% c(group1(), group2())))
# Create data subset based on two letters user chooses
datSel <- eventReactive(sampleIndex(), {
datSel <- dat[, c(1, sampleIndex())]
datSel$ID <- as.character(datSel$ID)
datSel <- as.data.frame(datSel)
datSel
})
sampleIndex1 <- reactive(which(colnames(datSel()) %in% c(group1())))
sampleIndex2 <- reactive(which(colnames(datSel()) %in% c(group2())))
# Create background Plotly graph with hex binning all 100 rows of the two user-selected columns
ggPS <- eventReactive(datSel(), {
minVal = min(datSel()[,-1])
maxVal = max(datSel()[,-1])
maxRange = c(minVal, maxVal)
xbins=7
buffer = (maxRange[2]-maxRange[1])/xbins/2
x = unlist(datSel()[,(sampleIndex1())])
y = unlist(datSel()[,(sampleIndex2())])
h <- hexbin(x=x, y=y, xbins=xbins, shape=1, IDs=TRUE, xbnds=maxRange, ybnds=maxRange)
hexdf <- data.frame (hcell2xy (h), hexID = h@cell, counts = h@count)
attr(hexdf, "cID") <- h@cID
p <- ggplot(hexdf, aes(x=x, y=y, fill = counts, hexID=hexID)) + geom_hex(stat="identity") + geom_abline(intercept = 0, color = "red", size = 0.25) + coord_cartesian(xlim = c(maxRange[1]-1*buffer, maxRange[2]+buffer), ylim = c(maxRange[1]-1*buffer, maxRange[2]+buffer)) + coord_equal(ratio=1) + labs(x = colnames(datSel()[sampleIndex1()]), y = colnames(datSel()[sampleIndex2()]))
ggPS <- ggplotly(p)
ggPS})
# Output hex bin plot created just above
output$scatMatPlot <- renderPlotly({
# Each time user pushes Go! button, the next row of the data frame is selected
datInput <- eventReactive(input$goButton, {
g <- datSel()$ID[input$goButton]
# Output ID of selected row
output$info <- renderPrint({
g
})
# Get x and y values of seleced row
currGene <- datSel()[which(datSel()$ID==g),]
currGene1 <- unname(unlist(currGene[,sampleIndex1()]))
currGene2 <- unname(unlist(currGene[,sampleIndex2()]))
c(currGene1, currGene2)
})
# Send x and y values of selected row into onRender() function
observe({
session$sendCustomMessage(type = "points", datInput())
})
# Use onRender() function to draw x and y values of seleced row as orange point
ggPS() %>% onRender("
function(el, x, data) {
noPoint = x.data.length;
Shiny.addCustomMessageHandler('points', function(drawPoints) {
if (x.data.length > noPoint){
Plotly.deleteTraces(el.id, x.data.length-1);
}
var Traces = [];
var trace = {
x: drawPoints.slice(0, drawPoints.length/2),
y: drawPoints.slice(drawPoints.length/2, drawPoints.length),
mode: 'markers',
marker: {
color: 'orange',
size: 7
},
hoverinfo: 'none'
};
Traces.push(trace);
Plotly.addTraces(el.id, Traces);
});}")
})
})
shinyApp(ui, server)
如@HubertL 所述，最好避免嵌套反应函数。如果您更改它，您的应用可能 运行 会更流畅。
关于您的第一个问题，req and validate 可能是最好的解决方法。这些函数检查用户输入是否有效并处理无效输入。
我根据这些建议对您的代码进行了一些调整，但您仍然可以对其进行更多更改。如果仔细查看 ggPS，您可能会注意到它仅使用 datSel()，因此您可以将其转换为函数。
library(plotly)
library(GGally)
library(hexbin)
library(htmlwidgets)
library(tidyr)
library(shiny)
library(dplyr)
library(data.table)
library(ggplot2)
library(tibble)
myPairs <- c("A", "B", "C", "D")
ui <- shinyUI(fluidPage(
titlePanel("title panel"),
sidebarLayout(
position = "left",
sidebarPanel(
selectizeInput("selPair", "Pairs:", choices = myPairs, multiple = TRUE,
options = list(maxItems = 2)),
actionButton("goButton", "Go!"),
width = 3
),
mainPanel(
verbatimTextOutput("info"),
plotlyOutput("scatMatPlot")
)
)
))
server <- shinyServer(function(input, output, session) {
# Create data and subsets of data based on user selection of pairs
dat <- data.frame(
ID = paste0("ID", 1:10000), A = rnorm(10000),
B = rnorm(10000), C = rnorm(10000), D = rnorm(10000),
stringsAsFactors = FALSE
)
# Create data subset based on two letters user chooses
datSel <- eventReactive(input$selPair, {
validate(need(length(input$selPair) == 2, "Select a pair."))
dat[c("ID", input$selPair)]
}, ignoreNULL = FALSE)
# Create background Plotly graph with hex binning all 100 rows of the two user-selected columns
ggPS <- eventReactive(datSel(), {
minVal = min(datSel()[,-1])
maxVal = max(datSel()[,-1])
maxRange = c(minVal, maxVal)
xbins=7
buffer = (maxRange[2]-maxRange[1])/xbins/2
x = unlist(datSel()[input$selPair[1]])
y = unlist(datSel()[input$selPair[2]])
h <- hexbin(x=x, y=y, xbins=xbins, shape=1, IDs=TRUE,
xbnds=maxRange, ybnds=maxRange)
hexdf <- data.frame (hcell2xy (h), hexID = h@cell, counts = h@count)
attr(hexdf, "cID") <- h@cID
p <- ggplot(hexdf, aes(x=x, y=y, fill = counts, hexID=hexID)) +
geom_hex(stat="identity") + geom_abline(intercept = 0, color = "red", size = 0.25) +
coord_cartesian(xlim = c(maxRange[1]-1*buffer, maxRange[2]+buffer),
ylim = c(maxRange[1]-1*buffer, maxRange[2]+buffer)) +
coord_equal(ratio = 1) +
labs(x = input$selPair[1], y = input$selPair[2])
ggPS <- ggplotly(p)
ggPS
})
# Output ID of selected row
output$info <- renderPrint({ datSel()$ID[req(input$goButton)] })
# Output hex bin plot created just above
output$scatMatPlot <- renderPlotly({
# Use onRender() function to draw x and y values of seleced row as orange point
ggPS() %>% onRender("
function(el, x, data) {
noPoint = x.data.length;
Shiny.addCustomMessageHandler('points', function(drawPoints) {
if (x.data.length > noPoint){
Plotly.deleteTraces(el.id, x.data.length-1);
}
var Traces = [];
var trace = {
x: drawPoints.slice(0, drawPoints.length/2),
y: drawPoints.slice(drawPoints.length/2, drawPoints.length),
mode: 'markers',
marker: {
color: 'orange',
size: 7
},
hoverinfo: 'none'
};
Traces.push(trace);
Plotly.addTraces(el.id, Traces);
});}")
})
observe({
# Get x and y values of seleced row
currGene <- datSel()[input$goButton, -1]
# Send x and y values of selected row into onRender() function
session$sendCustomMessage(type = "points", unname(unlist(currGene)))
})
})
shinyApp(ui, server)