Блог

Я создал приложение, которое будет использовать модель случайного леса для прогнозирования типа видов в наборе данных Iris. Идея состоит в том, что пользователь может выбрать значение для других input widgets переменных, которые затем использует модель для прогнозирования. Все это работает нормально.

Недавно я решил внедрить журнал, содержащий различные входные данные, временную метку и оценку. Я поместил этот журнал в другой tabPanel , чтобы дать лучший обзор. Все работает нормально, когда я нажимаю кнопку сохранения, входные данные, временная метка и оценка сохраняются в журнале, однако, когда я возвращаюсь к оригиналу tabPanel («Калькулятор»), появляются ошибки, говорящие о том, что количество столбцов не совпадает (или что-то в этом роде, я перевел это с датского).

Кто-нибудь знает, почему возникает эта проблема и как ее исправить?

У меня также возникли проблемы с запуском приложения с помощью кнопки «Запустить приложение» в R. Он отлично работает, когда я выбираю все с помощью ctrl A и нажимаю ctrl enter для запуска кода.

Вот мой код:

 require(shiny)
require(tidyverse)
require(shinythemes)
require(data.table)
require(RCurl)
require(randomForest)
require(mlbench)
require(janitor)
require(caret)
require(recipes)
require(rsconnect)


# Read data
DATA <- datasets::iris

# Rearrange data so the response variable is located in column 1
DATA <- DATA[,c(names(DATA)[5],names(DATA)[-5])]

# Creating a model
model <- randomForest(DATA$Species ~ ., data = DATA, ntree = 500, mtry = 3, importance = TRUE)


.# UI -------------------------------------------------------------------------
ui <- fluidPage(
  navbarPage(title = "Dynamic Calculator",
               
    tabPanel("Calculator", 
  
            sidebarPanel(
              
              h3("Values Selected"),
              br(),
              tableOutput('show_inputs'),
              hr(),
              actionButton("submitbutton", label = "calculate", class = "btn btn-primary", icon("calculator")),
              actionButton("savebutton", label = "Save", icon("save")),
              hr(),
              tableOutput("tabledata")
              
            ), # End sidebarPanel
            
            mainPanel(
              
              h3("Variables"),
              uiOutput("select")
            ) # End mainPanel
              ), # End tabPanel Calculator

  tabPanel("Log",
           br(),
           DT::dataTableOutput("datatable15", width = 300), 
           ) # End tabPanel "Log"
  ) # End tabsetPanel
) # End UI bracket


# Server -------------------------------------------------------------------------
server <- function(input, output, session) {
  
  # Create input widgets from dataset  
  output$select <- renderUI({
    df <- req(DATA)
    tagList(map(
      names(df[-1]),
      ~ ifelse(is.numeric(df[[.]]),
               yes = tagList(sliderInput(
                 inputId = paste0(.),
                 label = .,
                 value = mean(df[[.]], na.rm = TRUE),
                 min = round(min(df[[.]], na.rm = TRUE),2),
                 max = round(max(df[[.]], na.rm = TRUE),2)
               )),
               no = tagList(selectInput(
                 inputId = paste0(.),
                 label = .,
                 choices = sort(unique(df[[.]])),
                 selected = sort(unique(df[[.]]))[1],
               ))
      ) # End ifelse
    )) # End tagList
  })
  
  
  # creating dataframe of selected values to be displayed
  AllInputs <- reactive({
    id_exclude <- c("savebutton","submitbutton")
    id_include <- setdiff(names(input), id_exclude)
    
    if (length(id_include) > 0) {
      myvalues <- NULL
      for(i in id_include) {
        myvalues <- as.data.frame(rbind(myvalues, cbind(i, input[[i]])))
        
      }
      names(myvalues) <- c("Variable", "Selected Value")
      myvalues %>% 
        slice(match(names(DATA[,-1]), Variable))
    }
  })
  
  
  # render table of selected values to be displayed
  output$show_inputs <- renderTable({
    AllInputs()
  })
  
  
  # Creating a dataframe for calculating a prediction
  datasetInput <- reactive({  
    
    df1 <- data.frame(AllInputs(), stringsAsFactors = FALSE)
    input <- transpose(rbind(df1, names(DATA[1])))
    
    write.table(input,"input.csv", sep=",", quote = FALSE, row.names = FALSE, col.names = FALSE)
    test <- read.csv(paste("input.csv", sep=""), header = TRUE)
    
    
  # Defining factor levels for factor variables
    cnames <- colnames(DATA[sapply(DATA,class)=="factor"])
    if (length(cnames)>0){
      lapply(cnames, function(par) {
        test[par] <<- factor(test[par], levels = unique(DATA[,par]))
      })
    }
    
  # Making the actual prediction and store it in a data.frame     
    Prediction <- predict(model,test)
    Output <- data.frame("Prediction"=Prediction)
    print(format(Output, nsmall=2, big.mark=","))
    
    
    
  })
  
  # display the prediction when the submit button is pressed
  output$tabledata <- renderTable({
    if (input$submitbutton>0) { 
      isolate(datasetInput()) 
    } 
  })

# -------------------------------------------------------------------------
  
  # Create the Log 
  saveData <- function(data) {
    data <- as.data.frame(t(data))
    if (exists("datatable15")) {
      datatable15 <<- rbind(datatable15, data)
    } else {
      datatable15 <<- data
    }
  }
  
  loadData <- function() {
    if (exists("datatable15")) {
      datatable15
    }
  }
  
  # Whenever a field is filled, aggregate all form data
  formData <- reactive({
    fields <- c(colnames(DATA[,-1]), "Timestamp", "Prediction")
    data <- sapply(fields, function(x) input[[x]])
    data$Timestamp <- as.character(Sys.time())
    data$Prediction <- as.character(datasetInput())
    data
  })
  
  # When the Submit button is clicked, save the form data
  observeEvent(input$savebutton, {
    saveData(formData())
  })
  
  # Show the previous responses
  # (update with current response when Submit is clicked)
  output$datatable15 <- DT::renderDataTable({
    input$savebutton
    loadData()
  })
  
} # End server bracket

# ShinyApp -------------------------------------------------------------------------
shinyApp(ui, server)

 

При создании вашего реактивного AllInputs , вы делаете цикл на id_include. Проблема в том, что все input[[i]] они не имеют длины 1: они могут быть NULL или иметь длину более одного. Вы не можете использовать cbind для двух переменных разной длины, что приводит к ошибке.

Поэтому я добавил условие перед вычислением myvalues, и все работает нормально :

   # creating dataframe of selected values to be displayed
  AllInputs <- reactive({
    id_exclude <- c("savebutton","submitbutton")
    id_include <- setdiff(names(input), id_exclude)
    if (length(id_include) > 0) {
      myvalues <- NULL
      for(i in id_include) {
        if(!is.null(input[[i]]) amp; length(input[[i]] == 1)){
          myvalues <- as.data.frame(rbind(myvalues, cbind(i, input[[i]])))
        }
      }
      names(myvalues) <- c("Variable", "Selected Value")
      myvalues %>% 
        slice(match(names(DATA[,-1]), Variable))
    }
  })
 

Кстати, поскольку циклы не являются хорошей практикой в R, вы можете захотеть взглянуть на apply функции семейства.