关于r：更改选项卡面板时，表明Shiny忙(或正在加载)

Show that Shiny is busy (or loading) when changing tab panels

(问题描述后跟有代码)

我正在使用Shiny制作Web应用程序，而我正在执行的某些R命令需要几分钟才能完成。我发现我需要向用户提供一些提示，表明Shiny正在运行，否则他们将不断更改侧面板上提供的参数，这只会导致Shiny在初始运行完成后以反应方式重新启动计算。

因此，我创建了一个条件面板，其中显示"正在加载"消息(称为模式)，并带有以下内容(感谢Shiny Google网上论坛的Joe Cheng提供了条件语句)：

1
2
3

# generateButton is the name of my action button
loadPanel <- conditionalPanel("input.generateButton > 0 && $('html').hasClass('shiny-busy')"),
loadingMsg)

如果用户保留在当前选项卡上，则此操作按预期进行。但是，用户可以切换到另一个选项卡(其中可能包含一些需要运行一段时间的计算)，但是加载面板会立即出现并消失，同时R会取消计算，然后仅在完成了。

由于这可能很难看清，因此我提供了一些要在下面运行的代码。您会注意到单击按钮开始计算将产生一个不错的加载消息。但是，当您切换到选项卡2时，R开始运行一些计算，但是无法显示加载消息(也许Shiny没有注册为忙碌？)。如果再次按下按钮重新开始计算，则将正确显示加载屏幕。

我希望在切换到正在加载的选项卡时显示加载消息！

ui.R

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

library(shiny)

# Code to make a message that shiny is loading
# Make the loading bar
loadingBar <- tags$div(class="progress progress-striped active",
tags$div(class="bar", style="width: 100%;"))
# Code for loading message
loadingMsg <- tags$div(class="modal", tabindex="-1", role="dialog",
"aria-labelledby"="myModalLabel","aria-hidden"="true",
tags$div(class="modal-header",
tags$h3(id="myModalHeader","Loading...")),
tags$div(class="modal-footer",
loadingBar))
# The conditional panel to show when shiny is busy
loadingPanel <- conditionalPanel(paste("input.goButton > 0 &&",
"$('html').hasClass('shiny-busy')"),
loadingMsg)

# Now the UI code
shinyUI(pageWithSidebar(
headerPanel("Tabsets"),
sidebarPanel(
sliderInput(inputId="time", label="System sleep time (in seconds)",
value=1, min=1, max=5),
actionButton("goButton","Let's go!")
),

mainPanel(
tabsetPanel(
tabPanel(title="Tab 1", loadingPanel, textOutput("tabText1")),
tabPanel(title="Tab 2", loadingPanel, textOutput("tabText2"))
)
)
))

server.R

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

library(shiny)

# Define server logic for sleeping
shinyServer(function(input, output) {
sleep1 <- reactive({
if(input$goButton==0) return(NULL)
return(isolate({
Sys.sleep(input$time)
input$time
}))
})

sleep2 <- reactive({
if(input$goButton==0) return(NULL)
return(isolate({
Sys.sleep(input$time*2)
input$time*2
}))
})

output$tabText1 <- renderText({
if(input$goButton==0) return(NULL)
return({
print(paste("Slept for", sleep1(),"seconds."))
})
})

output$tabText2 <- renderText({
if(input$goButton==0) return(NULL)
return({
print(paste("Multiplied by 2, that is", sleep2(),"seconds."))
})
})
})

通过Shiny Google小组，Joe Cheng将我指向shinyIncubator软件包，其中正在实现进度条功能(安装shinyIncubator软件包后，请参见?withProgress)。

也许此功能将来会被添加到Shiny包中，但是现在可以使用。

示例：

UI.R

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17

library(shiny)
library(shinyIncubator)

shinyUI(pageWithSidebar(
headerPanel("Testing"),
sidebarPanel(
# Action button
actionButton("aButton","Let's go!")
),

mainPanel(
progressInit(),
tabsetPanel(
tabPanel(title="Tab1", plotOutput("plot1")),
tabPanel(title="Tab2", plotOutput("plot2")))
)
))

SERVER.R

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36

library(shiny)
library(shinyIncubator)

shinyServer(function(input, output, session) {
output$plot1 <- renderPlot({
if(input$aButton==0) return(NULL)

withProgress(session, min=1, max=15, expr={
for(i in 1:15) {
setProgress(message = 'Calculation in progress',
detail = 'This may take a while...',
value=i)
print(i)
Sys.sleep(0.1)
}
})
temp <- cars + matrix(rnorm(prod(dim(cars))), nrow=nrow(cars), ncol=ncol(cars))
plot(temp)
})

output$plot2 <- renderPlot({
if(input$aButton==0) return(NULL)

withProgress(session, min=1, max=15, expr={
for(i in 1:15) {
setProgress(message = 'Calculation in progress',
detail = 'This may take a while...',
value=i)
print(i)
Sys.sleep(0.1)
}
})
temp <- cars + matrix(rnorm(prod(dim(cars))), nrow=nrow(cars), ncol=ncol(cars))
plot(temp)
})
})