为回归模型添加过滤器

Question

我有一个功能齐全的闪亮应用程序，用于执行回归分析，带有 summary()、tidy() 和 augment()。但是，我想在闪亮的上传数据中添加一个过滤器 selection。我的数据集很大，在数据集中，它分为 5 种类型，（因此，type_1、type_2、type_3 等）。现在我必须在闪亮的应用程序之外手动将我的数据集划分为 5 个不同的数据集，所以我一次只能运行回归一种特定类型。

如果能够选择并 select 闪亮的类型，而无需经历所有这些麻烦，那就太好了。

感谢您的帮助。

library(shiny)
library(shinyWidgets) 
library(DT)
library(dplyr)
library(nlme)
library(broom)

ui <- navbarPage("dd",
                 tabPanel("Reg",
                          sidebarPanel(
                            fileInput(
                              inputId = "filedata",
                              label = "Upload data. csv",
                              multiple = FALSE,
                              accept = c(".csv"),
                              buttonLabel = "Choosing ...",
                              placeholder = "No files selected yet"
                            ),
                            uiOutput("xvariable"),
                            uiOutput("yvariable")
                          ), 
                          
                          mainPanel( 
                            DTOutput("tb1"), 
                            fluidRow(
                              column(6, verbatimTextOutput('lmSummary')),
                              column(6,verbatimTextOutput("tid")),
                              column(6,verbatimTextOutput("aug"))
                            ) 
                          )
                 )
)

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

  })
  

  
}

shinyApp(ui, server)

上传的数据集是什么样的，为了更好的解释

data_set <- data.frame (Simulation_1  = c(1,2,3,4,5,6,7,8,9,10),
                  Simulation_2 = c(1,2,3,4,5,6,7,8,9,10),
                  Simulation_3 = c(1,2,3,4,5,6,7,8,9,10),
                  type = c("type_1", "type_2", "Type_5",
                           "type_1", "type_2", "Type_3",
                           "type_1", "type_2", "Type_1","Type_4")
)

Answer 1

也许您正在寻找这个

library(shiny)
library(shinyWidgets)
library(DT)
library(dplyr)
library(nlme)
library(broom)

data_set <- data.frame (Simulation_1  = c(1,2,3,4,5,6,7,8,9,10),
                        Simulation_2 = c(1,2,3,4,5,6,7,8,9,10),
                        Simulation_3 = c(1,2,3,4,5,6,7,8,9,10),
                        type = c("type_1", "type_2", "Type_5",
                                 "type_1", "type_2", "Type_3",
                                 "type_1", "type_2", "Type_1","Type_4")
)

ui <- navbarPage("dd",
                 tabPanel("Reg",
                          sidebarPanel(
                            fileInput(
                              inputId = "filedata",
                              label = "Upload data. csv",
                              multiple = FALSE,
                              accept = c(".csv"),
                              buttonLabel = "Choosing ...",
                              placeholder = "No files selected yet"
                            ),
                            uiOutput("col"),
                            uiOutput("type"),
                            uiOutput("xvariable"),
                            uiOutput("yvariable")
                          ),

                          mainPanel(
                            DTOutput("tb1"), 
                            fluidRow(
                              column(6, verbatimTextOutput('lmSummary')),
                              column(6,verbatimTextOutput("tid")),
                              column(6,verbatimTextOutput("aug"))
                            )
                          )
                 )
)
server <- function(input, output, session) {

  data_0 <- reactive({
    # req(input$filedata)
    # inData <- input$filedata
    # if (is.null(inData)){ return(NULL) }
    # mydata <- read.csv(inData$datapath, header = TRUE, sep=",")
    data_set
  })

  output$tb1 <- renderDT(head(data_1()))
  
  output$col <- renderUI({
    req(data_0())
    selected = colnames(data_0())[length(colnames(data_0()))]
    selectInput("mycol", "Choose column", choices = colnames(data_0()), selected = selected)
  })

  output$type <- renderUI({
    req(data_0(),input$mycol)
    selectInput("mytype", "Choose Type", choices = unique(data_0()[[input$mycol]]))
  })

  data_1 <- eventReactive(input$mytype, {
    req(data_0(),input$mycol,input$mytype)
    df <- data_0()
    df$newvar <- df[[input$mycol]]
    df %>% dplyr::filter(newvar %in% input$mytype) %>% dplyr::select(- c(newvar))
  })

  output$xvariable <- renderUI({
    req(data_1())
    xa<-colnames(data_1())
    pickerInput(inputId = 'xvar',
                label = 'Select x-axis variable',
                choices = c(xa[1:length(xa)]), selected=xa[2],
                options = list(`style` = "btn-info"),
                multiple = TRUE)

  })
  output$yvariable <- renderUI({
    req(data_1())
    ya<-colnames(data_1())
    pickerInput(inputId = 'yvar',
                label = 'Select y-axis variable',
                choices = c(ya[1:length(ya)]), selected=ya[1],
                options = list(`style` = "btn-info"),
                multiple = FALSE)

  })

  lmModel <- reactive({
    req(data_1(),input$xvar,input$yvar)
    x <- as.numeric(data_1()[[as.name(input$xvar)]])
    y <- as.numeric(data_1()[[as.name(input$yvar)]])
    current_formula <- paste0(input$yvar, " ~ ", paste0(input$xvar, collapse = " + "))
    current_formula <- as.formula(current_formula)
    model <- lm(current_formula, data = data_1(), na.action=na.exclude)
    return(model)
  })

  output$lmSummary <- renderPrint({
    req(lmModel())
    summary(lmModel())
  })

  output$tid <- renderPrint({
    req(lmModel())
    tidy(lmModel())

  })

  output$aug <- renderPrint({
    req(lmModel())
    augment(lmModel())

  })

}

shinyApp(ui, server)

为回归模型添加过滤器

adding filter to the shiny for regression model

r

dplyr

shiny