无法让`future`在多逻辑核上实现并行与并发运行

需求背景 #

• 按钮触发的同步顺序任务耗时极久，需要拆分到多逻辑核运行以提升性能与执行速度
• 使用parallel::parLapply实现同步并行后，无法显示实时进度条或计时器，用户体验差，需实现长任务的非阻塞并发并行

并发并行概念说明 #

并发与并发+并行示意图 #

Concurrency                 Concurrency + parallelism
(Single-Core CPU)           (Multi-Core CPU)
 ___                         ___ ___
|th1|                       |th1|th2|
|   |                       |   |___|
|___|___                    |   |___
    |th2|                   |___|th2|
 ___|___|                    ___|___|
|th1|                       |th1|
|___|___                    |   |___
    |th2|                   |   |th2|

两种并行模式区别 #

• 并发并行：任务可交替执行，同时利用多核CPU资源运行多个任务
• 纯并行：仅依赖多核同时执行任务，无任务交替逻辑

问题描述 #

尝试通过future+promises+ipc组合实现异步并行，第一步先验证Future的并行效果，但在8核计算机上设置workers=7后，Future代码耗时与顺序代码完全一致（约1分01秒），CPU逻辑核使用率远低于50%，任务仍处于顺序执行状态。

代码示例 #

1. 配置workers=7的Future并行代码 #

library(shiny)
library(bslib)
library(ipc)
library(future)
library(promises)
library(openxlsx)

TIMER_NOT_STARTED <- 0L
TIMER_RUNNING <- 1L
TIMER_FINISHED <- 2L

ui <- fluidPage(
    
    titlePanel("4 - Future (with ipc)"),
    
    sidebarLayout(
        sidebarPanel(
            input_task_button(id = "run", "Run")
            #actionButton('run', 'Run')
        ),
        
        mainPanel(
            textOutput("Timer"),
            #tableOutput("result")
        )
    )
)

server <- function(input, output) {
    Timer.Status <- reactiveVal(0)
    Timer.Start <- reactiveVal(0)
    Timer.End <- reactiveVal(0)
    
    x <- 1:1000
    
    GenerateExcelFiles <- function(Row)
    {
        Number <- paste0(paste0(rep("0", NCharTotalNRows - nchar(Row)), collapse = ""), Row)
        OutputFile_Individual <- file.path(OutputFolder, paste0("4 - future with ipc_", Number, ".xlsx"))
        Workbook_Individual <- createWorkbook()
        saveWorkbook(wb = Workbook_Individual, file = OutputFile_Individual, overwrite = TRUE)
    }
    
    # Handle button click
    observeEvent(input$run,{
        Timer.Status(TIMER_RUNNING)
        Timer.Start(as.integer(Sys.time()))
        
        NCharTotalNRows <<- nchar(length(x))
        OutputFolder <<- file.path(".", "Output")
        if(!dir.exists(OutputFolder))   dir.create(OutputFolder)
        
        plan(multisession, workers = 7)
        
        future({
            lapply(c("openxlsx"), library, character.only = TRUE)
            for(i in x){
                GenerateExcelFiles(i)
            }
        }, globals = list("x" = x, "GenerateExcelFiles" = GenerateExcelFiles, "NCharTotalNRows" = NCharTotalNRows, "OutputFolder" = OutputFolder), seed = NULL) %...>% {
            Timer.End(as.integer(Sys.time()))
            Timer.Status(TIMER_FINISHED)
            update_task_button(id = "run", state = "ready")
            plan(sequential)
        }
    })
    
    output$Timer <- renderText({
        Status <- Timer.Status()
        if(Status == TIMER_RUNNING)
        {
            invalidateLater(1000L)
            Timer.End(as.integer(Sys.time()))
            paste("Time elapsed:", format(as.POSIXct(Timer.End() - Timer.Start() - 3600L), "%H:%M:%S"))
        } else if(Status == TIMER_FINISHED)
        {
            paste("Time elapsed:", format(as.POSIXct(Timer.End() - Timer.Start() - 3600L), "%H:%M:%S"))
        }
    })
}

# Run the application
shinyApp(ui = ui, server = server)

2. 顺序执行对比代码 #

library(shiny)
library(bslib)
library(openxlsx)

TIMER_NOT_STARTED <- 0L
TIMER_RUNNING <- 1L
TIMER_FINISHED <- 2L

ui <- fluidPage(
    
    titlePanel("1 - Sequential"),
    
    sidebarLayout(
        sidebarPanel(
            input_task_button(id = "run", "Run")
            #actionButton('run', 'Run')
        ),
        
        mainPanel(
            textOutput("Timer"),
            #tableOutput("result")
        )
    )
)

server <- function(input, output) {
    Timer.Status <- reactiveVal(0)
    Timer.Start <- reactiveVal(0)
    Timer.End <- reactiveVal(0)
    
    x <- 1:1000
    
    GenerateExcelFiles <- function(Row)
    {
        Number <- paste0(paste0(rep("0", NCharTotalNRows - nchar(Row)), collapse = ""), Row)
        OutputFile_Individual <- file.path(OutputFolder, paste0("1 - Sequential_", Number, ".xlsx"))
        Workbook_Individual <- createWorkbook()
        saveWorkbook(wb = Workbook_Individual, file = OutputFile_Individual, overwrite = TRUE)
    }
    
    # Handle button click
    observeEvent(input$run,{
        Timer.Status(TIMER_RUNNING)
        Timer.Start(as.integer(Sys.time()))
        
        NCharTotalNRows <<- nchar(length(x))
        OutputFolder <<- file.path(".", "Output")
        if(!dir.exists(OutputFolder))   dir.create(OutputFolder)
        lapply(X = x, FUN = GenerateExcelFiles)
        Timer.End(as.integer(Sys.time()))
        Timer.Status(TIMER_FINISHED)
    })
    output$Timer <- renderText({
        Status <- Timer.Status()
        if(Status == TIMER_RUNNING)
        {
            invalidateLater(1000L)
            Timer.End(as.integer(Sys.time()))
            paste("Time elapsed:", format(as.POSIXct(Timer.End() - Timer.Start() - 3600L), "%H:%M:%S"))
        } else if(Status == TIMER_FINISHED)
        {
            paste("Time elapsed:", format(as.POSIXct(Timer.End() - Timer.Start() - 3600L), "%H:%M:%S"))
        }
    })
}

# Run the application
shinyApp(ui = ui, server = server)

核心疑问 #

为何配置plan(multisession, workers =7)后，Future代码未实现并行执行，耗时与顺序代码完全一致？

内容的提问来源于stack exchange，提问作者Olivier7121