Вот решение, основанное на (абсолютно под звездной) библиотеке ( ipc ).
Я столкнулся с этой библиотекой из-за вопроса @Dean Attali, гдеДжо Ченг упомянул it.
Краткое руководство guide ipc-пакета дает пример того, что вы просите: AsyncProgress.
Кроме того, он предоставляет пример того, как убить будущее, используя AsyncInterruptor.Однако я пока не смог его протестировать.
Я обошел проблему отмены, используя замечательный пакет @Dean Attali smoothjs , чтобы просто начать новый сеанс и игнорировать старыйFuture (Вы можете улучшить это, используя AsyncInterruptor).
Но, тем не менее, я дал ваш код Future, отбросил ваш system() cmd, потому что в настоящее время я запускаю R на Windows, и нашелспособ отключить (дань @Dean Attali) кнопку анализа по сеансам, дав ей зависимые от сеанса имена:
library(shiny)
library(shinydashboard)
library(ipc)
library(promises)
library(future)
library(shinyjs)
library(datasets)
library(V8)
plan(multiprocess)
jsResetCode <- "shinyjs.reset = function() {history.go(0)}"
header <- dashboardHeader(title = "TestApp", titleWidth = 150)
sidebar <- dashboardSidebar(width = 200,
sidebarMenu(id = "tabs",
menuItem(
"File", tabName = "tab1", icon = icon("fas fa-file")
)))
body <- dashboardBody(useShinyjs(),
extendShinyjs(text = jsResetCode),
fluidRow(column(
12, tabItem(
tabName = "tab1",
h2("Input File"),
textOutput("shiny_session"),
tabPanel(
"Upload file",
value = "upload_file",
fileInput(
inputId = "uploadFile",
label = "Upload Input file",
multiple = FALSE,
accept = c(".txt")
),
checkboxInput('header', label = 'Header', TRUE)
),
box(
title = "Filter X rows",
width = 7,
status = "info",
tabsetPanel(
id = "input_tab",
tabPanel(
"Parameters",
numericInput(
"nrows",
label = "Entire number of rows",
value = 5,
max = 10
),
column(1, uiOutput("sessionRun")),
column(1, uiOutput("sessionCancel"))
),
tabPanel(
"Results",
value = "results",
navbarPage(NULL,
tabPanel(
"Table", DT::dataTableOutput("res_table"),
icon = icon("table")
)),
downloadButton("downList", "Download")
)
)
)
)
)))
ui <- shinyUI(dashboardPage(
header = header,
sidebar = sidebar,
body = body,
title = "TestApp"
))
server <- function(input, output, session) {
output$shiny_session <-
renderText(paste("Shiny session:", session$token))
file_rows <- reactiveVal()
run_btn_id <- paste0("run_", session$token)
cancel_btn_id <- paste0("cancel_", session$token)
output$sessionRun <- renderUI({
actionButton(run_btn_id, "Analyze")
})
output$sessionCancel <- renderUI({
actionButton(cancel_btn_id, "Cancel")
})
paste("Shiny session:", session$token)
observeEvent(input[[run_btn_id]], {
file_rows(NULL)
shinyjs::disable(id = run_btn_id)
progress <- AsyncProgress$new(message = 'Analysis in progress',
detail = 'This may take a while...')
row_cnt <- isolate(input$nrows)
get_header <- isolate(input$header)
future({
fileCon <- file("out.txt", "w+", blocking = TRUE)
linesCnt <- nrow(iris)
for (i in seq(linesCnt)) {
Sys.sleep(0.1)
progress$inc(1 / linesCnt)
writeLines(as.character(iris$Species)[i],
con = fileCon,
sep = "\n")
}
close(fileCon)
head_rows <- read.delim("out.txt", nrows = row_cnt, header=get_header)
progress$close() # Close the progress bar
return(head_rows)
}) %...>% file_rows
return(NULL) # Return something other than the future so we don't block the UI
})
observeEvent(input[[cancel_btn_id]],{
js$reset() # reset shiny session)
})
observeEvent(file_rows(), {
shinyjs::enable(id = run_btn_id)
updateTabsetPanel(session, "input_tab", "results")
output$res_table <-
DT::renderDataTable(DT::datatable(
req(file_rows()),
options = list(
searching = TRUE,
pageLength = 10,
rownames(NULL),
scrollX = T
)
))
})
output$downList <- downloadHandler(
filename = function() {
paste0("output", ".txt")
},
content = function(file) {
write.table(file_rows(), file, row.names = FALSE)
}
)
}
shinyApp(ui = ui, server = server)
Приложение работает:
