Shiny 基于用户上传的动态变量下拉线性回归应用

Question

如标题所述，我只是想创建一个 shiny 应用程序，该应用程序允许用户基于导入的 csv 文件生成线性回归图。 导入文件后，应动态更新感兴趣变量的下拉列表。

正如下面的代码所示，我可以使用 mtcars 完成此操作，但我无法对具有不同因变量和自变量的导入文件执行相同操作。

谢谢您的帮助

data(mtcars)
cols <- sort(unique(names(mtcars)[names(mtcars) != 'mpg']))
ui <- fluidPage(
  titlePanel("Build a Linear Model for MPG"),
  sidebarPanel(
    #fluidRow(
      #column(4,
             #tags$h3('Build a Linear Model for MPG'),
              fileInput(
                inputId = "filedata",
                label = "Upload data. csv",
                accept = c(".csv")
              ),
              
              fileInput(
                inputId = "filedata1",
                label = "Upload data. csv",
                accept = c(".csv")
              ),
              
              
                        selectInput('vars',
                         'Select dependent variables',
                         choices = cols,
                         selected = cols[1:2],
                         multiple = TRUE)
              
             

    #)
  ), #sidebarpanel
  
 mainPanel( column(4, verbatimTextOutput('lmSummary')),
  column(4, plotOutput('diagnosticPlot')))
) #fluidpage


server <- function(input, output) {
  
  data <- reactive({
    req(input$filedata)
    read.csv(input$filedata$datapath) %>% rename_all(tolower)  %>%
      filter(driver_name == input$driver_name & county == input$county & model == input$model) 
    
    
  })
  
  
  lmModel <- reactive({lm(sprintf('mpg ~ %s', paste(input$vars, collapse = '+')),
                          data = mtcars)})
  
  # lmModel <- reactive({lm(sprintf('mpg ~ %s', paste(input$vars, collapse = '+')),
  #                         data = mtcars)})
  output$lmSummary <- renderPrint({
    summary(lmModel())
  })
  
  output$diagnosticPlot <- renderPlot({
    par(mfrow = c(2,2))
    plot(lmModel())
  })
}
shinyApp(ui = ui, server = server)```

Answer 1

处理动态菜单：

您的selectInput元素必须放置在 server 部分才能使其具有反应性。 ui部分的东西基本都是static。 在ui部分使用uiOutput ，在server部分使用renderUI 。

• ui 部分（代替 selectInput 块）： uiOutput("var_select_ui")
• 服务器部分（添加）：

output$var_select_ui <- renderUI({
  cols <- colnames(data())
  selectInput(
    'vars',
    'Select dependent variables',
    choices = cols,
    selected = cols[1:2],
    multiple = TRUE
  )
})

Answer 2

要动态 select x 和 y 轴变量，可以尝试以下

ui <- fluidPage(
  titlePanel("Build a Linear Model"),
  sidebarPanel(
    
    fileInput(
      inputId = "filedata",
      label = "Upload data. csv",
      multiple = FALSE,
      accept = c(".csv"),
      buttonLabel = "Choosing ...",
      placeholder = "No files selected yet"
    ),
    uiOutput("xvariable"),
    uiOutput("yvariable")
  ), #sidebarpanel
  
  mainPanel( #DTOutput("tb1"), 
    fluidRow(column(6, verbatimTextOutput('lmSummary')) , column(6, plotOutput('diagnosticPlot')))
  )
) #fluidpage


server <- function(input, output) {
  
  data <- reactive({
    req(input$filedata)
    inData <- input$filedata
    if (is.null(inData)){ return(NULL) }
    mydata <- read.csv(inData$datapath, header = TRUE, sep=",")
  })
  output$tb1 <- renderDT(data())
  
  output$xvariable <- renderUI({
    req(data())
    xa<-colnames(data()) 
    pickerInput(inputId = 'xvar',
                label = 'Select x-axis variable',
                choices = c(xa[1:length(xa)]), selected=xa[1],
                options = list(`style` = "btn-info"))
    
  })
  output$yvariable <- renderUI({
    req(data())
    ya<-colnames(data()) 
    pickerInput(inputId = 'yvar',
                label = 'Select y-axis variable',
                choices = c(ya[1:length(ya)]), selected=ya[2],
                options = list(`style` = "btn-info"))
    
  })
  
  lmModel <- reactive({
    req(data(),input$xvar,input$yvar)
    x <- as.numeric(data()[[as.name(input$xvar)]])
    y <- as.numeric(data()[[as.name(input$yvar)]])
    if (length(x) == length(y)){
      model <- lm(x ~ y, data = data(), na.action=na.exclude)
    }else model <- NULL
    return(model)
  })
  
  output$lmSummary <- renderPrint({
    req(lmModel())
    summary(lmModel())
  })

  output$diagnosticPlot <- renderPlot({
    req(lmModel())
    par(mfrow = c(2,2))
    plot(lmModel())
  })
}

shinyApp(ui = ui, server = server)