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

如何解决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"),replace = TRUE)
  COUNTS <- sample(c(1:10),replace = TRUE)
  df <- data.frame(WEEKDAY,LOCATION,EQUIPMENT,COUNTS)
  
  return(df)
}

this_table <-get_data(1) %>% select(WEEKDAY,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","C")),pickerInput('equipment_type',"Choose Equipment:",choices = c("E1","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)

解决方法

更改您的 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()
  })