Bdtjtk

I have the following results and I am trying to apply a function within a pipe command.

The code I am using which gives me the error is the following:

sample_rmse_tbl <- dataset %>%

  mutate(rmse = map_dbl(predict, calc_rmse)) %>%

  select(id, rmse)

Which gives the following error:

Error in mutate_impl(.data, dots) : 

  Evaluation error: Result 1 is not a length 1 atomic vector.

The data uses the sun spots data and the code that I have is the following (the error I run into is the last line of the code):

I have followed the tutorial carefully and everything works for me up until this line of code.

--- The code is a cut down version of this tutorial: 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:

I come up with a "workaround" but I am getting different results to the article.

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)

The problem is that the function rmse() returns a list rather than a single double value. You need to select the estimate value from this list using .$.estimate. However, I had to remove the possibly() call to make my solution work.

So, the new function calc_rmse() looks like this.

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)



}