在管道函数中应用函数时出错

时间:2019-01-01 21:45:41

标签: r

我得到以下结果,我试图在管道命令中应用一个函数。

我正在使用的代码给我以下错误:

sample_rmse_tbl <- dataset %>%
  mutate(rmse = map_dbl(predict, calc_rmse)) %>%
  select(id, rmse)

哪个出现以下错误:

Error in mutate_impl(.data, dots) : 
  Evaluation error: Result 1 is not a length 1 atomic vector.

数据使用太阳黑子数据,下面是我的代码(我遇到的错误是代码的最后一行):

我已经仔细阅读了本教程,直到这行代码为止,一切对我都有效。

---代码是本教程的精简版:https://www.business-science.io/timeseries-analysis/2018/04/18/keras-lstm-sunspots-time-series-prediction.html

# Core Tidyverse
library(tidyverse)
library(glue)
library(forcats)

# Time Series
library(timetk)
library(tidyquant)
library(tibbletime)

# Visualization
library(cowplot)

# Preprocessing
library(recipes)

# Sampling / Accuracy
library(rsample)
library(yardstick) 

# Modeling
library(keras)

sun_spots <- datasets::sunspot.month %>%
  tk_tbl() %>%
  mutate(index = as_date(index)) %>%
  as_tbl_time(index = index)

sun_spots
############################################

periods_train <- 12 * 50
periods_test  <- 12 * 10
skip_span     <- 12 * 20

rolling_origin_resamples <- rolling_origin(
  sun_spots,
  initial    = periods_train,
  assess     = periods_test,
  cumulative = FALSE,
  skip       = skip_span
)

rolling_origin_resamples

############################################

calc_rmse <- function(prediction_tbl) {

  rmse_calculation <- function(data) {
    data %>%
      spread(key = key, value = value) %>%
      select(-index) %>%
      filter(!is.na(predict)) %>%
      rename(
        truth    = actual,
        estimate = predict
      ) %>%
      rmse(truth, estimate)
  }

  safe_rmse <- possibly(rmse_calculation, otherwise = NA)

  safe_rmse(prediction_tbl)

}

#############################################

predict_keras_lstm <- function(split, epochs = 300, ...) {

  lstm_prediction <- function(split, epochs, ...) {

    # 5.1.2 Data Setup
    df_trn <- training(split)
    df_tst <- testing(split)

    df <- bind_rows(
      df_trn %>% add_column(key = "training"),
      df_tst %>% add_column(key = "testing")
    ) %>% 
      as_tbl_time(index = index)

    # 5.1.3 Preprocessing
    rec_obj <- recipe(value ~ ., df) %>%
      step_sqrt(value) %>%
      step_center(value) %>%
      step_scale(value) %>%
      prep()

    df_processed_tbl <- bake(rec_obj, df)

    center_history <- rec_obj$steps[[2]]$means["value"]
    scale_history  <- rec_obj$steps[[3]]$sds["value"]

    # 5.1.4 LSTM Plan
    lag_setting  <- 120 # = nrow(df_tst)
    batch_size   <- 40
    train_length <- 440
    tsteps       <- 1
    epochs       <- epochs

    # 5.1.5 Train/Test Setup
    lag_train_tbl <- df_processed_tbl %>%
      mutate(value_lag = lag(value, n = lag_setting)) %>%
      filter(!is.na(value_lag)) %>%
      filter(key == "training") %>%
      tail(train_length)

    x_train_vec <- lag_train_tbl$value_lag
    x_train_arr <- array(data = x_train_vec, dim = c(length(x_train_vec), 1, 1))

    y_train_vec <- lag_train_tbl$value
    y_train_arr <- array(data = y_train_vec, dim = c(length(y_train_vec), 1))

    lag_test_tbl <- df_processed_tbl %>%
      mutate(
        value_lag = lag(value, n = lag_setting)
      ) %>%
      filter(!is.na(value_lag)) %>%
      filter(key == "testing")

    x_test_vec <- lag_test_tbl$value_lag
    x_test_arr <- array(data = x_test_vec, dim = c(length(x_test_vec), 1, 1))

    y_test_vec <- lag_test_tbl$value
    y_test_arr <- array(data = y_test_vec, dim = c(length(y_test_vec), 1))

    # 5.1.6 LSTM Model
    model <- keras_model_sequential()

    model %>%
      layer_lstm(units            = 50, 
                 input_shape      = c(tsteps, 1), 
                 batch_size       = batch_size,
                 return_sequences = TRUE, 
                 stateful         = TRUE) %>% 
      layer_lstm(units            = 50, 
                 return_sequences = FALSE, 
                 stateful         = TRUE) %>% 
      layer_dense(units = 1)

    model %>% 
      compile(loss = 'mae', optimizer = 'adam')

    # 5.1.7 Fitting LSTM
    for (i in 1:epochs) {
      model %>% fit(x          = x_train_arr, 
                    y          = y_train_arr, 
                    batch_size = batch_size,
                    epochs     = 1, 
                    verbose    = 1, 
                    shuffle    = FALSE)

      model %>% reset_states()
      cat("Epoch: ", i)

    }

    # 5.1.8 Predict and Return Tidy Data
    # Make Predictions
    pred_out <- model %>% 
      predict(x_test_arr, batch_size = batch_size) %>%
      .[,1] 

    # Retransform values
    pred_tbl <- tibble(
      index   = lag_test_tbl$index,
      value   = (pred_out * scale_history + center_history)^2
    ) 

    # Combine actual data with predictions
    tbl_1 <- df_trn %>%
      add_column(key = "actual")

    tbl_2 <- df_tst %>%
      add_column(key = "actual")

    tbl_3 <- pred_tbl %>%
      add_column(key = "predict")

    # Create time_bind_rows() to solve dplyr issue
    time_bind_rows <- function(data_1, data_2, index) {
      index_expr <- enquo(index)
      bind_rows(data_1, data_2) %>%
        as_tbl_time(index = !! index_expr)
    }

    ret <- list(tbl_1, tbl_2, tbl_3) %>%
      reduce(time_bind_rows, index = index) %>%
      arrange(key, index) %>%
      mutate(key = as_factor(key))

    return(ret)

  }

  safe_lstm <- possibly(lstm_prediction, otherwise = NA)

  safe_lstm(split, epochs, ...)

}

