Добавление фильтра в блестящую модель регрессии

У меня есть полностью функционирующее блестящее приложение для выполнения регрессионного анализа с функциями summary(), tidy() и augment(). Тем не менее, я хотел бы добавить выбор фильтра в блестящем для загруженных данных. Мой набор данных довольно большой и внутри набора данных он разделен на 5 типов (таким образом, type_1, type_2, type_3 и т. д.). Прямо сейчас я должен разделить свой набор данных вручную вне блестящего приложения на 5 разных наборов данных, поэтому я могу запускать регрессию только для одного определенного типа за раз.

Было бы здорово иметь возможность выбирать и подбирать тип внутри блеска, не проходя через все эти хлопоты.

Благодарен за всю вашу помощь.

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")
)
3 метода стилизации элементов HTML
3 метода стилизации элементов HTML
Когда дело доходит до применения какого-либо стиля к нашему HTML, существует три подхода: встроенный, внутренний и внешний. Предпочтительным обычно...
Формы c голосовым вводом в React с помощью Speechly
Формы c голосовым вводом в React с помощью Speechly
Пытались ли вы когда-нибудь заполнить веб-форму в области электронной коммерции, которая требует много кликов и выбора? Вас попросят заполнить дату,...
Стилизация и валидация html-формы без использования JavaScript (только HTML/CSS)
Стилизация и валидация html-формы без использования JavaScript (только HTML/CSS)
Будучи разработчиком веб-приложений, легко впасть в заблуждение, считая, что приложение без JavaScript не имеет права на жизнь. Нам становится удобно...
Flatpickr: простой модуль календаря для вашего приложения на React
Flatpickr: простой модуль календаря для вашего приложения на React
Если вы ищете пакет для быстрой интеграции календаря с выбором даты в ваше приложения, то библиотека Flatpickr отлично справится с этой задачей....
В чем разница между Promise и Observable?
В чем разница между Promise и Observable?
Разберитесь в этом вопросе, и вы значительно повысите уровень своей компетенции.
Что такое cURL в PHP? Встроенные функции и пример GET запроса
Что такое cURL в PHP? Встроенные функции и пример GET запроса
Клиент для URL-адресов, cURL, позволяет взаимодействовать с множеством различных серверов по множеству различных протоколов с синтаксисом URL.
0
0
26
1
Перейти к ответу Данный вопрос помечен как решенный

Ответы 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)

Спасибо @YBS, близко, но не совсем, я поместил набор данных, чтобы показать, как может выглядеть набор данных, я хочу иметь возможность выбрать столбец типа (или любой другой столбец) после загрузки моего набора данных.

EnriqueGG 23.04.2022 14:29

Пожалуйста, попробуйте обновленный код.

YBS 23.04.2022 14:50

Другие вопросы по теме