时间戳

首页 > 解决方案 > R Shiny：从上传的数据运行动态 For 循环

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

问题描述

我的 Shiny App 需要一些帮助。我正在创建一个闪亮的应用程序，用户可以在其中上传带有数据的预定义模板，查看它并能够运行线性模型。我的问题是，我无法运行“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())
})

任何帮助深表感谢。

标签： rfor-loopshiny

解决方案

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

  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
    }
  })

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

输出

推荐阅读