Блог

У меня есть довольно большая симуляция, которую я в настоящее время запускаю в Shiny, используя цикл double for, и это занимает очень много времени. Я читал о возможности использования foreach , но у меня ничего не получается, что бы я ни пробовал, я так и попадаю в ошибки. Может быть, кто-нибудь заметит ошибку и поможет мне ее исправить?

приложение.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)

 

Моей целью было изменить data <-... часть с foreach пакетом, и, поскольку мой компьютер работает на 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)
        }
 

Вот способ избежать двойного цикла для использования library(data.table) :

 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)
 

Здесь вы можете найти эталон с учетом dplyr и data.table (среди прочего).