#################################################

sample_predictions_lstm_tbl <- rolling_origin_resamples %>%
  mutate(predict = map(splits, predict_keras_lstm, epochs = 10))

sample_predictions_lstm_tbl


sample_predictions_lstm_tbl$predict
map_dbl(sample_predictions_lstm_tbl$predict, calc_rmse)

sample_rmse_tbl <- sample_predictions_lstm_tbl %>%
  mutate(rmse = map_dbl(predict, calc_rmse)) %>%
  select(id, rmse)

EDIT1:

[[11]]
# A time tibble: 840 x 3
# Index: index
   index      value key   
   <date>     <dbl> <fct> 
 1 1949-11-01 144.  actual
 2 1949-12-01 118.  actual
 3 1950-01-01 102.  actual
 4 1950-02-01  94.8 actual
 5 1950-03-01 110.  actual
 6 1950-04-01 113.  actual
 7 1950-05-01 106.  actual
 8 1950-06-01  83.6 actual
 9 1950-07-01  91   actual
10 1950-08-01  85.2 actual
# ... with 830 more rows

EDIT2:

我想出了一种“解决方法”,但与本文的结果有所不同。

temp <- NULL
sample_rmse_tbl <- NULL

for(i in 1:length(sample_predictions_lstm_tbl$predict)){
  temp <- calc_rmse(sample_predictions_lstm_tbl$predict[[i]])
  sample_rmse_tbl[[i]] <- temp
  }

sample_rmse_tbl <- do.call(rbind.data.frame, sample_rmse_tbl)

sample_rmse_tbl %>%
  setNames(., c("metric", "estimator", "rmse")) %>%
  mutate(id = row_number()) %>%
  select(id, rmse)

1 个答案:

答案 0 :(得分:1)

问题在于函数rmse()返回的是列表,而不是单个double值。您需要使用.$.estimate从此列表中选择估计值。但是,我必须删除possibly()调用才能使解决方案正常工作。

因此,新功能calc_rmse()如下所示。

calc_rmse <- function(prediction_tbl) {

  rmse_calculation <- function(data) {
    data %>%
      spread(key = key, value = value) %>%
      select(-index) %>%
      filter(!is.na(predict)) %>%
      rename(
        truth    = actual,
        estimate = predict
      ) %>%
      rmse(truth, estimate)  %>% .$.estimate
  }

  rmse_calculation(prediction_tbl)

}