R闪亮的foreach而不是双for循环

Question

我有一个相当大的模拟，我目前使用双循环在 Shiny 中运行，它需要很长时间。我读到了使用foreach 的可能性，但不管我尝试什么，它都没有成功，我犯了错误。也许有人可以发现错误并帮助我纠正它？

app.R 在此处运行（尽管非常缓慢（在真实数据上），并带有 reprex 的示例数据

require(shiny)
require(tidyverse)
require(foreach) 
require(doMC) 
registerDoMC() 
options(cores = detectCores())

df <- data.frame(a=rnorm(n=26), b=1:26, c=100:125)

calc <- function(let=0.5, var1=0.1, var2=0.5){
  df%>%
    mutate(p1=ifelse(a<let,var1,0))%>%
    mutate(p2=ifelse(a<let, var2,2))%>%
    summarise(mean_b=mean(b*p1),
              mean_c=mean(c*p2))
}

# Define UI for application that draws a histogram
ui <- fluidPage(
  
  # Application title
  titlePanel("Example"),
  
  # Sidebar with a slider input for number of bins 
  sidebarLayout(
    sidebarPanel(
      sliderInput(inputId="selected_let", 
                  label="LET", 
                  value=0.5, 
                  min=0, 
                  max=1, 
                  step=0.1),
      
      submitButton("CALCULATE")
      
      
    ),
    
    
    # Show a plot of the generated distribution
    mainPanel(
      h1(paste0("Table1")),
      tableOutput("table_1"),
      
      h1(paste0("Table2")),
      tableOutput("table_2")
    )
  )
)

# Define server logic required to draw a histogram
server <- function(input, output) {

  
  
  data <- reactive({
    
    data <- data.frame()
    
    for (i in seq(0,1,by=0.1)) {
      for (j in seq(0,1,by=0.1)) {
        
        tmp <- calc(let = input$selected_let, var1 = i, var2 = j)
        tmp_df <- data.frame(var1=i, 
                             var2=j, 
                             mean_b=tmp$mean_b, 
                             mean_c=tmp$mean_c)
        data <- rbind(data, tmp_df)
        
      }
    }
    return(data)
    
  })
  
  
  output$table_1 <-  renderTable({
    data()%>%
      select(var1,var2,mean_b)%>%
      spread(var2, mean_b)
  })
  
  
  output$table_2 <-  renderTable({    
    data()%>%
      select(var1,var2,mean_c)%>%
      spread(var2, mean_c)
  })
  
  
}

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

我的目标是用foreach 包更改data <-... 部分，当我的PC 在UNIX 上运行时，我使用doMC。

替换为：

data <- reactive({
  
  foreach(i=rep(seq(0,1,by=0.1),each=11), 
          j=rep(seq(0,1,by=0.1),times=11), 
          .combine="rbind") %dopar% {
            
            val <- calc(let=input$selected_let,
                        var1=i, 
                        var2=j)
            
            data.frame(var1=i, 
                       var2=j, 
                       mean_b=tmp$mean_b, 
                       mean_c=tmp$mean_c)
          }
  
})

但这最终会导致永久性错误：

我尝试在服务器部分输出require(dplyr)，但这也无济于事。 有什么解决方案的建议吗？

作为独立的，foreach 部分以let=0.5 作为输入运行良好，因为它不在reactive 中

foreach(i=rep(seq(0,1,by=0.1),each=11), 
        j=rep(seq(0,1,by=0.1),times=11), 
        .combine="rbind") %dopar% {
          
          val <- calc(let=0.5,
                      var1=i, 
                      var2=j)
          
          data.frame(var1=i, 
                     var2=j, 
                     mean_b=tmp$mean_b, 
                     mean_c=tmp$mean_c)
        }

Answer 1

这是一种使用library(data.table) 避免双重for循环的方法：

library(shiny)
library(data.table)

set.seed(0)

DF <- data.frame(a = rnorm(n = 26), b = 1:26, c = 100:125)
setDT(DF)

DT <- setDT(expand.grid(var1 = seq(0, 1, by = 0.1), var2 = seq(0, 1, by = 0.1)))
setorder(DT, var1, var2)

calc <- function(DF, let = 0.5, var1 = 0.1, var2 = 0.5) {
  DF[, c("mean_b", "mean_c") := .(b * fifelse(a < let, var1, 0), c * fifelse(a < let, var2, 2))]
  as.list(colMeans(DF[, .(mean_b, mean_c)]))
}

ui <- fluidPage(titlePanel("Example"),
                sidebarLayout(
                  sidebarPanel(
                    sliderInput(
                      inputId = "selected_let",
                      label = "LET",
                      value = 0.5,
                      min = 0,
                      max = 1,
                      step = 0.1
                    ),
                    submitButton("CALCULATE")
                  ),
                  mainPanel(
                    h1(paste0("Table1")),
                    tableOutput("table_1"),
                    h1(paste0("Table2")),
                    tableOutput("table_2")
                  )
                ))

server <- function(input, output) {
  data <- reactive({
    DT[, c("mean_b", "mean_c") := calc(DF, let = input$selected_let, var1 = var1, var2 = var2), by = seq_len(NROW(DT))]
  })
  
  output$table_1 <- renderTable({
    dcast(data(), var1 ~ var2, value.var = "mean_b")
  })
  
  output$table_2 <- renderTable({
    dcast(data(), var1 ~ var2, value.var = "mean_c")
  })
}

shinyApp(ui = ui, server = server)

Here 你可以找到一个考虑到 dplyr 和 data.table（以及其他）的基准。