R Shiny：从上传的数据运行动态 For 循环答案

【问题标题】：R Shiny: Run dynamic For loop from uploaded dataR Shiny：从上传的数据运行动态 For 循环
【发布时间】：2021-11-25 15:21:36
【问题描述】：

我的 Shiny 应用程序需要一些帮助。我正在创建一个闪亮的应用程序，用户可以在其中上传带有数据的预定义模板，查看它并能够运行线性模型。我的问题是，我无法运行“For”循环。我在“For”循环中有一个“For”循环要运行。基本上，我正在查看的是，为“For”循环的每次迭代运行线性模型。

第一个“For”循环过滤一年的数据，然后第二个“For”循环在一年内为每个参数运行。如果我硬编码“For”循环值（例如：Year ==“2018”& Parameter ==“LDPP”），应用程序可以正常工作，但当我尝试使用动态值 ynames[y] 或 tnames[t] 运行循环时，应用程序无法正常工作代码。

样本数据

Year <- rep(c("2018", "2019"), each = 48)
Zone <- rep(c("South", "West"), each = 24, times = 4)
Location <- rep(c("Bangalore", "Hyderabad", "Ahmedabad", "Gandhinagar"), each = 12, times = 2)
Product <- rep(c("E-Esta", "PAN-60065", "PAN-60098"), each = 4, times = 8)
Rep <- rep(c(1:2), times = 48)
Parameter <- rep(c("FFRM", "FSTR"), times = 48)
Value <- rnorm(96)

data <- data.frame(Year, Zone, Location, Product, Rep, Parameter, Value)

带有 For 循环的代码 - 没有按预期运行

library(shiny) 
library(tidyverse)
library(shinydashboard)
library(DT) 
library(readxl)
library(lme4) 
shinyApp(ui <- navbarPage("Pluto",
      tabPanel("Data Import & Preview",
        sidebarLayout(
          sidebarPanel(width = 2,
            fileInput("file1", "Upload the updated template (only 1 Sheet)", accept = ".xlsx")
            ),
          mainPanel(h2("Data Preview"), DT::dataTableOutput("mytable"), width = 4)
                        )) ,
        tabPanel("Data Analysis",
           sidebarLayout(
             sidebarPanel(width = 2, 
                 actionButton("analysis", "Fire")),
             
             fluidRow(width = 20,
               tabBox(id = "trans",
                 tabPanel("Names View", verbatimTextOutput("tnames", placeholder = T), 
                          verbatimTextOutput("ynames", placeholder = T)),
                 tabPanel("Variance Components", DT::dataTableOutput("varcomp")),
                 tabPanel("Pred Values", DT::dataTableOutput("pred"))
                 
                 )
              )
            )
          )
      ),
server <- function(input, output, session){
data <- reactive({
  req(input$file1)
  read_xlsx(input$file1$datapath)
  })

tnames <- reactive({
  if(is.null(input$file1)){
    return(NULL)
} else {
  tnames <- data() %>% unique(data()$Trait)
}
  }) 
ynames <- reactive({
  if(is.null(input$file1)){
    return(NULL)
  } else {
    ynames <- data() %>% unique(data()$Year)
  }
})

varcomp <- eventReactive(input$analysis, {
  if(is.null(input$file1)){
    return(NULL)
  } else {
    dummy1 <- data.frame()
    dummy2 <- data.frame()
    dummy3 <- data.frame()

    ynames <- unique(data()$Year)
    tnames <- unique(data()$Parameter)

    for(y in 1:length(ynames)){
      d2 <- data() %>% filter(Year == ynames[y]) %>%
        mutate_if(is.character, as.factor)

      for (t in 1:length(tnames[t])) {
        d3 <- d2 %>% filter(Parameter == "tnames[t]") %>%
          mutate_if(is.character, as.factor)

      m1 <- lm(Value ~ Zone + Product + Location, data = d3, na.action = "na.exclude")
      rclic0 <- as_tibble(m1$coefficients) %>% mutate("Year"=ynames[y],"Parameter"= tnames[t])
      fclic0 <- as_tibble(m1$coefficients) %>% mutate("Year"=ynames[y],"Parameter"= tnames[t])
      pred0 <- as_tibble(m1$fitted) %>% mutate("Year" = ynames[y], "Parameter" = tnames[t])
      dummy1 <- rbind(dummy1, rclic0)
      varcomp <- dummy1
     }
    }
  }
})

pred <- eventReactive(input$analysis, {
  if(is.null(input$file1)){
    return(NULL)
  } else {
    dummy1 <- data.frame()
    dummy2 <- data.frame()
    dummy3 <- data.frame()

   ynames <- unique(data()$Year)
   tnames <- unique(data()$Parameter)
   
   for(y in 1:length(ynames)){    # Running 
     d2 <- data() %>% filter(Year == ynames[y]) %>%
        mutate_if(is.character, as.factor)
    for (t in 1:length(tnames)) {
      d3 <- d2 %>% filter(Parameter == tnames[t]) %>%
          mutate_if(is.character, as.factor)
        
     m1 <- lm(Value ~ Zone + Product + Location, data = d3, na.action = "na.exclude")
     rclic0 <- as_tibble(m1$coefficients) %>% mutate("Year"=ynames[y],"Parameter" = tnames[t])
     fclic0 <- as_tibble(m1$coefficients) %>% mutate("Year"=ynames[y],"Parameter" = tnames[t])
        pred0 <- as_tibble(m1$fitted) %>% mutate("Year" = ynames[y], "Parameter" = tnames[t])
        dummy3 <- rbind(dummy3, pred0)
        pred <- dummy3
      }
    }
  }
})  

output$mytable <- renderDataTable(data())
output$ynames <- renderPrint({unique(data()$Year)})
output$tnames <- renderPrint({unique(data()$Parameter)})
output$varcomp <- renderDataTable(varcomp())
output$pred <- renderDataTable(pred())
})

