R/scorecard_update.R

In greatgray/scorecard: GGCM Model Performance Scorecard

#' Update scorecard data
#'
#' Creates a scorecard workspace file by updating all actual, benchmark,
#' and out-of-sample model performance statistics.  Uses
#' a manual transaction history for actual performance.  Uses a
#' scorecard definition file (YAML format) to identify model names, types,
#' and configuration settings for actual, buy-hold, and OOS analysis.
#' For each model referred to in the scorecard definition file, there
#' is a corresponding model configuration file (YAML format).
#' @param scorecard_dir the scorecard output directory for scorecard
#' workspace archive
#' @param scorecard_file the path to the scorecard configuration file (YAML)
#' @param transaction_file the path to the transactions mapping file (CSV)
#' @param date_start the analysis history time start, sufficiently long
#' to accommoate model technical indicator generation
#' @param init_date the partnership scorecard start date, used
#' for buy-hold start and other purposes
#' @param switch_date the first date for transactions to be considered
#' part of the partnership model operations regime
#' @param init_eq an initial equity value to be used for each model
#' when computing out-of-sample performance
#' @return nothing, side effects are writing workspace archive
#' (an environment object) to disk
#' @seealso scorecard_produce
#' @export
scorecard_update <- function(scorecard_dir=NA,
                             scorecard_file=NA,
                             transaction_file=NA,
                             date_start="2012-01-01",
                             init_date="2016-08-01",
                             switch_date="2016-08-05",
                             init_eq=250000) {

  # sequence the dependencies
  require(magrittr,quietly=TRUE)
  require(tidyr,quietly=TRUE)
  require(xts,quietly=TRUE)
  require(blotter,quietly=TRUE)
  require(ggplot2,quietly=TRUE)

  # options for many functions
  o1 <- options("stringsAsFactors" = FALSE)
  # o2 <- options("getSymbols.auto.assign" = FALSE)
  # o3 <- options("getSymbols.warning4.0" = FALSE)
  on.exit(options(o1), add=TRUE)
  # on.exit(options(o2), add=TRUE)
  # on.exit(options(o3), add=TRUE)
  `%nin%` <- Negate(`%in%`)

  # production algorithm
  cash_ticker <- "#CASH"
  benchmark_symbol <- "SPY"
  Sys.setenv(TZ = "UTC")
  acct_name <- "ggcm"
  port_name <- "model"
  refresh_date <- lubridate::today()

  # check output location now so we don't wait to discover it's missing
  # existence handles symbolic links, but does not check access
  if (is.na(scorecard_dir) || stringr::str_length(scorecard_dir) < 1) {
    stop("Scorecard output directory missing: use argument scorecard_dir")
  }

  # 1. initialize scorecard framework
  if ( is.na(scorecard_file) || !file.exists(scorecard_file)) {
    stop("Scorecard input file missing: use argument scorecard_file")
  }
  scorecard <- yaml::yaml.load_file(scorecard_file)
  scorecard$table$activated <- lapply(scorecard$table$activated, function(i){
    i$status <- "activated"
    return(i)
  })
  scorecard$table$candidate <- lapply(scorecard$table$candidate, function(i){
    i$status <- "candidate"
    return(i)
  })
  scorecard$table$deactivated <- lapply(scorecard$table$deactivated, function(i){
    i$status <- "deactivated"
    return(i)
  })
  scorecard$table$retired <- lapply(scorecard$table$retired, function(i){
    i$status <- "retired"
    return(i)
  })

  # universe of tickers across all baskets
  scorecard_tickers <- c() # filled later as set union

  # 2. initialize transaction history
  if ( is.na(transaction_file) || !file.exists(transaction_file))
    stop(paste("Cannot find transaction CSV file", transaction_file))

  # transactions from manual file
  get_transactions <- function(f) {
    #suppressPackageStartupMessages(require(dplyr))
    tdf <- read.csv(transaction_file,stringsAsFactors = FALSE) %>%
      dplyr::filter(Model!="") %>%
      dplyr::mutate(Date=as.Date(Date,format="%m/%d/%y"))
    #unloadNamespace("dplyr")
    return(tdf)
  }
  transactions.df <- get_transactions(transaction_file)
  transaction_tickers <- unique( subset(transactions.df,
                                        Ticker!=cash_ticker)[,'Ticker'] )

  # identify model configuration files from scorecard
  scorecard_table <- c(
    scorecard$table$activated,
    scorecard$table$candidate,
    scorecard$table$deactivated,
    scorecard$table$retired
  )
  model_files <-
    unlist(lapply(scorecard_table, function(x)
      return (x$config)))

  # compute benchmark returns applicable to every model
  ignore <- scorecard:::get_and_adjust(benchmark_symbol,
                           init_date,
                           switch_date,
                           scorecard_tickers,
                           adjust=TRUE)
  scorecard_tickers <- union(scorecard_tickers, benchmark_symbol)
  benchmark_returns <- diff(quantmod::Cl(log(get(benchmark_symbol))))[-1, ]
  colnames(benchmark_returns) <- "Benchmark"
  benchmark_cumulatives <-
    cumprod(1 + benchmark_returns)
  benchmark_annual_percent <-
    as.numeric(PerformanceAnalytics::Return.annualized(benchmark_returns)) * 100
  benchmark_calmar_ratio <-
    as.numeric(PerformanceAnalytics::CalmarRatio(benchmark_returns))
  benchmark_sortino_ratio <-
    as.numeric(PerformanceAnalytics::SortinoRatio(benchmark_returns, MAR = 0))
  benchmark_max_drawdown_percent <-
    PerformanceAnalytics::maxDrawdown(benchmark_returns) * 100

  # load model configurations
  scorecard_table <- lapply(scorecard_table, function(scorecard_row){
    if ( "config" %in% names(scorecard_row) ) {
      scorecard_row$model <-
        yaml::yaml.load_file(file.path("models",
                                       scorecard_row$config))
    }

    return(scorecard_row)
  })

  ##########
  # compute actual performance by transaction for traded models
  # assumes model loaded into row during prior iteration
  # assumes backet element history loaded during prior iteration
  if ( isNamespaceLoaded("dplyr") )
    unloadNamespace("dplyr")
  scorecard_table <- lapply(scorecard_table, function(scorecard_row) {
    model_name <- scorecard_row$id
    rv <- scorecard_row

    # skip rows not activated
    if ( length(scorecard_row$model) > 0) {
      if ( scorecard_row$status == "activated") {

        if ( getOption("verbose"))
          message(paste("Computing actuals for", model_name))

        model_basket <- scorecard_row$model$config$basket

        # clear the blotter account and portfolios for this model
        # use actual initial equity value from scorecard
        ignore <- scorecard:::reset_quantstrat()
        ignore <- blotter::initPortf(name = port_name,
                           model_basket,
                           initDate = init_date,
                           currency = "USD")
        ignore <- blotter::initAcct(name = acct_name,
                          portfolios = c(port_name),
                          initDate = init_date,
                          initEq = init_eq)
        ignore <- sapply(model_basket, function(m) {
          FinancialInstrument::stock(m, currency = "USD")
        })

        # ensure basket element tickers have been fetched
        # do NOT adjust prices here for actual performance
        ignore <- scorecard:::get_and_adjust(model_basket,
                                 init_date,
                                 switch_date,
                                 scorecard_tickers,
                                 adjust=FALSE)
        scorecard_tickers <<- base::union(scorecard_tickers, model_basket)

        # add transactions to blotter
        model_transactions.df <-
          subset(transactions.df, Model == scorecard_row$model$model )
        model_non_cash.df <-
          subset(model_transactions.df, Ticker != cash_ticker)
        model_cash.df <-
          subset(model_transactions.df, Ticker == cash_ticker)

        # perform cash transactions
        ignore <- by(model_cash.df,
           seq_len(nrow(model_cash.df)),
           function(ti){
             rv <- switch(ti$Action,
                          "Buy" = function(ti) {
                            if ( getOption("verbose"))
                              message(paste("Add cash transaction",
                                            ti$Date,
                                            ti$Shares,
                                            ti$Note))
                            addAcctTxn(
                              Account = acct_name,
                              TxnDate = ti$Date,
                              TxnType = "Additions",
                              Amount = ti$Shares, # positive
                              verbose = getOption("verbose")
                            )
                          },
                          "Sell" = function(ti) {
                            if ( getOption("verbose"))
                              message(paste("Remove cash transaction",
                                            ti$Date,
                                            ti$Shares,
                                            ti$Note))
                            addAcctTxn(
                              Account = acct_name,
                              TxnDate = ti$Date,
                              TxnType = "Withdrawals",
                              Amount = ti$Shares, # negative
                              verbose = getOption("verbose")
                            )
                          },
                          function(ti) {
                            warning(paste("Actual cash switch did not match",
                                          ti$ie.type))
                          }
             )
             rv(ti)
           })

        ignore <- blotter::updatePortf(port_name)
        ignore <- blotter::updateAcct(acct_name)
        ignore <- blotter::updateEndEq(acct_name)

        # perform non-cash transactions
        ignore <- by(model_non_cash.df,
           seq_len(nrow(model_non_cash.df)),
           function(ti) {
             # switch returns a function having ti parameter
             rv <- switch(ti$Action,
                          "Buy" = function(ti) {
                            if ( getOption("verbose"))
                              message(paste("Buy transaction",
                                            ti$Date,
                                            ti$Ticker,
                                            ti$Shares))
                            if ( ti$Shares < 0 )
                              warning(paste("Buy transaction",
                                            ti$Date,
                                            ti$Ticker,
                                            ti$Shares,
                                            "shares negative"))

                            fees <- ifelse(is.na(ti$Comm), 0, -abs(ti$Comm))
                            if ( ti$Ticker != cash_ticker ) {
                              addTxn(
                                Portfolio = port_name,
                                Symbol = ti$Ticker,
                                TxnDate = ti$Date,
                                TxnPrice = ti$Price,
                                TxnQty = ti$Shares,
                                TxnFees = fees,
                                verbose = getOption("verbose")
                              )
                            }
                          },
                          "Sell" = function(ti) {
                            if ( getOption("verbose"))
                              message(paste("Sell transaction",
                                            ti$Date,
                                            ti$Ticker,
                                            ti$Shares))

                            if ( ti$Shares > 0 )
                              warning(paste("Sell transaction",
                                            ti$Date,
                                            ti$Ticker,
                                            ti$Shares,
                                            "shares positive"))

                            fees <- ifelse(is.na(ti$Comm),0,-abs(ti$Comm))
                            if ( ti$Ticker != cash_ticker ) {
                              addTxn(
                                Portfolio = port_name,
                                Symbol = ti$Ticker,
                                TxnDate = ti$Date,
                                TxnPrice = ti$Price,
                                TxnQty = ti$Shares,
                                TxnFees = fees,
                                verbose = getOption("verbose")
                              )
                            }
                          },
                          function(ti) {
                            warning(paste("Actual non-cash switch did not match",
                                          ti$ie.type))
                          }
             )
             rv(ti)
           }
        ) # by transaction

        last_date <- xts::last(model_transactions.df)$date
        ignore <- blotter::updatePortf(port_name)
        ignore <- blotter::updateAcct(acct_name)
        ignore <-blotter::updateEndEq(acct_name)

        # portfolio plot sanity check
        model_stats <- blotter::getAccount(acct_name)$portfolios$model

        # account-level equity, return, cumulative
        account_summary <- blotter::getAccount(acct_name)$summary
        asr <- diff( log( account_summary$End.Eq ))
        colnames(asr) <- "Return"
        asr[1, 'Return'] <- 0
        asr$Cumulative <- cumprod( 1 + asr$Return )
        account_summary <- merge( account_summary, asr)

        p1 <-
          scorecard:::plot_model_stat(account_summary$End.Eq,
                          paste(model_name,
                                "Account Stats: Ending Equity"))

        # component returns
        pr <- blotter::PortfReturns(acct_name,
                                    Portfolios = port_name,
                                    period = "daily")
        colnames(pr) <- gsub(".DailyEndEq", "", colnames(pr))
        cr <- cumprod(1 + pr)

        # account returns
        # NB: doesn't account for cash
        #ar <- blotter::AcctReturns(acct_name)
        #colnames(ar) <- "Actual"
        #ar[1,1] <- 0
        #ar[is.na(ar)] <- 0
        #ar$Cumulative <- cumprod(1+ar)

        # portfolio return status
        pm <- pr
        pm$Actual <- rowSums(pm, na.rm = TRUE)
        pm$Cumulative <- cumprod(1 + pm$Actual)

        # individual component position plots, saved as list, NA if no position
        # use plot(cplots[[1]]) to recover graphic
        cplots <- lapply(model_basket, function(mt) {
          pf <- blotter::getPortfolio(port_name)
          position <- pf$symbols[[mt]]$txn$Pos.Qty
          rv <- NA
          if (nrow(position) > 1)
            rv <- scorecard:::plot_position(port_name, mt)
          return(rv)
        })

        # component return plots
        pr.df <- data.frame(pr)
        pr.df$Date = zoo::index(pr)
        gf <- pr.df %>%
          tidyr::gather(Symbol, Return, -Date)
        p2 <-
          ggplot2::ggplot(gf,
                          ggplot2::aes(x = Date,
                                       y = Return,
                                       color = Symbol)) +
          ggplot2::geom_line() +
          ggplot2::facet_wrap( ~ Symbol,
                               nrow = 3,
                               scales = "fixed") +
          ggplot2::xlab(NULL) +
          ggplot2::guides(color = FALSE) +
          ggplot2::ggtitle(paste(model_name, "Basket Element Returns"))

        p3 <-
          ggplot2::ggplot(gf,
                          ggplot2::aes(x = Return,
                                       fill = Symbol,
                                       color = Symbol)) +
          ggplot2::geom_histogram(binwidth = 0.01) +
          ggplot2::geom_density() +
          ggplot2::guides(fill = FALSE, color = FALSE) +
          ggplot2::facet_wrap( ~ Symbol, nrow = 3, scales = "fixed") +
          ggplot2::ylab("Frequency") +
          ggplot2::xlab(paste("Daily Returns",
                              min(gf$Date),
                              "to",
                              max(gf$Date),
                              sep = " ")) +
          ggplot2::ggtitle(paste(model_name,
                                 "Basket Element Return Distributions"))

        # component cumulative returns
        cr_df <- data.frame(cr)
        cr_df$Date = zoo::index(cr)

        gf <- cr_df %>%
          tidyr::gather(Symbol, Return, -Date)

        p4 <-
          ggplot2::ggplot(gf,
                          ggplot2::aes(x = Date,
                                       y = Return,
                                       color = Symbol)) +
          ggplot2::geom_line() +
          ggplot2::xlab(NULL) +
          ggplot2::ylab("Component Return") +
          ggplot2::guides(color = FALSE) +
          ggplot2::ggtitle(paste(model_name, "Model Component Cumulative Return"))
        p4 <- directlabels::direct.label(p4)

        # account cumulative return and drawdown
        p5xts <- account_summary$Return
        index(p5xts) <- as.Date(index(p5xts))
        p5 <- suppressWarnings(scorecard:::gg_charts_summary_2(p5xts,
                                  "Account-Level Return and Drawdown"))
        p5 <- p5 +
          guides(color=FALSE) +
          scale_x_date(date_breaks = "1 month",
                       date_minor_breaks = "1 week",
                       date_labels="%b %y")


        # trade stats
        stats <- blotter::tradeStats(port_name)
        stats <- scorecard:::format_trade_stats(stats)

        # model performance ratios
        annual_percent <-
          as.numeric(PerformanceAnalytics::Return.annualized(pm$Actual)) * 100
        calmar_ratio <-
          as.numeric(PerformanceAnalytics::CalmarRatio(pm$Actual))
        sortino_ratio <-
          as.numeric(PerformanceAnalytics::SortinoRatio(pm$Actual, MAR = 0))
        max_drawdown_percent <-
          PerformanceAnalytics::maxDrawdown(pm$Actual) * 100

        # store in scorecard row for later presentation
        scorecard_row$actual <- list(
          r = pr,
          c = cr,
          account = account_summary,
          portfolio = pm,
          cagr = annual_percent,
          mdd = max_drawdown_percent,
          sortino = sortino_ratio,
          calmar = calmar_ratio,
          p1 = p1,
          p2 = p2,
          p3 = p3,
          p4 = p4,
          p5 = p5,
          cplots = cplots,
          stats = stats
        )

        rv <- scorecard_row
      }}

    return(rv)
  }) # lapply

  # compute buy-hold returns for each model, including retired
  scorecard_table <- lapply(scorecard_table, function(scorecard_row) {
    scorecard_row$model <- NA
    model_name <- scorecard_row$id

    if ( !is.null(scorecard_row$config) ) {
      # read the model file
      if ( getOption("verbose") )
        message(paste("Working", model_name, "buy-hold basket comparison"))
      scorecard_row$model <-
        yaml::yaml.load_file(file.path("models",
                                       scorecard_row$config))
      basket <- scorecard_row$model$config$basket

      # save benchmark performance, currently same for each model
      scorecard_row$benchmark.cagr <- benchmark_annual_percent
      scorecard_row$benchmark.calmar <- benchmark_calmar_ratio
      scorecard_row$benchmark.sortino <- benchmark_sortino_ratio
      scorecard_row$benchmark.mdd <- benchmark_max_drawdown_percent

      # initialize quantstrat objects and blotter
      ignore <- scorecard:::reset_quantstrat()
      ignore <- blotter::initPortf("buyhold.port",
                         symbols = basket,
                         initDate = init_date)
      ignore <- blotter::initAcct("buyhold.acct",
                        portfolios = "buyhold.port",
                        initDate = init_date,
                        initEq = init_eq)
      ignore <- sapply(basket, function(m) {
        FinancialInstrument::stock(m, currency = "USD")
      })

      # ensure basket element tickers have been fetched
      ignore <- scorecard:::get_and_adjust(basket,
                               init_date,
                               switch_date,
                               scorecard_tickers,
                               adjust = TRUE)
      scorecard_tickers <<- base::union(scorecard_tickers, basket)

      # add a buy transaction for each ticker at switch date, equal weight
      buyhold_equal_equity <- init_eq / length(basket)
      buyhold_equal_weights <- rep(1.0 / length(basket), length(basket))
      for (ticker in basket) {
        history <- get(ticker)
        price <- as.numeric(quantmod::Cl(history[switch_date, ]))
        quantity <- buyhold_equal_equity / price

        # buy on switch date
        addTxn(
          Portfolio = "buyhold.port",
          Symbol = ticker,
          TxnDate = switch_date,
          TxnPrice = price,
          TxnQty = quantity,
          TxnFees = -4.95,
          verbose = getOption("verbose")
        )

        if ( getOption("verbose") )
          print(paste(ticker,switch_date,price,quantity))
      }

      ignore <- updatePortf("buyhold.port")
      ignore <- blotter::updateAcct("buyhold.acct")
      ignore <- blotter::updateEndEq("buyhold.acct")

      # create buy-hold account plot, save in row
      buyhold.summary <- blotter::getAccount("buyhold.acct")$summary
      bhp1 <- scorecard:::plot_model_stat(
        buyhold.summary$End.Eq,
        paste(model_name, "Buy-Hold Equal-Weight Basket Stats: Ending Equity"
        )
      )

      bhr <- blotter::PortfReturns("buyhold.acct",
                                   Portfolios = "buyhold.port",
                                   period = "daily")
      colnames(bhr) <- gsub(".DailyEndEq", "", colnames(bhr))
      bhc <- cumprod(1 + bhr)

      # append columns for portfolio
      bhp <- bhr
      bhp$BuyHold <- rowSums(bhp, na.rm = TRUE)
      bhp$Cumulative <- cumprod(1 + bhp$BuyHold)

      # basket component cumulative returns
      # bhc.df <- data.frame(bhc) %>%  mutate(Date = index(bhc))
      bhc.df <- data.frame(bhc)
      bhc.df$Date <- zoo::index(bhc)
      gf <- bhc.df %>% gather(Symbol, Return, -Date)
      bhp2 <-
        ggplot2::ggplot(gf, ggplot2::aes(x = Date, y = Return, color = Symbol)) +
        ggplot2::geom_line() +
        ggplot2::xlab(NULL) +
        ggplot2::ylab("Component Return") +
        ggplot2::guides(color = FALSE) +
        ggplot2::ggtitle(paste(model_name,
                               "Buy-Hold Basket Component Cumulative Return"))
      bhp2 <- directlabels::direct.label(bhp2)

      # basket aggregate cumulative return
      bhc.df <- data.frame(bhp$Cumulative)
      bhc.df$Date <- index(bhp$Cumulative)
      bhp3 <-
        ggplot2::ggplot(bhc.df, ggplot2::aes(x = Date, y = Cumulative)) +
        ggplot2::geom_line(color = "blue") +
        ggplot2::xlab(NULL) +
        ggplot2::ylab("Cumulative Return") +
        ggplot2::ggtitle(paste(model_name,
                               "Buy-Hold Equal-Weight Basket Cumulative Return"))

      bh_annual_percent <-
        as.numeric(PerformanceAnalytics::Return.annualized(bhp$BuyHold)) * 100
      bh_calmar_ratio <-
        as.numeric(PerformanceAnalytics::CalmarRatio(bhp$BuyHold))
      bh_sortino_ratio <-
        as.numeric(PerformanceAnalytics::SortinoRatio(bhp$BuyHold,
                                                      MAR = 0))
      bh_max_drawdown_percent <-
        PerformanceAnalytics::maxDrawdown(bhp$BuyHold) * 100

      # store in scorecard
      scorecard_row$buyhold <- list(
        r = bhr,
        c = bhc,
        portfolio = bhp,
        cagr = bh_annual_percent,
        mdd = bh_max_drawdown_percent,
        sortino = bh_sortino_ratio,
        calmar = bh_calmar_ratio,
        p1 = bhp1,
        p2 = bhp2,
        p3 = bhp3
      )

    }
    return(scorecard_row)
  })


  ##########
  # process out-of-sample results for every model
  # re-fetch tickers for all models, ensuring sufficient history
  # fetch start date should be oldest backtest stop date
  backtest_stops <- sapply(scorecard_table, function(sr){
    rv <- NA
    if ( length(sr$model) > 1 ) {
      rv <- sr$model$backtest$stop
    }
    return(rv)
  })

  oos_start_date <- min(c(backtest_stops, date_start), na.rm = TRUE)

  # re-query the tickers including benchmark
  # for ( ticker in base::union(scorecard_tickers, benchmark_symbol) ) {
  #   if ( getOption("verbose") )
  #     message(paste("Fetching", ticker))
  #   dx <- quantmod::getSymbols(
  #     ticker,
  #     from = oos_start_date,
  #     index.class = c("POSIXt", "POSIXct"),
  #     warnings = FALSE,
  #     verbose = getOption("verbose"),
  #     auto.assign = FALSE,
  #     adjust = TRUE
  #   )
  #   if ( any(is.na(dx)))
  #     dx <- zoo::na.approx(dx)
  #   colnames(dx) <- gsub(paste(ticker, ".", sep = ""), "", colnames(dx))
  #   assign(ticker, dx, envir = .GlobalEnv) # put back into global environment
  # }
  scorecard:::get_and_adjust( base::union(scorecard_tickers, benchmark_symbol),
                  init_date= oos_start_date,
                  switch_date = oos_start_date)

  # save a copy of the scorecard basket for reset before each model run
  scorecard_history <- new.env()
  for (ticker in scorecard_tickers) {
    assign(ticker, get(ticker), envir = scorecard_history)
  }

  # now run the non-retired models with data already acquired
  # these will trim individual use of the time series to actual OOS start date
  scorecard_table <- lapply(scorecard_table, function(scorecard_row) {
    model_name <- scorecard_row$id
    rv <- scorecard_row
    if (scorecard_row$status != "retired") {
      if (length(scorecard_row$model) > 1) {
        f <- scorecard_row$model$config[["function"]]
        if (! is.null(f)) {
          if (stringr::str_length(f) > 0) {
            if (getOption("verbose"))
              message(paste("Processing out-of-sample results for", model_name))
            update_model <- match.fun(f) # may throw an error
            for (ticker in scorecard_tickers) {
              assign(ticker,
                     get(ticker,
                         envir = scorecard_history),
                     envir = .GlobalEnv)
            }
            if (getOption("verbose"))
              message(scorecard_row$config)
            rv <- update_model(scorecard_row)
          }
        }
      }
    }

    return(rv)
  })

  ########
  # Content completed, ready to process scorecard output
  # Save workspace for reference, audting, debugging
  if ( getOption("verbose"))
    message("Saving workspace...")
  if ( ! dir.exists(scorecard_dir) ) {
    dir.create(scorecard_dir,
               showWarnings = getOption("verbose"),
               recursive = TRUE)
    warning(paste("Scorecard output directory created:",
                  scorecard_dir))
  }
  image_date <- format(lubridate::today("America/Chicago"), "%Y%m%d")
  image_file <- file.path(scorecard_dir,
                          paste0(image_date,
                                 "_",
                                 "scorecard",
                                 "_",
                                 "workspace",
                                 ".RData"))

  save(
    scorecard_table,
    model_files,
    init_date,
    image_date,
    refresh_date,
    oos_start_date,
    transactions.df,
    file=image_file
  )
  if (getOption("verbose"))
    message(paste0("Saved workspace to", image_file))

  #######
  # All done preparing data, reduce and produce elsewhere
  if (getOption("verbose"))
    message("Scorecard data preparation complete")

}