时间戳

首页 > 解决方案 > R Shiny：使用用户输入预测模型输出

r - R Shiny：使用用户输入预测模型输出

问题描述

我正在开发一个闪亮的应用程序，它将创建一个用户输入表。这些是训练泊松回归模型的输入。然后，我想获取用户创建的表（通过向反应表添加输入行）并将其用作模型预测的测试集。我已经包含了我的代码示例。我怎样才能做到这一点？我不断收到错误消息，说数据不是二维数据框或矩阵。

library(shiny)
library(DT)

#Create a Dataset
get_data <- function(size){
  startTime <- as.POSIXct("2016-01-01")
  endTime <- as.POSIXct("2019-01-31")
  DATE <- as.Date(sample(seq(startTime, endTime, 1), size))
  WEEKDAY <- weekdays(as.Date(DATE))
  LOCATION <- sample(c("A", "B", "C"), size, replace = T, prob = c(0.4, 0.4, 0.2))
  EQUIPMENT <- sample(c("E1", "E2", "E3", "E4"), size, replace = TRUE)
  COUNTS <- sample(c(1:10), size, replace = TRUE)
  df <- data.frame(WEEKDAY, LOCATION, EQUIPMENT, COUNTS)
  
  return(df)
}

this_table <-get_data(1) %>% select(WEEKDAY, LOCATION, EQUIPMENT)
#The goal is to simulate the inputs in the form of a table to be the new data set that will then
#be used in the newdata parameter to model the counts using Poisson regression

#-----------------------------------------------------------------------------------------------
ui <- fluidPage(
    sidebarPanel(
      pickerInput('days_of_week', 'Choose Weekdays:', choices =c("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday")),
      pickerInput('location', "Select Location:", choices = c("A", "B", "C")),
      pickerInput('equipment_type', "Choose Equipment:", choices = c("E1", "E2", "E3", "E4")),
      
      actionButton("add_btn", "Add"),
      actionButton("delete_btn", "Delete"),
      actionButton("predict_btn", "Predict")
    ),
    
    mainPanel(
      DTOutput("shiny_table"),
      hr(),
      DTOutput("prediction_table")
    )
)

server <- function(input, output) {
  
  this_table <- reactiveVal(this_table)
  
  observeEvent(input$add_btn, {
    t = rbind(data.frame(WEEKDAY = input$days_of_week,
                         LOCATION = input$location,
                         EQUIPMENT = input$equipment_type), this_table())
    this_table(t)
  })
  
  observeEvent(input$delete_btn, {
    t = this_table()
    print(nrow(t))
    if (!is.null(input$shiny_table_rows_selected)) {
      t <- t[-as.numeric(input$shiny_table_rows_selected),]
    }
    this_table(t)
  })
  
  
 
  output$shiny_table <- renderDT({
    datatable(this_table(), selection = 'multiple', options = list(
      initComplete = JS(
        "function(settings, json) {",
        "$(this.api().table().header()).css({'background-color': '#000', 'color': '#fff'});",
        "}")
    ))
  })
  
  
  output$prediction_table <- DT::renderDT({
    observeEvent(input$predict_btn, {
      
      train <- get_data(10000)
      factors <- c("WEEKDAY", "LOCATION", "EQUIPMENT")
      train <- train %>% mutate_if(is.character, as.factor)
      
      Model <- glm(COUNTS ~ WEEKDAY + LOCATION + EQUIPMENT, data = train, family = "poisson")
      #summary(Model)
      
      new_data <- this_table()
      new_data$WEEKDAY <- as.factor(new_data$WEEKDAY)
      new_data$LOCATION <- as.factor(new_data$LOCATION)
      new_data$EQUIPMENT <- as.factor(new_data$EQUIPMENT)
      
      df <- data.frame(new_data, PREDICTED_COUNTS = predict(Model, newdata = new_data, type = "response"))
      df
    })
  })
  
  
  
}

shinyApp(ui = ui, server = server)

标签： rshinyregressionpoisson

解决方案

output$prediction_table(...)如下所示更改您的：

predict_df <- eventReactive(input$predict_btn, {
    
    train <- get_data(10000)
    factors <- c("WEEKDAY", "LOCATION", "EQUIPMENT")
    train <- train %>% mutate_if(is.character, as.factor)
    
    Model <- glm(COUNTS ~ WEEKDAY + LOCATION + EQUIPMENT, data = train, family = "poisson")
    #summary(Model)
    
    new_data <- this_table()
    new_data$WEEKDAY <- as.factor(new_data$WEEKDAY)
    new_data$LOCATION <- as.factor(new_data$LOCATION)
    new_data$EQUIPMENT <- as.factor(new_data$EQUIPMENT)
    
    df <- data.frame(new_data, PREDICTED_COUNTS = predict(Model, newdata = new_data, type = "response"))
    df
  })
  
  
  output$prediction_table <- DT::renderDT({
    predict_df()
  })

推荐阅读