硬编码代码 - 运行良好。

library(shiny)
library(tidyverse)
library(shinydashboard)
library(DT)
library(readxl)
library(lme4)

shinyApp(
ui <- navbarPage("Pluto",
      tabPanel("Data Import & Preview",
        sidebarLayout(
          sidebarPanel(width = 2,
            fileInput("file1", "Upload the updated template (only 1 Sheet)", accept = ".xlsx")
            ),
          mainPanel(h2("Data Preview"), DT::dataTableOutput("mytable"), width = 4)
                        )) ,
        tabPanel("Data Analysis",
           sidebarLayout(
             sidebarPanel(width = 2, 
                 actionButton("analysis", "Fire")),
             
             fluidRow(width = 20,
               tabBox(id = "trans",
                 tabPanel("Names View", verbatimTextOutput("tnames", placeholder = T), 
                          verbatimTextOutput("ynames", placeholder = T)),
                 tabPanel("Variance Components", DT::dataTableOutput("varcomp")),
                 tabPanel("Pred Values", DT::dataTableOutput("pred"))
                 
                 )
              )
            )
          )
      ),
server <- function(input, output, session){
data <- reactive({
  req(input$file1)
  read_xlsx(input$file1$datapath)
  })

tnames <- reactive({
  if(is.null(input$file1)){
    return(NULL)
} else {
  tnames <- data() %>% unique(data()$Trait)
}
})
ynames <- reactive({
  if(is.null(input$file1)){
    return(NULL)
  } else {
    ynames <- data() %>% unique(data()$Year)
  }
})

varcomp <- eventReactive(input$analysis, {
  if(is.null(input$file1)){
    return(NULL)
  } else {

    dummy1 <- data.frame()
    dummy2 <- data.frame()
    dummy3 <- data.frame()

    ynames <- unique(data()$Year)
    tnames <- unique(data()$Parameter)

    #for(y in 1:length(ynames)){
      d2 <- data() %>% filter(Year == 2018) %>%
        mutate_if(is.character, as.factor)

      #for (t in 1:length(tnames)) {
        d3 <- d2 %>% filter(Parameter == "LDPP") %>%
          mutate_if(is.character, as.factor)

        m1 <- lm(Value ~ Zone + Product + Location, data = d3, na.action = "na.exclude")
        rclic0 <- as_tibble(m1$coefficients) %>% mutate("Year" = 2018, "Parameter" = "LDPP")
        fclic0 <- as_tibble(m1$coefficients) %>% mutate("Year" = 2018, "Parameter" = "LDPP")
        pred0 <- as_tibble(m1$fitted) %>% mutate("Year" = 2018, "Parameter" = "LDPP")
        dummy1 <- rbind(dummy1, rclic0)
        varcomp <- dummy1
    # }
  #  }
  }
})

pred <- eventReactive(input$analysis, {
  if(is.null(input$file1)){
    return(NULL)
  } else {
    
    dummy1 <- data.frame()
    dummy2 <- data.frame()
    dummy3 <- data.frame()
    
    ynames <- unique(data()$Year)
    
    tnames <- unique(data()$Parameter)
    
   # for(y in 1:length(ynames)){
d2 <- data() %>% filter(Year == 2018) %>%
        mutate_if(is.character, as.factor)
      
     # for (t in 1:length(tnames)) {
        d3 <- d2 %>% filter(Parameter == "LDPP") %>%
          mutate_if(is.character, as.factor)
        
        m1 <- lm(Value ~ Zone + Product + Location, data = d3, na.action = "na.exclude")
        
       rclic0 <- as_tibble(m1$coefficients) %>% mutate("Year" = 2018, "Parameter" = "LDPP")
       fclic0 <- as_tibble(m1$coefficients) %>% mutate("Year" = 2018, "Parameter" = "LDPP")
       pred0 <- as_tibble(m1$fitted) %>% mutate("Year" = 2018, "Parameter" = "LDPP")
       dummy3 <- rbind(dummy3, pred0)
       pred <- dummy3
     # }
  #  }
  }
})  

output$mytable <- renderDataTable(data())
output$ynames <- renderPrint({unique(data()$Year)})
output$tnames <- renderPrint({unique(data()$Parameter)})
output$varcomp <- renderDataTable(varcomp())
output$pred <- renderDataTable(pred())
})

非常感谢任何帮助。

【问题讨论】：

你试过不使用1:length而只使用变量吗？例如：for(y in ynames) 然后df %>% filter(Year == y)。
您好 Alexb523，感谢您的回复。我确实尝试了你的建议。我没有为我工作。但是 YBS 的以下解决方案确实工作得很好。

标签： r for-loop shiny

【解决方案1】：

您的filter 语法不正确。此外，您还有嵌套 for 循环。通过将外部for 循环切换为lapply，并在内部for 循环中使用local，您可以使其工作。试试这个

  varcomp <- eventReactive(input$analysis, {
    req(data())
    if(is.null(input$file1)){
      return(NULL)
    } else {
      dummy1 <- data.frame()
      dummy2 <- data.frame()
      dummy3 <- data.frame()
      
      ynames <- unique(data()$Year)
      tnames <- unique(data()$Parameter)
      n <- length(ynames)
      lapply(1:n, function(y) {
      #for(yy in 1:n){
        
          d2 <- data() %>% filter(Year == ynames[y]) %>%
            mutate_if(is.character, as.factor)
          m <- length(tnames[y])
          for (t in 1:m) {
            local({
              t <- t
              d3 <- d2 %>% filter(Parameter == as.character(tnames[t])) %>%
                mutate_if(is.character, as.factor)
              
              m1 <- lm(Value ~ Zone + Product + Location, data = d3, na.action = "na.exclude")
              rclic0 <- as_tibble(m1$coefficients) %>% mutate("Year"=ynames[y],"Parameter"= tnames[t])
              fclic0 <- as_tibble(m1$coefficients) %>% mutate("Year"=ynames[y],"Parameter"= tnames[t])
              pred0 <- as_tibble(m1$fitted) %>% mutate("Year" = ynames[y], "Parameter" = tnames[t])
              dummy1 <<- rbind(dummy1, rclic0)
              #varcomp <<- dummy1
            })
            dummy2 <<- rbind(dummy2,dummy1)
          }
        #})
        
      #}
      })
      dummy2
    }
  })

您可以尝试在pred eventReactive 中实现相同的功能。

【讨论】：

您好 YBS，这非常快速且很有帮助。它完全按照我需要的方式工作。非常感激。几个快速澄清的问题。 1. 'local({})' 有什么作用？ 2. 为什么在删除语法错误后嵌套的 for 循环不起作用？ 3. 为什么我们需要为每个输出创建单独的反应事件。 varcomp & pred & son 在这里？
@SandeepPatil，如果此解决方案对您有用，请接受答案。这可能对其他人有所帮助。您可以谷歌了解如何接受答案。你的问题很好。也许您应该对它们进行研究，因为我无法在 cmets 中简要回答。通常for 循环在 Shiny 中不能很好地工作（由于惰性评估）；替代方法是使用lapply。 for循环里面也可以切换到lapply，那么就不需要local()了。